diff options
363 files changed, 3008 insertions, 2746 deletions
@@ -39,7 +39,8 @@ Julien Forest <julien.forest@ensiie.fr> jforest <jforest@thune> Julien Forest <julien.forest@ensiie.fr> jforest <jforest@daneel.lan.home> Julien Forest <julien.forest@ensiie.fr> Julien Forest <forest@ensiie.fr> Emilio Jesus Gallego Arias <e+git@x80.org> Emilio Jesús Gallego Arias <e+git@x80.org> -Gaëtan Gilbert <gaetan.gilbert@ens-lyon.fr> Gaetan Gilbert <gaetan.gilbert@ens-lyon.fr> +Gaëtan Gilbert <gaetan.gilbert@skyskimmer.net> <gaetan.gilbert@ens-lyon.fr> +Gaëtan Gilbert <gaetan.gilbert@skyskimmer.net> <gaetan.gilbert@skyskimmer.net> Stéphane Glondu <steph@glondu.net> glondu <glondu@85f007b7-540e-0410-9357-904b9bb8a0f7> Stéphane Glondu <steph@glondu.net> Stephane Glondu <steph@glondu.net> Benjamin Grégoire <benjamin.gregoire@inria.fr> Benjamin Gregoire <Benjamin.Gregoire@inria.fr> diff --git a/API/API.ml b/API/API.ml index c4bcef6f6c..68da858ba0 100644 --- a/API/API.ml +++ b/API/API.ml @@ -10,9 +10,9 @@ To see such order issue the comand: -``` -bash -c 'for i in kernel intf library engine pretyping interp proofs parsing printing tactics vernac stm toplevel; do echo -e "\n## $i files" && cat ${i}/${i}.mllib; done && echo -e "\n## highparsing files" && cat parsing/highparsing.mllib' > API/link -``` + ``` + bash -c 'for i in kernel intf library engine pretyping interp proofs parsing printing tactics vernac stm toplevel; do echo -e "\n## $i files" && cat ${i}/${i}.mllib; done > API/link + ``` *) (******************************************************************************) @@ -223,6 +223,9 @@ module Pcoq = Pcoq module Egramml = Egramml (* Egramcoq *) +module G_vernac = G_vernac +module G_proofs = G_proofs + (******************************************************************************) (* Tactics *) (******************************************************************************) @@ -276,9 +279,3 @@ module Vernacentries = Vernacentries (******************************************************************************) module Vernac_classifier = Vernac_classifier module Stm = Stm - -(******************************************************************************) -(* Highparsing *) -(******************************************************************************) -module G_vernac = G_vernac -module G_proofs = G_proofs diff --git a/API/API.mli b/API/API.mli index d1774afe54..901ed3528b 100644 --- a/API/API.mli +++ b/API/API.mli @@ -10,7 +10,7 @@ in Coq. To see such order issue the comand: ``` - bash -c 'for i in kernel intf library engine pretyping interp proofs parsing printing tactics vernac stm toplevel; do echo -e "\n## $i files" && cat ${i}/${i}.mllib; done && echo -e "\n## highparsing files" && cat parsing/highparsing.mllib' > API/link + bash -c 'for i in kernel intf library engine pretyping interp proofs parsing printing tactics vernac stm toplevel; do echo -e "\n## $i files" && cat ${i}/${i}.mllib; done > API/link ``` Note however that files in intf/ are located manually now as their @@ -1280,23 +1280,28 @@ sig | Algebraic of module_expression | Struct of module_signature | FullStruct - and module_body = + and 'a generic_module_body = { mod_mp : Names.ModPath.t; - mod_expr : module_implementation; + mod_expr : 'a; mod_type : module_signature; mod_type_alg : module_expression option; mod_constraints : Univ.ContextSet.t; mod_delta : Mod_subst.delta_resolver; - mod_retroknowledge : Retroknowledge.action list + mod_retroknowledge : 'a module_retroknowledge; } and module_signature = (module_type_body,structure_body) functorize - and module_type_body = module_body + and module_body = module_implementation generic_module_body + and module_type_body = unit generic_module_body and structure_body = (Names.Label.t * structure_field_body) list and structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body | SFBmodtype of module_type_body + and _ module_retroknowledge = + | ModBodyRK : + Retroknowledge.action list -> module_implementation module_retroknowledge + | ModTypeRK : unit module_retroknowledge end module Declareops : @@ -2107,6 +2112,7 @@ sig val coq_not_ref : Globnames.global_reference lazy_t val coq_or_ref : Globnames.global_reference lazy_t val build_coq_and : Globnames.global_reference Util.delayed + val build_coq_or : Globnames.global_reference Util.delayed val build_coq_I : Globnames.global_reference Util.delayed val coq_reference : string -> string list -> string -> Globnames.global_reference end @@ -2757,6 +2763,7 @@ sig val pr_evar_info : Evd.evar_info -> Pp.t val print_constr : EConstr.constr -> Pp.t + val pr_sort_family : Sorts.family -> Pp.t (** [dependent m t] tests whether [m] is a subterm of [t] *) val dependent : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool @@ -2804,6 +2811,8 @@ sig val print_constr_env : Environ.env -> Evd.evar_map -> EConstr.constr -> Pp.t val clear_named_body : Names.Id.t -> Environ.env -> Environ.env val is_Prop : Evd.evar_map -> EConstr.constr -> bool + val is_Set : Evd.evar_map -> EConstr.constr -> bool + val is_Type : Evd.evar_map -> EConstr.constr -> bool val is_global : Evd.evar_map -> Globnames.global_reference -> EConstr.constr -> bool val eq_constr : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool @@ -3072,55 +3081,67 @@ end (* XXX: Located manually from intf *) module Glob_term : sig - type cases_pattern_r = + type 'a cases_pattern_r = | PatVar of Names.Name.t - | PatCstr of Names.constructor * cases_pattern list * Names.Name.t - and cases_pattern = cases_pattern_r CAst.t + | PatCstr of Names.constructor * 'a cases_pattern_g list * Names.Name.t + and 'a cases_pattern_g = ('a cases_pattern_r, 'a) DAst.t + type cases_pattern = [ `any ] cases_pattern_g type existential_name = Names.Id.t - type glob_constr_r = + type 'a glob_constr_r = | GRef of Globnames.global_reference * Misctypes.glob_level list option (** An identifier that represents a reference to an object defined either in the (global) environment or in the (local) context. *) | GVar of Names.Id.t (** An identifier that cannot be regarded as "GRef". Bound variables are typically represented this way. *) - | GEvar of existential_name * (Names.Id.t * glob_constr) list + | GEvar of existential_name * (Names.Id.t * 'a glob_constr_g) list | GPatVar of Evar_kinds.matching_var_kind - | GApp of glob_constr * glob_constr list - | GLambda of Names.Name.t * Decl_kinds.binding_kind * glob_constr * glob_constr - | GProd of Names.Name.t * Decl_kinds.binding_kind * glob_constr * glob_constr - | GLetIn of Names.Name.t * glob_constr * glob_constr option * glob_constr - | GCases of Term.case_style * glob_constr option * tomatch_tuples * cases_clauses - | GLetTuple of Names.Name.t list * (Names.Name.t * glob_constr option) * glob_constr * glob_constr - | GIf of glob_constr * (Names.Name.t * glob_constr option) * glob_constr * glob_constr - | GRec of fix_kind * Names.Id.t array * glob_decl list array * - glob_constr array * glob_constr array + | GApp of 'a glob_constr_g * 'a glob_constr_g list + | 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 + | 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 * + 'a glob_constr_g array * 'a glob_constr_g array | GSort of Misctypes.glob_sort | GHole of Evar_kinds.t * Misctypes.intro_pattern_naming_expr * Genarg.glob_generic_argument option - | GCast of glob_constr * glob_constr Misctypes.cast_type + | GCast of 'a glob_constr_g * 'a glob_constr_g Misctypes.cast_type - and glob_constr = glob_constr_r CAst.t + and 'a glob_constr_g = ('a glob_constr_r, 'a) DAst.t - and glob_decl = Names.Name.t * Decl_kinds.binding_kind * glob_constr option * glob_constr + and 'a glob_decl_g = Names.Name.t * Decl_kinds.binding_kind * 'a glob_constr_g option * 'a glob_constr_g - and fix_recursion_order = + and 'a fix_recursion_order_g = | GStructRec - | GWfRec of glob_constr - | GMeasureRec of glob_constr * glob_constr option + | GWfRec of 'a glob_constr_g + | GMeasureRec of 'a glob_constr_g * 'a glob_constr_g option - and fix_kind = - | GFix of ((int option * fix_recursion_order) array * int) + and 'a fix_kind_g = + | GFix of ((int option * 'a fix_recursion_order_g) array * int) | GCoFix of int - and predicate_pattern = + and 'a predicate_pattern_g = Names.Name.t * (Names.inductive * Names.Name.t list) Loc.located option - and tomatch_tuple = (glob_constr * predicate_pattern) + and 'a tomatch_tuple_g = ('a glob_constr_g * 'a predicate_pattern_g) - and tomatch_tuples = tomatch_tuple list + and 'a tomatch_tuples_g = 'a tomatch_tuple_g list - and cases_clause = (Names.Id.t list * cases_pattern list * glob_constr) Loc.located - and cases_clauses = cases_clause list + and 'a cases_clause_g = (Names.Id.t list * 'a cases_pattern_g list * 'a glob_constr_g) Loc.located + and 'a cases_clauses_g = 'a cases_clause_g list + + type glob_constr = [ `any ] glob_constr_g + type tomatch_tuple = [ `any ] tomatch_tuple_g + type tomatch_tuples = [ `any ] tomatch_tuples_g + type cases_clause = [ `any ] cases_clause_g + type cases_clauses = [ `any ] cases_clauses_g + type glob_decl = [ `any ] glob_decl_g + type fix_kind = [ `any ] fix_kind_g + type predicate_pattern = [ `any ] predicate_pattern_g + type any_glob_constr = + | AnyGlobConstr : 'r glob_constr_g -> any_glob_constr (** A globalised term together with a closure representing the value of its free variables. Intended for use when these variables are taken @@ -3799,7 +3820,7 @@ sig | VernacTimeout of int * vernac_expr | VernacFail of vernac_expr | VernacSyntaxExtension of - obsolete_locality * (lstring * syntax_modifier list) + bool * obsolete_locality * (lstring * syntax_modifier list) | VernacOpenCloseScope of obsolete_locality * (bool * scope_name) | VernacDelimiters of scope_name * string option | VernacBindScope of scope_name * class_rawexpr list @@ -3980,11 +4001,14 @@ end module Detyping : sig + type 'a delay = + | Now : 'a delay + | Later : [ `thunk ] delay val print_universes : bool ref val print_evar_arguments : bool ref - val detype : ?lax:bool -> bool -> Names.Id.t list -> Environ.env -> Evd.evar_map -> EConstr.constr -> Glob_term.glob_constr + val detype : 'a delay -> ?lax:bool -> bool -> Names.Id.t list -> Environ.env -> Evd.evar_map -> EConstr.constr -> 'a Glob_term.glob_constr_g val subst_glob_constr : Mod_subst.substitution -> Glob_term.glob_constr -> Glob_term.glob_constr - val set_detype_anonymous : (?loc:Loc.t -> int -> Glob_term.glob_constr) -> unit + val set_detype_anonymous : (?loc:Loc.t -> int -> Names.Id.t) -> unit end module Indrec : @@ -4025,7 +4049,6 @@ sig val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> Environ.env -> Evd.evar_map -> Glob_term.glob_constr -> Constr.t Evd.in_evar_universe_context val check_evars : Environ.env -> Evd.evar_map -> Evd.evar_map -> EConstr.constr -> unit - val interp_elimination_sort : Misctypes.glob_sort -> Sorts.family val register_constr_interp0 : ('r, 'g, 't) Genarg.genarg_type -> (Glob_term.unbound_ltac_var_map -> Environ.env -> Evd.evar_map -> EConstr.types -> 'g -> EConstr.constr * Evd.evar_map) -> unit @@ -4121,6 +4144,7 @@ sig val wit_global : (Libnames.reference, Globnames.global_reference Loc.located Misctypes.or_var, Globnames.global_reference) Genarg.genarg_type val wit_ident : Names.Id.t Genarg.uniform_genarg_type val wit_integer : int Genarg.uniform_genarg_type + val wit_sort_family : (Sorts.family, unit, unit) Genarg.genarg_type val wit_constr : (Constrexpr.constr_expr, Tactypes.glob_constr_and_expr, EConstr.constr) Genarg.genarg_type val wit_open_constr : (Constrexpr.constr_expr, Tactypes.glob_constr_and_expr, EConstr.constr) Genarg.genarg_type val wit_intro_pattern : (Constrexpr.constr_expr Misctypes.intro_pattern_expr Loc.located, Tactypes.glob_constr_and_expr Misctypes.intro_pattern_expr Loc.located, Tactypes.intro_pattern) Genarg.genarg_type @@ -4181,7 +4205,7 @@ sig type cases_pattern_status = bool type required_module = Libnames.full_path * string list type 'a prim_token_interpreter = ?loc:Loc.t -> 'a -> Glob_term.glob_constr - type 'a prim_token_uninterpreter = Glob_term.glob_constr list * (Glob_term.glob_constr -> 'a option) * cases_pattern_status + type 'a prim_token_uninterpreter = Glob_term.glob_constr list * (Glob_term.any_glob_constr -> 'a option) * cases_pattern_status type delimiters = string type local_scopes = Notation_term.tmp_scope_name option * Notation_term.scope_name list type notation_location = (Names.DirPath.t * Names.DirPath.t) * string @@ -4682,7 +4706,7 @@ sig type coq_parsable - val parsable : ?file:string -> char Stream.t -> coq_parsable + val parsable : ?file:Loc.source -> char Stream.t -> coq_parsable val action : 'a -> action val entry_create : string -> 'a entry val entry_parse : 'a entry -> coq_parsable -> 'a @@ -4752,6 +4776,7 @@ sig val global : reference Gram.entry val universe_level : glob_level Gram.entry val sort : glob_sort Gram.entry + val sort_family : Sorts.family Gram.entry val pattern : cases_pattern_expr Gram.entry val constr_pattern : constr_expr Gram.entry val lconstr_pattern : constr_expr Gram.entry @@ -4828,6 +4853,23 @@ sig end +module G_vernac : +sig + + val def_body : Vernacexpr.definition_expr Pcoq.Gram.entry + val section_subset_expr : Vernacexpr.section_subset_expr Pcoq.Gram.entry + val query_command : (Vernacexpr.goal_selector option -> Vernacexpr.vernac_expr) Pcoq.Gram.entry + +end + +module G_proofs : +sig + + val hint : Vernacexpr.hints_expr Pcoq.Gram.entry + val hint_proof_using : 'a Pcoq.Gram.entry -> 'a option -> 'a option + +end + (************************************************************************) (* End of modules from parsing/ *) (************************************************************************) @@ -5312,7 +5354,7 @@ sig val lemInv_clause : Misctypes.quantified_hypothesis -> EConstr.constr -> Names.Id.t list -> unit Proofview.tactic val add_inversion_lemma_exn : - Names.Id.t -> Constrexpr.constr_expr -> Misctypes.glob_sort -> bool -> (Names.Id.t -> unit Proofview.tactic) -> + Names.Id.t -> Constrexpr.constr_expr -> Sorts.family -> bool -> (Names.Id.t -> unit Proofview.tactic) -> unit end @@ -5717,28 +5759,3 @@ end (************************************************************************) (* End of modules from stm/ *) (************************************************************************) - -(************************************************************************) -(* Modules from highparsing/ *) -(************************************************************************) - -module G_vernac : -sig - - val def_body : Vernacexpr.definition_expr Pcoq.Gram.entry - val section_subset_expr : Vernacexpr.section_subset_expr Pcoq.Gram.entry - val query_command : (Vernacexpr.goal_selector option -> Vernacexpr.vernac_expr) Pcoq.Gram.entry - -end - -module G_proofs : -sig - - val hint : Vernacexpr.hints_expr Pcoq.Gram.entry - val hint_proof_using : 'a Pcoq.Gram.entry -> 'a option -> 'a option - -end - -(************************************************************************) -(* End of modules from highparsing/ *) -(************************************************************************) @@ -6,8 +6,23 @@ Notations - Recursive notations with the recursive pattern repeating on the right (e.g. "( x ; .. ; y ; z )") now supported. -Changes from 8.6.1 to 8.7+beta -============================== +Tactics + +- On Linux, "native_compute" calls can be profiled using the "perf" + utility. The command "Set NativeCompute Profiling" enables + profiling, and "Set NativeCompute Profile Filename" customizes + the profile filename. + +Changes from 8.7+beta1 to 8.7.0 +=============================== + +Tools + +- In CoqIDE, the "Compile Buffer" command takes account of flags in + _CoqProject or other project file. + +Changes from 8.6.1 to 8.7+beta1 +=============================== Tactics @@ -63,10 +78,6 @@ Tactics Ltac definition or a Tactic Notation. - New option `Set Ltac Batch Debug` on top of `Set Ltac Debug` for non-interactive Ltac debug output. -- On Linux, "native_compute" calls can be profiled using the "perf" - utility. The command "Set NativeCompute Profiling" enables - profiling, and "Set NativeCompute Profile Filename" customizes - the profile filename. Gallina diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 05f21895eb..c935b6b140 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -26,7 +26,7 @@ Documentation for getting started with the Coq sources is located in various fil Please make pull requests against the `master` branch. -It's helpful to run the Coq test suite with `make test-suite` before submitting your change. Travis CI runs this test suite and a much larger one including external Coq developments on every pull request, but these results take significantly longer to come back (on the order of a few hours). Running the test suite locally will take somewhere around 10-15 minutes. +It's helpful to run the Coq test suite with `make test-suite` before submitting your change. Travis CI runs this test suite and a much larger one including external Coq developments on every pull request, but these results take significantly longer to come back (on the order of a few hours). Running the test suite locally will take somewhere around 10-15 minutes. Refer to [`dev/ci/README.md`](/dev/ci/README.md#information-for-developers) for more information on Travis CI tests. Don't be alarmed if the pull request process takes some time. It can take a few days to get feedback, approval on the final changes, and then a merge. Coq doesn't release new versions very frequently so it can take a few months for your change to land in a released version. That said, you can start using the latest Coq `master` branch to take advantage of all the new features, improvements, and fixes. @@ -50,6 +50,8 @@ There are many useful ways to contribute to the Coq ecosystem that don't involve Tutorials to teach Coq, and especially to teach particular advanced features, would be much appreciated. Some tutorials are listed on the [Coq website](https://coq.inria.fr/documentation). If you would like to add a link to this list, please make a pull request against the Coq website repository at https://github.com/coq/www. +External plugins / libraries contribute to create a successful ecosystem around Coq. If your external development is mature enough, you may consider submitting it for addition to our CI tests. Refer to [`dev/ci/README.md`](/dev/ci/README.md) for more information. + Ask and answer questions on [Stack Exchange](https://stackexchange.com/filters/299857/questions-tagged-coq-on-stackexchange-sites) which has a helpful community of Coq users. Hang out on the Coq IRC channel, `irc://irc.freenode.net/#coq`, and help answer questions. @@ -7,7 +7,10 @@ The "Coq proof assistant" was jointly developed by associated to CNRS and university Paris Sud (since Sep. 1997), - Laboratoire d'Informatique de l'Ecole Polytechnique (LIX) associated to CNRS and Ecole Polytechnique (since Jan. 2003). -- Laboratoire PPS associated to CNRS and university Paris 7 (since Jan. 2009). +- Laboratoire PPS associated to CNRS and University Paris Diderot + (Jan. 2009 - Dec. 2015). +- Institut de Recherche en Informatique Fondamentale (IRIF), + associated to CNRS and University Paris Diderot (since Jan. 2016). All files of the "Coq proof assistant" in directories or sub-directories of @@ -15,8 +18,8 @@ All files of the "Coq proof assistant" in directories or sub-directories of scripts states tactics test-suite theories tools toplevel are distributed under the terms of the GNU Lesser General Public License -Version 2.1 (see file LICENSE). These files are COPYRIGHT 1999-2010, -The Coq development team, CNRS, INRIA and Université Paris Sud. +Version 2.1 (see file LICENSE). These files are COPYRIGHT 1999-2017, +The Coq development team, INRIA, CNRS, LIX, LRI, PPS. Files from the directory doc are distributed as indicated in file doc/LICENCE. @@ -37,8 +40,8 @@ plugins/firstorder plugins/fourier developed by Loïc Pottier (INRIA-Lemme, 2001) plugins/funind - developed by Pierre Courtieu (INRIA-Lemme, 2003-2004, CNAM, 2004-2008), - Julien Forest (INRIA-Everest, 2006, CNAM, 2007-2008) + developed by Pierre Courtieu (INRIA-Lemme, 2003-2004, CNAM, 2006-now), + Julien Forest (INRIA-Everest, 2006, CNAM, 2007-2008, ENSIIE, 2008-now) and Yves Bertot (INRIA-Marelle, 2005-2006) plugins/omega developed by Pierre Crégut (France Telecom R&D, 1996) @@ -60,7 +63,7 @@ plugins/ssrmatching plugins/subtac developed by Matthieu Sozeau (LRI, 2005-2008) plugins/micromega - developed by Frédéric Besson (IRISA/INRIA, 2006-2008), with some + developed by Frédéric Besson (IRISA/INRIA, 2006-now), with some extensions by Evgeny Makarov (INRIA, 2007); sum-of-squares solver and interface to the csdp solver uses code from John Harrison (University of Cambridge, 1998) @@ -94,32 +97,41 @@ of the Coq Proof assistant during the indicated time: Bruno Barras (INRIA, 1995-now) Yves Bertot (INRIA, 2000-now) - Pierre Boutillier (INRIA-PPS, 2010-now) + Pierre Boutillier (INRIA-PPS, 2010-2015) Xavier Clerc (INRIA, 2012-2014) + Tej Chajed (MIT, 2016-now) Jacek Chrzaszcz (LRI, 1998-2003) Thierry Coquand (INRIA, 1985-1989) Pierre Corbineau (LRI, 2003-2005, Nijmegen, 2005-2008, Grenoble 1, 2008-2011) Cristina Cornes (INRIA, 1993-1996) Yann Coscoy (INRIA Sophia-Antipolis, 1995-1996) + Pierre Courtieu (CNAM, 2006-now) David Delahaye (INRIA, 1997-2002) Maxime Dénès (INRIA, 2013-now) - Daniel de Rauglaudre (INRIA, 1996-1998) + Daniel de Rauglaudre (INRIA, 1996-1998, 2012, 2016) Olivier Desmettre (INRIA, 2001-2003) Gilles Dowek (INRIA, 1991-1994) Amy Felty (INRIA, 1993) Jean-Christophe Filliâtre (ENS Lyon, 1994-1997, LRI, 1997-2008) + Emilio Jesús Gallego Arias (MINES ParisTech 2015-now) + Gaetan Gilbert (INRIA-CoqHoTT 2016-now) Eduardo Giménez (ENS Lyon, 1993-1996, INRIA, 1997-1998) Stéphane Glondu (INRIA-PPS, 2007-2013) Benjamin Grégoire (INRIA, 2003-2011) + Jason Gross (MIT 2013-now) Hugo Herbelin (INRIA, 1996-now) Sébastien Hinderer (INRIA, 2014) Gérard Huet (INRIA, 1985-1997) + Matej Košík (INRIA, 2015-2017) Pierre Letouzey (LRI, 2000-2004, PPS, 2005-2008, INRIA-PPS, 2009-now) Patrick Loiseleur (Paris Sud, 1997-1999) Evgeny Makarov (INRIA, 2007) + Gregory Malecha (Harvard University 2013-2015, + University of California, San Diego 2016) + Cyprien Mangin (INRIA-IRIF, 2015-now) Pascal Manoury (INRIA, 1993) - Micaela Mayero (INRIA, 1997-2002) Claude Marché (INRIA, 2003-2004 & LRI, 2004) + Micaela Mayero (INRIA, 1997-2002) Guillaume Melquiond (INRIA, 2009-now) Benjamin Monate (LRI, 2003) César Muñoz (INRIA, 1994-1995) @@ -129,7 +141,8 @@ of the Coq Proof assistant during the indicated time: Catherine Parent-Vigouroux (ENS Lyon, 1992-1995) Christine Paulin-Mohring (INRIA, 1985-1989, ENS Lyon, 1989-1997, LRI, 1997-2006) - Pierre-Marie Pédrot (INRIA-PPS, 2011-now) + Pierre-Marie Pédrot (INRIA-PPS, 2011-2015, INRIA-CoqHoTT 2015-2016, + University of Ljubljana 2016-2017) Matthias Puech (INRIA-Bologna, 2008-2011) Yann Régis-Gianas (INRIA-PPS, 2009-now) Clément Renard (INRIA, 2001-2004) @@ -138,9 +151,15 @@ of the Coq Proof assistant during the indicated time: Vincent Siles (INRIA, 2007) Élie Soubiran (INRIA, 2007-2010) Matthieu Sozeau (INRIA, 2005-now) - Arnaud Spiwack (INRIA, 2006-now) + Arnaud Spiwack (INRIA-LIX-Chalmers University, 2006-2010, + INRIA, 2011-2014, MINES ParisTech 2014-2015, + Tweag/IO 2015-now) + Paul Steckler (MIT 2016-now) Enrico Tassi (INRIA, 2011-now) + Amin Timany (Katholieke Universiteit Leuven, 2017) Benjamin Werner (INRIA, 1989-1994) + Nickolai Zeldovich (MIT 2014-2016) + Théo Zimmermann (INRIA-IRIF, 2015-now) *************************************************************************** INRIA refers to: @@ -228,6 +228,32 @@ package "stm" ( ) +package "API" ( + + description = "Coq API" + version = "8.7" + + requires = "coq.stm" + directory = "API" + + archive(byte) = "API.cma" + archive(native) = "API.cmxa" + +) + +package "ltac" ( + + description = "Coq LTAC Plugin" + version = "8.7" + + requires = "coq.API" + directory = "plugins/ltac" + + archive(byte) = "ltac_plugin.cmo" + archive(native) = "ltac_plugin.cmx" + +) + package "toplevel" ( description = "Coq Toplevel" @@ -254,6 +280,7 @@ package "idetop" ( ) +# XXX Depends on way less than toplevel package "ide" ( description = "Coq IDE Libraries" @@ -267,44 +294,3 @@ package "ide" ( archive(native) = "ide.cmxa" ) - -# XXX: Remove the dependency on toplevel (due to Coqinit use for compat flags) -package "highparsing" ( - - description = "Coq Extra Parsing" - version = "8.7" - - requires = "coq.toplevel" - directory = "parsing" - - archive(byte) = "highparsing.cma" - archive(native) = "highparsing.cmxa" - -) - -# XXX: API should depend only on stm. -package "API" ( - - description = "Coq API" - version = "8.7" - - requires = "coq.highparsing" - directory = "API" - - archive(byte) = "API.cma" - archive(native) = "API.cmxa" - -) - -package "ltac" ( - - description = "Coq LTAC Plugin" - version = "8.7" - - requires = "coq.API" - directory = "plugins/ltac" - - archive(byte) = "ltac_plugin.cmo" - archive(native) = "ltac_plugin.cmx" - -) diff --git a/Makefile.ci b/Makefile.ci index 744b7c6550..b5a26d96e8 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -24,9 +24,4 @@ CI_TARGETS=ci-all \ # Generic rule, we use make to ease travis integration with mixed rules $(CI_TARGETS): ci-%: - rm -f ci-$*.ok - +(./dev/ci/ci-$*.sh 2>&1 && touch ci-$*.ok) | tee time-of-build.log - echo 'Aggregating timing log...' && echo -en 'travis_fold:start:coq.test.timing\\r' - python ./tools/make-one-time-file.py time-of-build.log - echo -en 'travis_fold:end:coq.test.timing\\r' - rm ci-$*.ok # must not be -f; we're checking to see that it exists + +./dev/ci/ci-wrapper.sh ci-$*.sh diff --git a/Makefile.common b/Makefile.common index ccbe9261ef..4d63b08e2b 100644 --- a/Makefile.common +++ b/Makefile.common @@ -105,7 +105,7 @@ BYTERUN:=$(addprefix kernel/byterun/, \ CORECMA:=lib/clib.cma lib/lib.cma kernel/kernel.cma intf/intf.cma library/library.cma \ engine/engine.cma pretyping/pretyping.cma interp/interp.cma proofs/proofs.cma \ parsing/parsing.cma printing/printing.cma tactics/tactics.cma vernac/vernac.cma \ - parsing/highparsing.cma stm/stm.cma toplevel/toplevel.cma API/API.cma + stm/stm.cma toplevel/toplevel.cma API/API.cma TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.cma diff --git a/Makefile.dev b/Makefile.dev index b0299bd160..dc4ded3977 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -116,12 +116,11 @@ tactics: tactics/tactics.cma interp: interp/interp.cma parsing: parsing/parsing.cma pretyping: pretyping/pretyping.cma -highparsing: parsing/highparsing.cma stm: stm/stm.cma toplevel: toplevel/toplevel.cma .PHONY: lib kernel byterun library proofs tactics interp parsing pretyping API -.PHONY: engine highparsing stm toplevel +.PHONY: engine stm toplevel ###################### ### 3) theories files diff --git a/Makefile.doc b/Makefile.doc index bc5dfa3917..0c3b701497 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -469,7 +469,7 @@ OCAMLDOC_MLLIBD = $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) - ml-doc: $(OCAMLFIND) ocamldoc -charset utf-8 -html -rectypes -I +threads $(MLINCLUDES) $(COQIDEFLAGS) -d $(OCAMLDOCDIR) $(MLSTATICFILES) -parsing/parsing.dot : | parsing/parsing.mllib.d parsing/highparsing.mllib.d +parsing/parsing.dot : | parsing/parsing.mllib.d $(OCAMLDOC_MLLIBD) grammar/grammar.dot : | grammar/grammar.mllib.d diff --git a/Makefile.install b/Makefile.install index 85ffc93d51..4800f8f3fa 100644 --- a/Makefile.install +++ b/Makefile.install @@ -87,7 +87,6 @@ install-tools: $(MKDIR) $(FULLBINDIR) # recopie des fichiers de style pour coqide $(MKDIR) $(FULLCOQLIB)/tools/coqdoc - touch $(FULLCOQLIB)/tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc/coqdoc.css # to have the mode according to umask (bug #1715) $(INSTALLLIB) tools/coqdoc/coqdoc.css tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc $(INSTALLBIN) $(TOOLS) $(FULLBINDIR) diff --git a/README.ci.md b/README.ci.md deleted file mode 100644 index cf9da50941..0000000000 --- a/README.ci.md +++ /dev/null @@ -1,116 +0,0 @@ -**WARNING:** This document is a work in progress and intended as a RFC. -If you are not a Coq Developer, don't follow these instructions yet. - -Introduction -============ - -As of 2017, Coq's Git repository includes a `.travis.yml` file, a -`.gitlab-ci.yml` file, and supporting scripts, that enable lightweight -Continuous Integration (CI) tests to be run on clones of that repository stored -at Github or on a GitLab instance, respectively. This affords two benefits. - -First, it allows developers working on Coq itself to perform CI on their own -Git remotes, thereby enabling them to catch and fix problems with their -proposed changes before submitting pull requests to Coq itself. This in turn -reduces the risk of a faulty PR being opened against the official Coq -repository. - -Secondly, it allows developers working on a library dependent on Coq to have -that library included in the Travis CI tests invoked by the official Coq -repository on GitHub. - -(More comprehensive testing than is provided by the Travis CI and GitLab CI -integration is the responsibility of Coq's [Jenkins CI -server](https://ci.inria.fr/coq/) see, [XXX: add document] for instructions on -how to add your development to Jenkins.) - -How to submit your library for inclusion in Coq's Travis CI builds -================================================================== - -CI provides a convenient way to perform testing of Coq changes -versus a set of curated libraries. - -Are you an author of a Coq library who would be interested in having -the latest Coq changes validated against it? - -If so, all you need to do is: - -1. Put your library in a public repository tracking the `master` - branch of Coq's Git repository. -2. Make sure that your development builds in less than 35 minutes. -3. Submit a PR adding your development. -4. ? -5. Profit! Your library is now part of Coq's continous integration! - -Note that by partipating in this program, you assume a reasonable -compromise to discuss and eventually integrate compatibility changes -upstream. - -Get in touch with us to discuss any special need your development may -have. - -Maintaining your contribution manually [current method] -====================================== - -To add your contribution to the Coq CI set, add a script for building -your library to `dev/ci/`, update `.travis.yml`, `.gitlab-ci.yml` and -`Makefile.ci`. Then, submit a PR. - -Maintaining your contribution as an OPAM package [work in progress] [to be implemented] -================================================ - -You can also provide an opam package for your contribution XXX at -https://github.com/coq/opam-coq-archive - -Then, add a `ci-opam-XXX` target to the `.travis.yml` file, the -package XXX.dev will be tested against each Coq commit and pull -request. - -- TODO: The main question here is what to do with `.opam` caching. We - could disable it altogether, however this will have an impact. We - could install a dummy Coq package, but `coq-*` dependencies will be - botched too. Need to think more. - -PR Overlays [work in progress] [to be implemented] -=========== - -It is common for PR to break some of the external tests. To this -purpose, we provide a method for particular PR to overlay the -repositories of some of the tests so they can provide fixed -developments. - -The general idea is that the PR author will drop a file -`dev/ci/overlays/$branch.overlay` where branch name is taken from -`${TRAVIS_PULL_REQUEST_BRANCH:-$TRAVIS_BRANCH}` -that is to say, the name of the original branch for the PR. - -The `.overlay` file will contain a set of variables that will be used -to do the corresponding `opam pin` or to overload the corresponding -git repositories, etc... - -Since pull requests only happen on GitHub there is no need to test the -corresponding GitLab CI variables. - -Travis specific information -=========================== - -Travis rebuilds all of Coq's executables and stdlib for each job. Coq -is built with `./configure -local`, then used for the job's test. - -GitLab specific information -=========================== - -GitLab is set up to use the "build artifact" feature to avoid -rebuilding Coq. In one job, Coq is built with `./configure -prefix -install` and `make install` is run, then the `install` directory -persists to and is used by the next jobs. - -Artifacts can also be downloaded from the GitLab repository. -Currently, available artifacts are: -- the Coq executables and stdlib, in three copies varying in - architecture and Ocaml version used to build Coq. -- the Coq documentation, in two different copies varying in the OCaml - version used to build Coq - -As an exception to the above, jobs testing that compilation triggers -no Ocaml warnings build Coq in parallel with other tests. diff --git a/appveyor.yml b/appveyor.yml index fb5a445848..64c1bedb54 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -8,20 +8,24 @@ image: - Visual Studio 2017 environment: - CYGROOT: C:\cygwin64 CYGMIRROR: http://ftp.inf.tu-dresden.de/software/windows/cygwin32 - CYGCACHE: C:\cygwin64\var\cache\setup - opam_url: https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.1/opam64.tar.xz - -install: -- cmd: '%CYGROOT%\setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s - %CYGMIRROR% -P rsync -P patch -P diffutils -P curl -P make -P unzip -P git -p m4 - -P perl -P findutils -P time' -- cmd: '%CYGROOT%/bin/bash -l %APPVEYOR_BUILD_FOLDER%/dev/build/windows/appveyor.sh' + matrix: + - USEOPAM: true + ARCH: 64 + - USEOPAM: false + ARCH: 32 + - USEOPAM: false + ARCH: 64 build_script: -- cmd: '%CYGROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && ./configure -local && make"' +- cmd: 'call %APPVEYOR_BUILD_FOLDER%\dev\ci\appveyor.bat' + +test: off + +artifacts: + - path: 'dev\nsis\*.exe' + name: installer + + - path: 'coq-opensource-archive-*.zip' + name: opensource-archive -test_script: -- cmd: '%CYGROOT%/bin/bash -lc "cd $APPVEYOR_BUILD_FOLDER && make -C test-suite all - INTERACTIVE= && make validate"' diff --git a/checker/cic.mli b/checker/cic.mli index 59dd5bc4d3..753fd0fc00 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -385,9 +385,9 @@ and module_implementation = | Struct of module_signature (** interactive body *) | FullStruct (** special case of [Struct] : the body is exactly [mod_type] *) -and module_body = +and 'a generic_module_body = { mod_mp : module_path; (** absolute path of the module *) - mod_expr : module_implementation; (** implementation *) + mod_expr : 'a; (** implementation *) mod_type : module_signature; (** expanded type *) (** algebraic type, kept if it's relevant for extraction *) mod_type_alg : module_expression option; @@ -395,13 +395,19 @@ and module_body = mod_constraints : Univ.ContextSet.t; (** quotiented set of equivalent constants and inductive names *) mod_delta : delta_resolver; - mod_retroknowledge : action list } + mod_retroknowledge : 'a module_retroknowledge; } + +and module_body = module_implementation generic_module_body (** A [module_type_body] is just a [module_body] with no - implementation ([mod_expr] always [Abstract]) and also - an empty [mod_retroknowledge] *) + implementation and also an empty [mod_retroknowledge] *) + +and module_type_body = unit generic_module_body -and module_type_body = module_body +and _ module_retroknowledge = +| ModBodyRK : + action list -> module_implementation module_retroknowledge +| ModTypeRK : unit module_retroknowledge (*************************************************************************) (** {4 From safe_typing.ml} *) diff --git a/checker/declarations.ml b/checker/declarations.ml index 093d999a34..884a1ef18c 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -583,24 +583,30 @@ let rec subst_expr sub = function | MEwith (me,wd)-> MEwith (subst_expr sub me, subst_with_body sub wd) let rec subst_expression sub me = - functor_map (subst_module sub) (subst_expr sub) me + functor_map (subst_module_type sub) (subst_expr sub) me and subst_signature sub sign = - functor_map (subst_module sub) (subst_structure sub) sign + functor_map (subst_module_type sub) (subst_structure sub) sign and subst_structure sub struc = let subst_body = function | SFBconst cb -> SFBconst (subst_const_body sub cb) | SFBmind mib -> SFBmind (subst_mind sub mib) | SFBmodule mb -> SFBmodule (subst_module sub mb) - | SFBmodtype mtb -> SFBmodtype (subst_module sub mtb) + | SFBmodtype mtb -> SFBmodtype (subst_module_type sub mtb) in List.map (fun (l,b) -> (l,subst_body b)) struc -and subst_module sub mb = +and subst_body : 'a. (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> 'a generic_module_body = + fun subst_impl sub mb -> { mb with mod_mp = subst_mp sub mb.mod_mp; - mod_expr = - implem_map (subst_signature sub) (subst_expression sub) mb.mod_expr; + mod_expr = subst_impl sub mb.mod_expr; mod_type = subst_signature sub mb.mod_type; mod_type_alg = Option.smartmap (subst_expression sub) mb.mod_type_alg } + +and subst_module sub mb = + subst_body (fun sub e -> implem_map (subst_signature sub) (subst_expression sub) e) sub mb + +and subst_module_type sub mb = + subst_body (fun _ () -> ()) sub mb diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index b6816dd484..3c9e1cac54 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -70,12 +70,12 @@ let lookup_module mp env = let mk_mtb mp sign delta = { mod_mp = mp; - mod_expr = Abstract; + mod_expr = (); mod_type = sign; mod_type_alg = None; mod_constraints = Univ.ContextSet.empty; mod_delta = delta; - mod_retroknowledge = []; } + mod_retroknowledge = ModTypeRK; } let rec check_module env mp mb = let (_:module_signature) = diff --git a/checker/modops.ml b/checker/modops.ml index 79cd5c29fd..f0abc39eac 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -49,7 +49,7 @@ let destr_functor = function | NoFunctor _ -> error_not_a_functor () let module_body_of_type mp mtb = - { mtb with mod_mp = mp; mod_expr = Abstract } + { mtb with mod_mp = mp; mod_expr = Abstract; mod_retroknowledge = ModBodyRK [] } let rec add_structure mp sign resolver env = let add_one env (l,elem) = @@ -93,17 +93,19 @@ let strengthen_const mp_from l cb resolver = let rec strengthen_mod mp_from mp_to mb = if Declarations.mp_in_delta mb.mod_mp mb.mod_delta then mb - else strengthen_body true mp_from mp_to mb + else + let mk_expr mp_to = Algebraic (NoFunctor (MEident mp_to)) in + strengthen_body mk_expr mp_from mp_to mb -and strengthen_body is_mod mp_from mp_to mb = +and strengthen_body : 'a. (_ -> 'a) -> _ -> _ -> 'a generic_module_body -> 'a generic_module_body = + fun mk_expr mp_from mp_to mb -> match mb.mod_type with | MoreFunctor _ -> mb | NoFunctor sign -> let resolve_out,sign_out = strengthen_sig mp_from sign mp_to mb.mod_delta in { mb with - mod_expr = - (if is_mod then Algebraic (NoFunctor (MEident mp_to)) else Abstract); + mod_expr = mk_expr mp_to; mod_type = NoFunctor sign_out; mod_delta = resolve_out } @@ -130,7 +132,7 @@ and strengthen_sig mp_from sign mp_to resolver = resolve_out,item::rest' let strengthen mtb mp = - strengthen_body false mtb.mod_mp mp mtb + strengthen_body ignore mtb.mod_mp mp mtb let subst_and_strengthen mb mp = strengthen_mod mb.mod_mp mp (subst_module (map_mp mb.mod_mp mp) mb) @@ -138,9 +140,9 @@ let subst_and_strengthen mb mp = let module_type_of_module mp mb = let mtb = { mb with - mod_expr = Abstract; + mod_expr = (); mod_type_alg = None; - mod_retroknowledge = [] } + mod_retroknowledge = ModTypeRK } in match mp with | Some mp -> strengthen {mtb with mod_mp = mp} mp diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 68a467bea2..98a9c8250d 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -393,7 +393,7 @@ and check_modtypes env mtb1 mtb2 subst1 subst2 equiv = mod_type = body_t1; mod_type_alg = None; mod_constraints = mtb1.mod_constraints; - mod_retroknowledge = []; + mod_retroknowledge = ModBodyRK []; mod_delta = mtb1.mod_delta} env in check_structure env body_t1 body_t2 equiv diff --git a/checker/univ.ml b/checker/univ.ml index 558315c2c1..4f31318132 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -29,107 +29,6 @@ open Util union-find algorithm. The assertions $<$ and $\le$ are represented by adjacency lists *) -module type Hashconsed = -sig - type t - val hash : t -> int - val eq : t -> t -> bool - val hcons : t -> t -end - -module HashedList (M : Hashconsed) : -sig - type t = private Nil | Cons of M.t * int * t - val nil : t - val cons : M.t -> t -> t -end = -struct - type t = Nil | Cons of M.t * int * t - module Self = - struct - type _t = t - type t = _t - type u = (M.t -> M.t) - let hash = function Nil -> 0 | Cons (_, h, _) -> h - let eq l1 l2 = match l1, l2 with - | Nil, Nil -> true - | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2 - | _ -> false - let hashcons hc = function - | Nil -> Nil - | Cons (x, h, l) -> Cons (hc x, h, l) - end - module Hcons = Hashcons.Make(Self) - let hcons = Hashcons.simple_hcons Hcons.generate Hcons.hcons M.hcons - (** No recursive call: the interface guarantees that all HLists from this - program are already hashconsed. If we get some external HList, we can - still reconstruct it by traversing it entirely. *) - let nil = Nil - let cons x l = - let h = M.hash x in - let hl = match l with Nil -> 0 | Cons (_, h, _) -> h in - let h = Hashset.Combine.combine h hl in - hcons (Cons (x, h, l)) -end - -module HList = struct - - module type S = sig - type elt - type t = private Nil | Cons of elt * int * t - val hash : t -> int - val nil : t - val cons : elt -> t -> t - val tip : elt -> t - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - val map : (elt -> elt) -> t -> t - val smartmap : (elt -> elt) -> t -> t - val exists : (elt -> bool) -> t -> bool - val for_all : (elt -> bool) -> t -> bool - val for_all2 : (elt -> elt -> bool) -> t -> t -> bool - val to_list : t -> elt list - end - - module Make (H : Hashconsed) : S with type elt = H.t = - struct - type elt = H.t - include HashedList(H) - - let hash = function Nil -> 0 | Cons (_, h, _) -> h - - let tip e = cons e nil - - let rec fold f l accu = match l with - | Nil -> accu - | Cons (x, _, l) -> fold f l (f x accu) - - let rec map f = function - | Nil -> nil - | Cons (x, _, l) -> cons (f x) (map f l) - - let smartmap = map - (** Apriori hashconsing ensures that the map is equal to its argument *) - - let rec exists f = function - | Nil -> false - | Cons (x, _, l) -> f x || exists f l - - let rec for_all f = function - | Nil -> true - | Cons (x, _, l) -> f x && for_all f l - - let rec for_all2 f l1 l2 = match l1, l2 with - | Nil, Nil -> true - | Cons (x1, _, l1), Cons (x2, _, l2) -> f x1 x2 && for_all2 f l1 l2 - | _ -> false - - let rec to_list = function - | Nil -> [] - | Cons (x, _, l) -> x :: to_list l - - end -end - module RawLevel = struct open Names @@ -167,24 +66,6 @@ struct | _, Level _ -> 1 | Var n, Var m -> Int.compare n m - let hequal x y = - x == y || - match x, y with - | Prop, Prop -> true - | Set, Set -> true - | Level (n,d), Level (n',d') -> - n == n' && d == d' - | Var n, Var n' -> n == n' - | _ -> false - - let hcons = function - | Prop as x -> x - | Set as x -> x - | Level (n,d) as x -> - let d' = Names.DirPath.hcons d in - if d' == d then x else Level (n,d') - | Var n as x -> x - open Hashset.Combine let hash = function @@ -216,24 +97,7 @@ module Level = struct let data x = x.data - (** Hashcons on levels + their hash *) - - module Self = struct - type _t = t - type t = _t - type u = unit - let eq x y = x.hash == y.hash && RawLevel.hequal x.data y.data - let hash x = x.hash - let hashcons () x = - let data' = RawLevel.hcons x.data in - if x.data == data' then x else { x with data = data' } - end - - let hcons = - let module H = Hashcons.Make(Self) in - Hashcons.simple_hcons H.generate H.hcons () - - let make l = hcons { hash = RawLevel.hash l; data = l } + let make l = { hash = RawLevel.hash l; data = l } let set = make Set let prop = make Prop @@ -270,7 +134,7 @@ module Level = struct let pr u = str (to_string u) - let make m n = make (Level (n, Names.DirPath.hcons m)) + let make m n = make (Level (n, m)) end @@ -303,48 +167,12 @@ struct module Expr = struct type t = Level.t * int - type _t = t - (* Hashing of expressions *) - module ExprHash = - struct - type t = _t - type u = Level.t -> Level.t - let hashcons hdir (b,n as x) = - let b' = hdir b in - if b' == b then x else (b',n) - let eq l1 l2 = - l1 == l2 || - match l1,l2 with - | (b,n), (b',n') -> b == b' && n == n' - - let hash (x, n) = n + Level.hash x - - end - - module HExpr = - struct - - module H = Hashcons.Make(ExprHash) - - type t = ExprHash.t - - let hcons = - Hashcons.simple_hcons H.generate H.hcons Level.hcons - let hash = ExprHash.hash - let eq x y = x == y || - (let (u,n) = x and (v,n') = y in - Int.equal n n' && Level.equal u v) - - end - - let hcons = HExpr.hcons - - let make l = hcons (l, 0) + let make l = (l, 0) - let prop = make Level.prop - let set = make Level.set - let type1 = hcons (Level.set, 1) + let prop = (Level.prop, 0) + let set = (Level.set, 0) + let type1 = (Level.set, 1) let is_prop = function | (l,0) -> Level.is_prop l @@ -363,13 +191,13 @@ struct let successor (u,n) = if Level.is_prop u then type1 - else hcons (u, n + 1) + else (u, n + 1) let addn k (u,n as x) = if k = 0 then x else if Level.is_prop u then - hcons (Level.set,n+k) - else hcons (u,n+k) + (Level.set,n+k) + else (u,n+k) let super (u,n as x) (v,n' as y) = let cmp = Level.compare u v in @@ -394,31 +222,29 @@ struct let v' = f v in if v' == v then x else if Level.is_prop v' && n != 0 then - hcons (Level.set, n) - else hcons (v', n) + (Level.set, n) + else (v', n) end - - module Huniv = HList.Make(Expr.HExpr) - type t = Huniv.t - open Huniv - - let equal x y = x == y || - (Huniv.hash x == Huniv.hash y && - Huniv.for_all2 Expr.equal x y) - let make l = Huniv.tip (Expr.make l) - let tip x = Huniv.tip x - + type t = Expr.t list + + let tip u = [u] + let cons u v = u :: v + + let equal x y = x == y || List.equal Expr.equal x y + + let make l = tip (Expr.make l) + let pr l = match l with - | Cons (u, _, Nil) -> Expr.pr u + | [u] -> Expr.pr u | _ -> str "max(" ++ hov 0 - (prlist_with_sep pr_comma Expr.pr (to_list l)) ++ + (prlist_with_sep pr_comma Expr.pr l) ++ str ")" let level l = match l with - | Cons (l, _, Nil) -> Expr.level l + | [l] -> Expr.level l | _ -> None (* The lower predicative level of the hierarchy that contains (impredicative) @@ -438,16 +264,16 @@ struct (* Returns the formal universe that lies juste above the universe variable u. Used to type the sort u. *) let super l = - Huniv.map (fun x -> Expr.successor x) l + List.map (fun x -> Expr.successor x) l let addn n l = - Huniv.map (fun x -> Expr.addn n x) l + List.map (fun x -> Expr.addn n x) l let rec merge_univs l1 l2 = match l1, l2 with - | Nil, _ -> l2 - | _, Nil -> l1 - | Cons (h1, _, t1), Cons (h2, _, t2) -> + | [], _ -> l2 + | _, [] -> l1 + | h1 :: t1, h2 :: t2 -> (match Expr.super h1 h2 with | Inl true (* h1 < h2 *) -> merge_univs t1 l2 | Inl false -> merge_univs l1 t2 @@ -459,28 +285,28 @@ struct let sort u = let rec aux a l = match l with - | Cons (b, _, l') -> + | b :: l' -> (match Expr.super a b with | Inl false -> aux a l' | Inl true -> l | Inr c -> if c <= 0 then cons a l else cons b (aux a l')) - | Nil -> cons a l + | [] -> cons a l in - fold (fun a acc -> aux a acc) u nil + List.fold_right (fun a acc -> aux a acc) u [] (* Returns the formal universe that is greater than the universes u and v. Used to type the products. *) let sup x y = merge_univs x y - let empty = nil + let empty = [] - let exists = Huniv.exists + let exists = List.exists - let for_all = Huniv.for_all + let for_all = List.for_all - let smartmap = Huniv.smartmap + let smartmap = List.smartmap end @@ -768,9 +594,9 @@ let check_equal_expr g x y = let check_eq_univs g l1 l2 = let f x1 x2 = check_equal_expr g x1 x2 in - let exists x1 l = Huniv.exists (fun x2 -> f x1 x2) l in - Huniv.for_all (fun x1 -> exists x1 l2) l1 - && Huniv.for_all (fun x2 -> exists x2 l1) l2 + let exists x1 l = List.exists (fun x2 -> f x1 x2) l in + List.for_all (fun x1 -> exists x1 l2) l1 + && List.for_all (fun x2 -> exists x2 l1) l2 let check_eq g u v = Universe.equal u v || check_eq_univs g u v @@ -784,11 +610,11 @@ let check_smaller_expr g (u,n) (v,m) = | _ -> false let exists_bigger g ul l = - Huniv.exists (fun ul' -> + Universe.exists (fun ul' -> check_smaller_expr g ul ul') l let real_check_leq g u v = - Huniv.for_all (fun ul -> exists_bigger g ul v) u + Universe.for_all (fun ul -> exists_bigger g ul v) u let check_leq g u v = Universe.equal u v || @@ -1026,8 +852,8 @@ let check_univ_leq u v = let enforce_leq u v c = match v with - | Universe.Huniv.Cons (v, _, Universe.Huniv.Nil) -> - Universe.Huniv.fold (fun u -> constraint_add_leq u v) u c + | [v] -> + List.fold_right (fun u -> constraint_add_leq u v) u c | _ -> anomaly (Pp.str"A universe bound can only be a variable.") let enforce_leq u v c = @@ -1080,63 +906,18 @@ end = struct type t = Level.t array - let empty : t = [||] - - module HInstancestruct = - struct - type _t = t - type t = _t - type u = Level.t -> Level.t - - let hashcons huniv a = - let len = Array.length a in - if Int.equal len 0 then empty - else begin - for i = 0 to len - 1 do - let x = Array.unsafe_get a i in - let x' = huniv x in - if x == x' then () - else Array.unsafe_set a i x' - done; - a - end - - let eq t1 t2 = - t1 == t2 || - (Int.equal (Array.length t1) (Array.length t2) && - let rec aux i = - (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) - in aux 0) - - let hash a = - let accu = ref 0 in - for i = 0 to Array.length a - 1 do - let l = Array.unsafe_get a i in - let h = Level.hash l in - accu := Hashset.Combine.combine !accu h; - done; - (* [h] must be positive. *) - let h = !accu land 0x3FFFFFFF in - h - - end - - module HInstance = Hashcons.Make(HInstancestruct) - - let hcons = Hashcons.simple_hcons HInstance.generate HInstance.hcons Level.hcons - - let empty = hcons [||] + let empty = [||] let is_empty x = Int.equal (Array.length x) 0 let subst_fn fn t = let t' = CArray.smartmap fn t in - if t' == t then t else hcons t' + if t' == t then t else t' let subst s t = let t' = CArray.smartmap (fun x -> try LMap.find x s with Not_found -> x) t - in if t' == t then t else hcons t' + in if t' == t then t else t' let pr = prvect_with_sep spc Level.pr @@ -1296,7 +1077,7 @@ let subst_univs_expr_opt fn (l,n) = let subst_univs_universe fn ul = let subst, nosubst = - Universe.Huniv.fold (fun u (subst,nosubst) -> + List.fold_right (fun u (subst,nosubst) -> try let a' = subst_univs_expr_opt fn u in (a' :: subst, nosubst) with Not_found -> (subst, u :: nosubst)) @@ -1307,7 +1088,7 @@ let subst_univs_universe fn ul = let substs = List.fold_left Universe.merge_univs Universe.empty subst in - List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u)) + List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.tip u)) substs nosubst let merge_context strict ctx g = diff --git a/checker/univ.mli b/checker/univ.mli index 0a21019b1b..0eadc6801f 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -164,7 +164,6 @@ sig val is_empty : t -> bool val equal : t -> t -> bool - (** Equality (note: instances are hash-consed, this is O(1)) *) val subst_fn : universe_level_subst_fn -> t -> t (** Substitution by a level-to-level function. *) diff --git a/checker/values.ml b/checker/values.ml index c95c3f1b2b..86634fbd80 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 c802f941f368bedd96e931cda0559d67 checker/cic.mli +MD5 62a4037e9e584d508909d631c5e8a759 checker/cic.mli *) @@ -54,6 +54,7 @@ let v_enum name n = Sum(name,n,[||]) let v_pair v1 v2 = v_tuple "*" [|v1; v2|] let v_bool = v_enum "bool" 2 +let v_unit = v_enum "unit" 1 let v_ref v = v_tuple "ref" [|v|] let v_set v = @@ -98,7 +99,7 @@ let v_raw_level = v_sum "raw_level" 2 (* Prop, Set *) [|(*Level*)[|Int;v_dp|]; (*Var*)[|Int|]|] let v_level = v_tuple "level" [|Int;v_raw_level|] let v_expr = v_tuple "levelexpr" [|v_level;Int|] -let rec v_univ = Sum ("universe", 1, [| [|v_expr; Int; v_univ|] |]) +let v_univ = List v_expr let v_cstrs = Annot @@ -311,13 +312,13 @@ and v_impl = Sum ("module_impl",2, (* Abstract, FullStruct *) [|[|v_mexpr|]; (* Algebraic *) [|v_sign|]|]) (* Struct *) -and v_noimpl = v_enum "no_impl" 1 (* Abstract is mandatory for mtb *) +and v_noimpl = v_unit and v_module = Tuple ("module_body", [|v_mp;v_impl;v_sign;Opt v_mexpr;v_context_set;v_resolver;Any|]) and v_modtype = Tuple ("module_type_body", - [|v_mp;v_noimpl;v_sign;Opt v_mexpr;v_context_set;v_resolver;Any|]) + [|v_mp;v_noimpl;v_sign;Opt v_mexpr;v_context_set;v_resolver;v_unit|]) (** kernel/safe_typing *) diff --git a/configure.ml b/configure.ml index 4eac8eaccf..b5e4567792 100644 --- a/configure.ml +++ b/configure.ml @@ -11,11 +11,11 @@ #load "str.cma" open Printf -let coq_version = "8.7+alpha" -let coq_macos_version = "8.6.90" (** "[...] should be a string comprised of +let coq_version = "8.8+alpha" +let coq_macos_version = "8.7.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) -let vo_magic = 8691 -let state_magic = 58691 +let vo_magic = 8791 +let state_magic = 58791 let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqmktop";"coqworkmgr"; "coqdoc";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert";"coqdep"] diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index b2efe2ddd4..a420b5d8bb 100644 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -344,6 +344,9 @@ IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" ( IF NOT "%CYGWIN_QUIET%" == "Y" ( SET RUNSETUP=Y ) +IF "%COQREGTESTING%" == "Y" ( + SET RUNSETUP=Y +) IF "%RUNSETUP%"=="Y" ( %SETUP% ^ diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index e179239514..f3e4cec0b9 100644 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1058,13 +1058,18 @@ function copq_coq_gtk { install_rec "$PREFIX/share/themes/" '*' "$PREFIXCOQ/share/themes" # This below item look like a bug in make install + if [ -d "$PREFIXCOQ/share/coq/" ] ; then + COQSHARE="$PREFIXCOQ/share/coq/" + else + COQSHARE="$PREFIXCOQ/share/" + fi if [[ ! $COQ_VERSION == 8.4* ]] ; then - mv "$PREFIXCOQ/share/coq/"*.lang "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" - mv "$PREFIXCOQ/share/coq/"*.xml "$PREFIXCOQ/share/gtksourceview-2.0/styles" + mv "$COQSHARE"*.lang "$PREFIXCOQ/share/gtksourceview-2.0/language-specs" + mv "$COQSHARE"*.xml "$PREFIXCOQ/share/gtksourceview-2.0/styles" fi mkdir -p "$PREFIXCOQ/ide" - mv "$PREFIXCOQ/share/coq/"*.png "$PREFIXCOQ/ide" - rmdir "$PREFIXCOQ/share/coq" + mv "$COQSHARE"*.png "$PREFIXCOQ/ide" + rmdir "$PREFIXCOQ/share/coq" || true fi } @@ -1119,11 +1124,11 @@ function make_coq { then if [ "$INSTALLMODE" == "relocatable" ]; then # HACK: for relocatable builds, first configure with ./, then build but before install reconfigure with the real target path - logn configure ./configure -debug -with-doc no -prefix ./ -libdir ./lib -mandir ./man + ./configure -with-doc no -prefix ./ -libdir ./lib -mandir ./man elif [ "$INSTALLMODE" == "absolute" ]; then - logn configure ./configure -debug -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" + ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" else - logn configure ./configure -debug -with-doc no -prefix "$PREFIXCOQ" + ./configure -with-doc no -prefix "$PREFIXCOQ" fi # The windows resource compiler binary name is hard coded @@ -1134,17 +1139,17 @@ function make_coq { if [[ $COQ_VERSION == 8.4* ]] ; then log1 make else - log1 make $MAKE_OPT + make $MAKE_OPT fi if [ "$INSTALLMODE" == "relocatable" ]; then - logn reconfigure ./configure -debug -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" + ./configure -with-doc no -prefix "$PREFIXCOQ" -libdir "$PREFIXCOQ/lib" -mandir "$PREFIXCOQ/man" fi - log2 make install - log1 copy_coq_dlls + make install + copy_coq_dlls if [ "$INSTALLOCAML" == "Y" ]; then - log1 copy_coq_objects + copy_coq_objects fi copq_coq_gtk @@ -1267,7 +1272,7 @@ function get_cygwin_mingw_sources { function make_coq_installer { make_coq make_mingw_make - # get_cygwin_mingw_sources + get_cygwin_mingw_sources # Prepare the file lists for the installer. We created to file list dumps of the target folder during the build: # ocaml: ocaml + menhir + camlp5 + findlib diff --git a/dev/ci/README.md b/dev/ci/README.md new file mode 100644 index 0000000000..f4423558cc --- /dev/null +++ b/dev/ci/README.md @@ -0,0 +1,130 @@ +Continuous Integration for the Coq Proof Assistant +================================================== + +Changes to Coq are systematically tested for regression and compatibility +breakage on our Continuous Integration (CI) platforms *before* integration, +so as to ensure better robustness and catch problems as early as possible. +These tests include the compilation of several external libraries / plugins. + +This document contains information for both external library / plugin authors, +who might be interested in having their development tested, and for Coq +developers / contributors, who must ensure that they don't break these +external developments accidentally. + +*Remark:* the CI policy outlined in this document is susceptible to evolve and +specific accommodations are of course possible. + +Information for external library / plugin authors +------------------------------------------------- + +You are encouraged to consider submitting your development for addition to +our CI. This means that: + +- Any time that a proposed change is breaking your development, Coq developers + will send you patches to adapt it or, at the very least, will work with you + to see how to adapt it. + +On the condition that: + +- At the time of the submission, your development works with Coq master branch. + +- Your development is publicly available in a git repository and we can easily + send patches to you (e.g. through pull / merge requests). + +- You react in a timely manner to discuss / integrate those patches. + +- You do not push, to the branches that we test, commits that haven't been + first tested to compile with the corresponding branch(es) of Coq. + +- Your development compiles in less than 35 minutes with just two threads. + If this is not the case, consider adding a "lite" target that compiles just + part of it. + +In case you forget to comply with these last three conditions, we would reach +out to you and give you a 30-day grace period during which your development +would be moved into our "allow failure" category. At the end of the grace +period, in the absence of progress, the development would be removed from our +CI. + +### Add your development by submitting a pull request + +Add a new `ci-mydev.sh` script to [`dev/ci`](/dev/ci) (have a look at +[`ci-coq-dpdgraph.sh`](/dev/ci/ci-coq-dpdgraph.sh) or +[`ci-fiat-parsers.sh`](/dev/ci/ci-fiat-parsers.sh) for simple examples); +set the corresponding variables in +[`ci-basic-overlay.sh`](/dev/ci/ci-basic-overlay.sh); add the corresponding +target to [`Makefile.ci`](/Makefile.ci); add new jobs to +[`.travis.yml`](/.travis.yml) and [`.gitlab-ci.yml`](/.gitlab-ci.yml) so that +this new target is run. **Do not hesitate to submit an incomplete pull request +if you need help to finish it.** + +You may also be interested in having your development tested in our +performance benchmark. Currently this is done by providing an OPAM package +in https://github.com/coq/opam-coq-archive and opening an issue at +https://github.com/coq/coq-bench/issues. + + +Information for developers +-------------------------- + +When you submit a pull request (PR) on Coq GitHub repository, this will +automatically launch a battery of CI tests. The PR will not be integrated +unless these tests pass. + +Currently, we have two CI platforms: + +- Travis is the main CI platform. It tests the compilation of Coq, of the + documentation, and of CoqIDE on Linux with several versions of OCaml / + camlp5, and with warnings as errors; it runs the test-suite and tests the + compilation of several external developments. It also tests the compilation + of Coq on OS X. + +- AppVeyor is used to test the compilation of Coq and run the test-suite on + Windows. + +You can anticipate the results of these tests prior to submitting your PR +by having them run of your fork of Coq, on GitHub or GitLab. This can be +especially helpful given that our Travis platform is often overloaded and +therefore there can be a significant delay before these tests are actually +run on your PR. To take advantage of this, simply create a Travis account +and link it to your GitHub account, or activate the pipelines on your GitLab +fork. + +You can also run one CI target locally (using `make ci-somedev`). + +Whenever your PR breaks tested developments, you should either adapt it +so that it doesn't, or provide a branch fixing these developments (or at +least work with the author of the development / other Coq developers to +prepare these fixes). Then, add an overlay in +[`dev/ci/user-overlays`](/dev/ci/user-overlays) (see the README there) +in a separate commit in your PR. + +The process to merge your PR is then to submit PRs to the external +development repositories, merge the latter first (if the fixes are +backward-compatible), drop the overlay commit and merge the PR on Coq then. + + +Travis specific information +--------------------------- + +Travis rebuilds all of Coq's executables and stdlib for each job. Coq +is built with `./configure -local`, then used for the job's test. + + +GitLab specific information +--------------------------- + +GitLab is set up to use the "build artifact" feature to avoid +rebuilding Coq. In one job, Coq is built with `./configure -prefix +install` and `make install` is run, then the `install` directory +persists to and is used by the next jobs. + +Artifacts can also be downloaded from the GitLab repository. +Currently, available artifacts are: +- the Coq executables and stdlib, in three copies varying in + architecture and Ocaml version used to build Coq. +- the Coq documentation, in two different copies varying in the OCaml + version used to build Coq + +As an exception to the above, jobs testing that compilation triggers +no Ocaml warnings build Coq in parallel with other tests. diff --git a/dev/ci/appveyor.bat b/dev/ci/appveyor.bat new file mode 100644 index 0000000000..ca6a5643c1 --- /dev/null +++ b/dev/ci/appveyor.bat @@ -0,0 +1,35 @@ +REM This script either runs the test suite with OPAM (if USEOPAM is true) or +REM builds the Coq binary packages for windows (if USEOPAM is false). + +if %ARCH% == 32 ( + SET ARCHLONG=i686 + SET CYGROOT=C:\cygwin + SET SETUP=setup-x86.exe +) + +if %ARCH% == 64 ( + SET ARCHLONG=x86_64 + SET CYGROOT=C:\cygwin64 + SET SETUP=setup-x86_64.exe +) + +SET CYGCACHE=%CYGROOT%\var\cache\setup +SET APPVEYOR_BUILD_FOLDER_MFMT=%APPVEYOR_BUILD_FOLDER:\=/% +SET APPVEYOR_BUILD_FOLDER_CFMT=%APPVEYOR_BUILD_FOLDER_MFMT:C:/=/cygdrive/c/% +SET DESTCOQ=C:\coq%ARCH%_inst +SET COQREGTESTING=Y + +if %USEOPAM% == false ( + call %APPVEYOR_BUILD_FOLDER%\dev\build\windows\MakeCoq_MinGW.bat -threads=1 ^ + -arch=%ARCH% -installer=Y -coqver=%APPVEYOR_BUILD_FOLDER_CFMT% ^ + -destcyg=%CYGROOT% -destcoq=%DESTCOQ% -cygcache=%CYGCACHE% ^ + -setup %CYGROOT%\%SETUP% + copy "%CYGROOT%\build\coq-local\dev\nsis\*.exe" dev\nsis + 7z a coq-opensource-archive-%ARCHLONG%.zip %CYGROOT%\build\tarballs\* +) + +if %USEOPAM% == true ( + %CYGROOT%\%SETUP% -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% ^ + -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time + %CYGROOT%/bin/bash -l %APPVEYOR_BUILD_FOLDER%/dev/ci/appveyor.sh +) diff --git a/dev/build/windows/appveyor.sh b/dev/ci/appveyor.sh index 53f7a23466..524a55a423 100644 --- a/dev/build/windows/appveyor.sh +++ b/dev/ci/appveyor.sh @@ -1,8 +1,9 @@ #!/bin/bash set -e -x -wget $opam_url +wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.1/opam64.tar.xz tar -xf opam64.tar.xz bash opam64/install.sh opam init -a mingw https://github.com/fdopen/opam-repository-mingw.git --comp 4.02.3+mingw64c --switch 4.02.3+mingw64c eval $(opam config env) opam install -y ocamlfind camlp5 +cd $APPVEYOR_BUILD_FOLDER && ./configure -local && make && make byte && make -C test-suite all INTERACTIVE= && make validate diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 4b3b44875f..8e7265969b 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -114,7 +114,9 @@ ######################################################################## # SF ######################################################################## -: ${sf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/current/sf.tgz} +: ${sf_lf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/lf-current/lf.tgz} +: ${sf_plf_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/plf-current/plf.tgz} +: ${sf_vfa_CI_TARURL:=https://www.cis.upenn.edu/~bcpierce/sf/vfa-current/vfa.tgz} ######################################################################## # TLC @@ -125,5 +127,5 @@ ######################################################################## # Bignums ######################################################################## -: ${bignums_CI_BRANCH:=master} -: ${bignums_CI_GITURL:=https://github.com/coq/bignums.git} +: ${bignums_CI_BRANCH:=fix-thunk-printer} +: ${bignums_CI_GITURL:=https://github.com/ppedrot/bignums.git} diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh index 6e6c7012b7..272041205c 100755 --- a/dev/ci/ci-sf.sh +++ b/dev/ci/ci-sf.sh @@ -4,11 +4,18 @@ ci_dir="$(dirname "$0")" source ${ci_dir}/ci-common.sh # XXX: Needs fixing to properly set the build directory. -wget ${sf_CI_TARURL} -tar xvfz sf.tgz +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 -sed -i.bak '15i From Coq Require Extraction.' sf/Extraction.v +sed -i.bak '1i From Coq Require Extraction.' lf/Extraction.v +sed -i.bak '1i From Coq Require Extraction.' vfa/Extract.v -( cd sf && sed -i.bak 's/(K,N)/((K,N))/' LibTactics.v && make clean && make ) +( cd lf && make clean && make ) +( cd plf && sed -i.bak 's/(K,N)/((K,N))/' LibTactics.v && make clean && make ) +( cd vfa && make clean && make ) diff --git a/dev/ci/ci-wrapper.sh b/dev/ci/ci-wrapper.sh new file mode 100755 index 0000000000..96acc5a11c --- /dev/null +++ b/dev/ci/ci-wrapper.sh @@ -0,0 +1,24 @@ +#!/usr/bin/env bash + +# Use this script to preserve the exit code of $CI_SCRIPT when piping +# it to `tee time-of-build.log`. We have a separate script, because +# this only works in bash, which we don't require project-wide. + +set -eo pipefail + +function travis_fold { + if [ -n "${TRAVIS}" ]; + then + echo "travis_fold:$1:$2" + fi +} + +CI_SCRIPT="$1" +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" +# assume this script is in dev/ci/, cd to the root Coq directory +cd "${DIR}/../.." + +"${DIR}/${CI_SCRIPT}" 2>&1 | tee time-of-build.log +travis_fold 'start' 'coq.test.timing' && echo 'Aggregating timing log...' +python ./tools/make-one-time-file.py time-of-build.log +travis_fold 'end' 'coq.test.timing' diff --git a/dev/core.dbg b/dev/core.dbg index 71d06cdb0a..18e82c352c 100644 --- a/dev/core.dbg +++ b/dev/core.dbg @@ -16,7 +16,6 @@ load_printer tactics.cma load_printer vernac.cma load_printer stm.cma load_printer toplevel.cma -load_printer highparsing.cma load_printer intf.cma load_printer API.cma load_printer ltac_plugin.cmo diff --git a/dev/doc/changes.txt b/dev/doc/changes.md index 0f1a28028c..5ed74917aa 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.md @@ -1,141 +1,146 @@ -========================================= -= CHANGES BETWEEN COQ V8.7 AND COQ V8.8 = -========================================= +## Changes between Coq 8.7 and Coq 8.8 -* ML API * +### Plugin API + +Coq 8.8 offers a new module overlay containing a proposed plugin API +in `API/API.ml`; this overlay is enabled by adding the `-open API` +flag to the OCaml compiler; this happens automatically for +developments in the `plugin` folder and `coq_makefile`. + +However, `coq_makefile` can be instructed not to enable this flag by +passing `-bypass-API`. + +### ML API We removed the following functions: -- Universes.unsafe_constr_of_global: use Global.constr_of_global_in_context +- `Universes.unsafe_constr_of_global`: use `Global.constr_of_global_in_context` instead. The returned term contains De Bruijn universe variables. If you don't depend on universes being instantiated, simply drop the context. -- Universes.unsafe_type_of_global: same as above with - Global.type_of_global_in_context + +- `Universes.unsafe_type_of_global`: same as above with + `Global.type_of_global_in_context` We changed the type of the following functions: -- Global.body_of_constant_body: now also returns the abstract universe context. +- `Global.body_of_constant_body`: now also returns the abstract universe context. The returned term contains De Bruijn universe variables. -- Global.body_of_constant: same as above. + +- `Global.body_of_constant`: same as above. We renamed the following datatypes: - Pp.std_ppcmds -> Pp.t +- `Pp.std_ppcmds` -> `Pp.t` -========================================= -= CHANGES BETWEEN COQ V8.6 AND COQ V8.7 = -========================================= +## Changes between Coq 8.6 and Coq 8.7 -* Ocaml * +### Ocaml -Coq is compiled with -safe-string enabled and requires plugins to do +Coq is compiled with `-safe-string` enabled and requires plugins to do the same. This means that code using `String` in an imperative way will fail to compile now. They should switch to `Bytes.t` -* Plugin API * +### ML API -Coq 8.7 offers a new module overlay containing a proposed plugin API -in `API/API.ml`; this overlay is enabled by adding the `-open API` -flag to the OCaml compiler; this happens automatically for -developments in the `plugin` folder and `coq_makefile`. - -However, `coq_makefile` can be instructed not to enable this flag by -passing `-bypass-API`. - -* ML API * - -Added two functions for declaring hooks to be executed in reduction +- Added two functions for declaring hooks to be executed in reduction functions when some given constants are traversed: - declare_reduction_effect: to declare a hook to be applied when some + * `declare_reduction_effect`: to declare a hook to be applied when some constant are visited during the execution of some reduction functions (primarily cbv). - set_reduction_effect: to declare a constant on which a given effect + * `set_reduction_effect`: to declare a constant on which a given effect hook should be called. -We renamed the following functions: +- We renamed the following functions: + ``` Context.Rel.Declaration.fold -> Context.Rel.Declaration.fold_constr Context.Named.Declaration.fold -> Context.Named.Declaration.fold_constr Printer.pr_var_list_decl -> Printer.pr_compacted_decl Printer.pr_var_decl -> Printer.pr_named_decl Nameops.lift_subscript -> Nameops.increment_subscript + ``` -We removed the following functions: +- We removed the following functions: - Termops.compact_named_context_reverse ... practical substitute is Termops.compact_named_context - Namegen.to_avoid ... equivalent substitute is Names.Id.List.mem + * `Termops.compact_named_context_reverse`: practical substitute is `Termops.compact_named_context`. + * `Namegen.to_avoid`: equivalent substitute is `Names.Id.List.mem`. -We renamed the following modules: +- We renamed the following modules: - Context.ListNamed -> Context.Compacted + * `Context.ListNamed` -> `Context.Compacted` -The following type aliases where removed +- The following type aliases where removed - Context.section_context ... it was just an alias for "Context.Named.t" which is still available + * `Context.section_context`: it was just an alias for `Context.Named.t` which is still available. -The module Constrarg was merged into Stdarg. +- The module `Constrarg` was merged into `Stdarg`. -The following types have been moved and modified: +- The following types have been moved and modified: - local_binder -> local_binder_expr - glob_binder merged with glob_decl + * `local_binder` -> `local_binder_expr` + * `glob_binder` merged with `glob_decl` -The following constructors have been renamed: +- The following constructors have been renamed: + ``` LocalRawDef -> CLocalDef LocalRawAssum -> CLocalAssum LocalPattern -> CLocalPattern + ``` -In Constrexpr_ops: +- In `Constrexpr_ops`: - Deprecating abstract_constr_expr in favor of mkCLambdaN, and - prod_constr_expr in favor of mkCProdN. Note: the first ones were - interpreting "(x y z:_)" as "(x:_) (y:_) (z:_)" while the second + Deprecating `abstract_constr_expr` in favor of `mkCLambdaN`, and + `prod_constr_expr` in favor of `mkCProdN`. Note: the first ones were + interpreting `(x y z:_)` as `(x:_) (y:_) (z:_)` while the second ones were preserving the original sharing of the type. -In Nameops: +- In `Nameops`: The API has been made more uniform. New combinators added in the - "Name" space name. Function "out_name" now fails with IsAnonymous - rather than with Failure "Nameops.out_name". + `Name` space name. Function `out_name` now fails with `IsAnonymous` + rather than with `Failure "Nameops.out_name"`. -Location handling and AST attributes: +- Location handling and AST attributes: - Location handling has been reworked. First, Loc.ghost has been + Location handling has been reworked. First, `Loc.ghost` has been removed in favor of an option type, all objects carrying an optional source code location have been switched to use `Loc.t option`. Storage of location information has been also refactored. The main - datatypes representing Coq AST (constrexpr, glob_expr) have been + datatypes representing Coq AST (`constrexpr`, `glob_expr`) have been switched to a generic "node with attributes" representation `'a CAst.ast`, which is a record of the form: -```ocaml -type 'a ast = private { - v : 'a; - loc : Loc.t option; - ... -} -``` + ```ocaml + type 'a ast = private { + v : 'a; + loc : Loc.t option; + ... + } + ``` consumers of AST nodes are recommended to use accessor-based pattern matching `{ v; loc }` to destruct `ast` object. Creation is done with `CAst.make ?loc obj`, where the attributes are optional. Some convenient combinators are provided in the module. A typical match: -``` -| CCase(loc, a1) -> CCase(loc, f a1) -``` + + ```ocaml + | CCase(loc, a1) -> CCase(loc, f a1) + ``` + is now done as: -``` -| { v = CCase(a1); loc } -> CAst.make ?loc @@ CCase(f a1) -``` + ```ocaml + | { v = CCase(a1); loc } -> CAst.make ?loc @@ CCase(f a1) + + ``` or even better, if plan to preserve the attributes you can wrap your top-level function in `CAst.map` to have: -``` -| CCase(a1) -> CCase(f a1) -``` + ```ocaml + | CCase(a1) -> CCase(f a1) + ``` This scheme based on records enables easy extensibility of the AST node type without breaking compatibility. @@ -151,14 +156,14 @@ type 'a ast = private { implemented in the whole code base. Matching a located object hasn't changed, however, `Loc.tag ?loc obj` must be used to build one. -In GOption: +- In `GOption`: Support for non-synchronous options has been removed. Now all options are handled as a piece of normal document state, and thus passed to workers, etc... As a consequence, the field `Goptions.optsync` has been removed. -In Coqlib / reference location: +- In `Coqlib` / reference location: We have removed from Coqlib functions returning `constr` from names. Now it is only possible to obtain references, that must be @@ -175,65 +180,67 @@ In Coqlib / reference location: `pf_constr_of_global` in tactics and `Evarutil.new_global` variants when constructing terms in ML (see univpoly.txt for more information). -** Tactic API ** +### Tactic API -- pf_constr_of_global now returns a tactic instead of taking a continuation. +- `pf_constr_of_global` now returns a tactic instead of taking a continuation. Thus it only generates one instance of the global reference, and it is the caller's responsibility to perform a focus on the goal. -- pf_global, construct_reference, global_reference, - global_reference_in_absolute_module now return a global_reference - instead of a constr. +- `pf_global`, `construct_reference`, `global_reference`, + `global_reference_in_absolute_module` now return a `global_reference` + instead of a `constr`. -- The tclWEAK_PROGRESS and tclNOTSAMEGOAL tacticals were removed. Their usecase - was very specific. Use tclPROGRESS instead. +- The `tclWEAK_PROGRESS` and `tclNOTSAMEGOAL` tacticals were removed. Their usecase + was very specific. Use `tclPROGRESS` instead. - New (internal) tactical `tclINDEPENDENTL` that combined with enter_one allows to iterate a non-unit tactic on all goals and access their returned values. -- The unsafe flag of the Refine.refine function and its variants has been +- The unsafe flag of the `Refine.refine` function and its variants has been renamed and dualized into typecheck and has been made mandatory. -** Ltac API ** +### Ltac API Many Ltac specific API has been moved in its own ltac/ folder. Amongst other important things: -- Pcoq.Tactic -> Pltac -- Constrarg.wit_tactic -> Tacarg.wit_tactic -- Constrarg.wit_ltac -> Tacarg.wit_ltac -- API below ltac/ that accepted a *_tactic_expr now accept a *_generic_argument +- `Pcoq.Tactic` -> `Pltac` +- `Constrarg.wit_tactic` -> `Tacarg.wit_tactic` +- `Constrarg.wit_ltac` -> `Tacarg.wit_ltac` +- API below `ltac/` that accepted a *`_tactic_expr` now accept a *`_generic_argument` instead -- Some printing functions were moved from Pptactic to Pputils -- A part of Tacexpr has been moved to Tactypes -- The TacFun tactic expression constructor now takes a `Name.t list` for the +- Some printing functions were moved from `Pptactic` to `Pputils` +- A part of `Tacexpr` has been moved to `Tactypes` +- The `TacFun` tactic expression constructor now takes a `Name.t list` for the variable list rather than an `Id.t option list`. The folder itself has been turned into a plugin. This does not change much, but because it is a packed plugin, it may wreak havoc for third-party plugins -depending on any module defined in the ltac/ directory. Namely, even if +depending on any module defined in the `ltac/` directory. Namely, even if everything looks OK at compile time, a plugin can fail to load at link time -because it mistakenly looks for a module Foo instead of Ltac_plugin.Foo, with +because it mistakenly looks for a module `Foo` instead of `Ltac_plugin.Foo`, with an error of the form: +``` Error: while loading myplugin.cmxs, no implementation available for Foo. +``` -In particular, most EXTEND macros will trigger this problem even if they +In particular, most `EXTEND` macros will trigger this problem even if they seemingly do not use any Ltac module, as their expansion do. -The solution is simple, and consists in adding a statement "open Ltac_plugin" +The solution is simple, and consists in adding a statement `open Ltac_plugin` in each file using a Ltac module, before such a module is actually called. An alternative solution would be to fully qualify Ltac modules, e.g. turning any -call to Tacinterp into Ltac_plugin.Tacinterp. Note that this solution does not -work for EXTEND macros though. +call to Tacinterp into `Ltac_plugin.Tacinterp`. Note that this solution does not +work for `EXTEND` macros though. -** Additional changes in tactic extensions ** +### Additional changes in tactic extensions -Entry "constr_with_bindings" has been renamed into -"open_constr_with_bindings". New entry "constr_with_bindings" now +Entry `constr_with_bindings` has been renamed into +`open_constr_with_bindings`. New entry `constr_with_bindings` now uses type classes and rejects terms with unresolved holes. -** Error handling ** +### Error handling - All error functions now take an optional parameter `?loc:Loc.t`. For functions that used to carry a suffix `_loc`, such suffix has been @@ -243,14 +250,14 @@ uses type classes and rejects terms with unresolved holes. - The header parameter to `user_err` has been made optional. -** Pretty printing ** +### Pretty printing Some functions have been removed, see pretty printing below for more details. -* Pretty Printing and XML protocol * +#### Pretty Printing and XML protocol -The type std_cmdpps has been reworked and made the canonical "Coq rich +The type `std_cmdpps` has been reworked and made the canonical "Coq rich document type". This allows for a more uniform handling of printing (specially in IDEs). The main consequences are: @@ -267,12 +274,13 @@ document type". This allows for a more uniform handling of printing - `Pp_control` has removed. The new module `Topfmt` implements console control for the toplevel. - - The impure tag system in Pp has been removed. This also does away + - The impure tag system in `Pp` has been removed. This also does away with the printer signatures and functors. Now printers tag unconditionally. - The following functions have been removed from `Pp`: + ```ocaml val stras : int * string -> std_ppcmds val tbrk : int * int -> std_ppcmds val tab : unit -> std_ppcmds @@ -294,8 +302,9 @@ document type". This allows for a more uniform handling of printing val msg_with : ... module Tag + ``` -** Stm API ** +### Stm API - We have streamlined the `Stm` API, now `add` and `query` take a `coq_parsable` instead a `string` so clients can have more control @@ -312,7 +321,7 @@ document type". This allows for a more uniform handling of printing - A few unused hooks were removed due to cleanups, no clients known. -** Toplevel and Vernacular API ** +### Toplevel and Vernacular API - The components related to vernacular interpretation have been moved to their own folder `vernac/` whereas toplevel now contains the @@ -321,39 +330,41 @@ document type". This allows for a more uniform handling of printing - Coq's toplevel has been ported to directly use the common `Stm` API. The signature of a few functions has changed as a result. -** XML Protocol ** +### XML Protocol - The legacy `Interp` call has been turned into a noop. - The `query` call has been modified, now it carries a mandatory - "route_id" integer parameter, that associated the result of such + `route_id` integer parameter, that associated the result of such query with its generated feedback. -========================================= -= CHANGES BETWEEN COQ V8.5 AND COQ V8.6 = -========================================= +## Changes between Coq 8.5 and Coq 8.6 -** Parsing ** +### Parsing -Pcoq.parsable now takes an extra optional filename argument so as to +`Pcoq.parsable` now takes an extra optional filename argument so as to bind locations to a file name when relevant. -** Files ** +### Files To avoid clashes with OCaml's compiler libs, the following files were renamed: + +``` kernel/closure.ml{,i} -> kernel/cClosure.ml{,i} lib/errors.ml{,i} -> lib/cErrors.ml{,i} toplevel/cerror.ml{,i} -> toplevel/explainErr.mli{,i} +``` -All IDE-specific files, including the XML protocol have been moved to ide/ +All IDE-specific files, including the XML protocol have been moved to `ide/` -** Reduction functions ** +### Reduction functions -In closure.ml, we introduced the more precise reduction flags fMATCH, fFIX, -fCOFIX. +In `closure.ml`, we introduced the more precise reduction flags `fMATCH`, `fFIX`, +`fCOFIX`. We renamed the following functions: +``` Closure.betadeltaiota -> Closure.all Closure.betadeltaiotanolet -> Closure.allnolet Reductionops.beta -> Closure.beta @@ -380,9 +391,11 @@ Reductionops.whd_betadeltaiota_nolet_state -> Reductionops.whd_allnolet_state Reductionops.whd_eta -> Reductionops.shrink_eta Tacmach.pf_whd_betadeltaiota -> Tacmach.pf_whd_all Tacmach.New.pf_whd_betadeltaiota -> Tacmach.New.pf_whd_all +``` And removed the following ones: +``` Reductionops.whd_betaetalet Reductionops.whd_betaetalet_stack Reductionops.whd_betaetalet_state @@ -392,15 +405,16 @@ Reductionops.whd_betadeltaeta Reductionops.whd_betadeltaiotaeta_stack Reductionops.whd_betadeltaiotaeta_state Reductionops.whd_betadeltaiotaeta +``` -In intf/genredexpr.mli, fIota was replaced by FMatch, FFix and -FCofix. Similarly, rIota was replaced by rMatch, rFix and rCofix. +In `intf/genredexpr.mli`, `fIota` was replaced by `FMatch`, `FFix` and +`FCofix`. Similarly, `rIota` was replaced by `rMatch`, `rFix` and `rCofix`. -** Notation_ops ** +### Notation_ops -Use Glob_ops.glob_constr_eq instead of Notation_ops.eq_glob_constr. +Use `Glob_ops.glob_constr_eq` instead of `Notation_ops.eq_glob_constr`. -** Logging and Pretty Printing: ** +### Logging and Pretty Printing * Printing functions have been removed from `Pp.mli`, which is now a purely pretty-printing interface. Functions affected are: @@ -429,7 +443,7 @@ val message : string -> unit * Feedback related functions and definitions have been moved to the `Feedback` module. `message_level` has been renamed to - level. Functions moved from Pp to Feedback are: + level. Functions moved from `Pp` to `Feedback` are: ```` ocaml val set_logger : logger -> unit @@ -474,12 +488,13 @@ val set_id_for_feedback : ?route:route_id -> edit_or_state_id -> unit val get_id_for_feedback : unit -> edit_or_state_id * route_id ```` -** Kernel API changes ** +### Kernel API changes -- The interface of the Context module was changed. +- The interface of the `Context` module was changed. Related types and functions were put in separate submodules. The mapping from old identifiers to new identifiers is the following: + ``` Context.named_declaration ---> Context.Named.Declaration.t Context.named_list_declaration ---> Context.NamedList.Declaration.t Context.rel_declaration ---> Context.Rel.Declaration.t @@ -521,123 +536,142 @@ val get_id_for_feedback : unit -> edit_or_state_id * route_id Context.rel_context_length ---> Context.Rel.length Context.rel_context_nhyps ---> Context.Rel.nhyps Context.rel_context_tags ---> Context.Rel.to_tags + ``` - Originally, rel-context was represented as: - Context.rel_context = Names.Name.t * Constr.t option * Constr.t + ```ocaml + type Context.rel_context = Names.Name.t * Constr.t option * Constr.t + ``` Now it is represented as: - Context.Rel.Declaration.t = LocalAssum of Names.Name.t * Constr.t - | LocalDef of Names.Name.t * Constr.t * Constr.t - + ```ocaml + type Context.Rel.Declaration.t = LocalAssum of Names.Name.t * Constr.t + | LocalDef of Names.Name.t * Constr.t * Constr.t + ``` + - Originally, named-context was represented as: - Context.named_context = Names.Id.t * Constr.t option * Constr.t + ```ocaml + type Context.named_context = Names.Id.t * Constr.t option * Constr.t + ``` Now it is represented as: - Context.Named.Declaration.t = LocalAssum of Names.Id.t * Constr.t - | LocalDef of Names.Id.t * Constr.t * Constr.t + ```ocaml + type Context.Named.Declaration.t = LocalAssum of Names.Id.t * Constr.t + | LocalDef of Names.Id.t * Constr.t * Constr.t + ``` -- The various EXTEND macros do not handle specially the Coq-defined entries +- The various `EXTEND` macros do not handle specially the Coq-defined entries anymore. Instead, they just output a name that have to exist in the scope - of the ML code. The parsing rules (VERNAC) ARGUMENT EXTEND will look for - variables "$name" of type Gram.entry, while the parsing rules of - (VERNAC COMMAND | TACTIC) EXTEND, as well as the various TYPED AS clauses will - look for variables "wit_$name" of type Genarg.genarg_type. The small DSL + of the ML code. The parsing rules (`VERNAC`) `ARGUMENT EXTEND` will look for + variables `$name` of type `Gram.entry`, while the parsing rules of + (`VERNAC COMMAND` | `TACTIC`) `EXTEND`, as well as the various `TYPED AS` clauses will + look for variables `wit_$name` of type `Genarg.genarg_type`. The small DSL for constructing compound entries still works over this scheme. Note that in - the case of (VERNAC) ARGUMENT EXTEND, the name of the argument entry is bound + the case of (`VERNAC`) `ARGUMENT EXTEND`, the name of the argument entry is bound in the parsing rules, so beware of recursive calls. - For example, to get "wit_constr" you must "open Constrarg" at the top of the file. + For example, to get `wit_constr` you must `open Constrarg` at the top of the file. -- Evarutil was split in two parts. The new Evardefine file exposes functions -define_evar_* mostly used internally in the unification engine. +- `Evarutil` was split in two parts. The new `Evardefine` file exposes functions + `define_evar_`* mostly used internally in the unification engine. -- The Refine module was move out of Proofview. +- The `Refine` module was moved out of `Proofview`. + ``` Proofview.Refine.* ---> Refine.* + ``` -- A statically monotonous evarmap type was introduced in Sigma. Not all the API +- A statically monotonic evarmap type was introduced in `Sigma`. Not all the API has been converted, so that the user may want to use compatibility functions - Sigma.to_evar_map and Sigma.Unsafe.of_evar_map or Sigma.Unsafe.of_pair when + `Sigma.to_evar_map` and `Sigma.Unsafe.of_evar_map` or `Sigma.Unsafe.of_pair` when needed. Code can be straightforwardly adapted in the following way: + ```ocaml let (sigma, x1) = ... in ... let (sigma, xn) = ... in (sigma, ans) + ``` should be turned into: + ```ocaml open Sigma.Notations let Sigma (x1, sigma, p1) = ... in ... let Sigma (xn, sigma, pn) = ... in Sigma (ans, sigma, p1 +> ... +> pn) + ``` Examples of `Sigma.Unsafe.of_evar_map` include: + ``` Evarutil.new_evar env (Tacmach.project goal) ty ----> Evarutil.new_evar env (Sigma.Unsafe.of_evar_map (Tacmach.project goal)) ty + ``` -- The Proofview.Goal.*enter family of functions now takes a polymorphic +- The `Proofview.Goal.`*`enter` family of functions now takes a polymorphic continuation given as a record as an argument. + ```ocaml Proofview.Goal.enter begin fun gl -> ... end + ``` should be turned into + ```ocaml open Proofview.Notations Proofview.Goal.enter { enter = begin fun gl -> ... end } + ``` - `Tacexpr.TacDynamic(Loc.dummy_loc, Pretyping.constr_in c)` ---> `Tacinterp.Value.of_constr c` - `Vernacexpr.HintsResolveEntry(priority, poly, hnf, path, atom)` ---> `Vernacexpr.HintsResolveEntry(Vernacexpr.({hint_priority = priority; hint_pattern = None}), poly, hnf, path, atom)` - `Pretyping.Termops.mem_named_context` ---> `Engine.Termops.mem_named_context_val` - (`Global.named_context` ---> `Global.named_context_val`) - (`Context.Named.lookup` ---> `Environ.lookup_named_val`) +- `Global.named_context` ---> `Global.named_context_val` +- `Context.Named.lookup` ---> `Environ.lookup_named_val` -** Search API ** +### Search API The main search functions now take a function iterating over the results. This allows for clients to use streaming or more economic printing. -========================================= -= CHANGES BETWEEN COQ V8.4 AND COQ V8.5 = -========================================= +## Changes between Coq 8.4 and Coq 8.5 -** Refactoring : more mli interfaces and simpler grammar.cma ** +### Refactoring : more mli interfaces and simpler grammar.cma - A new directory intf/ now contains mli-only interfaces : - Constrexpr : definition of constr_expr, was in Topconstr - Decl_kinds : now contains binding_kind = Explicit | Implicit - Evar_kinds : type Evar_kinds.t was previously Evd.hole_kind - Extend : was parsing/extend.mli - Genredexpr : regroup Glob_term.red_expr_gen and Tacexpr.glob_red_flag - Glob_term : definition of glob_constr - Locus : definition of occurrences and stuff about clauses - Misctypes : intro_pattern_expr, glob_sort, cast_type, or_var, ... - Notation_term : contains notation_constr, was Topconstr.aconstr - Pattern : contains constr_pattern - Tacexpr : was tactics/tacexpr.ml - Vernacexpr : was toplevel/vernacexpr.ml + * `Constrexpr` : definition of `constr_expr`, was in `Topconstr` + * `Decl_kinds` : now contains `binding_kind = Explicit | Implicit` + * `Evar_kinds` : type `Evar_kinds.t` was previously `Evd.hole_kind` + * `Extend` : was `parsing/extend.mli` + * `Genredexpr` : regroup `Glob_term.red_expr_gen` and `Tacexpr.glob_red_flag` + * `Glob_term` : definition of `glob_constr` + * `Locus` : definition of occurrences and stuff about clauses + * `Misctypes` : `intro_pattern_expr`, `glob_sort`, `cast_type`, `or_var`, ... + * `Notation_term` : contains `notation_constr`, was `Topconstr.aconstr` + * `Pattern` : contains `constr_pattern` + * `Tacexpr` : was `tactics/tacexpr.ml` + * `Vernacexpr` : was `toplevel/vernacexpr.ml` - Many files have been divided : - vernacexpr: vernacexpr.mli + Locality - decl_kinds: decl_kinds.mli + Kindops - evd: evar_kinds.mli + evd - tacexpr: tacexpr.mli + tacops - glob_term: glob_term.mli + glob_ops + genredexpr.mli + redops - topconstr: constrexpr.mli + constrexpr_ops - + notation_expr.mli + notation_ops + topconstr - pattern: pattern.mli + patternops - libnames: libnames (qualid, reference) + globnames (global_reference) - egrammar: egramml + egramcoq + * vernacexpr: vernacexpr.mli + Locality + * decl_kinds: decl_kinds.mli + Kindops + * evd: evar_kinds.mli + evd + * tacexpr: tacexpr.mli + tacops + * glob_term: glob_term.mli + glob_ops + genredexpr.mli + redops + * topconstr: constrexpr.mli + constrexpr_ops + + notation_expr.mli + notation_ops + topconstr + * pattern: pattern.mli + patternops + * libnames: libnames (qualid, reference) + globnames (global_reference) + * egrammar: egramml + egramcoq - New utility files : miscops (cf. misctypes.mli) and redops (cf genredexpr.mli). @@ -686,11 +720,11 @@ printing. letin_pat_tac do not accept a type anymore - New file find_subterm.ml for gathering former functions - subst_closed_term_occ_modulo, subst_closed_term_occ_decl (which now - take and outputs also an evar_map), and - subst_closed_term_occ_modulo, subst_closed_term_occ_decl_modulo (now - renamed into replace_term_occ_modulo and - replace_term_occ_decl_modulo). + `subst_closed_term_occ_modulo`, `subst_closed_term_occ_decl` (which now + take and outputs also an `evar_map`), and + `subst_closed_term_occ_modulo`, `subst_closed_term_occ_decl_modulo` (now + renamed into `replace_term_occ_modulo` and + `replace_term_occ_decl_modulo`). - API of Inductiveops made more uniform (see commit log or file itself). @@ -704,36 +738,34 @@ printing. - All functions taking an env and a sigma (or an evdref) now takes the env first. -========================================= -= CHANGES BETWEEN COQ V8.3 AND COQ V8.4 = -========================================= +## Changes between Coq 8.3 and Coq 8.4 -** Functions in unification.ml have now the evar_map coming just after the env +- Functions in unification.ml have now the evar_map coming just after the env -** Removal of Tacinterp.constr_of_id ** +- Removal of Tacinterp.constr_of_id Use instead either global_reference or construct_reference in constrintern.ml. -** Optimizing calls to Evd functions ** +- Optimizing calls to Evd functions Evars are split into defined evars and undefined evars; for efficiency, when an evar is known to be undefined, it is preferable to use specific functions about undefined evars since these ones are generally fewer than the defined ones. -** Type changes in TACTIC EXTEND rules ** +- Type changes in TACTIC EXTEND rules Arguments bound with tactic(_) in TACTIC EXTEND rules are now of type glob_tactic_expr, instead of glob_tactic_expr * tactic. Only the first component is kept, the second one can be obtained via Tacinterp.eval_tactic. -** ARGUMENT EXTEND ** +- ARGUMENT EXTEND It is now forbidden to use TYPED simultaneously with {RAW,GLOB}_TYPED in ARGUMENT EXTEND statements. -** Renaming of rawconstr to glob_constr ** +- Renaming of rawconstr to glob_constr The "rawconstr" type has been renamed to "glob_constr" for consistency. The "raw" in everything related to former rawconstr has @@ -743,62 +775,67 @@ scripts to migrate code using Coq's internals, see commits 13743, 2010) in Subversion repository. Contribs have been fixed too, and commit messages there might also be helpful for migrating. -========================================= -= CHANGES BETWEEN COQ V8.2 AND COQ V8.3 = -========================================= +## Changes between Coq 8.2 and Coq 8.3 -** Light cleaning in evarutil.ml ** +### Light cleaning in evaruil.ml whd_castappevar is now whd_head_evar obsolete whd_ise disappears -** Restructuration of the syntax of binders ** +### Restructuration of the syntax of binders +``` binders_let -> binders binders_let_fixannot -> binders_fixannot binder_let -> closed_binder (and now covers only bracketed binders) binder was already obsolete and has been removed +``` -** Semantical change of h_induction_destruct ** +### Semantical change of h_induction_destruct Warning, the order of the isrec and evar_flag was inconsistent and has been permuted. Tactic induction_destruct in tactics.ml is unchanged. -** Internal tactics renamed +### Internal tactics renamed There is no more difference between bindings and ebindings. The following tactics are therefore renamed +``` apply_with_ebindings_gen -> apply_with_bindings_gen left_with_ebindings -> left_with_bindings right_with_ebindings -> right_with_bindings split_with_ebindings -> split_with_bindings +``` and the following tactics are removed -apply_with_ebindings (use instead apply_with_bindings) -eapply_with_ebindings (use instead eapply_with_bindings) + - apply_with_ebindings (use instead apply_with_bindings) + - eapply_with_ebindings (use instead eapply_with_bindings) -** Obsolete functions in typing.ml +### Obsolete functions in typing.ml For mtype_of, msort_of, mcheck, now use type_of, sort_of, check -** Renaming functions renamed +### Renaming functions renamed +``` concrete_name -> compute_displayed_name_in concrete_let_name -> compute_displayed_let_name_in rename_rename_bound_var -> rename_bound_vars_as_displayed lookup_name_as_renamed -> lookup_name_as_displayed next_global_ident_away true -> next_ident_away_in_goal next_global_ident_away false -> next_global_ident_away +``` -** Cleaning in commmand.ml +### Cleaning in commmand.ml Functions about starting/ending a lemma are in lemmas.ml Functions about inductive schemes are in indschemes.ml Functions renamed: +``` declare_one_assumption -> declare_assumption declare_assumption -> declare_assumptions Command.syntax_definition -> Metasyntax.add_syntactic_definition @@ -815,15 +852,17 @@ instantiate_type_indrec_scheme -> weaken_sort_scheme instantiate_indrec_scheme -> modify_sort_scheme make_case_dep, make_case_nodep -> build_case_analysis_scheme make_case_gen -> build_case_analysis_scheme_default +``` Types: decl_notation -> decl_notation option -** Cleaning in libnames/nametab interfaces +### Cleaning in libnames/nametab interfaces Functions: +``` dirpath_prefix -> pop_dirpath extract_dirpath_prefix pop_dirpath_n extend_dirpath -> add_dirpath_suffix @@ -837,17 +876,19 @@ absolute_reference -> global_of_path locate_syntactic_definition -> locate_syndef path_of_syntactic_definition -> path_of_syndef push_syntactic_definition -> push_syndef +``` Types: section_path -> full_path -** Cleaning in parsing extensions (commit 12108) +### Cleaning in parsing extensions (commit 12108) Many moves and renamings, one new file (Extrawit, that contains wit_tactic). -** Cleaning in tactical.mli +### Cleaning in tactical.mli +``` tclLAST_HYP -> onLastHyp tclLAST_DECL -> onLastDecl tclLAST_NHYPS -> onNLastHypsId @@ -857,24 +898,21 @@ onLastHyp -> onLastHypId onNLastHyps -> onNLastDecls onClauses -> onClause allClauses -> allHypsAndConcl +``` -+ removal of various unused combinators on type "clause" - -========================================= -= CHANGES BETWEEN COQ V8.1 AND COQ V8.2 = -========================================= +and removal of various unused combinators on type "clause" -A few differences in Coq ML interfaces between Coq V8.1 and V8.2 -================================================================ +## Changes between Coq 8.1 and Coq 8.2 -** Datatypes +### Datatypes List of occurrences moved from "int list" to "Termops.occurrences" (an alias to "bool * int list") ETIdent renamed to ETName -** Functions +### Functions +``` Eauto: e_resolve_constr, vernac_e_resolve_constr -> simplest_eapply Tactics: apply_with_bindings -> apply_with_bindings_wo_evars Eauto.simplest_apply -> Hiddentac.h_simplest_apply @@ -884,98 +922,93 @@ Tactics.true_cut renamed into Tactics.assert_tac Constrintern.interp_constrpattern -> intern_constr_pattern Hipattern.match_with_conjunction is a bit more restrictive Hipattern.match_with_disjunction is a bit more restrictive +``` -** Universe names (univ.mli) +### Universe names (univ.mli) + ```ocaml base_univ -> type0_univ (* alias of Set is the Type hierarchy *) prop_univ -> type1_univ (* the type of Set in the Type hierarchy *) neutral_univ -> lower_univ (* semantic alias of Prop in the Type hierarchy *) is_base_univ -> is_type1_univ is_empty_univ -> is_lower_univ + ``` -** Sort names (term.mli) +### Sort names (term.mli) + ``` mk_Set -> set_sort mk_Prop -> prop_sort type_0 -> type1_sort - -========================================= -= CHANGES BETWEEN COQ V8.0 AND COQ V8.1 = -========================================= - -A few differences in Coq ML interfaces between Coq V8.0 and V8.1 -================================================================ - -** Functions - -Util: option_app -> option_map -Term: substl_decl -> subst_named_decl -Lib: library_part -> remove_section_part -Printer: prterm -> pr_lconstr -Printer: prterm_env -> pr_lconstr_env -Ppconstr: pr_sort -> pr_rawsort -Evd: in_dom, etc got standard ocaml names (i.e. mem, etc) -Pretyping: - - understand_gen_tcc and understand_gen_ltac merged into understand_ltac - - type_constraints can now say typed by a sort (use OfType to get the - previous behavior) -Library: import_library -> import_module - -** Constructors - -Declarations: mind_consnrealargs -> mind_consnrealdecls -NoRedun -> NoDup -Cast and RCast have an extra argument: you can recover the previous + ``` + +## Changes between Coq 8.0 and Coq 8.1 + +### Functions + +- Util: option_app -> option_map +- Term: substl_decl -> subst_named_decl +- Lib: library_part -> remove_section_part +- Printer: prterm -> pr_lconstr +- Printer: prterm_env -> pr_lconstr_env +- Ppconstr: pr_sort -> pr_rawsort +- Evd: in_dom, etc got standard ocaml names (i.e. mem, etc) +- Pretyping: + - understand_gen_tcc and understand_gen_ltac merged into understand_ltac + - type_constraints can now say typed by a sort (use OfType to get the + previous behavior) +- Library: import_library -> import_module + +### Constructors + + * Declarations: mind_consnrealargs -> mind_consnrealdecls + * NoRedun -> NoDup + * Cast and RCast have an extra argument: you can recover the previous behavior by setting the extra argument to "CastConv DEFAULTcast" and "DEFAULTcast" respectively -Names: "kernel_name" is now "constant" when argument of Term.Const -Tacexpr: TacTrueCut and TacForward(false,_,_) merged into new TacAssert -Tacexpr: TacForward(true,_,_) branched to TacLetTac + * Names: "kernel_name" is now "constant" when argument of Term.Const + * Tacexpr: TacTrueCut and TacForward(false,_,_) merged into new TacAssert + * Tacexpr: TacForward(true,_,_) branched to TacLetTac -** Modules +### Modules -module Decl_kinds: new interface -module Bigint: new interface -module Tacred spawned module Redexpr -module Symbols -> Notation -module Coqast, Ast, Esyntax, Termast, and all other modules related to old - syntax are removed -module Instantiate: integrated to Evd -module Pretyping now a functor: use Pretyping.Default instead + * module Decl_kinds: new interface + * module Bigint: new interface + * module Tacred spawned module Redexpr + * module Symbols -> Notation + * module Coqast, Ast, Esyntax, Termast, and all other modules related to old + syntax are removed + * module Instantiate: integrated to Evd + * module Pretyping now a functor: use Pretyping.Default instead -** Internal names +### Internal names OBJDEF and OBJDEF1 -> CANONICAL-STRUCTURE -** Tactic extensions +### Tactic extensions -- printers have an extra parameter which is a constr printer at high precedence -- the tactic printers have an extra arg which is the expected precedence -- level is now a precedence in declare_extra_tactic_pprule -- "interp" functions now of types the actual arg type, not its encapsulation - as a generic_argument + * printers have an extra parameter which is a constr printer at high precedence + * the tactic printers have an extra arg which is the expected precedence + * level is now a precedence in declare_extra_tactic_pprule + * "interp" functions now of types the actual arg type, not its encapsulation + as a generic_argument -========================================= -= CHANGES BETWEEN COQ V7.4 AND COQ V8.0 = -========================================= +## Changes between Coq 7.4 and Coq 8.0 See files in dev/syntax-v8 -============================================== -= MAIN CHANGES BETWEEN COQ V7.3 AND COQ V7.4 = -============================================== +## Main changes between Coq 7.4 and Coq 8.0 -CHANGES DUE TO INTRODUCTION OF MODULES -====================================== +### Changes due to introduction of modules -1.Kernel --------- +#### Kernel The module level has no effect on constr except for the structure of section_path. The type of unique names for constructions (what section_path served) is now called a kernel name and is defined by +```ocaml type uniq_ident = int * string * dir_path (* int may be enough *) type module_path = | MPfile of dir_path (* reference to physical module, e.g. file *) @@ -1002,7 +1035,8 @@ type kernel_name = module_path * dir_path * label Def u = ... end Def x := ... <M>.t ... <N>.O.u ... X.T.b ... L.A.a - +``` + <M> and <N> are self-references, X is a bound reference and L is a reference to a physical module. @@ -1019,14 +1053,13 @@ world. module_expr) and kernel/declarations.ml (type module_body and module_type_body). -2. Library ----------- +#### Library -i) tables +1. tables [Summaries] - the only change is the special treatment of the global environmet. -ii) objects +2. objects [Libobject] declares persistent objects, given with methods: * cache_function specifying how to add the object in the current @@ -1047,25 +1080,25 @@ Coq.Init.Datatypes.Fst) and kernel_name is its substitutive internal version such as (MPself<Datatypes#1>,[],"Fst") (see above) -What happens at the end of an interactive module ? -================================================== +#### What happens at the end of an interactive module ? + (or when a file is stored and reloaded from disk) All summaries (except Global environment) are reverted to the state from before the beginning of the module, and: -a) the objects (again, since last Declaremods.start_module or +1. the objects (again, since last Declaremods.start_module or Library.start_library) are classified using the classify_function. To simplify consider only those who returned Substitute _ or Keep _. -b) If the module is not a functor, the subst_function for each object of +2. If the module is not a functor, the subst_function for each object of the first group is called with the substitution [MPself "<Datatypes#1>" |-> MPfile "Coq.Init.Datatypes"]. Then the load_function is called for substituted objects and the "keep" object. (If the module is a library the substitution is done at reloading). -c) The objects which returned substitute are stored in the modtab +3. The objects which returned substitute are stored in the modtab together with the self ident of the module, and functor argument names if the module was a functor. @@ -1075,9 +1108,9 @@ c) The objects which returned substitute are stored in the modtab is evaluated -The difference between "substitute" and "keep" objects -======================================================== -i) The "keep" objects can _only_ reference other objects by section_paths +#### The difference between "substitute" and "keep" objects + +1. The "keep" objects can _only_ reference other objects by section_paths and qualids. They do not need the substitution function. They will work after end_module (or reloading a compiled library), @@ -1089,7 +1122,7 @@ These would typically be grammar rules, pretty printing rules etc. -ii) The "substitute" objects can _only_ reference objects by +2. The "substitute" objects can _only_ reference objects by kernel_names. They must have a valid subst_function. They will work after end_module _and_ after Module Z:=N or @@ -1098,17 +1131,18 @@ Module Z:=F(M). Other kinds of objects: -iii) "Dispose" - objects which do not survive end_module + +3. "Dispose" - objects which do not survive end_module As a consequence, objects which reference other objects sometimes by kernel_names and sometimes by section_path must be of this kind... -iv) "Anticipate" - objects which must be treated individually by +4. "Anticipate" - objects which must be treated individually by end_module (typically "REQUIRE" objects) -Writing subst_thing functions -============================= +#### Writing subst_thing functions + The subst_thing shoud not copy the thing if it hasn't actually changed. There are some cool emacs macros in dev/objects.el to help writing subst functions this way quickly and without errors. @@ -1123,15 +1157,13 @@ They are all (apart from constr, for now) written in the non-copying way. -Nametab -======= +#### Nametab Nametab has been made more uniform. For every kind of thing there is only one "push" function and one "locate" function. -Lib -=== +#### Lib library_segment is now a list of object_name * library_item, where object_name = section_path * kernel_name (see above) @@ -1139,20 +1171,19 @@ object_name = section_path * kernel_name (see above) New items have been added for open modules and module types -Declaremods -========== +#### Declaremods + Functions to declare interactive and noninteractive modules and module types. -Library -======= +#### Library + Uses Declaremods to actually communicate with Global and to register objects. -OTHER CHANGES -============= +### Other changes Internal representation of tactics bindings has changed (see type Rawterm.substitution). @@ -1169,258 +1200,48 @@ New parsing model for tactics and vernacular commands TACTIC EXTEND ... END to be used in ML files New organisation of THENS: -tclTHENS tac tacs : tacs is now an array -tclTHENSFIRSTn tac1 tacs tac2 : + +- tclTHENS tac tacs : tacs is now an array +- tclTHENSFIRSTn tac1 tacs tac2 : apply tac1 then, apply the array tacs on the first n subgoals and tac2 on the remaining subgoals (previously tclTHENST) -tclTHENSLASTn tac1 tac2 tacs : +- tclTHENSLASTn tac1 tac2 tacs : apply tac1 then, apply tac2 on the first subgoals and apply the array tacs on the last n subgoals -tclTHENFIRSTn tac1 tacs = tclTHENSFIRSTn tac1 tacs tclIDTAC (prev. tclTHENSI) -tclTHENLASTn tac1 tacs = tclTHENSLASTn tac1 tclIDTAC tacs -tclTHENFIRST tac1 tac2 = tclTHENFIRSTn tac1 [|tac2|] -tclTHENLAST tac1 tac2 = tclTHENLASTn tac1 [|tac2|] (previously tclTHENL) -tclTHENS tac1 tacs = tclTHENSFIRSTn tac1 tacs (fun _ -> error "wrong number") -tclTHENSV same as tclTHENS but with an array -tclTHENSi : no longer available +- tclTHENFIRSTn tac1 tacs = tclTHENSFIRSTn tac1 tacs tclIDTAC (prev. tclTHENSI) +- tclTHENLASTn tac1 tacs = tclTHENSLASTn tac1 tclIDTAC tacs +- tclTHENFIRST tac1 tac2 = tclTHENFIRSTn tac1 [|tac2|] +- tclTHENLAST tac1 tac2 = tclTHENLASTn tac1 [|tac2|] (previously tclTHENL) +- tclTHENS tac1 tacs = tclTHENSFIRSTn tac1 tacs (fun _ -> error "wrong number") +- tclTHENSV same as tclTHENS but with an array +- tclTHENSi : no longer available Proof_type: subproof field in type proof_tree glued with the ref field Tacmach: no more echo from functions of module Refiner Files plugins/*/g_*.ml4 take the place of files plugins/*/*.v. + Files parsing/{vernac,tac}extend.ml{4,i} implements TACTIC EXTEND andd VERNAC COMMAND EXTEND macros + File syntax/PPTactic.v moved to parsing/pptactic.ml + Tactics about False and not now in tactics/contradiction.ml + Tactics depending on Init now tactics/*.ml4 (no longer in tactics/*.v) + File tacinterp.ml moved from proofs to directory tactics -========================================== -= MAIN CHANGES FROM COQ V7.1 TO COQ V7.2 = -========================================== +## Changes between Coq 7.1 and Coq 7.2 The core of Coq (kernel) has meen minimized with the following effects: -kernel/term.ml split into kernel/term.ml, pretyping/termops.ml -kernel/reduction.ml split into kernel/reduction.ml, pretyping/reductionops.ml -kernel/names.ml split into kernel/names.ml, library/nameops.ml -kernel/inductive.ml split into kernel/inductive.ml, pretyping/inductiveops.ml +- kernel/term.ml split into kernel/term.ml, pretyping/termops.ml +- kernel/reduction.ml split into kernel/reduction.ml, pretyping/reductionops.ml +- kernel/names.ml split into kernel/names.ml, library/nameops.ml +- kernel/inductive.ml split into kernel/inductive.ml, pretyping/inductiveops.ml the prefixes "Is" ans "IsMut" have been dropped from kind_of_term constructors, e.g. IsRel is now Rel, IsMutCase is now Case, etc. - - -======================================================= -= PRINCIPAUX CHANGEMENTS ENTRE COQ V6.3.1 ET COQ V7.0 = -======================================================= - -Changements d'organisation / modules : --------------------------------------- - - Std, More_util -> lib/util.ml - - Names -> kernel/names.ml et kernel/sign.ml - (les parties noms et signatures ont été séparées) - - Avm,Mavm,Fmavm,Mhm -> utiliser plutôt Map (et freeze alors gratuit) - Mhb -> Bij - - Generic est intégré à Term (et un petit peu à Closure) - -Changements dans les types de données : ---------------------------------------- - dans Generic: free_rels : constr -> int Listset.t - devient : constr -> Intset.t - - type_judgement -> typed_type - environment -> context - context -> typed_type signature - - -ATTENTION: ----------- - - Il y a maintenant d'autres exceptions que UserError (TypeError, - RefinerError, etc.) - - Il ne faut donc plus se contenter (pour rattraper) de faire - - try . .. with UserError _ -> ... - - mais écrire à la place - - try ... with e when Logic.catchable_exception e -> ... - - -Changements dans les fonctions : --------------------------------- - - Vectops. - it_vect -> Array.fold_left - vect_it -> Array.fold_right - exists_vect -> Util.array_exists - for_all2eq_vect -> Util.array_for_all2 - tabulate_vect -> Array.init - hd_vect -> Util.array_hd - tl_vect -> Util.array_tl - last_vect -> Util.array_last - it_vect_from -> array_fold_left_from - vect_it_from -> array_fold_right_from - app_tl_vect -> array_app_tl - cons_vect -> array_cons - map_i_vect -> Array.mapi - map2_vect -> array_map2 - list_of_tl_vect -> array_list_of_tl - - Names - sign_it -> fold_var_context (se fait sur env maintenant) - it_sign -> fold_var_context_reverse (sur env maintenant) - - Generic - noccur_bet -> noccur_between - substn_many -> substnl - - Std - comp -> Util.compose - rev_append -> List.rev_append - - Termenv - mind_specif_of_mind -> Global.lookup_mind_specif - ou Environ.lookup_mind_specif si on a un env sous la main - mis_arity -> instantiate_arity - mis_lc -> instantiate_lc - - Ex-Environ - mind_of_path -> Global.lookup_mind - - Printer - gentermpr -> gen_pr_term - term0 -> prterm_env - pr_sign -> pr_var_context - pr_context_opt -> pr_context_of - pr_ne_env -> pr_ne_context_of - - Typing, Machops - type_of_type -> judge_of_type - fcn_proposition -> judge_of_prop_contents - safe_fmachine -> safe_infer - - Reduction, Clenv - whd_betadeltat -> whd_betaevar - whd_betadeltatiota -> whd_betaiotaevar - find_mrectype -> Inductive.find_mrectype - find_minductype -> Inductive.find_inductive - find_mcoinductype -> Inductive.find_coinductive - - Astterm - constr_of_com_casted -> interp_casted_constr - constr_of_com_sort -> interp_type - constr_of_com -> interp_constr - rawconstr_of_com -> interp_rawconstr - type_of_com -> type_judgement_of_rawconstr - judgement_of_com -> judgement_of_rawconstr - - Termast - bdize -> ast_of_constr - - Tacmach - pf_constr_of_com_sort -> pf_interp_type - pf_constr_of_com -> pf_interp_constr - pf_get_hyp -> pf_get_hyp_typ - pf_hyps, pf_untyped_hyps -> pf_env (tout se fait sur env maintenant) - - Pattern - raw_sopattern_of_compattern -> Astterm.interp_constrpattern - somatch -> is_matching - dest_somatch -> matches - - Tacticals - matches -> gl_is_matching - dest_match -> gl_matches - suff -> utiliser sort_of_goal - lookup_eliminator -> utiliser sort_of_goal pour le dernier arg - - Divers - initial_sign -> var_context - - Sign - ids_of_sign -> ids_of_var_context (or Environ.ids_of_context) - empty_sign -> empty_var_context - - Pfedit - list_proofs -> get_all_proof_names - get_proof -> get_current_proof_name - abort_goal -> abort_proof - abort_goals -> abort_all_proofs - abort_cur_goal -> abort_current_proof - get_evmap_sign -> get_goal_context/get_current_goal_context - unset_undo -> reset_undo - - Proof_trees - mkGOAL -> mk_goal - - Declare - machine_constant -> declare_constant (+ modifs) - - ex-Trad, maintenant Pretyping - inh_cast_rel -> Coercion.inh_conv_coerce_to - inh_conv_coerce_to -> Coercion.inh_conv_coerce_to_fail - ise_resolve1 -> understand, understand_type - ise_resolve -> understand_judgment, understand_type_judgment - - ex-Tradevar, maintenant Evarutil - mt_tycon -> empty_tycon - - Recordops - struc_info -> find_structure - -Changements dans les inductifs ------------------------------- -Nouveaux types "constructor" et "inductive" dans Term -La plupart des fonctions de typage des inductives prennent maintenant -un inductive au lieu d'un oonstr comme argument. Les seules fonctions -à traduire un constr en inductive sont les find_rectype and co. - -Changements dans les grammaires -------------------------------- - - . le lexer (parsing/lexer.mll) est maintenant un lexer ocamllex - - . attention : LIDENT -> IDENT (les identificateurs n'ont pas de - casse particulière dans Coq) - - . Le mot "command" est remplacé par "constr" dans les noms de - fichiers, noms de modules et non-terminaux relatifs au parsing des - termes; aussi les changements suivants "COMMAND"/"CONSTR" dans - g_vernac.ml4, VARG_COMMAND/VARG_CONSTR dans vernac*.ml* - - . Les constructeurs d'arguments de tactiques IDENTIFIER, CONSTR, ...n - passent en minuscule Identifier, Constr, ... - - . Plusieurs parsers ont changé de format (ex: sortarg) - -Changements dans le pretty-printing ------------------------------------ - - . Découplage de la traduction de constr -> rawconstr (dans detyping) - et de rawconstr -> ast (dans termast) - . Déplacement des options d'affichage de printer vers termast - . Déplacement des réaiguillage d'univers du pp de printer vers esyntax - - -Changements divers ------------------- - - . il n'y a plus de script coqtop => coqtop et coqtop.byte sont - directement le résultat du link du code - => debuggage et profiling directs - - . il n'y a plus d'installation locale dans bin/$ARCH - - . #use "include.ml" => #use "include" - go() => loop() - - . il y a "make depend" et "make dependcamlp4" car ce dernier prend beaucoup - de temps diff --git a/dev/doc/coq-src-description.txt b/dev/doc/coq-src-description.txt index 00e7f5c53c..2dbd132da7 100644 --- a/dev/doc/coq-src-description.txt +++ b/dev/doc/coq-src-description.txt @@ -14,11 +14,6 @@ parsing tactics toplevel -highparsing : - - Files in parsing/ that cannot be linked too early. - Contains the grammar rules g_*.ml4 - Special components ------------------ diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index 713f344cbe..7af4e9313a 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -279,15 +279,78 @@ of the chapter devoted to coercions. \label{prim-proj} The option {\tt Set Primitive Projections} turns on the use of primitive -projections when defining subsequent records. Primitive projections +projections when defining subsequent records (even through the {\tt + Inductive} and {\tt CoInductive} commands). Primitive projections extended the Calculus of Inductive Constructions with a new binary term constructor {\tt r.(p)} representing a primitive projection p applied to a record object {\tt r} (i.e., primitive projections are always applied). Even if the record type has parameters, these do not appear at applications of the projection, considerably reducing the sizes of terms when manipulating parameterized records and typechecking time. On the -user level, primitive projections are a transparent replacement -for the usual defined ones. +user level, primitive projections can be used as a replacement for the +usual defined ones, although there are a few notable differences. + +The internally omitted parameters can be reconstructed at printing time +even though they are absent in the actual AST manipulated by the kernel. This +can be obtained by setting the {\tt Printing Primitive Projection Parameters} +flag. Another compatibility printing can be activated thanks to the +{\tt Printing Primitive Projection Compatibility} option which governs the +printing of pattern-matching over primitive records. + +\subsubsection{Primitive Record Types} +When the {\tt Set Primitive Projections} option is on, definitions of +record types change meaning. When a type is declared with primitive +projections, its {\tt match} construct is disabled (see +\ref{primproj:compat} though). To eliminate the (co-)inductive type, one +must use its defined primitive projections. + +There are currently two ways to introduce primitive records types: +\begin{itemize} +\item Through the {\tt Record} command, in which case the type has to be + non-recursive. The defined type enjoys eta-conversion definitionally, + that is the generalized form of surjective pairing for records: + {\tt $r$ = Build\_R ($r$.($p_1$) .. $r$.($p_n$))}. Eta-conversion allows to define + dependent elimination for these types as well. +\item Through the {\tt Inductive} and {\tt CoInductive} commands, when + the body of the definition is a record declaration of the form {\tt + Build\_R \{ $p_1$ : $t_1$; .. ; $p_n$ : $t_n$ \}}. In this case the types can be + recursive and eta-conversion is disallowed. These kind of record types + differ from their traditional versions in the sense that dependent + elimination is not available for them and only non-dependent case analysis + can be defined. +\end{itemize} + +\subsubsection{Reduction} + +The basic reduction rule of a primitive projection is {\tt $p_i$ + (Build\_R $t_1$ .. $t_n$) $\rightarrow_{\iota}$ $t_i$}. However, to take the $\delta$ flag into +account, projections can be in two states: folded or unfolded. An +unfolded primitive projection application obeys the rule above, while +the folded version delta-reduces to the unfolded version. This allows to +precisely mimic the usual unfolding rules of constants. Projections +obey the usual {\tt simpl} flags of the {\tt Arguments} command in particular. + +There is currently no way to input unfolded primitive projections at the +user-level, and one must use the {\tt Printing Primitive Projection + Compatibility} to display unfolded primitive projections as matches +and distinguish them from folded ones. + +\subsubsection{Compatibility Projections and {\tt match}} +\label{primproj:compat} +To ease compatibility with ordinary record types, each primitive +projection is also defined as a ordinary constant taking parameters and +an object of the record type as arguments, and whose body is an +application of the unfolded primitive projection of the same name. These +constants are used when elaborating partial applications of the +projection. One can distinguish them from applications of the primitive +projection if the {\tt Printing Primitive Projection Parameters} option +is off: for a primitive projection application, parameters are printed +as underscores while for the compatibility projections they are printed +as usual. + +Additionally, user-written {\tt match} constructs on primitive records +are desugared into substitution of the projections, they cannot be +printed back as {\tt match} constructs. % - r.(p) and (p r) elaborate to native projection application, and % the parameters cannot be mentioned. The following arguments are @@ -305,13 +368,6 @@ for the usual defined ones. % - [pattern x at n], [rewrite x at n] and in general abstraction and selection % of occurrences may fail due to the disappearance of parameters. -The internally omitted parameters can be reconstructed at printing time -even though they are absent in the actual AST manipulated by the kernel. This -can be obtained by setting the {\tt Printing Primitive Projection Parameters} -flag. Another compatibility printing can be activated thanks to the -{\tt Printing Primitive Projection Compatibility} option which governs the -printing of pattern-matching over primitive records. - \section{Variants and extensions of {\mbox{\tt match}} \label{Extensions-of-match} \index{match@{\tt match\ldots with\ldots end}}} @@ -1664,7 +1720,7 @@ to be given as if none arguments were implicit. By symmetry, this also affects printing. To restore parsing and normal printing of implicit arguments, use: \begin{quote} -{\tt Set Parsing Explicit.} +{\tt Unset Parsing Explicit.} \end{quote} \subsection{Canonical structures diff --git a/doc/refman/RefMan-ssr.tex b/doc/refman/RefMan-ssr.tex index 61f7421c44..db794e5a63 100644 --- a/doc/refman/RefMan-ssr.tex +++ b/doc/refman/RefMan-ssr.tex @@ -42,7 +42,7 @@ Proofs written in \ssr{} typically look quite different from the ones written using only tactics as per Chapter~\ref{Tactics}. We try to summarise here the most ``visible'' ones in order to help the reader already accustomed to the tactics described in -Chapter~\ref{Tactics}to read this chapter. +Chapter~\ref{Tactics} to read this chapter. The first difference between the tactics described in this chapter and the tactics described in Chapter~\ref{Tactics} is the way @@ -79,19 +79,19 @@ expansion and partial evaluation participate all to a same concept of rewriting a goal in a larger sense. As such, all these functionalities are provided by the \ssrC{rewrite} tactic. -\ssrC{} includes a little language of patterns to select subterms in tactics +\ssr{} includes a little language of patterns to select subterms in tactics or tacticals where it matters. Its most notable application is in the \ssrC{rewrite} tactic, where patterns are used to specify where the rewriting step has to take place. -Finally, \ssr{} supports the so-called reflection steps, typically +Finally, \ssr{} supports so-called reflection steps, typically allowing to switch back and forth between the computational view and logical view of a concept. To conclude it is worth mentioning that \ssr{} tactics can be mixed with non \ssr{} tactics in the same proof, -or in the same LTac expression. The few exceptions -to this statement are described in section~\label{sec:compat}. +or in the same Ltac expression. The few exceptions +to this statement are described in section~\ref{sec:compat}. \iffalse %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -130,7 +130,7 @@ ProofGeneral provided in the distribution: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection*{Acknowledgments} -The authors would like to thank Fr\'ed\'eric Blanqui, Fran\,cois Pottier +The authors would like to thank Frédéric Blanqui, François Pottier and Laurence Rideau for their comments and suggestions. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 6e27357008..8fbcfdf308 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -3309,7 +3309,7 @@ evaluating purely computational expressions (i.e. with little dead code). fine-tuned. It is specially interesting for full evaluation of algebraic objects. This includes the case of reflection-based tactics. -\item {\tt native\_compute} \tacindex{native\_compute} +\item {\tt native\_compute} \tacindex{native\_compute} \optindex{NativeCompute Profiling} This tactic evaluates the goal by compilation to \ocaml{} as described in \cite{FullReduction}. If \Coq{} is running in native code, it can be typically diff --git a/doc/refman/Setoid.tex b/doc/refman/Setoid.tex index 6c79284389..0c8cd408f2 100644 --- a/doc/refman/Setoid.tex +++ b/doc/refman/Setoid.tex @@ -223,7 +223,7 @@ the following command. \comindex{Add Parametric Morphism} \begin{quote} - \texttt{Add Parametric Morphism} ($x_1 : \T_!$) \ldots ($x_k : \T_k$)\\ + \texttt{Add Parametric Morphism} ($x_1 : \T_1$) \ldots ($x_k : \T_k$) : (\textit{f $t_1$ \ldots $t_n$})\\ \texttt{~with signature} \textit{sig}\\ \texttt{~as id}.\\ diff --git a/engine/termops.ml b/engine/termops.ml index 2bd0c06d6d..e2bdf72387 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -1165,6 +1165,24 @@ let rec is_Prop sigma c = match EConstr.kind sigma c with | Cast (c,_,_) -> is_Prop sigma c | _ -> false +let rec is_Set sigma c = match EConstr.kind sigma c with + | Sort u -> + begin match EConstr.ESorts.kind sigma u with + | Prop Pos -> true + | _ -> false + end + | Cast (c,_,_) -> is_Set sigma c + | _ -> false + +let rec is_Type sigma c = match EConstr.kind sigma c with + | Sort u -> + begin match EConstr.ESorts.kind sigma u with + | Type _ -> true + | _ -> false + end + | Cast (c,_,_) -> is_Type sigma c + | _ -> false + (* eq_constr extended with universe erasure *) let compare_constr_univ sigma f cv_pb t1 t2 = let open EConstr in diff --git a/engine/termops.mli b/engine/termops.mli index 2624afd30d..ef2c52a455 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -267,6 +267,8 @@ val isGlobalRef : Evd.evar_map -> constr -> bool val is_template_polymorphic : env -> Evd.evar_map -> constr -> bool val is_Prop : Evd.evar_map -> constr -> bool +val is_Set : Evd.evar_map -> constr -> bool +val is_Type : Evd.evar_map -> constr -> bool (** Combinators on judgments *) diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 364fc883ba..9be70e6d38 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -463,7 +463,7 @@ object(self) self#attach_tooltip ~loc sentence (Printf.sprintf "%s %s %s" filepath ident ty) | Message(Error, loc, msg), Some (id,sentence) -> - log_pp ?id Pp.(str "ErrorMsg" ++ msg); + log_pp ?id Pp.(str "ErrorMsg " ++ msg); remove_flag sentence `PROCESSING; let rmsg = Pp.string_of_ppcmds msg in add_flag sentence (`ERROR (loc, rmsg)); @@ -471,17 +471,17 @@ object(self) self#attach_tooltip ?loc sentence rmsg; self#position_tag_at_sentence ?loc Tags.Script.error sentence | Message(Warning, loc, msg), Some (id,sentence) -> - log_pp ?id Pp.(str "WarningMsg" ++ msg); + log_pp ?id Pp.(str "WarningMsg " ++ msg); let rmsg = Pp.string_of_ppcmds msg in add_flag sentence (`WARNING (loc, rmsg)); self#attach_tooltip ?loc sentence rmsg; self#position_tag_at_sentence ?loc Tags.Script.warning sentence; messages#push Warning msg | Message(lvl, loc, msg), Some (id,sentence) -> - log_pp ?id Pp.(str "Msg" ++ msg); + log_pp ?id Pp.(str "Msg " ++ msg); messages#push lvl msg | Message(lvl, loc, msg), None -> - log_pp Pp.(str "Msg" ++ msg); + log_pp Pp.(str "Msg " ++ msg); messages#push lvl msg | InProgress n, _ -> if n < 0 then processed <- processed + abs n diff --git a/ide/coqide.ml b/ide/coqide.ml index 7b65c9fec9..2c8ce0049e 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -439,7 +439,9 @@ let compile sn = match sn.fileops#filename with |None -> flash_info "Active buffer has no name" |Some f -> - let cmd = cmd_coqc#get ^ " -I " ^ (Filename.quote (Filename.dirname f)) + let args = Coq.get_arguments sn.coqtop in + let cmd = cmd_coqc#get + ^ " " ^ String.concat " " args ^ " " ^ (Filename.quote f) ^ " 2>&1" in let buf = Buffer.create 1024 in diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 67391f5567..b11a11606f 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -1,5 +1,4 @@ (************************************************************************) - (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) (* \VV/ **************************************************************) diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 2d0a19b9a6..771c137344 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -320,13 +320,13 @@ let coerce_reference_to_id = function (str "This expression should be a simple identifier.") let coerce_to_id = function - | { CAst.v = CRef (Ident (loc,id),_); _ } -> (loc,id) + | { CAst.v = CRef (Ident (loc,id),None) } -> (loc,id) | { CAst.loc; _ } -> CErrors.user_err ?loc ~hdr:"coerce_to_id" (str "This expression should be a simple identifier.") let coerce_to_name = function - | { CAst.v = CRef (Ident (loc,id),_) } -> (loc,Name id) - | { CAst.loc; CAst.v = CHole (_,_,_) } -> (loc,Anonymous) + | { CAst.v = CRef (Ident (loc,id),None) } -> (loc,Name id) + | { CAst.loc; CAst.v = CHole (None,Misctypes.IntroAnonymous,None) } -> (loc,Anonymous) | { CAst.loc; _ } -> CErrors.user_err ?loc ~hdr:"coerce_to_name" (str "This expression should be a name.") diff --git a/interp/constrextern.ml b/interp/constrextern.ml index e85415bed3..f5eff693ff 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -298,7 +298,7 @@ let add_patt_for_params ind l = let add_cpatt_for_params ind l = if !Flags.in_debugger then l else - Util.List.addn (Inductiveops.inductive_nparamdecls ind) (CAst.make @@ PatVar Anonymous) l + Util.List.addn (Inductiveops.inductive_nparamdecls ind) (DAst.make @@ PatVar Anonymous) l let drop_implicits_in_patt cst nb_expl args = let impl_st = (implicits_of_global cst) in @@ -376,6 +376,10 @@ let pattern_printable_in_both_syntax (ind,_ as c) = (List.for_all is_status_implicit params)&&(List.for_all (fun x -> not (is_status_implicit x)) args) ) impl_st +let lift f c = + let loc = c.CAst.loc in + CAst.make ?loc (f ?loc (DAst.get c)) + (* Better to use extern_glob_constr composed with injection/retraction ?? *) let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = try @@ -392,7 +396,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = extern_notation_pattern scopes vars pat (uninterp_cases_pattern_notations pat) with No_match -> - CAst.map_with_loc (fun ?loc -> function + lift (fun ?loc -> function | PatVar (Name id) -> CPatAtom (Some (Ident (loc,id))) | PatVar (Anonymous) -> CPatAtom None | PatCstr(cstrsp,args,na) -> @@ -482,7 +486,7 @@ and extern_notation_pattern (tmp_scope,scopes as allscopes) vars t = function try if is_inactive_rule keyrule then raise No_match; let loc = t.loc in - match t.v with + match DAst.get t with | PatCstr (cstr,_,na) -> let p = apply_notation_to_pattern ?loc (ConstructRef cstr) (match_notation_constr_cases_pattern t pat) allscopes vars keyrule in @@ -645,8 +649,12 @@ let extern_args extern env args = let map (arg, argscopes) = lazy (extern argscopes env arg) in List.map map args -let match_coercion_app = function - | {loc; v = GApp ({ v = GRef (r,_) },args)} -> Some (loc, r, 0, args) +let match_coercion_app c = match DAst.get c with + | GApp (r, args) -> + begin match DAst.get r with + | GRef (r,_) -> Some (c.CAst.loc, r, 0, args) + | _ -> None + end | _ -> None let rec remove_coercions inctx c = @@ -668,14 +676,20 @@ let rec remove_coercions inctx c = been confused with ordinary application or would have need a surrounding context and the coercion to funclass would have been made explicit to match *) - if List.is_empty l then a' else CAst.make ?loc @@ GApp (a',l) + if List.is_empty l then a' else DAst.make ?loc @@ GApp (a',l) | _ -> c with Not_found -> c) | _ -> c -let rec flatten_application = function - | {loc; v = GApp ({ v = GApp(a,l')},l)} -> flatten_application (CAst.make ?loc @@ GApp (a,l'@l)) - | a -> a +let rec flatten_application c = match DAst.get c with + | GApp (f, l) -> + begin match DAst.get f with + | GApp(a,l') -> + let loc = c.CAst.loc in + flatten_application (DAst.make ?loc @@ GApp (a,l'@l)) + | _ -> c + end + | a -> c (**********************************************************************) (* mapping glob_constr to numerals (in presence of coercions, choose the *) @@ -702,10 +716,12 @@ let extern_optimal_prim_token scopes r r' = let extended_glob_local_binder_of_decl loc = function | (p,bk,None,t) -> GLocalAssum (p,bk,t) - | (p,bk,Some x, { v = GHole ( _, Misctypes.IntroAnonymous, None) } ) -> GLocalDef (p,bk,x,None) - | (p,bk,Some x,t) -> GLocalDef (p,bk,x,Some t) + | (p,bk,Some x, t) -> + match DAst.get t with + | GHole (_, Misctypes.IntroAnonymous, None) -> GLocalDef (p,bk,x,None) + | _ -> GLocalDef (p,bk,x,Some t) -let extended_glob_local_binder_of_decl ?loc u = CAst.make ?loc (extended_glob_local_binder_of_decl loc u) +let extended_glob_local_binder_of_decl ?loc u = DAst.make ?loc (extended_glob_local_binder_of_decl loc u) (**********************************************************************) (* mapping glob_constr to constr_expr *) @@ -730,7 +746,7 @@ let rec extern inctx scopes vars r = 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'') - with No_match -> CAst.map_with_loc (fun ?loc -> function + with No_match -> lift (fun ?loc -> function | GRef (ref,us) -> extern_global (select_stronger_impargs (implicits_of_global ref)) (extern_reference ?loc vars ref) (extern_universes us) @@ -749,8 +765,9 @@ let rec extern inctx scopes vars r = | Evar_kinds.FirstOrderPatVar n -> CEvar (n,[])) | GApp (f,args) -> - (match f with - | {loc = rloc; v = GRef (ref,us) } -> + (match DAst.get f with + | GRef (ref,us) -> + let rloc = f.CAst.loc in let subscopes = find_arguments_scope ref in let args = fill_arg_scopes args subscopes (snd scopes) in begin @@ -825,8 +842,8 @@ let rec extern inctx scopes vars r = (cases_predicate_names tml) vars in let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in let tml = List.map (fun (tm,(na,x)) -> - let na' = match na,tm with - | Anonymous, { v = GVar id } -> + let na' = match na, DAst.get tm with + | Anonymous, GVar id -> begin match rtntypopt with | None -> None | Some ntn -> @@ -835,12 +852,12 @@ let rec extern inctx scopes vars r = else None end | Anonymous, _ -> None - | Name id, { v = GVar id' } when Id.equal id id' -> None + | Name id, GVar id' when Id.equal id id' -> None | Name _, _ -> Some (Loc.tag na) in (sub_extern false scopes vars tm, na', Option.map (fun (loc,(ind,nal)) -> - let args = List.map (fun x -> CAst.make @@ PatVar x) nal in + let args = List.map (fun x -> DAst.make @@ PatVar x) nal in let fullargs = add_cpatt_for_params ind args in extern_ind_pattern_in_scope scopes vars ind fullargs ) x)) @@ -931,14 +948,16 @@ and factorize_lambda inctx scopes vars na bk aty c = and extern_local_binder scopes vars = function [] -> ([],[],[]) - | { v = GLocalDef (na,bk,bd,ty)}::l -> + | b :: l -> + match DAst.get b with + | GLocalDef (na,bk,bd,ty) -> let (assums,ids,l) = extern_local_binder scopes (Name.fold_right Id.Set.add na vars) l in (assums,na::ids, CLocalDef((Loc.tag na), extern false scopes vars bd, Option.map (extern false scopes vars) ty) :: l) - | { v = GLocalAssum (na,bk,ty)}::l -> + | GLocalAssum (na,bk,ty) -> let ty = extern_typ scopes vars ty in (match extern_local_binder scopes (Name.fold_right Id.Set.add na vars) l with (assums,ids,CLocalAssum(nal,k,ty')::l) @@ -951,7 +970,7 @@ and extern_local_binder scopes vars = function (na::assums,na::ids, CLocalAssum([(Loc.tag na)],Default bk,ty) :: l)) - | { v = GLocalPattern ((p,_),_,bk,ty)}::l -> + | GLocalPattern ((p,_),_,bk,ty) -> let ty = if !Flags.raw_print then Some (extern_typ scopes vars ty) else None in let p = extern_cases_pattern vars p in @@ -969,12 +988,12 @@ and extern_notation (tmp_scope,scopes as allscopes) vars t = function try if is_inactive_rule keyrule then raise No_match; (* Adjusts to the number of arguments expected by the notation *) - let (t,args,argsscopes,argsimpls) = match t.v ,n with + let (t,args,argsscopes,argsimpls) = match DAst.get t ,n with | GApp (f,args), Some n when List.length args >= n -> let args1, args2 = List.chop n args in let subscopes, impls = - match f.v with + match DAst.get f with | GRef (ref,us) -> let subscopes = try List.skipn n (find_arguments_scope ref) @@ -987,15 +1006,19 @@ and extern_notation (tmp_scope,scopes as allscopes) vars t = function subscopes,impls | _ -> [], [] in - (if Int.equal n 0 then f else CAst.make @@ GApp (f,args1)), + (if Int.equal n 0 then f else DAst.make @@ GApp (f,args1)), args2, subscopes, impls - | GApp ({ v = GRef (ref,us) } as f, args), None -> + | GApp (f, args), None -> + begin match DAst.get f with + | GRef (ref,us) -> let subscopes = find_arguments_scope ref in let impls = select_impargs_size (List.length args) (implicits_of_global ref) in f, args, subscopes, impls - | GRef (ref,us), Some 0 -> CAst.make @@ GApp (t,[]), [], [], [] + | _ -> t, [], [], [] + end + | GRef (ref,us), Some 0 -> DAst.make @@ GApp (t,[]), [], [], [] | _, None -> t, [], [], [] | _ -> raise No_match in (* Try matching ... *) @@ -1065,7 +1088,7 @@ let extern_constr_gen lax goal_concl_style scopt env sigma t = (* those goal/section/rel variables that occurs in the subterm under *) (* consideration; see namegen.ml for further details *) let avoid = if goal_concl_style then ids_of_context env else [] in - let r = Detyping.detype ~lax:lax goal_concl_style avoid env sigma t in + let r = Detyping.detype Detyping.Later ~lax:lax goal_concl_style avoid env sigma t in let vars = vars_of_env env in extern false (scopt,[]) vars r @@ -1077,7 +1100,7 @@ let extern_constr ?(lax=false) goal_concl_style env sigma t = let extern_type goal_concl_style env sigma t = let avoid = if goal_concl_style then ids_of_context env else [] in - let r = Detyping.detype goal_concl_style avoid env sigma t in + let r = Detyping.detype Detyping.Later goal_concl_style avoid env sigma t in extern_glob_type (vars_of_env env) r let extern_sort sigma s = extern_glob_sort (detype_sort sigma s) @@ -1095,9 +1118,9 @@ let extern_closed_glob ?lax goal_concl_style env sigma t = let any_any_branch = (* | _ => _ *) - Loc.tag ([],[CAst.make @@ PatVar Anonymous], CAst.make @@ GHole (Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None)) + Loc.tag ([],[DAst.make @@ PatVar Anonymous], DAst.make @@ GHole (Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None)) -let rec glob_of_pat env sigma pat = CAst.make @@ match pat with +let rec glob_of_pat env sigma pat = DAst.make @@ match pat with | PRef ref -> GRef (ref,None) | PVar id -> GVar id | PEvar (evk,l) -> @@ -1117,12 +1140,12 @@ let rec glob_of_pat env sigma pat = CAst.make @@ match pat with GVar id | PMeta None -> GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous,None) | PMeta (Some n) -> GPatVar (Evar_kinds.FirstOrderPatVar n) - | PProj (p,c) -> GApp (CAst.make @@ GRef (ConstRef (Projection.constant p),None), + | PProj (p,c) -> GApp (DAst.make @@ GRef (ConstRef (Projection.constant p),None), [glob_of_pat env sigma c]) | PApp (f,args) -> GApp (glob_of_pat env sigma f,Array.map_to_list (glob_of_pat env sigma) args) | PSoApp (n,args) -> - GApp (CAst.make @@ GPatVar (Evar_kinds.SecondOrderPatVar n), + GApp (DAst.make @@ GPatVar (Evar_kinds.SecondOrderPatVar n), List.map (glob_of_pat env sigma) args) | PProd (na,t,c) -> GProd (na,Explicit,glob_of_pat env sigma t,glob_of_pat (na::env) sigma c) @@ -1154,15 +1177,15 @@ let rec glob_of_pat env sigma pat = CAst.make @@ match pat with | _ -> anomaly (Pp.str "PCase with non-trivial predicate but unknown inductive.") in GCases (RegularStyle,rtn,[glob_of_pat env sigma tm,indnames],mat) - | PFix f -> (Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkFix f))).v (** FIXME bad env *) - | PCoFix c -> (Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkCoFix c))).v + | PFix f -> DAst.get (Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkFix f))) (** FIXME bad env *) + | PCoFix c -> DAst.get (Detyping.detype_names false [] env (Global.env()) sigma (EConstr.of_constr (mkCoFix c))) | PSort s -> GSort s let extern_constr_pattern env sigma pat = extern true (None,[]) Id.Set.empty (glob_of_pat env sigma pat) let extern_rel_context where env sigma sign = - let a = detype_rel_context where [] (names_of_rel_context env,env) sigma sign in + let a = detype_rel_context Detyping.Later where [] (names_of_rel_context env,env) sigma sign in let vars = vars_of_env env in let a = List.map (extended_glob_local_binder_of_decl) a in pi3 (extern_local_binder (None,[]) vars a) diff --git a/interp/constrextern.mli b/interp/constrextern.mli index ffa891c502..593580fb7e 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -23,9 +23,9 @@ open Misctypes (** Translation of pattern, cases pattern, glob_constr and term into syntax trees for printing *) -val extern_cases_pattern : Id.Set.t -> cases_pattern -> cases_pattern_expr -val extern_glob_constr : Id.Set.t -> glob_constr -> constr_expr -val extern_glob_type : Id.Set.t -> glob_constr -> constr_expr +val extern_cases_pattern : Id.Set.t -> 'a cases_pattern_g -> cases_pattern_expr +val extern_glob_constr : Id.Set.t -> 'a glob_constr_g -> constr_expr +val extern_glob_type : Id.Set.t -> 'a glob_constr_g -> constr_expr val extern_constr_pattern : names_context -> Evd.evar_map -> constr_pattern -> constr_expr val extern_closed_glob : ?lax:bool -> bool -> env -> Evd.evar_map -> closed_glob_constr -> constr_expr diff --git a/interp/constrintern.ml b/interp/constrintern.ml index e465677cde..6f7c6c8277 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -15,7 +15,6 @@ open Namegen open Libnames open Globnames open Impargs -open CAst open Glob_term open Glob_ops open Patternops @@ -306,12 +305,12 @@ let reset_tmp_scope env = {env with tmp_scope = None} let rec it_mkGProd ?loc env body = match env with - (loc2, (na, bk, t)) :: tl -> it_mkGProd ?loc:loc2 tl (CAst.make ?loc:(Loc.merge_opt loc loc2) @@ GProd (na, bk, t, body)) + (loc2, (na, bk, t)) :: tl -> it_mkGProd ?loc:loc2 tl (DAst.make ?loc:(Loc.merge_opt loc loc2) @@ GProd (na, bk, t, body)) | [] -> body let rec it_mkGLambda ?loc env body = match env with - (loc2, (na, bk, t)) :: tl -> it_mkGLambda ?loc:loc2 tl (CAst.make ?loc:(Loc.merge_opt loc loc2) @@ GLambda (na, bk, t, body)) + (loc2, (na, bk, t)) :: tl -> it_mkGLambda ?loc:loc2 tl (DAst.make ?loc:(Loc.merge_opt loc loc2) @@ GLambda (na, bk, t, body)) | [] -> body (**********************************************************************) @@ -323,15 +322,15 @@ let build_impls = function |Explicit -> fun _ -> None let impls_type_list ?(args = []) = - let rec aux acc = function - | { v = GProd (na,bk,_,c) } -> aux ((build_impls bk na)::acc) c + let rec aux acc c = match DAst.get c with + | GProd (na,bk,_,c) -> aux ((build_impls bk na)::acc) c | _ -> (Variable,[],List.append args (List.rev acc),[]) in aux [] let impls_term_list ?(args = []) = - let rec aux acc = function - | { v = GLambda (na,bk,_,c) } -> aux ((build_impls bk na)::acc) c - | { v = GRec (fix_kind, nas, args, tys, bds) } -> + let rec aux acc c = match DAst.get c with + | GLambda (na,bk,_,c) -> aux ((build_impls bk na)::acc) c + | GRec (fix_kind, nas, args, tys, bds) -> let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in let acc' = List.fold_left (fun a (na, bk, _, _) -> (build_impls bk na)::a) acc args.(nb) in aux acc' bds.(nb) @@ -347,14 +346,14 @@ let rec check_capture ty = function | [] -> () -let locate_if_hole ?loc na = function - | { v = GHole (_,naming,arg) } -> +let locate_if_hole ?loc na c = match DAst.get c with + | GHole (_,naming,arg) -> (try match na with | Name id -> glob_constr_of_notation_constr ?loc (Reserve.find_reserved_type id) | Anonymous -> raise Not_found - with Not_found -> CAst.make ?loc @@ GHole (Evar_kinds.BinderType na, naming, arg)) - | x -> x + with Not_found -> DAst.make ?loc @@ GHole (Evar_kinds.BinderType na, naming, arg)) + | _ -> c let reset_hidden_inductive_implicit_test env = { env with impls = Id.Map.map (function @@ -400,7 +399,7 @@ let intern_generalized_binder ?(global_level=false) intern_type lvar env fvs in let bl = List.map (fun (loc, id) -> - (loc, (Name id, b, CAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None)))) + (loc, (Name id, b, DAst.make ?loc @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None)))) fvs in let na = match na with @@ -433,11 +432,11 @@ let intern_assumption intern lvar env nal bk ty = let env, b = intern_generalized_binder intern_type lvar env (List.hd nal) b b' t ty in env, b -let glob_local_binder_of_extended = CAst.with_loc_val (fun ?loc -> function +let glob_local_binder_of_extended = DAst.with_loc_val (fun ?loc -> function | GLocalAssum (na,bk,t) -> (na,bk,None,t) | GLocalDef (na,bk,c,Some t) -> (na,bk,Some c,t) | GLocalDef (na,bk,c,None) -> - let t = CAst.make ?loc @@ GHole(Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None) in + let t = DAst.make ?loc @@ GHole(Evar_kinds.BinderType na,Misctypes.IntroAnonymous,None) in (na,bk,Some c,t) | GLocalPattern (_,_,_,_) -> Loc.raise ?loc (Stream.Error "pattern with quote not allowed here.") @@ -448,13 +447,13 @@ let intern_cases_pattern_fwd = ref (fun _ -> failwith "intern_cases_pattern_fwd" let intern_local_binder_aux ?(global_level=false) intern lvar (env,bl) = function | CLocalAssum(nal,bk,ty) -> let env, bl' = intern_assumption intern lvar env nal bk ty in - let bl' = List.map (fun (loc,(na,c,t)) -> CAst.make ?loc @@ GLocalAssum (na,c,t)) bl' in + let bl' = List.map (fun (loc,(na,c,t)) -> DAst.make ?loc @@ GLocalAssum (na,c,t)) bl' in env, bl' @ bl | CLocalDef((loc,na as locna),def,ty) -> let term = intern env def in let ty = Option.map (intern env) ty in (push_name_env lvar (impls_term_list term) env locna, - (CAst.make ?loc @@ GLocalDef (na,Explicit,term,ty)) :: bl) + (DAst.make ?loc @@ GLocalDef (na,Explicit,term,ty)) :: bl) | CLocalPattern (loc,(p,ty)) -> let tyc = match ty with @@ -476,7 +475,7 @@ let intern_local_binder_aux ?(global_level=false) intern lvar (env,bl) = functio let bk = Default Explicit in let _, bl' = intern_assumption intern lvar env [na] bk tyc in let _,(_,bk,t) = List.hd bl' in - (env, (CAst.make ?loc @@ GLocalPattern((cp,il),id,bk,t)) :: bl) + (env, (DAst.make ?loc @@ GLocalPattern((cp,il),id,bk,t)) :: bl) let intern_generalization intern env lvar loc bk ak c = let c = intern {env with unb = true} c in @@ -499,12 +498,12 @@ let intern_generalization intern env lvar loc bk ak c = in if pi then (fun (loc', id) acc -> - CAst.make ?loc:(Loc.merge_opt loc' loc) @@ - GProd (Name id, bk, CAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) + DAst.make ?loc:(Loc.merge_opt loc' loc) @@ + GProd (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) else (fun (loc', id) acc -> - CAst.make ?loc:(Loc.merge_opt loc' loc) @@ - GLambda (Name id, bk, CAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) + DAst.make ?loc:(Loc.merge_opt loc' loc) @@ + GLambda (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), acc)) in List.fold_right (fun (loc, id as lid) (env, acc) -> let env' = push_name_env lvar (Variable,[],[],[]) env (loc, Name id) in @@ -558,27 +557,34 @@ let make_letins = (fun a c -> match a with | loc, LPLetIn (na,b,t) -> - CAst.make ?loc @@ GLetIn(na,b,t,c) + DAst.make ?loc @@ GLetIn(na,b,t,c) | loc, LPCases ((cp,il),id) -> - let tt = (CAst.make ?loc @@ GVar id, (Name id,None)) in - CAst.make ?loc @@ GCases(Misctypes.LetPatternStyle,None,[tt],[(loc,(il,[cp],c))])) + let tt = (DAst.make ?loc @@ GVar id, (Name id,None)) in + DAst.make ?loc @@ GCases(Misctypes.LetPatternStyle,None,[tt],[(loc,(il,[cp],c))])) -let rec subordinate_letins letins = function +let rec subordinate_letins letins l = match l with + | bnd :: l -> + let loc = bnd.CAst.loc in + begin match DAst.get bnd with (* binders come in reverse order; the non-let are returned in reverse order together *) (* with the subordinated let-in in writing order *) - | { loc; v = GLocalDef (na,_,b,t) }::l -> + | GLocalDef (na,_,b,t) -> subordinate_letins ((Loc.tag ?loc @@ LPLetIn (na,b,t))::letins) l - | { loc; v = GLocalAssum (na,bk,t)}::l -> + | GLocalAssum (na,bk,t) -> let letins',rest = subordinate_letins [] l in letins',((loc,(na,bk,t)),letins)::rest - | { loc; v = GLocalPattern (u,id,bk,t)} :: l -> + | GLocalPattern (u,id,bk,t) -> subordinate_letins ((Loc.tag ?loc @@ LPCases (u,id))::letins) - ([CAst.make ?loc @@ GLocalAssum (Name id,bk,t)] @ l) + ([DAst.make ?loc @@ GLocalAssum (Name id,bk,t)] @ l) + end | [] -> letins,[] +let dmap_with_loc f n = + CAst.map_with_loc (fun ?loc c -> f ?loc (DAst.get_thunk c)) n + let terms_of_binders bl = - let rec term_of_pat pt = CAst.map_with_loc (fun ?loc -> function + let rec term_of_pat pt = dmap_with_loc (fun ?loc -> function | PatVar (Name id) -> CRef (Ident (loc,id), None) | PatVar (Anonymous) -> user_err Pp.(str "Cannot turn \"_\" into a term.") | PatCstr (c,l,_) -> @@ -586,12 +592,16 @@ let terms_of_binders bl = let hole = CAst.make ?loc @@ CHole (None,Misctypes.IntroAnonymous,None) in let params = List.make (Inductiveops.inductive_nparams (fst c)) hole in CAppExpl ((None,r,None),params @ List.map term_of_pat l)) pt in - let rec extract_variables = function - | {loc; v = GLocalAssum (Name id,_,_)}::l -> (CAst.make ?loc @@ CRef (Ident (loc,id), None)) :: extract_variables l - | {loc; v = GLocalDef (Name id,_,_,_)}::l -> extract_variables l - | {loc; v = GLocalDef (Anonymous,_,_,_)}::l - | {loc; v = GLocalAssum (Anonymous,_,_)}::l -> user_err Pp.(str "Cannot turn \"_\" into a term.") - | {loc; v = GLocalPattern ((u,_),_,_,_)}::l -> term_of_pat u :: extract_variables l + let rec extract_variables l = match l with + | bnd :: l -> + let loc = bnd.CAst.loc in + begin match DAst.get bnd with + | GLocalAssum (Name id,_,_) -> (CAst.make ?loc @@ CRef (Ident (loc,id), None)) :: extract_variables l + | GLocalDef (Name id,_,_,_) -> extract_variables l + | GLocalDef (Anonymous,_,_,_) + | GLocalAssum (Anonymous,_,_) -> user_err Pp.(str "Cannot turn \"_\" into a term.") + | GLocalPattern ((u,_),_,_,_) -> term_of_pat u :: extract_variables l + end | [] -> [] in extract_variables bl @@ -647,7 +657,7 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = let bindings = Id.Map.map mk_env terms in Some (Genintern.generic_substitute_notation bindings arg) in - CAst.make ?loc @@ GHole (knd, naming, arg) + DAst.make ?loc @@ GHole (knd, naming, arg) | NBinderList (x,y,iter,terminator) -> (try (* All elements of the list are in scopes (scopt,subscopes) *) @@ -665,22 +675,22 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = let a,letins = snd (Option.get binderopt) in let e = make_letins letins (aux subst' infos c') in let (_loc,(na,bk,t)) = a in - CAst.make ?loc @@ GProd (na,bk,t,e) + DAst.make ?loc @@ GProd (na,bk,t,e) | NLambda (Name id,NHole _,c') when option_mem_assoc id binderopt -> let a,letins = snd (Option.get binderopt) in let (_loc,(na,bk,t)) = a in - CAst.make ?loc @@ GLambda (na,bk,t,make_letins letins (aux subst' infos c')) + DAst.make ?loc @@ GLambda (na,bk,t,make_letins letins (aux subst' infos c')) (* Two special cases to keep binder name synchronous with BinderType *) | NProd (na,NHole(Evar_kinds.BinderType na',naming,arg),c') when Name.equal na na' -> let subinfos,na = traverse_binder subst avoid subinfos na in - let ty = CAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in - CAst.make ?loc @@ GProd (na,Explicit,ty,aux subst' subinfos c') + let ty = DAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in + DAst.make ?loc @@ GProd (na,Explicit,ty,aux subst' subinfos c') | NLambda (na,NHole(Evar_kinds.BinderType na',naming,arg),c') when Name.equal na na' -> let subinfos,na = traverse_binder subst avoid subinfos na in - let ty = CAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in - CAst.make ?loc @@ GLambda (na,Explicit,ty,aux subst' subinfos c') + let ty = DAst.make ?loc @@ GHole (Evar_kinds.BinderType na,naming,arg) in + DAst.make ?loc @@ GLambda (na,Explicit,ty,aux subst' subinfos c') | t -> glob_constr_of_notation_constr_with_binders ?loc (traverse_binder subst avoid) (aux subst') subinfos t @@ -692,7 +702,7 @@ let instantiate_notation_constr loc intern ntnvars subst infos c = intern {env with tmp_scope = scopt; scopes = subscopes @ env.scopes} a with Not_found -> - CAst.make ?loc ( + DAst.make ?loc ( try GVar (Id.Map.find id renaming) with Not_found -> @@ -732,7 +742,7 @@ let string_of_ty = function | Variable -> "var" let gvar (loc, id) us = match us with -| None -> CAst.make ?loc @@ GVar id +| None -> DAst.make ?loc @@ GVar id | Some _ -> user_err ?loc (str "Variable " ++ pr_id id ++ str " cannot have a universe instance") @@ -774,24 +784,27 @@ let intern_var genv (ltacvars,ntnvars) namedctx loc id us = let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in Dumpglob.dump_reference ?loc "<>" (string_of_qualid (Decls.variable_secpath id)) "var"; - CAst.make ?loc @@ GRef (ref, us), impls, scopes, [] + DAst.make ?loc @@ GRef (ref, us), impls, scopes, [] with e when CErrors.noncritical e -> (* [id] a goal variable *) gvar (loc,id) us, [], [], [] let find_appl_head_data c = - match c.v with + match DAst.get c with | GRef (ref,_) -> let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in c, impls, scopes, [] - | GApp ({ v = GRef (ref,_) },l) - when l != [] -> + | GApp (r, l) -> + begin match DAst.get r with + | GRef (ref,_) when l != [] -> let n = List.length l in let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in c, List.map (drop_first_implicits n) impls, List.skipn_at_least n scopes,[] + | _ -> c,[],[],[] + end | _ -> c,[],[],[] let error_not_enough_arguments ?loc = @@ -824,7 +837,7 @@ let intern_reference ref = (* Is it a global reference or a syntactic definition? *) let intern_qualid loc qid intern env lvar us args = match intern_extended_global_of_qualid (loc,qid) with - | TrueGlobal ref -> (CAst.make ?loc @@ GRef (ref, us)), true, args + | TrueGlobal ref -> (DAst.make ?loc @@ GRef (ref, us)), true, args | SynDef sp -> let (ids,c) = Syntax_def.search_syntactic_definition sp in let nids = List.length ids in @@ -836,23 +849,32 @@ let intern_qualid loc qid intern env lvar us args = let infos = (Id.Map.empty, env) in let projapp = match c with NRef _ -> true | _ -> false in let c = instantiate_notation_constr loc intern lvar subst infos c in - let c = match us, c with - | None, _ -> c - | Some _, { loc; v = GRef (ref, None) } -> CAst.make ?loc @@ GRef (ref, us) - | Some _, { loc; v = GApp ({ loc = loc' ; v = GRef (ref, None) }, arg) } -> - CAst.make ?loc @@ GApp (CAst.make ?loc:loc' @@ GRef (ref, us), arg) - | Some _, _ -> + let loc = c.CAst.loc in + let err () = user_err ?loc (str "Notation " ++ pr_qualid qid - ++ str " cannot have a universe instance," - ++ str " its expanded head does not start with a reference") + ++ str " cannot have a universe instance," + ++ str " its expanded head does not start with a reference") + in + let c = match us, DAst.get c with + | None, _ -> c + | Some _, GRef (ref, None) -> DAst.make ?loc @@ GRef (ref, us) + | Some _, GApp (r, arg) -> + let loc' = r.CAst.loc in + begin match DAst.get r with + | GRef (ref, None) -> + DAst.make ?loc @@ GApp (DAst.make ?loc:loc' @@ GRef (ref, us), arg) + | _ -> err () + end + | Some _, _ -> err () in c, projapp, args2 (* Rule out section vars since these should have been found by intern_var *) let intern_non_secvar_qualid loc qid intern env lvar us args = - match intern_qualid loc qid intern env lvar us args with - | { v = GRef (VarRef _, _) },_,_ -> raise Not_found - | r -> r + let c, _, _ as r = intern_qualid loc qid intern env lvar us args in + match DAst.get c with + | GRef (VarRef _, _) -> raise Not_found + | _ -> r let intern_applied_reference intern env namedctx (_, ntnvars as lvar) us args = function | Qualid (loc, qid) -> @@ -888,14 +910,14 @@ let interp_reference vars r = (** {5 Cases } *) (** Private internalization patterns *) -type raw_cases_pattern_expr_r = - | RCPatAlias of raw_cases_pattern_expr * Id.t +type 'a raw_cases_pattern_expr_r = + | RCPatAlias of 'a raw_cases_pattern_expr * Id.t | RCPatCstr of Globnames.global_reference - * raw_cases_pattern_expr list * raw_cases_pattern_expr list + * 'a raw_cases_pattern_expr list * 'a raw_cases_pattern_expr list (** [RCPatCstr (loc, c, l1, l2)] represents ((@c l1) l2) *) | RCPatAtom of Id.t option - | RCPatOr of raw_cases_pattern_expr list -and raw_cases_pattern_expr = raw_cases_pattern_expr_r CAst.t + | RCPatOr of 'a raw_cases_pattern_expr list +and 'a raw_cases_pattern_expr = ('a raw_cases_pattern_expr_r, 'a) DAst.t (** {6 Elementary bricks } *) let apply_scope_env env = function @@ -977,7 +999,7 @@ let insert_local_defs_in_pattern (ind,j) l = let (decls,_) = decompose_prod_assum typi in let rec aux decls args = match decls, args with - | Context.Rel.Declaration.LocalDef _ :: decls, args -> (CAst.make @@ RCPatAtom None) :: aux decls args + | Context.Rel.Declaration.LocalDef _ :: decls, args -> (DAst.make @@ RCPatAtom None) :: aux decls args | _, [] -> [] (* In particular, if there were trailing local defs, they have been inserted *) | Context.Rel.Declaration.LocalAssum _ :: decls, a :: args -> a :: aux decls args | _ -> assert false in @@ -1013,10 +1035,10 @@ let add_implicits_check_length fail nargs nargs_with_letin impls_st len_pl1 pl2 else Int.equal args_len nargs_with_letin || (fst (fail (nargs - List.length impl_list + i)))) ,l) |imp::q as il,[] -> if is_status_implicit imp && maximal_insertion_of imp - then let (b,out) = aux i (q,[]) in (b,(CAst.make @@ RCPatAtom None)::out) + then let (b,out) = aux i (q,[]) in (b,(DAst.make @@ RCPatAtom None)::out) else fail (remaining_args (len_pl1+i) il) |imp::q,(hh::tt as l) -> if is_status_implicit imp - then let (b,out) = aux i (q,l) in (b,(CAst.make @@ RCPatAtom(None))::out) + then let (b,out) = aux i (q,l) in (b,(DAst.make @@ RCPatAtom(None))::out) else let (b,out) = aux (succ i) (q,tt) in (b,hh::out) in aux 0 (impl_list,pl2) @@ -1041,8 +1063,9 @@ let chop_params_pattern loc ind args with_letin = else Inductiveops.inductive_nparams ind in assert (nparams <= List.length args); let params,args = List.chop nparams args in - List.iter (function { v = PatVar Anonymous } -> () - | { loc; v = PatVar _ } | { loc; v = PatCstr(_,_,_) } -> error_parameter_not_implicit ?loc) params; + List.iter (fun c -> match DAst.get c with + | PatVar Anonymous -> () + | PatVar _ | PatCstr(_,_,_) -> error_parameter_not_implicit ?loc:c.CAst.loc) params; args let find_constructor loc add_params ref = @@ -1062,7 +1085,7 @@ let find_constructor loc add_params ref = then Inductiveops.inductive_nparamdecls ind else Inductiveops.inductive_nparams ind in - List.make nb ([], [(Id.Map.empty, CAst.make @@ PatVar Anonymous)]) + List.make nb ([], [(Id.Map.empty, DAst.make @@ PatVar Anonymous)]) | None -> [] let find_pattern_variable = function @@ -1235,15 +1258,23 @@ let product_of_cases_patterns aliases idspl = List.map (fun (subst',ptail) -> (merge_subst subst subst',p::ptail)) ptaill) pl))) idspl (aliases.alias_ids,[aliases.alias_map,[]]) -let rec subst_pat_iterator y t = CAst.(map (function +let rec subst_pat_iterator y t = DAst.(map (function | RCPatAtom id as p -> - begin match id with Some x when Id.equal x y -> t.v | _ -> p end + begin match id with Some x when Id.equal x y -> DAst.get t | _ -> p end | RCPatCstr (id,l1,l2) -> RCPatCstr (id,List.map (subst_pat_iterator y t) l1, List.map (subst_pat_iterator y t) l2) | RCPatAlias (p,a) -> RCPatAlias (subst_pat_iterator y t p,a) | RCPatOr pl -> RCPatOr (List.map (subst_pat_iterator y t) pl))) +let is_non_zero c = match c with +| { CAst.v = CPrim (Numeral (p, true)) } -> not (is_zero p) +| _ -> false + +let is_non_zero_pat c = match c with +| { CAst.v = CPatPrim (Numeral (p, true)) } -> not (is_zero p) +| _ -> false + let drop_notations_pattern looked_for genv = (* At toplevel, Constructors and Inductives are accepted, in recursive calls only constructor are allowed *) @@ -1258,11 +1289,16 @@ let drop_notations_pattern looked_for genv = if top then looked_for else function ConstructRef _ -> () | _ -> raise Not_found in (** [rcp_of_glob] : from [glob_constr] to [raw_cases_pattern_expr] *) - let rec rcp_of_glob x = CAst.(map (function + let rec rcp_of_glob x = DAst.(map (function | GVar id -> RCPatAtom (Some id) | GHole (_,_,_) -> RCPatAtom (None) | GRef (g,_) -> RCPatCstr (g,[],[]) - | GApp ({ v = GRef (g,_) }, l) -> RCPatCstr (g, List.map rcp_of_glob l,[]) + | GApp (r, l) -> + begin match DAst.get r with + | GRef (g,_) -> RCPatCstr (g, List.map rcp_of_glob l,[]) + | _ -> + CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr.") + end | _ -> CErrors.anomaly Pp.(str "Invalid return pattern from Notation.interp_prim_token_cases_pattern_expr."))) x in let rec drop_syndef top scopes re pats = @@ -1303,25 +1339,25 @@ let drop_notations_pattern looked_for genv = let open CAst in let loc = pt.loc in match pt.v with - | CPatAlias (p, id) -> CAst.make ?loc @@ RCPatAlias (in_pat top scopes p, id) + | CPatAlias (p, id) -> DAst.make ?loc @@ RCPatAlias (in_pat top scopes p, id) | CPatRecord l -> let sorted_fields = sort_fields ~complete:false loc l (fun _idx -> CAst.make ?loc @@ CPatAtom None) in begin match sorted_fields with - | None -> CAst.make ?loc @@ RCPatAtom None + | None -> DAst.make ?loc @@ RCPatAtom None | Some (n, head, pl) -> let pl = if !asymmetric_patterns then pl else let pars = List.make n (CAst.make ?loc @@ CPatAtom None) in List.rev_append pars pl in match drop_syndef top scopes head pl with - | Some (a,b,c) -> CAst.make ?loc @@ RCPatCstr(a, b, c) + | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) | None -> raise (InternalizationError (loc,NotAConstructor head)) end | CPatCstr (head, None, pl) -> begin match drop_syndef top scopes head pl with - | Some (a,b,c) -> CAst.make ?loc @@ RCPatCstr(a, b, c) + | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr(a, b, c) | None -> raise (InternalizationError (loc,NotAConstructor head)) end | CPatCstr (r, Some expl_pl, pl) -> @@ -1330,14 +1366,14 @@ let drop_notations_pattern looked_for genv = raise (InternalizationError (loc,NotAConstructor r)) in if expl_pl == [] then (* Convention: (@r) deactivates all further implicit arguments and scopes *) - CAst.make ?loc @@ RCPatCstr (g, List.map (in_pat false scopes) pl, []) + DAst.make ?loc @@ RCPatCstr (g, List.map (in_pat false scopes) pl, []) else (* Convention: (@r expl_pl) deactivates implicit arguments in expl_pl and in pl *) (* but not scopes in expl_pl *) let (argscs1,_) = find_remaining_scopes expl_pl pl g in - CAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat false scopes) pl, []) - | CPatNotation ("- _",([{ CAst.v = CPatPrim(Numeral (p,true)) }],[]),[]) - when not (is_zero p) -> + DAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat false scopes) pl, []) + | CPatNotation ("- _",([a],[]),[]) when is_non_zero_pat a -> + let p = match a.CAst.v with CPatPrim (Numeral (p, _)) -> p | _ -> assert false in let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind false loc) (Numeral (p,false)) scopes in rcp_of_glob pat | CPatNotation ("( _ )",([a],[]),[]) -> @@ -1358,11 +1394,11 @@ let drop_notations_pattern looked_for genv = | CPatAtom Some id -> begin match drop_syndef top scopes id [] with - | Some (a,b,c) -> CAst.make ?loc @@ RCPatCstr (a, b, c) - | None -> CAst.make ?loc @@ RCPatAtom (Some (find_pattern_variable id)) + | Some (a,b,c) -> DAst.make ?loc @@ RCPatCstr (a, b, c) + | None -> DAst.make ?loc @@ RCPatAtom (Some (find_pattern_variable id)) end - | CPatAtom None -> CAst.make ?loc @@ RCPatAtom None - | CPatOr pl -> CAst.make ?loc @@ RCPatOr (List.map (in_pat top scopes) pl) + | CPatAtom None -> DAst.make ?loc @@ RCPatAtom None + | CPatOr pl -> DAst.make ?loc @@ RCPatOr (List.map (in_pat top scopes) pl) | CPatCast (_,_) -> (* We raise an error if the pattern contains a cast, due to current restrictions on casts in patterns. Cast in patterns @@ -1389,19 +1425,19 @@ let drop_notations_pattern looked_for genv = let (a,(scopt,subscopes)) = Id.Map.find id subst in in_pat top (scopt,subscopes@snd scopes) a with Not_found -> - if Id.equal id ldots_var then CAst.make ?loc @@ RCPatAtom (Some id) else + if Id.equal id ldots_var then DAst.make ?loc @@ RCPatAtom (Some id) else anomaly (str "Unbound pattern notation variable: " ++ Id.print id ++ str ".") end | NRef g -> ensure_kind top loc g; let (_,argscs) = find_remaining_scopes [] args g in - CAst.make ?loc @@ RCPatCstr (g, [], List.map2 (in_pat_sc scopes) argscs args) + DAst.make ?loc @@ RCPatCstr (g, [], List.map2 (in_pat_sc scopes) argscs args) | NApp (NRef g,pl) -> ensure_kind top loc g; let (argscs1,argscs2) = find_remaining_scopes pl args g in let pl = List.map2 (fun x -> in_not false loc (x,snd scopes) fullsubst []) argscs1 pl in let pl = add_local_defs_and_check_length loc genv g pl args in - CAst.make ?loc @@ RCPatCstr (g, pl @ List.map (in_pat false scopes) args, []) + DAst.make ?loc @@ RCPatCstr (g, pl @ List.map (in_pat false scopes) args, []) | NList (x,y,iter,terminator,lassoc) -> if not (List.is_empty args) then user_err ?loc (strbrk "Application of arguments to a recursive notation not supported in patterns."); @@ -1418,7 +1454,7 @@ let drop_notations_pattern looked_for genv = anomaly (Pp.str "Inconsistent substitution of recursive notation.")) | NHole _ -> let () = assert (List.is_empty args) in - CAst.make ?loc @@ RCPatAtom None + DAst.make ?loc @@ RCPatAtom None | t -> error_invalid_pattern_notation ?loc () in in_pat true @@ -1427,10 +1463,10 @@ let rec intern_pat genv aliases pat = let idslpl2 = List.map (intern_pat genv empty_alias) pl2 in let (ids',pll) = product_of_cases_patterns aliases (idslpl1@idslpl2) in let pl' = List.map (fun (asubst,pl) -> - (asubst, CAst.make ?loc @@ PatCstr (c,chop_params_pattern loc (fst c) pl with_letin,alias_of aliases))) pll in + (asubst, DAst.make ?loc @@ PatCstr (c,chop_params_pattern loc (fst c) pl with_letin,alias_of aliases))) pll in ids',pl' in let loc = CAst.(pat.loc) in - match CAst.(pat.v) with + match DAst.get pat with | RCPatAlias (p, id) -> let aliases' = merge_aliases aliases id in intern_pat genv aliases' p @@ -1448,10 +1484,10 @@ let rec intern_pat genv aliases pat = intern_cstr_with_all_args loc c with_letin idslpl1 (expl_pl@pl2) | RCPatAtom (Some id) -> let aliases = merge_aliases aliases id in - (aliases.alias_ids,[aliases.alias_map, CAst.make ?loc @@ PatVar (alias_of aliases)]) + (aliases.alias_ids,[aliases.alias_map, DAst.make ?loc @@ PatVar (alias_of aliases)]) | RCPatAtom (None) -> let { alias_ids = ids; alias_map = asubst; } = aliases in - (ids, [asubst, CAst.make ?loc @@ PatVar (alias_of aliases)]) + (ids, [asubst, DAst.make ?loc @@ PatVar (alias_of aliases)]) | RCPatOr pl -> assert (not (List.is_empty pl)); let pl' = List.map (intern_pat genv aliases) pl in @@ -1475,7 +1511,7 @@ let intern_ind_pattern genv scopes pat = with InternalizationError(loc,NotAConstructor _) -> error_bad_inductive_type ?loc in let loc = no_not.CAst.loc in - match no_not.CAst.v with + match DAst.get no_not with | RCPatCstr (head, expl_pl, pl) -> let c = (function IndRef ind -> ind | _ -> error_bad_inductive_type ?loc) head in let with_letin, pl2 = add_implicits_check_ind_length genv loc c @@ -1506,9 +1542,18 @@ let merge_impargs l args = let get_implicit_name n imps = Some (Impargs.name_of_implicit (List.nth imps (n-1))) -let set_hole_implicit i b = function - | {loc; v = GRef (r,_) } | { v = GApp ({loc; v = GRef (r,_)},_) } -> Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),Misctypes.IntroAnonymous,None) - | {loc; v = GVar id } -> Loc.tag ?loc (Evar_kinds.ImplicitArg (VarRef id,i,b),Misctypes.IntroAnonymous,None) +let set_hole_implicit i b c = + let loc = c.CAst.loc in + match DAst.get c with + | GRef (r, _) -> Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),Misctypes.IntroAnonymous,None) + | GApp (r, _) -> + let loc = r.CAst.loc in + begin match DAst.get r with + | GRef (r, _) -> + Loc.tag ?loc (Evar_kinds.ImplicitArg (r,i,b),Misctypes.IntroAnonymous,None) + | _ -> anomaly (Pp.str "Only refs have implicits.") + end + | GVar id -> Loc.tag ?loc (Evar_kinds.ImplicitArg (VarRef id,i,b),Misctypes.IntroAnonymous,None) | _ -> anomaly (Pp.str "Only refs have implicits.") let exists_implicit_name id = @@ -1574,7 +1619,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let before, after = split_at_annot bl n in let (env',rbefore) = List.fold_left intern_local_binder (env,[]) before in let ro = f (intern env') in - let n' = Option.map (fun _ -> List.count (function | { v = GLocalAssum _ } -> true + let n' = Option.map (fun _ -> List.count (fun c -> match DAst.get c with + | GLocalAssum _ -> true | _ -> false (* remove let-ins *)) rbefore) n in n', ro, List.fold_left intern_local_binder (env',rbefore) after @@ -1597,7 +1643,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = push_name_env ntnvars (impls_type_list ~args:fix_args tyi) en (Loc.tag @@ Name name)) 0 env' lf in (a,b,c,intern {env'' with tmp_scope = None} bd)) dl idl_temp in - CAst.make ?loc @@ + DAst.make ?loc @@ GRec (GFix (Array.map (fun (ro,_,_,_) -> ro) idl,n), Array.of_list lf, @@ -1624,7 +1670,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = push_name_env ntnvars (impls_type_list ~args:cofix_args tyi) en (Loc.tag @@ Name name)) 0 env' lf in (b,c,intern {env'' with tmp_scope = None} bd)) dl idl_tmp in - CAst.make ?loc @@ + DAst.make ?loc @@ GRec (GCoFix n, Array.of_list lf, Array.map (fun (bl,_,_) -> bl) idl, @@ -1641,11 +1687,11 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CLetIn (na,c1,t,c2) -> let inc1 = intern (reset_tmp_scope env) c1 in let int = Option.map (intern_type env) t in - CAst.make ?loc @@ + DAst.make ?loc @@ GLetIn (snd na, inc1, int, intern (push_name_env ntnvars (impls_term_list inc1) env na) c2) - | CNotation ("- _",([{ CAst.v = CPrim (Numeral (p,true)) }],[],[])) - when not (is_zero p) -> + | CNotation ("- _", ([a],[],[])) when is_non_zero a -> + let p = match a.CAst.v with CPrim (Numeral (p, _)) -> p | _ -> assert false in intern env (CAst.make ?loc @@ CPrim (Numeral (p,false))) | CNotation ("( _ )",([a],[],[])) -> intern env a | CNotation (ntn,args) -> @@ -1664,13 +1710,13 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = lvar us args ref in (* Rem: GApp(_,f,[]) stands for @f *) - CAst.make ?loc @@ + DAst.make ?loc @@ GApp (f, intern_args env args_scopes (List.map fst args)) | CApp ((isproj,f), args) -> - let f,args = match f with + let f,args = match f.CAst.v with (* Compact notations like "t.(f args') args" *) - | { CAst.v = CApp ((Some _,f), args') } when not (Option.has_some isproj) -> + | CApp ((Some _,f), args') when not (Option.has_some isproj) -> f,args'@args (* Don't compact "(f args') args" to resolve implicits separately *) | _ -> f,args in @@ -1719,9 +1765,13 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (Id.Set.union ex_ids as_in_vars) (reset_hidden_inductive_implicit_test env) in (* PatVars before a real pattern do not need to be matched *) let stripped_match_from_in = + let is_patvar c = match DAst.get c with + | PatVar _ -> true + | _ -> false + in let rec aux = function | [] -> [] - | (_, { v = PatVar _}) :: q -> aux q + | (_, c) :: q when is_patvar c -> aux q | l -> l in aux match_from_in in let rtnpo = match stripped_match_from_in with @@ -1730,20 +1780,20 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* Build a return predicate by expansion of the patterns of the "in" clause *) let thevars, thepats = List.split l in let sub_rtn = (* Some (GSort (Loc.ghost,GType None)) *) None in - let sub_tms = List.map (fun id -> (CAst.make @@ GVar id),(Name id,None)) thevars (* "match v1,..,vn" *) in + let sub_tms = List.map (fun id -> (DAst.make @@ GVar id),(Name id,None)) thevars (* "match v1,..,vn" *) in let main_sub_eqn = Loc.tag @@ ([],thepats, (* "|p1,..,pn" *) Option.cata (intern_type env') - (CAst.make ?loc @@ GHole(Evar_kinds.CasesType false,Misctypes.IntroAnonymous,None)) + (DAst.make ?loc @@ GHole(Evar_kinds.CasesType false,Misctypes.IntroAnonymous,None)) rtnpo) (* "=> P" if there were a return predicate P, and "=> _" otherwise *) in let catch_all_sub_eqn = if List.for_all (irrefutable globalenv) thepats then [] else - [Loc.tag @@ ([],List.make (List.length thepats) (CAst.make @@ PatVar Anonymous), (* "|_,..,_" *) - CAst.make @@ GHole(Evar_kinds.ImpossibleCase,Misctypes.IntroAnonymous,None))] (* "=> _" *) in - Some (CAst.make @@ GCases(Term.RegularStyle,sub_rtn,sub_tms,main_sub_eqn::catch_all_sub_eqn)) + [Loc.tag @@ ([],List.make (List.length thepats) (DAst.make @@ PatVar Anonymous), (* "|_,..,_" *) + DAst.make @@ GHole(Evar_kinds.ImpossibleCase,Misctypes.IntroAnonymous,None))] (* "=> _" *) in + Some (DAst.make @@ GCases(Term.RegularStyle,sub_rtn,sub_tms,main_sub_eqn::catch_all_sub_eqn)) in let eqns' = List.map (intern_eqn (List.length tms) env) eqns in - CAst.make ?loc @@ + DAst.make ?loc @@ GCases (sty, rtnpo, tms, List.flatten eqns') | CLetTuple (nal, (na,po), b, c) -> let env' = reset_tmp_scope env in @@ -1753,7 +1803,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env') (Loc.tag na') in intern_type env'' u) po in - CAst.make ?loc @@ + DAst.make ?loc @@ GLetTuple (List.map snd nal, (na', p'), b', intern (List.fold_left (push_name_env ntnvars (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c) | CIf (c, (na,po), b1, b2) -> @@ -1763,7 +1813,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env) (Loc.tag na') in intern_type env'' p) po in - CAst.make ?loc @@ + DAst.make ?loc @@ GIf (c', (na', p'), intern env b1, intern env b2) | CHole (k, naming, solve) -> let k = match k with @@ -1791,28 +1841,28 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let (_, glb) = Genintern.generic_intern ist gen in Some glb in - CAst.make ?loc @@ + DAst.make ?loc @@ GHole (k, naming, solve) (* Parsing pattern variables *) | CPatVar n when pattern_mode -> - CAst.make ?loc @@ + DAst.make ?loc @@ GPatVar (Evar_kinds.SecondOrderPatVar n) | CEvar (n, []) when pattern_mode -> - CAst.make ?loc @@ + DAst.make ?loc @@ GPatVar (Evar_kinds.FirstOrderPatVar n) (* end *) (* Parsing existential variables *) | CEvar (n, l) -> - CAst.make ?loc @@ + DAst.make ?loc @@ GEvar (n, List.map (on_snd (intern env)) l) | CPatVar _ -> raise (InternalizationError (loc,IllegalMetavariable)) (* end *) | CSort s -> - CAst.make ?loc @@ + DAst.make ?loc @@ GSort s | CCast (c1, c2) -> - CAst.make ?loc @@ + DAst.make ?loc @@ GCast (intern env c1, Miscops.map_cast_type (intern_type env) c2) ) and intern_type env = intern (set_type_scope env) @@ -1850,9 +1900,11 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* the "match" part *) let tm' = intern env tm in (* the "as" part *) - let extra_id,na = match tm', na with - | {loc; v = GVar id}, None when not (Id.Map.mem id (snd lvar)) -> Some id,(loc,Name id) - | {loc; v = GRef (VarRef id, _)}, None -> Some id,(loc,Name id) + let extra_id,na = + let loc = tm'.CAst.loc in + match DAst.get tm', na with + | GVar id, None when not (Id.Map.mem id (snd lvar)) -> Some id,(loc,Name id) + | GRef (VarRef id, _), None -> Some id,(loc,Name id) | _, None -> None,(Loc.tag Anonymous) | _, Some (loc,na) -> None,(loc,na) in (* the "in" part *) @@ -1871,21 +1923,25 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let rec canonize_args case_rel_ctxt arg_pats forbidden_names match_acc var_acc = let add_name l = function | _,Anonymous -> l - | loc,(Name y as x) -> (y, CAst.make ?loc @@ PatVar x) :: l in + | loc,(Name y as x) -> (y, DAst.make ?loc @@ PatVar x) :: l in match case_rel_ctxt,arg_pats with (* LetIn in the rel_context *) | LocalDef _ :: t, l when not with_letin -> canonize_args t l forbidden_names match_acc ((Loc.tag Anonymous)::var_acc) | [],[] -> (add_name match_acc na, var_acc) - | _::t, { loc; v = PatVar x}::tt -> - canonize_args t tt forbidden_names - (add_name match_acc (loc,x)) ((loc,x)::var_acc) | (LocalAssum (cano_name,ty) | LocalDef (cano_name,_,ty)) :: t, c::tt -> - let fresh = - Namegen.next_name_away_with_default_using_types "iV" cano_name forbidden_names (EConstr.of_constr ty) in - canonize_args t tt (fresh::forbidden_names) - ((fresh,c)::match_acc) ((cases_pattern_loc c,Name fresh)::var_acc) + begin match DAst.get c with + | PatVar x -> + let loc = c.CAst.loc in + canonize_args t tt forbidden_names + (add_name match_acc (loc,x)) ((loc,x)::var_acc) + | _ -> + let fresh = + Namegen.next_name_away_with_default_using_types "iV" cano_name forbidden_names (EConstr.of_constr ty) in + canonize_args t tt (fresh::forbidden_names) + ((fresh,c)::match_acc) ((cases_pattern_loc c,Name fresh)::var_acc) + end | _ -> assert false in let _,args_rel = List.chop nparams (List.rev mip.Declarations.mind_arity_ctxt) in @@ -1924,7 +1980,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* with implicit arguments if maximal insertion is set *) [] else - (CAst.map_from_loc (fun ?loc (a,b,c) -> GHole(a,b,c)) + (DAst.map_from_loc (fun ?loc (a,b,c) -> GHole(a,b,c)) (set_hole_implicit (n,get_implicit_name n l) (force_inference_of imp) c) ) :: aux (n+1) impl' subscopes' eargs rargs end @@ -1950,9 +2006,11 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = and smart_gapp f loc = function | [] -> f - | l -> match f with - | { loc = loc'; v = GApp (g, args) } -> CAst.make ?loc:(Loc.merge_opt loc' loc) @@ GApp (g, args@l) - | _ -> CAst.make ?loc:(Loc.merge_opt (loc_of_glob_constr f) loc) @@ GApp (f, l) + | l -> + let loc' = f.CAst.loc in + match DAst.get f with + | GApp (g, args) -> DAst.make ?loc:(Loc.merge_opt loc' loc) @@ GApp (g, args@l) + | _ -> DAst.make ?loc:(Loc.merge_opt (loc_of_glob_constr f) loc) @@ GApp (f, l) and intern_args env subscopes = function | [] -> [] diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index e498d979de..cae67c3e70 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -119,13 +119,14 @@ let free_vars_of_binders ?(bound=Id.Set.empty) l (binders : local_binder_expr li in aux bound l binders let generalizable_vars_of_glob_constr ?(bound=Id.Set.empty) ?(allowed=Id.Set.empty) = - let rec vars bound vs t = match t with - | { loc; CAst.v = GVar id } -> + let rec vars bound vs c = match DAst.get c with + | GVar id -> + let loc = c.CAst.loc in if is_freevar bound (Global.env ()) id then if Id.List.mem_assoc_sym id vs then vs else (Loc.tag ?loc id) :: vs else vs - | c -> Glob_ops.fold_glob_constr_with_binders Id.Set.add vars bound vs c + | _ -> Glob_ops.fold_glob_constr_with_binders Id.Set.add vars bound vs c in fun rt -> let vars = List.rev (vars bound [] rt) in List.iter (fun (loc, id) -> @@ -253,11 +254,11 @@ let implicits_of_glob_constr ?(with_products=true) l = (ExplByPos (i, name), (true, true, true)) :: l | _ -> l in - let rec aux i { loc; CAst.v = c } = + let rec aux i c = let abs na bk b = add_impl i na bk (aux (succ i) b) in - match c with + match DAst.get c with | GProd (na, bk, t, b) -> if with_products then abs na bk b else diff --git a/interp/notation.ml b/interp/notation.ml index c373faf680..d3cac1e3e9 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -265,19 +265,28 @@ let keymap_find key map = (* Scopes table : interpretation -> scope_name *) let notations_key_table = ref (KeyMap.empty : notation_rule list KeyMap.t) -let prim_token_key_table = ref KeyMap.empty - -let glob_prim_constr_key = function - | { CAst.v = GApp ({ CAst.v = GRef (ref,_) } ,_) } | { CAst.v = GRef (ref,_) } -> RefKey (canonical_gr ref) +let prim_token_key_table = ref (KeyMap.empty : (string * (any_glob_constr -> prim_token option) * bool) KeyMap.t) + +let glob_prim_constr_key c = match DAst.get c with + | GRef (ref, _) -> RefKey (canonical_gr ref) + | GApp (c, _) -> + begin match DAst.get c with + | GRef (ref, _) -> RefKey (canonical_gr ref) + | _ -> Oth + end | _ -> Oth -let glob_constr_keys = function - | { CAst.v = GApp ({ CAst.v = GRef (ref,_) },_) } -> [RefKey (canonical_gr ref); Oth] - | { CAst.v = GRef (ref,_) } -> [RefKey (canonical_gr ref)] +let glob_constr_keys c = match DAst.get c with + | GApp (c, _) -> + begin match DAst.get c with + | GRef (ref, _) -> [RefKey (canonical_gr ref); Oth] + | _ -> [Oth] + end + | GRef (ref,_) -> [RefKey (canonical_gr ref)] | _ -> [Oth] -let cases_pattern_key = function - | { CAst.v = PatCstr (ref,_,_) } -> RefKey (canonical_gr (ConstructRef ref)) +let cases_pattern_key c = match DAst.get c with + | PatCstr (ref,_,_) -> RefKey (canonical_gr (ConstructRef ref)) | _ -> Oth let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) @@ -300,7 +309,7 @@ type 'a prim_token_interpreter = type cases_pattern_status = bool (* true = use prim token in patterns *) type 'a prim_token_uninterpreter = - glob_constr list * (glob_constr -> 'a option) * cases_pattern_status + glob_constr list * (any_glob_constr -> 'a option) * cases_pattern_status type internal_prim_token_interpreter = ?loc:Loc.t -> prim_token -> required_module * (unit -> glob_constr) @@ -416,7 +425,7 @@ let warn_notation_overridden = CWarnings.create ~name:"notation-overridden" ~category:"parsing" (fun (ntn,which_scope) -> str "Notation" ++ spc () ++ str ntn ++ spc () - ++ strbrk "was already used" ++ which_scope) + ++ strbrk "was already used" ++ which_scope ++ str ".") let declare_notation_interpretation ntn scopt pat df ~onlyprint = let scope = match scopt with Some s -> s | None -> default_scope in @@ -496,11 +505,15 @@ let interp_prim_token_gen ?loc g p local_scopes = let interp_prim_token ?loc = interp_prim_token_gen ?loc (fun _ -> ()) -let rec check_allowed_ref_in_pat looked_for = CAst.(with_val (function +let rec check_allowed_ref_in_pat looked_for = DAst.(with_val (function | GVar _ | GHole _ -> () | GRef (g,_) -> looked_for g - | GApp ({ v = GRef (g,_) },l) -> - looked_for g; List.iter (check_allowed_ref_in_pat looked_for) l + | GApp (f, l) -> + begin match DAst.get f with + | GRef (g, _) -> + looked_for g; List.iter (check_allowed_ref_in_pat looked_for) l + | _ -> raise Not_found + end | _ -> raise Not_found)) let interp_prim_token_cases_pattern_expr ?loc looked_for p = @@ -532,7 +545,7 @@ let uninterp_prim_token c = try let (sc,numpr,_) = KeyMap.find (glob_prim_constr_key c) !prim_token_key_table in - match numpr c with + match numpr (AnyGlobConstr c) with | None -> raise Notation_ops.No_match | Some n -> (sc,n) with Not_found -> raise Notation_ops.No_match @@ -545,8 +558,8 @@ let uninterp_prim_token_ind_pattern ind args = if not b then raise Notation_ops.No_match; let args' = List.map (fun x -> snd (glob_constr_of_closed_cases_pattern x)) args in - let ref = CAst.make @@ GRef (ref,None) in - match numpr (CAst.make @@ GApp (ref,args')) with + let ref = DAst.make @@ GRef (ref,None) in + match numpr (AnyGlobConstr (DAst.make @@ GApp (ref,args'))) with | None -> raise Notation_ops.No_match | Some n -> (sc,n) with Not_found -> raise Notation_ops.No_match @@ -557,7 +570,7 @@ let uninterp_prim_token_cases_pattern c = let (sc,numpr,b) = KeyMap.find k !prim_token_key_table in if not b then raise Notation_ops.No_match; let na,c = glob_constr_of_closed_cases_pattern c in - match numpr c with + match numpr (AnyGlobConstr c) with | None -> raise Notation_ops.No_match | Some n -> (na,sc,n) with Not_found -> raise Notation_ops.No_match diff --git a/interp/notation.mli b/interp/notation.mli index f9f247fe10..75c8d5aa5f 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -70,7 +70,7 @@ type 'a prim_token_interpreter = ?loc:Loc.t -> 'a -> glob_constr type 'a prim_token_uninterpreter = - glob_constr list * (glob_constr -> 'a option) * cases_pattern_status + glob_constr list * (any_glob_constr -> 'a option) * cases_pattern_status type rawnum = Constrexpr.raw_natural_number * Constrexpr.sign @@ -96,9 +96,9 @@ val interp_prim_token_cases_pattern_expr : ?loc:Loc.t -> (global_reference -> un raise [No_match] if no such token *) val uninterp_prim_token : - glob_constr -> scope_name * prim_token + 'a glob_constr_g -> scope_name * prim_token val uninterp_prim_token_cases_pattern : - cases_pattern -> Name.t * scope_name * prim_token + 'a cases_pattern_g -> Name.t * scope_name * prim_token val uninterp_prim_token_ind_pattern : inductive -> cases_pattern list -> scope_name * prim_token @@ -124,8 +124,8 @@ 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 : glob_constr -> notation_rule list -val uninterp_cases_pattern_notations : cases_pattern -> notation_rule list +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 (** Test if a notation is available in the scopes diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 5d703011d2..3d48114ec6 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -99,43 +99,43 @@ let name_to_ident = function let to_id g e id = let e,na = g e (Name id) in e,name_to_ident na -let rec cases_pattern_fold_map ?loc g e = CAst.with_val (function +let rec cases_pattern_fold_map ?loc g e = DAst.with_val (function | PatVar na -> - let e',na' = g e na in e', CAst.make ?loc @@ PatVar na' + let e',na' = g e na in e', DAst.make ?loc @@ PatVar na' | PatCstr (cstr,patl,na) -> let e',na' = g e na in - let e',patl' = List.fold_map (cases_pattern_fold_map ?loc g) e patl in - e', CAst.make ?loc @@ PatCstr (cstr,patl',na') + let e',patl' = List.fold_left_map (cases_pattern_fold_map ?loc g) e patl in + e', DAst.make ?loc @@ PatCstr (cstr,patl',na') ) let subst_binder_type_vars l = function | Evar_kinds.BinderType (Name id) -> let id = - try match Id.List.assoc id l with { CAst.v = GVar id' } -> id' | _ -> id + try match DAst.get (Id.List.assoc id l) with GVar id' -> id' | _ -> id with Not_found -> id in Evar_kinds.BinderType (Name id) | e -> e -let rec subst_glob_vars l gc = CAst.map (function - | GVar id as r -> (try (Id.List.assoc id l).CAst.v with Not_found -> r) +let rec subst_glob_vars l gc = DAst.map (function + | GVar id as r -> (try DAst.get (Id.List.assoc id l) with Not_found -> r) | GProd (Name id,bk,t,c) -> let id = - try match Id.List.assoc id l with { CAst.v = GVar id' } -> id' | _ -> id + try match DAst.get (Id.List.assoc id l) with GVar id' -> id' | _ -> id with Not_found -> id in GProd (Name id,bk,subst_glob_vars l t,subst_glob_vars l c) | GLambda (Name id,bk,t,c) -> let id = - try match Id.List.assoc id l with { CAst.v = GVar id' } -> id' | _ -> id + try match DAst.get (Id.List.assoc id l) with GVar id' -> id' | _ -> id with Not_found -> id in GLambda (Name id,bk,subst_glob_vars l t,subst_glob_vars l c) | GHole (x,naming,arg) -> GHole (subst_binder_type_vars l x,naming,arg) - | _ -> (map_glob_constr (subst_glob_vars l) gc).CAst.v (* assume: id is not binding *) + | _ -> DAst.get (map_glob_constr (subst_glob_vars l) gc) (* assume: id is not binding *) ) gc let ldots_var = Id.of_string ".." let glob_constr_of_notation_constr_with_binders ?loc g f e nc = - let lt x = CAst.make ?loc x in lt @@ match nc with + let lt x = DAst.make ?loc x in lt @@ match nc with | NVar id -> GVar id | NApp (a,args) -> GApp (f e a, List.map (f e) args) | NList (x,y,iter,tail,swap) -> @@ -143,13 +143,13 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = let innerl = (ldots_var,t)::(if swap then [] else [x, lt @@ GVar y]) in let inner = lt @@ GApp (lt @@ GVar (ldots_var),[subst_glob_vars innerl it]) in let outerl = (ldots_var,inner)::(if swap then [x, lt @@ GVar y] else []) in - (subst_glob_vars outerl it).CAst.v + DAst.get (subst_glob_vars outerl it) | NBinderList (x,y,iter,tail) -> let t = f e tail in let it = f e iter in let innerl = [(ldots_var,t);(x, lt @@ GVar y)] in let inner = lt @@ GApp (lt @@ GVar ldots_var,[subst_glob_vars innerl it]) in let outerl = [(ldots_var,inner)] in - (subst_glob_vars outerl it).CAst.v + DAst.get (subst_glob_vars outerl it) | NLambda (na,ty,c) -> let e',na = g e na in GLambda (na,Explicit,f e ty,f e' c) | NProd (na,ty,c) -> @@ -169,21 +169,21 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = let fold (idl,e) na = let (e,na) = g e na in ((Name.cons na idl,e),na) in let eqnl' = List.map (fun (patl,rhs) -> let ((idl,e),patl) = - List.fold_map (cases_pattern_fold_map ?loc fold) ([],e) patl in + List.fold_left_map (cases_pattern_fold_map ?loc fold) ([],e) patl in Loc.tag (idl,patl,f e rhs)) eqnl in GCases (sty,Option.map (f e') rtntypopt,tml',eqnl') | NLetTuple (nal,(na,po),b,c) -> - let e',nal = List.fold_map g e nal in + let e',nal = List.fold_left_map g e nal in let e'',na = g e na in GLetTuple (nal,(na,Option.map (f e'') po),f e b,f e' c) | NIf (c,(na,po),b1,b2) -> let e',na = g e na in GIf (f e c,(na,Option.map (f e') po),f e b1,f e b2) | NRec (fk,idl,dll,tl,bl) -> - let e,dll = Array.fold_map (List.fold_map (fun e (na,oc,b) -> + let e,dll = Array.fold_left_map (List.fold_left_map (fun e (na,oc,b) -> let e,na = g e na in (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in - let e',idl = Array.fold_map (to_id g) e idl in + let e',idl = Array.fold_left_map (to_id g) e idl in GRec (fk,idl,dll,Array.map (f e) tl,Array.map (f e') bl) | NCast (c,k) -> GCast (f e c,Miscops.map_cast_type (f e) k) | NSort x -> GSort x @@ -201,28 +201,34 @@ let glob_constr_of_notation_constr ?loc x = let add_id r id = r := (id :: pi1 !r, pi2 !r, pi3 !r) let add_name r = function Anonymous -> () | Name id -> add_id r id +let is_gvar id c = match DAst.get c with +| GVar id' -> Id.equal id id' +| _ -> false + let split_at_recursive_part c = let sub = ref None in - let open CAst in - let rec aux = function - | { loc = loc0; v = GApp ({ loc; v = GVar v },c::l) } when Id.equal v ldots_var -> (* *) + let rec aux c = + let loc0 = c.CAst.loc in + match DAst.get c with + | GApp (f, c::l) when is_gvar ldots_var f -> (* *) + let loc = f.CAst.loc in begin match !sub with | None -> let () = sub := Some c in begin match l with - | [] -> CAst.make ?loc @@ GVar ldots_var - | _ :: _ -> CAst.make ?loc:loc0 @@ GApp (CAst.make ?loc @@ GVar ldots_var, l) + | [] -> DAst.make ?loc @@ GVar ldots_var + | _ :: _ -> DAst.make ?loc:loc0 @@ GApp (DAst.make ?loc @@ GVar ldots_var, l) end | Some _ -> (* Not narrowed enough to find only one recursive part *) raise Not_found end - | c -> map_glob_constr aux c in + | _ -> map_glob_constr aux c in let outer_iterator = aux c in match !sub with | None -> (* No recursive pattern found *) raise Not_found | Some c -> - match outer_iterator.v with + match DAst.get outer_iterator with | GVar v when Id.equal v ldots_var -> (* Not enough context *) raise Not_found | _ -> outer_iterator, c @@ -231,7 +237,7 @@ let subtract_loc loc1 loc2 = let l2 = fst (Option.cata Loc.unloc (0,0) loc2) in Some (Loc.make_loc (l1,l2-1)) -let check_is_hole id = function { CAst.v = GHole _ } -> () | t -> +let check_is_hole id t = match DAst.get t with GHole _ -> () | _ -> user_err ?loc:(loc_of_glob_constr t) (strbrk "In recursive notation with binders, " ++ pr_id id ++ strbrk " is expected to come without type.") @@ -243,21 +249,24 @@ type recursive_pattern_kind = | RecursiveBinders of glob_constr * glob_constr let compare_recursive_parts found f f' (iterator,subc) = - let open CAst in let diff = ref None in let terminator = ref None in - let rec aux c1 c2 = match c1.v, c2.v with + let rec aux c1 c2 = match DAst.get c1, DAst.get c2 with | GVar v, term when Id.equal v ldots_var -> (* We found the pattern *) assert (match !terminator with None -> true | Some _ -> false); terminator := Some c2; true - | GApp ({ v = GVar v },l1), GApp (term, l2) when Id.equal v ldots_var -> + | GApp (f,l1), GApp (term, l2) -> + begin match DAst.get f with + | GVar v when Id.equal v ldots_var -> (* We found the pattern, but there are extra arguments *) (* (this allows e.g. alternative (recursive) notation of application) *) assert (match !terminator with None -> true | Some _ -> false); terminator := Some term; List.for_all2eq aux l1 l2 + | _ -> mk_glob_constr_eq aux c1 c2 + end | GVar x, GVar y when not (Id.equal x y) -> (* We found the position where it differs *) let lassoc = match !terminator with None -> false | Some _ -> true in @@ -288,28 +297,29 @@ let compare_recursive_parts found f f' (iterator,subc) = user_err ?loc:(subtract_loc loc1 loc2) (str "Both ends of the recursive pattern are the same.") | Some (x,y,RecursiveTerms lassoc) -> - let newfound,x,y,lassoc = + let toadd,x,y,lassoc = if List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi2 !found) || List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi3 !found) then - !found,x,y,lassoc + None,x,y,lassoc else if List.mem_f (pair_equal Id.equal Id.equal) (y,x) (pi2 !found) || List.mem_f (pair_equal Id.equal Id.equal) (y,x) (pi3 !found) then - !found,y,x,not lassoc + None,y,x,not lassoc else - (pi1 !found, (x,y) :: pi2 !found, pi3 !found),x,y,lassoc in + Some (x,y),x,y,lassoc in let iterator = f' (if lassoc then iterator - else subst_glob_vars [x, CAst.make @@ GVar y] iterator) in - (* found have been collected by compare_constr *) - found := newfound; + else subst_glob_vars [x, DAst.make @@ GVar y] iterator) in + (* found variables have been collected by compare_constr *) + found := (List.remove Id.equal y (pi1 !found), + Option.fold_right (fun a l -> a::l) toadd (pi2 !found), + pi3 !found); NList (x,y,iterator,f (Option.get !terminator),lassoc) | Some (x,y,RecursiveBinders (t_x,t_y)) -> - let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in - let iterator = f' (subst_glob_vars [x, CAst.make @@ GVar y] iterator) in + let iterator = f' (subst_glob_vars [x, DAst.make @@ GVar y] iterator) in (* found have been collected by compare_constr *) - found := newfound; + found := (List.remove Id.equal y (pi1 !found), pi2 !found, (x,y) :: pi3 !found); check_is_hole x t_x; check_is_hole y t_y; NBinderList (x,y,iterator,f (Option.get !terminator)) @@ -325,16 +335,21 @@ let notation_constr_and_vars_of_glob_constr a = try compare_recursive_parts found aux aux' (split_at_recursive_part c) with Not_found -> found := keepfound; - match c.CAst.v with - | GApp ({ CAst.v = GVar f; loc},[c]) when Id.equal f ldots_var -> + match DAst.get c with + | GApp (t, [_]) -> + begin match DAst.get t with + | GVar f when Id.equal f ldots_var -> (* Fall on the second part of the recursive pattern w/o having found the first part *) + let loc = t.CAst.loc in user_err ?loc (str "Cannot find where the recursive pattern starts.") + | _ -> aux' c + end | _c -> aux' c - and aux' x = CAst.with_val (function - | GVar id -> add_id found id; NVar id + and aux' x = DAst.with_val (function + | GVar id -> if not (Id.equal id ldots_var) then add_id found id; NVar id | GApp (g,args) -> NApp (aux g, List.map aux args) | GLambda (na,bk,ty,c) -> add_name found na; NLambda (na,aux ty,aux c) | GProd (na,bk,ty,c) -> add_name found na; NProd (na,aux ty,aux c) @@ -433,7 +448,7 @@ let notation_constr_of_glob_constr nenv a = let notation_constr_of_constr avoiding t = let t = EConstr.of_constr t in - let t = Detyping.detype false avoiding (Global.env()) Evd.empty t in + let t = Detyping.detype Detyping.Now false avoiding (Global.env()) Evd.empty t in let nenv = { ninterp_var_type = Id.Map.empty; ninterp_rec_vars = Id.Map.empty; @@ -441,13 +456,13 @@ let notation_constr_of_constr avoiding t = notation_constr_of_glob_constr nenv t let rec subst_pat subst pat = - match pat.CAst.v with + match DAst.get pat with | PatVar _ -> pat | PatCstr (((kn,i),j),cpl,n) -> let kn' = subst_mind subst kn and cpl' = List.smartmap (subst_pat subst) cpl in if kn' == kn && cpl' == cpl then pat else - CAst.make ?loc:pat.CAst.loc @@ PatCstr (((kn',i),j),cpl',n) + DAst.make ?loc:pat.CAst.loc @@ PatCstr (((kn',i),j),cpl',n) let rec subst_notation_constr subst bound raw = match raw with @@ -576,14 +591,14 @@ let abstract_return_type_context pi mklam tml rtno = List.fold_right mklam nal rtn) rtno -let abstract_return_type_context_glob_constr = +let abstract_return_type_context_glob_constr tml rtn = abstract_return_type_context (fun (_,(_,nal)) -> nal) - (fun na c -> CAst.make @@ - GLambda(na,Explicit,CAst.make @@ GHole(Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None),c)) + (fun na c -> DAst.make @@ + GLambda(na,Explicit,DAst.make @@ GHole(Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None),c)) tml rtn -let abstract_return_type_context_notation_constr = +let abstract_return_type_context_notation_constr tml rtn = abstract_return_type_context snd - (fun na c -> NLambda(na,NHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None),c)) + (fun na c -> NLambda(na,NHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None),c)) tml rtn let is_term_meta id metas = try match Id.List.assoc id metas with _,(NtnTypeConstr | NtnTypeConstrList) -> true | _ -> false @@ -651,19 +666,23 @@ let add_binding_env alp (terms,onlybinders,termlists,binderlists) var v = let add_bindinglist_env (terms,onlybinders,termlists,binderlists) x bl = (terms,onlybinders,termlists,(x,bl)::binderlists) -let rec pat_binder_of_term t = CAst.map (function +let rec pat_binder_of_term t = DAst.map (function | GVar id -> PatVar (Name id) - | GApp ({ CAst.v = GRef (ConstructRef cstr,_)}, l) -> + | GApp (t, l) -> + begin match DAst.get t with + | GRef (ConstructRef cstr,_) -> let nparams = Inductiveops.inductive_nparams (fst cstr) in let _,l = List.chop nparams l in PatCstr (cstr, List.map pat_binder_of_term l, Anonymous) + | _ -> raise No_match + end | _ -> raise No_match ) t let bind_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var v = try let v' = Id.List.assoc var terms in - match CAst.(v.v, v'.v) with + match DAst.get v, DAst.get v' with | GHole _, _ -> sigma | _, GHole _ -> let sigma = Id.List.remove_assoc var terms,onlybinders,termlists,binderlists in @@ -677,7 +696,7 @@ let bind_termlist_env alp (terms,onlybinders,termlists,binderlists as sigma) var try let vl' = Id.List.assoc var termlists in let unify_term v v' = - match CAst.(v.v, v'.v) with + match DAst.get v, DAst.get v' with | GHole _, _ -> v' | _, GHole _ -> v | _, _ -> if glob_constr_eq (alpha_rename (snd alp) v) v' then v' else raise No_match in @@ -693,8 +712,8 @@ let bind_termlist_env alp (terms,onlybinders,termlists,binderlists as sigma) var let bind_term_as_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var id = try - match Id.List.assoc var terms with - | { CAst.v = GVar id' } -> + match DAst.get (Id.List.assoc var terms) with + | GVar id' -> (if not (Id.equal id id') then (fst alp,(id,id')::snd alp) else alp), sigma | _ -> anomaly (str "A term which can be a binder has to be a variable.") @@ -702,7 +721,7 @@ let bind_term_as_binding_env alp (terms,onlybinders,termlists,binderlists as sig (* The matching against a term allowing to find the instance has not been found yet *) (* If it will be a different name, we shall unfortunately fail *) (* TODO: look at the consequences for alp *) - alp, add_env alp sigma var (CAst.make @@ GVar id) + alp, add_env alp sigma var (DAst.make @@ GVar id) let bind_binding_as_term_env alp (terms,onlybinders,termlists,binderlists as sigma) var id = try @@ -729,17 +748,19 @@ let bind_binding_env alp (terms,onlybinders,termlists,binderlists as sigma) var else (fst alp,(id1,id2)::snd alp),sigma with Not_found -> alp, add_binding_env alp sigma var v -let rec map_cases_pattern_name_left f = CAst.map (function +let rec map_cases_pattern_name_left f = DAst.map (function | PatVar na -> PatVar (f na) | PatCstr (c,l,na) -> PatCstr (c,List.map_left (map_cases_pattern_name_left f) l,f na) ) -let rec fold_cases_pattern_eq f x p p' = let open CAst in match p, p' with - | { loc; v = PatVar na}, { v = PatVar na' } -> let x,na = f x na na' in x, CAst.make ?loc @@ PatVar na - | { loc; v = PatCstr (c,l,na)}, { v = PatCstr (c',l',na') } when eq_constructor c c' -> +let rec fold_cases_pattern_eq f x p p' = + let loc = p.CAst.loc in + match DAst.get p, DAst.get p' with + | PatVar na, PatVar na' -> let x,na = f x na na' in x, DAst.make ?loc @@ PatVar na + | PatCstr (c,l,na), PatCstr (c',l',na') when eq_constructor c c' -> let x,l = fold_cases_pattern_list_eq f x l l' in let x,na = f x na na' in - x, CAst.make ?loc @@ PatCstr (c,l,na) + x, DAst.make ?loc @@ PatCstr (c,l,na) | _ -> failwith "Not equal" and fold_cases_pattern_list_eq f x pl pl' = match pl, pl' with @@ -750,7 +771,7 @@ and fold_cases_pattern_list_eq f x pl pl' = match pl, pl' with x, p :: pl | _ -> assert false -let rec cases_pattern_eq p1 p2 = match CAst.(p1.v, p2.v) with +let rec cases_pattern_eq p1 p2 = match DAst.get p1, DAst.get p2 with | PatVar na1, PatVar na2 -> Name.equal na1 na2 | PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && @@ -771,7 +792,7 @@ let bind_bindinglist_env alp (terms,onlybinders,termlists,binderlists as sigma) let unify_pat alp p p' = try fold_cases_pattern_eq unify_name alp p p' with Failure _ -> raise No_match in let unify_term alp v v' = - match CAst.(v.v, v'.v) with + match DAst.get v, DAst.get v' with | GHole _, _ -> v' | _, GHole _ -> v | _, _ -> if glob_constr_eq (alpha_rename (snd alp) v) v' then v else raise No_match in @@ -783,16 +804,16 @@ let bind_bindinglist_env alp (terms,onlybinders,termlists,binderlists as sigma) let unify_binding_kind bk bk' = if bk == bk' then bk' else raise No_match in let unify_binder alp b b' = let loc, loc' = CAst.(b.loc, b'.loc) in - match CAst.(b.v, b'.v) with + match DAst.get b, DAst.get b' with | GLocalAssum (na,bk,t), GLocalAssum (na',bk',t') -> let alp, na = unify_name alp na na' in - alp, CAst.make ?loc @@ GLocalAssum (na, unify_binding_kind bk bk', unify_term alp t t') + alp, DAst.make ?loc @@ GLocalAssum (na, unify_binding_kind bk bk', unify_term alp t t') | GLocalDef (na,bk,c,t), GLocalDef (na',bk',c',t') -> let alp, na = unify_name alp na na' in - alp, CAst.make ?loc @@ GLocalDef (na, unify_binding_kind bk bk', unify_term alp c c', unify_opt_term alp t t') + alp, DAst.make ?loc @@ GLocalDef (na, unify_binding_kind bk bk', unify_term alp c c', unify_opt_term alp t t') | GLocalPattern ((p,ids),id,bk,t), GLocalPattern ((p',_),_,bk',t') -> let alp, p = unify_pat alp p p' in - alp, CAst.make ?loc @@ GLocalPattern ((p,ids), id, unify_binding_kind bk bk', unify_term alp t t') + alp, DAst.make ?loc @@ GLocalPattern ((p,ids), id, unify_binding_kind bk bk', unify_term alp t t') | _ -> raise No_match in let rec unify alp bl bl' = match bl, bl' with @@ -803,7 +824,7 @@ let bind_bindinglist_env alp (terms,onlybinders,termlists,binderlists as sigma) alp, b :: bl | _ -> raise No_match in let alp, bl = unify alp bl bl' in - let sigma = (terms,Id.List.remove_assoc var onlybinders,termlists,binderlists) in + let sigma = (terms,onlybinders,termlists,Id.List.remove_assoc var binderlists) in alp, add_bindinglist_env sigma var bl with Not_found -> alp, add_bindinglist_env sigma var bl @@ -819,19 +840,22 @@ let bind_bindinglist_as_term_env alp (terms,onlybinders,termlists,binderlists) v let unify_pat p p' = if cases_pattern_eq (map_cases_pattern_name_left (name_app (rename_var (snd alp))) p) p' then p' else raise No_match in - let unify_term_binder c = CAst.(map (fun b' -> - match c, b' with - | { v = GVar id}, GLocalAssum (na', bk', t') -> + let unify_term_binder c = DAst.(map (fun b' -> + match DAst.get c, b' with + | GVar id, GLocalAssum (na', bk', t') -> GLocalAssum (unify_id id na', bk', t') - | c, GLocalPattern ((p',ids), id, bk', t') -> + | _, GLocalPattern ((p',ids), id, bk', t') -> let p = pat_binder_of_term c in GLocalPattern ((unify_pat p p',ids), id, bk', t') | _ -> raise No_match )) in let rec unify cl bl' = match cl, bl' with | [], [] -> [] - | c :: cl, { CAst.v = GLocalDef ( _, _, _, t) } :: bl' -> unify cl bl' - | c :: cl, b' :: bl' -> unify_term_binder c b' :: unify cl bl' + | c :: cl, b' :: bl' -> + begin match DAst.get b' with + | GLocalDef ( _, _, _, t) -> unify cl bl' + | _ -> unify_term_binder c b' :: unify cl bl' + end | _ -> raise No_match in let bl = unify cl bl' in let sigma = (terms,onlybinders,termlists,Id.List.remove_assoc var binderlists) in @@ -872,7 +896,7 @@ let match_names metas (alp,sigma) na1 na2 = match (na1,na2) with | _ -> raise No_match let rec match_cases_pattern_binders metas acc pat1 pat2 = - match CAst.(pat1.v, pat2.v) with + match DAst.get pat1, DAst.get pat2 with | PatVar na1, PatVar na2 -> match_names metas acc na1 na2 | PatCstr (c1,patl1,na1), PatCstr (c2,patl2,na2) when eq_constructor c1 c2 && Int.equal (List.length patl1) (List.length patl2) -> @@ -882,21 +906,29 @@ let rec match_cases_pattern_binders metas acc pat1 pat2 = let glue_letin_with_decls = true -let rec match_iterated_binders islambda decls bi = CAst.(with_loc_val (fun ?loc -> function - | GLambda (Name p,bk,t, { v = GCases (LetPatternStyle,None,[({ v = GVar e },_)],[(_,(ids,[cp],b))])}) - when islambda && Id.equal p e -> - match_iterated_binders islambda ((CAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t))::decls) b - | GLambda (na,bk,t,b) when islambda -> - match_iterated_binders islambda ((CAst.make ?loc @@ GLocalAssum(na,bk,t))::decls) b - | GProd (Name p,bk,t, { v = GCases (LetPatternStyle,None,[({ v = GVar e },_)],[(_,(ids,[cp],b))]) } ) - when not islambda && Id.equal p e -> - match_iterated_binders islambda ((CAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t))::decls) b - | GProd ((Name _ as na),bk,t,b) when not islambda -> - match_iterated_binders islambda ((CAst.make ?loc @@ GLocalAssum(na,bk,t))::decls) b +let rec match_iterated_binders islambda decls bi = DAst.(with_loc_val (fun ?loc -> function + | GLambda (na,bk,t,b) as b0 -> + begin match na, DAst.get b with + | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b))]) + when islambda && is_gvar p e && not (occur_glob_constr p b) -> + match_iterated_binders islambda ((DAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t))::decls) b + | _, _ when islambda -> + match_iterated_binders islambda ((DAst.make ?loc @@ GLocalAssum(na,bk,t))::decls) b + | _ -> (decls, DAst.make ?loc b0) + end + | GProd (na,bk,t,b) as b0 -> + begin match na, DAst.get b with + | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b))]) + when not islambda && is_gvar p e && not (occur_glob_constr p b) -> + match_iterated_binders islambda ((DAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t))::decls) b + | Name _, _ when not islambda -> + match_iterated_binders islambda ((DAst.make ?loc @@ GLocalAssum(na,bk,t))::decls) b + | _ -> (decls, DAst.make ?loc b0) + end | GLetIn (na,c,t,b) when glue_letin_with_decls -> match_iterated_binders islambda - ((CAst.make ?loc @@ GLocalDef (na,Explicit (*?*), c,t))::decls) b - | b -> (decls, CAst.make ?loc b) + ((DAst.make ?loc @@ GLocalDef (na,Explicit (*?*), c,t))::decls) b + | b -> (decls, DAst.make ?loc b) )) bi let remove_sigma x (terms,onlybinders,termlists,binderlists) = @@ -948,7 +980,7 @@ let match_termlist match_fun alp metas sigma rest x y iter termin lassoc = else bind_termlist_env alp sigma x l -let does_not_come_from_already_eta_expanded_var = +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 *) (* "F (fun x => H x)" and "H x" is recursively matched against the same *) @@ -958,12 +990,12 @@ let does_not_come_from_already_eta_expanded_var = (* The following test is then an approximation of what can be done *) (* optimally (whether other looping situations can occur remains to be *) (* checked). *) - function { CAst.v = GVar _ } -> false | _ -> true + match DAst.get glob with GVar _ -> false | _ -> true let rec match_ inner u alp metas sigma a1 a2 = let open CAst in let loc = a1.loc in - match a1.v, a2 with + match DAst.get a1, a2 with (* Matching notation variable *) | r1, NVar id2 when is_term_meta id2 metas -> bind_term_env alp sigma id2 a1 | GVar id1, NVar id2 when is_onlybinding_meta id2 metas -> bind_binding_as_term_env alp sigma id2 id1 @@ -973,50 +1005,64 @@ let rec match_ inner u alp metas sigma a1 a2 = | r1, NList (x,y,iter,termin,lassoc) -> match_termlist (match_hd u alp) alp metas sigma a1 x y iter termin lassoc - (* "λ p, let 'cp = p in t" -> "λ 'cp, t" *) - | GLambda (Name p,bk,t1, { v = GCases (LetPatternStyle,None,[({ v = GVar e},_)],[(_,(ids,[cp],b1))])}), - NBinderList (x,_,NLambda (Name _id2,_,b2),termin) when Id.equal p e -> - let (decls,b) = match_iterated_binders true [CAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t1)] b1 in + | GLambda (na1, bk, t1, b1), NBinderList (x,y,iter,termin) -> + begin match na1, DAst.get b1, iter with + (* "λ p, let 'cp = p in t" -> "λ 'cp, t" *) + | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b1))]), NLambda (Name _, _, _) + when is_gvar p e && not (occur_glob_constr p b1) -> + let (decls,b) = match_iterated_binders true [DAst.make ?loc @@ GLocalPattern((cp,ids),p,bk,t1)] b1 in let alp,sigma = bind_bindinglist_env alp sigma x decls in match_in u alp metas sigma b termin - - (* Matching recursive notations for binders: ad hoc cases supporting let-in *) - | GLambda (na1,bk,t1,b1), NBinderList (x,_,NLambda (Name _id2,_,b2),termin)-> - let (decls,b) = match_iterated_binders true [CAst.make ?loc @@ GLocalAssum (na1,bk,t1)] b1 in + (* Matching recursive notations for binders: ad hoc cases supporting let-in *) + | _, _, NLambda (Name _,_,_) -> + let (decls,b) = match_iterated_binders true [DAst.make ?loc @@ GLocalAssum (na1,bk,t1)] b1 in (* TODO: address the possibility that termin is a Lambda itself *) let alp,sigma = bind_bindinglist_env alp sigma x decls in match_in u alp metas sigma b termin - - (* "∀ p, let 'cp = p in t" -> "∀ 'cp, t" *) - | GProd (Name p,bk,t1, { v = GCases (LetPatternStyle,None,[({ v = GVar e },_)],[(_,(ids,[cp],b1))]) } ), - NBinderList (x,_,NProd (Name _id2,_,b2),(NVar v as termin)) when Id.equal p e -> - let (decls,b) = match_iterated_binders true [CAst.make ?loc @@ GLocalPattern ((cp,ids),p,bk,t1)] b1 in + (* Matching recursive notations for binders: general case *) + | _, _, _ -> + match_binderlist_with_app (match_hd u) alp metas sigma a1 x y iter termin + end + + | GProd (na1, bk, t1, b1), NBinderList (x,y,iter,termin) -> + (* "∀ p, let 'cp = p in t" -> "∀ 'cp, t" *) + begin match na1, DAst.get b1, iter, termin with + | Name p, GCases (LetPatternStyle,None,[(e, _)],[(_,(ids,[cp],b1))]), NProd (Name _,_,_), NVar _ + when is_gvar p e && not (occur_glob_constr p b1) -> + let (decls,b) = match_iterated_binders true [DAst.make ?loc @@ GLocalPattern ((cp,ids),p,bk,t1)] b1 in let alp,sigma = bind_bindinglist_env alp sigma x decls in match_in u alp metas sigma b termin - - | GProd (na1,bk,t1,b1), NBinderList (x,_,NProd (Name _id2,_,b2),termin) - when na1 != Anonymous -> - let (decls,b) = match_iterated_binders false [CAst.make ?loc @@ GLocalAssum (na1,bk,t1)] b1 in + | _, _, NProd (Name _,_,_), _ when na1 != Anonymous -> + let (decls,b) = match_iterated_binders false [DAst.make ?loc @@ GLocalAssum (na1,bk,t1)] b1 in (* TODO: address the possibility that termin is a Prod itself *) let alp,sigma = bind_bindinglist_env alp sigma x decls in match_in u alp metas sigma b termin + (* Matching recursive notations for binders: general case *) + | _, _, _, _ -> + match_binderlist_with_app (match_hd u) alp metas sigma a1 x y iter termin + end + (* Matching recursive notations for binders: general case *) | _r, NBinderList (x,y,iter,termin) -> - match_binderlist_with_app (match_hd u) alp metas sigma a1 x y iter termin + match_binderlist_with_app (match_hd u) alp metas sigma a1 x y iter termin (* Matching individual binders as part of a recursive pattern *) - | GLambda (Name p,bk,t, { v = GCases (LetPatternStyle,None,[({ v = GVar e },_)],[(_,(ids,[cp],b1))])}), - NLambda (Name id,_,b2) - when is_bindinglist_meta id metas -> - let alp,sigma = bind_bindinglist_env alp sigma id [CAst.make ?loc @@ GLocalPattern ((cp,ids),p,bk,t)] in + | GLambda (na1, bk, t1, b1), NLambda (na2, t2, b2) -> + begin match na1, DAst.get b1, na2 with + | Name p, GCases (LetPatternStyle,None,[(e,_)],[(_,(ids,[cp],b1))]), Name id + when is_gvar p e && is_bindinglist_meta id metas && not (occur_glob_constr p b1) -> + let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalPattern ((cp,ids),p,bk,t1)] in match_in u alp metas sigma b1 b2 - | GLambda (na,bk,t,b1), NLambda (Name id,_,b2) - when is_bindinglist_meta id metas -> - let alp,sigma = bind_bindinglist_env alp sigma id [CAst.make ?loc @@ GLocalAssum (na,bk,t)] in + | _, _, Name id when is_bindinglist_meta id metas -> + let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalAssum (na1,bk,t1)] in match_in u alp metas sigma b1 b2 + | _ -> + match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 + end + | GProd (na,bk,t,b1), NProd (Name id,_,b2) when is_bindinglist_meta id metas && na != Anonymous -> - let alp,sigma = bind_bindinglist_env alp sigma id [CAst.make ?loc @@ GLocalAssum (na,bk,t)] in + let alp,sigma = bind_bindinglist_env alp sigma id [DAst.make ?loc @@ GLocalAssum (na,bk,t)] in match_in u alp metas sigma b1 b2 (* Matching compositionally *) @@ -1028,13 +1074,11 @@ let rec match_ inner u alp metas sigma a1 a2 = if n1 < n2 then let l21,l22 = List.chop (n2-n1) l2 in f1,l1, NApp (f2,l21), l22 else if n1 > n2 then - let l11,l12 = List.chop (n1-n2) l1 in CAst.make ?loc @@ GApp (f1,l11),l12, f2,l2 + let l11,l12 = List.chop (n1-n2) l1 in DAst.make ?loc @@ GApp (f1,l11),l12, f2,l2 else f1,l1, f2, l2 in let may_use_eta = does_not_come_from_already_eta_expanded_var f1 in List.fold_left2 (match_ may_use_eta u alp metas) (match_in u alp metas sigma f1 f2) l1 l2 - | GLambda (na1,_,t1,b1), NLambda (na2,t2,b2) -> - match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 | GProd (na1,_,t1,b1), NProd (na2,t2,b2) -> match_binders u alp metas na1 na2 (match_in u alp metas sigma t1 t2) b1 b2 | GLetIn (na1,b1,_,c1), NLetIn (na2,b2,None,c2) @@ -1101,17 +1145,17 @@ let rec match_ inner u alp metas sigma a1 a2 = let avoid = free_glob_vars a1 @ (* as in Namegen: *) glob_visible_short_qualid a1 in let id' = Namegen.next_ident_away id avoid in - let t1 = CAst.make @@ GHole(Evar_kinds.BinderType (Name id'),Misctypes.IntroAnonymous,None) in + let t1 = DAst.make @@ GHole(Evar_kinds.BinderType (Name id'),Misctypes.IntroAnonymous,None) in let sigma = match t2 with | NHole _ -> sigma | NVar id2 -> bind_term_env alp sigma id2 t1 | _ -> assert false in let (alp,sigma) = if is_bindinglist_meta id metas then - bind_bindinglist_env alp sigma id [CAst.make @@ GLocalAssum (Name id',Explicit,t1)] + bind_bindinglist_env alp sigma id [DAst.make @@ GLocalAssum (Name id',Explicit,t1)] else match_names metas (alp,sigma) (Name id') na in - match_in u alp metas sigma (mkGApp a1 (CAst.make @@ GVar id')) b2 + match_in u alp metas sigma (mkGApp a1 (DAst.make @@ GVar id')) b2 | (GRec _ | GEvar _), _ | _,_ -> raise No_match @@ -1132,7 +1176,7 @@ and match_equations u alp metas sigma (_,(_,patl1,rhs1)) (patl2,rhs2) = (alp,sigma) patl1 patl2 in match_in u alp metas sigma rhs1 rhs2 -let term_of_binder bi = CAst.make @@ match bi with +let term_of_binder bi = DAst.make @@ match bi with | Name id -> GVar id | Anonymous -> GHole (Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) @@ -1145,7 +1189,7 @@ let match_notation_constr u c (metas,pat) = with Not_found -> (* Happens for binders bound to Anonymous *) (* Find a better way to propagate Anonymous... *) - CAst.make @@GVar x in + DAst.make @@GVar x in List.fold_right (fun (x,(scl,typ)) (terms',termlists',binders') -> match typ with | NtnTypeConstr -> @@ -1185,8 +1229,7 @@ let match_cases_pattern_list match_fun metas sigma rest x y iter termin lassoc = (terms,onlybinders,(x,if lassoc then l else List.rev l)::termlists, binderlists) let rec match_cases_pattern metas (terms,(),termlists,() as sigma) a1 a2 = - let open CAst in - match a1.v, a2 with + match DAst.get a1, a2 with | r1, NVar id2 when Id.List.mem_assoc id2 metas -> (bind_env_cases_pattern sigma id2 a1),(0,[]) | PatVar Anonymous, NHole _ -> sigma,(0,[]) | PatCstr ((ind,_ as r1),largs,_), NRef (ConstructRef r2) when eq_constructor r1 r2 -> diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index 3154fd7adb..0904a4ea3e 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -47,19 +47,19 @@ val glob_constr_of_notation_constr : ?loc:Loc.t -> notation_constr -> glob_const exception No_match -val match_notation_constr : bool -> glob_constr -> interpretation -> - (glob_constr * subscopes) list * (glob_constr list * subscopes) list * - (extended_glob_local_binder list * subscopes) list +val match_notation_constr : bool -> 'a glob_constr_g -> interpretation -> + ('a glob_constr_g * subscopes) list * ('a glob_constr_g list * subscopes) list * + ('a extended_glob_local_binder_g list * subscopes) list val match_notation_constr_cases_pattern : - cases_pattern -> interpretation -> - ((cases_pattern * subscopes) list * (cases_pattern list * subscopes) list) * - (int * cases_pattern list) + 'a cases_pattern_g -> interpretation -> + (('a cases_pattern_g * subscopes) list * ('a cases_pattern_g list * subscopes) list) * + (int * 'a cases_pattern_g list) val match_notation_constr_ind_pattern : - inductive -> cases_pattern list -> interpretation -> - ((cases_pattern * subscopes) list * (cases_pattern list * subscopes) list) * - (int * cases_pattern list) + inductive -> 'a cases_pattern_g list -> interpretation -> + (('a cases_pattern_g * subscopes) list * ('a cases_pattern_g list * subscopes) list) * + (int * 'a cases_pattern_g list) (** {5 Matching a notation pattern against a [glob_constr]} *) diff --git a/interp/reserve.ml b/interp/reserve.ml index b05f052837..a1e5bd0ea9 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -110,7 +110,7 @@ let revert_reserved_type t = let t = EConstr.Unsafe.to_constr t in let reserved = KeyMap.find (constr_key t) !reserve_revtable in let t = EConstr.of_constr t in - let t = Detyping.detype false [] (Global.env()) Evd.empty t in + let t = Detyping.detype Detyping.Now false [] (Global.env()) Evd.empty t in (* pedrot: if [Notation_ops.match_notation_constr] may raise [Failure _] then I've introduced a bug... *) let filter _ pat = diff --git a/interp/stdarg.ml b/interp/stdarg.ml index 274ea6213b..45dec5112b 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -50,6 +50,8 @@ let wit_ref = make0 "ref" let wit_quant_hyp = make0 "quant_hyp" +let wit_sort_family = make0 "sort_family" + let wit_constr = make0 "constr" diff --git a/interp/stdarg.mli b/interp/stdarg.mli index 1d4a29b9c2..dffbd6659f 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -47,6 +47,8 @@ val wit_ref : (reference, global_reference located or_var, global_reference) gen val wit_quant_hyp : quantified_hypothesis uniform_genarg_type +val wit_sort_family : (Sorts.family, unit, unit) genarg_type + val wit_constr : (constr_expr, glob_constr_and_expr, constr) genarg_type val wit_uconstr : (constr_expr , glob_constr_and_expr, Glob_term.closed_glob_constr) genarg_type diff --git a/intf/glob_term.ml b/intf/glob_term.ml index dd122b972d..757ba57868 100644 --- a/intf/glob_term.ml +++ b/intf/glob_term.ml @@ -24,66 +24,82 @@ type existential_name = Id.t (** The kind of patterns that occurs in "match ... with ... end" locs here refers to the ident's location, not whole pat *) -type cases_pattern_r = +type 'a cases_pattern_r = | PatVar of Name.t - | PatCstr of constructor * cases_pattern list * Name.t + | PatCstr of constructor * 'a cases_pattern_g list * Name.t (** [PatCstr(p,C,l,x)] = "|'C' 'l' as 'x'" *) -and cases_pattern = cases_pattern_r CAst.t +and 'a cases_pattern_g = ('a cases_pattern_r, 'a) DAst.t + +type cases_pattern = [ `any ] cases_pattern_g (** Representation of an internalized (or in other words globalized) term. *) -type glob_constr_r = +type 'a glob_constr_r = | GRef of global_reference * glob_level list option (** An identifier that represents a reference to an object defined either in the (global) environment or in the (local) context. *) | GVar of Id.t (** An identifier that cannot be regarded as "GRef". Bound variables are typically represented this way. *) - | GEvar of existential_name * (Id.t * glob_constr) list + | GEvar of existential_name * (Id.t * 'a glob_constr_g) list | GPatVar of Evar_kinds.matching_var_kind (** Used for patterns only *) - | GApp of glob_constr * glob_constr list - | GLambda of Name.t * binding_kind * glob_constr * glob_constr - | GProd of Name.t * binding_kind * glob_constr * glob_constr - | GLetIn of Name.t * glob_constr * glob_constr option * glob_constr - | GCases of case_style * glob_constr option * tomatch_tuples * cases_clauses + | GApp of 'a glob_constr_g * 'a glob_constr_g list + | GLambda of Name.t * binding_kind * 'a glob_constr_g * 'a glob_constr_g + | GProd of Name.t * binding_kind * 'a glob_constr_g * 'a glob_constr_g + | GLetIn of Name.t * 'a glob_constr_g * 'a glob_constr_g option * 'a glob_constr_g + | GCases of case_style * 'a glob_constr_g option * 'a tomatch_tuples_g * 'a cases_clauses_g (** [GCases(style,r,tur,cc)] = "match 'tur' return 'r' with 'cc'" (in [MatchStyle]) *) - | GLetTuple of Name.t list * (Name.t * glob_constr option) * glob_constr * glob_constr - | GIf of glob_constr * (Name.t * glob_constr option) * glob_constr * glob_constr - | GRec of fix_kind * Id.t array * glob_decl list array * - glob_constr array * glob_constr array + | GLetTuple of Name.t list * (Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g + | GIf of 'a glob_constr_g * (Name.t * 'a glob_constr_g option) * 'a glob_constr_g * 'a glob_constr_g + | GRec of 'a fix_kind_g * Id.t array * 'a glob_decl_g list array * + 'a glob_constr_g array * 'a glob_constr_g array | GSort of glob_sort | GHole of Evar_kinds.t * intro_pattern_naming_expr * Genarg.glob_generic_argument option - | GCast of glob_constr * glob_constr cast_type -and glob_constr = glob_constr_r CAst.t + | GCast of 'a glob_constr_g * 'a glob_constr_g cast_type +and 'a glob_constr_g = ('a glob_constr_r, 'a) DAst.t -and glob_decl = Name.t * binding_kind * glob_constr option * glob_constr +and 'a glob_decl_g = Name.t * binding_kind * 'a glob_constr_g option * 'a glob_constr_g -and fix_recursion_order = +and 'a fix_recursion_order_g = | GStructRec - | GWfRec of glob_constr - | GMeasureRec of glob_constr * glob_constr option + | GWfRec of 'a glob_constr_g + | GMeasureRec of 'a glob_constr_g * 'a glob_constr_g option -and fix_kind = - | GFix of ((int option * fix_recursion_order) array * int) +and 'a fix_kind_g = + | GFix of ((int option * 'a fix_recursion_order_g) array * int) | GCoFix of int -and predicate_pattern = +and 'a predicate_pattern_g = Name.t * (inductive * Name.t list) Loc.located option (** [(na,id)] = "as 'na' in 'id'" where if [id] is [Some(l,I,k,args)]. *) -and tomatch_tuple = (glob_constr * predicate_pattern) +and 'a tomatch_tuple_g = ('a glob_constr_g * 'a predicate_pattern_g) -and tomatch_tuples = tomatch_tuple list +and 'a tomatch_tuples_g = 'a tomatch_tuple_g list -and cases_clause = (Id.t list * cases_pattern list * glob_constr) Loc.located +and 'a cases_clause_g = (Id.t list * 'a cases_pattern_g list * 'a glob_constr_g) Loc.located (** [(p,il,cl,t)] = "|'cl' => 't'". Precondition: the free variables of [t] are members of [il]. *) -and cases_clauses = cases_clause list - -type extended_glob_local_binder_r = - | GLocalAssum of Name.t * binding_kind * glob_constr - | GLocalDef of Name.t * binding_kind * glob_constr * glob_constr option - | GLocalPattern of (cases_pattern * Id.t list) * Id.t * binding_kind * glob_constr -and extended_glob_local_binder = extended_glob_local_binder_r CAst.t +and 'a cases_clauses_g = 'a cases_clause_g list + +type glob_constr = [ `any ] glob_constr_g +type tomatch_tuple = [ `any ] tomatch_tuple_g +type tomatch_tuples = [ `any ] tomatch_tuples_g +type cases_clause = [ `any ] cases_clause_g +type cases_clauses = [ `any ] cases_clauses_g +type glob_decl = [ `any ] glob_decl_g +type fix_kind = [ `any ] fix_kind_g +type predicate_pattern = [ `any ] predicate_pattern_g +type fix_recursion_order = [ `any ] fix_recursion_order_g + +type any_glob_constr = AnyGlobConstr : 'r glob_constr_g -> any_glob_constr + +type 'a extended_glob_local_binder_r = + | GLocalAssum of Name.t * binding_kind * 'a glob_constr_g + | GLocalDef of Name.t * binding_kind * 'a glob_constr_g * 'a glob_constr_g option + | GLocalPattern of ('a cases_pattern_g * Id.t list) * Id.t * binding_kind * 'a glob_constr_g +and 'a extended_glob_local_binder_g = ('a extended_glob_local_binder_r, 'a) DAst.t + +type extended_glob_local_binder = [ `any ] extended_glob_local_binder_g (** A globalised term together with a closure representing the value of its free variables. Intended for use when these variables are taken diff --git a/intf/vernacexpr.ml b/intf/vernacexpr.ml index 2adf522b74..94e166f920 100644 --- a/intf/vernacexpr.ml +++ b/intf/vernacexpr.ml @@ -169,7 +169,7 @@ type option_ref_value = (** Identifier and optional list of bound universes. *) type plident = lident * lident list option -type sort_expr = glob_sort +type sort_expr = Sorts.family type definition_expr = | ProveBody of local_binder_expr list * constr_expr @@ -325,7 +325,7 @@ type vernac_expr = (* Syntax *) | VernacSyntaxExtension of - obsolete_locality * (lstring * syntax_modifier list) + bool * obsolete_locality * (lstring * syntax_modifier list) | VernacOpenCloseScope of obsolete_locality * (bool * scope_name) | VernacDelimiters of scope_name * string option | VernacBindScope of scope_name * class_rawexpr list diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 9697b0b8b2..e17fb1c38f 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -250,16 +250,16 @@ and module_implementation = | Struct of module_signature (** interactive body *) | FullStruct (** special case of [Struct] : the body is exactly [mod_type] *) -and module_body = +and 'a generic_module_body = { mod_mp : module_path; (** absolute path of the module *) - mod_expr : module_implementation; (** implementation *) + mod_expr : 'a; (** implementation *) mod_type : module_signature; (** expanded type *) mod_type_alg : module_expression option; (** algebraic type *) mod_constraints : Univ.ContextSet.t; (** set of all universes constraints in the module *) mod_delta : Mod_subst.delta_resolver; (** quotiented set of equivalent constants and inductive names *) - mod_retroknowledge : Retroknowledge.action list } + mod_retroknowledge : 'a module_retroknowledge } (** For a module, there are five possible situations: - [Declare Module M : T] then [mod_expr = Abstract; mod_type_alg = Some T] @@ -269,13 +269,19 @@ and module_body = - [Module M : T. ... End M] then [mod_expr = Struct; mod_type_alg = Some T] And of course, all these situations may be functors or not. *) -(** A [module_type_body] is just a [module_body] with no - implementation ([mod_expr] always [Abstract]) and also - an empty [mod_retroknowledge]. Its [mod_type_alg] contains +and module_body = module_implementation generic_module_body + +(** A [module_type_body] is just a [module_body] with no implementation and + also an empty [mod_retroknowledge]. Its [mod_type_alg] contains the algebraic definition of this module type, or [None] if it has been built interactively. *) -and module_type_body = module_body +and module_type_body = unit generic_module_body + +and _ module_retroknowledge = +| ModBodyRK : + Retroknowledge.action list -> module_implementation module_retroknowledge +| ModTypeRK : unit module_retroknowledge (** Extra invariants : diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 85dd1e66db..66d66c7d09 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -318,7 +318,7 @@ let rec hcons_structure_field_body sb = match sb with let mb' = hcons_module_body mb in if mb == mb' then sb else SFBmodule mb' | SFBmodtype mb -> - let mb' = hcons_module_body mb in + let mb' = hcons_module_type mb in if mb == mb' then sb else SFBmodtype mb' and hcons_structure_body sb = @@ -331,10 +331,10 @@ and hcons_structure_body sb = List.smartmap map sb and hcons_module_signature ms = - hcons_functorize hcons_module_body hcons_structure_body hcons_module_signature ms + hcons_functorize hcons_module_type hcons_structure_body hcons_module_signature ms and hcons_module_expression me = - hcons_functorize hcons_module_body hcons_module_alg_expr hcons_module_expression me + hcons_functorize hcons_module_type hcons_module_alg_expr hcons_module_expression me and hcons_module_implementation mip = match mip with | Abstract -> Abstract @@ -346,9 +346,11 @@ and hcons_module_implementation mip = match mip with if ms == ms' then mip else Struct ms | FullStruct -> FullStruct -and hcons_module_body mb = +and hcons_generic_module_body : + 'a. ('a -> 'a) -> 'a generic_module_body -> 'a generic_module_body = + fun hcons_impl mb -> let mp' = mb.mod_mp in - let expr' = hcons_module_implementation mb.mod_expr in + let expr' = hcons_impl mb.mod_expr in let type' = hcons_module_signature mb.mod_type in let type_alg' = mb.mod_type_alg in let constraints' = Univ.hcons_universe_context_set mb.mod_constraints in @@ -373,3 +375,9 @@ and hcons_module_body mb = mod_delta = delta'; mod_retroknowledge = retroknowledge'; } + +and hcons_module_body mb = + hcons_generic_module_body hcons_module_implementation mb + +and hcons_module_type mb = + hcons_generic_module_body (fun () -> ()) mb diff --git a/kernel/declareops.mli b/kernel/declareops.mli index a8ba5fa392..b2d29759da 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -78,3 +78,4 @@ val safe_flags : typing_flags val hcons_const_body : constant_body -> constant_body val hcons_mind : mutual_inductive_body -> mutual_inductive_body val hcons_module_body : module_body -> module_body +val hcons_module_type : module_type_body -> module_type_body diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 0888ccc109..d2b41aae98 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -264,7 +264,9 @@ let rec translate_mse env mpo inl = function |MEident mp1 as me -> let mb = match mpo with |Some mp -> strengthen_and_subst_mb (lookup_module mp1 env) mp false - |None -> lookup_modtype mp1 env + |None -> + let mt = lookup_modtype mp1 env in + module_body_of_type mt.mod_mp mt in mb.mod_type, me, mb.mod_delta, Univ.ContextSet.empty |MEapply (fe,mp1) -> @@ -281,9 +283,11 @@ let mk_mod mp e ty cst reso = mod_type_alg = None; mod_constraints = cst; mod_delta = reso; - mod_retroknowledge = [] } + mod_retroknowledge = ModBodyRK []; } -let mk_modtype mp ty cst reso = mk_mod mp Abstract ty cst reso +let mk_modtype mp ty cst reso = + let mb = mk_mod mp Abstract ty cst reso in + { mb with mod_expr = (); mod_retroknowledge = ModTypeRK } let rec translate_mse_funct env mpo inl mse = function |[] -> @@ -319,6 +323,7 @@ let finalize_module env mp (sign,alg,reso,cst) restype = match restype with { res_mtb with mod_mp = mp; mod_expr = impl; + mod_retroknowledge = ModBodyRK []; (** cst from module body typing, cst' from subtyping, constraints from module type. *) diff --git a/kernel/modops.ml b/kernel/modops.ml index a079bc8931..76915e917a 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -143,11 +143,12 @@ let rec functor_iter fty f0 = function (** {6 Misc operations } *) let module_type_of_module mb = - { mb with mod_expr = Abstract; mod_type_alg = None } + { mb with mod_expr = (); mod_type_alg = None; + mod_retroknowledge = ModTypeRK; } let module_body_of_type mp mtb = - assert (mtb.mod_expr == Abstract); - { mtb with mod_mp = mp } + { mtb with mod_expr = Abstract; mod_mp = mp; + mod_retroknowledge = ModBodyRK []; } let check_modpath_equiv env mp1 mp2 = if ModPath.equal mp1 mp2 then () @@ -196,7 +197,8 @@ let rec subst_structure sub do_delta sign = in List.smartmap subst_body sign -and subst_body is_mod sub do_delta mb = +and subst_body : 'a. _ -> _ -> (_ -> 'a -> 'a) -> _ -> 'a generic_module_body -> 'a generic_module_body = + fun is_mod sub subst_impl do_delta mb -> let { mod_mp=mp; mod_expr=me; mod_type=ty; mod_type_alg=aty } = mb in let mp' = subst_mp sub mp in let sub = @@ -205,10 +207,7 @@ and subst_body is_mod sub do_delta mb = else add_mp mp mp' empty_delta_resolver sub in let ty' = subst_signature sub do_delta ty in - let me' = - implem_smartmap - (subst_signature sub id_delta) (subst_expression sub id_delta) me - in + let me' = subst_impl sub me in let aty' = Option.smartmap (subst_expression sub id_delta) aty in let delta' = do_delta mb.mod_delta sub in if mp==mp' && me==me' && ty==ty' && aty==aty' && delta'==mb.mod_delta @@ -221,9 +220,14 @@ and subst_body is_mod sub do_delta mb = mod_type_alg = aty'; mod_delta = delta' } -and subst_module sub do_delta mb = subst_body true sub do_delta mb +and subst_module sub do_delta mb = + subst_body true sub subst_impl do_delta mb + +and subst_impl sub me = + implem_smartmap + (subst_signature sub id_delta) (subst_expression sub id_delta) me -and subst_modtype sub do_delta mtb = subst_body false sub do_delta mtb +and subst_modtype sub do_delta mtb = subst_body false sub (fun _ () -> ()) do_delta mtb and subst_expr sub do_delta seb = match seb with |MEident mp -> @@ -268,7 +272,7 @@ let add_retroknowledge mp = CErrors.anomaly ~label:"Modops.add_retroknowledge" (Pp.str "had to import an unsupported kind of term.") in - fun lclrk env -> + fun (ModBodyRK lclrk) env -> (* The order of the declaration matters, for instance (and it's at the time this comment is being written, the only relevent instance) the int31 type registration absolutely needs int31 bits to be registered. @@ -567,7 +571,7 @@ let rec is_bounded_expr l = function is_bounded_expr l (MEident mp) || is_bounded_expr l fexpr | _ -> false -let rec clean_module l mb = +let rec clean_module_body l mb = let impl, typ = mb.mod_expr, mb.mod_type in let typ' = clean_signature l typ in let impl' = match impl with @@ -577,19 +581,25 @@ let rec clean_module l mb = if typ==typ' && impl==impl' then mb else { mb with mod_type=typ'; mod_expr=impl' } +and clean_module_type l mb = + let (), typ = mb.mod_expr, mb.mod_type in + let typ' = clean_signature l typ in + if typ==typ' then mb + else { mb with mod_type=typ' } + and clean_field l field = match field with |(lab,SFBmodule mb) -> - let mb' = clean_module l mb in + let mb' = clean_module_body l mb in if mb==mb' then field else (lab,SFBmodule mb') |_ -> field and clean_structure l = List.smartmap (clean_field l) and clean_signature l = - functor_smartmap (clean_module l) (clean_structure l) + functor_smartmap (clean_module_type l) (clean_structure l) and clean_expression l = - functor_smartmap (clean_module l) (fun me -> me) + functor_smartmap (clean_module_type l) (fun me -> me) let rec collect_mbid l sign = match sign with |MoreFunctor (mbid,ty,m) -> @@ -613,14 +623,16 @@ let join_constant_body except otab cb = | _ -> () let join_structure except otab s = - let rec join_module mb = - implem_iter join_signature join_expression mb.mod_expr; + let rec join_module : 'a. 'a generic_module_body -> unit = fun mb -> Option.iter join_expression mb.mod_type_alg; join_signature mb.mod_type and join_field (l,body) = match body with |SFBconst sb -> join_constant_body except otab sb |SFBmind _ -> () - |SFBmodule m |SFBmodtype m -> join_module m + |SFBmodule m -> + implem_iter join_signature join_expression m.mod_expr; + join_module m + |SFBmodtype m -> join_module m and join_structure struc = List.iter join_field struc and join_signature sign = functor_iter join_module join_structure sign diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 7b4fb4e869..94738d6186 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -156,7 +156,7 @@ let map_named_val f ctxt = in (accu, d') in - let map, ctx = List.fold_map fold ctxt.env_named_map ctxt.env_named_ctx in + let map, ctx = List.fold_left_map fold ctxt.env_named_map ctxt.env_named_ctx in if map == ctxt.env_named_map then ctxt else { env_named_ctx = ctx; env_named_map = map } diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 04051f2e23..ad622b07d8 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -574,7 +574,7 @@ let add_mind dir l mie senv = let add_modtype l params_mte inl senv = let mp = MPdot(senv.modpath, l) in let mtb = Mod_typing.translate_modtype senv.env mp inl params_mte in - let mtb = Declareops.hcons_module_body mtb in + let mtb = Declareops.hcons_module_type mtb in let senv' = add_field (l,SFBmodtype mtb) MT senv in mp, senv' @@ -677,7 +677,7 @@ let build_module_body params restype senv = (struc,None,senv.modresolver,senv.univ) restype' in let mb' = functorize_module params mb in - { mb' with mod_retroknowledge = senv.local_retroknowledge } + { mb' with mod_retroknowledge = ModBodyRK senv.local_retroknowledge } (** Returning back to the old pre-interactive-module environment, with one extra component and some updated fields @@ -732,12 +732,12 @@ let end_module l restype senv = let build_mtb mp sign cst delta = { mod_mp = mp; - mod_expr = Abstract; + mod_expr = (); mod_type = sign; mod_type_alg = None; mod_constraints = cst; mod_delta = delta; - mod_retroknowledge = [] } + mod_retroknowledge = ModTypeRK } let end_modtype l senv = let mp = senv.modpath in @@ -853,7 +853,7 @@ let export ?except senv dir = mod_type_alg = None; mod_constraints = senv.univ; mod_delta = senv.modresolver; - mod_retroknowledge = senv.local_retroknowledge + mod_retroknowledge = ModBodyRK senv.local_retroknowledge } in let ast, symbols = diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index b311165f10..b564b2a8c1 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -416,7 +416,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = mod_type = subst_signature subst1 body_t1; mod_type_alg = None; mod_constraints = mtb1.mod_constraints; - mod_retroknowledge = []; + mod_retroknowledge = ModBodyRK []; mod_delta = mtb1.mod_delta} env in check_structure cst env body_t1 body_t2 equiv subst1 subst2 diff --git a/kernel/univ.ml b/kernel/univ.ml index d915fb8c98..bae782f5d4 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -31,133 +31,6 @@ open Util union-find algorithm. The assertions $<$ and $\le$ are represented by adjacency lists *) -module type Hashconsed = -sig - type t - val hash : t -> int - val eq : t -> t -> bool - val hcons : t -> t -end - -module HashedList (M : Hashconsed) : -sig - type t = private Nil | Cons of M.t * int * t - val nil : t - val cons : M.t -> t -> t -end = -struct - type t = Nil | Cons of M.t * int * t - module Self = - struct - type _t = t - type t = _t - type u = (M.t -> M.t) - let hash = function Nil -> 0 | Cons (_, h, _) -> h - let eq l1 l2 = match l1, l2 with - | Nil, Nil -> true - | Cons (x1, _, l1), Cons (x2, _, l2) -> x1 == x2 && l1 == l2 - | _ -> false - let hashcons hc = function - | Nil -> Nil - | Cons (x, h, l) -> Cons (hc x, h, l) - end - module Hcons = Hashcons.Make(Self) - let hcons = Hashcons.simple_hcons Hcons.generate Hcons.hcons M.hcons - (** No recursive call: the interface guarantees that all HLists from this - program are already hashconsed. If we get some external HList, we can - still reconstruct it by traversing it entirely. *) - let nil = Nil - let cons x l = - let h = M.hash x in - let hl = match l with Nil -> 0 | Cons (_, h, _) -> h in - let h = Hashset.Combine.combine h hl in - hcons (Cons (x, h, l)) -end - -module HList = struct - - module type S = sig - type elt - type t = private Nil | Cons of elt * int * t - val hash : t -> int - val nil : t - val cons : elt -> t -> t - val tip : elt -> t - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - val map : (elt -> elt) -> t -> t - val smartmap : (elt -> elt) -> t -> t - val exists : (elt -> bool) -> t -> bool - val for_all : (elt -> bool) -> t -> bool - val for_all2 : (elt -> elt -> bool) -> t -> t -> bool - val mem : elt -> t -> bool - val remove : elt -> t -> t - val to_list : t -> elt list - val compare : (elt -> elt -> int) -> t -> t -> int - end - - module Make (H : Hashconsed) : S with type elt = H.t = - struct - type elt = H.t - include HashedList(H) - - let hash = function Nil -> 0 | Cons (_, h, _) -> h - - let tip e = cons e nil - - let rec fold f l accu = match l with - | Nil -> accu - | Cons (x, _, l) -> fold f l (f x accu) - - let rec map f = function - | Nil -> nil - | Cons (x, _, l) -> cons (f x) (map f l) - - let smartmap = map - (** Apriori hashconsing ensures that the map is equal to its argument *) - - let rec exists f = function - | Nil -> false - | Cons (x, _, l) -> f x || exists f l - - let rec for_all f = function - | Nil -> true - | Cons (x, _, l) -> f x && for_all f l - - let rec for_all2 f l1 l2 = match l1, l2 with - | Nil, Nil -> true - | Cons (x1, _, l1), Cons (x2, _, l2) -> f x1 x2 && for_all2 f l1 l2 - | _ -> false - - let rec to_list = function - | Nil -> [] - | Cons (x, _, l) -> x :: to_list l - - let rec remove x = function - | Nil -> nil - | Cons (y, _, l) -> - if H.eq x y then l - else cons y (remove x l) - - let rec mem x = function - | Nil -> false - | Cons (y, _, l) -> H.eq x y || mem x l - - let rec compare cmp l1 l2 = match l1, l2 with - | Nil, Nil -> 0 - | Cons (x1, h1, l1), Cons (x2, h2, l2) -> - let c = Int.compare h1 h2 in - if c == 0 then - let c = cmp x1 x2 in - if c == 0 then - compare cmp l1 l2 - else c - else c - | Cons _, Nil -> 1 - | Nil, Cons _ -> -1 - - end -end - module RawLevel = struct open Names @@ -390,12 +263,11 @@ struct module Expr = struct type t = Level.t * int - type _t = t (* Hashing of expressions *) module ExprHash = struct - type t = _t + type t = Level.t * int type u = Level.t -> Level.t let hashcons hdir (b,n as x) = let b' = hdir b in @@ -409,25 +281,12 @@ struct end - module HExpr = - struct - - module H = Hashcons.Make(ExprHash) - - type t = ExprHash.t - - let hcons = - Hashcons.simple_hcons H.generate H.hcons Level.hcons - let hash = ExprHash.hash - let eq x y = x == y || - (let (u,n) = x and (v,n') = y in - Int.equal n n' && Level.equal u v) - - end + module H = Hashcons.Make(ExprHash) - let hcons = HExpr.hcons + let hcons = + Hashcons.simple_hcons H.generate H.hcons Level.hcons - let make l = hcons (l, 0) + let make l = (l, 0) let compare u v = if u == v then 0 @@ -436,8 +295,8 @@ struct if Int.equal n n' then Level.compare x x' else n - n' - let prop = make Level.prop - let set = make Level.set + let prop = hcons (Level.prop, 0) + let set = hcons (Level.set, 0) let type1 = hcons (Level.set, 1) let is_small = function @@ -448,6 +307,8 @@ struct (let (u,n) = x and (v,n') = y in Int.equal n n' && Level.equal u v) + let hash = ExprHash.hash + let leq (u,n) (v,n') = let cmp = Level.compare u v in if Int.equal cmp 0 then n <= n' @@ -457,13 +318,13 @@ struct let successor (u,n) = if Level.is_prop u then type1 - else hcons (u, n + 1) + else (u, n + 1) let addn k (u,n as x) = if k = 0 then x else if Level.is_prop u then - hcons (Level.set,n+k) - else hcons (u,n+k) + (Level.set,n+k) + else (u,n+k) type super_result = SuperSame of bool @@ -515,71 +376,63 @@ struct let v' = f v in if v' == v then x else if Level.is_prop v' && n != 0 then - hcons (Level.set, n) - else hcons (v', n) + (Level.set, n) + else (v', n) end - - let compare_expr = Expr.compare - module Huniv = HList.Make(Expr.HExpr) - type t = Huniv.t - open Huniv - - let equal x y = x == y || - (Huniv.hash x == Huniv.hash y && - Huniv.for_all2 Expr.equal x y) + type t = Expr.t list - let hash = Huniv.hash + let tip l = [l] + let cons x l = x :: l - let compare x y = - if x == y then 0 - else - let hx = Huniv.hash x and hy = Huniv.hash y in - let c = Int.compare hx hy in - if c == 0 then - Huniv.compare (fun e1 e2 -> compare_expr e1 e2) x y - else c + let rec hash = function + | [] -> 0 + | e :: l -> Hashset.Combine.combinesmall (Expr.ExprHash.hash e) (hash l) + + let equal x y = x == y || List.equal Expr.equal x y + + let compare x y = if x == y then 0 else List.compare Expr.compare x y + + module Huniv = Hashcons.Hlist(Expr) - let rec hcons = function - | Nil -> Huniv.nil - | Cons (x, _, l) -> Huniv.cons x (hcons l) + let hcons = Hashcons.recursive_hcons Huniv.generate Huniv.hcons Expr.hcons - let make l = Huniv.tip (Expr.make l) - let tip x = Huniv.tip x + let make l = tip (Expr.make l) + let tip x = tip x let pr l = match l with - | Cons (u, _, Nil) -> Expr.pr u + | [u] -> Expr.pr u | _ -> str "max(" ++ hov 0 - (prlist_with_sep pr_comma Expr.pr (to_list l)) ++ + (prlist_with_sep pr_comma Expr.pr l) ++ str ")" let pr_with f l = match l with - | Cons (u, _, Nil) -> Expr.pr_with f u + | [u] -> Expr.pr_with f u | _ -> str "max(" ++ hov 0 - (prlist_with_sep pr_comma (Expr.pr_with f) (to_list l)) ++ + (prlist_with_sep pr_comma (Expr.pr_with f) l) ++ str ")" let is_level l = match l with - | Cons (l, _, Nil) -> Expr.is_level l + | [l] -> Expr.is_level l | _ -> false let rec is_levels l = match l with - | Cons (l, _, r) -> Expr.is_level l && is_levels r - | Nil -> true + | l :: r -> Expr.is_level l && is_levels r + | [] -> true let level l = match l with - | Cons (l, _, Nil) -> Expr.level l + | [l] -> Expr.level l | _ -> None let levels l = - fold (fun x acc -> LSet.add (Expr.get_level x) acc) l LSet.empty + List.fold_left (fun acc x -> LSet.add (Expr.get_level x) acc) LSet.empty l let is_small u = match u with - | Cons (l, _, Nil) -> Expr.is_small l + | [l] -> Expr.is_small l | _ -> false (* The lower predicative level of the hierarchy that contains (impredicative) @@ -601,16 +454,16 @@ struct let super l = if is_small l then type1 else - Huniv.map (fun x -> Expr.successor x) l + List.smartmap (fun x -> Expr.successor x) l let addn n l = - Huniv.map (fun x -> Expr.addn n x) l + List.smartmap (fun x -> Expr.addn n x) l let rec merge_univs l1 l2 = match l1, l2 with - | Nil, _ -> l2 - | _, Nil -> l1 - | Cons (h1, _, t1), Cons (h2, _, t2) -> + | [], _ -> l2 + | _, [] -> l1 + | h1 :: t1, h2 :: t2 -> let open Expr in (match super h1 h2 with | SuperSame true (* h1 < h2 *) -> merge_univs t1 l2 @@ -623,7 +476,7 @@ struct let sort u = let rec aux a l = match l with - | Cons (b, _, l') -> + | b :: l' -> let open Expr in (match super a b with | SuperSame false -> aux a l' @@ -631,21 +484,21 @@ struct | SuperDiff c -> if c <= 0 then cons a l else cons b (aux a l')) - | Nil -> cons a l + | [] -> cons a l in - fold (fun a acc -> aux a acc) u nil + List.fold_right (fun a acc -> aux a acc) u [] (* Returns the formal universe that is greater than the universes u and v. Used to type the products. *) let sup x y = merge_univs x y - let empty = nil + let empty = [] - let exists = Huniv.exists + let exists = List.exists - let for_all = Huniv.for_all + let for_all = List.for_all - let smartmap = Huniv.smartmap + let smartmap = List.smartmap end @@ -818,12 +671,11 @@ let check_univ_leq u v = Universe.for_all (fun u -> check_univ_leq_one u v) u let enforce_leq u v c = - let open Universe.Huniv in let rec aux acc v = match v with - | Cons (v, _, l) -> - aux (fold (fun u -> constraint_add_leq u v) u c) l - | Nil -> acc + | v :: l -> + aux (List.fold_right (fun u -> constraint_add_leq u v) u c) l + | [] -> acc in aux c v let enforce_leq u v c = @@ -842,12 +694,13 @@ let enforce_univ_constraint (u,d,v) = (* Miscellaneous functions to remove or test local univ assumed to occur in a universe *) -let univ_level_mem u v = Huniv.mem (Expr.make u) v +let univ_level_mem u v = + List.exists (fun (l, n) -> Int.equal n 0 && Level.equal u l) v let univ_level_rem u v min = match Universe.level v with | Some u' -> if Level.equal u u' then min else v - | None -> Huniv.remove (Universe.Expr.make u) v + | None -> List.filter (fun (l, n) -> not (Int.equal n 0 && Level.equal u l)) v (* Is u mentionned in v (or equals to v) ? *) @@ -1260,7 +1113,7 @@ let subst_univs_expr_opt fn (l,n) = let subst_univs_universe fn ul = let subst, nosubst = - Universe.Huniv.fold (fun u (subst,nosubst) -> + List.fold_right (fun u (subst,nosubst) -> try let a' = subst_univs_expr_opt fn u in (a' :: subst, nosubst) with Not_found -> (subst, u :: nosubst)) @@ -1271,7 +1124,7 @@ let subst_univs_universe fn ul = let substs = List.fold_left Universe.merge_univs Universe.empty subst in - List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u)) + List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.tip u)) substs nosubst let subst_univs_level fn l = diff --git a/lib/cArray.ml b/lib/cArray.ml index 85984d4362..013585735c 100644 --- a/lib/cArray.ml +++ b/lib/cArray.ml @@ -53,8 +53,12 @@ sig ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array val map_left : ('a -> 'b) -> 'a array -> 'b array val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit - val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array + val fold_right_map : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c + val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b array -> 'c array -> 'a * 'd array + val fold_right2_map : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array + val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c val fold_map2' : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c val distinct : 'a array -> bool @@ -330,7 +334,7 @@ let smartmap f (ar : 'a array) = Array.unsafe_set ans !i v; incr i; while !i < len do - let v = Array.unsafe_get ar !i in + let v = Array.unsafe_get ans !i in let v' = f v in if v != v' then Array.unsafe_set ans !i v'; incr i @@ -433,7 +437,7 @@ let iter2 f v1 v2 = let pure_functional = false -let fold_map' f v e = +let fold_right_map f v e = if pure_functional then let (l,e) = Array.fold_right @@ -445,18 +449,28 @@ else let v' = Array.map (fun x -> let (y,e) = f x !e' in e' := e; y) v in (v',!e') -let fold_map f e v = +let fold_map' = fold_right_map + +let fold_left_map f e v = let e' = ref e in let v' = Array.map (fun x -> let (e,y) = f !e' x in e' := e; y) v in (!e',v') -let fold_map2' f v1 v2 e = +let fold_map = fold_left_map + +let fold_right2_map f v1 v2 e = let e' = ref e in let v' = map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2 in (v',!e') +let fold_map2' = fold_right2_map + +let fold_left2_map f e v1 v2 = + let e' = ref e in + let v' = map2 (fun x1 x2 -> let (e,y) = f !e' x1 x2 in e' := e; y) v1 v2 in + (!e',v') let distinct v = let visited = Hashtbl.create 23 in @@ -513,7 +527,7 @@ struct Array.unsafe_set ans !i v; incr i; while !i < len do - let v = Array.unsafe_get ar !i in + let v = Array.unsafe_get ans !i in let v' = f arg v in if v != v' then Array.unsafe_set ans !i v'; incr i diff --git a/lib/cArray.mli b/lib/cArray.mli index 7e5c93b5da..325ff8edcc 100644 --- a/lib/cArray.mli +++ b/lib/cArray.mli @@ -96,10 +96,28 @@ sig val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit (** Iter on two arrays. Raise [Invalid_argument "Array.iter2"] if sizes differ. *) - val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array + (** [fold_left_map f e_0 [|l_1...l_n|] = e_n,[|k_1...k_n|]] + where [(e_i,k_i)=f e_{i-1} l_i] *) + + val fold_right_map : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c + (** Same, folding on the right *) + + val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b array -> 'c array -> 'a * 'd array + (** Same with two arrays, folding on the left *) + + val fold_right2_map : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c + (** Same with two arrays, folding on the left *) + val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array + (** @deprecated Same as [fold_left_map] *) + + val fold_map' : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c + (** @deprecated Same as [fold_right_map] *) + val fold_map2' : ('a -> 'b -> 'c -> 'd * 'c) -> 'a array -> 'b array -> 'c -> 'd array * 'c + (** @deprecated Same as [fold_right2_map] *) val distinct : 'a array -> bool (** Return [true] if every element of the array is unique (for default diff --git a/lib/cList.ml b/lib/cList.ml index cb84b6097f..ca69628af7 100644 --- a/lib/cList.ml +++ b/lib/cList.ml @@ -92,6 +92,10 @@ sig val map_append : ('a -> 'b list) -> 'a list -> 'b list val map_append2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + val fold_right_map : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a + val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b list -> 'c list -> 'a * 'd list + val fold_right2_map : ('b -> 'c -> 'a -> 'd * 'a) -> 'b list -> 'c list -> 'a -> 'd list * 'a val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list @@ -761,13 +765,15 @@ let share_tails l1 l2 = in shr_rev [] (List.rev l1, List.rev l2) -let rec fold_map f e = function +let rec fold_left_map f e = function | [] -> (e,[]) | h::t -> let e',h' = f e h in - let e'',t' = fold_map f e' t in + let e'',t' = fold_left_map f e' t in e'',h'::t' +let fold_map = fold_left_map + (* (* tail-recursive version of the above function *) let fold_map f e l = let g (e,b') h = @@ -779,9 +785,17 @@ let fold_map f e l = *) (* The same, based on fold_right, with the effect accumulated on the right *) -let fold_map' f l e = +let fold_right_map f l e = List.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) l ([],e) +let fold_map' = fold_right_map + +let fold_left2_map f e l l' = + List.fold_left2 (fun (e,l) x x' -> let (e,y) = f e x x' in (e,y::l)) (e,[]) l l' + +let fold_right2_map f l l' e = + List.fold_right2 (fun x x' (l,e) -> let (y,e) = f x x' e in (y::l,e)) l l' ([],e) + let map_assoc f = List.map (fun (x,a) -> (x,f a)) let rec assoc_f f a = function diff --git a/lib/cList.mli b/lib/cList.mli index d7d6614cd3..8cb07da79c 100644 --- a/lib/cList.mli +++ b/lib/cList.mli @@ -198,11 +198,25 @@ sig val share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list - val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list - (** [fold_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]] + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + (** [fold_left_map f e_0 [l_1...l_n] = e_n,[k_1...k_n]] where [(e_i,k_i)=f e_{i-1} l_i] *) + val fold_right_map : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a + (** Same, folding on the right *) + + val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b list -> 'c list -> 'a * 'd list + (** Same with two lists, folding on the left *) + + val fold_right2_map : ('b -> 'c -> 'a -> 'd * 'a) -> 'b list -> 'c list -> 'a -> 'd list * 'a + (** Same with two lists, folding on the right *) + + val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list + (** @deprecated Same as [fold_left_map] *) + val fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a + (** @deprecated Same as [fold_right_map] *) + val map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list val assoc_f : 'a eq -> 'a -> ('a * 'b) list -> 'b val remove_assoc_f : 'a eq -> 'a -> ('a * 'b) list -> ('a * 'b) list diff --git a/lib/clib.mllib b/lib/clib.mllib index d5c938fe54..5c1f7d9af8 100644 --- a/lib/clib.mllib +++ b/lib/clib.mllib @@ -19,6 +19,7 @@ Flags Control Loc CAst +DAst CList CString Deque diff --git a/lib/dAst.ml b/lib/dAst.ml new file mode 100644 index 0000000000..0fe323d013 --- /dev/null +++ b/lib/dAst.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 *) +(************************************************************************) + +open CAst + +type ('a, _) thunk = +| Value : 'a -> ('a, 'b) thunk +| Thunk : 'a Lazy.t -> ('a, [ `thunk ]) thunk + +type ('a, 'b) t = ('a, 'b) thunk CAst.t + +let map_thunk (type s) f : (_, s) thunk -> (_, s) thunk = function +| Value x -> Value (f x) +| Thunk k -> Thunk (lazy (f (Lazy.force k))) + +let get_thunk (type s) : ('a, s) thunk -> 'a = function +| Value x -> x +| Thunk k -> Lazy.force k + +let get x = get_thunk x.v + +let make ?loc v = CAst.make ?loc (Value v) + +let delay ?loc v = CAst.make ?loc (Thunk (Lazy.from_fun v)) + +let map f n = CAst.map (fun x -> map_thunk f x) n + +let map_with_loc f n = + CAst.map_with_loc (fun ?loc x -> map_thunk (fun x -> f ?loc x) x) n + +let map_from_loc f (loc, x) = + make ?loc (f ?loc x) + +let with_val f n = f (get n) + +let with_loc_val f n = f ?loc:n.CAst.loc (get n) diff --git a/lib/dAst.mli b/lib/dAst.mli new file mode 100644 index 0000000000..5b51677fc6 --- /dev/null +++ b/lib/dAst.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(** Lazy AST node wrapper. Only used for [glob_constr] as of today. *) + +type ('a, _) thunk = +| Value : 'a -> ('a, 'b) thunk +| Thunk : 'a Lazy.t -> ('a, [ `thunk ]) thunk + +type ('a, 'b) t = ('a, 'b) thunk CAst.t + +val get : ('a, 'b) t -> 'a +val get_thunk : ('a, 'b) thunk -> 'a + +val make : ?loc:Loc.t -> 'a -> ('a, 'b) t +val delay : ?loc:Loc.t -> (unit -> 'a) -> ('a, [ `thunk ]) t + +val map : ('a -> 'b) -> ('a, 'c) t -> ('b, 'c) t +val map_with_loc : (?loc:Loc.t -> 'a -> 'b) -> ('a, 'c) t -> ('b, 'c) t +val map_from_loc : (?loc:Loc.t -> 'a -> 'b) -> 'a Loc.located -> ('b, 'c) t + +val with_val : ('a -> 'b) -> ('a, 'c) t -> 'b +val with_loc_val : (?loc:Loc.t -> 'a -> 'b) -> ('a, 'c) t -> 'b diff --git a/lib/loc.ml b/lib/loc.ml index 9f036d90f9..06da13d44f 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -8,8 +8,12 @@ (* Locations management *) +type source = + | InFile of string + | ToplevelInput + type t = { - fname : string; (** filename *) + fname : source; (** filename or toplevel input *) line_nb : int; (** start line number *) bol_pos : int; (** position of the beginning of start line *) line_nb_last : int; (** end line number *) @@ -23,10 +27,15 @@ let create fname line_nb bol_pos bp ep = { line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep; } let make_loc (bp, ep) = { - fname = ""; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; + fname = ToplevelInput; line_nb = -1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0; bp = bp; ep = ep; } +let mergeable loc1 loc2 = + loc1.fname = loc2.fname + let merge loc1 loc2 = + if not (mergeable loc1 loc2) then + failwith "Trying to merge unmergeable locations."; if loc1.bp < loc2.bp then if loc1.ep < loc2.ep then { fname = loc1.fname; diff --git a/lib/loc.mli b/lib/loc.mli index 1fbaae8368..d4061e0446 100644 --- a/lib/loc.mli +++ b/lib/loc.mli @@ -8,8 +8,12 @@ (** {5 Basic types} *) +type source = + | InFile of string + | ToplevelInput + type t = { - fname : string; (** filename *) + fname : source; (** filename or toplevel input *) line_nb : int; (** start line number *) bol_pos : int; (** position of the beginning of start line *) line_nb_last : int; (** end line number *) @@ -22,7 +26,7 @@ type t = { (** This is inherited from CAMPL4/5. *) -val create : string -> int -> int -> int -> int -> t +val create : source -> int -> int -> int -> int -> t (** Create a location from a filename, a line number, a position of the beginning of the line, a start and end position *) diff --git a/lib/option.ml b/lib/option.ml index 7cedffef08..98b1680354 100644 --- a/lib/option.ml +++ b/lib/option.ml @@ -121,12 +121,19 @@ let fold_right f x a = | Some y -> f y a | _ -> a -(** [fold_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *) -let fold_map f a x = +(** [fold_left_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *) +let fold_left_map f a x = match x with | Some y -> let a, z = f a y in a, Some z | _ -> a, None +let fold_right_map f x a = + match x with + | Some y -> let z, a = f y a in Some z, a + | _ -> None, a + +let fold_map = fold_left_map + (** [cata f a x] is [a] if [x] is [None] and [f y] if [x] is [Some y]. *) let cata f a = function | Some c -> f c diff --git a/lib/option.mli b/lib/option.mli index c4d1ebc3a7..66f05023f7 100644 --- a/lib/option.mli +++ b/lib/option.mli @@ -85,7 +85,13 @@ val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b option -> 'c option -> 'a (** [fold_right f x a] is [f y a] if [x] is [Some y], and [a] otherwise. *) val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b -(** [fold_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *) +(** [fold_left_map f a x] is [a, f y] if [x] is [Some y], and [a] otherwise. *) +val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option + +(** Same as [fold_left_map] on the right *) +val fold_right_map : ('b -> 'a -> 'c * 'a) -> 'b option -> 'a -> 'c option * 'a + +(** @deprecated Same as [fold_left_map] *) val fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option (** [cata f e x] is [e] if [x] is [None] and [f a] if [x] is [Some a] *) diff --git a/library/nameops.ml b/library/nameops.ml index adfe6f5a5d..d598a63b8d 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -130,7 +130,8 @@ sig val fold_right : (Id.t -> 'a -> 'a) -> t -> 'a -> 'a val iter : (Id.t -> unit) -> t -> unit val map : (Id.t -> Id.t) -> t -> t - val fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> t -> 'a * t + val fold_left_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> t -> 'a * t + val fold_right_map : (Id.t -> 'a -> Id.t * 'a) -> Name.t -> 'a -> Name.t * 'a val get_id : t -> Id.t val pick : t -> t -> t val cons : t -> Id.t list -> Id.t list @@ -160,10 +161,14 @@ struct | Name id -> Name (f id) | Anonymous -> Anonymous - let fold_map f a = function + let fold_left_map f a = function | Name id -> let (a, id) = f a id in (a, Name id) | Anonymous -> a, Anonymous + let fold_right_map f na a = match na with + | Name id -> let (id, a) = f id a in (Name id, a) + | Anonymous -> Anonymous, a + let get_id = function | Name id -> id | Anonymous -> raise IsAnonymous @@ -191,7 +196,7 @@ let out_name = get_id let name_fold = fold_right let name_iter = iter let name_app = map -let name_fold_map = fold_map +let name_fold_map = fold_left_map let name_cons = cons let name_max = pick let pr_name = print diff --git a/library/nameops.mli b/library/nameops.mli index 89aba24476..58cd6ed4e0 100644 --- a/library/nameops.mli +++ b/library/nameops.mli @@ -66,10 +66,14 @@ module Name : sig val map : (Id.t -> Id.t) -> Name.t -> t (** [map f na] is [Anonymous] if [na] is [Anonymous] and [Name (f id)] if [na] is [Name id]. *) - val fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t - (** [fold_map f na a] is [a',Name id'] when [na] is [Name id] and [f a id] is [(a',id')]. + val fold_left_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t + (** [fold_left_map f a na] is [a',Name id'] when [na] is [Name id] and [f a id] is [(a',id')]. It is [a,Anonymous] otherwise. *) + val fold_right_map : (Id.t -> 'a -> Id.t * 'a) -> Name.t -> 'a -> Name.t * 'a + (** [fold_right_map f na a] is [Name id',a'] when [na] is [Name id] and [f id a] is [(id',a')]. + It is [Anonymous,a] otherwise. *) + val get_id : Name.t -> Id.t (** [get_id] associates [id] to [Name id]. @raise IsAnonymous otherwise. *) @@ -98,7 +102,7 @@ val name_app : (Id.t -> Id.t) -> Name.t -> Name.t (** @deprecated Same as [Name.map] *) val name_fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t -(** @deprecated Same as [Name.fold_map] *) +(** @deprecated Same as [Name.fold_left_map] *) val name_max : Name.t -> Name.t -> Name.t (** @deprecated Same as [Name.pick] *) diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index 636027f9b4..9c9189ffeb 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -10,8 +10,19 @@ open Pp open Util open Tok +(** Location utilities *) +let ploc_file_of_coq_file = function +| Loc.ToplevelInput -> "" +| Loc.InFile f -> f + +let coq_file_of_ploc_file s = + if s = "" then Loc.ToplevelInput else Loc.InFile s + +let from_coqloc fname line_nb bol_pos bp ep = + Ploc.make_loc (ploc_file_of_coq_file fname) line_nb bol_pos (bp, ep) "" + let to_coqloc loc = - { Loc.fname = Ploc.file_name loc; + { Loc.fname = coq_file_of_ploc_file (Ploc.file_name loc); Loc.line_nb = Ploc.line_nb loc; Loc.bol_pos = Ploc.bol_pos loc; Loc.bp = Ploc.first_pos loc; @@ -118,14 +129,6 @@ let err loc str = Loc.raise ~loc:(to_coqloc loc) (Error.E str) let bad_token str = raise (Error.E (Bad_token str)) -(** Location utilities *) -let file_loc_of_file = function -| None -> "" -| Some f -> f - -let make_loc fname line_nb bol_pos bp ep = - Ploc.make_loc (file_loc_of_file fname) line_nb bol_pos (bp, ep) "" - (* Update a loc without allocating an intermediate pair *) let set_loc_pos loc bp ep = Ploc.sub loc (bp - Ploc.first_pos loc) (ep - bp) @@ -369,7 +372,7 @@ let rec string loc ~comm_level bp len = parser err loc Unterminated_string (* To associate locations to a file name *) -let current_file = ref None +let current_file = ref Loc.ToplevelInput (* Utilities for comments in beautify *) let comment_begin = ref None @@ -392,7 +395,7 @@ let rec split_comments comacc acc pos = function let extract_comments pos = split_comments [] [] pos !comments (* The state of the lexer visible from outside *) -type lexer_state = int option * string * bool * ((int * int) * string) list * string option +type lexer_state = int option * string * bool * ((int * int) * string) list * Loc.source let init_lexer_state f = (None,"",true,[],f) let set_lexer_state (o,s,b,c,f) = @@ -404,7 +407,7 @@ let set_lexer_state (o,s,b,c,f) = let release_lexer_state () = (!comment_begin, Buffer.contents current_comment, !between_commands, !comments, !current_file) let drop_lexer_state () = - set_lexer_state (init_lexer_state None) + set_lexer_state (init_lexer_state Loc.ToplevelInput) let real_push_char c = Buffer.add_char current_comment c @@ -672,7 +675,7 @@ let token_text = function let func cs = let loct = loct_create () in - let cur_loc = ref (make_loc !current_file 1 0 0 0) in + let cur_loc = ref (from_coqloc !current_file 1 0 0 0) in let ts = Stream.from (fun i -> diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index 77d652b185..d3ef19873f 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -49,7 +49,7 @@ end (* Mainly for comments state, etc... *) type lexer_state -val init_lexer_state : string option -> lexer_state +val init_lexer_state : Loc.source -> lexer_state val set_lexer_state : lexer_state -> unit val release_lexer_state : unit -> lexer_state val drop_lexer_state : unit -> unit diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index f637e9746c..7d0728458b 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -123,8 +123,8 @@ let name_colon = let aliasvar = function { CAst.loc = loc; CAst.v = CPatAlias (_, id) } -> Some (loc,Name id) | _ -> None GEXTEND Gram - GLOBAL: binder_constr lconstr constr operconstr universe_level sort global - constr_pattern lconstr_pattern Constr.ident + GLOBAL: binder_constr lconstr constr operconstr universe_level sort sort_family + global constr_pattern lconstr_pattern Constr.ident closed_binder open_binders binder binders binders_fixannot record_declaration typeclass_constraint pattern appl_arg; Constr.ident: @@ -149,6 +149,12 @@ GEXTEND Gram | "Type"; "@{"; u = universe; "}" -> GType u ] ] ; + sort_family: + [ [ "Set" -> Sorts.InSet + | "Prop" -> Sorts.InProp + | "Type" -> Sorts.InType + ] ] + ; universe: [ [ IDENT "max"; "("; ids = LIST1 name SEP ","; ")" -> ids | id = name -> [id] diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 560a9a7578..de98415cd6 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -64,20 +64,6 @@ let parse_compat_version ?(allow_old = true) = let open Flags in function CErrors.user_err ~hdr:"get_compat_version" Pp.(str "Unknown compatibility version \"" ++ str s ++ str "\".") -let extraction_err ~loc = - if not (Mltop.module_is_known "extraction_plugin") then - CErrors.user_err ~loc (str "Please do first a Require Extraction.") - else - (* The right grammar entries should have been loaded. - We could only end here in case of syntax error. *) - raise (Stream.Error "unexpected end of command") - -let funind_err ~loc = - if not (Mltop.module_is_known "recdef_plugin") then - CErrors.user_err ~loc (str "Please do first a Require Import FunInd.") - else - raise (Stream.Error "unexpected end of command") (* Same as above... *) - GEXTEND Gram GLOBAL: vernac gallina_ext noedit_mode subprf; vernac: FIRST @@ -354,13 +340,13 @@ GEXTEND Gram ; scheme_kind: [ [ IDENT "Induction"; "for"; ind = smart_global; - IDENT "Sort"; s = sort-> InductionScheme(true,ind,s) + IDENT "Sort"; s = sort_family-> InductionScheme(true,ind,s) | IDENT "Minimality"; "for"; ind = smart_global; - IDENT "Sort"; s = sort-> InductionScheme(false,ind,s) + IDENT "Sort"; s = sort_family-> InductionScheme(false,ind,s) | IDENT "Elimination"; "for"; ind = smart_global; - IDENT "Sort"; s = sort-> CaseScheme(true,ind,s) + IDENT "Sort"; s = sort_family-> CaseScheme(true,ind,s) | IDENT "Case"; "for"; ind = smart_global; - IDENT "Sort"; s = sort-> CaseScheme(false,ind,s) + IDENT "Sort"; s = sort_family-> CaseScheme(false,ind,s) | IDENT "Equality"; "for" ; ind = smart_global -> EqualityScheme(ind) ] ] ; (* Various Binders *) @@ -881,22 +867,6 @@ GEXTEND Gram | IDENT "DelPath"; dir = ne_string -> VernacRemoveLoadPath dir - (* Some plugins are not loaded initially anymore : extraction, - and funind. To ease this transition toward a mandatory Require, - we hack here the vernac grammar in order to get customized - error messages telling what to Require instead of the dreadful - "Illegal begin of vernac". Normally, these fake grammar entries - are overloaded later by the grammar extensions in these plugins. - This code is meant to be removed in a few releases, when this - transition is considered finished. *) - - | IDENT "Extraction" -> extraction_err ~loc:!@loc - | IDENT "Extract" -> extraction_err ~loc:!@loc - | IDENT "Recursive"; IDENT "Extraction" -> extraction_err ~loc:!@loc - | IDENT "Separate"; IDENT "Extraction" -> extraction_err ~loc:!@loc - | IDENT "Function" -> funind_err ~loc:!@loc - | IDENT "Functional" -> funind_err ~loc:!@loc - (* Type-Checking (pas dans le refman) *) | "Type"; c = lconstr -> VernacGlobalCheck c @@ -1164,14 +1134,13 @@ GEXTEND Gram | IDENT "Reserved"; IDENT "Infix"; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> - Metasyntax.check_infix_modifiers l; let (loc,s) = s in - VernacSyntaxExtension (false,((loc,"x '"^s^"' y"),l)) + VernacSyntaxExtension (true, false,((loc,"x '"^s^"' y"),l)) | IDENT "Reserved"; IDENT "Notation"; local = obsolete_locality; s = ne_lstring; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] - -> VernacSyntaxExtension (local,(s,l)) + -> VernacSyntaxExtension (false, local,(s,l)) (* "Print" "Grammar" should be here but is in "command" entry in order to factorize with other "Print"-based vernac entries *) diff --git a/parsing/highparsing.mllib b/parsing/highparsing.mllib deleted file mode 100644 index 05e2911c2f..0000000000 --- a/parsing/highparsing.mllib +++ /dev/null @@ -1,4 +0,0 @@ -G_constr -G_vernac -G_prim -G_proofs diff --git a/parsing/parsing.mllib b/parsing/parsing.mllib index 2a73d7bc69..1f29636b2e 100644 --- a/parsing/parsing.mllib +++ b/parsing/parsing.mllib @@ -3,3 +3,7 @@ CLexer Pcoq Egramml Egramcoq +G_constr +G_vernac +G_prim +G_proofs diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 81f02bf955..40c5da7a53 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -15,8 +15,11 @@ let curry f x y = f (x, y) let uncurry f (x,y) = f x y (** Location Utils *) +let coq_file_of_ploc_file s = + if s = "" then Loc.ToplevelInput else Loc.InFile s + let to_coqloc loc = - { Loc.fname = Ploc.file_name loc; + { Loc.fname = coq_file_of_ploc_file (Ploc.file_name loc); Loc.line_nb = Ploc.line_nb loc; Loc.bol_pos = Ploc.bol_pos loc; Loc.bp = Ploc.first_pos loc; @@ -80,7 +83,7 @@ module type S = Gramext.position option * single_extend_statment list type coq_parsable - val parsable : ?file:string -> char Stream.t -> coq_parsable + val parsable : ?file:Loc.source -> char Stream.t -> coq_parsable val action : 'a -> action val entry_create : string -> 'a entry val entry_parse : 'a entry -> coq_parsable -> 'a @@ -104,7 +107,7 @@ end with type 'a Entry.e = 'a Grammar.GMake(CLexer).Entry.e = struct Gramext.position option * single_extend_statment list type coq_parsable = parsable * CLexer.lexer_state ref - let parsable ?file c = + let parsable ?(file=Loc.ToplevelInput) c = let state = ref (CLexer.init_lexer_state file) in CLexer.set_lexer_state !state; let a = parsable c in @@ -471,6 +474,7 @@ module Constr = let global = make_gen_entry uconstr "global" let universe_level = make_gen_entry uconstr "universe_level" let sort = make_gen_entry uconstr "sort" + let sort_family = make_gen_entry uconstr "sort_family" let pattern = Gram.entry_create "constr:pattern" let constr_pattern = gec_constr "constr_pattern" let lconstr_pattern = gec_constr "lconstr_pattern" @@ -631,6 +635,7 @@ let () = Grammar.register0 wit_ident (Prim.ident); Grammar.register0 wit_var (Prim.var); Grammar.register0 wit_ref (Prim.reference); + Grammar.register0 wit_sort_family (Constr.sort_family); Grammar.register0 wit_constr (Constr.constr); Grammar.register0 wit_red_expr (Vernac_.red_expr); () diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 445818e130..4e6bff20a6 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -73,7 +73,7 @@ module type S = type coq_parsable - val parsable : ?file:string -> char Stream.t -> coq_parsable + val parsable : ?file:Loc.source -> char Stream.t -> coq_parsable val action : 'a -> action val entry_create : string -> 'a entry val entry_parse : 'a entry -> coq_parsable -> 'a @@ -225,6 +225,7 @@ module Constr : val global : reference Gram.entry val universe_level : glob_level Gram.entry val sort : glob_sort Gram.entry + val sort_family : Sorts.family Gram.entry val pattern : cases_pattern_expr Gram.entry val constr_pattern : constr_expr Gram.entry val lconstr_pattern : constr_expr Gram.entry diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 5a4c52456d..fca7d9851f 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -442,11 +442,11 @@ let cc_tactic depth additionnal_terms = let open Glob_term in let env = Proofview.Goal.env gl in let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in - let hole = CAst.make @@ GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None) in + let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None) in let pr_missing (c, missing) = - let c = Detyping.detype ~lax:true false [] env sigma c in + let c = Detyping.detype Detyping.Now ~lax:true false [] env sigma c in let holes = List.init missing (fun _ -> hole) in - Printer.pr_glob_constr_env env (CAst.make @@ GApp (c, holes)) + Printer.pr_glob_constr_env env (DAst.make @@ GApp (c, holes)) in Feedback.msg_info (Pp.str "Goal is solvable by congruence but some arguments are missing."); diff --git a/plugins/derive/Derive.v b/plugins/derive/Derive.v index 0d5a93b034..d1046ae79b 100644 --- a/plugins/derive/Derive.v +++ b/plugins/derive/Derive.v @@ -1 +1 @@ -Declare ML Module "derive_plugin".
\ No newline at end of file +Declare ML Module "derive_plugin". diff --git a/plugins/extraction/ExtrHaskellNatNum.v b/plugins/extraction/ExtrHaskellNatNum.v index fabe9a4c67..09b0444614 100644 --- a/plugins/extraction/ExtrHaskellNatNum.v +++ b/plugins/extraction/ExtrHaskellNatNum.v @@ -34,4 +34,4 @@ Extract Constant Init.Nat.sub => "(\n m -> Prelude.max 0 (n Prelude.- m))". Extract Constant Nat.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". Extract Constant Nat.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)". Extract Constant Init.Nat.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". -Extract Constant Init.Nat.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)".
\ No newline at end of file +Extract Constant Init.Nat.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)". diff --git a/plugins/extraction/ExtrOcamlIntConv.v b/plugins/extraction/ExtrOcamlIntConv.v index fe6eb7780f..ab13d75ada 100644 --- a/plugins/extraction/ExtrOcamlIntConv.v +++ b/plugins/extraction/ExtrOcamlIntConv.v @@ -96,4 +96,4 @@ Extraction "/tmp/test.ml" pos_of_int int_of_pos z_of_int int_of_z n_of_int int_of_n. -*)
\ No newline at end of file +*) diff --git a/plugins/extraction/Extraction.v b/plugins/extraction/Extraction.v index 1374a91abf..b3f9d6556d 100644 --- a/plugins/extraction/Extraction.v +++ b/plugins/extraction/Extraction.v @@ -6,4 +6,4 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -Declare ML Module "extraction_plugin".
\ No newline at end of file +Declare ML Module "extraction_plugin". diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 89c2a0ae30..f503c572d0 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -281,7 +281,8 @@ and extract_msignature_spec env mp1 reso = function MTfunsig (mbid, extract_mbody_spec env mp mtb, extract_msignature_spec env' mp1 reso me) -and extract_mbody_spec env mp mb = match mb.mod_type_alg with +and extract_mbody_spec : 'a. _ -> _ -> 'a generic_module_body -> _ = + fun env mp mb -> match mb.mod_type_alg with | Some ty -> extract_mexpression_spec env mp (mb.mod_type,ty) | None -> extract_msignature_spec env mp mb.mod_delta mb.mod_type diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 513fce2484..ef1654fdf5 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -11,7 +11,6 @@ open Tactics open Context.Rel.Declaration open Indfun_common open Functional_principles_proofs -open Misctypes module RelDecl = Context.Rel.Declaration @@ -463,7 +462,7 @@ let get_funs_constant mp dp = exception No_graph_found exception Found_type of int -let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_constants definition_entry list = +let make_scheme evd (fas : (pconstant*Sorts.family) list) : Safe_typing.private_constants definition_entry list = let env = Global.env () in let funs = List.map fst fas in let first_fun = List.hd funs in @@ -500,7 +499,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con let i = ref (-1) in let sorts = List.rev_map (fun (_,x) -> - Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd (Pretyping.interp_elimination_sort x) + Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd x ) fas in @@ -674,7 +673,7 @@ let build_case_scheme fa = let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in let sorts = (fun (_,_,x) -> - Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) + Universes.new_sort_in_family x ) fa in diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index 5a7ffe0590..2eb1b7935d 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -8,7 +8,6 @@ open Names open Term -open Misctypes val generate_functional_principle : Evd.evar_map ref -> @@ -37,8 +36,7 @@ val compute_new_princ_type_from_rel : constr array -> Sorts.t array -> exception No_graph_found val make_scheme : Evd.evar_map ref -> - (pconstant*glob_sort) list -> Safe_typing.private_constants Entries.definition_entry list - -val build_scheme : (Id.t*Libnames.reference*glob_sort) list -> unit -val build_case_scheme : (Id.t*Libnames.reference*glob_sort) -> unit + (pconstant*Sorts.family) list -> Safe_typing.private_constants Entries.definition_entry list +val build_scheme : (Id.t*Libnames.reference*Sorts.family) list -> unit +val build_case_scheme : (Id.t*Libnames.reference*Sorts.family) -> unit diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 16d9f200f3..62ecaa552b 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -166,11 +166,11 @@ END let pr_fun_scheme_arg (princ_name,fun_name,s) = Names.Id.print princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ - Ppconstr.pr_glob_sort s + Termops.pr_sort_family s VERNAC ARGUMENT EXTEND fun_scheme_arg PRINTED BY pr_fun_scheme_arg -| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] +| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort_family(s) ] -> [ (princ_name,fun_name,s) ] END diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 8cf5e8442d..7087a195e4 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -34,10 +34,10 @@ type glob_context = (binder_type*glob_constr) list let rec solve_trivial_holes pat_as_term e = - match pat_as_term.CAst.v,e.CAst.v with + match DAst.get pat_as_term, DAst.get e with | GHole _,_ -> e | GApp(fp,argsp),GApp(fe,argse) when glob_constr_eq fp fe -> - CAst.make (GApp((solve_trivial_holes fp fe),List.map2 solve_trivial_holes argsp argse)) + DAst.make (GApp((solve_trivial_holes fp fe),List.map2 solve_trivial_holes argsp argse)) | _,_ -> pat_as_term (* @@ -361,7 +361,7 @@ let add_pat_variables pat typ env : Environ.env = let rec add_pat_variables env pat typ : Environ.env = observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); - match pat.CAst.v with + match DAst.get pat with | PatVar na -> Environ.push_rel (RelDecl.LocalAssum (na,typ)) env | PatCstr(c,patl,na) -> let Inductiveops.IndType(indf,indargs) = @@ -411,7 +411,7 @@ let add_pat_variables pat typ env : Environ.env = -let rec pattern_to_term_and_type env typ = CAst.with_val (function +let rec pattern_to_term_and_type env typ = DAst.with_val (function | PatVar Anonymous -> assert false | PatVar (Name id) -> mkGVar id @@ -434,7 +434,7 @@ let rec pattern_to_term_and_type env typ = CAst.with_val (function Array.to_list (Array.init (cst_narg - List.length patternl) - (fun i -> Detyping.detype false [] env (Evd.from_env env) (EConstr.of_constr csta.(i))) + (fun i -> Detyping.detype Detyping.Now false [] env (Evd.from_env env) (EConstr.of_constr csta.(i))) ) in let patl_as_term = @@ -480,7 +480,7 @@ let rec pattern_to_term_and_type env typ = CAst.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); let open CAst in - match rt.v with + match DAst.get rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> (* do nothing (except changing type of course) *) mk_result [] rt avoid @@ -496,13 +496,13 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = (mk_result [] [] avoid) in begin - match f.v with + match DAst.get f with | GLambda _ -> let rec aux t l = match l with | [] -> t - | u::l -> CAst.make @@ - match t.v with + | u::l -> DAst.make @@ + match DAst.get t with | GLambda(na,_,nat,b) -> GLetIn(na,u,None,aux b l) | _ -> @@ -519,7 +519,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = *) let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr rt_as_constr) in - let res_raw_type = Detyping.detype false [] env (Evd.from_env env) rt_typ in + let res_raw_type = Detyping.detype Detyping.Now false [] env (Evd.from_env env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in let new_avoid = res::args_res.to_avoid in let res_rt = mkGVar res in @@ -564,7 +564,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let new_b = replace_var_by_term id - (CAst.make @@ GVar id) + (DAst.make @@ GVar id) b in (Name new_id,new_b,new_avoid) @@ -626,7 +626,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = then the one corresponding to the value [t] and combine the two result *) - let v = match typ with None -> v | Some t -> CAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in + let v = match typ with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in let v_res = build_entry_lc env funnames avoid v in let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in let v_type = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr v_as_constr) in @@ -773,7 +773,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (EConstr.mkVar id) in let raw_typ_of_id = - Detyping.detype false [] + Detyping.detype Detyping.Now false [] env_with_pat_ids (Evd.from_env env) typ_of_id in mkGProd (Name id,raw_typ_of_id,acc)) @@ -819,7 +819,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve (fun pat e typ_as_constr -> let this_pat_ids = ids_of_pat pat in let typ_as_constr = EConstr.of_constr typ_as_constr in - let typ = Detyping.detype false [] new_env (Evd.from_env env) typ_as_constr in + let typ = Detyping.detype Detyping.Now false [] new_env (Evd.from_env env) typ_as_constr in let pat_as_term = pattern_to_term pat in (* removing trivial holes *) let pat_as_term = solve_trivial_holes pat_as_term e in @@ -833,7 +833,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve then (Prod (Name id), let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (EConstr.mkVar id) in let raw_typ_of_id = - Detyping.detype false [] new_env (Evd.from_env env) typ_of_id + Detyping.detype Detyping.Now false [] new_env (Evd.from_env env) typ_of_id in raw_typ_of_id )::acc @@ -875,15 +875,23 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve { brl'_res with result = this_branch_res@brl'_res.result } -let is_res id = - try +let is_res r = match DAst.get r with +| GVar id -> + begin try String.equal (String.sub (Id.to_string id) 0 4) "_res" - with Invalid_argument _ -> false + with Invalid_argument _ -> false end +| _ -> false +let is_gr c gr = match DAst.get c with +| GRef (r, _) -> Globnames.eq_gr r gr +| _ -> false +let is_gvar c = match DAst.get c with +| GVar id -> true +| _ -> false let same_raw_term rt1 rt2 = - match CAst.(rt1.v, rt2.v) with + match DAst.get rt1, DAst.get rt2 with | GRef(r1,_), GRef (r2,_) -> Globnames.eq_gr r1 r2 | GHole _, GHole _ -> true | _ -> false @@ -917,23 +925,24 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = observe (str "rebuilding : " ++ pr_glob_constr rt); let open Context.Rel.Declaration in let open CAst in - match rt.v with + match DAst.get rt with | GProd(n,k,t,b) -> let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t::crossed_types in begin - match t with - | { v = GApp(({ v = GVar res_id } as res_rt),args') } when is_res res_id -> + match DAst.get t with + | GApp(res_rt ,args') when is_res res_rt -> begin - match args' with - | { v = GVar this_relname }::args' -> + let arg = List.hd args' in + match DAst.get arg with + | GVar this_relname -> (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) let new_t = - mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt]) + mkGApp(mkGVar(mk_rel_id this_relname),List.tl args'@[res_rt]) in let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in let new_env = Environ.push_rel (LocalAssum (n,t')) env in @@ -948,9 +957,13 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | _ -> (* the first args is the name of the function! *) assert false end - | { loc = loc1; v = GApp({ loc = loc2; v = GRef(eq_as_ref,_) },[ty; { loc = loc3; v = GVar id};rt]) } - when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous + | GApp(eq_as_ref,[ty; id ;rt]) + when is_gvar id && is_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> + let loc1 = rt.CAst.loc in + let loc2 = eq_as_ref.CAst.loc in + let loc3 = id.CAst.loc in + 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); @@ -985,10 +998,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let params,arg' = ((Util.List.chop nparam args')) in - let rt_typ = CAst.make @@ - GApp(CAst.make @@ GRef (Globnames.IndRef (fst ind),None), + let rt_typ = DAst.make @@ + GApp(DAst.make @@ GRef (Globnames.IndRef (fst ind),None), (List.map - (fun p -> Detyping.detype false [] + (fun p -> Detyping.detype Detyping.Now false [] env (Evd.from_env env) (EConstr.of_constr p)) params)@(Array.to_list (Array.make @@ -996,7 +1009,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (mkGHole ())))) in let eq' = - CAst.make ?loc:loc1 @@ GApp(CAst.make ?loc:loc2 @@GRef(jmeq,None),[ty;CAst.make ?loc:loc3 @@ GVar id;rt_typ;rt]) + 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'); let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in @@ -1015,12 +1028,12 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = match na with | Anonymous -> acc | Name id' -> - (id',Detyping.detype false [] + (id',Detyping.detype Detyping.Now false [] env (Evd.from_env env) arg)::acc else if isVar var_as_constr - then (destVar var_as_constr,Detyping.detype false [] + then (destVar var_as_constr,Detyping.detype Detyping.Now false [] env (Evd.from_env env) arg)::acc @@ -1065,8 +1078,8 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = mkGProd(n,t,new_b),id_to_exclude else new_b, Id.Set.add id id_to_exclude *) - | { loc = loc1; v = GApp({ loc = loc2; v = GRef(eq_as_ref,_) },[ty;rt1;rt2]) } - when Globnames.eq_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous + | GApp(eq_as_ref,[ty;rt1;rt2]) + when is_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous -> begin try @@ -1077,7 +1090,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = List.fold_left (fun acc (lhs,rhs) -> mkGProd(Anonymous, - mkGApp(mkGRef(eq_as_ref),[mkGHole ();lhs;rhs]),acc) + mkGApp(mkGRef(Lazy.force Coqlib.coq_eq_ref),[mkGHole ();lhs;rhs]),acc) ) b l @@ -1135,14 +1148,14 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = then new_b, Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) else - CAst.make @@ GProd(n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude + DAst.make @@ GProd(n,k,t,new_b),Id.Set.filter not_free_in_t id_to_exclude | _ -> anomaly (Pp.str "Should not have an anonymous function here.") (* We have renamed all the anonymous functions during alpha_renaming phase *) end | GLetIn(n,v,t,b) -> begin - let t = match t with None -> v | Some t -> CAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in + let t = match t with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in let not_free_in_t id = not (is_free_in id t) in let evd = (Evd.from_env env) in let t',ctx = Pretyping.understand env evd t in @@ -1158,7 +1171,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = match n with | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> CAst.make @@ GLetIn(n,t,None,new_b), (* HOPING IT WOULD WORK *) + | _ -> DAst.make @@ GLetIn(n,t,None,new_b), (* HOPING IT WOULD WORK *) Id.Set.filter not_free_in_t id_to_exclude end | GLetTuple(nal,(na,rto),t,b) -> @@ -1184,7 +1197,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (* | Name id when Id.Set.mem id id_to_exclude -> *) (* new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) *) (* | _ -> *) - CAst.make @@ GLetTuple(nal,(na,None),t,new_b), + DAst.make @@ GLetTuple(nal,(na,None),t,new_b), Id.Set.filter not_free_in_t (Id.Set.union id_to_exclude id_to_exclude') end @@ -1210,12 +1223,15 @@ let rebuild_cons env nb_args relname args crossed_types rt = TODO: Find a valid way to deal with implicit arguments here! *) -let rec compute_cst_params relnames params gt = CAst.with_val (function +let rec compute_cst_params relnames params gt = DAst.with_val (function | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params - | GApp({ CAst.v = GVar relname' },rtl) when Id.Set.mem relname' relnames -> - compute_cst_params_from_app [] (params,rtl) | GApp(f,args) -> + begin match DAst.get f with + | GVar relname' when Id.Set.mem relname' relnames -> + compute_cst_params_from_app [] (params,args) + | _ -> List.fold_left (compute_cst_params relnames) params (f::args) + end | GLambda(_,_,t,b) | GProd(_,_,t,b) | GLetTuple(_,_,t,b) -> let t_params = compute_cst_params relnames params t in compute_cst_params relnames t_params b @@ -1232,10 +1248,10 @@ let rec compute_cst_params relnames params gt = CAst.with_val (function raise (UserError(Some "compute_cst_params", str "Not handled case")) ) gt and compute_cst_params_from_app acc (params,rtl) = + let is_gid id c = match DAst.get c with GVar id' -> Id.equal id id' | _ -> false in match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) - | ((Name id,_,None) as param)::params', { CAst.v = GVar id' }::rtl' - when Id.compare id id' == 0 -> + | ((Name id,_,None) as param)::params', c::rtl' when is_gid id c -> compute_cst_params_from_app (param::acc) (params',rtl') | _ -> List.rev acc diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 003bb4e30d..02ee56ac58 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -10,36 +10,36 @@ open Misctypes Some basic functions to rebuild glob_constr In each of them the location is Loc.ghost *) -let mkGRef ref = CAst.make @@ GRef(ref,None) -let mkGVar id = CAst.make @@ GVar(id) -let mkGApp(rt,rtl) = CAst.make @@ GApp(rt,rtl) -let mkGLambda(n,t,b) = CAst.make @@ GLambda(n,Explicit,t,b) -let mkGProd(n,t,b) = CAst.make @@ GProd(n,Explicit,t,b) -let mkGLetIn(n,b,t,c) = CAst.make @@ GLetIn(n,b,t,c) -let mkGCases(rto,l,brl) = CAst.make @@ GCases(Term.RegularStyle,rto,l,brl) -let mkGSort s = CAst.make @@ GSort(s) -let mkGHole () = CAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) -let mkGCast(b,t) = CAst.make @@ GCast(b,CastConv t) +let mkGRef ref = DAst.make @@ GRef(ref,None) +let mkGVar id = DAst.make @@ GVar(id) +let mkGApp(rt,rtl) = DAst.make @@ GApp(rt,rtl) +let mkGLambda(n,t,b) = DAst.make @@ GLambda(n,Explicit,t,b) +let mkGProd(n,t,b) = DAst.make @@ GProd(n,Explicit,t,b) +let mkGLetIn(n,b,t,c) = DAst.make @@ GLetIn(n,b,t,c) +let mkGCases(rto,l,brl) = DAst.make @@ GCases(Term.RegularStyle,rto,l,brl) +let mkGSort s = DAst.make @@ GSort(s) +let mkGHole () = DAst.make @@ GHole(Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) +let mkGCast(b,t) = DAst.make @@ GCast(b,CastConv t) (* Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) let glob_decompose_prod = - let rec glob_decompose_prod args = function - | { CAst.v = GProd(n,k,t,b) } -> + let rec glob_decompose_prod args c = match DAst.get c with + | GProd(n,k,t,b) -> glob_decompose_prod ((n,t)::args) b - | rt -> args,rt + | _ -> args,c in glob_decompose_prod [] let glob_decompose_prod_or_letin = - let rec glob_decompose_prod args = function - | { CAst.v = GProd(n,k,t,b) } -> + let rec glob_decompose_prod args rt = match DAst.get rt with + | GProd(n,k,t,b) -> glob_decompose_prod ((n,None,Some t)::args) b - | { CAst.v = GLetIn(n,b,t,c) } -> + | GLetIn(n,b,t,c) -> glob_decompose_prod ((n,Some b,t)::args) c - | rt -> args,rt + | _ -> args,rt in glob_decompose_prod [] @@ -58,10 +58,10 @@ let glob_decompose_prod_n n = let rec glob_decompose_prod i args c = if i<=0 then args,c else - match c with - | { CAst.v = GProd(n,_,t,b) } -> + match DAst.get c with + | GProd(n,_,t,b) -> glob_decompose_prod (i-1) ((n,t)::args) b - | rt -> args,rt + | _ -> args,c in glob_decompose_prod n [] @@ -70,12 +70,12 @@ let glob_decompose_prod_or_letin_n n = let rec glob_decompose_prod i args c = if i<=0 then args,c else - match c with - | { CAst.v = GProd(n,_,t,b) } -> + match DAst.get c with + | GProd(n,_,t,b) -> glob_decompose_prod (i-1) ((n,None,Some t)::args) b - | { CAst.v = GLetIn(n,b,t,c) } -> + | GLetIn(n,b,t,c) -> glob_decompose_prod (i-1) ((n,Some b,t)::args) c - | rt -> args,rt + | _ -> args,c in glob_decompose_prod n [] @@ -83,10 +83,10 @@ let glob_decompose_prod_or_letin_n n = let glob_decompose_app = let rec decompose_rapp acc rt = (* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) - match rt with - | { CAst.v = GApp(rt,rtl) } -> + match DAst.get rt with + | GApp(rt,rtl) -> decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt - | rt -> rt,List.rev acc + | _ -> rt,List.rev acc in decompose_rapp [] @@ -120,7 +120,7 @@ let remove_name_from_mapping mapping na = let change_vars = let rec change_vars mapping rt = - CAst.map_with_loc (fun ?loc -> function + DAst.map_with_loc (fun ?loc -> function | GRef _ as x -> x | GVar id -> let new_id = @@ -191,15 +191,15 @@ let change_vars = let rec alpha_pat excluded pat = let loc = pat.CAst.loc in - match pat.CAst.v with + match DAst.get pat with | PatVar Anonymous -> let new_id = Indfun_common.fresh_id excluded "_x" in - (CAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty + (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded),Id.Map.empty | PatVar(Name id) -> if Id.List.mem id excluded then let new_id = Namegen.next_ident_away id excluded in - (CAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded), + (DAst.make ?loc @@ PatVar(Name new_id)),(new_id::excluded), (Id.Map.add id new_id Id.Map.empty) else pat, excluded,Id.Map.empty | PatCstr(constr,patl,na) -> @@ -219,7 +219,7 @@ let rec alpha_pat excluded pat = ([],new_excluded,map) patl in - (CAst.make ?loc @@ PatCstr(constr,List.rev new_patl,new_na)),new_excluded,new_map + (DAst.make ?loc @@ PatCstr(constr,List.rev new_patl,new_na)),new_excluded,new_map let alpha_patl excluded patl = let patl,new_excluded,map = @@ -238,7 +238,7 @@ let alpha_patl excluded patl = let raw_get_pattern_id pat acc = let rec get_pattern_id pat = - match pat.CAst.v with + match DAst.get pat with | PatVar(Anonymous) -> assert false | PatVar(Name id) -> [id] @@ -257,8 +257,8 @@ let get_pattern_id pat = raw_get_pattern_id pat [] let rec alpha_rt excluded rt = let loc = rt.CAst.loc in - let new_rt = CAst.make ?loc @@ - match rt.CAst.v with + let new_rt = DAst.make ?loc @@ + match DAst.get rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ as rt -> rt | GLambda(Anonymous,k,t,b) -> let new_id = Namegen.next_ident_away (Id.of_string "_x") excluded in @@ -377,7 +377,7 @@ and alpha_br excluded (loc,(ids,patl,res)) = [is_free_in id rt] checks if [id] is a free variable in [rt] *) let is_free_in id = - let rec is_free_in x = CAst.with_loc_val (fun ?loc -> function + let rec is_free_in x = DAst.with_loc_val (fun ?loc -> function | GRef _ -> false | GVar id' -> Id.compare id' id == 0 | GEvar _ -> false @@ -421,7 +421,7 @@ let is_free_in id = -let rec pattern_to_term pt = CAst.with_val (function +let rec pattern_to_term pt = DAst.with_val (function | PatVar Anonymous -> assert false | PatVar(Name id) -> mkGVar id @@ -448,8 +448,8 @@ let rec pattern_to_term pt = CAst.with_val (function let replace_var_by_term x_id term = - let rec replace_var_by_pattern x = CAst.map (function - | GVar id when Id.compare id x_id == 0 -> term.CAst.v + let rec replace_var_by_pattern x = DAst.map (function + | GVar id when Id.compare id x_id == 0 -> DAst.get term | GRef _ | GVar _ | GEvar _ @@ -522,11 +522,10 @@ exception NotUnifiable let rec are_unifiable_aux = function | [] -> () - | eq::eqs -> - let open CAst in - match eq with - | { v = PatVar _ },_ | _, { v = PatVar _ } -> are_unifiable_aux eqs - | { v = PatCstr(constructor1,cpl1,_) }, { v = PatCstr(constructor2,cpl2,_) } -> + | (l, r) ::eqs -> + match DAst.get l, DAst.get r with + | PatVar _ ,_ | _, PatVar _-> are_unifiable_aux eqs + | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> if not (eq_constructor constructor2 constructor1) then raise NotUnifiable else @@ -545,11 +544,10 @@ let are_unifiable pat1 pat2 = let rec eq_cases_pattern_aux = function | [] -> () - | eq::eqs -> - let open CAst in - match eq with - | { v = PatVar _ }, { v = PatVar _ } -> eq_cases_pattern_aux eqs - | { v = PatCstr(constructor1,cpl1,_) }, { v = PatCstr(constructor2,cpl2,_) } -> + | (l, r) ::eqs -> + match DAst.get l, DAst.get r with + | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs + | PatCstr(constructor1,cpl1,_), PatCstr(constructor2,cpl2,_) -> if not (eq_constructor constructor2 constructor1) then raise NotUnifiable else @@ -569,7 +567,7 @@ let eq_cases_pattern pat1 pat2 = let ids_of_pat = - let rec ids_of_pat ids = CAst.with_val (function + let rec ids_of_pat ids = DAst.with_val (function | PatVar Anonymous -> ids | PatVar(Name id) -> Id.Set.add id ids | PatCstr(_,patl,_) -> List.fold_left ids_of_pat ids patl @@ -583,9 +581,9 @@ let id_of_name = function (* TODO: finish Rec caes *) let ids_of_glob_constr c = - let rec ids_of_glob_constr acc {loc; CAst.v = c} = + let rec ids_of_glob_constr acc c = let idof = id_of_name in - match c with + match DAst.get c with | GVar id -> id::acc | GApp (g,args) -> ids_of_glob_constr [] g @ List.flatten (List.map (ids_of_glob_constr []) args) @ acc @@ -610,7 +608,7 @@ let ids_of_glob_constr c = let zeta_normalize = - let rec zeta_normalize_term x = CAst.map (function + let rec zeta_normalize_term x = DAst.map (function | GRef _ | GVar _ | GEvar _ @@ -632,9 +630,9 @@ let zeta_normalize = zeta_normalize_term b ) | GLetIn(Name id,def,typ,b) -> - (zeta_normalize_term (replace_var_by_term id def b)).CAst.v + DAst.get (zeta_normalize_term (replace_var_by_term id def b)) | GLetIn(Anonymous,def,typ,b) -> - (zeta_normalize_term b).CAst.v + DAst.get (zeta_normalize_term b) | GLetTuple(nal,(na,rto),def,b) -> GLetTuple(nal, (na,Option.map zeta_normalize_term rto), @@ -670,19 +668,19 @@ let zeta_normalize = let expand_as = - let rec add_as map ({loc; CAst.v = pat } as rt) = - match pat with + let rec add_as map rt = + match DAst.get rt with | PatVar _ -> map | PatCstr(_,patl,Name id) -> Id.Map.add id (pattern_to_term rt) (List.fold_left add_as map patl) | PatCstr(_,patl,_) -> List.fold_left add_as map patl in - let rec expand_as map = CAst.map (function + let rec expand_as map = DAst.map (function | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ as rt -> rt | GVar id as rt -> begin try - (Id.Map.find id map).CAst.v + DAst.get (Id.Map.find id map) with Not_found -> rt end | GApp(f,args) -> GApp(expand_as map f,List.map (expand_as map) args) @@ -723,7 +721,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas (* then we map [rt] to replace the implicit holes by their values *) let rec change rt = - match rt.CAst.v with + match DAst.get rt with | GHole(ImplicitArg(grk,pk,bk),_,_) -> (* we only want to deal with implicit arguments *) ( try (* we scan the new evar map to find the evar corresponding to this hole (by looking the source *) @@ -743,7 +741,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas match evi.evar_body with | Evar_defined c -> (* we just have to lift the solution in glob_term *) - Detyping.detype false [] env ctx (EConstr.of_constr (f c)) + Detyping.detype Detyping.Now false [] env ctx (EConstr.of_constr (f c)) | Evar_empty -> rt (* the hole was not solved : we do nothing *) ) | (GHole(BinderType na,_,_)) -> (* we only want to deal with implicit arguments *) @@ -765,7 +763,7 @@ If someone knows how to prevent solved existantial removal in understand, pleas match evi.evar_body with | Evar_defined c -> (* we just have to lift the solution in glob_term *) - Detyping.detype false [] env ctx (EConstr.of_constr (f c)) + Detyping.detype Detyping.Now false [] env ctx (EConstr.of_constr (f c)) | Evar_empty -> rt (* the hole was not solved : we d when falseo nothing *) in res diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 8769f56688..dab094f913 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -191,7 +191,7 @@ let error msg = user_err Pp.(str msg) let is_rec names = let names = List.fold_right Id.Set.add names Id.Set.empty in let check_id id names = Id.Set.mem id names in - let rec lookup names gt = match gt.CAst.v with + let rec lookup names gt = match DAst.get gt with | GVar(id) -> check_id id names | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> false | GCast(b,_) -> lookup names b diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index f4f9ba2bbb..5f4d514f36 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -66,7 +66,7 @@ let chop_rlambda_n = if n == 0 then List.rev acc,rt else - match rt.CAst.v with + match DAst.get rt with | Glob_term.GLambda(name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b | Glob_term.GLetIn(name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b | _ -> @@ -80,7 +80,7 @@ let chop_rprod_n = if n == 0 then List.rev acc,rt else - match rt.CAst.v with + match DAst.get rt with | Glob_term.GProd(name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b | _ -> raise (CErrors.UserError(Some "chop_rprod_n",str "chop_rprod_n: Not enough products")) in diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 8dea6c90f5..5f8d50da12 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -797,7 +797,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( (fun entry -> (EConstr.of_constr (fst (fst(Future.force entry.Entries.const_entry_body))), EConstr.of_constr (Option.get entry.Entries.const_entry_type )) ) - (make_scheme evd (Array.map_to_list (fun const -> const,GType []) funs)) + (make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs)) ) ) in diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 3ae9221903..96200a98a4 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -64,8 +64,8 @@ let string_of_name = id_of_name %> Id.to_string (** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) let isVarf f x = - match x with - | { CAst.v = GVar x } -> Id.equal x f + match DAst.get x with + | GVar x -> Id.equal x f | _ -> false (** [ident_global_exist id] returns true if identifier [id] is linked @@ -491,38 +491,38 @@ exception NoMerge let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in - match CAst.(c1.v, c2.v) with + match DAst.get c1, DAst.get c2 with | GApp(f1, arr1), GApp(f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> let _ = prstr "\nICI1!\n" in let args = filter_shift_stable lnk (arr1 @ arr2) in - CAst.make @@ GApp ((CAst.make @@ GVar shift.ident) , args) + DAst.make @@ GApp ((DAst.make @@ GVar shift.ident) , args) | GApp(f1, arr1), GApp(f2,arr2) -> raise NoMerge | GLetIn(nme,bdy,typ,trm) , _ -> let _ = prstr "\nICI2!\n" in let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in - CAst.make @@ GLetIn(nme,bdy,typ,newtrm) + DAst.make @@ GLetIn(nme,bdy,typ,newtrm) | _, GLetIn(nme,bdy,typ,trm) -> let _ = prstr "\nICI3!\n" in let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in - CAst.make @@ GLetIn(nme,bdy,typ,newtrm) + DAst.make @@ GLetIn(nme,bdy,typ,newtrm) | _ -> let _ = prstr "\nICI4!\n" in raise NoMerge let rec merge_app_unsafe c1 c2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in - match CAst.(c1.v, c2.v) with + match DAst.get c1, DAst.get c2 with | GApp(f1, arr1), GApp(f2,arr2) -> let args = filter_shift_stable lnk (arr1 @ arr2) in - CAst.make @@ GApp (CAst.make @@ GVar shift.ident, args) + DAst.make @@ GApp (DAst.make @@ GVar shift.ident, args) (* FIXME: what if the function appears in the body of the let? *) | GLetIn(nme,bdy,typ,trm) , _ -> let _ = prstr "\nICI2 '!\n" in let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in - CAst.make @@ GLetIn(nme,bdy,typ,newtrm) + DAst.make @@ GLetIn(nme,bdy,typ,newtrm) | _, GLetIn(nme,bdy,typ,trm) -> let _ = prstr "\nICI3 '!\n" in let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in - CAst.make @@ GLetIn(nme,bdy,typ,newtrm) + DAst.make @@ GLetIn(nme,bdy,typ,newtrm) | _ -> let _ = prstr "\nICI4 '!\n" in raise NoMerge @@ -533,16 +533,18 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable = let rec merge_rec_hyps shift accrec (ltyp:(Name.t * glob_constr option * glob_constr option) list) filter_shift_stable : (Name.t * glob_constr option * glob_constr option) list = + let is_app c = match DAst.get c with GApp _ -> true | _ -> false in let mergeonehyp t reldecl = match reldecl with - | (nme,x,Some ({ CAst.v = GApp(i,args)} as ind)) + | (nme,x,Some ind) when is_app ind -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable) | (nme,Some _,None) -> error "letins with recursive calls not treated yet" | (nme,None,Some _) -> assert false | (nme,None,None) | (nme,Some _,Some _) -> assert false in + let is_app c = match DAst.get c with GApp (f, _) -> isVarf ind2name f | _ -> false in match ltyp with | [] -> [] - | (nme,None,Some ({ CAst. v = GApp(f, largs) } as t)) :: lt when isVarf ind2name f -> + | (nme,None,Some t) :: lt when is_app t -> let rechyps = List.map (mergeonehyp t) accrec in rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable @@ -553,12 +555,13 @@ let build_suppl_reccall (accrec:(Name.t * glob_constr) list) concl2 shift = let find_app (nme:Id.t) ltyp = + let is_app c = match DAst.get c with GApp (f, _) -> isVarf nme f | _ -> false in try ignore (List.map (fun x -> match x with - | _,None,Some { CAst.v = GApp(f,_)} when isVarf nme f -> raise (Found 0) + | _,None,Some c when is_app c -> raise (Found 0) | _ -> ()) ltyp); false @@ -617,7 +620,7 @@ let rec merge_types shift accrec1 rechyps , concl | (nme,None, Some t1)as e ::lt1 -> - (match t1.CAst.v with + (match DAst.get t1 with | GApp(f,carr) when isVarf ind1name f -> merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 | _ -> @@ -764,7 +767,7 @@ let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) (* first replace rel 1 by a varname *) let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in let substindtyp = EConstr.of_constr substindtyp in - Detyping.detype false (Id.Set.elements avoid) (Global.env()) Evd.empty substindtyp in + Detyping.detype Detyping.Now false (Id.Set.elements avoid) (Global.env()) Evd.empty substindtyp in let lcstr1: glob_constr list = Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in (* add to avoid all indentifiers of lcstr1 *) @@ -848,8 +851,8 @@ let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) = match rdecl with | LocalAssum (nme,t) -> let t = EConstr.of_constr t in - let traw = Detyping.detype false [] (Global.env()) Evd.empty t in - CAst.make @@ GProd (nme,Explicit,traw,t2) + let traw = Detyping.detype Detyping.Now false [] (Global.env()) Evd.empty t in + DAst.make @@ GProd (nme,Explicit,traw,t2) | LocalDef _ -> assert false diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index d3eccb58d7..41a10cba3c 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -190,15 +190,15 @@ let (value_f:Term.constr list -> global_reference -> Term.constr) = in let env = Environ.push_rel_context context (Global.env ()) in let glob_body = - CAst.make @@ + DAst.make @@ GCases (RegularStyle,None, - [CAst.make @@ GApp(CAst.make @@ GRef(fterm,None), List.rev_map (fun x_id -> CAst.make @@ GVar x_id) rev_x_id_l), + [DAst.make @@ GApp(DAst.make @@ GRef(fterm,None), List.rev_map (fun x_id -> DAst.make @@ GVar x_id) rev_x_id_l), (Anonymous,None)], - [Loc.tag ([v_id], [CAst.make @@ PatCstr ((destIndRef (delayed_force coq_sig_ref),1), - [CAst.make @@ PatVar(Name v_id); CAst.make @@ PatVar Anonymous], + [Loc.tag ([v_id], [DAst.make @@ PatCstr ((destIndRef (delayed_force coq_sig_ref),1), + [DAst.make @@ PatVar(Name v_id); DAst.make @@ PatVar Anonymous], Anonymous)], - CAst.make @@ GVar v_id)]) + DAst.make @@ GVar v_id)]) in let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in it_mkLambda_or_LetIn body context diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index b847aadf21..b4c6f9c90e 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -403,38 +403,38 @@ open Leminv let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater -VERNAC ARGUMENT EXTEND sort -| [ "Set" ] -> [ GSet ] -| [ "Prop" ] -> [ GProp ] -| [ "Type" ] -> [ GType [] ] -END +(*VERNAC ARGUMENT EXTEND sort_family +| [ "Set" ] -> [ InSet ] +| [ "Prop" ] -> [ InProp ] +| [ "Type" ] -> [ InType ] +END*) VERNAC COMMAND EXTEND DeriveInversionClear -| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] +| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] => [ seff na ] -> [ add_inversion_lemma_exn na c s false inv_clear_tac ] | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ] - -> [ add_inversion_lemma_exn na c GProp false inv_clear_tac ] + -> [ add_inversion_lemma_exn na c InProp false inv_clear_tac ] END VERNAC COMMAND EXTEND DeriveInversion -| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] +| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] => [ seff na ] -> [ add_inversion_lemma_exn na c s false inv_tac ] | [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ] - -> [ add_inversion_lemma_exn na c GProp false inv_tac ] + -> [ add_inversion_lemma_exn na c InProp false inv_tac ] END VERNAC COMMAND EXTEND DeriveDependentInversion -| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] +| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] => [ seff na ] -> [ add_inversion_lemma_exn na c s true dinv_tac ] END VERNAC COMMAND EXTEND DeriveDependentInversionClear -| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] +| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] => [ seff na ] -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ] END @@ -626,19 +626,19 @@ END let subst_var_with_hole occ tid t = let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in let locref = ref 0 in - let rec substrec = function - | { CAst.v = GVar id } as x -> + let rec substrec x = match DAst.get x with + | GVar id -> if Id.equal id tid then (decr occref; if Int.equal !occref 0 then x else (incr locref; - CAst.make ~loc:(Loc.make_loc (!locref,0)) @@ + DAst.make ~loc:(Loc.make_loc (!locref,0)) @@ GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous), Misctypes.IntroAnonymous, None))) else x - | c -> map_glob_constr_left_to_right substrec c in + | _ -> map_glob_constr_left_to_right substrec x in let t' = substrec t in if !occref > 0 then Find_subterm.error_invalid_occurrence [occ] else t' @@ -646,15 +646,15 @@ let subst_var_with_hole occ tid t = let subst_hole_with_term occ tc t = let locref = ref 0 in let occref = ref occ in - let rec substrec = function - | { CAst.v = GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s) } -> + let rec substrec c = match DAst.get c with + | GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s) -> decr occref; if Int.equal !occref 0 then tc else (incr locref; - CAst.make ~loc:(Loc.make_loc (!locref,0)) @@ + DAst.make ~loc:(Loc.make_loc (!locref,0)) @@ GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s)) - | c -> map_glob_constr_left_to_right substrec c + | _ -> map_glob_constr_left_to_right substrec c in substrec t @@ -666,8 +666,8 @@ let hResolve id c occ t = let env = Termops.clear_named_body id (Proofview.Goal.env gl) in let concl = Proofview.Goal.concl gl in let env_ids = Termops.ids_of_context env in - let c_raw = Detyping.detype true env_ids env sigma c in - let t_raw = Detyping.detype true env_ids env sigma t in + let c_raw = Detyping.detype Detyping.Now true env_ids env sigma c in + let t_raw = Detyping.detype Detyping.Now true env_ids env sigma t in let rec resolve_hole t_hole = try Pretyping.understand env sigma t_hole diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 index c874f8d5a3..c22e683235 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.ml4 @@ -123,7 +123,7 @@ END let clsubstitute o c = Proofview.Goal.enter begin fun gl -> - let is_tac id = match fst (fst (snd c)) with { CAst.v = GVar id' } when Id.equal id' id -> true | _ -> false in + let is_tac id = match DAst.get (fst (fst (snd c))) with GVar id' when Id.equal id' id -> true | _ -> false in let hyps = Tacmach.New.pf_ids_of_hyps gl in Tacticals.New.tclMAP (fun cl -> diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index cb7d9b9c02..f4e3ba633f 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -1040,7 +1040,7 @@ type 'a extra_genarg_printer = let strip_prod_binders_glob_constr n (ty,_) = let rec strip_ty acc n ty = if Int.equal n 0 then (List.rev acc, (ty,None)) else - match ty.CAst.v with + match DAst.get ty with Glob_term.GProd(na,Explicit,a,b) -> strip_ty (([Loc.tag na],(a,None))::acc) (n-1) b | _ -> user_err Pp.(str "Cannot translate fix tactic: not enough products") in diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 0554d43641..fc6ee6aab6 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -106,12 +106,12 @@ let intern_ltac_variable ist = function let intern_constr_reference strict ist = function | Ident (_,id) as r when not strict && find_hyp id ist -> - (CAst.make @@ GVar id), Some (CAst.make @@ CRef (r,None)) + (DAst.make @@ GVar id), Some (CAst.make @@ CRef (r,None)) | Ident (_,id) as r when find_var id ist -> - (CAst.make @@ GVar id), if strict then None else Some (CAst.make @@ CRef (r,None)) + (DAst.make @@ GVar id), if strict then None else Some (CAst.make @@ CRef (r,None)) | r -> let loc,_ as lqid = qualid_of_reference r in - CAst.make @@ GRef (locate_global_with_alias lqid,None), + DAst.make @@ GRef (locate_global_with_alias lqid,None), if strict then None else Some (CAst.make @@ CRef (r,None)) (* Internalize an isolated reference in position of tactic *) @@ -264,9 +264,10 @@ let intern_destruction_arg ist = function | clear,ElimOnIdent (loc,id) -> if !strict_check then (* If in a defined tactic, no intros-until *) - match intern_constr ist (CAst.make @@ CRef (Ident (Loc.tag id), None)) with - | {loc; CAst.v = GVar id}, _ -> clear,ElimOnIdent (loc,id) - | c -> clear,ElimOnConstr (c,NoBindings) + let c, p = intern_constr ist (CAst.make @@ CRef (Ident (Loc.tag id), None)) in + match DAst.get c with + | GVar id -> clear,ElimOnIdent (c.CAst.loc,id) + | _ -> clear,ElimOnConstr ((c, p), NoBindings) else clear,ElimOnIdent (loc,id) @@ -348,7 +349,7 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = ltac_extra = ist.extra; } in let c = Constrintern.interp_reference sign r in - match c.CAst.v with + match DAst.get c with | GRef (r,None) -> Inl (ArgArg (evaluable_of_global_reference ist.genv r,None)) | GVar id -> diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 51eed2f4ec..8fa95ffb02 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -679,8 +679,8 @@ let interp_typed_pattern ist env sigma (_,c,_) = (* Interprets a constr expression *) let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = let try_expand_ltac_var sigma x = - try match dest_fun x with - | { CAst.v = GVar id }, _ -> + try match DAst.get (fst (dest_fun x)) with + | GVar id -> let v = Id.Map.find id ist.lfun in sigma, List.map inj_fun (coerce_to_constr_list env v) | _ -> @@ -689,7 +689,7 @@ let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = (* dest_fun, List.assoc may raise Not_found *) let sigma, c = interp_fun ist env sigma x in sigma, [c] in - let sigma, l = List.fold_map try_expand_ltac_var sigma l in + let sigma, l = List.fold_left_map try_expand_ltac_var sigma l in sigma, List.flatten l let interp_constr_list ist env sigma c = @@ -908,18 +908,18 @@ and interp_intro_pattern_action ist env sigma = function and interp_or_and_intro_pattern ist env sigma = function | IntroAndPattern l -> - let sigma, l = List.fold_map (interp_intro_pattern ist env) sigma l in + let sigma, l = List.fold_left_map (interp_intro_pattern ist env) sigma l in sigma, IntroAndPattern l | IntroOrPattern ll -> - let sigma, ll = List.fold_map (interp_intro_pattern_list_as_list ist env) sigma ll in + let sigma, ll = List.fold_left_map (interp_intro_pattern_list_as_list ist env) sigma ll in sigma, IntroOrPattern ll and interp_intro_pattern_list_as_list ist env sigma = function | [loc,IntroNaming (IntroIdentifier id)] as l -> (try sigma, coerce_to_intro_pattern_list ?loc env sigma (Id.Map.find id ist.lfun) with Not_found | CannotCoerceTo _ -> - List.fold_map (interp_intro_pattern ist env) sigma l) - | l -> List.fold_map (interp_intro_pattern ist env) sigma l + List.fold_left_map (interp_intro_pattern ist env) sigma l) + | l -> List.fold_left_map (interp_intro_pattern ist env) sigma l let interp_intro_pattern_naming_option ist env sigma = function | None -> None @@ -973,7 +973,7 @@ let interp_bindings ist env sigma = function let sigma, l = interp_open_constr_list ist env sigma l in sigma, ImplicitBindings l | ExplicitBindings l -> - let sigma, l = List.fold_map (interp_binding ist env) sigma l in + let sigma, l = List.fold_left_map (interp_binding ist env) sigma l in sigma, ExplicitBindings l let interp_constr_with_bindings ist env sigma (c,bl) = @@ -1043,7 +1043,7 @@ let interp_destruction_arg ist gl arg = if Tactics.is_quantified_hypothesis id gl then keep,ElimOnIdent (loc,id) else - let c = (CAst.make ?loc @@ GVar id,Some (CAst.make @@ CRef (Ident (loc,id),None))) in + let c = (DAst.make ?loc @@ GVar id,Some (CAst.make @@ CRef (Ident (loc,id),None))) in let f env sigma = let (sigma,c) = interp_open_constr ist env sigma c in (sigma, (c,NoBindings)) @@ -1671,7 +1671,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = Proofview.Goal.env gl in let sigma = project gl in let sigma, cb = interp_open_constr_with_bindings ist env sigma cb in - let sigma, cbo = Option.fold_map (interp_open_constr_with_bindings ist env) sigma cbo in + let sigma, cbo = Option.fold_left_map (interp_open_constr_with_bindings ist env) sigma cbo in let named_tac = let tac = Tactics.elim ev keep cb cbo in name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac @@ -1789,7 +1789,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = Proofview.Goal.env gl in let sigma = project gl in let sigma,l = - List.fold_map begin fun sigma (c,(ipato,ipats),cls) -> + List.fold_left_map begin fun sigma (c,(ipato,ipats),cls) -> (* TODO: move sigma as a side-effect *) (* spiwack: the [*p] variants are for printing *) let cp = c in @@ -1803,7 +1803,7 @@ and interp_atomic ist tac : unit Proofview.tactic = in let l,lp = List.split l in let sigma,el = - Option.fold_map (interp_open_constr_with_bindings ist env) sigma el in + Option.fold_left_map (interp_open_constr_with_bindings ist env) sigma el in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (name_atomic ~env (TacInductionDestruct(isrec,ev,(lp,el))) diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index d07b2e0b45..99493d6982 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1773,11 +1773,6 @@ let onClearedName2 id tac = tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] end) -let rec is_Prop sigma c = match EConstr.kind sigma c with - | Sort s -> Sorts.is_prop (ESorts.kind sigma s) - | Cast (c,_,_) -> is_Prop sigma c - | _ -> false - let destructure_hyps = Proofview.Goal.enter begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in @@ -1809,7 +1804,7 @@ let destructure_hyps = | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) - if is_Prop sigma (type_of t2) + if Termops.is_Prop sigma (type_of t2) then let d1 = decidability t1 in tclTHENLIST [ diff --git a/plugins/romega/ROmega.v b/plugins/romega/ROmega.v index 3ddb6bed12..657aae90e8 100644 --- a/plugins/romega/ROmega.v +++ b/plugins/romega/ROmega.v @@ -11,4 +11,4 @@ Require Export Setoid. Require Export PreOmega. Require Export ZArith_base. Require Import OmegaPlugin. -Declare ML Module "romega_plugin".
\ No newline at end of file +Declare ML Module "romega_plugin". diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v index 329fa0ee81..36d1e7c542 100644 --- a/plugins/setoid_ring/Ring_tac.v +++ b/plugins/setoid_ring/Ring_tac.v @@ -460,4 +460,4 @@ Tactic Notation "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H intro H'; move H' after H; clear H;rename H' into H; - unfold g;clear g.
\ No newline at end of file + unfold g;clear g. diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 0f996c65aa..d0fe1f9570 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -131,7 +131,7 @@ let closed_term_ast l = let l = List.map (fun gr -> ArgArg(Loc.tag gr)) l in TacFun([Name(Id.of_string"t")], TacML(Loc.tag (tacname, - [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (CAst.make @@ GVar(Id.of_string"t"),None)); + [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (DAst.make @@ GVar(Id.of_string"t"),None)); TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)]))) (* let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml index cc0e86684e..c29a1fe7cc 100644 --- a/plugins/ssr/ssrbwd.ml +++ b/plugins/ssr/ssrbwd.ml @@ -42,10 +42,10 @@ let interp_agen ist gl ((goclr, _), (k, gc as c)) (clr, rcs) = | Some ghyps -> let clr' = snd (interp_hyps ist gl ghyps) @ clr in if k <> xNoFlag then clr', rcs' else - let open CAst in - match rc with - | { loc; v = GVar id } when not_section_id id -> SsrHyp (Loc.tag ?loc id) :: clr', rcs' - | { loc; v = GRef (VarRef id, _) } when not_section_id id -> + let loc = rc.CAst.loc in + match DAst.get rc with + | GVar id when not_section_id id -> SsrHyp (Loc.tag ?loc id) :: clr', rcs' + | GRef (VarRef id, _) when not_section_id id -> SsrHyp (Loc.tag ?loc id) :: clr', rcs' | _ -> clr', rcs' @@ -68,9 +68,8 @@ let pf_match = pf_apply (fun e s c t -> understand_tcc e s ~expected_type:t c) let apply_rconstr ?ist t gl = (* ppdebug(lazy(str"sigma@apply_rconstr=" ++ pr_evar_map None (project gl))); *) - let open CAst in - let n = match ist, t with - | None, { v = GVar id | GRef (VarRef id,_) } -> pf_nbargs gl (EConstr.mkVar id) + let n = match ist, DAst.get t with + | None, (GVar id | GRef (VarRef id,_)) -> pf_nbargs gl (EConstr.mkVar id) | Some ist, _ -> interp_nbargs ist gl t | _ -> anomaly "apply_rconstr without ist and not RVar" in let mkRlemma i = mkRApp t (mkRHoles i) in diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 799e969ae2..cf5fdf3184 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -176,24 +176,26 @@ open Globnames open Misctypes open Decl_kinds -let mkRHole = CAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None) +let mkRHole = DAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None) let rec mkRHoles n = if n > 0 then mkRHole :: mkRHoles (n - 1) else [] -let rec isRHoles = function { CAst.v = GHole _ } :: cl -> isRHoles cl | cl -> cl = [] -let mkRApp f args = if args = [] then f else CAst.make @@ GApp (f, args) -let mkRVar id = CAst.make @@ GRef (VarRef id,None) -let mkRltacVar id = CAst.make @@ GVar (id) -let mkRCast rc rt = CAst.make @@ GCast (rc, CastConv rt) -let mkRType = CAst.make @@ GSort (GType []) -let mkRProp = CAst.make @@ GSort (GProp) -let mkRArrow rt1 rt2 = CAst.make @@ GProd (Anonymous, Explicit, rt1, rt2) -let mkRConstruct c = CAst.make @@ GRef (ConstructRef c,None) -let mkRInd mind = CAst.make @@ GRef (IndRef mind,None) -let mkRLambda n s t = CAst.make @@ GLambda (n, Explicit, s, t) +let rec isRHoles cl = match cl with +| [] -> true +| c :: l -> match DAst.get c with GHole _ -> isRHoles l | _ -> false +let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) +let mkRVar id = DAst.make @@ GRef (VarRef id,None) +let mkRltacVar id = DAst.make @@ GVar (id) +let mkRCast rc rt = DAst.make @@ GCast (rc, CastConv rt) +let mkRType = DAst.make @@ GSort (GType []) +let mkRProp = DAst.make @@ GSort (GProp) +let mkRArrow rt1 rt2 = DAst.make @@ GProd (Anonymous, Explicit, rt1, rt2) +let mkRConstruct c = DAst.make @@ GRef (ConstructRef c,None) +let mkRInd mind = DAst.make @@ GRef (IndRef mind,None) +let mkRLambda n s t = DAst.make @@ GLambda (n, Explicit, s, t) let rec mkRnat n = - if n <= 0 then CAst.make @@ GRef (Coqlib.glob_O, None) else - mkRApp (CAst.make @@ GRef (Coqlib.glob_S, None)) [mkRnat (n - 1)] + if n <= 0 then DAst.make @@ GRef (Coqlib.glob_O, None) else + mkRApp (DAst.make @@ GRef (Coqlib.glob_S, None)) [mkRnat (n - 1)] let glob_constr ist genv = function | _, Some ce -> @@ -710,7 +712,7 @@ let mkSsrRef name = try locate_reference (ssrqid name) with Not_found -> try locate_reference (ssrtopqid name) with Not_found -> CErrors.user_err (Pp.str "Small scale reflection library not loaded") -let mkSsrRRef name = (CAst.make @@ GRef (mkSsrRef name,None)), None +let mkSsrRRef name = (DAst.make @@ GRef (mkSsrRef name,None)), None let mkSsrConst name env sigma = EConstr.fresh_global env sigma (mkSsrRef name) let pf_mkSsrConst name gl = @@ -845,10 +847,10 @@ let pf_interp_ty ?(resolve_typeclasses=false) ist gl ty = let n_binders = ref 0 in let ty = match ty with | a, (t, None) -> - let rec force_type ty = CAst.(map (function + let rec force_type ty = DAst.(map (function | GProd (x, k, s, t) -> incr n_binders; GProd (x, k, s, force_type t) | GLetIn (x, v, oty, t) -> incr n_binders; GLetIn (x, v, oty, force_type t) - | _ -> (mkRCast ty mkRType).v)) ty in + | _ -> DAst.get (mkRCast ty mkRType))) ty in a, (force_type t, None) | _, (_, Some ty) -> let rec force_type ty = CAst.(map (function diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index ab6a60f4ee..8b69c3435a 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -129,7 +129,7 @@ let newssrcongrtac arg ist gl = let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in pf_saturate gl (EConstr.of_constr eq) 3 in tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) - (fun ty -> congrtac (arg, Detyping.detype false [] (pf_env gl) (project gl) ty) ist) + (fun ty -> congrtac (arg, Detyping.detype Detyping.Now false [] (pf_env gl) (project gl) ty) ist) (fun () -> let lhs, gl' = mk_evar gl EConstr.mkProp in let rhs, gl' = mk_evar gl' EConstr.mkProp in let arrow = EConstr.mkArrow lhs (EConstr.Vars.lift 1 rhs) in diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 8e6329a15e..d01bdc1b9e 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -184,9 +184,13 @@ let havetac ist mkt ct, mkt cty, mkt (mkCHole None), loc | _, (_, Some ct) -> mkt ct, mkt (mkCHole None), mkt (mkCHole None), None - | _, ({ loc; v = GCast (ct, CastConv cty) }, None) -> - mkl ct, mkl cty, mkl mkRHole, loc - | _, (t, None) -> mkl t, mkl mkRHole, mkl mkRHole, None in + | _, (t, None) -> + begin match DAst.get t with + | GCast (ct, CastConv cty) -> + mkl ct, mkl cty, mkl mkRHole, t.CAst.loc + | _ -> mkl t, mkl mkRHole, mkl mkRHole, None + end + in let gl, cut, sol, itac1, itac2 = match fk, namefst, suff with | FwdHave, true, true -> @@ -323,11 +327,18 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = let mkpats = function | _, Some ((x, _), _) -> fun pats -> IPatId (hoi_id x) :: pats | _ -> fun x -> x in - let open CAst in let ct = match ct with - | (a, (b, Some { v = CCast (_, CastConv cty)})) -> a, (b, Some cty) - | (a, ({ v = GCast (_, CastConv cty) }, None)) -> a, (cty, None) - | _ -> anomaly "wlog: ssr cast hole deleted by typecheck" in + | (a, (b, Some ct)) -> + begin match ct.CAst.v with + | CCast (_, CastConv cty) -> a, (b, Some cty) + | _ -> anomaly "wlog: ssr cast hole deleted by typecheck" + end + | (a, (t, None)) -> + begin match DAst.get t with + | GCast (_, CastConv cty) -> a, (cty, None) + | _ -> anomaly "wlog: ssr cast hole deleted by typecheck" + end + in let cut_implies_goal = not (suff || ghave <> `NoGen) in let c, args, ct, gl = let gens = List.filter (function _, Some _ -> true | _ -> false) gens in @@ -398,11 +409,18 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave gl = let sufftac ist ((((clr, pats),binders),simpl), ((_, c), hint)) = let htac = Tacticals.tclTHEN (introstac ~ist pats) (hinttac ist true hint) in - let open CAst in let c = match c with - | (a, (b, Some { v = CCast (_, CastConv cty)})) -> a, (b, Some cty) - | (a, ({ v = GCast (_, CastConv cty) }, None)) -> a, (cty, None) - | _ -> anomaly "suff: ssr cast hole deleted by typecheck" in + | (a, (b, Some ct)) -> + begin match ct.CAst.v with + | CCast (_, CastConv cty) -> a, (b, Some cty) + | _ -> anomaly "suff: ssr cast hole deleted by typecheck" + end + | (a, (t, None)) -> + begin match DAst.get t with + | GCast (_, CastConv cty) -> a, (cty, None) + | _ -> anomaly "suff: ssr cast hole deleted by typecheck" + end + in let ctac gl = let _,ty,_,uc = pf_interp_ty ist gl c in let gl = pf_merge_uc uc gl in basecuttac "ssr_suff" ty gl in diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index db1981228a..060225dab7 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -342,7 +342,7 @@ let interp_index ist gl idx = | None -> begin match Tacinterp.Value.to_constr v with | Some c -> - let rc = Detyping.detype false [] (pf_env gl) (project gl) c in + let rc = Detyping.detype Detyping.Now false [] (pf_env gl) (project gl) c in begin match Notation.uninterp_prim_token rc with | _, Constrexpr.Numeral (s,b) -> let n = int_of_string s in if b then n else -n @@ -1062,32 +1062,32 @@ let rec format_glob_decl h0 d0 = match h0, d0 with Bdef (x, None, v) :: format_glob_decl [] d | _, [] -> [] -let rec format_glob_constr h0 c0 = let open CAst in match h0, c0 with - | BFvar :: h, { v = GLambda (x, _, _, c) } -> +let rec format_glob_constr h0 c0 = match h0, DAst.get c0 with + | BFvar :: h, GLambda (x, _, _, c) -> let bs, c' = format_glob_constr h c in Bvar x :: bs, c' - | BFdecl 1 :: h, { v = GLambda (x, _, t, c) } -> + | BFdecl 1 :: h, GLambda (x, _, t, c) -> let bs, c' = format_glob_constr h c in Bdecl ([x], t) :: bs, c' - | BFdecl n :: h, { v = GLambda (x, _, t, c) } when n > 1 -> + | BFdecl n :: h, GLambda (x, _, t, c) when n > 1 -> begin match format_glob_constr (BFdecl (n - 1) :: h) c with | Bdecl (xs, _) :: bs, c' -> Bdecl (x :: xs, t) :: bs, c' | _ -> [Bdecl ([x], t)], c end - | BFdef :: h, { v = GLetIn(x, v, oty, c) } -> + | BFdef :: h, GLetIn(x, v, oty, c) -> let bs, c' = format_glob_constr h c in Bdef (x, oty, v) :: bs, c' - | [BFcast], { v = GCast (c, CastConv t) } -> + | [BFcast], GCast (c, CastConv t) -> [Bcast t], c - | BFrec (has_str, has_cast) :: h, { v = GRec (f, _, bl, t, c) } + | BFrec (has_str, has_cast) :: h, GRec (f, _, bl, t, c) when Array.length c = 1 -> let bs = format_glob_decl h bl.(0) in let bstr = match has_str, f with | true, GFix ([|Some i, GStructRec|], _) -> mkBstruct i bs | _ -> [] in bs @ bstr @ (if has_cast then [Bcast t.(0)] else []), c.(0) - | _, c -> - [], c + | _, _ -> + [], c0 (** Forward chaining argument *) diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.ml4 index 9c59d83d4e..507b4631b0 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.ml4 @@ -292,7 +292,7 @@ let interp_search_notation ?loc tag okey = err (pr_ntn ntn ++ str " is an n-ary notation"); let nvars = List.filter (fun (_,(_,typ)) -> typ = NtnTypeConstr) nvars in let rec sub () = function - | NVar x when List.mem_assoc x nvars -> CAst.make ?loc @@ GPatVar (FirstOrderPatVar x) + | NVar x when List.mem_assoc x nvars -> DAst.make ?loc @@ GPatVar (FirstOrderPatVar x) | c -> glob_constr_of_notation_constr_with_binders ?loc (fun _ x -> (), x) sub () c in let _, npat = Patternops.pattern_of_glob_constr (sub () body) in @@ -467,10 +467,10 @@ let pr_raw_ssrhintref prc _ _ = let open CAst in function prc c ++ str "|" ++ int (List.length args) | c -> prc c -let pr_rawhintref = let open CAst in function - | { v = GApp (f, args) } when isRHoles args -> +let pr_rawhintref c = match DAst.get c with + | GApp (f, args) when isRHoles args -> pr_glob_constr f ++ str "|" ++ int (List.length args) - | c -> pr_glob_constr c + | _ -> pr_glob_constr c let pr_glob_ssrhintref _ _ _ (c, _) = pr_rawhintref c diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 338ecccc2d..61b65e3478 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -59,13 +59,13 @@ let glob_view_hints lvh = let add_view_hints lvh i = Lib.add_anonymous_leaf (in_viewhint (i, lvh)) -let interp_view ist si env sigma gv v rid = - let open CAst in - match v with - | { v = GApp ( { v = GHole _ } , rargs); loc } -> - let rv = make ?loc @@ GApp (rid, rargs) in +let interp_view ist si env sigma gv rv rid = + match DAst.get rv with + | GApp (h, rargs) when (match DAst.get h with GHole _ -> true | _ -> false) -> + let loc = rv.CAst.loc in + let rv = DAst.make ?loc @@ GApp (rid, rargs) in snd (interp_open_constr ist (re_sig si sigma) (rv, None)) - | rv -> + | _ -> let interp rc rargs = interp_open_constr ist (re_sig si sigma) (mkRApp rc rargs, None) in let rec simple_view rargs n = diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index f6300ab7e1..2e5522b83f 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -134,6 +134,10 @@ let dC t = CastConv t let isCVar = function { CAst.v = CRef (Ident _, _) } -> true | _ -> false let destCVar = function { CAst.v = CRef (Ident (_, id), _) } -> id | _ -> CErrors.anomaly (str"not a CRef.") +let isGLambda c = match DAst.get c with GLambda (Name _, _, _, _) -> true | _ -> false +let destGLambda c = match DAst.get c with GLambda (Name id, _, _, c) -> (id, c) + | _ -> CErrors.anomaly (str "not a GLambda") +let isGHole c = match DAst.get c with GHole _ -> true | _ -> false let mkCHole ~loc = CAst.make ?loc @@ CHole (None, IntroAnonymous, None) let mkCLambda ?loc name ty t = CAst.make ?loc @@ CLambdaN ([[Loc.tag ?loc name], Default Explicit, ty], t) @@ -141,10 +145,10 @@ let mkCLetIn ?loc name bo t = CAst.make ?loc @@ CLetIn ((Loc.tag ?loc name), bo, None, t) let mkCCast ?loc t ty = CAst.make ?loc @@ CCast (t, dC ty) (** Constructors for rawconstr *) -let mkRHole = CAst.make @@ GHole (InternalHole, IntroAnonymous, None) -let mkRApp f args = if args = [] then f else CAst.make @@ GApp (f, args) -let mkRCast rc rt = CAst.make @@ GCast (rc, dC rt) -let mkRLambda n s t = CAst.make @@ GLambda (n, Explicit, s, t) +let mkRHole = DAst.make @@ GHole (InternalHole, IntroAnonymous, None) +let mkRApp f args = if args = [] then f else DAst.make @@ GApp (f, args) +let mkRCast rc rt = DAst.make @@ GCast (rc, dC rt) +let mkRLambda n s t = DAst.make @@ GLambda (n, Explicit, s, t) (* ssrterm conbinators *) let combineCG t1 t2 f g = match t1, t2 with @@ -980,11 +984,10 @@ let pr_rpattern = pr_pattern type pattern = Evd.evar_map * (constr, constr) ssrpattern - -let id_of_cpattern = let open CAst in function - | _,(_,Some { v = CRef (Ident (_, x), _) } ) -> Some x - | _,(_,Some { v = CAppExpl ((_, Ident (_, x), _), []) } ) -> Some x - | _,({ v = GRef (VarRef x, _)} ,None) -> Some x +let id_of_cpattern (_, (c1, c2)) = let open CAst in match DAst.get c1, c2 with + | _, Some { v = CRef (Ident (_, x), _) } -> Some x + | _, Some { v = CAppExpl ((_, Ident (_, x), _), []) } -> Some x + | GRef (VarRef x, _), None -> Some x | _ -> None let id_of_Cterm t = match id_of_cpattern t with | Some x -> x @@ -1082,10 +1085,11 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = let eAsXInT e x t = E_As_X_In_T(e,x,t) in let mkG ?(k=' ') x = k,(x,None) in let decode ist t ?reccall f g = - let open CAst in - try match (pf_intern_term ist gl t) with - | { v = GCast({ v = GHole _},CastConv({ v = GLambda(Name x,_,_,c)})) } -> f x (' ',(c,None)) - | { v = GVar id } + try match DAst.get (pf_intern_term ist gl t) with + | GCast(t,CastConv c) when isGHole t && isGLambda c-> + let (x, c) = destGLambda c in + f x (' ',(c,None)) + | GVar id when Id.Map.mem id ist.lfun && not(Option.is_empty reccall) && not(Option.is_empty wit_ssrpatternarg) -> @@ -1126,19 +1130,27 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = thin name sigma e) sigma new_evars in sigma in - let red = let rec decode_red (ist,red) = let open CAst in match red with - | T(k,({ v = GCast ({ v = GHole _ },CastConv({ v = GLambda (Name id,_,_,t)}))},None)) - when let id = Id.to_string id in let len = String.length id in + let red = let rec decode_red (ist,red) = match red with + | T(k,(t,None)) -> + begin match DAst.get t with + | GCast (c,CastConv t) + when isGHole c && + let (id, t) = destGLambda t in + let id = Id.to_string id in let len = String.length id in (len > 8 && String.sub id 0 8 = "_ssrpat_") -> + let (id, t) = destGLambda t in let id = Id.to_string id in let len = String.length id in - (match String.sub id 8 (len - 8), t with - | "In", { v = GApp( _, [t]) } -> decodeG t xInT (fun x -> T x) - | "In", { v = GApp( _, [e; t]) } -> decodeG t (eInXInT (mkG e)) (bad_enc id) - | "In", { v = GApp( _, [e; t; e_in_t]) } -> + (match String.sub id 8 (len - 8), DAst.get t with + | "In", GApp( _, [t]) -> decodeG t xInT (fun x -> T x) + | "In", GApp( _, [e; t]) -> decodeG t (eInXInT (mkG e)) (bad_enc id) + | "In", GApp( _, [e; t; e_in_t]) -> decodeG t (eInXInT (mkG e)) (fun _ -> decodeG e_in_t xInT (fun _ -> assert false)) - | "As", { v = GApp(_, [e; t]) } -> decodeG t (eAsXInT (mkG e)) (bad_enc id) + | "As", GApp(_, [e; t]) -> decodeG t (eAsXInT (mkG e)) (bad_enc id) | _ -> bad_enc id ()) + | _ -> + decode ist ~reccall:decode_red (k, (t, None)) xInT (fun x -> T x) + end | T t -> decode ist ~reccall:decode_red t xInT (fun x -> T x) | In_T t -> decode ist t inXInT inT | X_In_T (e,t) -> decode ist t (eInXInT e) (fun x -> xInT (id_of_Cterm e) x) @@ -1163,7 +1175,7 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); let mkXLetIn ?loc x (a,(g,c)) = match c with | Some b -> a,(g,Some (mkCLetIn ?loc x (mkCHole ~loc) b)) - | None -> a,(CAst.make ?loc @@ GLetIn (x, CAst.make ?loc @@ GHole (BinderType x, IntroAnonymous, None), None, g), None) in + | None -> a,(DAst.make ?loc @@ GLetIn (x, DAst.make ?loc @@ GHole (BinderType x, IntroAnonymous, None), None, g), None) in match red with | T t -> let sigma, t = interp_term ist gl t in sigma, T t | In_T t -> let sigma, t = interp_term ist gl t in sigma, In_T t @@ -1336,10 +1348,10 @@ let pf_fill_occ_term gl occ t = let cl,(_,t) = fill_occ_term env concl occ sigma0 t in cl, t -let cpattern_of_id id = ' ', (CAst.make @@ GRef (VarRef id, None), None) +let cpattern_of_id id = ' ', (DAst.make @@ GRef (VarRef id, None), None) -let is_wildcard : cpattern -> bool = function - | _,(_,Some { CAst.v = CHole _ } | { CAst.v = GHole _ } ,None) -> true +let is_wildcard ((_, (l, r)) : cpattern) : bool = match DAst.get l, r with + | _, Some { CAst.v = CHole _ } | GHole _, None -> true | _ -> false (* "ssrpattern" *) diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index c41ec39cb4..b299ff853f 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -25,6 +25,10 @@ let make_dir l = DirPath.make (List.rev_map Id.of_string l) let make_kn dir id = Globnames.encode_mind (make_dir dir) (Id.of_string id) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) +let is_gr c gr = match DAst.get c with +| GRef (r, _) -> Globnames.eq_gr r gr +| _ -> false + let ascii_module = ["Coq";"Strings";"Ascii"] let ascii_path = make_path ascii_module "ascii" @@ -42,9 +46,9 @@ let interp_ascii ?loc p = let rec aux n p = if Int.equal n 0 then [] else let mp = p mod 2 in - (CAst.make ?loc @@ GRef ((if Int.equal mp 0 then glob_false else glob_true),None)) + (DAst.make ?loc @@ GRef ((if Int.equal mp 0 then glob_false else glob_true),None)) :: (aux (n-1) (p/2)) in - CAst.make ?loc @@ GApp (CAst.make ?loc @@ GRef(force glob_Ascii,None), aux 8 p) + DAst.make ?loc @@ GApp (DAst.make ?loc @@ GRef(force glob_Ascii,None), aux 8 p) let interp_ascii_string ?loc s = let p = @@ -60,12 +64,12 @@ let interp_ascii_string ?loc s = let uninterp_ascii r = let rec uninterp_bool_list n = function | [] when Int.equal n 0 -> 0 - | { CAst.v = GRef (k,_)}::l when Globnames.eq_gr k glob_true -> 1+2*(uninterp_bool_list (n-1) l) - | { CAst.v = GRef (k,_)}::l when Globnames.eq_gr k glob_false -> 2*(uninterp_bool_list (n-1) l) + | r::l when is_gr r glob_true -> 1+2*(uninterp_bool_list (n-1) l) + | r::l when is_gr r glob_false -> 2*(uninterp_bool_list (n-1) l) | _ -> raise Non_closed_ascii in try - let aux = function - | { CAst.v = GApp ({ CAst.v = GRef (k,_)},l) } when Globnames.eq_gr k (force glob_Ascii) -> uninterp_bool_list 8 l + let aux c = match DAst.get c with + | GApp (r, l) when is_gr r (force glob_Ascii) -> uninterp_bool_list 8 l | _ -> raise Non_closed_ascii in Some (aux r) with @@ -75,10 +79,10 @@ let make_ascii_string n = if n>=32 && n<=126 then String.make 1 (char_of_int n) else Printf.sprintf "%03d" n -let uninterp_ascii_string r = Option.map make_ascii_string (uninterp_ascii r) +let uninterp_ascii_string (AnyGlobConstr r) = Option.map make_ascii_string (uninterp_ascii r) let _ = Notation.declare_string_interpreter "char_scope" (ascii_path,ascii_module) interp_ascii_string - ([CAst.make @@ GRef (static_glob_Ascii,None)], uninterp_ascii_string, true) + ([DAst.make @@ GRef (static_glob_Ascii,None)], uninterp_ascii_string, true) diff --git a/plugins/syntax/int31_syntax.ml b/plugins/syntax/int31_syntax.ml index af64b1479a..0dff047a3c 100644 --- a/plugins/syntax/int31_syntax.ml +++ b/plugins/syntax/int31_syntax.ml @@ -23,6 +23,10 @@ open Glob_term let make_dir l = DirPath.make (List.rev_map Id.of_string l) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) +let is_gr c gr = match DAst.get c with +| GRef (r, _) -> Globnames.eq_gr r gr +| _ -> false + let make_mind mp id = Names.MutInd.make2 mp (Label.make id) let make_mind_mpfile dir id = make_mind (ModPath.MPfile (make_dir dir)) id let make_mind_mpdot dir modname id = @@ -49,9 +53,9 @@ exception Non_closed (* parses a *non-negative* integer (from bigint.ml) into an int31 wraps modulo 2^31 *) let int31_of_pos_bigint ?loc n = - let ref_construct = CAst.make ?loc (GRef (int31_construct, None)) in - let ref_0 = CAst.make ?loc (GRef (int31_0, None)) in - let ref_1 = CAst.make ?loc (GRef (int31_1, None)) in + let ref_construct = DAst.make ?loc (GRef (int31_construct, None)) in + let ref_0 = DAst.make ?loc (GRef (int31_0, None)) in + let ref_1 = DAst.make ?loc (GRef (int31_1, None)) in let rec args counter n = if counter <= 0 then [] @@ -59,7 +63,7 @@ let int31_of_pos_bigint ?loc n = let (q,r) = div2_with_rest n in (if r then ref_1 else ref_0)::(args (counter-1) q) in - CAst.make ?loc (GApp (ref_construct, List.rev (args 31 n))) + DAst.make ?loc (GApp (ref_construct, List.rev (args 31 n))) let error_negative ?loc = CErrors.user_err ?loc ~hdr:"interp_int31" (Pp.str "int31 are only non-negative numbers.") @@ -76,15 +80,15 @@ let bigint_of_int31 = let rec args_parsing args cur = match args with | [] -> cur - | { CAst.v = GRef (b,_) }::l when eq_gr b int31_0 -> args_parsing l (mult_2 cur) - | { CAst.v = GRef (b,_) }::l when eq_gr b int31_1 -> args_parsing l (add_1 (mult_2 cur)) + | r::l when is_gr r int31_0 -> args_parsing l (mult_2 cur) + | r::l when is_gr r int31_1 -> args_parsing l (add_1 (mult_2 cur)) | _ -> raise Non_closed in - function - | { CAst.v = GApp ({ CAst.v = GRef (c, _) }, args) } when eq_gr c int31_construct -> args_parsing args zero + fun c -> match DAst.get c with + | GApp (r, args) when is_gr r int31_construct -> args_parsing args zero | _ -> raise Non_closed -let uninterp_int31 i = +let uninterp_int31 (AnyGlobConstr i) = try Some (bigint_of_int31 i) with Non_closed -> @@ -94,6 +98,6 @@ let uninterp_int31 i = let _ = Notation.declare_numeral_interpreter int31_scope (int31_path, int31_module) interp_int31 - ([CAst.make (GRef (int31_construct, None))], + ([DAst.make (GRef (int31_construct, None))], uninterp_int31, true) diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index 524a5c5221..2f9870cf96 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -37,11 +37,11 @@ let warn_large_nat = let nat_of_int ?loc n = if is_pos_or_zero n then begin if less_than threshold n then warn_large_nat (); - let ref_O = CAst.make ?loc @@ GRef (glob_O, None) in - let ref_S = CAst.make ?loc @@ GRef (glob_S, None) in + let ref_O = DAst.make ?loc @@ GRef (glob_O, None) in + let ref_S = DAst.make ?loc @@ GRef (glob_S, None) in let rec mk_nat acc n = if n <> zero then - mk_nat (CAst.make ?loc @@ GApp (ref_S, [acc])) (sub_1 n) + mk_nat (DAst.make ?loc @@ GApp (ref_S, [acc])) (sub_1 n) else acc in @@ -56,13 +56,17 @@ let nat_of_int ?loc n = exception Non_closed_number -let rec int_of_nat x = CAst.with_val (function - | GApp ({ CAst.v = GRef (s,_) } ,[a]) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) +let rec int_of_nat x = DAst.with_val (function + | GApp (r, [a]) -> + begin match DAst.get r with + | GRef (s,_) when Globnames.eq_gr s glob_S -> add_1 (int_of_nat a) + | _ -> raise Non_closed_number + end | GRef (z,_) when Globnames.eq_gr z glob_O -> zero | _ -> raise Non_closed_number ) x -let uninterp_nat p = +let uninterp_nat (AnyGlobConstr p) = try Some (int_of_nat p) with @@ -75,4 +79,4 @@ let _ = Notation.declare_numeral_interpreter "nat_scope" (nat_path,datatypes_module_name) nat_of_int - ([CAst.make @@ GRef (glob_S,None); CAst.make @@ GRef (glob_O,None)], uninterp_nat, true) + ([DAst.make @@ GRef (glob_S,None); DAst.make @@ GRef (glob_O,None)], uninterp_nat, true) diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 06117de79a..88ff38c6d1 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -27,6 +27,10 @@ let binnums = ["Coq";"Numbers";"BinNums"] let make_dir l = DirPath.make (List.rev_map Id.of_string l) let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) +let is_gr c gr = match DAst.get c with +| GRef (r, _) -> Globnames.eq_gr r gr +| _ -> false + let positive_path = make_path binnums "positive" (* TODO: temporary hack *) @@ -42,13 +46,13 @@ let glob_xO = ConstructRef path_of_xO let glob_xH = ConstructRef path_of_xH let pos_of_bignat ?loc x = - let ref_xI = CAst.make @@ GRef (glob_xI, None) in - let ref_xH = CAst.make @@ GRef (glob_xH, None) in - let ref_xO = CAst.make @@ GRef (glob_xO, None) in + let ref_xI = DAst.make @@ GRef (glob_xI, None) in + let ref_xH = DAst.make @@ GRef (glob_xH, None) in + let ref_xO = DAst.make @@ GRef (glob_xO, None) in let rec pos_of x = match div2_with_rest x with - | (q,false) -> CAst.make @@ GApp (ref_xO,[pos_of q]) - | (q,true) when not (Bigint.equal q zero) -> CAst.make @@ GApp (ref_xI,[pos_of q]) + | (q,false) -> DAst.make @@ GApp (ref_xO,[pos_of q]) + | (q,true) when not (Bigint.equal q zero) -> DAst.make @@ GApp (ref_xI,[pos_of q]) | (q,true) -> ref_xH in pos_of x @@ -57,10 +61,10 @@ let pos_of_bignat ?loc x = (* Printing positive via scopes *) (**********************************************************************) -let rec bignat_of_pos = function - | { CAst.v = GApp ({ CAst.v = GRef (b,_)},[a]) } when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) - | { CAst.v = GApp ({ CAst.v = GRef (b,_)},[a]) } when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) - | { CAst.v = GRef (a, _) } when Globnames.eq_gr a glob_xH -> Bigint.one +let rec bignat_of_pos c = match DAst.get c with + | GApp (r, [a]) when is_gr r glob_xO -> mult_2(bignat_of_pos a) + | GApp (r, [a]) when is_gr r glob_xI -> add_1(mult_2(bignat_of_pos a)) + | GRef (a, _) when Globnames.eq_gr a glob_xH -> Bigint.one | _ -> raise Non_closed_number (**********************************************************************) @@ -81,18 +85,18 @@ let z_of_int ?loc n = if not (Bigint.equal n zero) then let sgn, n = if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in - CAst.make @@ GApp(CAst.make @@ GRef (sgn,None), [pos_of_bignat ?loc n]) + DAst.make @@ GApp(DAst.make @@ GRef (sgn,None), [pos_of_bignat ?loc n]) else - CAst.make @@ GRef (glob_ZERO, None) + DAst.make @@ GRef (glob_ZERO, None) (**********************************************************************) (* Printing Z via scopes *) (**********************************************************************) -let bigint_of_z = function - | { CAst.v = GApp ({ CAst.v = GRef (b,_)},[a]) } when Globnames.eq_gr b glob_POS -> bignat_of_pos a - | { CAst.v = GApp ({ CAst.v = GRef (b,_)},[a]) } when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) - | { CAst.v = GRef (a, _) } when Globnames.eq_gr a glob_ZERO -> Bigint.zero +let bigint_of_z c = match DAst.get c with + | GApp (r,[a]) when is_gr r glob_POS -> bignat_of_pos a + | GApp (r,[a]) when is_gr r glob_NEG -> Bigint.neg (bignat_of_pos a) + | GRef (a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number (**********************************************************************) @@ -108,18 +112,18 @@ let make_path dir id = Globnames.encode_con dir (Id.of_string id) let glob_IZR = ConstRef (make_path (make_dir rdefinitions) "IZR") let r_of_int ?loc z = - CAst.make @@ GApp (CAst.make @@ GRef(glob_IZR,None), [z_of_int ?loc z]) + DAst.make @@ GApp (DAst.make @@ GRef(glob_IZR,None), [z_of_int ?loc z]) (**********************************************************************) (* Printing R via scopes *) (**********************************************************************) -let bigint_of_r = function - | { CAst.v = GApp ({ CAst.v = GRef (o,_) }, [a]) } when Globnames.eq_gr o glob_IZR -> +let bigint_of_r c = match DAst.get c with + | GApp (r, [a]) when is_gr r glob_IZR -> bigint_of_z a | _ -> raise Non_closed_number -let uninterp_r p = +let uninterp_r (AnyGlobConstr p) = try Some (bigint_of_r p) with Non_closed_number -> @@ -128,6 +132,6 @@ let uninterp_r p = let _ = Notation.declare_numeral_interpreter "R_scope" (r_path,["Coq";"Reals";"Rdefinitions"]) r_of_int - ([CAst.make @@ GRef (glob_IZR, None)], + ([DAst.make @@ GRef (glob_IZR, None)], uninterp_r, false) diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index b7f13b0400..cc82fc94ca 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -31,25 +31,29 @@ let make_reference id = find_reference "String interpretation" string_module id let glob_String = lazy (make_reference "String") let glob_EmptyString = lazy (make_reference "EmptyString") +let is_gr c gr = match DAst.get c with +| GRef (r, _) -> Globnames.eq_gr r gr +| _ -> false + open Lazy let interp_string ?loc s = let le = String.length s in let rec aux n = - if n = le then CAst.make ?loc @@ GRef (force glob_EmptyString, None) else - CAst.make ?loc @@ GApp (CAst.make ?loc @@ GRef (force glob_String, None), + if n = le then DAst.make ?loc @@ GRef (force glob_EmptyString, None) else + DAst.make ?loc @@ GApp (DAst.make ?loc @@ GRef (force glob_String, None), [interp_ascii ?loc (int_of_char s.[n]); aux (n+1)]) in aux 0 -let uninterp_string r = +let uninterp_string (AnyGlobConstr r) = try let b = Buffer.create 16 in - let rec aux = function - | { CAst.v = GApp ({ CAst.v = GRef (k,_) },[a;s]) } when eq_gr k (force glob_String) -> + let rec aux c = match DAst.get c with + | GApp (k,[a;s]) when is_gr k (force glob_String) -> (match uninterp_ascii a with | Some c -> Buffer.add_char b (Char.chr c); aux s | _ -> raise Non_closed_string) - | { CAst.v = GRef (z,_) } when eq_gr z (force glob_EmptyString) -> + | GRef (z,_) when eq_gr z (force glob_EmptyString) -> Some (Buffer.contents b) | _ -> raise Non_closed_string @@ -61,6 +65,6 @@ let _ = Notation.declare_string_interpreter "string_scope" (string_path,["Coq";"Strings";"String"]) interp_string - ([CAst.make @@ GRef (static_glob_String,None); - CAst.make @@ GRef (static_glob_EmptyString,None)], + ([DAst.make @@ GRef (static_glob_String,None); + DAst.make @@ GRef (static_glob_EmptyString,None)], uninterp_string, true) diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index af3df28890..0d743a2b57 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -45,13 +45,13 @@ let glob_xO = ConstructRef path_of_xO let glob_xH = ConstructRef path_of_xH let pos_of_bignat ?loc x = - let ref_xI = CAst.make ?loc @@ GRef (glob_xI, None) in - let ref_xH = CAst.make ?loc @@ GRef (glob_xH, None) in - let ref_xO = CAst.make ?loc @@ GRef (glob_xO, None) in + let ref_xI = DAst.make ?loc @@ GRef (glob_xI, None) in + let ref_xH = DAst.make ?loc @@ GRef (glob_xH, None) in + let ref_xO = DAst.make ?loc @@ GRef (glob_xO, None) in let rec pos_of x = match div2_with_rest x with - | (q,false) -> CAst.make ?loc @@ GApp (ref_xO,[pos_of q]) - | (q,true) when not (Bigint.equal q zero) -> CAst.make ?loc @@ GApp (ref_xI,[pos_of q]) + | (q,false) -> DAst.make ?loc @@ GApp (ref_xO,[pos_of q]) + | (q,true) when not (Bigint.equal q zero) -> DAst.make ?loc @@ GApp (ref_xI,[pos_of q]) | (q,true) -> ref_xH in pos_of x @@ -68,14 +68,18 @@ let interp_positive ?loc n = (* Printing positive via scopes *) (**********************************************************************) -let rec bignat_of_pos x = CAst.with_val (function - | GApp ({ CAst.v = GRef (b,_) },[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) - | GApp ({ CAst.v = GRef (b,_) },[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) +let is_gr c gr = match DAst.get c with +| GRef (r, _) -> Globnames.eq_gr r gr +| _ -> false + +let rec bignat_of_pos x = DAst.with_val (function + | GApp (r ,[a]) when is_gr r glob_xO -> mult_2(bignat_of_pos a) + | GApp (r ,[a]) when is_gr r glob_xI -> add_1(mult_2(bignat_of_pos a)) | GRef (a, _) when Globnames.eq_gr a glob_xH -> Bigint.one | _ -> raise Non_closed_number ) x -let uninterp_positive p = +let uninterp_positive (AnyGlobConstr p) = try Some (bignat_of_pos p) with Non_closed_number -> @@ -88,9 +92,9 @@ let uninterp_positive p = let _ = Notation.declare_numeral_interpreter "positive_scope" (positive_path,binnums) interp_positive - ([CAst.make @@ GRef (glob_xI, None); - CAst.make @@ GRef (glob_xO, None); - CAst.make @@ GRef (glob_xH, None)], + ([DAst.make @@ GRef (glob_xI, None); + DAst.make @@ GRef (glob_xO, None); + DAst.make @@ GRef (glob_xH, None)], uninterp_positive, true) @@ -107,9 +111,9 @@ let glob_Npos = ConstructRef path_of_Npos let n_path = make_path binnums "N" -let n_of_binnat ?loc pos_or_neg n = CAst.make ?loc @@ +let n_of_binnat ?loc pos_or_neg n = DAst.make ?loc @@ if not (Bigint.equal n zero) then - GApp(CAst.make @@ GRef (glob_Npos,None), [pos_of_bignat ?loc n]) + GApp(DAst.make @@ GRef (glob_Npos,None), [pos_of_bignat ?loc n]) else GRef(glob_N0, None) @@ -124,13 +128,13 @@ let n_of_int ?loc n = (* Printing N via scopes *) (**********************************************************************) -let bignat_of_n = CAst.with_val (function - | GApp ({ CAst.v = GRef (b,_)},[a]) when Globnames.eq_gr b glob_Npos -> bignat_of_pos a +let bignat_of_n n = DAst.with_val (function + | GApp (r, [a]) when is_gr r glob_Npos -> bignat_of_pos a | GRef (a,_) when Globnames.eq_gr a glob_N0 -> Bigint.zero | _ -> raise Non_closed_number - ) + ) n -let uninterp_n p = +let uninterp_n (AnyGlobConstr p) = try Some (bignat_of_n p) with Non_closed_number -> None @@ -140,8 +144,8 @@ let uninterp_n p = let _ = Notation.declare_numeral_interpreter "N_scope" (n_path,binnums) n_of_int - ([CAst.make @@ GRef (glob_N0, None); - CAst.make @@ GRef (glob_Npos, None)], + ([DAst.make @@ GRef (glob_N0, None); + DAst.make @@ GRef (glob_Npos, None)], uninterp_n, true) @@ -163,22 +167,22 @@ let z_of_int ?loc n = if not (Bigint.equal n zero) then let sgn, n = if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in - CAst.make ?loc @@ GApp(CAst.make ?loc @@ GRef(sgn,None), [pos_of_bignat ?loc n]) + DAst.make ?loc @@ GApp(DAst.make ?loc @@ GRef(sgn,None), [pos_of_bignat ?loc n]) else - CAst.make ?loc @@ GRef(glob_ZERO, None) + DAst.make ?loc @@ GRef(glob_ZERO, None) (**********************************************************************) (* Printing Z via scopes *) (**********************************************************************) -let bigint_of_z = CAst.with_val (function - | GApp ({ CAst.v = GRef (b,_)},[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a - | GApp ({ CAst.v = GRef (b,_)},[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) +let bigint_of_z z = DAst.with_val (function + | GApp (r, [a]) when is_gr r glob_POS -> bignat_of_pos a + | GApp (r, [a]) when is_gr r glob_NEG -> Bigint.neg (bignat_of_pos a) | GRef (a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number - ) + ) z -let uninterp_z p = +let uninterp_z (AnyGlobConstr p) = try Some (bigint_of_z p) with Non_closed_number -> None @@ -189,8 +193,8 @@ let uninterp_z p = let _ = Notation.declare_numeral_interpreter "Z_scope" (z_path,binnums) z_of_int - ([CAst.make @@ GRef (glob_ZERO, None); - CAst.make @@ GRef (glob_POS, None); - CAst.make @@ GRef (glob_NEG, None)], + ([DAst.make @@ GRef (glob_ZERO, None); + DAst.make @@ GRef (glob_POS, None); + DAst.make @@ GRef (glob_NEG, None)], uninterp_z, true) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 1a879f911b..7455587c0a 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -94,7 +94,7 @@ let msg_may_need_inversion () = (* Utils *) let make_anonymous_patvars n = - List.make n (CAst.make @@ PatVar Anonymous) + List.make n (DAst.make @@ PatVar Anonymous) (* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *) @@ -177,7 +177,7 @@ and build_glob_pattern args = function | Top -> args | MakeConstructor (pci, rh) -> glob_pattern_of_partial_history - [CAst.make @@ PatCstr (pci, args, Anonymous)] rh + [DAst.make @@ PatCstr (pci, args, Anonymous)] rh let complete_history = glob_pattern_of_partial_history [] @@ -187,12 +187,12 @@ let pop_history_pattern = function | Continuation (0, l, Top) -> Result (List.rev l) | Continuation (0, l, MakeConstructor (pci, rh)) -> - feed_history (CAst.make @@ PatCstr (pci,List.rev l,Anonymous)) rh + feed_history (DAst.make @@ PatCstr (pci,List.rev l,Anonymous)) rh | _ -> anomaly (Pp.str "Constructor not yet filled with its arguments.") let pop_history h = - feed_history (CAst.make @@ PatVar Anonymous) h + feed_history (DAst.make @@ PatVar Anonymous) h (* Builds a continuation expecting [n] arguments and building [ci] applied to this [n] arguments *) @@ -273,8 +273,10 @@ type 'a pattern_matching_problem = let rec find_row_ind = function [] -> None - | { CAst.v = PatVar _ } :: l -> find_row_ind l - | { CAst.v = PatCstr(c,_,_) ; loc } :: _ -> Some (loc,c) + | p :: l -> + match DAst.get p with + | PatVar _ -> find_row_ind l + | PatCstr(c,_,_) -> Some (p.CAst.loc,c) let inductive_template evdref env tmloc ind = let indu = evd_comb1 (Evd.fresh_inductive_instance env) evdref ind in @@ -348,7 +350,7 @@ let find_tomatch_tycon evdref env loc = function empty_tycon,None let make_return_predicate_ltac_lvar sigma na tm c lvar = - match na, tm.CAst.v with + match na, DAst.get tm with | Name id, (GVar id' | GRef (Globnames.VarRef id', _)) when Id.equal id id' -> if Id.Map.mem id lvar.ltac_genargs then let ltac_genargs = Id.Map.remove id lvar.ltac_genargs in @@ -447,7 +449,7 @@ let current_pattern eqn = | pat::_ -> pat | [] -> anomaly (Pp.str "Empty list of patterns.") -let alias_of_pat = CAst.with_val (function +let alias_of_pat = DAst.with_val (function | PatVar name -> name | PatCstr(_,_,name) -> name ) @@ -493,13 +495,14 @@ let rec adjust_local_defs ?loc = function | (pat :: pats, LocalAssum _ :: decls) -> pat :: adjust_local_defs ?loc (pats,decls) | (pats, LocalDef _ :: decls) -> - (CAst.make ?loc @@ PatVar Anonymous) :: adjust_local_defs ?loc (pats,decls) + (DAst.make ?loc @@ PatVar Anonymous) :: adjust_local_defs ?loc (pats,decls) | [], [] -> [] | _ -> raise NotAdjustable -let check_and_adjust_constructor env ind cstrs = function - | { CAst.v = PatVar _ } as pat -> pat - | { CAst.v = PatCstr (((_,i) as cstr),args,alias) ; loc } as pat -> +let check_and_adjust_constructor env ind cstrs pat = match DAst.get pat with + | PatVar _ -> pat + | PatCstr (((_,i) as cstr),args,alias) -> + let loc = pat.CAst.loc in (* Check it is constructor of the right type *) let ind' = inductive_of_constructor cstr in if eq_ind ind' ind then @@ -510,7 +513,7 @@ let check_and_adjust_constructor env ind cstrs = function else try let args' = adjust_local_defs ?loc (args, List.rev ci.cs_args) - in CAst.make ?loc @@ PatCstr (cstr, args', alias) + in DAst.make ?loc @@ PatCstr (cstr, args', alias) with NotAdjustable -> error_wrong_numarg_constructor ?loc env cstr nb_args_constr else @@ -522,9 +525,12 @@ let check_and_adjust_constructor env ind cstrs = function let check_all_variables env sigma typ mat = List.iter - (fun eqn -> match current_pattern eqn with - | { CAst.v = PatVar id } -> () - | { CAst.v = PatCstr (cstr_sp,_,_); loc } -> + (fun eqn -> + let pat = current_pattern eqn in + match DAst.get pat with + | PatVar id -> () + | PatCstr (cstr_sp,_,_) -> + let loc = pat.CAst.loc in error_bad_pattern ?loc env sigma cstr_sp typ) mat @@ -549,9 +555,9 @@ let occur_in_rhs na rhs = | Anonymous -> false | Name id -> Id.List.mem id rhs.rhs_vars -let is_dep_patt_in eqn = function - | { CAst.v = PatVar name } -> Flags.is_program_mode () || occur_in_rhs name eqn.rhs - | { CAst.v = PatCstr _ } -> true +let is_dep_patt_in eqn pat = match DAst.get pat with + | PatVar name -> Flags.is_program_mode () || occur_in_rhs name eqn.rhs + | PatCstr _ -> true let mk_dep_patt_row (pats,_,eqn) = List.map (is_dep_patt_in eqn) pats @@ -771,7 +777,7 @@ let recover_and_adjust_alias_names names sign = | x::names, LocalAssum (_,t)::sign -> (x, LocalAssum (alias_of_pat x,t)) :: aux (names,sign) | names, (LocalDef (na,_,_) as decl)::sign -> - (CAst.make @@ PatVar na, decl) :: aux (names,sign) + (DAst.make @@ PatVar na, decl) :: aux (names,sign) | _ -> assert false in List.split (aux (names,sign)) @@ -987,7 +993,7 @@ let use_unit_judge evd = evd', j let add_assert_false_case pb tomatch = - let pats = List.map (fun _ -> CAst.make @@ PatVar Anonymous) tomatch in + let pats = List.map (fun _ -> DAst.make @@ PatVar Anonymous) tomatch in let aliasnames = List.map_filter (function Alias _ | NonDepAlias -> Some Anonymous | _ -> None) tomatch in @@ -1184,9 +1190,9 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs = (************************************************************************) (* Sorting equations by constructor *) -let rec irrefutable env = function - | { CAst.v = PatVar name } -> true - | { CAst.v = PatCstr (cstr,args,_) } -> +let rec irrefutable env pat = match DAst.get pat with + | PatVar name -> true + | PatCstr (cstr,args,_) -> let ind = inductive_of_constructor cstr in let (_,mip) = Inductive.lookup_mind_specif env ind in let one_constr = Int.equal (Array.length mip.mind_user_lc) 1 in @@ -1206,15 +1212,15 @@ let group_equations pb ind current cstrs mat = (fun eqn () -> let rest = remove_current_pattern eqn in let pat = current_pattern eqn in - match check_and_adjust_constructor pb.env ind cstrs pat with - | { CAst.v = PatVar name } -> + match DAst.get (check_and_adjust_constructor pb.env ind cstrs pat) with + | PatVar name -> (* This is a default clause that we expand *) for i=1 to Array.length cstrs do let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in brs.(i-1) <- (args, name, rest) :: brs.(i-1) done; if !only_default == None then only_default := Some true - | { CAst.v = PatCstr (((_,i)),args,name) ; loc } -> + | PatCstr (((_,i)),args,name) -> (* This is a regular clause *) only_default := Some false; brs.(i-1) <- (args, name, rest) :: brs.(i-1)) mat () in @@ -1745,22 +1751,22 @@ let build_tycon ?loc env tycon_env s subst tycon extenv evdref t = let build_inversion_problem loc env sigma tms t = let make_patvar t (subst,avoid) = let id = next_name_away (named_hd env sigma t Anonymous) avoid in - CAst.make @@ PatVar (Name id), ((id,t)::subst, id::avoid) in + DAst.make @@ PatVar (Name id), ((id,t)::subst, id::avoid) in let rec reveal_pattern t (subst,avoid as acc) = match EConstr.kind sigma (whd_all env sigma t) with - | Construct (cstr,u) -> CAst.make (PatCstr (cstr,[],Anonymous)), acc + | Construct (cstr,u) -> DAst.make (PatCstr (cstr,[],Anonymous)), acc | App (f,v) when isConstruct sigma f -> let cstr,u = destConstruct sigma f in let n = constructor_nrealargs_env env cstr in let l = List.lastn n (Array.to_list v) in - let l,acc = List.fold_map' reveal_pattern l acc in - CAst.make (PatCstr (cstr,l,Anonymous)), acc + let l,acc = List.fold_right_map reveal_pattern l acc in + DAst.make (PatCstr (cstr,l,Anonymous)), acc | _ -> make_patvar t acc in let rec aux n env acc_sign tms acc = match tms with | [] -> [], acc_sign, acc | (t, IsInd (_,IndType(indf,realargs),_)) :: tms -> - let patl,acc = List.fold_map' reveal_pattern realargs acc in + let patl,acc = List.fold_right_map reveal_pattern realargs acc in let pat,acc = make_patvar t acc in let indf' = lift_inductive_family n indf in let sign = make_arity_signature env sigma true indf' in @@ -1830,7 +1836,7 @@ let build_inversion_problem loc env sigma tms t = (* No need for a catch all clause *) [] else - [ { patterns = List.map (fun _ -> CAst.make @@ PatVar Anonymous) patl; + [ { patterns = List.map (fun _ -> DAst.make @@ PatVar Anonymous) patl; alias_stack = []; eqn_loc = None; used = ref false; @@ -2094,14 +2100,14 @@ let mk_JMeq evdref typ x typ' y = let mk_JMeq_refl evdref typ x = papp evdref coq_JMeq_refl [| typ; x |] -let hole na = CAst.make @@ +let hole na = DAst.make @@ GHole (Evar_kinds.QuestionMark (Evar_kinds.Define false,na), Misctypes.IntroAnonymous, None) let constr_of_pat env evdref arsign pat avoid = let rec typ env (ty, realargs) pat avoid = let loc = pat.CAst.loc in - match pat.CAst.v with + match DAst.get pat with | PatVar name -> let name, avoid = match name with Name n -> name, avoid @@ -2109,7 +2115,7 @@ let constr_of_pat env evdref arsign pat avoid = let previd, id = prime avoid (Name (Id.of_string "wildcard")) in Name id, id :: avoid in - ((CAst.make ?loc @@ PatVar name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, + ((DAst.make ?loc @@ PatVar name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid) | PatCstr (((_, i) as cstr),args,alias) -> let cind = inductive_of_constructor cstr in @@ -2140,7 +2146,7 @@ let constr_of_pat env evdref arsign pat avoid = in let args = List.rev args in let patargs = List.rev patargs in - let pat' = CAst.make ?loc @@ PatCstr (cstr, patargs, alias) in + let pat' = DAst.make ?loc @@ PatCstr (cstr, patargs, alias) in let cstr = mkConstructU (on_snd EInstance.make ci.cs_cstr) in let app = applist (cstr, List.map (lift (List.length sign)) params) in let app = applist (app, args) in @@ -2196,18 +2202,18 @@ let vars_of_ctx sigma ctx = match decl with | LocalDef (na,t',t) when is_topvar sigma t' -> prev, - (CAst.make @@ GApp ( - (CAst.make @@ GRef (delayed_force coq_eq_refl_ref, None)), - [hole na; CAst.make @@ GVar prev])) :: vars + (DAst.make @@ GApp ( + (DAst.make @@ GRef (delayed_force coq_eq_refl_ref, None)), + [hole na; DAst.make @@ GVar prev])) :: vars | _ -> match RelDecl.get_name decl with Anonymous -> invalid_arg "vars_of_ctx" - | Name n -> n, (CAst.make @@ GVar n) :: vars) + | Name n -> n, (DAst.make @@ GVar n) :: vars) ctx (Id.of_string "vars_of_ctx_error", []) in List.rev y let rec is_included x y = - match CAst.(x.v, y.v) with + match DAst.get x, DAst.get y with | PatVar _, _ -> true | _, PatVar _ -> true | PatCstr ((_, i), args, alias), PatCstr ((_, i'), args', alias') -> @@ -2325,13 +2331,13 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in let branch_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in let branch = - let bref = CAst.make @@ GVar branch_name in + let bref = DAst.make @@ GVar branch_name in match vars_of_ctx !evdref rhs_rels with [] -> bref - | l -> CAst.make @@ GApp (bref, l) + | l -> DAst.make @@ GApp (bref, l) in let branch = match ineqs with - Some _ -> CAst.make @@ GApp (branch, [ hole Anonymous ]) + Some _ -> DAst.make @@ GApp (branch, [ hole Anonymous ]) | None -> branch in incr i; diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 535a62046a..fc0a650bc2 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -77,8 +77,8 @@ let apply_pattern_coercion ?loc pat p = List.fold_left (fun pat (co,n) -> let f i = - if i<n then (CAst.make ?loc @@ Glob_term.PatVar Anonymous) else pat in - CAst.make ?loc @@ Glob_term.PatCstr (co, List.init (n+1) f, Anonymous)) + if i<n then (DAst.make ?loc @@ Glob_term.PatVar Anonymous) else pat in + DAst.make ?loc @@ Glob_term.PatCstr (co, List.init (n+1) f, Anonymous)) pat p (* raise Not_found if no coercion found *) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 886cfd880f..ca7f633dc5 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -90,7 +90,8 @@ let rec build_lambda sigma vars ctx m = match vars with let pre, suf = List.chop (pred n) ctx in let (na, t, suf) = match suf with | [] -> assert false - | (_, na, t) :: suf -> (na, t, suf) + | (_, id, t) :: suf -> + (Name id, t, suf) in (** Check that the abstraction is legal by generating a transitive closure of its dependencies. *) @@ -126,11 +127,11 @@ let rec build_lambda sigma vars ctx m = match vars with mkRel 1 :: List.mapi (fun i _ -> mkRel (i + keep + 2)) suf in - let map i (id, na, c) = + let map i (na, id, c) = let i = succ i in let subst = List.skipn i subst in let subst = List.map (fun c -> Vars.lift (- i) c) subst in - (id, na, substl subst c) + (na, id, substl subst c) in let pre = List.mapi map pre in let pre = List.filter_with clear pre in @@ -150,11 +151,10 @@ let rec build_lambda sigma vars ctx m = match vars with let rec extract_bound_aux k accu frels ctx = match ctx with | [] -> accu -| (na1, na2, _) :: ctx -> +| (na, _, _) :: ctx -> if Int.Set.mem k frels then - begin match na1 with + begin match na with | Name id -> - let () = assert (match na2 with Anonymous -> false | Name _ -> true) in let () = if Id.Set.mem id accu then raise PatternMatchingFailure in extract_bound_aux (k + 1) (Id.Set.add id accu) frels ctx | Anonymous -> raise PatternMatchingFailure @@ -167,13 +167,21 @@ let extract_bound_vars frels ctx = let dummy_constr = EConstr.mkProp let make_renaming ids = function -| (Name id, Name _, _) -> +| (Name id, _, _) -> begin try EConstr.mkRel (List.index Id.equal id ids) with Not_found -> dummy_constr end | _ -> dummy_constr +let push_binder na1 na2 t ctx = + let id2 = match na2 with + | Name id2 -> id2 + | Anonymous -> + let avoid = List.map pi2 ctx in + Namegen.next_ident_away Namegen.default_non_dependent_ident avoid in + (na1, id2, t) :: ctx + let to_fix (idx, (nas, cs, ts)) = let inj = EConstr.of_constr in (idx, (nas, Array.map inj cs, Array.map inj ts)) @@ -306,19 +314,19 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels sorec ctx env subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> - sorec ((na1,na2,c2)::ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) + sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> - sorec ((na1,na2,c2)::ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) + sorec (push_binder na1 na2 c2 ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLetIn (na1,c1,Some t1,d1), LetIn(na2,c2,t2,d2) -> - sorec ((na1,na2,t2)::ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) + sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env (sorec ctx env subst c1 c2) t1 t2)) d1 d2 | PLetIn (na1,c1,None,d1), LetIn(na2,c2,t2,d2) -> - sorec ((na1,na2,t2)::ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) + sorec (push_binder na1 na2 t2 ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> @@ -327,7 +335,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels let n = Context.Rel.length ctx_b2 in let n' = Context.Rel.length ctx_b2' in if Vars.noccur_between sigma 1 n b2 && Vars.noccur_between sigma 1 n' b2' then - let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = (Anonymous,na,t)::l in + let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = push_binder Anonymous na t l in let ctx_br = List.fold_left f ctx ctx_b2 in let ctx_br' = List.fold_left f ctx ctx_b2' in let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index b9cb7ba1b1..1eb22cdb81 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -28,6 +28,10 @@ open Misctypes open Decl_kinds open Context.Named.Declaration +type _ delay = +| Now : 'a delay +| Later : [ `thunk ] delay + (** Should we keep details of universes during detyping ? *) let print_universes = Flags.univ_print @@ -277,7 +281,7 @@ let rec decomp_branch tags nal b (avoid,env as e) sigma c = (avoid', add_name_opt na' body t env) sigma c let rec build_tree na isgoal e sigma ci cl = - let mkpat n rhs pl = CAst.make @@ PatCstr((ci.ci_ind,n+1),pl,update_name sigma na rhs) in + let mkpat n rhs pl = DAst.make @@ PatCstr((ci.ci_ind,n+1),pl,update_name sigma na rhs) in let cnl = ci.ci_pp_info.cstr_tags in let cna = ci.ci_cstr_nargs in List.flatten @@ -300,7 +304,7 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with List.map (fun (hd,rest) -> pat::hd,rest) lines) clauses) | _ -> - let pat = CAst.make @@ PatVar(update_name sigma na rhs) in + let pat = DAst.make @@ PatVar(update_name sigma na rhs) in let mat = align_tree nal isgoal rhs sigma in List.map (fun (hd,rest) -> pat::hd,rest) mat @@ -323,7 +327,7 @@ let is_nondep_branch sigma c l = let extract_nondep_branches test c b l = let rec strip l r = - match r.CAst.v, l with + match DAst.get r, l with | r', [] -> r | GLambda (_,_,_,t), false::l -> strip l t | GLetIn (_,_,_,t), true::l -> strip l t @@ -333,7 +337,7 @@ let extract_nondep_branches test c b l = let it_destRLambda_or_LetIn_names l c = let rec aux l nal c = - match c.CAst.v, l with + match DAst.get c, l with | _, [] -> (List.rev nal,c) | GLambda (na,_,_,c), false::l -> aux l (na::nal) c | GLetIn (na,_,_,c), true::l -> aux l (na::nal) c @@ -347,11 +351,11 @@ let it_destRLambda_or_LetIn_names l c = x in let x = next (free_glob_vars c) in - let a = CAst.make @@ GVar x in + let a = DAst.make @@ GVar x in aux l (Name x :: nal) - (match c with - | { loc; CAst.v = GApp (p,l) } -> CAst.make ?loc @@ GApp (p,l@[a]) - | _ -> CAst.make @@ GApp (c,[a])) + (match DAst.get c with + | GApp (p,l) -> DAst.make ?loc:c.CAst.loc @@ GApp (p,l@[a]) + | _ -> DAst.make @@ GApp (c,[a])) in aux l [] c let detype_case computable detype detype_eqns testdep avoid data p c bl = @@ -367,7 +371,7 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl = | None -> Anonymous, None, None | Some p -> let nl,typ = it_destRLambda_or_LetIn_names k p in - let n,typ = match typ.CAst.v with + let n,typ = match DAst.get typ with | GLambda (x,_,t,c) -> x, c | _ -> Anonymous, typ in let aliastyp = @@ -437,12 +441,20 @@ let detype_instance sigma l = if Univ.Instance.is_empty l then None else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) -let rec detype flags avoid env sigma t = CAst.make @@ +let delay (type a) (d : a delay) (f : a delay -> _ -> _ -> _ -> _ -> _ -> a glob_constr_r) flags env avoid sigma t : a glob_constr_g = + match d with + | Now -> DAst.make (f d flags env avoid sigma t) + | Later -> DAst.delay (fun () -> f d flags env avoid sigma t) + +let rec detype d flags avoid env sigma t = + delay d detype_r flags avoid env sigma t + +and detype_r d flags avoid env sigma t = match EConstr.kind sigma (collapse_appl sigma t) with | Rel n -> (try match lookup_name_of_rel n (fst env) with | Name id -> GVar id - | Anonymous -> (!detype_anonymous n).CAst.v + | Anonymous -> GVar (!detype_anonymous n) with Not_found -> let s = "_UNBOUND_REL_"^(string_of_int n) in GVar (Id.of_string s)) @@ -455,44 +467,44 @@ let rec detype flags avoid env sigma t = CAst.make @@ with Not_found -> GVar id) | Sort s -> GSort (detype_sort sigma (ESorts.kind sigma s)) | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> - (detype flags avoid env sigma c1).CAst.v + DAst.get (detype d flags avoid env sigma c1) | Cast (c1,k,c2) -> - let d1 = detype flags avoid env sigma c1 in - let d2 = detype flags avoid env sigma c2 in + let d1 = detype d flags avoid env sigma c1 in + let d2 = detype d flags avoid env sigma c2 in let cast = match k with | VMcast -> CastVM d2 | NATIVEcast -> CastNative d2 | _ -> CastConv d2 in GCast(d1,cast) - | Prod (na,ty,c) -> detype_binder flags BProd avoid env sigma na None ty c - | Lambda (na,ty,c) -> detype_binder flags BLambda avoid env sigma na None ty c - | LetIn (na,b,ty,c) -> detype_binder flags BLetIn avoid env sigma na (Some b) ty c + | Prod (na,ty,c) -> detype_binder d flags BProd avoid env sigma na None ty c + | Lambda (na,ty,c) -> detype_binder d flags BLambda avoid env sigma na None ty c + | LetIn (na,b,ty,c) -> detype_binder d flags BLetIn avoid env sigma na (Some b) ty c | App (f,args) -> let mkapp f' args' = - match f'.CAst.v with + match DAst.get f' with | GApp (f',args'') -> GApp (f',args''@args') | _ -> GApp (f',args') in - mkapp (detype flags avoid env sigma f) - (Array.map_to_list (detype flags avoid env sigma) args) + mkapp (detype d flags avoid env sigma f) + (Array.map_to_list (detype d flags avoid env sigma) args) | Const (sp,u) -> GRef (ConstRef sp, detype_instance sigma u) | Proj (p,c) -> let noparams () = let pb = Environ.lookup_projection p (snd env) in let pars = pb.Declarations.proj_npars in - let hole = CAst.make @@ GHole(Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) in + let hole = DAst.make @@ GHole(Evar_kinds.InternalHole,Misctypes.IntroAnonymous,None) in let args = List.make pars hole in - GApp (CAst.make @@ GRef (ConstRef (Projection.constant p), None), - (args @ [detype flags avoid env sigma c])) + GApp (DAst.make @@ GRef (ConstRef (Projection.constant p), None), + (args @ [detype d flags avoid env sigma c])) in if fst flags || !Flags.in_debugger || !Flags.in_toplevel then try noparams () with _ -> (* lax mode, used by debug printers only *) - GApp (CAst.make @@ GRef (ConstRef (Projection.constant p), None), - [detype flags avoid env sigma c]) + GApp (DAst.make @@ GRef (ConstRef (Projection.constant p), None), + [detype d flags avoid env sigma c]) else if print_primproj_compatibility () && Projection.unfolded p then (** Print the compatibility match version *) @@ -509,12 +521,12 @@ let rec detype flags avoid env sigma t = CAst.make @@ substl (c :: List.rev args) body' with Retyping.RetypeError _ | Not_found -> anomaly (str"Cannot detype an unfolded primitive projection.") - in (detype flags avoid env sigma c').CAst.v + in DAst.get (detype d flags avoid env sigma c') else if print_primproj_params () then try let c = Retyping.expand_projection (snd env) sigma p c [] in - (detype flags avoid env sigma c).CAst.v + DAst.get (detype d flags avoid env sigma c) with Retyping.RetypeError _ -> noparams () else noparams () @@ -542,23 +554,23 @@ let rec detype flags avoid env sigma t = CAst.make @@ (Array.map_to_list (fun c -> (Id.of_string "__",c)) cl) in GEvar (id, - List.map (on_snd (detype flags avoid env sigma)) l) + List.map (on_snd (detype d flags avoid env sigma)) l) | Ind (ind_sp,u) -> GRef (IndRef ind_sp, detype_instance sigma u) | Construct (cstr_sp,u) -> GRef (ConstructRef cstr_sp, detype_instance sigma u) | Case (ci,p,c,bl) -> let comp = computable sigma p (List.length (ci.ci_pp_info.ind_tags)) in - detype_case comp (detype flags avoid env sigma) - (detype_eqns flags avoid env sigma ci comp) + detype_case comp (detype d flags avoid env sigma) + (detype_eqns d flags avoid env sigma ci comp) (is_nondep_branch sigma) avoid (ci.ci_ind,ci.ci_pp_info.style, ci.ci_pp_info.cstr_tags,ci.ci_pp_info.ind_tags) (Some p) c bl - | Fix (nvn,recdef) -> detype_fix flags avoid env sigma nvn recdef - | CoFix (n,recdef) -> detype_cofix flags avoid env sigma n recdef + | Fix (nvn,recdef) -> detype_fix d flags avoid env sigma nvn recdef + | CoFix (n,recdef) -> detype_cofix d flags avoid env sigma n recdef -and detype_fix flags avoid env sigma (vn,_ as nvn) (names,tys,bodies) = +and detype_fix d flags avoid env sigma (vn,_ as nvn) (names,tys,bodies) = let def_avoid, def_env, lfi = Array.fold_left2 (fun (avoid, env, l) na ty -> @@ -567,14 +579,14 @@ and detype_fix flags avoid env sigma (vn,_ as nvn) (names,tys,bodies) = (avoid, env, []) names tys in let n = Array.length tys in let v = Array.map3 - (fun c t i -> share_names flags (i+1) [] def_avoid def_env sigma c (lift n t)) + (fun c t i -> share_names d flags (i+1) [] def_avoid def_env sigma c (lift n t)) bodies tys vn in GRec(GFix (Array.map (fun i -> Some i, GStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) -and detype_cofix flags avoid env sigma n (names,tys,bodies) = +and detype_cofix d flags avoid env sigma n (names,tys,bodies) = let def_avoid, def_env, lfi = Array.fold_left2 (fun (avoid, env, l) na ty -> @@ -583,14 +595,14 @@ and detype_cofix flags avoid env sigma n (names,tys,bodies) = (avoid, env, []) names tys in let ntys = Array.length tys in let v = Array.map2 - (fun c t -> share_names flags 0 [] def_avoid def_env sigma c (lift ntys t)) + (fun c t -> share_names d flags 0 [] def_avoid def_env sigma c (lift ntys t)) bodies tys in GRec(GCoFix n,Array.of_list (List.rev lfi), Array.map (fun (bl,_,_) -> bl) v, Array.map (fun (_,_,ty) -> ty) v, Array.map (fun (_,bd,_) -> bd) v) -and share_names flags n l avoid env sigma c t = +and share_names d flags n l avoid env sigma c t = match EConstr.kind sigma c, EConstr.kind sigma t with (* factorize even when not necessary to have better presentation *) | Lambda (na,t,c), Prod (na',t',c') -> @@ -598,59 +610,59 @@ and share_names flags n l avoid env sigma c t = Name _, _ -> na | _, Name _ -> na' | _ -> na in - let t' = detype flags avoid env sigma t in + let t' = detype d flags avoid env sigma t in let id = next_name_away na avoid in let avoid = id::avoid and env = add_name (Name id) None t env in - share_names flags (n-1) ((Name id,Explicit,None,t')::l) avoid env sigma c c' + share_names d flags (n-1) ((Name id,Explicit,None,t')::l) avoid env sigma c c' (* May occur for fix built interactively *) | LetIn (na,b,t',c), _ when n > 0 -> - let t'' = detype flags avoid env sigma t' in - let b' = detype flags avoid env sigma b in + let t'' = detype d flags avoid env sigma t' in + let b' = detype d flags avoid env sigma b in let id = next_name_away na avoid in let avoid = id::avoid and env = add_name (Name id) (Some b) t' env in - share_names flags n ((Name id,Explicit,Some b',t'')::l) avoid env sigma c (lift 1 t) + share_names d flags n ((Name id,Explicit,Some b',t'')::l) avoid env sigma c (lift 1 t) (* Only if built with the f/n notation or w/o let-expansion in types *) | _, LetIn (_,b,_,t) when n > 0 -> - share_names flags n l avoid env sigma c (subst1 b t) + share_names d flags n l avoid env sigma c (subst1 b t) (* If it is an open proof: we cheat and eta-expand *) | _, Prod (na',t',c') when n > 0 -> - let t'' = detype flags avoid env sigma t' in + let t'' = detype d flags avoid env sigma t' in let id = next_name_away na' avoid in let avoid = id::avoid and env = add_name (Name id) None t' env in let appc = mkApp (lift 1 c,[|mkRel 1|]) in - share_names flags (n-1) ((Name id,Explicit,None,t'')::l) avoid env sigma appc c' + share_names d flags (n-1) ((Name id,Explicit,None,t'')::l) avoid env sigma appc c' (* If built with the f/n notation: we renounce to share names *) | _ -> if n>0 then Feedback.msg_debug (strbrk "Detyping.detype: cannot factorize fix enough"); - let c = detype flags avoid env sigma c in - let t = detype flags avoid env sigma t in + let c = detype d flags avoid env sigma c in + let t = detype d flags avoid env sigma t in (List.rev l,c,t) -and detype_eqns flags avoid env sigma ci computable constructs consnargsl bl = +and detype_eqns d flags avoid env sigma ci computable constructs consnargsl bl = try if !Flags.raw_print || not (reverse_matching ()) then raise Exit; let mat = build_tree Anonymous (snd flags) (avoid,env) sigma ci bl in - List.map (fun (pat,((avoid,env),c)) -> Loc.tag ([],[pat],detype flags avoid env sigma c)) + List.map (fun (pat,((avoid,env),c)) -> Loc.tag ([],[pat],detype d flags avoid env sigma c)) mat with e when CErrors.noncritical e -> Array.to_list - (Array.map3 (detype_eqn flags avoid env sigma) constructs consnargsl bl) + (Array.map3 (detype_eqn d flags avoid env sigma) constructs consnargsl bl) -and detype_eqn (lax,isgoal as flags) avoid env sigma constr construct_nargs branch = +and detype_eqn d (lax,isgoal as flags) avoid env sigma constr construct_nargs branch = let make_pat x avoid env b body ty ids = if force_wildcard () && noccurn sigma 1 b then - CAst.make @@ PatVar Anonymous,avoid,(add_name Anonymous body ty env),ids + DAst.make @@ PatVar Anonymous,avoid,(add_name Anonymous body ty env),ids else let flag = if isgoal then RenamingForGoal else RenamingForCasesPattern (fst env,b) in let na,avoid' = compute_displayed_name_in sigma flag avoid x b in - CAst.make (PatVar na),avoid',(add_name na body ty env),add_vname ids na + DAst.make (PatVar na),avoid',(add_name na body ty env),add_vname ids na in let rec buildrec ids patlist avoid env l b = match EConstr.kind sigma b, l with | _, [] -> Loc.tag @@ (Id.Set.elements ids, - [CAst.make @@ PatCstr(constr, List.rev patlist,Anonymous)], - detype flags avoid env sigma b) + [DAst.make @@ PatCstr(constr, List.rev patlist,Anonymous)], + detype d flags avoid env sigma b) | Lambda (x,t,b), false::l -> let pat,new_avoid,new_env,new_ids = make_pat x avoid env b None t ids in buildrec new_ids (pat::patlist) new_avoid new_env l b @@ -663,7 +675,7 @@ and detype_eqn (lax,isgoal as flags) avoid env sigma constr construct_nargs bran buildrec ids patlist avoid env l c | _, true::l -> - let pat = CAst.make @@ PatVar Anonymous in + let pat = DAst.make @@ PatVar Anonymous in buildrec ids (pat::patlist) avoid env l b | _, false::l -> @@ -678,23 +690,23 @@ and detype_eqn (lax,isgoal as flags) avoid env sigma constr construct_nargs bran in buildrec Id.Set.empty [] avoid env construct_nargs branch -and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c = +and detype_binder d (lax,isgoal as flags) bk avoid env sigma na body ty c = let flag = if isgoal then RenamingForGoal else RenamingElsewhereFor (fst env,c) in let na',avoid' = match bk with | BLetIn -> compute_displayed_let_name_in sigma flag avoid na c | _ -> compute_displayed_name_in sigma flag avoid na c in - let r = detype flags avoid' (add_name na' body ty env) sigma c in + let r = detype d flags avoid' (add_name na' body ty env) sigma c in match bk with - | BProd -> GProd (na',Explicit,detype (lax,false) avoid env sigma ty, r) - | BLambda -> GLambda (na',Explicit,detype (lax,false) avoid env sigma ty, r) + | BProd -> GProd (na',Explicit,detype d (lax,false) avoid env sigma ty, r) + | BLambda -> GLambda (na',Explicit,detype d (lax,false) avoid env sigma ty, r) | BLetIn -> - let c = detype (lax,false) avoid env sigma (Option.get body) in + let c = detype d (lax,false) avoid env sigma (Option.get body) in (* Heuristic: we display the type if in Prop *) let s = try Retyping.get_sort_family_of (snd env) sigma ty with _ when !Flags.in_debugger || !Flags.in_toplevel -> InType (* Can fail because of sigma missing in debugger *) in - let t = if s != InProp && not !Flags.raw_print then None else Some (detype (lax,false) avoid env sigma ty) in + let t = if s != InProp && not !Flags.raw_print then None else Some (detype d (lax,false) avoid env sigma ty) in GLetIn (na', c, t, r) -let detype_rel_context ?(lax=false) where avoid env sigma sign = +let detype_rel_context d ?(lax=false) where avoid env sigma sign = let where = Option.map (fun c -> EConstr.it_mkLambda_or_LetIn c sign) where in let rec aux avoid env = function | [] -> [] @@ -716,15 +728,18 @@ let detype_rel_context ?(lax=false) where avoid env sigma sign = | LocalAssum _ -> None | LocalDef (_,b,_) -> Some b in - let b' = Option.map (detype (lax,false) avoid env sigma) b in - let t' = detype (lax,false) avoid env sigma t in + let b' = Option.map (detype d (lax,false) avoid env sigma) b in + let t' = detype d (lax,false) avoid env sigma t in (na',Explicit,b',t') :: aux avoid' (add_name na' b t env) rest in aux avoid env (List.rev sign) let detype_names isgoal avoid nenv env sigma t = - detype (false,isgoal) avoid (nenv,env) sigma t -let detype ?(lax=false) isgoal avoid env sigma t = - detype (lax,isgoal) avoid (names_of_rel_context env, env) sigma t + detype Now (false,isgoal) avoid (nenv,env) sigma t +let detype d ?(lax=false) isgoal avoid env sigma t = + detype d (lax,isgoal) avoid (names_of_rel_context env, env) sigma t + +let detype_rel_context d ?lax where avoid env sigma sign = + detype_rel_context d ?lax where avoid env sigma sign let detype_closed_glob ?lax isgoal avoid env sigma t = let open Context.Rel.Declaration in @@ -736,7 +751,7 @@ let detype_closed_glob ?lax isgoal avoid env sigma t = | Name id -> Name (convert_id cl id) | Anonymous -> Anonymous in - let rec detype_closed_glob cl cg : Glob_term.glob_constr = CAst.map (function + let rec detype_closed_glob cl cg : Glob_term.glob_constr = DAst.map (function | GVar id -> (* if [id] is bound to a name. *) begin try @@ -750,11 +765,11 @@ let detype_closed_glob ?lax isgoal avoid env sigma t = [Printer.pr_constr_under_binders_env] does. *) let assums = List.map (fun id -> LocalAssum (Name id,(* dummy *) mkProp)) b in let env = push_rel_context assums env in - (detype ?lax isgoal avoid env sigma c).CAst.v + DAst.get (detype Now ?lax isgoal avoid env sigma c) (* if [id] is bound to a [closed_glob_constr]. *) with Not_found -> try let {closure;term} = Id.Map.find id cl.untyped in - (detype_closed_glob closure term).CAst.v + DAst.get (detype_closed_glob closure term) (* Otherwise [id] stands for itself *) with Not_found -> GVar id @@ -781,7 +796,7 @@ let detype_closed_glob ?lax isgoal avoid env sigma t = in GCases(sty,po,tml,eqns) | c -> - (Glob_ops.map_glob_constr (detype_closed_glob cl) cg).CAst.v + DAst.get (Glob_ops.map_glob_constr (detype_closed_glob cl) cg) ) cg in detype_closed_glob t.closure t.term @@ -789,7 +804,7 @@ let detype_closed_glob ?lax isgoal avoid env sigma t = (**********************************************************************) (* Module substitution: relies on detyping *) -let rec subst_cases_pattern subst = CAst.map (function +let rec subst_cases_pattern subst = DAst.map (function | PatVar _ as pat -> pat | PatCstr (((kn,i),j),cpl,n) as pat -> let kn' = subst_mind subst kn @@ -800,11 +815,11 @@ let rec subst_cases_pattern subst = CAst.map (function let (f_subst_genarg, subst_genarg_hook) = Hook.make () -let rec subst_glob_constr subst = CAst.map (function +let rec subst_glob_constr subst = DAst.map (function | GRef (ref,u) as raw -> let ref',t = subst_global subst ref in if ref' == ref then raw else - (detype false [] (Global.env()) Evd.empty (EConstr.of_constr t)).CAst.v + DAst.get (detype Now false [] (Global.env()) Evd.empty (EConstr.of_constr t)) | GSort _ | GVar _ @@ -905,8 +920,8 @@ let rec subst_glob_constr subst = CAst.map (function let simple_cases_matrix_of_branches ind brs = List.map (fun (i,n,b) -> let nal,c = it_destRLambda_or_LetIn_names n b in - let mkPatVar na = CAst.make @@ PatVar na in - let p = CAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in + let mkPatVar na = DAst.make @@ PatVar na in + let p = DAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in let ids = List.map_filter Nameops.Name.to_option nal in Loc.tag @@ (ids,[p],c)) brs diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 59f3f967d3..67c852af32 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -16,6 +16,10 @@ open Mod_subst open Misctypes open Evd +type _ delay = +| Now : 'a delay +| Later : [ `thunk ] delay + (** Should we keep details of universes during detyping ? *) val print_universes : bool ref @@ -33,12 +37,12 @@ val subst_glob_constr : substitution -> glob_constr -> glob_constr val detype_names : bool -> Id.t list -> names_context -> env -> evar_map -> constr -> glob_constr -val detype : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> constr -> glob_constr +val detype : 'a delay -> ?lax:bool -> bool -> Id.t list -> env -> evar_map -> constr -> 'a glob_constr_g val detype_sort : evar_map -> sorts -> glob_sort -val detype_rel_context : ?lax:bool -> constr option -> Id.t list -> (names_context * env) -> - evar_map -> rel_context -> glob_decl list +val detype_rel_context : 'a delay -> ?lax:bool -> constr option -> Id.t list -> (names_context * env) -> + evar_map -> rel_context -> 'a glob_decl_g list val detype_closed_glob : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> closed_glob_constr -> glob_constr @@ -47,7 +51,7 @@ val lookup_name_as_displayed : env -> evar_map -> constr -> Id.t -> int option val lookup_index_as_renamed : env -> evar_map -> constr -> int -> int option (* XXX: This is a hack and should go away *) -val set_detype_anonymous : (?loc:Loc.t -> int -> glob_constr) -> unit +val set_detype_anonymous : (?loc:Loc.t -> int -> Id.t) -> unit val force_wildcard : unit -> bool val synthetize_type : unit -> bool diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index b94228e75e..c40a24e3b7 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -23,8 +23,8 @@ let cases_predicate_names tml = | (tm,(na,None)) -> [na] | (tm,(na,Some (_,(_,nal)))) -> na::nal) tml) -let mkGApp ?loc p t = CAst.make ?loc @@ - match p.CAst.v with +let mkGApp ?loc p t = DAst.make ?loc @@ + match DAst.get p with | GApp (f,l) -> GApp (f,l@[t]) | _ -> GApp (p,[t]) @@ -46,7 +46,7 @@ let case_style_eq s1 s2 = match s1, s2 with | RegularStyle, RegularStyle -> true | (LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle), _ -> false -let rec cases_pattern_eq { CAst.v = p1} { CAst.v = p2 } = match p1, p2 with +let rec cases_pattern_eq p1 p2 = match DAst.get p1, DAst.get p2 with | PatVar na1, PatVar na2 -> Name.equal na1 na2 | PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) -> eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 && @@ -98,7 +98,7 @@ let fix_kind_eq f k1 k2 = match k1, k2 with let instance_eq f (x1,c1) (x2,c2) = Id.equal x1 x2 && f c1 c2 -let mk_glob_constr_eq f { CAst.v = c1 } { CAst.v = c2 } = match c1, c2 with +let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with | GRef (gr1, _), GRef (gr2, _) -> eq_gr gr1 gr2 | GVar id1, GVar id2 -> Id.equal id1 id2 | GEvar (id1, arg1), GEvar (id2, arg2) -> @@ -137,7 +137,7 @@ let mk_glob_constr_eq f { CAst.v = c1 } { CAst.v = c2 } = match c1, c2 with let rec glob_constr_eq c = mk_glob_constr_eq glob_constr_eq c -let map_glob_constr_left_to_right f = CAst.map (function +let map_glob_constr_left_to_right f = DAst.map (function | GApp (g,args) -> let comp1 = f g in let comp2 = Util.List.map_left f args in @@ -186,7 +186,7 @@ let map_glob_constr = map_glob_constr_left_to_right let fold_return_type f acc (na,tyopt) = Option.fold_left f acc tyopt -let fold_glob_constr f acc = CAst.with_val (function +let fold_glob_constr f acc = DAst.with_val (function | GVar _ -> acc | GApp (c,args) -> List.fold_left f (f acc c) args | GLambda (_,_,b,c) | GProd (_,_,b,c) -> @@ -217,7 +217,7 @@ let fold_glob_constr f acc = CAst.with_val (function let fold_return_type_with_binders f g v acc (na,tyopt) = Option.fold_left (f (Name.fold_right g na v)) acc tyopt -let fold_glob_constr_with_binders g f v acc = CAst.(with_val (function +let fold_glob_constr_with_binders g f v acc = DAst.(with_val (function | GVar _ -> acc | GApp (c,args) -> List.fold_left (f v) (f v acc c) args | GLambda (na,_,b,c) | GProd (na,_,b,c) -> @@ -256,10 +256,9 @@ let fold_glob_constr_with_binders g f v acc = CAst.(with_val (function let iter_glob_constr f = fold_glob_constr (fun () -> f) () let occur_glob_constr id = - let open CAst in - let rec occur barred acc = function - | { loc ; v = GVar id' } -> Id.equal id id' - | c -> + let rec occur barred acc c = match DAst.get c with + | GVar id' -> Id.equal id id' + | _ -> (* [g] looks if [id] appears in a binding position, in which case, we don't have to look in the corresponding subterm *) let g id' barred = barred || Id.equal id id' in @@ -268,21 +267,20 @@ let occur_glob_constr id = occur false false let free_glob_vars = - let open CAst in - let rec vars bound vs = function - | { loc ; v = GVar id' } -> if Id.Set.mem id' bound then vs else Id.Set.add id' vs - | c -> fold_glob_constr_with_binders Id.Set.add vars bound vs c in + let rec vars bound vs c = match DAst.get c with + | GVar id' -> if Id.Set.mem id' bound then vs else Id.Set.add id' vs + | _ -> fold_glob_constr_with_binders Id.Set.add vars bound vs c in fun rt -> let vs = vars Id.Set.empty Id.Set.empty rt in Id.Set.elements vs let glob_visible_short_qualid c = - let rec aux acc = function - | { CAst.v = GRef (c,_) } -> + let rec aux acc c = match DAst.get c with + | GRef (c,_) -> let qualid = Nametab.shortest_qualid_of_global Id.Set.empty c in let dir,id = Libnames.repr_qualid qualid in if DirPath.is_empty dir then id :: acc else acc - | c -> + | _ -> fold_glob_constr aux acc c in aux [] c @@ -326,7 +324,7 @@ let map_tomatch_binders f ((c,(na,inp)) as x) : tomatch_tuple = if r == inp then x else c,(f na, r) -let rec map_case_pattern_binders f = CAst.map (function +let rec map_case_pattern_binders f = DAst.map (function | PatVar na as x -> let r = f na in if r == na then x @@ -396,7 +394,9 @@ let rename_var l id = if List.exists (fun (_,id') -> Id.equal id id') l then raise UnsoundRenaming else id -let rec rename_glob_vars l c = CAst.map_with_loc (fun ?loc -> function +let force c = DAst.make ?loc:c.CAst.loc (DAst.get c) + +let rec rename_glob_vars l c = force @@ DAst.map_with_loc (fun ?loc -> function | GVar id as r -> let id' = rename_var l id in if id == id' then r else GVar id' @@ -436,13 +436,13 @@ let rec rename_glob_vars l c = CAst.map_with_loc (fun ?loc -> function test_na l na; (na,k,Option.map (rename_glob_vars l) bbd,rename_glob_vars l bty))) decls, Array.map (rename_glob_vars l) bs, Array.map (rename_glob_vars l) ts) - | _ -> (map_glob_constr (rename_glob_vars l) c).CAst.v + | _ -> DAst.get (map_glob_constr (rename_glob_vars l) c) ) c (**********************************************************************) (* Conversion from glob_constr to cases pattern, if possible *) -let rec cases_pattern_of_glob_constr na = CAst.map (function +let rec cases_pattern_of_glob_constr na = DAst.map (function | GVar id -> begin match na with | Name _ -> @@ -452,8 +452,12 @@ let rec cases_pattern_of_glob_constr na = CAst.map (function end | GHole (_,_,_) -> PatVar na | GRef (ConstructRef cstr,_) -> PatCstr (cstr,[],na) - | GApp ( { CAst.v = GRef (ConstructRef cstr,_) }, l) -> + | GApp (c, l) -> + begin match DAst.get c with + | GRef (ConstructRef cstr,_) -> PatCstr (cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na) + | _ -> raise Not_found + end | _ -> raise Not_found ) @@ -469,7 +473,7 @@ let drop_local_defs typi args = | [], [] -> [] | Rel.Declaration.LocalDef _ :: decls, pat :: args -> begin - match pat.CAst.v with + match DAst.get pat with | PatVar Anonymous -> aux decls args | _ -> raise Not_found (* The pattern is used, one cannot drop it *) end @@ -487,21 +491,22 @@ let add_patterns_for_params_remove_local_defs (ind,j) l = let typi = mip.mind_nf_lc.(j-1) in let (_,typi) = decompose_prod_n_assum (Rel.length mib.mind_params_ctxt) typi in drop_local_defs typi l in - Util.List.addn nparams (CAst.make @@ PatVar Anonymous) l + Util.List.addn nparams (DAst.make @@ PatVar Anonymous) l (* Turn a closed cases pattern into a glob_constr *) -let rec glob_constr_of_closed_cases_pattern_aux x = CAst.map_with_loc (fun ?loc -> function +let rec glob_constr_of_closed_cases_pattern_aux x = DAst.map_with_loc (fun ?loc -> function | PatCstr (cstr,[],Anonymous) -> GRef (ConstructRef cstr,None) | PatCstr (cstr,l,Anonymous) -> - let ref = CAst.make ?loc @@ GRef (ConstructRef cstr,None) in + let ref = DAst.make ?loc @@ GRef (ConstructRef cstr,None) in let l = add_patterns_for_params_remove_local_defs cstr l in GApp (ref, List.map glob_constr_of_closed_cases_pattern_aux l) | _ -> raise Not_found ) x -let glob_constr_of_closed_cases_pattern = function - | { CAst.loc ; v = PatCstr (cstr,l,na) } -> - na,glob_constr_of_closed_cases_pattern_aux (CAst.make ?loc @@ PatCstr (cstr,l,Anonymous)) +let glob_constr_of_closed_cases_pattern p = match DAst.get p with + | PatCstr (cstr,l,na) -> + let loc = p.CAst.loc in + na,glob_constr_of_closed_cases_pattern_aux (DAst.make ?loc @@ PatCstr (cstr,l,Anonymous)) | _ -> raise Not_found diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index bd9e111f5c..bacc8fbe4e 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -11,21 +11,21 @@ open Glob_term (** Equalities *) -val cases_pattern_eq : cases_pattern -> cases_pattern -> bool +val cases_pattern_eq : 'a cases_pattern_g -> 'a cases_pattern_g -> bool val cast_type_eq : ('a -> 'a -> bool) -> 'a Misctypes.cast_type -> 'a Misctypes.cast_type -> bool -val glob_constr_eq : glob_constr -> glob_constr -> bool +val glob_constr_eq : 'a glob_constr_g -> 'a glob_constr_g -> bool (** Operations on [glob_constr] *) -val cases_pattern_loc : cases_pattern -> Loc.t option +val cases_pattern_loc : 'a cases_pattern_g -> Loc.t option -val cases_predicate_names : tomatch_tuples -> Name.t list +val cases_predicate_names : 'a tomatch_tuples_g -> Name.t list (** Apply one argument to a glob_constr *) -val mkGApp : ?loc:Loc.t -> glob_constr -> glob_constr -> glob_constr +val mkGApp : ?loc:Loc.t -> 'a glob_constr_g -> 'a glob_constr_g -> 'a glob_constr_g val map_glob_constr : (glob_constr -> glob_constr) -> glob_constr -> glob_constr @@ -42,12 +42,12 @@ val mk_glob_constr_eq : (glob_constr -> glob_constr -> bool) -> val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a val fold_glob_constr_with_binders : (Id.t -> 'a -> 'a) -> ('a -> 'b -> glob_constr -> 'b) -> 'a -> 'b -> glob_constr -> 'b val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit -val occur_glob_constr : Id.t -> glob_constr -> bool -val free_glob_vars : glob_constr -> Id.t list +val occur_glob_constr : Id.t -> 'a glob_constr_g -> bool +val free_glob_vars : 'a glob_constr_g -> Id.t list val bound_glob_vars : glob_constr -> Id.Set.t (* Obsolete *) -val loc_of_glob_constr : glob_constr -> Loc.t option -val glob_visible_short_qualid : glob_constr -> Id.t list +val loc_of_glob_constr : 'a glob_constr_g -> Loc.t option +val glob_visible_short_qualid : 'a glob_constr_g -> Id.t list (* Renaming free variables using a renaming map; fails with [UnsoundRenaming] if applying the renaming would introduce @@ -57,7 +57,7 @@ val glob_visible_short_qualid : glob_constr -> Id.t list exception UnsoundRenaming val rename_var : (Id.t * Id.t) list -> Id.t -> Id.t -val rename_glob_vars : (Id.t * Id.t) list -> glob_constr -> glob_constr +val rename_glob_vars : (Id.t * Id.t) list -> 'a glob_constr_g -> 'a glob_constr_g (** [map_pattern_binders f m c] applies [f] to all the binding names in a pattern-matching expression ({!Glob_term.GCases}) represented @@ -80,9 +80,9 @@ val map_pattern : (glob_constr -> glob_constr) -> @raise Not_found if translation is impossible *) val cases_pattern_of_glob_constr : Name.t -> glob_constr -> cases_pattern -val glob_constr_of_closed_cases_pattern : cases_pattern -> Name.t * glob_constr +val glob_constr_of_closed_cases_pattern : 'a cases_pattern_g -> Name.t * 'a glob_constr_g -val add_patterns_for_params_remove_local_defs : constructor -> cases_pattern list -> cases_pattern list +val add_patterns_for_params_remove_local_defs : constructor -> 'a cases_pattern_g list -> 'a cases_pattern_g list val ltac_interp_name : Glob_term.ltac_var_map -> Names.name -> Names.name val empty_lvar : Glob_term.ltac_var_map diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 5826cc1355..3b3ad021e4 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -326,7 +326,7 @@ let warn_cast_in_pattern = CWarnings.create ~name:"cast-in-pattern" ~category:"automation" (fun () -> Pp.strbrk "Casts are ignored in patterns") -let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function +let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function | GVar id -> (try PRel (List.index Name.equal (Name id) vars) with Not_found -> PVar id) @@ -335,11 +335,14 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function | GRef (gr,_) -> PRef (canonical_gr gr) (* Hack to avoid rewriting a complete interpretation of patterns *) - | GApp ({ CAst.v = GPatVar (Evar_kinds.SecondOrderPatVar n) }, cl) -> + | GApp (c, cl) -> + begin match DAst.get c with + | GPatVar (Evar_kinds.SecondOrderPatVar n) -> metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl) - | GApp (c,cl) -> + | _ -> PApp (pat_of_raw metas vars c, Array.of_list (List.map (pat_of_raw metas vars) cl)) + end | GLambda (na,bk,c1,c2) -> Name.iter (fun n -> metas := n::!metas) na; PLambda (na, pat_of_raw metas vars c1, @@ -364,8 +367,8 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function PIf (pat_of_raw metas vars c, pat_of_raw metas vars b1,pat_of_raw metas vars b2) | GLetTuple (nal,(_,None),b,c) -> - let mkGLambda na c = CAst.make ?loc @@ - GLambda (na,Explicit, CAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None),c) in + let mkGLambda na c = DAst.make ?loc @@ + GLambda (na,Explicit, DAst.make @@ GHole (Evar_kinds.InternalHole, IntroAnonymous, None),c) in let c = List.fold_right mkGLambda nal c in let cip = { cip_style = LetStyle; @@ -377,8 +380,12 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function PCase (cip, PMeta None, pat_of_raw metas vars b, [0,tags,pat_of_raw metas vars c]) | GCases (sty,p,[c,(na,indnames)],brs) -> + let get_ind p = match DAst.get p with + | PatCstr((ind,_),_,_) -> Some ind + | _ -> None + in let get_ind = function - | (_,(_,[{ CAst.v = PatCstr((ind,_),_,_) }],_))::_ -> Some ind + | (_,(_,[p],_))::_ -> get_ind p | _ -> None in let ind_tags,ind = match indnames with @@ -391,8 +398,11 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function | Some p, Some (_,(_,nal)) -> let nvars = na :: List.rev nal @ vars in rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas nvars p)) - | (None | Some { CAst.v = GHole _}), _ -> PMeta None + | None, _ -> PMeta None | Some p, None -> + match DAst.get p with + | GHole _ -> PMeta None + | _ -> user_err ?loc (strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") in let info = @@ -410,30 +420,36 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function ) and pats_of_glob_branches loc metas vars ind brs = - let get_arg = function - | { CAst.v = PatVar na } -> + let get_arg p = match DAst.get p with + | PatVar na -> Name.iter (fun n -> metas := n::!metas) na; na - | { CAst.v = PatCstr(_,_,_) ; loc } -> err ?loc (Pp.str "Non supported pattern.") + | PatCstr(_,_,_) -> err ?loc:p.CAst.loc (Pp.str "Non supported pattern.") in let rec get_pat indexes = function | [] -> false, [] - | [(_,(_,[{ CAst.v = PatVar Anonymous }], { CAst.v = GHole _}))] -> true, [] (* ends with _ => _ *) - | (_,(_,[{ CAst.v = PatCstr((indsp,j),lv,_) }],br)) :: brs -> - let () = match ind with - | Some sp when eq_ind sp indsp -> () + | (loc',(_,[p], br)) :: brs -> + begin match DAst.get p, DAst.get br, brs with + | PatVar Anonymous, GHole _, [] -> + true, [] (* ends with _ => _ *) + | PatCstr((indsp,j),lv,_), _, _ -> + let () = match ind with + | Some sp when eq_ind sp indsp -> () + | _ -> + err ?loc (Pp.str "All constructors must be in the same inductive type.") + in + if Int.Set.mem (j-1) indexes then + err ?loc + (str "No unique branch for " ++ int j ++ str"-th constructor."); + let lna = List.map get_arg lv in + let vars' = List.rev lna @ vars in + let pat = rev_it_mkPLambda lna (pat_of_raw metas vars' br) in + let ext,pats = get_pat (Int.Set.add (j-1) indexes) brs in + let tags = List.map (fun _ -> false) lv (* approximation, w/o let-in *) in + ext, ((j-1, tags, pat) :: pats) | _ -> - err ?loc (Pp.str "All constructors must be in the same inductive type.") - in - if Int.Set.mem (j-1) indexes then - err ?loc - (str "No unique branch for " ++ int j ++ str"-th constructor."); - let lna = List.map get_arg lv in - let vars' = List.rev lna @ vars in - let pat = rev_it_mkPLambda lna (pat_of_raw metas vars' br) in - let ext,pats = get_pat (Int.Set.add (j-1) indexes) brs in - let tags = List.map (fun _ -> false) lv (* approximation, w/o let-in *) in - ext, ((j-1, tags, pat) :: pats) + err ?loc:loc' (Pp.str "Non supported pattern.") + end | (loc,(_,_,_)) :: _ -> err ?loc (Pp.str "Non supported pattern.") in get_pat Int.Set.empty brs diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 40b8bcad92..ea1f2de539 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -222,18 +222,6 @@ let interp_level_info ?loc evd : Misctypes.level_info -> _ = function | None -> new_univ_level_variable ?loc univ_rigid evd | Some (loc,s) -> interp_universe_level_name ~anon_rigidity:univ_flexible evd (Loc.tag ?loc s) -let interp_sort ?loc evd = function - | GProp -> evd, Prop Null - | GSet -> evd, Prop Pos - | GType n -> - let evd, u = interp_universe ?loc evd n in - evd, Type u - -let interp_elimination_sort = function - | GProp -> InProp - | GSet -> InSet - | GType _ -> InType - type inference_hook = env -> evar_map -> evar -> evar_map * constr type inference_flags = { @@ -572,7 +560,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let pretype = pretype k0 resolve_tc in let open Context.Rel.Declaration in let loc = t.CAst.loc in - match t.CAst.v with + match DAst.get t with | GRef (ref,u) -> inh_conv_coerce_to_tycon ?loc env evdref (pretype_ref ?loc evdref env ref u) @@ -1100,17 +1088,9 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = Array.map_of_list snd subst (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) -and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function - | { loc; CAst.v = GHole (knd, naming, None) } -> - let rec is_Type c = match EConstr.kind !evdref c with - | Sort s -> - begin match ESorts.kind !evdref s with - | Type _ -> true - | Prop _ -> false - end - | Cast (c, _, _) -> is_Type c - | _ -> false - in +and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar c = match DAst.get c with + | GHole (knd, naming, None) -> + let loc = loc_of_glob_constr c in (match valcon with | Some v -> let s = @@ -1118,7 +1098,7 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function let t = Retyping.get_type_of env.ExtraEnv.env sigma v in match EConstr.kind sigma (whd_all env.ExtraEnv.env sigma t) with | Sort s -> ESorts.kind sigma s - | Evar ev when is_Type (existential_type sigma ev) -> + | Evar ev when is_Type sigma (existential_type sigma ev) -> evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev | _ -> anomaly (Pp.str "Found a type constraint which is not a type.") in @@ -1134,7 +1114,7 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function let s = evd_comb0 (new_sort_variable univ_flexible_alg) evdref in { utj_val = e_new_evar env evdref ~src:(loc, knd) ~naming (mkSort s); utj_type = s}) - | c -> + | _ -> let j = pretype k0 resolve_tc empty_tycon env evdref lvar c in let loc = loc_of_glob_constr c in let tj = evd_comb1 (Coercion.inh_coerce_to_sort ?loc env.ExtraEnv.env) evdref j in diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 7395e94a09..5822f5add5 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -18,7 +18,6 @@ open Evd open EConstr open Glob_term open Evarutil -open Misctypes (** An auxiliary function for searching for fixpoint guard indexes *) @@ -119,9 +118,6 @@ val ise_pretype_gen : (** To embed constr in glob_constr *) -val interp_sort : ?loc:Loc.t -> evar_map -> glob_sort -> evar_map * sorts -val interp_elimination_sort : glob_sort -> sorts_family - val register_constr_interp0 : ('r, 'g, 't) Genarg.genarg_type -> (unbound_ltac_var_map -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 4a103cdd23..37204c2134 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -380,9 +380,9 @@ let tag_var = tag Tag.variable match bl with | [CLocalAssum (nal,k,t)] -> kw n ++ pr_binder false pr_c (nal,k,t) - | (CLocalAssum _ | CLocalPattern _) :: _ as bdl -> + | (CLocalAssum _ | CLocalPattern _ | CLocalDef _) :: _ as bdl -> kw n ++ pr_undelimited_binders sep pr_c bdl - | _ -> assert false + | [] -> assert false let pr_binders_gen pr_c sep is_open = if is_open then pr_delimited_binders pr_com_at sep pr_c diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 4c50c2f368..5e57f5de03 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -275,7 +275,7 @@ open Decl_kinds ) ++ hov 0 ((if dep then keyword "Induction for" else keyword "Minimality for") ++ spc() ++ pr_smart_global ind) ++ spc() ++ - hov 0 (keyword "Sort" ++ spc() ++ pr_glob_sort s) + hov 0 (keyword "Sort" ++ spc() ++ Termops.pr_sort_family s) | CaseScheme (dep,ind,s) -> (match idop with | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() @@ -283,7 +283,7 @@ open Decl_kinds ) ++ hov 0 ((if dep then keyword "Elimination for" else keyword "Case for") ++ spc() ++ pr_smart_global ind) ++ spc() ++ - hov 0 (keyword "Sort" ++ spc() ++ pr_glob_sort s) + hov 0 (keyword "Sort" ++ spc() ++ Termops.pr_sort_family s) | EqualityScheme ind -> (match idop with | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() @@ -656,7 +656,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 diff --git a/proofs/refine.ml b/proofs/refine.ml index 4161d71047..e3f6508481 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -102,7 +102,12 @@ let generic_refine ~typecheck f gl = in (** Proceed to the refinement *) let c = EConstr.Unsafe.to_constr c in - let sigma = match evkmain with + let sigma = match Proofview.Unsafe.advance sigma self with + | None -> + (** Nothing to do, the goal has been solved by side-effect *) + sigma + | Some self -> + match evkmain with | None -> Evd.define self c sigma | Some evk -> let id = Evd.evar_ident self sigma in diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 9c58df5b21..31ede2d8b7 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -10,7 +10,7 @@ open CErrors open Pp open Util -let stm_pr_err pp = Format.eprintf "%s] @[%a@]%!\n" (System.process_id ()) Pp.pp_with pp +let stm_pr_err pp = Format.eprintf "%s] @[%a@]\n%!" (System.process_id ()) Pp.pp_with pp let stm_prerr_endline s = if !Flags.debug then begin stm_pr_err (str s) end else () diff --git a/tactics/hints.ml b/tactics/hints.ml index a572508d47..3ccbab874f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -56,7 +56,9 @@ let head_constr_bound sigma t = | _ -> raise Bound let head_constr sigma c = - try head_constr_bound sigma c with Bound -> user_err Pp.(str "Bound head variable.") + try head_constr_bound sigma c + with Bound -> user_err (Pp.str "Head identifier must be a constant, section variable, \ + (co)inductive type, (co)inductive type constructor, or projection.") let decompose_app_bound sigma t = let t = strip_outer_cast sigma t in @@ -764,7 +766,9 @@ let rec nb_hyp sigma c = match EConstr.kind sigma c with let try_head_pattern c = try head_pattern_bound c - with BoundPattern -> user_err Pp.(str "Bound head variable.") + with BoundPattern -> + user_err (Pp.str "Head pattern or sub-pattern must be a global constant, a section variable, \ + an if, case, or let expression, an application, or a projection.") let with_uid c = { obj = c; uid = fresh_key () } diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index b057cf72bc..75fae6647d 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -252,16 +252,16 @@ open Decl_kinds open Evar_kinds let mkPattern c = snd (Patternops.pattern_of_glob_constr c) -let mkGApp f args = CAst.make @@ GApp (f, args) -let mkGHole = CAst.make @@ +let mkGApp f args = DAst.make @@ GApp (f, args) +let mkGHole = DAst.make @@ GHole (QuestionMark (Define false,Anonymous), Misctypes.IntroAnonymous, None) -let mkGProd id c1 c2 = CAst.make @@ +let mkGProd id c1 c2 = DAst.make @@ GProd (Name (Id.of_string id), Explicit, c1, c2) -let mkGArrow c1 c2 = CAst.make @@ +let mkGArrow c1 c2 = DAst.make @@ GProd (Anonymous, Explicit, c1, c2) -let mkGVar id = CAst.make @@ GVar (Id.of_string id) -let mkGPatVar id = CAst.make @@ GPatVar(Evar_kinds.FirstOrderPatVar (Id.of_string id)) -let mkGRef r = CAst.make @@ GRef (Lazy.force r, None) +let mkGVar id = DAst.make @@ GVar (Id.of_string id) +let mkGPatVar id = DAst.make @@ GPatVar(Evar_kinds.FirstOrderPatVar (Id.of_string id)) +let mkGRef r = DAst.make @@ GRef (Lazy.force r, None) let mkGAppRef r args = mkGApp (mkGRef r) args (** forall x : _, _ x x *) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index aeb80ae57c..967ec2a71b 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -248,9 +248,9 @@ let add_inversion_lemma_exn na com comsort bool tac = let env = Global.env () in let evd = ref (Evd.from_env env) in let c = Constrintern.interp_type_evars env evd com in - let sigma, sort = Pretyping.interp_sort !evd comsort in + let evd, sort = Evd.fresh_sort_in_family ~rigid:univ_rigid env !evd comsort in try - add_inversion_lemma na env sigma c sort bool tac + add_inversion_lemma na env evd c sort bool tac with | UserError (Some "Case analysis",s) -> (* Reference to Indrec *) user_err ~hdr:"Inv needs Nodep Prop Set" s diff --git a/tactics/leminv.mli b/tactics/leminv.mli index 41b0e09b42..8745ad3979 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -15,5 +15,5 @@ val lemInv_clause : quantified_hypothesis -> constr -> Id.t list -> unit Proofview.tactic val add_inversion_lemma_exn : - Id.t -> constr_expr -> glob_sort -> bool -> (Id.t -> unit Proofview.tactic) -> + Id.t -> constr_expr -> Sorts.family -> bool -> (Id.t -> unit Proofview.tactic) -> unit diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 67bc55d3fe..32e366bc44 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -4131,7 +4131,7 @@ let guess_elim isrec dep s hyp0 gl = let env = Tacmach.New.pf_env gl in let sigma = Tacmach.New.project gl in let u = EInstance.kind (Tacmach.New.project gl) u in - if use_dependent_propositions_elimination () && dep + if use_dependent_propositions_elimination () && dep = Some true then let (sigma, ind) = build_case_analysis_scheme env sigma (mind, u) true s in let ind = EConstr.of_constr ind in @@ -4165,7 +4165,7 @@ let find_induction_type isrec elim hyp0 gl = | None -> let sort = Tacticals.New.elimination_sort_of_goal gl in let _, (elimc,elimt),_ = - guess_elim isrec (* dummy: *) true sort hyp0 gl in + guess_elim isrec None sort hyp0 gl in let scheme = compute_elim_sig sigma ~elimc elimt in (* We drop the scheme waiting to know if it is dependent *) scheme, ElimOver (isrec,hyp0) @@ -4199,7 +4199,7 @@ let get_eliminator elim dep s gl = | ElimUsing (elim,indsign) -> Tacmach.New.project gl, (* bugged, should be computed *) true, elim, indsign | ElimOver (isrec,id) -> - let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in + let evd, (elimc,elimt),_ as elims = guess_elim isrec (Some dep) s id gl in let _, (l, s) = compute_elim_signature elims id in let branchlengthes = List.map (fun d -> assert (RelDecl.is_local_assum d); pi1 (decompose_prod_letin (Tacmach.New.project gl) (RelDecl.get_type d))) (List.rev s.branches) diff --git a/test-suite/bugs/4623.v b/test-suite/bugs/4623.v index 405d09809c..7ecfd98b67 100644 --- a/test-suite/bugs/4623.v +++ b/test-suite/bugs/4623.v @@ -2,4 +2,4 @@ Goal Type -> Type. set (T := Type). clearbody T. refine (@id _). -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/4624.v b/test-suite/bugs/4624.v index a737afcdab..f5ce981cd0 100644 --- a/test-suite/bugs/4624.v +++ b/test-suite/bugs/4624.v @@ -4,4 +4,4 @@ Canonical Structure fooA (T : Type) := mkfoo (T -> T). Definition id (t : foo) (x : type t) := x. -Definition bar := id _ ((fun x : nat => x) : _).
\ No newline at end of file +Definition bar := id _ ((fun x : nat => x) : _). diff --git a/test-suite/bugs/closed/1425.v b/test-suite/bugs/closed/1425.v index 6be30174ae..775d278e74 100644 --- a/test-suite/bugs/closed/1425.v +++ b/test-suite/bugs/closed/1425.v @@ -16,4 +16,4 @@ Goal forall n : nat, recursion nat 0 (fun _ _ => 1) (S n) = 1. intro n. setoid_rewrite recursion_S. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/1738.v b/test-suite/bugs/closed/1738.v index c2926a2b25..ef52c876c1 100644 --- a/test-suite/bugs/closed/1738.v +++ b/test-suite/bugs/closed/1738.v @@ -27,4 +27,4 @@ Module Test (Import M:FSetInterface.S). rewrite H in H0. assumption. Qed. -End Test.
\ No newline at end of file +End Test. diff --git a/test-suite/bugs/closed/1900.v b/test-suite/bugs/closed/1900.v index cf03efda42..6eea5db083 100644 --- a/test-suite/bugs/closed/1900.v +++ b/test-suite/bugs/closed/1900.v @@ -5,4 +5,4 @@ Definition eq_A := @eq A. Goal forall x, eq_A x x. intros. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/1901.v b/test-suite/bugs/closed/1901.v index 7d86adbfb2..98e017f9d6 100644 --- a/test-suite/bugs/closed/1901.v +++ b/test-suite/bugs/closed/1901.v @@ -8,4 +8,4 @@ Record Poset{A:Type}(Le : relation A) : Type := Le_antisym : forall x y : A, Le x y -> Le y x -> x = y }. Definition nat_Poset : Poset Peano.le. -Admitted.
\ No newline at end of file +Admitted. diff --git a/test-suite/bugs/closed/1905.v b/test-suite/bugs/closed/1905.v index 8c81d7510b..3b8a3d2f68 100644 --- a/test-suite/bugs/closed/1905.v +++ b/test-suite/bugs/closed/1905.v @@ -10,4 +10,4 @@ Goal forall a s, Proof. intros a s Ia. rewrite InE in Ia. -Admitted.
\ No newline at end of file +Admitted. diff --git a/test-suite/bugs/closed/1915.v b/test-suite/bugs/closed/1915.v index 7e62437d7b..2b0aed8c7d 100644 --- a/test-suite/bugs/closed/1915.v +++ b/test-suite/bugs/closed/1915.v @@ -3,4 +3,4 @@ Require Import Setoid. Fail Goal forall x, impl True (x = 0) -> x = 0 -> False. (*intros x H E. -rewrite H in E.*)
\ No newline at end of file +rewrite H in E.*) diff --git a/test-suite/bugs/closed/1939.v b/test-suite/bugs/closed/1939.v index 5e61529b4b..7b430ace5e 100644 --- a/test-suite/bugs/closed/1939.v +++ b/test-suite/bugs/closed/1939.v @@ -16,4 +16,4 @@ Require Import Setoid Program.Basics. intros x y H1 H2. rewrite H1. auto. - Qed.
\ No newline at end of file + Qed. diff --git a/test-suite/bugs/closed/1962.v b/test-suite/bugs/closed/1962.v index a6b0fee584..37b0dde06d 100644 --- a/test-suite/bugs/closed/1962.v +++ b/test-suite/bugs/closed/1962.v @@ -52,4 +52,4 @@ unfold triple, couple. Time fsetdec. Qed. -End BuildFSets.
\ No newline at end of file +End BuildFSets. diff --git a/test-suite/bugs/closed/2027.v b/test-suite/bugs/closed/2027.v index fb53c6ef43..ebc2bc070c 100644 --- a/test-suite/bugs/closed/2027.v +++ b/test-suite/bugs/closed/2027.v @@ -8,4 +8,4 @@ Goal forall A (p : T A), P p. Proof. intros. rewrite <- f_id. -Admitted.
\ No newline at end of file +Admitted. diff --git a/test-suite/bugs/closed/2136.v b/test-suite/bugs/closed/2136.v index d2b926f379..2fcfbe40dc 100644 --- a/test-suite/bugs/closed/2136.v +++ b/test-suite/bugs/closed/2136.v @@ -58,4 +58,4 @@ fsetdec. (* Error: Tactic failure: because the goal is beyond the scope of this tactic. *) -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/2137.v b/test-suite/bugs/closed/2137.v index 6c2023ab7b..b1f54b1766 100644 --- a/test-suite/bugs/closed/2137.v +++ b/test-suite/bugs/closed/2137.v @@ -49,4 +49,4 @@ fsetdec. (* Error: Tactic failure: because the goal is beyond the scope of this tactic. *) -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/2141.v b/test-suite/bugs/closed/2141.v index c556ff0b2b..22e33c8e81 100644 --- a/test-suite/bugs/closed/2141.v +++ b/test-suite/bugs/closed/2141.v @@ -13,4 +13,4 @@ Module NatSet' := FSetHide NatSet. Recursive Extraction NatSet'.fold. Extraction TestCompile NatSet'.fold. -(* Extraction "test2141.ml" NatSet'.fold. *)
\ No newline at end of file +(* Extraction "test2141.ml" NatSet'.fold. *) diff --git a/test-suite/bugs/closed/2281.v b/test-suite/bugs/closed/2281.v index 40948d9059..8f549b9201 100644 --- a/test-suite/bugs/closed/2281.v +++ b/test-suite/bugs/closed/2281.v @@ -47,4 +47,4 @@ intros. fsetdec. (* Error: Tactic failure: because the goal is beyond the scope of this tactic. *) -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/2310.v b/test-suite/bugs/closed/2310.v index 7fae328715..14a3e5a7b0 100644 --- a/test-suite/bugs/closed/2310.v +++ b/test-suite/bugs/closed/2310.v @@ -18,4 +18,4 @@ Definition replace a (y:Nest (prod a a)) : a = a -> Nest a. Unset Solve Unification Constraints. (* Keep the unification constraint around *) refine (Cons (cast H _ y)). intros. - refine (Nest (prod X X)). Qed.
\ No newline at end of file + refine (Nest (prod X X)). Qed. diff --git a/test-suite/bugs/closed/2319.v b/test-suite/bugs/closed/2319.v index e06fb97590..73d95e91a1 100644 --- a/test-suite/bugs/closed/2319.v +++ b/test-suite/bugs/closed/2319.v @@ -10,4 +10,4 @@ Section S. with t : A unit := mkA unit (mkA unit t). Timeout 5 Eval vm_compute in s. -End S.
\ No newline at end of file +End S. diff --git a/test-suite/bugs/closed/2464.v b/test-suite/bugs/closed/2464.v index af70858720..b9db30359c 100644 --- a/test-suite/bugs/closed/2464.v +++ b/test-suite/bugs/closed/2464.v @@ -36,4 +36,4 @@ Lemma foo : forall (pu_type : Type) NameSetMod.Equal ns2 (NameSetMod.add (pu_nameOf p) ns). Proof. NameSetDec.fsetdec. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/2473.v b/test-suite/bugs/closed/2473.v index fb676c7e47..0e7c0c25fa 100644 --- a/test-suite/bugs/closed/2473.v +++ b/test-suite/bugs/closed/2473.v @@ -37,4 +37,4 @@ Section S3. rewrite <- H. (* ok *) admit. Qed. -End S3.
\ No newline at end of file +End S3. diff --git a/test-suite/bugs/closed/2584.v b/test-suite/bugs/closed/2584.v index a5f4ae64a0..ef2e4e3555 100644 --- a/test-suite/bugs/closed/2584.v +++ b/test-suite/bugs/closed/2584.v @@ -86,4 +86,4 @@ should be "Prop" or "Set". Elimination of an inductive object of sort Set is not allowed on a predicate in sort Type because strong elimination on non-small inductive types leads to paradoxes. -*)
\ No newline at end of file +*) diff --git a/test-suite/bugs/closed/2586.v b/test-suite/bugs/closed/2586.v index 7e02e7f110..e57bcc25bb 100644 --- a/test-suite/bugs/closed/2586.v +++ b/test-suite/bugs/closed/2586.v @@ -3,4 +3,4 @@ Require Import Setoid SetoidClass Program. Goal forall `(Setoid nat) x y, x == y -> S x == S y. intros. Fail clsubst H0. - Abort.
\ No newline at end of file + Abort. diff --git a/test-suite/bugs/closed/2602.v b/test-suite/bugs/closed/2602.v index f074478868..29c8ac16b2 100644 --- a/test-suite/bugs/closed/2602.v +++ b/test-suite/bugs/closed/2602.v @@ -5,4 +5,4 @@ match goal with match goal with | |- S a > 0 => idtac end -end.
\ No newline at end of file +end. diff --git a/test-suite/bugs/closed/2615.v b/test-suite/bugs/closed/2615.v index 38c1cfc848..26c0f334d0 100644 --- a/test-suite/bugs/closed/2615.v +++ b/test-suite/bugs/closed/2615.v @@ -14,4 +14,4 @@ refine (fun p => match p with _ => _ end). Undo. refine (fun p => match p with foo_intro _ _ => _ end). admit. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/2668.v b/test-suite/bugs/closed/2668.v index 74c8fa347b..d5bbfd3f08 100644 --- a/test-suite/bugs/closed/2668.v +++ b/test-suite/bugs/closed/2668.v @@ -3,4 +3,4 @@ Require Import MSetProperties. Module Pos := MSetPositive.PositiveSet. Module PPPP := MSetProperties.WPropertiesOn(Pos). -Print Module PPPP.
\ No newline at end of file +Print Module PPPP. diff --git a/test-suite/bugs/closed/2734.v b/test-suite/bugs/closed/2734.v index 826361be2b..3210214ea1 100644 --- a/test-suite/bugs/closed/2734.v +++ b/test-suite/bugs/closed/2734.v @@ -12,4 +12,4 @@ Inductive control := Go: expr -> control. Definition program := (Adr.t * (control))%type. -Fail Definition myprog : program := (Adr.nat2t 0, Go (Adr.nat2t 0) ).
\ No newline at end of file +Fail Definition myprog : program := (Adr.nat2t 0, Go (Adr.nat2t 0) ). diff --git a/test-suite/bugs/closed/2750.v b/test-suite/bugs/closed/2750.v index fc580f1018..9d65e51f63 100644 --- a/test-suite/bugs/closed/2750.v +++ b/test-suite/bugs/closed/2750.v @@ -20,4 +20,4 @@ Module Test_ModWithRecord (M : ModWithRecord). {| M.A := 0 ; M.B := 2 |}. -End Test_ModWithRecord.
\ No newline at end of file +End Test_ModWithRecord. diff --git a/test-suite/bugs/closed/2837.v b/test-suite/bugs/closed/2837.v index 5d98446395..52a56c2cff 100644 --- a/test-suite/bugs/closed/2837.v +++ b/test-suite/bugs/closed/2837.v @@ -12,4 +12,4 @@ Fail rewrite test. Fail (intros; rewrite test). (* III) a working variant: *) -intros; rewrite (test n m).
\ No newline at end of file +intros; rewrite (test n m). diff --git a/test-suite/bugs/closed/2848.v b/test-suite/bugs/closed/2848.v index 828e3b8c1f..e234630332 100644 --- a/test-suite/bugs/closed/2848.v +++ b/test-suite/bugs/closed/2848.v @@ -7,4 +7,4 @@ Add Parametric Relation : _ equiv' reflexivity proved by (Equivalence.equiv_reflexive cheat) transitivity proved by (Equivalence.equiv_transitive cheat) as apply_equiv'_rel. -Check apply_equiv'_rel : PreOrder equiv'.
\ No newline at end of file +Check apply_equiv'_rel : PreOrder equiv'. diff --git a/test-suite/bugs/closed/2955.v b/test-suite/bugs/closed/2955.v index 45e24b5f5c..11fd7bada7 100644 --- a/test-suite/bugs/closed/2955.v +++ b/test-suite/bugs/closed/2955.v @@ -49,4 +49,4 @@ Module E. assumption. Qed. -End E.
\ No newline at end of file +End E. diff --git a/test-suite/bugs/closed/2983.v b/test-suite/bugs/closed/2983.v index 15598352b1..ad76350949 100644 --- a/test-suite/bugs/closed/2983.v +++ b/test-suite/bugs/closed/2983.v @@ -5,4 +5,4 @@ End ModB. Module Foo(A : ModA)(B : ModB A). End Foo. -Print Module Foo.
\ No newline at end of file +Print Module Foo. diff --git a/test-suite/bugs/closed/2995.v b/test-suite/bugs/closed/2995.v index ba3acd088d..b6c5b6df44 100644 --- a/test-suite/bugs/closed/2995.v +++ b/test-suite/bugs/closed/2995.v @@ -6,4 +6,4 @@ Module Implementation <: Interface. Definition t := bool. Definition error: t := false. Fail End Implementation. -(* A UserError here is expected, not an uncaught Not_found *)
\ No newline at end of file +(* A UserError here is expected, not an uncaught Not_found *) diff --git a/test-suite/bugs/closed/3008.v b/test-suite/bugs/closed/3008.v index 3f3a979a35..1979eda820 100644 --- a/test-suite/bugs/closed/3008.v +++ b/test-suite/bugs/closed/3008.v @@ -26,4 +26,4 @@ Fail Module Toto (* NB : the Inductive above and the A=A weren't in the initial test, they are here only to force an access to the environment - (cf [Printer.qualid_of_global]) and check that this env is ok. *)
\ No newline at end of file + (cf [Printer.qualid_of_global]) and check that this env is ok. *) diff --git a/test-suite/bugs/closed/3319.v b/test-suite/bugs/closed/3319.v index 3b37e39e52..fbf5d86dcb 100644 --- a/test-suite/bugs/closed/3319.v +++ b/test-suite/bugs/closed/3319.v @@ -23,4 +23,4 @@ Section precategory. = morphism' xa yb. Proof. admit. - Defined.
\ No newline at end of file + Defined. diff --git a/test-suite/bugs/closed/3331.v b/test-suite/bugs/closed/3331.v index 9cd44bd0ca..b7dbb290e1 100644 --- a/test-suite/bugs/closed/3331.v +++ b/test-suite/bugs/closed/3331.v @@ -28,4 +28,4 @@ Section groupoid_category. clear H' foo. Set Typeclasses Debug. pose (_ : Contr (idpath = idpath :> (@paths (@paths X d d) idpath idpath))). -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/bugs/closed/3352.v b/test-suite/bugs/closed/3352.v index 555accfd51..bf2f7a9d19 100644 --- a/test-suite/bugs/closed/3352.v +++ b/test-suite/bugs/closed/3352.v @@ -32,4 +32,4 @@ simpl. Set Printing Universes. exact hprop_Empty. Defined. -End B.
\ No newline at end of file +End B. diff --git a/test-suite/bugs/closed/3387.v b/test-suite/bugs/closed/3387.v index cb435e7865..1d9e783374 100644 --- a/test-suite/bugs/closed/3387.v +++ b/test-suite/bugs/closed/3387.v @@ -19,4 +19,4 @@ Proof. first [ unify x y | fail 2 "no unify" ]; change x with y at -1. (* Error: Not convertible. *) reflexivity. -Defined.
\ No newline at end of file +Defined. diff --git a/test-suite/bugs/closed/3392.v b/test-suite/bugs/closed/3392.v index 3a59869546..a03db77544 100644 --- a/test-suite/bugs/closed/3392.v +++ b/test-suite/bugs/closed/3392.v @@ -37,4 +37,4 @@ Proof. rewrite eissect; apply apD ). -Defined.
\ No newline at end of file +Defined. diff --git a/test-suite/bugs/closed/3402.v b/test-suite/bugs/closed/3402.v index ed47ec8255..b4705780db 100644 --- a/test-suite/bugs/closed/3402.v +++ b/test-suite/bugs/closed/3402.v @@ -4,4 +4,4 @@ Goal forall A B (p : prod A B), p = let (x, y) := p in pair A B x y. Proof. intros A B p. exact eq_refl. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/3428.v b/test-suite/bugs/closed/3428.v index 3eb75e43ac..16ace90af3 100644 --- a/test-suite/bugs/closed/3428.v +++ b/test-suite/bugs/closed/3428.v @@ -32,4 +32,4 @@ z' : prod A B p : @paths A (foo.fst ?11 ?14 z) (foo.fst ?26 ?29 z') q : @paths ?54 (foo.snd ?42 ?45 z) (foo.snd ?57 ?60 z') The term "p" has type "@paths A (foo.fst ?11 ?14 z) (foo.fst ?26 ?29 z')" -while it is expected to have type "@paths A (foo.fst z) (foo.fst z')". *)
\ No newline at end of file +while it is expected to have type "@paths A (foo.fst z) (foo.fst z')". *) diff --git a/test-suite/bugs/closed/3439.v b/test-suite/bugs/closed/3439.v index 1ea24bf1b8..e8c2d8b8ca 100644 --- a/test-suite/bugs/closed/3439.v +++ b/test-suite/bugs/closed/3439.v @@ -41,4 +41,4 @@ Module prim. Undo. solve [ typeclasses eauto ]. (* Error: No applicable tactic. *) Defined. -End prim.
\ No newline at end of file +End prim. diff --git a/test-suite/bugs/closed/3441.v b/test-suite/bugs/closed/3441.v index 50d2978077..ddfb339443 100644 --- a/test-suite/bugs/closed/3441.v +++ b/test-suite/bugs/closed/3441.v @@ -20,4 +20,4 @@ Timeout 1 let H := fresh "H" in Timeout 1 Time let H := fresh "H" in let x := constr:(let n := 17 in do_n n = do_n n) in let y := (eval lazy in x) in - assert (H := y). (* Finished transaction in 1.19 secs (1.164u,0.024s) (successful) *)
\ No newline at end of file + assert (H := y). (* Finished transaction in 1.19 secs (1.164u,0.024s) (successful) *) diff --git a/test-suite/bugs/closed/3446.v b/test-suite/bugs/closed/3446.v index dce73e1a50..8a0c98c333 100644 --- a/test-suite/bugs/closed/3446.v +++ b/test-suite/bugs/closed/3446.v @@ -48,4 +48,4 @@ Instance isequiv_pr1_contr {A} {P : A -> Type} : IsEquiv (@pr1 A P) | 100. Admitted. Definition path_sigma_hprop {A : Type} {P : A -> Type} (u v : sigT P) : u.1 = v.1 -> u = v := - path_sigma_uncurried P u v o pr1^-1.
\ No newline at end of file + path_sigma_uncurried P u v o pr1^-1. diff --git a/test-suite/bugs/closed/3477.v b/test-suite/bugs/closed/3477.v index e941486472..3ed63604ea 100644 --- a/test-suite/bugs/closed/3477.v +++ b/test-suite/bugs/closed/3477.v @@ -6,4 +6,4 @@ Proof. intros A B. evar (a : prod A B); evar (f : (prod A B -> Set)). let a' := (eval unfold a in a) in - set(foo:=eq_refl : a' = (@pair _ _ (fst a') (snd a'))).
\ No newline at end of file + set(foo:=eq_refl : a' = (@pair _ _ (fst a') (snd a'))). diff --git a/test-suite/bugs/closed/3480.v b/test-suite/bugs/closed/3480.v index a81837e714..35e0c51a93 100644 --- a/test-suite/bugs/closed/3480.v +++ b/test-suite/bugs/closed/3480.v @@ -45,4 +45,4 @@ yb : object StrX x : xa <~=~> yb The term "morphism_isomorphic:@morphism (precategory_of_structures P) xa yb" has type "@morphism (precategory_of_structures P) xa yb" -while it is expected to have type "morphism ?40 ?41 ?42". *)
\ No newline at end of file +while it is expected to have type "morphism ?40 ?41 ?42". *) diff --git a/test-suite/bugs/closed/3482.v b/test-suite/bugs/closed/3482.v index 34a5e73da7..87fd2723c9 100644 --- a/test-suite/bugs/closed/3482.v +++ b/test-suite/bugs/closed/3482.v @@ -8,4 +8,4 @@ Check foo _. (* Toplevel input, characters 6-11: Error: Illegal application (Non-functional construction): The expression "foo" of type "True" cannot be applied to the term - "?36" : "?35" *)
\ No newline at end of file + "?36" : "?35" *) diff --git a/test-suite/bugs/closed/3484.v b/test-suite/bugs/closed/3484.v index dc88a332b4..a0e157303f 100644 --- a/test-suite/bugs/closed/3484.v +++ b/test-suite/bugs/closed/3484.v @@ -28,4 +28,4 @@ T : Type H : sigT T (fun g : T => paths g g) x : T Unable to unify "paths (@projT1 ?24 ?23 ?25) (@projT1 ?24 ?23 ?26)" with - "paths (projT1 H) (projT1 {| projT1 := x; projT2 := idpath |})". *)
\ No newline at end of file + "paths (projT1 H) (projT1 {| projT1 := x; projT2 := idpath |})". *) diff --git a/test-suite/bugs/closed/3513.v b/test-suite/bugs/closed/3513.v index 9ed0926a66..5adc48215e 100644 --- a/test-suite/bugs/closed/3513.v +++ b/test-suite/bugs/closed/3513.v @@ -91,4 +91,4 @@ Debug: 2.2.1.1.1.1: apply ILFun_ILogic on (ILogic OPred) Set Printing All. (* As in 8.5, allow a shelved subgoal to remain *) apply reflexivity. -
\ No newline at end of file + diff --git a/test-suite/bugs/closed/3531.v b/test-suite/bugs/closed/3531.v index 764a7334e8..3502b4f549 100644 --- a/test-suite/bugs/closed/3531.v +++ b/test-suite/bugs/closed/3531.v @@ -51,4 +51,4 @@ Goal forall b, (exists e1 e2 e3, admit. admit. Show Universes. -Time Qed.
\ No newline at end of file +Time Qed. diff --git a/test-suite/bugs/closed/3560.v b/test-suite/bugs/closed/3560.v index 65ce4fb6b0..a740675f30 100644 --- a/test-suite/bugs/closed/3560.v +++ b/test-suite/bugs/closed/3560.v @@ -12,4 +12,4 @@ Goal forall (A B : Type) (C : Type), Equiv (A -> B -> C) (A * B -> C). Proof. intros. exists (fun u => fun x => u (fst x) (snd x)). -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/bugs/closed/3561.v b/test-suite/bugs/closed/3561.v index f6cbc92992..ef4422eeac 100644 --- a/test-suite/bugs/closed/3561.v +++ b/test-suite/bugs/closed/3561.v @@ -21,4 +21,4 @@ Goal forall (H0 H2 : Type) x p, intros. match goal with | [ |- context[x (?f _)] ] => set(foo':=f) - end.
\ No newline at end of file + end. diff --git a/test-suite/bugs/closed/3567.v b/test-suite/bugs/closed/3567.v index cb16b3ae4a..00c9c05469 100644 --- a/test-suite/bugs/closed/3567.v +++ b/test-suite/bugs/closed/3567.v @@ -65,4 +65,4 @@ ap (path_prod_uncurried z0 z') which is ill-typed. Reason is: Pattern-matching expression on an object of inductive type prod has invalid information. - *)
\ No newline at end of file + *) diff --git a/test-suite/bugs/closed/3584.v b/test-suite/bugs/closed/3584.v index 3d4660b487..37fe46376e 100644 --- a/test-suite/bugs/closed/3584.v +++ b/test-suite/bugs/closed/3584.v @@ -13,4 +13,4 @@ Definition sum_of_sigT A B (x : sigT (fun b : bool => if b then A else B)) | existT _ false b => inr b end. (* Toplevel input, characters 0-182: Error: Pattern-matching expression on an object of inductive type sigT -has invalid information. *)
\ No newline at end of file +has invalid information. *) diff --git a/test-suite/bugs/closed/3590.v b/test-suite/bugs/closed/3590.v index 3ef9270d40..9fded85a8d 100644 --- a/test-suite/bugs/closed/3590.v +++ b/test-suite/bugs/closed/3590.v @@ -9,4 +9,4 @@ Qed. (* Toplevel input, characters 20-58: Error: Failed to get enough information from the left-hand side to type the -right-hand side. *)
\ No newline at end of file +right-hand side. *) diff --git a/test-suite/bugs/closed/3594.v b/test-suite/bugs/closed/3594.v index d1aae7b440..1f86f4bd70 100644 --- a/test-suite/bugs/closed/3594.v +++ b/test-suite/bugs/closed/3594.v @@ -48,4 +48,4 @@ while it is expected to have type object := opposite D; morphism := fun s d : opposite D => morphism (opposite D) d s |}" and "opposite D"). - *)
\ No newline at end of file + *) diff --git a/test-suite/bugs/closed/3596.v b/test-suite/bugs/closed/3596.v index 49dd7be5a8..1ee9a5d8c1 100644 --- a/test-suite/bugs/closed/3596.v +++ b/test-suite/bugs/closed/3596.v @@ -16,4 +16,4 @@ Goal forall f b, Bar b = Bar b -> Foo f = Foo f. Fail progress unfold Bar. (* success *) Fail progress unfold Foo. (* failed to progress *) reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/3618.v b/test-suite/bugs/closed/3618.v index dc560ad525..674b4cc2f4 100644 --- a/test-suite/bugs/closed/3618.v +++ b/test-suite/bugs/closed/3618.v @@ -100,4 +100,4 @@ Hint Mode IsEquiv - - + : typeclass_instances. Fail Definition equiv_O_rectnd {fs : Funext} {subU : ReflectiveSubuniverse} (P Q : Type) {Q_inO : inO_internal Q} -: IsEquiv (fun f : O P -> P => compose f (O_unit P)) := _.
\ No newline at end of file +: IsEquiv (fun f : O P -> P => compose f (O_unit P)) := _. diff --git a/test-suite/bugs/closed/3624.v b/test-suite/bugs/closed/3624.v index a05d5eb215..024243cfd3 100644 --- a/test-suite/bugs/closed/3624.v +++ b/test-suite/bugs/closed/3624.v @@ -8,4 +8,4 @@ Module Prim. Set Primitive Projections. Class foo (m : Set) := { pf : m = m }. Notation pf' m := (pf (m:=m)). (* Wrong argument name: m. *) -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3633.v b/test-suite/bugs/closed/3633.v index 6a952377ce..52bb307271 100644 --- a/test-suite/bugs/closed/3633.v +++ b/test-suite/bugs/closed/3633.v @@ -7,4 +7,4 @@ Proof. (* Ensure the constraints are solved independently, otherwise a frozen ?A makes a search for Contr ?A fail when finishing to apply (fun x => x) *) apply (fun x => x), center. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/3638.v b/test-suite/bugs/closed/3638.v index 70144174d7..5441fbedce 100644 --- a/test-suite/bugs/closed/3638.v +++ b/test-suite/bugs/closed/3638.v @@ -22,4 +22,4 @@ Goal forall (A B : Type) (x : O A * O B) (x0 : B), (* Toplevel input, characters 15-114: -Anomaly: Bad recursive type. Please report. *)
\ No newline at end of file +Anomaly: Bad recursive type. Please report. *) diff --git a/test-suite/bugs/closed/3640.v b/test-suite/bugs/closed/3640.v index bdbfbb152b..5dff98ba23 100644 --- a/test-suite/bugs/closed/3640.v +++ b/test-suite/bugs/closed/3640.v @@ -28,4 +28,4 @@ Proof. simpl in *. Fail match type of H with | _ = negb ?T => unify T (f.1 true); fail 1 "still has f.1 true" - end. (* Error: Tactic failure: still has f.1 true. *)
\ No newline at end of file + end. (* Error: Tactic failure: still has f.1 true. *) diff --git a/test-suite/bugs/closed/3641.v b/test-suite/bugs/closed/3641.v index f47f64ead7..730ab3f431 100644 --- a/test-suite/bugs/closed/3641.v +++ b/test-suite/bugs/closed/3641.v @@ -18,4 +18,4 @@ Goal forall (A B : Type) (x : O A * O B) (x0 : B), match goal with | [ |- context[?e] ] => is_evar e; let e' := fresh "e'" in pose (e' := e) end. - Fail change ?g with e'. (* Stack overflow *)
\ No newline at end of file + Fail change ?g with e'. (* Stack overflow *) diff --git a/test-suite/bugs/closed/3648.v b/test-suite/bugs/closed/3648.v index ba6006ed93..58aa161403 100644 --- a/test-suite/bugs/closed/3648.v +++ b/test-suite/bugs/closed/3648.v @@ -80,4 +80,4 @@ Error: Found no subterm matching "F _1 (identity (fst x))" in the current goal. *) rewrite identity_of. (* Toplevel input, characters 15-34: Error: -Found no subterm matching "morphism_of ?202 (identity ?203)" in the current goal. *)
\ No newline at end of file +Found no subterm matching "morphism_of ?202 (identity ?203)" in the current goal. *) diff --git a/test-suite/bugs/closed/3658.v b/test-suite/bugs/closed/3658.v index 622c3c94ac..74f4e82dbb 100644 --- a/test-suite/bugs/closed/3658.v +++ b/test-suite/bugs/closed/3658.v @@ -72,4 +72,4 @@ Module Prim. end. (* Error: Tactic failure: bad H1. *) admit. Defined. -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3661.v b/test-suite/bugs/closed/3661.v index fdca49bc42..1f13ffcf34 100644 --- a/test-suite/bugs/closed/3661.v +++ b/test-suite/bugs/closed/3661.v @@ -85,4 +85,4 @@ Goal forall (x3 x9 : PreCategory) (x12 f0 : Functor x9 x3) (@morphism_inverse _ _ _ (@morphism_isomorphic (functor_category x9 x3) f0 x12 x35) _) x37) -*)
\ No newline at end of file +*) diff --git a/test-suite/bugs/closed/3664.v b/test-suite/bugs/closed/3664.v index 63a81b6d01..cd1427a143 100644 --- a/test-suite/bugs/closed/3664.v +++ b/test-suite/bugs/closed/3664.v @@ -21,4 +21,4 @@ Module Prim. Fail progress cbn. (* [cbn] succeeds incorrectly, giving [d x] *) admit. Defined. -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3666.v b/test-suite/bugs/closed/3666.v index e69ec10976..c7bc2f22a8 100644 --- a/test-suite/bugs/closed/3666.v +++ b/test-suite/bugs/closed/3666.v @@ -48,4 +48,4 @@ H' : H_f a (h c) = H_g b (h c) Unable to unify "hproptype (H_f a (h c))" with "?T (H_f a (h c))". *) Defined. -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3668.v b/test-suite/bugs/closed/3668.v index da01ed00e4..1add3dba1e 100644 --- a/test-suite/bugs/closed/3668.v +++ b/test-suite/bugs/closed/3668.v @@ -51,4 +51,4 @@ Module Prim. end. (* Tactic failure: bad *) all:admit. Defined. -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3672.v b/test-suite/bugs/closed/3672.v index 283be49587..b355e7e9db 100644 --- a/test-suite/bugs/closed/3672.v +++ b/test-suite/bugs/closed/3672.v @@ -24,4 +24,4 @@ Record Ar3 C (A:AT) := ; id3 : forall X, ar3 X X }. (* The command has indeed failed with message: => Anomaly: Bad recursive type. Please report. -*)
\ No newline at end of file +*) diff --git a/test-suite/bugs/closed/3698.v b/test-suite/bugs/closed/3698.v index 31de8ec45b..3882eee97c 100644 --- a/test-suite/bugs/closed/3698.v +++ b/test-suite/bugs/closed/3698.v @@ -23,4 +23,4 @@ Proof. assert (H'' : forall g : X = Y -> (issig_hSet^-1 X).1 = (issig_hSet^-1 Y).1, g = g -> IsEquiv g) by admit. Eval compute in (@projT1 Type IsHSet (@equiv_inv _ _ _ (equiv_isequiv _ _ issig_hSet) X)). - Fail apply H''. (* stack overflow *)
\ No newline at end of file + Fail apply H''. (* stack overflow *) diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v index efa4325264..dbb10f94f2 100644 --- a/test-suite/bugs/closed/3699.v +++ b/test-suite/bugs/closed/3699.v @@ -156,4 +156,4 @@ Module Prim. | fail 1 "destruct should generate unfolded projections, as should [let], goal:" G ]. admit. Defined. -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3700.v b/test-suite/bugs/closed/3700.v index 4e226524cb..bac443e337 100644 --- a/test-suite/bugs/closed/3700.v +++ b/test-suite/bugs/closed/3700.v @@ -81,4 +81,4 @@ Goal (forall x : NonPrim.prod Set Set, match x with NonPrim.pair a b => a = a /\ and (@eq Set (@Prim.fst Set Set x) (@Prim.fst Set Set x)) (@eq Set (@Prim.snd Set Set x) (@Prim.snd Set Set x))) *) Unset Printing All. -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/bugs/closed/3703.v b/test-suite/bugs/closed/3703.v index 7282500769..feeb04d64e 100644 --- a/test-suite/bugs/closed/3703.v +++ b/test-suite/bugs/closed/3703.v @@ -29,4 +29,4 @@ Module Keyed. rewrite <- H'. admit. Defined. -End Keyed.
\ No newline at end of file +End Keyed. diff --git a/test-suite/bugs/closed/3732.v b/test-suite/bugs/closed/3732.v index 76beedf687..09f1149c20 100644 --- a/test-suite/bugs/closed/3732.v +++ b/test-suite/bugs/closed/3732.v @@ -102,4 +102,4 @@ cannot be applied to the terms "G0" : "list Type" The 2nd term has type "Type@{Top.53}" which should be coercible to "Type@{Top.12}". - *)
\ No newline at end of file + *) diff --git a/test-suite/bugs/closed/3735.v b/test-suite/bugs/closed/3735.v index a50572ace0..aced9615ee 100644 --- a/test-suite/bugs/closed/3735.v +++ b/test-suite/bugs/closed/3735.v @@ -1,4 +1,4 @@ Require Import Coq.Program.Tactics. Class Foo := { bar : Type }. Fail Lemma foo : Foo -> bar. (* 'Command has indeed failed.' in both 8.4 and trunk *) -Fail Program Lemma foo : Foo -> bar.
\ No newline at end of file +Fail Program Lemma foo : Foo -> bar. diff --git a/test-suite/bugs/closed/3743.v b/test-suite/bugs/closed/3743.v index c799d4393f..ca78987bf3 100644 --- a/test-suite/bugs/closed/3743.v +++ b/test-suite/bugs/closed/3743.v @@ -8,4 +8,4 @@ Add Parametric Relation A transitivity proved by transitivity as refine_rel. (* Toplevel input, characters 20-118: -Anomaly: index to an anonymous variable. Please report. *)
\ No newline at end of file +Anomaly: index to an anonymous variable. Please report. *) diff --git a/test-suite/bugs/closed/3753.v b/test-suite/bugs/closed/3753.v index 5bfbee9494..f586438cdd 100644 --- a/test-suite/bugs/closed/3753.v +++ b/test-suite/bugs/closed/3753.v @@ -1,4 +1,4 @@ Axiom foo : Type -> Type. Axiom bar : forall (T : Type), T -> foo T. Arguments bar A x : rename. -About bar.
\ No newline at end of file +About bar. diff --git a/test-suite/bugs/closed/3782.v b/test-suite/bugs/closed/3782.v index 2dc50c17d0..16b0b8b603 100644 --- a/test-suite/bugs/closed/3782.v +++ b/test-suite/bugs/closed/3782.v @@ -61,4 +61,4 @@ The term "e'" has type "@IsEquiv md mc e" while it is expected to have type *) admit. Defined. -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3783.v b/test-suite/bugs/closed/3783.v index e217129688..f7e2b54353 100644 --- a/test-suite/bugs/closed/3783.v +++ b/test-suite/bugs/closed/3783.v @@ -30,4 +30,4 @@ Module Prim. Timeout 1 cbv beta in y. (* takes around 2s. Grows with the value passed to [exp] above *) admit. Defined. -End Prim.
\ No newline at end of file +End Prim. diff --git a/test-suite/bugs/closed/3807.v b/test-suite/bugs/closed/3807.v index 108ebf592b..a6286f0377 100644 --- a/test-suite/bugs/closed/3807.v +++ b/test-suite/bugs/closed/3807.v @@ -30,4 +30,4 @@ Axiom f@{i} : Type@{i}. (* *** [ f@{i} : Type@{i} ] (* i |= *) -*)
\ No newline at end of file +*) diff --git a/test-suite/bugs/closed/3808.v b/test-suite/bugs/closed/3808.v index a5c84e6856..ac6a850193 100644 --- a/test-suite/bugs/closed/3808.v +++ b/test-suite/bugs/closed/3808.v @@ -1,3 +1,3 @@ Unset Strict Universe Declaration. Inductive Foo : (let enforce := (fun x => x) : Type@{j} -> Type@{i} in Type@{i}) - := foo : Foo.
\ No newline at end of file + := foo : Foo. diff --git a/test-suite/bugs/closed/3819.v b/test-suite/bugs/closed/3819.v index 355d23a58b..0b9c3183cc 100644 --- a/test-suite/bugs/closed/3819.v +++ b/test-suite/bugs/closed/3819.v @@ -6,4 +6,4 @@ Lemma test1 (X:Type) : eq (op OpType X) X. Proof eq_refl. Definition test2 (A:Type) : eq (op _ A) A. -Proof eq_refl.
\ No newline at end of file +Proof eq_refl. diff --git a/test-suite/bugs/closed/3881.v b/test-suite/bugs/closed/3881.v index bb6af6a66c..7c60ddf347 100644 --- a/test-suite/bugs/closed/3881.v +++ b/test-suite/bugs/closed/3881.v @@ -32,4 +32,4 @@ Proof. apply (@isequiv_homotopic _ _ ((g o f) o f^-1) g _ (fun b => ap g (eisretr f b))). Qed. -
\ No newline at end of file + diff --git a/test-suite/bugs/closed/3886.v b/test-suite/bugs/closed/3886.v index 2ac4abe54f..b523b117e5 100644 --- a/test-suite/bugs/closed/3886.v +++ b/test-suite/bugs/closed/3886.v @@ -20,4 +20,4 @@ Obligation 1 of doubleO. apply cheat. Qed. -Check doubleE.
\ No newline at end of file +Check doubleE. diff --git a/test-suite/bugs/closed/3899.v b/test-suite/bugs/closed/3899.v index e83166aaec..7754934c0b 100644 --- a/test-suite/bugs/closed/3899.v +++ b/test-suite/bugs/closed/3899.v @@ -8,4 +8,4 @@ Fail Check fun x y : unit => eq_refl : x = y. Record ok : Set := tt' { a : unit }. Record nonprim : Prop := { undef : unit }. -Record prim : Prop := { def : True }.
\ No newline at end of file +Record prim : Prop := { def : True }. diff --git a/test-suite/bugs/closed/3943.v b/test-suite/bugs/closed/3943.v index 5e5ba816f9..ac9c50369b 100644 --- a/test-suite/bugs/closed/3943.v +++ b/test-suite/bugs/closed/3943.v @@ -47,4 +47,4 @@ Definition path_isomorphic (i j : Isomorphic s d) Admitted. Definition ap_morphism_inverse_path_isomorphic (i j : Isomorphic s d) p q -: ap (fun e : Isomorphic s d => e^-1)%morphism (path_isomorphic i j p) = q.
\ No newline at end of file +: ap (fun e : Isomorphic s d => e^-1)%morphism (path_isomorphic i j p) = q. diff --git a/test-suite/bugs/closed/3956.v b/test-suite/bugs/closed/3956.v index 66dee702aa..4957cc740d 100644 --- a/test-suite/bugs/closed/3956.v +++ b/test-suite/bugs/closed/3956.v @@ -140,4 +140,4 @@ Module Comodality_Theory (F : Comodality). End cip_FPHM. End isequiv_F_prod_cmp_M. -End Comodality_Theory.
\ No newline at end of file +End Comodality_Theory. diff --git a/test-suite/bugs/closed/3960.v b/test-suite/bugs/closed/3960.v index e56dcef74f..3527312486 100644 --- a/test-suite/bugs/closed/3960.v +++ b/test-suite/bugs/closed/3960.v @@ -23,4 +23,4 @@ Class myClassP (A : Type) := Instance myInstanceP : myClassP nat := { barP := fooP - }.
\ No newline at end of file + }. diff --git a/test-suite/bugs/closed/3974.v b/test-suite/bugs/closed/3974.v index b6be159595..3d9e06b612 100644 --- a/test-suite/bugs/closed/3974.v +++ b/test-suite/bugs/closed/3974.v @@ -4,4 +4,4 @@ End S. Module Type M (X : S). Fail Module P (X : S). (* Used to say: Anomaly: X already exists. Please report. *) - (* Should rather say now: Error: X already exists. *)
\ No newline at end of file + (* Should rather say now: Error: X already exists. *) diff --git a/test-suite/bugs/closed/3975.v b/test-suite/bugs/closed/3975.v index 95851c8137..c7616b3ab6 100644 --- a/test-suite/bugs/closed/3975.v +++ b/test-suite/bugs/closed/3975.v @@ -5,4 +5,4 @@ Module M (X:S). End M. Module Type P (X : S). Print M. (* Used to say: Anomaly: X already exists. Please report. *) - (* Should rather : print something :-) *)
\ No newline at end of file + (* Should rather : print something :-) *) diff --git a/test-suite/bugs/closed/3998.v b/test-suite/bugs/closed/3998.v index ced13839dd..e17550e904 100644 --- a/test-suite/bugs/closed/3998.v +++ b/test-suite/bugs/closed/3998.v @@ -21,4 +21,4 @@ Axiom ex : RecordOf _ I1FieldType. Definition works := (fun ex' => update ex' C true) (update ex C false). Set Typeclasses Debug. -Definition doesnt := update (update ex C false) C true.
\ No newline at end of file +Definition doesnt := update (update ex C false) C true. diff --git a/test-suite/bugs/closed/4031.v b/test-suite/bugs/closed/4031.v index 2b8641ebb0..6c23baffa0 100644 --- a/test-suite/bugs/closed/4031.v +++ b/test-suite/bugs/closed/4031.v @@ -11,4 +11,4 @@ Proof. change mytt with (@something _ mytt) in x. subst x. (* Proof works if this line is removed *) reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4069.v b/test-suite/bugs/closed/4069.v index 61527764e2..606c6e0845 100644 --- a/test-suite/bugs/closed/4069.v +++ b/test-suite/bugs/closed/4069.v @@ -101,4 +101,4 @@ Variable T : Type. Goal @eq Type T T. congruence. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4095.v b/test-suite/bugs/closed/4095.v index ffd33d3813..8d7dfbd49b 100644 --- a/test-suite/bugs/closed/4095.v +++ b/test-suite/bugs/closed/4095.v @@ -84,4 +84,4 @@ O1 : T -> PointedOPred tr : T -> T O2 : PointedOPred x0 : T -H : forall x0 : T, catOP (O0 x0) (O1 (tr x0)) |-- O1 x0 *)
\ No newline at end of file +H : forall x0 : T, catOP (O0 x0) (O1 (tr x0)) |-- O1 x0 *) diff --git a/test-suite/bugs/closed/4097.v b/test-suite/bugs/closed/4097.v index 02aa25e09f..183b860d1f 100644 --- a/test-suite/bugs/closed/4097.v +++ b/test-suite/bugs/closed/4097.v @@ -62,4 +62,4 @@ Definition path_path_sigma {A : Type} (P : A -> Type) (u v : sigT P) (r : p..1 = q..1) (s : transport (fun x => transport P x u.2 = v.2) r p..2 = q..2) : p = q - := path_path_sigma_uncurried P u v p q (r; s).
\ No newline at end of file + := path_path_sigma_uncurried P u v p q (r; s). diff --git a/test-suite/bugs/closed/4101.v b/test-suite/bugs/closed/4101.v index a38b050966..75a26a0670 100644 --- a/test-suite/bugs/closed/4101.v +++ b/test-suite/bugs/closed/4101.v @@ -16,4 +16,4 @@ Lemma sigT_obj_eq Proof. intros. Set Debug Tactic Unification. - apply path_forall.
\ No newline at end of file + apply path_forall. diff --git a/test-suite/bugs/closed/4120.v b/test-suite/bugs/closed/4120.v index 00db8f7f3c..315dc0d242 100644 --- a/test-suite/bugs/closed/4120.v +++ b/test-suite/bugs/closed/4120.v @@ -2,4 +2,4 @@ Definition id {T} (x : T) := x. Goal sigT (fun x => id x)%type. change (fun x => ?f x) with f. exists Type. exact Set. -Defined. (* Error: Attempt to save a proof with shelved goals (in proof Unnamed_thm) *)
\ No newline at end of file +Defined. (* Error: Attempt to save a proof with shelved goals (in proof Unnamed_thm) *) diff --git a/test-suite/bugs/closed/4151.v b/test-suite/bugs/closed/4151.v index fec64555f4..fc0b58cfe1 100644 --- a/test-suite/bugs/closed/4151.v +++ b/test-suite/bugs/closed/4151.v @@ -400,4 +400,4 @@ Section sound. Undo. assumption. Undo. - eassumption. (* no applicable tactic *)
\ No newline at end of file + eassumption. (* no applicable tactic *) diff --git a/test-suite/bugs/closed/4161.v b/test-suite/bugs/closed/4161.v index aa2b189b67..d2003ab1f0 100644 --- a/test-suite/bugs/closed/4161.v +++ b/test-suite/bugs/closed/4161.v @@ -24,4 +24,4 @@ Inductive t : Type -> Type := Fixpoint test {A : Type} (x : t A) : t (A + unit) := match x in t A with | Just B x => @test B x - end.
\ No newline at end of file + end. diff --git a/test-suite/bugs/closed/4203.v b/test-suite/bugs/closed/4203.v index 076a3c3d68..eb6867a033 100644 --- a/test-suite/bugs/closed/4203.v +++ b/test-suite/bugs/closed/4203.v @@ -16,4 +16,4 @@ Definition t' := Eval vm_compute in constant_ok nat_ops nat_ops_ok. Definition t'' := Eval native_compute in constant_ok nat_ops nat_ops_ok. Check (eq_refl t : t = t'). -Check (eq_refl t : t = t'').
\ No newline at end of file +Check (eq_refl t : t = t''). diff --git a/test-suite/bugs/closed/4214.v b/test-suite/bugs/closed/4214.v index d684e8cf4b..2e620fce2a 100644 --- a/test-suite/bugs/closed/4214.v +++ b/test-suite/bugs/closed/4214.v @@ -3,4 +3,4 @@ Goal forall A (a b c : A), b = a -> b = c -> a = c. intros. subst. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4250.v b/test-suite/bugs/closed/4250.v index 74cacf559a..f5d0d1a523 100644 --- a/test-suite/bugs/closed/4250.v +++ b/test-suite/bugs/closed/4250.v @@ -8,4 +8,4 @@ Function f2 {A:Type} {n:nat} {v:Vector.t A n} : nat := n. (* fails with "The reference A was not found in the current environment." *) Function f3 `{n:nat , u:Vector.t A n} := u. -Check R_f3_complete.
\ No newline at end of file +Check R_f3_complete. diff --git a/test-suite/bugs/closed/4251.v b/test-suite/bugs/closed/4251.v index 66343d6671..f112e7b4d5 100644 --- a/test-suite/bugs/closed/4251.v +++ b/test-suite/bugs/closed/4251.v @@ -14,4 +14,4 @@ Check array Type. Check fun A : Type => Ref A. Definition abs_val (a : Type) := - bind (ref a) (fun r : array Type => array_make tt).
\ No newline at end of file + bind (ref a) (fun r : array Type => array_make tt). diff --git a/test-suite/bugs/closed/4273.v b/test-suite/bugs/closed/4273.v index 591ea4b5b2..401e86649b 100644 --- a/test-suite/bugs/closed/4273.v +++ b/test-suite/bugs/closed/4273.v @@ -6,4 +6,4 @@ Theorem onefiber' (q : total2 (fun y => y = 0)) : True. Proof. assert (foo:=pr2 _ q). simpl in foo. destruct foo. (* Error: q is used in conclusion. *) exact I. Qed. -Print onefiber'.
\ No newline at end of file +Print onefiber'. diff --git a/test-suite/bugs/closed/4276.v b/test-suite/bugs/closed/4276.v index ba82e6c376..ea9cbb210f 100644 --- a/test-suite/bugs/closed/4276.v +++ b/test-suite/bugs/closed/4276.v @@ -8,4 +8,4 @@ Definition bad' : True := mybox.(unwrap _ _). Fail Definition bad : False := unwrap _ _ mybox. -(* Closed under the global context *)
\ No newline at end of file +(* Closed under the global context *) diff --git a/test-suite/bugs/closed/4287.v b/test-suite/bugs/closed/4287.v index 43c9b51295..757b71b2dd 100644 --- a/test-suite/bugs/closed/4287.v +++ b/test-suite/bugs/closed/4287.v @@ -120,4 +120,4 @@ Definition setle (B : Type@{i}) := Fail Check @setlt@{j Prop}. Fail Definition foo := @setle@{j Prop}. Check setlt@{Set i}. -Check setlt@{Set j}.
\ No newline at end of file +Check setlt@{Set j}. diff --git a/test-suite/bugs/closed/4293.v b/test-suite/bugs/closed/4293.v index 3671c931b7..21d333fa63 100644 --- a/test-suite/bugs/closed/4293.v +++ b/test-suite/bugs/closed/4293.v @@ -4,4 +4,4 @@ End Foo. Module M : Foo. Definition T := let X := Type in Type. -End M.
\ No newline at end of file +End M. diff --git a/test-suite/bugs/closed/4299.v b/test-suite/bugs/closed/4299.v index 955c3017d7..a1daa193ae 100644 --- a/test-suite/bugs/closed/4299.v +++ b/test-suite/bugs/closed/4299.v @@ -9,4 +9,4 @@ End Foo. Module M : Foo with Definition U := Type : Type. Definition U := let X := Type in Type. Definition eq : Type = U := eq_refl. -Fail End M.
\ No newline at end of file +Fail End M. diff --git a/test-suite/bugs/closed/4306.v b/test-suite/bugs/closed/4306.v index 4aef5bb95e..28f028ad89 100644 --- a/test-suite/bugs/closed/4306.v +++ b/test-suite/bugs/closed/4306.v @@ -29,4 +29,4 @@ Function bar (xys : (list nat * list nat)) {measure (fun xys => length (fst xys) | Eq => x :: foo (xs', ys') | Gt => y :: foo (xs, ys') end - end.
\ No newline at end of file + end. diff --git a/test-suite/bugs/closed/4328.v b/test-suite/bugs/closed/4328.v index 8e1bb31007..b40b3a4830 100644 --- a/test-suite/bugs/closed/4328.v +++ b/test-suite/bugs/closed/4328.v @@ -3,4 +3,4 @@ Axiom pi : forall (P : Prop) (p : P), Prop. Definition test1 A (x : _) := pi A x. (* success *) Fail Definition test2 A (x : A) := pi A x. (* failure ??? *) Fail Definition test3 A (x : A) (_ : M A) := pi A x. (* failure *) -Fail Definition test4 A (_ : M A) (x : A) := pi A x. (* success ??? *)
\ No newline at end of file +Fail Definition test4 A (_ : M A) (x : A) := pi A x. (* success ??? *) diff --git a/test-suite/bugs/closed/4354.v b/test-suite/bugs/closed/4354.v index e71ddaf71f..c55b4cf02a 100644 --- a/test-suite/bugs/closed/4354.v +++ b/test-suite/bugs/closed/4354.v @@ -8,4 +8,4 @@ Proof. auto using closed_increment. Show Universes. Qed. (* also fails with -nois, so the content of the hint database does not matter -*)
\ No newline at end of file +*) diff --git a/test-suite/bugs/closed/4375.v b/test-suite/bugs/closed/4375.v index 71e3a75187..468bade1cc 100644 --- a/test-suite/bugs/closed/4375.v +++ b/test-suite/bugs/closed/4375.v @@ -104,4 +104,4 @@ with cb@{i} (t : Type@{i}) : foo@{i} t := Print ca. Print cb. -
\ No newline at end of file + diff --git a/test-suite/bugs/closed/4416.v b/test-suite/bugs/closed/4416.v index 3189685ec0..62b90b4286 100644 --- a/test-suite/bugs/closed/4416.v +++ b/test-suite/bugs/closed/4416.v @@ -1,4 +1,4 @@ Goal exists x, x. Unset Solve Unification Constraints. unshelve refine (ex_intro _ _ _); match goal with _ => refine (_ _) end. -(* Error: Incorrect number of goals (expected 2 tactics). *)
\ No newline at end of file +(* Error: Incorrect number of goals (expected 2 tactics). *) diff --git a/test-suite/bugs/closed/4433.v b/test-suite/bugs/closed/4433.v index 9eeb864689..83c0e3f81f 100644 --- a/test-suite/bugs/closed/4433.v +++ b/test-suite/bugs/closed/4433.v @@ -26,4 +26,4 @@ Proof. case proof_admitted. Unshelve. all:constructor. -Defined.
\ No newline at end of file +Defined. diff --git a/test-suite/bugs/closed/4443.v b/test-suite/bugs/closed/4443.v index 66dfa0e685..a3a8717d98 100644 --- a/test-suite/bugs/closed/4443.v +++ b/test-suite/bugs/closed/4443.v @@ -28,4 +28,4 @@ Defined. Set Printing Universes. Check PROD@{i i i}. Check PRODinj@{i j}. -Fail Check PRODinj@{j i}.
\ No newline at end of file +Fail Check PRODinj@{j i}. diff --git a/test-suite/bugs/closed/4450.v b/test-suite/bugs/closed/4450.v index ecebaba812..c1fe44315a 100644 --- a/test-suite/bugs/closed/4450.v +++ b/test-suite/bugs/closed/4450.v @@ -55,4 +55,4 @@ Proof. eauto using foo. Show Universes. Undo. eauto using foop. Show Proof. Show Universes. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4480.v b/test-suite/bugs/closed/4480.v index 08a86330f2..98c05ee1a8 100644 --- a/test-suite/bugs/closed/4480.v +++ b/test-suite/bugs/closed/4480.v @@ -9,4 +9,4 @@ Admitted. Goal True. Fail setoid_rewrite foo. Fail setoid_rewrite trueI. -
\ No newline at end of file + diff --git a/test-suite/bugs/closed/4498.v b/test-suite/bugs/closed/4498.v index ccdb2dddda..379e46b3e3 100644 --- a/test-suite/bugs/closed/4498.v +++ b/test-suite/bugs/closed/4498.v @@ -21,4 +21,4 @@ Require Export Coq.Setoids.Setoid. Add Parametric Morphism `{C : Category} {A B C} : (@compose _ A B C) with signature equiv ==> equiv ==> equiv as compose_mor. -Proof. apply comp_respects. Qed.
\ No newline at end of file +Proof. apply comp_respects. Qed. diff --git a/test-suite/bugs/closed/4503.v b/test-suite/bugs/closed/4503.v index f54d6433d8..5162f352df 100644 --- a/test-suite/bugs/closed/4503.v +++ b/test-suite/bugs/closed/4503.v @@ -34,4 +34,4 @@ Section Embed_ILogic_Pre. Polymorphic Universes A T. Fail Context {A : Type@{A}} {ILA: ILogic.ILogic@{A} A}. -End Embed_ILogic_Pre.
\ No newline at end of file +End Embed_ILogic_Pre. diff --git a/test-suite/bugs/closed/4519.v b/test-suite/bugs/closed/4519.v index ccbc47d20f..945183fae7 100644 --- a/test-suite/bugs/closed/4519.v +++ b/test-suite/bugs/closed/4519.v @@ -18,4 +18,4 @@ Check qux nat nat nat : Set. Check qux nat nat Set : Set. (* Error: The term "qux@{Top.50 Top.51} ?T ?T0 Set" has type "Type@{Top.50}" while it is expected to have type "Set" -(universe inconsistency: Cannot enforce Top.50 = Set because Set < Top.50). *)
\ No newline at end of file +(universe inconsistency: Cannot enforce Top.50 = Set because Set < Top.50). *) diff --git a/test-suite/bugs/closed/4603.v b/test-suite/bugs/closed/4603.v index e7567623a6..2c90044dc7 100644 --- a/test-suite/bugs/closed/4603.v +++ b/test-suite/bugs/closed/4603.v @@ -7,4 +7,4 @@ Abort. Goal True. Definition foo (A : Type) : Prop:= True. set (x:=foo). split. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4627.v b/test-suite/bugs/closed/4627.v index e1206bb37a..4f56e19584 100644 --- a/test-suite/bugs/closed/4627.v +++ b/test-suite/bugs/closed/4627.v @@ -46,4 +46,4 @@ The term "predicate nat (Build_sa nat)" has type while it is expected to have type "Type@{Top.208}" (universe inconsistency: Cannot enforce Top.205 <= Top.208 because Top.208 < Top.205). -*)
\ No newline at end of file +*) diff --git a/test-suite/bugs/closed/4679.v b/test-suite/bugs/closed/4679.v index c94fa31a9d..3f41c5d6b1 100644 --- a/test-suite/bugs/closed/4679.v +++ b/test-suite/bugs/closed/4679.v @@ -15,4 +15,4 @@ Proof. Undo. setoid_rewrite H. (* Error: Tactic failure: setoid rewrite failed: Nothing to rewrite. *) reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4723.v b/test-suite/bugs/closed/4723.v index 8884812102..5fb9696f3f 100644 --- a/test-suite/bugs/closed/4723.v +++ b/test-suite/bugs/closed/4723.v @@ -25,4 +25,4 @@ Program Fact kp_assoc (x: Matrix xr xc) (y: Matrix yr yc) (z: Matrix zr zc): kp x (kp y z) = kp (kp x y) z. admit. -Admitted.
\ No newline at end of file +Admitted. diff --git a/test-suite/bugs/closed/4754.v b/test-suite/bugs/closed/4754.v index 5bb3cd1be7..67d645a68f 100644 --- a/test-suite/bugs/closed/4754.v +++ b/test-suite/bugs/closed/4754.v @@ -32,4 +32,4 @@ Proof. pose proof (_ : (Proper (_ ==> eq ==> _) and)). setoid_rewrite (FG _ _); [ | reflexivity.. ]. Undo. - setoid_rewrite (FG _ eq_refl). (* Error: Tactic failure: setoid rewrite failed: Nothing to rewrite. in 8.5 *) Admitted.
\ No newline at end of file + setoid_rewrite (FG _ eq_refl). (* Error: Tactic failure: setoid rewrite failed: Nothing to rewrite. in 8.5 *) Admitted. diff --git a/test-suite/bugs/closed/4763.v b/test-suite/bugs/closed/4763.v index ae8ed0e6e8..9613b5c248 100644 --- a/test-suite/bugs/closed/4763.v +++ b/test-suite/bugs/closed/4763.v @@ -10,4 +10,4 @@ Goal forall x y z, leb x y -> leb y z -> True. => pose proof (transitivity H H' : is_true (R x z)) end. exact I. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4769.v b/test-suite/bugs/closed/4769.v index 33a1d1a50b..f0c91f7b49 100644 --- a/test-suite/bugs/closed/4769.v +++ b/test-suite/bugs/closed/4769.v @@ -91,4 +91,4 @@ Section Adjunction. (oppositeC C) D C (identityF (oppositeC C)) G)) }. -End Adjunction.
\ No newline at end of file +End Adjunction. diff --git a/test-suite/bugs/closed/4869.v b/test-suite/bugs/closed/4869.v index 6d21b66fe9..ac5d7ea287 100644 --- a/test-suite/bugs/closed/4869.v +++ b/test-suite/bugs/closed/4869.v @@ -15,4 +15,4 @@ Section Foo. Constraint Set < j. Definition foo := Type@{j}. -End Foo.
\ No newline at end of file +End Foo. diff --git a/test-suite/bugs/closed/4873.v b/test-suite/bugs/closed/4873.v index f2f917b4e7..3be36d8475 100644 --- a/test-suite/bugs/closed/4873.v +++ b/test-suite/bugs/closed/4873.v @@ -69,4 +69,4 @@ Proof. destruct xs; simpl; intros; subst; auto. generalize dependent t. simpl in *. induction xs; simpl in *; intros; congruence. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/4877.v b/test-suite/bugs/closed/4877.v index 7e3c78dc2e..7d153d9828 100644 --- a/test-suite/bugs/closed/4877.v +++ b/test-suite/bugs/closed/4877.v @@ -9,4 +9,4 @@ Ltac induction_last := Goal forall n m : nat, True -> n = m -> m = n. induction_last. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/5036.v b/test-suite/bugs/closed/5036.v index 12c958be67..83f1677455 100644 --- a/test-suite/bugs/closed/5036.v +++ b/test-suite/bugs/closed/5036.v @@ -7,4 +7,4 @@ Section foo. autorewrite with core. constructor. Qed. -End foo. (* Anomaly: Universe Top.16 undefined. Please report. *)
\ No newline at end of file +End foo. (* Anomaly: Universe Top.16 undefined. Please report. *) diff --git a/test-suite/bugs/closed/5065.v b/test-suite/bugs/closed/5065.v index 6bd677ba6f..932fee8b3b 100644 --- a/test-suite/bugs/closed/5065.v +++ b/test-suite/bugs/closed/5065.v @@ -3,4 +3,4 @@ Inductive foo := C1 : bar -> foo with bar := C2 : foo -> bar. Lemma L1 : foo -> True with L2 : bar -> True. intros; clear L1 L2; abstract (exact I). intros; exact I. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/bugs/closed/5123.v b/test-suite/bugs/closed/5123.v index bcde510ee6..17231bffcf 100644 --- a/test-suite/bugs/closed/5123.v +++ b/test-suite/bugs/closed/5123.v @@ -30,4 +30,4 @@ Goal True. all:cycle 3. eapply existT. (*This does no typeclass resultion, which is correct.*) Focus 5. -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/bugs/closed/5180.v b/test-suite/bugs/closed/5180.v index 261092ee6d..05603a048c 100644 --- a/test-suite/bugs/closed/5180.v +++ b/test-suite/bugs/closed/5180.v @@ -61,4 +61,4 @@ The term "x" has type "TypeOfTypei' (Typei 0)" while it is expected to have type "TypeOfTypei' (Typei 1)" (universe inconsistency: Cannot enforce b = a because a < b). *) all:compute in *. - all:exact x.
\ No newline at end of file + all:exact x. diff --git a/test-suite/bugs/closed/5203.v b/test-suite/bugs/closed/5203.v index ed137395fc..3428e1a450 100644 --- a/test-suite/bugs/closed/5203.v +++ b/test-suite/bugs/closed/5203.v @@ -2,4 +2,4 @@ Goal True. Typeclasses eauto := debug. Fail solve [ typeclasses eauto ]. Fail typeclasses eauto. -
\ No newline at end of file + diff --git a/test-suite/bugs/closed/5315.v b/test-suite/bugs/closed/5315.v index f1f1b8c051..d8824bff87 100644 --- a/test-suite/bugs/closed/5315.v +++ b/test-suite/bugs/closed/5315.v @@ -7,4 +7,4 @@ Function dumb_nope (a:nat) {struct a} := match (id (fun x => x)) a with O => O | S n' => dumb_nope n' end. (* This check is just present to ensure Function worked well *) -Check R_dumb_nope_complete.
\ No newline at end of file +Check R_dumb_nope_complete. diff --git a/test-suite/bugs/closed/5434.v b/test-suite/bugs/closed/5434.v new file mode 100644 index 0000000000..5d2460face --- /dev/null +++ b/test-suite/bugs/closed/5434.v @@ -0,0 +1,18 @@ +(* About binders which remain unnamed after typing *) + +Global Set Asymmetric Patterns. + +Definition proj2_sig_map {A} {P Q : A -> Prop} (f : forall a, P a -> Q a) (x : +@sig A P) : @sig A Q + := let 'exist a p := x in exist Q a (f a p). +Axioms (feBW' : Type) (g : Prop -> Prop) (f' : feBW' -> Prop). +Definition foo := @proj2_sig_map feBW' (fun H => True = f' _) (fun H => + g True = g (f' H)) + (fun (a : feBW') (p : (fun H : feBW' => True = + f' H) a) => @f_equal Prop Prop g True (f' a) p). +Print foo. +Goal True. + lazymatch type of foo with + | sig (fun a : ?A => ?P) -> _ + => pose (fun a : A => a = a /\ P = P) + end. diff --git a/test-suite/bugs/closed/5578.v b/test-suite/bugs/closed/5578.v index 5bcdaa2f18..b9f0bc45c6 100644 --- a/test-suite/bugs/closed/5578.v +++ b/test-suite/bugs/closed/5578.v @@ -54,4 +54,4 @@ Goal forall (Rat : Set) (PositiveMap_t : Set -> Set) f eta ( (Bind (k eta) (fun rands => ret_bool (interp_term_fixed_t_x eta (adv' eta) rands ?= interp_term_fixed_t_x eta (adv' eta) rands)))))). - (* Error: Anomaly "Signature and its instance do not match." Please report at http://coq.inria.fr/bugs/. *)
\ No newline at end of file + (* Error: Anomaly "Signature and its instance do not match." Please report at http://coq.inria.fr/bugs/. *) diff --git a/test-suite/bugs/closed/5618.v b/test-suite/bugs/closed/5618.v index ab88a88f44..47e0e92d2a 100644 --- a/test-suite/bugs/closed/5618.v +++ b/test-suite/bugs/closed/5618.v @@ -6,4 +6,4 @@ Function test {T} (v : T) (x : nat) : nat := | S x' => test v x' end. -Check R_test_complete.
\ No newline at end of file +Check R_test_complete. diff --git a/test-suite/bugs/closed/5707.v b/test-suite/bugs/closed/5707.v new file mode 100644 index 0000000000..785844c66d --- /dev/null +++ b/test-suite/bugs/closed/5707.v @@ -0,0 +1,12 @@ +(* Destruct and primitive projections *) + +(* Checking the (superficial) part of #5707: + "destruct" should be able to use non-dependent case analysis when + dependent case analysis is not available and unneeded *) + +Set Primitive Projections. + +Inductive foo := Foo { proj1 : nat; proj2 : nat }. + +Goal forall x : foo, True. +Proof. intros x. destruct x. diff --git a/test-suite/bugs/closed/5713.v b/test-suite/bugs/closed/5713.v new file mode 100644 index 0000000000..9daf9647fc --- /dev/null +++ b/test-suite/bugs/closed/5713.v @@ -0,0 +1,15 @@ +(* Checking that classical_right/classical_left work in an empty context *) + +Require Import Classical. + +Parameter A:Prop. + +Goal A \/ ~A. +classical_right. +assumption. +Qed. + +Goal ~A \/ A. +classical_left. +assumption. +Qed. diff --git a/test-suite/bugs/closed/808_2411.v b/test-suite/bugs/closed/808_2411.v index 1c13e74547..1169b2036b 100644 --- a/test-suite/bugs/closed/808_2411.v +++ b/test-suite/bugs/closed/808_2411.v @@ -24,4 +24,4 @@ rewrite bar'. now apply le_S. Qed. -End test.
\ No newline at end of file +End test. diff --git a/test-suite/bugs/closed/HoTT_coq_014.v b/test-suite/bugs/closed/HoTT_coq_014.v index 223a98de1c..5c45036643 100644 --- a/test-suite/bugs/closed/HoTT_coq_014.v +++ b/test-suite/bugs/closed/HoTT_coq_014.v @@ -199,4 +199,4 @@ Fail Admitted. Polymorphic Definition UnderlyingGraphFunctor_MorphismOf (C D : SmallCategory) (F : SpecializedFunctor C D) : Morphism (FunctorCategory GraphIndexingCategory TypeCat) (UnderlyingGraph C) (UnderlyingGraph D). (* Anomaly: apply_coercion. Please report.*) Proof. -Admitted.
\ No newline at end of file +Admitted. diff --git a/test-suite/bugs/closed/HoTT_coq_080.v b/test-suite/bugs/closed/HoTT_coq_080.v index 6b07c30404..a9e0bd2676 100644 --- a/test-suite/bugs/closed/HoTT_coq_080.v +++ b/test-suite/bugs/closed/HoTT_coq_080.v @@ -24,4 +24,4 @@ Goal forall C D (x y : ob (sum_category C D)), Type. intros C D x y. hnf in x, y. exact (hom (sum_category _ _) x y). -Defined.
\ No newline at end of file +Defined. diff --git a/test-suite/bugs/opened/1596.v b/test-suite/bugs/opened/1596.v index 7c5dc41679..0b576db6b3 100644 --- a/test-suite/bugs/opened/1596.v +++ b/test-suite/bugs/opened/1596.v @@ -258,4 +258,4 @@ n). apply SynInc;apply H.mem_2;trivial. rewrite H in H0. discriminate. (* !! impossible here !! *) Qed. -End B.
\ No newline at end of file +End B. diff --git a/test-suite/bugs/opened/1811.v b/test-suite/bugs/opened/1811.v index 10c988fc02..57c1744313 100644 --- a/test-suite/bugs/opened/1811.v +++ b/test-suite/bugs/opened/1811.v @@ -7,4 +7,4 @@ Goal forall b1 b2, (negb b1 = b2) -> xorb true b1 = b2. Proof. intros b1 b2. Fail rewrite neg2xor. -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/bugs/opened/3794.v b/test-suite/bugs/opened/3794.v index 99ca6cb39d..e4711a38c0 100644 --- a/test-suite/bugs/opened/3794.v +++ b/test-suite/bugs/opened/3794.v @@ -4,4 +4,4 @@ Hint Unfold not : core. Goal true<>false. Set Typeclasses Debug. Fail typeclasses eauto with core. -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/bugs/opened/3948.v b/test-suite/bugs/opened/3948.v index 165813084d..5c4b4277b2 100644 --- a/test-suite/bugs/opened/3948.v +++ b/test-suite/bugs/opened/3948.v @@ -22,4 +22,4 @@ Module DepMap : Interface. let _ := @Dom.fold in tt. End DepMap. -Print Assumptions DepMap.constant.
\ No newline at end of file +Print Assumptions DepMap.constant. diff --git a/test-suite/coq-makefile/findlib-package/findlib/foo/Makefile b/test-suite/coq-makefile/findlib-package/findlib/foo/Makefile index 31cf116652..1615bfd067 100644 --- a/test-suite/coq-makefile/findlib-package/findlib/foo/Makefile +++ b/test-suite/coq-makefile/findlib-package/findlib/foo/Makefile @@ -1,7 +1,7 @@ -include ../../Makefile.conf -CO=$(COQMF_OCAMLFIND) opt -CB=$(COQMF_OCAMLFIND) ocamlc +CO="$(COQMF_OCAMLFIND)" opt +CB="$(COQMF_OCAMLFIND)" ocamlc all: $(CO) -c foolib.ml diff --git a/test-suite/coq-makefile/findlib-package/run.sh b/test-suite/coq-makefile/findlib-package/run.sh index a0d8a7fea7..5b24df6397 100755 --- a/test-suite/coq-makefile/findlib-package/run.sh +++ b/test-suite/coq-makefile/findlib-package/run.sh @@ -4,6 +4,11 @@ echo "let () = Foolib.foo ();;" >> src/test_aux.ml export OCAMLPATH=$OCAMLPATH:$PWD/findlib +if which cygpath 2>/dev/null; then + # the only way I found to pass OCAMLPATH on win is to have it contain + # only one entry + export OCAMLPATH=`cygpath -w $PWD/findlib` +fi make -C findlib/foo clean coq_makefile -f _CoqProject -o Makefile cat Makefile.conf diff --git a/test-suite/coqchk/cumulativity.v b/test-suite/coqchk/cumulativity.v index 7906a5b15e..d63a3548e5 100644 --- a/test-suite/coqchk/cumulativity.v +++ b/test-suite/coqchk/cumulativity.v @@ -64,4 +64,4 @@ I disable these tests because cqochk can't process them when compiled with (* Inductive TP2 := tp2 : Type@{i} -> Type@{j} -> TP2. *) -(* End subtyping_test. *)
\ No newline at end of file +(* End subtyping_test. *) diff --git a/test-suite/coqdoc/bug5700.html.out b/test-suite/coqdoc/bug5700.html.out new file mode 100644 index 0000000000..0e05660d6c --- /dev/null +++ b/test-suite/coqdoc/bug5700.html.out @@ -0,0 +1,50 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" +"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" /> +<link href="coqdoc.css" rel="stylesheet" type="text/css" /> +<title>Coqdoc.bug5700</title> +</head> + +<body> + +<div id="page"> + +<div id="header"> +</div> + +<div id="main"> + +<h1 class="libtitle">Library Coqdoc.bug5700</h1> + +<div class="code"> +</div> + +<div class="doc"> +<pre>foo (* bar *) </pre> + +</div> +<div class="code"> +<span class="id" title="keyword">Definition</span> <a name="const1"><span class="id" title="definition">const1</span></a> := 1.<br/> + +<br/> +</div> + +<div class="doc"> +<pre>more (* nested (* comments *) within verbatim *) </pre> + +</div> +<div class="code"> +<span class="id" title="keyword">Definition</span> <a name="const2"><span class="id" title="definition">const2</span></a> := 2.<br/> +</div> +</div> + +<div id="footer"> +<hr/><a href="index.html">Index</a><hr/>This page has been generated by <a href="http://coq.inria.fr/">coqdoc</a> +</div> + +</div> + +</body> +</html>
\ No newline at end of file diff --git a/test-suite/coqdoc/bug5700.tex.out b/test-suite/coqdoc/bug5700.tex.out new file mode 100644 index 0000000000..33990cb89f --- /dev/null +++ b/test-suite/coqdoc/bug5700.tex.out @@ -0,0 +1,24 @@ +\documentclass[12pt]{report} +\usepackage[]{inputenc} +\usepackage[T1]{fontenc} +\usepackage{fullpage} +\usepackage{coqdoc} +\usepackage{amsmath,amssymb} +\usepackage{url} +\begin{document} +\coqlibrary{Coqdoc.bug5700}{Library }{Coqdoc.bug5700} + +\begin{coqdoccode} +\end{coqdoccode} +\begin{verbatim}foo (* bar *) \end{verbatim} + \begin{coqdoccode} +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.bug5700.const1}{const1}{\coqdocdefinition{const1}} := 1.\coqdoceol +\coqdocemptyline +\end{coqdoccode} +\begin{verbatim}more (* nested (* comments *) within verbatim *) \end{verbatim} + \begin{coqdoccode} +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.bug5700.const2}{const2}{\coqdocdefinition{const2}} := 2.\coqdoceol +\end{coqdoccode} +\end{document} diff --git a/test-suite/coqdoc/bug5700.v b/test-suite/coqdoc/bug5700.v new file mode 100644 index 0000000000..839034a48f --- /dev/null +++ b/test-suite/coqdoc/bug5700.v @@ -0,0 +1,5 @@ +(** << foo (* bar *) >> *) +Definition const1 := 1. + +(** << more (* nested (* comments *) within verbatim *) >> *) +Definition const2 := 2. diff --git a/test-suite/failure/circular_subtyping.v b/test-suite/failure/circular_subtyping.v index ceccd4607d..9eb7e3bc20 100644 --- a/test-suite/failure/circular_subtyping.v +++ b/test-suite/failure/circular_subtyping.v @@ -7,4 +7,4 @@ Module NN <: T. Module M:=N. End NN. Fail Module P <: T with Module M:=NN := NN. Module F (X:S) (Y:T with Module M:=X). End F. -Fail Module G := F N N.
\ No newline at end of file +Fail Module G := F N N. diff --git a/test-suite/failure/cofixpoint.v b/test-suite/failure/cofixpoint.v index cb39893f47..d193dc484f 100644 --- a/test-suite/failure/cofixpoint.v +++ b/test-suite/failure/cofixpoint.v @@ -12,4 +12,4 @@ Fail CoFixpoint loop : CoFalse := (cofix f := I with g := loop for g). Fail CoFixpoint loop : CoFalse := - (cofix f := loop with g := I for f).
\ No newline at end of file + (cofix f := loop with g := I for f). diff --git a/test-suite/failure/guard-cofix.v b/test-suite/failure/guard-cofix.v index eda4a18673..3ae8770546 100644 --- a/test-suite/failure/guard-cofix.v +++ b/test-suite/failure/guard-cofix.v @@ -40,4 +40,4 @@ Fail CoFixpoint loop' : CoFalse := Omega match eq_sym H in _ = T return T with eq_refl => loop' end end. -Fail Definition ff' : False := match loop' with CF _ t => t end.
\ No newline at end of file +Fail Definition ff' : False := match loop' with CF _ t => t end. diff --git a/test-suite/failure/sortelim.v b/test-suite/failure/sortelim.v index 2b3cf10660..3d2eef6a98 100644 --- a/test-suite/failure/sortelim.v +++ b/test-suite/failure/sortelim.v @@ -146,4 +146,4 @@ Qed. Print Assumptions pandora. -*)
\ No newline at end of file +*) diff --git a/test-suite/ideal-features/implicit_binders.v b/test-suite/ideal-features/implicit_binders.v index 2ec7278080..d75620c257 100644 --- a/test-suite/ideal-features/implicit_binders.v +++ b/test-suite/ideal-features/implicit_binders.v @@ -121,4 +121,4 @@ Definition qux₁ {( F : `(SomeStruct a) )} : nat := 0. (** *** Questions - Autres propositions de syntaxe ? - Réactions sur la construction ? - *)
\ No newline at end of file + *) diff --git a/test-suite/interactive/ParalITP.v b/test-suite/interactive/ParalITP.v index a96d4a5c7f..7fab2a58e8 100644 --- a/test-suite/interactive/ParalITP.v +++ b/test-suite/interactive/ParalITP.v @@ -44,4 +44,4 @@ split. exact a. Qed. -End Demo.
\ No newline at end of file +End Demo. diff --git a/test-suite/interactive/proof_block.v b/test-suite/interactive/proof_block.v index 31e3493768..a865632e8c 100644 --- a/test-suite/interactive/proof_block.v +++ b/test-suite/interactive/proof_block.v @@ -63,4 +63,4 @@ split. split. split. - solve [ trivial ]. - solve [ trivial ]. - exact 6. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/modules/Demo.v b/test-suite/modules/Demo.v index 1f27fe1ba1..820fda172a 100644 --- a/test-suite/modules/Demo.v +++ b/test-suite/modules/Demo.v @@ -52,4 +52,4 @@ Print N'''.x. Import N'''. -Print t.
\ No newline at end of file +Print t. diff --git a/test-suite/modules/Nat.v b/test-suite/modules/Nat.v index 57878a5f15..d2116d2183 100644 --- a/test-suite/modules/Nat.v +++ b/test-suite/modules/Nat.v @@ -16,4 +16,4 @@ Qed. Lemma le_antis : forall n m : nat, le n m -> le m n -> n = m. eauto with arith. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/modules/PO.v b/test-suite/modules/PO.v index 6198f29a0d..8ba8525c66 100644 --- a/test-suite/modules/PO.v +++ b/test-suite/modules/PO.v @@ -54,4 +54,4 @@ Module NN := Pair Nat Nat. Lemma zz_min : forall p : NN.T, NN.le (0, 0) p. info auto with arith. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/modules/Tescik.v b/test-suite/modules/Tescik.v index 1d1b1e0ab2..ea49553942 100644 --- a/test-suite/modules/Tescik.v +++ b/test-suite/modules/Tescik.v @@ -27,4 +27,4 @@ Module List (X: ELEM). End List. -Module N := List Nat.
\ No newline at end of file +Module N := List Nat. diff --git a/test-suite/modules/grammar.v b/test-suite/modules/grammar.v index 9657c685d0..11ad205e40 100644 --- a/test-suite/modules/grammar.v +++ b/test-suite/modules/grammar.v @@ -12,4 +12,4 @@ Check (f 0 0). Check (f 0 0). Import M. Check (f 0 0). -Check (N.f 0 0).
\ No newline at end of file +Check (N.f 0 0). diff --git a/test-suite/modules/injection_discriminate_inversion.v b/test-suite/modules/injection_discriminate_inversion.v index d4ac7b3a24..8b5969dd76 100644 --- a/test-suite/modules/injection_discriminate_inversion.v +++ b/test-suite/modules/injection_discriminate_inversion.v @@ -31,4 +31,4 @@ Goal forall x, M.C x = M1.C 0 -> x = 0. par des modules differents *) inversion H. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/modules/modeq.v b/test-suite/modules/modeq.v index 1238ee9deb..c8129eec5e 100644 --- a/test-suite/modules/modeq.v +++ b/test-suite/modules/modeq.v @@ -19,4 +19,4 @@ Module Z. Module N := M. End Z. -Module A : SIG := Z.
\ No newline at end of file +Module A : SIG := Z. diff --git a/test-suite/modules/pliczek.v b/test-suite/modules/pliczek.v index f806a7c412..51f5f40078 100644 --- a/test-suite/modules/pliczek.v +++ b/test-suite/modules/pliczek.v @@ -1,3 +1,3 @@ Require Export plik. -Definition tutu (X : Set) := toto X.
\ No newline at end of file +Definition tutu (X : Set) := toto X. diff --git a/test-suite/modules/plik.v b/test-suite/modules/plik.v index 50bfd96046..c2f0fe3cee 100644 --- a/test-suite/modules/plik.v +++ b/test-suite/modules/plik.v @@ -1,3 +1,3 @@ Definition toto (x : Set) := x. -(* <Warning> : Grammar is replaced by Notation *)
\ No newline at end of file +(* <Warning> : Grammar is replaced by Notation *) diff --git a/test-suite/modules/pseudo_circular_with.v b/test-suite/modules/pseudo_circular_with.v index 9e46d17ed9..6bf067fd18 100644 --- a/test-suite/modules/pseudo_circular_with.v +++ b/test-suite/modules/pseudo_circular_with.v @@ -3,4 +3,4 @@ Module Type T. Declare Module M:S. End T. Module N:S. End N. Module NN:T. Module M:=N. End NN. -Module Type U := T with Module M:=NN.
\ No newline at end of file +Module Type U := T with Module M:=NN. diff --git a/test-suite/modules/sig.v b/test-suite/modules/sig.v index da5d25fa2e..fc936a515a 100644 --- a/test-suite/modules/sig.v +++ b/test-suite/modules/sig.v @@ -26,4 +26,4 @@ Module Type SIG. Parameter x : T. End SIG. -Module J : SIG := M.N.
\ No newline at end of file +Module J : SIG := M.N. diff --git a/test-suite/output/CompactContexts.v b/test-suite/output/CompactContexts.v index 07588d34f9..c409c0ee46 100644 --- a/test-suite/output/CompactContexts.v +++ b/test-suite/output/CompactContexts.v @@ -2,4 +2,4 @@ Set Printing Compact Contexts. Lemma f (hP1:True) (a:nat) (b:list nat) (h:forall (x:nat) , { y:nat | y > x}) (h2:True): False. Show. -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 9d106d2dac..7bcd7b041c 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -133,3 +133,5 @@ fun (x : nat) (p : x = x) => match p with | 1 => 1 end = p : forall x : nat, x = x -> Prop +bar 0 + : nat diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index b9985a594f..fe6c05c39e 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -291,3 +291,11 @@ Check fun (x:nat) (p : x=x) => match p with ONE => ONE end = p. Notation "1" := eq_refl. Check fun (x:nat) (p : x=x) => match p with 1 => 1 end = p. +(* Check bug 5693 *) + +Module M. +Definition A := 0. +Definition bar (a b : nat) := plus a b. +Notation "" := A (format "", only printing). +Check (bar A 0). +End M. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index e5dbfcb4be..65efe228af 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -122,3 +122,5 @@ return (1, 2, 3, 4) : nat * nat * nat * nat {{ 1 | 1 // 1 }} : nat +!!! _ _ : nat, True + : (nat -> Prop) * ((nat -> Prop) * Prop) diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index b1015137d6..ea372ad1a3 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -186,3 +186,7 @@ Check letpair x [1] = {0}; return (1,2,3,4). Notation "{ { xL | xR // xcut } }" := (xL+xR+xcut) (at level 0, xR at level 39, format "{ { xL | xR // xcut } }"). Check 1+1+1. + +(* Test presence of notation variables in the recursive parts (introduced in dfdaf4de) *) +Notation "!!! x .. y , b" := ((fun x => b), .. ((fun y => b), True) ..) (at level 200, x binder). +Check !!! (x y:nat), True. diff --git a/test-suite/output/SearchPattern.v b/test-suite/output/SearchPattern.v index bde195a511..de9f48873a 100644 --- a/test-suite/output/SearchPattern.v +++ b/test-suite/output/SearchPattern.v @@ -33,4 +33,4 @@ Goal forall n (P:nat -> Prop), P n -> ~P n -> False. Search (P _) -"h'". (* search hypothesis also for patterns *) Search (P _) -not. (* search hypothesis also for patterns *) -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/output/ltac_missing_args.v b/test-suite/output/ltac_missing_args.v index 8ecd97aa56..91331a1de5 100644 --- a/test-suite/output/ltac_missing_args.v +++ b/test-suite/output/ltac_missing_args.v @@ -16,4 +16,4 @@ Goal True. Fail (fun _ => idtac). Fail rec True. Fail let rec tac x := tac in tac True. -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v index 837f2efd06..4d04f2cf9b 100644 --- a/test-suite/success/Notations.v +++ b/test-suite/success/Notations.v @@ -142,3 +142,8 @@ Fail Notation "'foobarkeyword'" := (@nil) (only parsing, only printing). Reserved Notation "x === y" (at level 50). Inductive EQ {A} (x:A) : A -> Prop := REFL : x === x where "x === y" := (EQ x y). + +(* Check that strictly ident or _ are coerced to a name *) + +Fail Check {x@{u},y|x=x}. +Fail Check {?[n],y|0=0}. diff --git a/test-suite/success/ProgramWf.v b/test-suite/success/ProgramWf.v index 681c4716b6..85d7a770fc 100644 --- a/test-suite/success/ProgramWf.v +++ b/test-suite/success/ProgramWf.v @@ -102,4 +102,4 @@ Qed. Program Fixpoint check_n' (n : nat) (m : {m:nat | m = n}) (p : nat) (q:{q : nat | q = p}) {measure (p - n) p} : nat := - _.
\ No newline at end of file + _. diff --git a/test-suite/success/cbn.v b/test-suite/success/cbn.v index 6aeb05f54e..c98689c234 100644 --- a/test-suite/success/cbn.v +++ b/test-suite/success/cbn.v @@ -15,4 +15,4 @@ Goal forall n, foo (S n) = g n. match goal with |- g _ = g _ => reflexivity end. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/success/clear.v b/test-suite/success/clear.v index e25510cf09..03034cf130 100644 --- a/test-suite/success/clear.v +++ b/test-suite/success/clear.v @@ -30,4 +30,4 @@ Section Foo. assert(b:=Build_A). solve [ typeclasses eauto ]. Qed. -End Foo.
\ No newline at end of file +End Foo. diff --git a/test-suite/success/coercions.v b/test-suite/success/coercions.v index b538d2ed27..9b11bc011c 100644 --- a/test-suite/success/coercions.v +++ b/test-suite/success/coercions.v @@ -130,4 +130,4 @@ Local Coercion l2v2 : list >-> vect. of coercions *) Fail Check (fun l : list (T1 * T1) => (l : vect _ _)). Check (fun l : list (T1 * T1) => (l2v2 l : vect _ _)). -Section what_we_could_do.
\ No newline at end of file +Section what_we_could_do. diff --git a/test-suite/success/hintdb_in_ltac_bis.v b/test-suite/success/hintdb_in_ltac_bis.v index f5c25540ef..2bc3f9d22a 100644 --- a/test-suite/success/hintdb_in_ltac_bis.v +++ b/test-suite/success/hintdb_in_ltac_bis.v @@ -12,4 +12,4 @@ Goal Foo. progress foo mybase. Undo. progress bar mybase. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/success/indelim.v b/test-suite/success/indelim.v index 91b6dee2ec..a962c29f44 100644 --- a/test-suite/success/indelim.v +++ b/test-suite/success/indelim.v @@ -58,4 +58,4 @@ Inductive color := Red | Black. Inductive option (A : Type) : Type := | None : option A -| Some : A -> option A.
\ No newline at end of file +| Some : A -> option A. diff --git a/test-suite/success/keyedrewrite.v b/test-suite/success/keyedrewrite.v index b88c142be1..5638a7d3eb 100644 --- a/test-suite/success/keyedrewrite.v +++ b/test-suite/success/keyedrewrite.v @@ -59,4 +59,4 @@ Qed. Lemma test b : b && true = b. Fail rewrite andb_true_l. Admitted. -
\ No newline at end of file + diff --git a/test-suite/success/ltac_match_pattern_names.v b/test-suite/success/ltac_match_pattern_names.v index 7363294960..790cd1b3a7 100644 --- a/test-suite/success/ltac_match_pattern_names.v +++ b/test-suite/success/ltac_match_pattern_names.v @@ -25,4 +25,4 @@ Ltac multiple_branches := let P := fresh P in let Q := fresh Q in idtac - end.
\ No newline at end of file + end. diff --git a/test-suite/success/ltac_plus.v b/test-suite/success/ltac_plus.v index 8a08d64650..01d477bdf9 100644 --- a/test-suite/success/ltac_plus.v +++ b/test-suite/success/ltac_plus.v @@ -9,4 +9,4 @@ Proof. Fail ((apply h0+apply h2) || apply h1); apply h3. (* interaction with || *) ((apply h0+apply h1) || apply h2); apply h3. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/success/programequality.v b/test-suite/success/programequality.v index 414c572f81..05f4a71856 100644 --- a/test-suite/success/programequality.v +++ b/test-suite/success/programequality.v @@ -10,4 +10,4 @@ Proof. pi_eq_proofs. clear e. destruct e'. simpl. change (P a eq_refl). -Abort.
\ No newline at end of file +Abort. diff --git a/test-suite/success/rewrite_dep.v b/test-suite/success/rewrite_dep.v index d0aafd3833..d73864e4e0 100644 --- a/test-suite/success/rewrite_dep.v +++ b/test-suite/success/rewrite_dep.v @@ -31,4 +31,4 @@ Proof. intros. rewrite H0. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/test-suite/success/rewrite_strat.v b/test-suite/success/rewrite_strat.v index 04c675563e..a6e59fdda0 100644 --- a/test-suite/success/rewrite_strat.v +++ b/test-suite/success/rewrite_strat.v @@ -50,4 +50,4 @@ Proof. Time Qed. (* 0.06 s *) Set Printing All. -Set Printing Depth 100000.
\ No newline at end of file +Set Printing Depth 100000. diff --git a/test-suite/success/univers.v b/test-suite/success/univers.v index 269359ae62..fc74225d76 100644 --- a/test-suite/success/univers.v +++ b/test-suite/success/univers.v @@ -76,4 +76,4 @@ End Ind. Module Rec. Record box_in : myType := BoxIn { coord :> nat * nat; _ : is_box_in_shape coord }. -End Rec.
\ No newline at end of file +End Rec. diff --git a/test-suite/typeclasses/deftwice.v b/test-suite/typeclasses/deftwice.v index 439782c9e5..1394477027 100644 --- a/test-suite/typeclasses/deftwice.v +++ b/test-suite/typeclasses/deftwice.v @@ -6,4 +6,4 @@ Instance inhab_C : C Type := Inhab. Variable full : forall A (X : C A), forall x : A, c x. -Definition truc {A : Type} : Inhab A := (full _ _ _).
\ No newline at end of file +Definition truc {A : Type} : Inhab A := (full _ _ _). diff --git a/test-suite/typeclasses/unification_delta.v b/test-suite/typeclasses/unification_delta.v index 663a837f36..518912433d 100644 --- a/test-suite/typeclasses/unification_delta.v +++ b/test-suite/typeclasses/unification_delta.v @@ -43,4 +43,4 @@ Proof. (* Breaks if too much delta in unification *) rewrite H. reflexivity. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index 88cda79d82..247ea20a88 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -57,4 +57,4 @@ now rewrite H. Qed. (** For compatibility *) -Require Import Le Lt.
\ No newline at end of file +Require Import Le Lt. diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v index 572f286545..e03fb2236a 100644 --- a/theories/FSets/FSets.v +++ b/theories/FSets/FSets.v @@ -20,4 +20,4 @@ Require Export FSetEqProperties. Require Export FSetWeakList. Require Export FSetList. Require Export FSetPositive. -Require Export FSetAVL.
\ No newline at end of file +Require Export FSetAVL. diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v index f7b53f1dc2..a5ae07b64c 100644 --- a/theories/Logic/Classical_Prop.v +++ b/theories/Logic/Classical_Prop.v @@ -97,12 +97,12 @@ Proof proof_irrelevance_cci classic. (* classical_left transforms |- A \/ B into ~B |- A *) (* classical_right transforms |- A \/ B into ~A |- B *) -Ltac classical_right := match goal with - | _:_ |-?X1 \/ _ => (elim (classic X1);intro;[left;trivial|right]) +Ltac classical_right := match goal with +|- ?X \/ _ => (elim (classic X);intro;[left;trivial|right]) end. Ltac classical_left := match goal with -| _:_ |- _ \/?X1 => (elim (classic X1);intro;[right;trivial|left]) +|- _ \/ ?X => (elim (classic X);intro;[right;trivial|left]) end. Require Export EqdepFacts. diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 036ff1aa4b..9fb8e499ba 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -1144,4 +1144,4 @@ Proof. apply mindepth_cardinal. Qed. -End Props.
\ No newline at end of file +End Props. diff --git a/theories/MSets/MSets.v b/theories/MSets/MSets.v index f179bcd1d7..1ee485cc13 100644 --- a/theories/MSets/MSets.v +++ b/theories/MSets/MSets.v @@ -18,4 +18,4 @@ Require Export MSetEqProperties. Require Export MSetWeakList. Require Export MSetList. Require Export MSetPositive. -Require Export MSetAVL.
\ No newline at end of file +Require Export MSetAVL. diff --git a/theories/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v index ba923d0624..6771e57add 100644 --- a/theories/NArith/BinNatDef.v +++ b/theories/NArith/BinNatDef.v @@ -378,4 +378,4 @@ Definition iter (n:N) {A} (f:A->A) (x:A) : A := | pos p => Pos.iter f x p end. -End N.
\ No newline at end of file +End N. diff --git a/theories/Numbers/NatInt/NZParity.v b/theories/Numbers/NatInt/NZParity.v index de3bbbca76..626d59d73e 100644 --- a/theories/Numbers/NatInt/NZParity.v +++ b/theories/Numbers/NatInt/NZParity.v @@ -260,4 +260,4 @@ Proof. intros. apply odd_add_mul_even. apply even_spec, even_2. Qed. -End NZParityProp.
\ No newline at end of file +End NZParityProp. diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index 9aca56f479..b06562fc4f 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -328,4 +328,4 @@ Ltac program_simpl := program_simplify ; try typeclasses eauto with program ; tr Obligation Tactic := program_simpl. -Definition obligation (A : Type) {a : A} := a.
\ No newline at end of file +Definition obligation (A : Type) {a : A} := a. diff --git a/theories/QArith/Qcabs.v b/theories/QArith/Qcabs.v index 1883c77be5..09908665e1 100644 --- a/theories/QArith/Qcabs.v +++ b/theories/QArith/Qcabs.v @@ -126,4 +126,4 @@ Proof. destruct (proj1 (Qcabs_Qcle_condition x 0)) as [A B]. + rewrite H; apply Qcle_refl. + apply Qcle_antisym; auto. -Qed.
\ No newline at end of file +Qed. diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v index 66e37e867e..9b0357f033 100644 --- a/theories/Reals/Ranalysis.v +++ b/theories/Reals/Ranalysis.v @@ -26,4 +26,4 @@ Require Export RList. Require Export Sqrt_reg. Require Export Ranalysis4. Require Export Rpower. -Require Export Ranalysis_reg.
\ No newline at end of file +Require Export Ranalysis_reg. diff --git a/theories/Vectors/Vector.v b/theories/Vectors/Vector.v index 672858fa51..19d749fc85 100644 --- a/theories/Vectors/Vector.v +++ b/theories/Vectors/Vector.v @@ -21,4 +21,4 @@ Require VectorSpec. Require VectorEq. Include VectorDef. Include VectorSpec. -Include VectorEq.
\ No newline at end of file +Include VectorEq. diff --git a/theories/ZArith/BinIntDef.v b/theories/ZArith/BinIntDef.v index 7686fbae87..443667f48b 100644 --- a/theories/ZArith/BinIntDef.v +++ b/theories/ZArith/BinIntDef.v @@ -616,4 +616,4 @@ Definition lxor a b := | neg a, neg b => of_N (N.lxor (Pos.pred_N a) (Pos.pred_N b)) end. -End Z.
\ No newline at end of file +End Z. diff --git a/theories/ZArith/Zsqrt_compat.v b/theories/ZArith/Zsqrt_compat.v index fb7f71b4b5..cccd970dad 100644 --- a/theories/ZArith/Zsqrt_compat.v +++ b/theories/ZArith/Zsqrt_compat.v @@ -229,4 +229,4 @@ Proof. symmetry. apply Z.sqrt_unique; trivial. now apply Zsqrt_interval. now destruct n. -Qed.
\ No newline at end of file +Qed. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index f4d1118d0f..56e12a1e06 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -207,8 +207,8 @@ else TIMING_ARG= endif -# Retro compatibility (DESTDIR is standard on Unix, DESTROOT is not) -ifneq "$(DSTROOT)" "" +# Retro compatibility (DESTDIR is standard on Unix, DSTROOT is not) +ifdef DSTROOT DESTDIR := $(DSTROOT) endif diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index 60a245dc4d..186f6cf6cf 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -682,7 +682,7 @@ and doc_bol = parse | space* nl+ { Output.paragraph (); doc_bol lexbuf } | "<<" space* - { Output.start_verbatim false; verbatim false lexbuf; doc_bol lexbuf } + { Output.start_verbatim false; verbatim 0 false lexbuf; doc_bol lexbuf } | eof { true } | '_' @@ -707,7 +707,7 @@ and doc_list_bol indents = parse } | "<<" space* { Output.start_verbatim false; - verbatim false lexbuf; + verbatim 0 false lexbuf; doc_list_bol indents lexbuf } | "[[" nl { formatted := true; @@ -852,7 +852,7 @@ and doc indents = parse Output.char (lexeme_char lexbuf 1); doc indents lexbuf } | "<<" space* - { Output.start_verbatim true; verbatim true lexbuf; doc_bol lexbuf } + { Output.start_verbatim true; verbatim 0 true lexbuf; doc_bol lexbuf } | '"' { if !Cdglobals.plain_comments then Output.char '"' @@ -892,13 +892,20 @@ and escaped_html = parse { backtrack lexbuf } | _ { Output.html_char (lexeme_char lexbuf 0); escaped_html lexbuf } -and verbatim inline = parse +and verbatim depth inline = parse | nl ">>" space* nl { Output.verbatim_char inline '\n'; Output.stop_verbatim inline } | nl ">>" { Output.verbatim_char inline '\n'; Output.stop_verbatim inline } | ">>" { Output.stop_verbatim inline } - | "*)" { Output.stop_verbatim inline; backtrack lexbuf } + | "(*" { Output.verbatim_char inline '('; + Output.verbatim_char inline '*'; + verbatim (depth+1) inline lexbuf } + | "*)" { if (depth == 0) + then (Output.stop_verbatim inline; backtrack lexbuf) + else (Output.verbatim_char inline '*'; + Output.verbatim_char inline ')'; + verbatim (depth-1) inline lexbuf) } | eof { Output.stop_verbatim inline } - | _ { Output.verbatim_char inline (lexeme_char lexbuf 0); verbatim inline lexbuf } + | _ { Output.verbatim_char inline (lexeme_char lexbuf 0); verbatim depth inline lexbuf } and url = parse | "}}" { Output.url (Buffer.contents url_buffer) None; Buffer.clear url_buffer } diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index d76703d980..444bf8a8f7 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -155,14 +155,16 @@ let error_info_for_buffer ?loc buf = let fname = loc.Loc.fname in let hl, loc = (* We are in the toplevel *) - if CString.equal fname "" then + match fname with + | Loc.ToplevelInput -> let nloc = adjust_loc_buf buf loc in if valid_buffer_loc buf loc then (fnl () ++ print_highlight_location buf nloc, nloc) (* in the toplevel, but not a valid buffer *) else (mt (), nloc) (* we are in batch mode, don't adjust location *) - else (mt (), loc) + | Loc.InFile _ -> + (mt (), loc) in Topfmt.pr_loc loc ++ hl ) loc diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index bfab447706..1602f9c683 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -182,7 +182,7 @@ and load_vernac verbosely sid file = if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout in let in_chan = open_utf8_file_in file in let in_echo = if verbosely then Some (open_utf8_file_in file) else None in - let in_pa = Pcoq.Gram.parsable ~file (Stream.of_channel in_chan) in + let in_pa = Pcoq.Gram.parsable ~file:(Loc.InFile file) (Stream.of_channel in_chan) in let rsid = ref sid in try (* we go out of the following infinite loop when a End_of_input is diff --git a/vernac/command.ml b/vernac/command.ml index a315ac14e2..32ab5401a0 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -241,7 +241,7 @@ let do_assumptions_unbound_univs (_, poly, _ as kind) nl l = else l in (* We intepret all declarations in the same evar_map, i.e. as a telescope. *) - let _,l = List.fold_map (fun (env,ienv) (is_coe,(idl,c)) -> + let _,l = List.fold_left_map (fun (env,ienv) (is_coe,(idl,c)) -> let t,imps = interp_assumption evdref env ienv [] c in let env = push_named_context (List.map (fun (_,id) -> LocalAssum (id,t)) idl) env in @@ -367,7 +367,7 @@ let prepare_param = function let rec check_anonymous_type ind = let open Glob_term in - match ind.CAst.v with + match DAst.get ind with | GSort (GType []) -> true | GProd ( _, _, _, e) | GLetIn (_, _, _, e) diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 2be10a0397..12b68fe38e 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -418,7 +418,7 @@ let explain_not_product env sigma c = let pr = pr_lconstr_env env sigma c in str "The type of this term is a product" ++ spc () ++ str "while it is expected to be" ++ - (if is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "." + (if Term.is_Type c then str " a sort" else (brk(1,1) ++ pr)) ++ str "." (* TODO: use the names *) (* (co)fixpoints *) @@ -1176,7 +1176,7 @@ let error_not_allowed_case_analysis isrec kind i = pr_inductive (Global.env()) (fst i) ++ str "." let error_not_allowed_dependent_analysis isrec i = - str "Dependent " ++ str (if isrec then "Induction" else "Case analysis") ++ + str "Dependent " ++ str (if isrec then "induction" else "case analysis") ++ strbrk " is not allowed for inductive definition " ++ pr_inductive (Global.env()) i ++ str "." diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 6ea8bc7f2c..facebd096a 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -30,7 +30,6 @@ open Globnames open Goptions open Nameops open Termops -open Pretyping open Nametab open Smartlocate open Vernacexpr @@ -345,24 +344,23 @@ requested let names inds recs isdep y z = let ind = smart_global_inductive y in let sort_of_ind = inductive_sort_family (snd (lookup_mind_specif env ind)) in - let z' = interp_elimination_sort z in let suffix = ( match sort_of_ind with | InProp -> - if isdep then (match z' with + if isdep then (match z with | InProp -> inds ^ "_dep" | InSet -> recs ^ "_dep" | InType -> recs ^ "t_dep") - else ( match z' with + else ( match z with | InProp -> inds | InSet -> recs | InType -> recs ^ "t" ) | _ -> - if isdep then (match z' with + if isdep then (match z with | InProp -> inds | InSet -> recs | InType -> recs ^ "t" ) - else (match z' with + else (match z with | InProp -> inds ^ "_nodep" | InSet -> recs ^ "_nodep" | InType -> recs ^ "t_nodep") @@ -392,7 +390,7 @@ let do_mutual_induction_scheme lnamedepindsort = evd, (ind,u), Some u | Some ui -> evd, (ind, ui), inst in - (evd, (indu,dep,interp_elimination_sort sort) :: l, inst)) + (evd, (indu,dep,sort) :: l, inst)) lnamedepindsort (Evd.from_env env0,[],None) in let sigma, listdecl = Indrec.build_mutual_induction_scheme env0 sigma lrecspec in diff --git a/vernac/indschemes.mli b/vernac/indschemes.mli index 076e4938fd..91c4c58255 100644 --- a/vernac/indschemes.mli +++ b/vernac/indschemes.mli @@ -11,7 +11,6 @@ open Names open Term open Environ open Vernacexpr -open Misctypes (** See also Auto_ind_decl, Indrec, Eqscheme, Ind_tables, ... *) @@ -32,7 +31,7 @@ val declare_rewriting_schemes : inductive -> unit (** Mutual Minimality/Induction scheme *) val do_mutual_induction_scheme : - (Id.t located * bool * inductive * glob_sort) list -> unit + (Id.t located * bool * inductive * Sorts.family) list -> unit (** Main calls to interpret the Scheme command *) diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 8b042a3ca3..c424b1d501 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -98,8 +98,7 @@ let pr_grammar = function quote (except a single quote alone) must be quoted) *) let parse_format ((loc, str) : lstring) = - let str = " "^str in - let l = String.length str in + let len = String.length str in let push_token a = function | cur::l -> (a::cur)::l | [] -> [[a]] in @@ -109,16 +108,16 @@ let parse_format ((loc, str) : lstring) = | a::(_::_ as l) -> push_token (UnpBox (b,a)) l | _ -> user_err Pp.(str "Non terminated box in format.") in let close_quotation i = - if i < String.length str && str.[i] == '\'' && (Int.equal (i+1) l || str.[i+1] == ' ') + if i < len && str.[i] == '\'' && (Int.equal (i+1) len || str.[i+1] == ' ') then i+1 else user_err Pp.(str "Incorrectly terminated quoted expression.") in let rec spaces n i = - if i < String.length str && str.[i] == ' ' then spaces (n+1) (i+1) + if i < len && str.[i] == ' ' then spaces (n+1) (i+1) else n in let rec nonspaces quoted n i = - if i < String.length str && str.[i] != ' ' then + if i < len && str.[i] != ' ' then if str.[i] == '\'' && quoted && - (i+1 >= String.length str || str.[i+1] == ' ') + (i+1 >= len || str.[i+1] == ' ') then if Int.equal n 0 then user_err Pp.(str "Empty quoted token.") else n else nonspaces quoted (n+1) (i+1) else @@ -126,26 +125,26 @@ let parse_format ((loc, str) : lstring) = else n in let rec parse_non_format i = let n = nonspaces false 0 i in - push_token (UnpTerminal (String.sub str i n)) (parse_token (i+n)) + push_token (UnpTerminal (String.sub str i n)) (parse_token 1 (i+n)) and parse_quoted n i = - if i < String.length str then match str.[i] with + if i < len then match str.[i] with (* Parse " // " *) - | '/' when i <= String.length str && str.[i+1] == '/' -> + | '/' when i <= len && str.[i+1] == '/' -> (* We forget the useless n spaces... *) push_token (UnpCut PpFnl) - (parse_token (close_quotation (i+2))) + (parse_token 1 (close_quotation (i+2))) (* Parse " .. / .. " *) - | '/' when i <= String.length str -> + | '/' when i <= len -> let p = spaces 0 (i+1) in push_token (UnpCut (PpBrk (n,p))) - (parse_token (close_quotation (i+p+1))) + (parse_token 1 (close_quotation (i+p+1))) | c -> (* The spaces are real spaces *) push_white n (match c with | '[' -> - if i <= String.length str then match str.[i+1] with + if i <= len then match str.[i+1] with (* Parse " [h .. ", *) - | 'h' when i+1 <= String.length str && str.[i+2] == 'v' -> + | 'h' when i+1 <= len && str.[i+2] == 'v' -> (parse_box (fun n -> PpHVB n) (i+3)) (* Parse " [v .. ", *) | 'v' -> @@ -157,39 +156,39 @@ let parse_format ((loc, str) : lstring) = else user_err Pp.(str "\"v\", \"hv\" or \" \" expected after \"[\" in format.") (* Parse "]" *) | ']' -> - ([] :: parse_token (close_quotation (i+1))) + ([] :: parse_token 1 (close_quotation (i+1))) (* Parse a non formatting token *) | c -> let n = nonspaces true 0 i in push_token (UnpTerminal (String.sub str (i-1) (n+2))) - (parse_token (close_quotation (i+n)))) + (parse_token 1 (close_quotation (i+n)))) else if Int.equal n 0 then [] else user_err Pp.(str "Ending spaces non part of a format annotation.") and parse_box box i = let n = spaces 0 i in - close_box i (box n) (parse_token (close_quotation (i+n))) - and parse_token i = + close_box i (box n) (parse_token 1 (close_quotation (i+n))) + and parse_token k i = let n = spaces 0 i in let i = i+n in - if i < l then match str.[i] with + if i < len then match str.[i] with (* Parse a ' *) - | '\'' when i+1 >= String.length str || str.[i+1] == ' ' -> - push_white (n-1) (push_token (UnpTerminal "'") (parse_token (i+1))) + | '\'' when i+1 >= len || str.[i+1] == ' ' -> + push_white (n-k) (push_token (UnpTerminal "'") (parse_token 1 (i+1))) (* Parse the beginning of a quoted expression *) | '\'' -> - parse_quoted (n-1) (i+1) + parse_quoted (n-k) (i+1) (* Otherwise *) | _ -> - push_white (n-1) (parse_non_format i) + push_white (n-k) (parse_non_format i) else push_white n [[]] in try - if not (String.is_empty str) then match parse_token 0 with + if not (String.is_empty str) then match parse_token 0 0 with | [l] -> l | _ -> user_err Pp.(str "Box closed without being opened in format.") else - user_err Pp.(str "Empty format.") + [] with reraise -> let (e, info) = CErrors.push reraise in let info = Option.cata (Loc.add_loc info) info loc in diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index e7b14309d1..6a10eb43a2 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -292,10 +292,11 @@ let emacs_logger = gen_logger Emacs.quote_info Emacs.quote_warning (* This is specific to the toplevel *) let pr_loc loc = let fname = loc.Loc.fname in - if CString.equal fname "" then + match fname with + | Loc.ToplevelInput -> Loc.(str"Toplevel input, characters " ++ int loc.bp ++ str"-" ++ int loc.ep ++ str":") - else + | Loc.InFile fname -> Loc.(str"File " ++ str "\"" ++ str fname ++ str "\"" ++ str", line " ++ int loc.line_nb ++ str", characters " ++ int (loc.bp-loc.bol_pos) ++ str"-" ++ int (loc.ep-loc.bol_pos) ++ diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 8738e58e82..4fd08b42d4 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -409,9 +409,10 @@ let dump_global r = (**********) (* Syntax *) -let vernac_syntax_extension locality local = +let vernac_syntax_extension locality local infix l = let local = enforce_module_locality locality local in - Metasyntax.add_syntax_extension local + if infix then Metasyntax.check_infix_modifiers (snd l); + Metasyntax.add_syntax_extension local l let vernac_delimiters sc = function | Some lr -> Metasyntax.add_delimiters sc lr @@ -1230,7 +1231,7 @@ let vernac_reserve bl = let env = Global.env() in let sigma = Evd.from_env env in let t,ctx = Constrintern.interp_type env sigma c in - let t = Detyping.detype false [] env (Evd.from_ctx ctx) (EConstr.of_constr t) in + let t = Detyping.detype Detyping.Now false [] env (Evd.from_ctx ctx) (EConstr.of_constr t) in let t,_ = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in Reserve.declare_reserved_type idl t) in List.iter sb_decl bl @@ -1902,7 +1903,7 @@ let vernac_load interp fname = let input = let longfname = Loadpath.locate_file fname in let in_chan = open_utf8_file_in longfname in - Pcoq.Gram.parsable ~file:longfname (Stream.of_channel in_chan) in + Pcoq.Gram.parsable ~file:(Loc.InFile longfname) (Stream.of_channel in_chan) in try while true do interp (snd (parse_sentence input)) done with End_of_input -> () @@ -1950,8 +1951,8 @@ let interp ?proof ?loc locality poly c = | VernacLocal _ -> assert false (* Syntax *) - | VernacSyntaxExtension (local,sl) -> - vernac_syntax_extension locality local sl + | VernacSyntaxExtension (infix, local,sl) -> + vernac_syntax_extension locality local infix sl | VernacDelimiters (sc,lr) -> vernac_delimiters sc lr | VernacBindScope (sc,rl) -> vernac_bind_scope sc rl | VernacOpenCloseScope (local, s) -> vernac_open_close_scope locality local s |