diff options
48 files changed, 562 insertions, 332 deletions
diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index 3bd3342329..df9e14b178 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -17,3 +17,5 @@ Fixes / closes #???? <!-- (Otherwise, remove these lines.) --> - [ ] Corresponding documentation was added / updated (including any warning and error messages added / removed / modified). - [ ] Entry added in the changelog (see https://github.com/coq/coq/tree/master/doc/changelog#unreleased-changelog for details). +- [ ] Overlay pull requests (if this breaks 3rd party developments in CI, see +https://github.com/coq/coq/blob/master/dev/ci/user-overlays/README.md for details) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index d0ffedab2a..ce6be777f3 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -706,7 +706,11 @@ library:ci-engine_bench: extends: .ci-template library:ci-fcsl_pcm: - extends: .ci-template + extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-mathcomp library:ci-fiat_crypto: extends: .ci-template-flambda @@ -781,6 +785,10 @@ plugin:ci-gappa: library:ci-geocoq: extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-mathcomp library:ci-hott: extends: .ci-template @@ -820,6 +828,13 @@ library:ci-vst: - build:edge+flambda - library:ci-flocq +library:ci-deriving: + extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-mathcomp + # Plugins are by definition the projects that depend on Coq's ML API plugin:ci-aac_tactics: @@ -871,6 +886,10 @@ plugin:plugin-tutorial: plugin:ci-quickchick: extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-mathcomp plugin:ci-reduction_effects: extends: .ci-template diff --git a/Makefile.ci b/Makefile.ci index d549ed1b39..f7c2943cc2 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -24,6 +24,7 @@ CI_TARGETS= \ ci-coq_performance_tests \ ci-coq_tools \ ci-coqprime \ + ci-deriving \ ci-elpi \ ci-engine_bench \ ci-ext_lib \ @@ -74,6 +75,7 @@ ci-color: ci-bignums ci-coqprime: ci-bignums ci-coquelicot: ci-mathcomp +ci-deriving: ci-mathcomp ci-math_classes: ci-bignums ci-corn: ci-math_classes @@ -86,9 +88,12 @@ ci-fiat_crypto_ocaml: ci-fiat_crypto ci-interval: ci-mathcomp ci-flocq ci-coquelicot ci-bignums ci-fourcolor: ci-mathcomp ci-oddorder: ci-mathcomp +ci-fcsl_pcm: ci-mathcomp + +ci-geocoq: ci-mathcomp ci-simple_io: ci-ext_lib -ci-quickchick: ci-ext_lib ci-simple_io +ci-quickchick: ci-ext_lib ci-simple_io ci-mathcomp ci-metacoq: ci-equations diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 8bcbd90f0b..4799755b15 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -308,3 +308,8 @@ project sf "https://github.com/DeepSpec/sf" "master" # Coqtail ######################################################################## project coqtail "https://github.com/whonore/Coqtail" "master" + +######################################################################## +# Deriving +######################################################################## +project deriving "https://github.com/arthuraa/deriving" "master" diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 8d8f78e10c..006565df5c 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -143,33 +143,3 @@ make() command make --output-sync "$@" fi } - -# this installs just the ssreflect library of math-comp -install_ssreflect() -{ - echo 'Installing ssreflect' - - git_download mathcomp - - ( cd "${CI_BUILD_DIR}/mathcomp/mathcomp/ssreflect" && \ - make && \ - make install ) - -} - -# this installs just the ssreflect + algebra library of math-comp -install_ssralg() -{ - echo 'Installing ssralg' - - git_download mathcomp - - ( cd "${CI_BUILD_DIR}/mathcomp/mathcomp" && \ - make -C ssreflect && \ - make -C ssreflect install && \ - make -C fingroup && \ - make -C fingroup install && \ - make -C algebra && \ - make -C algebra install ) - -} diff --git a/dev/ci/ci-deriving.sh b/dev/ci/ci-deriving.sh new file mode 100755 index 0000000000..c34fc44f69 --- /dev/null +++ b/dev/ci/ci-deriving.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download deriving + +( cd "${CI_BUILD_DIR}/deriving" && make && make tests && make install ) diff --git a/dev/ci/ci-fcsl_pcm.sh b/dev/ci/ci-fcsl_pcm.sh index cb951630c8..e1248c6627 100755 --- a/dev/ci/ci-fcsl_pcm.sh +++ b/dev/ci/ci-fcsl_pcm.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -install_ssreflect - git_download fcsl_pcm ( cd "${CI_BUILD_DIR}/fcsl_pcm" && make ) diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index e4fc983e68..0ad9ac0cbb 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -install_ssralg - git_download geocoq ( cd "${CI_BUILD_DIR}/geocoq" && ./configure.sh && make ) diff --git a/dev/ci/ci-quickchick.sh b/dev/ci/ci-quickchick.sh index 08686d7ced..2bc2a18849 100755 --- a/dev/ci/ci-quickchick.sh +++ b/dev/ci/ci-quickchick.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -install_ssreflect - git_download quickchick ( cd "${CI_BUILD_DIR}/quickchick" && make && make install) diff --git a/doc/changelog/05-tactic-language/13920-ltac2-ind-api.rst b/doc/changelog/05-tactic-language/13920-ltac2-ind-api.rst new file mode 100644 index 0000000000..32499957be --- /dev/null +++ b/doc/changelog/05-tactic-language/13920-ltac2-ind-api.rst @@ -0,0 +1,5 @@ +- **Added:** + Added the Ltac2 API `Ltac2.Ind` for manipulating inductive types + (`#13920 <https://github.com/coq/coq/pull/13920>`_, + fixes `#10095 <https://github.com/coq/coq/issues/10095>`_, + by Pierre-Marie Pédrot). diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index b0f4e883be..d67906c4a8 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -685,6 +685,7 @@ through the <tt>Require Import</tt> command.</p> user-contrib/Ltac2/Fresh.v user-contrib/Ltac2/Ident.v user-contrib/Ltac2/Init.v + user-contrib/Ltac2/Ind.v user-contrib/Ltac2/Int.v user-contrib/Ltac2/List.v user-contrib/Ltac2/Ltac1.v diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index edb8db1e94..1428dae7ef 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -529,12 +529,12 @@ class ProductionObject(CoqObject): self.signatures = [] indexnode = super().run()[0] # makes calls to handle_signature - table = nodes.container(classes=['prodn-table']) - tgroup = nodes.container(classes=['prodn-column-group']) + table = nodes.inline(classes=['prodn-table']) + tgroup = nodes.inline(classes=['prodn-column-group']) for _ in range(4): - tgroup += nodes.container(classes=['prodn-column']) + tgroup += nodes.inline(classes=['prodn-column']) table += tgroup - tbody = nodes.container(classes=['prodn-row-group']) + tbody = nodes.inline(classes=['prodn-row-group']) table += tbody # create rows @@ -542,8 +542,8 @@ class ProductionObject(CoqObject): lhs, op, rhs, tag = signature position = self.state_machine.get_source_and_line(self.lineno) - row = nodes.container(classes=['prodn-row']) - entry = nodes.container(classes=['prodn-cell-nonterminal']) + row = nodes.inline(classes=['prodn-row']) + entry = nodes.inline(classes=['prodn-cell-nonterminal']) if lhs != "": target_name = make_id('grammar-token-' + lhs) target = nodes.target('', '', ids=[target_name], names=[target_name]) @@ -553,19 +553,19 @@ class ProductionObject(CoqObject): entry += inline entry += notation_to_sphinx('@'+lhs, *position) else: - entry += nodes.Text('') + entry += nodes.literal('', '') row += entry - entry = nodes.container(classes=['prodn-cell-op']) - entry += nodes.Text(op) + entry = nodes.inline(classes=['prodn-cell-op']) + entry += nodes.literal(op, op) row += entry - entry = nodes.container(classes=['prodn-cell-production']) + entry = nodes.inline(classes=['prodn-cell-production']) entry += notation_to_sphinx(rhs, *position) row += entry - entry = nodes.container(classes=['prodn-cell-tag']) - entry += nodes.Text(tag) + entry = nodes.inline(classes=['prodn-cell-tag']) + entry += nodes.literal(tag, tag) row += entry tbody += row diff --git a/engine/termops.ml b/engine/termops.ml index 4dc584cfa8..d60aa69ccb 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -979,69 +979,52 @@ let collapse_appl sigma c = match EConstr.kind sigma c with (* First utilities for avoiding telescope computation for subst_term *) -let prefix_application sigma eq_fun (k,c) t = +let prefix_application sigma eq_fun k l1 t = let open EConstr in - let c' = collapse_appl sigma c and t' = collapse_appl sigma t in - match EConstr.kind sigma c', EConstr.kind sigma t' with - | App (f1,cl1), App (f2,cl2) -> - let l1 = Array.length cl1 - and l2 = Array.length cl2 in + let t' = collapse_appl sigma t in + if 0 < l1 then match EConstr.kind sigma t' with + | App (f2,cl2) -> + let l2 = Array.length cl2 in if l1 <= l2 - && eq_fun sigma c' (mkApp (f2, Array.sub cl2 0 l1)) then - Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1))) + && eq_fun sigma k (mkApp (f2, Array.sub cl2 0 l1)) then + Some (Array.sub cl2 l1 (l2 - l1)) else None | _ -> None + else None -let my_prefix_application sigma eq_fun (k,c) by_c t = - let open EConstr in - let c' = collapse_appl sigma c and t' = collapse_appl sigma t in - match EConstr.kind sigma c', EConstr.kind sigma t' with - | App (f1,cl1), App (f2,cl2) -> - let l1 = Array.length cl1 - and l2 = Array.length cl2 in - if l1 <= l2 - && eq_fun sigma c' (mkApp (f2, Array.sub cl2 0 l1)) then - Some (mkApp ((Vars.lift k by_c), Array.sub cl2 l1 (l2 - l1))) - else - None - | _ -> None - -(* Recognizing occurrences of a given subterm in a term: [subst_term c t] - substitutes [(Rel 1)] for all occurrences of term [c] in a term [t]; - works if [c] has rels *) - -let subst_term_gen sigma eq_fun c t = - let open EConstr in - let open Vars in - let rec substrec (k,c as kc) t = - match prefix_application sigma eq_fun kc t with - | Some x -> x - | None -> - if eq_fun sigma c t then mkRel k - else - EConstr.map_with_binders sigma (fun (k,c) -> (k+1,lift 1 c)) substrec kc t +let eq_upto_lift cache c sigma k t = + let c = + try Int.Map.find k !cache + with Not_found -> + let c = EConstr.Vars.lift k c in + let () = cache := Int.Map.add k c !cache in + c in - substrec (1,c) t - -let subst_term sigma c t = subst_term_gen sigma EConstr.eq_constr c t + EConstr.eq_constr sigma c t (* Recognizing occurrences of a given subterm in a term : [replace_term c1 c2 t] substitutes [c2] for all occurrences of term [c1] in a term [t]; works if [c1] and [c2] have rels *) -let replace_term_gen sigma eq_fun c by_c in_t = - let rec substrec (k,c as kc) t = - match my_prefix_application sigma eq_fun kc by_c t with - | Some x -> x +let replace_term_gen sigma eq_fun ar by_c in_t = + let rec substrec k t = + match prefix_application sigma eq_fun k ar t with + | Some args -> EConstr.mkApp (EConstr.Vars.lift k by_c, args) | None -> - (if eq_fun sigma c t then (EConstr.Vars.lift k by_c) else - EConstr.map_with_binders sigma (fun (k,c) -> (k+1,EConstr.Vars.lift 1 c)) - substrec kc t) + (if eq_fun sigma k t then (EConstr.Vars.lift k by_c) else + EConstr.map_with_binders sigma succ substrec k t) in - substrec (0,c) in_t + substrec 0 in_t + +let replace_term sigma c byc t = + let cache = ref Int.Map.empty in + let c = collapse_appl sigma c in + let ar = Array.length (snd (decompose_app_vect sigma c)) in + let eq sigma k t = eq_upto_lift cache c sigma k t in + replace_term_gen sigma eq ar byc t -let replace_term sigma c byc t = replace_term_gen sigma EConstr.eq_constr c byc t +let subst_term sigma c t = replace_term sigma c (EConstr.mkRel 1) t let vars_of_env env = let s = Environ.ids_of_named_context_val (Environ.named_context_val env) in diff --git a/engine/termops.mli b/engine/termops.mli index 12df61e4c8..bdde2c450d 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -122,16 +122,12 @@ val pop : constr -> constr (** Substitution of an arbitrary large term. Uses equality modulo reduction of let *) -(** [subst_term_gen eq d c] replaces [d] by [Rel 1] in [c] using [eq] - as equality *) -val subst_term_gen : Evd.evar_map -> - (Evd.evar_map -> constr -> constr -> bool) -> constr -> constr -> constr - -(** [replace_term_gen eq d e c] replaces [d] by [e] in [c] using [eq] - as equality *) +(** [replace_term_gen eq arity e c] replaces matching subterms according to + [eq] by [e] in [c]. If [arity] is non-zero applications of larger length + are handled atomically. *) val replace_term_gen : - Evd.evar_map -> (Evd.evar_map -> constr -> constr -> bool) -> - constr -> constr -> constr -> constr + Evd.evar_map -> (Evd.evar_map -> int -> constr -> bool) -> + int -> constr -> constr -> constr (** [subst_term d c] replaces [d] by [Rel 1] in [c] *) val subst_term : Evd.evar_map -> constr -> constr -> constr diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 1432fb9310..d31d7a03b6 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -196,8 +196,9 @@ let vm_conv_gen cv_pb env univs t1 t2 = TransparentState.full env univs t1 t2 else try - let v1 = val_of_constr env t1 in - let v2 = val_of_constr env t2 in + let sigma _ = assert false in + let v1 = val_of_constr env sigma t1 in + let v2 = val_of_constr env sigma t2 in fst (conv_val env cv_pb (nb_rel env) v1 v2 univs) with Not_found | Invalid_argument _ -> warn_bytecode_compiler_failed (); diff --git a/kernel/vmbytegen.ml b/kernel/vmbytegen.ml index 20de4bc81b..7d3b3469b0 100644 --- a/kernel/vmbytegen.ml +++ b/kernel/vmbytegen.ml @@ -840,21 +840,21 @@ let dump_bytecodes init code fvs = prlist_with_sep (fun () -> str "; ") pp_fv_elem fvs ++ fnl ()) -let compile ~fail_on_error ?universes:(universes=0) env c = +let compile ~fail_on_error ?universes:(universes=0) env sigma c = init_fun_code (); Label.reset_label_counter (); let cont = [Kstop] in try let cenv, init_code = if Int.equal universes 0 then - let lam = lambda_of_constr ~optimize:true env c in + let lam = lambda_of_constr ~optimize:true env sigma c in let cenv = empty_comp_env () in cenv, ensure_stack_capacity (compile_lam env cenv lam 0) cont else (* We are going to generate a lambda, but merge the universe closure * with the function closure if it exists. *) - let lam = lambda_of_constr ~optimize:true env c in + let lam = lambda_of_constr ~optimize:true env sigma c in let params, body = decompose_Llam lam in let arity = Array.length params in let cenv = empty_comp_env () in @@ -896,7 +896,8 @@ let compile_constant_body ~fail_on_error env univs = function let con= Constant.make1 (Constant.canonical kn') in Some (BCalias (get_alias env con)) | _ -> - let res = compile ~fail_on_error ~universes:instance_size env body in + let sigma _ = assert false in + let res = compile ~fail_on_error ~universes:instance_size env sigma body in Option.map (fun x -> BCdefined (to_memory x)) res (* Shortcut of the previous function used during module strengthening *) diff --git a/kernel/vmbytegen.mli b/kernel/vmbytegen.mli index aef7ac3d6b..c724cad5ec 100644 --- a/kernel/vmbytegen.mli +++ b/kernel/vmbytegen.mli @@ -15,8 +15,10 @@ open Declarations open Environ (** Should only be used for monomorphic terms *) -val compile : fail_on_error:bool -> - ?universes:int -> env -> constr -> (bytecodes * bytecodes * fv) option +val compile : + fail_on_error:bool -> ?universes:int -> + env -> (existential -> constr option) -> constr -> + (bytecodes * bytecodes * fv) option (** init, fun, fv *) val compile_constant_body : fail_on_error:bool -> diff --git a/kernel/vmlambda.ml b/kernel/vmlambda.ml index 91de58b0e6..e353348ac7 100644 --- a/kernel/vmlambda.ml +++ b/kernel/vmlambda.ml @@ -591,12 +591,14 @@ struct type t = { global_env : env; + evar_body : existential -> constr option; name_rel : Name.t Vect.t; construct_tbl : (constructor, constructor_info) Hashtbl.t; } - let make env = { + let make env sigma = { global_env = env; + evar_body = sigma; name_rel = Vect.make 16 Anonymous; construct_tbl = Hashtbl.create 111 } @@ -633,9 +635,13 @@ open Renv let rec lambda_of_constr env c = match Constr.kind c with | Meta _ -> raise (Invalid_argument "Vmbytegen.lambda_of_constr: Meta") - | Evar (evk, args) -> - let args = Array.map_of_list (fun c -> lambda_of_constr env c) args in - Levar (evk, args) + | Evar (evk, args as ev) -> + begin match env.evar_body ev with + | None -> + let args = Array.map_of_list (fun c -> lambda_of_constr env c) args in + Levar (evk, args) + | Some t -> lambda_of_constr env t + end | Cast (c, _, _) -> lambda_of_constr env c @@ -774,8 +780,8 @@ let optimize_lambda lam = let lam = simplify subst_id lam in remove_let subst_id lam -let lambda_of_constr ~optimize genv c = - let env = Renv.make genv in +let lambda_of_constr ~optimize genv sigma c = + let env = Renv.make genv sigma in let ids = List.rev_map Context.Rel.Declaration.get_annot (rel_context genv) in Renv.push_rels env (Array.of_list ids); let lam = lambda_of_constr env c in diff --git a/kernel/vmlambda.mli b/kernel/vmlambda.mli index ad5f81638f..03d3393219 100644 --- a/kernel/vmlambda.mli +++ b/kernel/vmlambda.mli @@ -33,7 +33,7 @@ and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array exception TooLargeInductive of Pp.t -val lambda_of_constr : optimize:bool -> env -> Constr.t -> lambda +val lambda_of_constr : optimize:bool -> env -> (existential -> constr option) -> Constr.t -> lambda val decompose_Llam : lambda -> Name.t Context.binder_annot array * lambda diff --git a/kernel/vmsymtable.ml b/kernel/vmsymtable.ml index ae0fa38571..90ee1c5378 100644 --- a/kernel/vmsymtable.ml +++ b/kernel/vmsymtable.ml @@ -144,7 +144,7 @@ let slot_for_proj_name key = ProjNameTable.add proj_name_tbl key n; n -let rec slot_for_getglobal env kn = +let rec slot_for_getglobal env sigma kn = let (cb,(_,rk)) = lookup_constant_key kn env in try key rk with NotEvaluated -> @@ -155,22 +155,22 @@ let rec slot_for_getglobal env kn = | Some code -> match Vmemitcodes.force code with | BCdefined(code,pl,fv) -> - let v = eval_to_patch env (code,pl,fv) in + let v = eval_to_patch env sigma (code,pl,fv) in set_global v - | BCalias kn' -> slot_for_getglobal env kn' + | BCalias kn' -> slot_for_getglobal env sigma kn' | BCconstant -> set_global (val_of_constant kn) in (*Pp.msgnl(str"value stored at: "++int pos);*) rk := Some (CEphemeron.create pos); pos -and slot_for_fv env fv = +and slot_for_fv env sigma fv = let fill_fv_cache cache id v_of_id env_of_id b = let v,d = match b with | None -> v_of_id id, Id.Set.empty | Some c -> - val_of_constr (env_of_id id env) c, + val_of_constr (env_of_id id env) sigma c, Environ.global_vars_set env c in build_lazy_val cache (v, d); v in let val_of_rel i = val_of_rel (nb_rel env - i) in @@ -194,11 +194,11 @@ and slot_for_fv env fv = | FVuniv_var _idu -> assert false -and eval_to_patch env (buff,pl,fv) = +and eval_to_patch env sigma (buff,pl,fv) = let slots = function | Reloc_annot a -> slot_for_annot a | Reloc_const sc -> slot_for_str_cst sc - | Reloc_getglobal kn -> slot_for_getglobal env kn + | Reloc_getglobal kn -> slot_for_getglobal env sigma kn | Reloc_proj_name p -> slot_for_proj_name p | Reloc_caml_prim op -> slot_for_caml_prim op in @@ -207,13 +207,13 @@ and eval_to_patch env (buff,pl,fv) = (* Environment should look like a closure, so free variables start at slot 2. *) let a = Array.make (Array.length fv + 2) crazy_val in a.(1) <- Obj.magic 2; - Array.iteri (fun i v -> a.(i + 2) <- slot_for_fv env v) fv; + Array.iteri (fun i v -> a.(i + 2) <- slot_for_fv env sigma v) fv; a in eval_tcode tc (get_atom_rel ()) (vm_global global_data.glob_val) vm_env -and val_of_constr env c = - match compile ~fail_on_error:true env c with - | Some v -> eval_to_patch env (to_memory v) +and val_of_constr env sigma c = + match compile ~fail_on_error:true env sigma c with + | Some v -> eval_to_patch env sigma (to_memory v) | None -> assert false let set_transparent_const _kn = () (* !?! *) diff --git a/kernel/vmsymtable.mli b/kernel/vmsymtable.mli index e480bfcec1..c6dc09d944 100644 --- a/kernel/vmsymtable.mli +++ b/kernel/vmsymtable.mli @@ -14,7 +14,7 @@ open Names open Constr open Environ -val val_of_constr : env -> constr -> Vmvalues.values +val val_of_constr : env -> (existential -> constr option) -> constr -> Vmvalues.values val set_opaque_const : Constant.t -> unit val set_transparent_const : Constant.t -> unit diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index f2241e78d2..54d7c310aa 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -2148,7 +2148,8 @@ let interp_redexp env sigma r = (* Backwarding recursive needs of tactic glob/interp/eval functions *) let _ = - let eval lfun poly env sigma ty tac = + let eval ?loc ~poly env sigma tycon tac = + let lfun = GlobEnv.lfun env in let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in let ist = { lfun; poly; extra; } in let tac = eval_tactic_ist ist tac in @@ -2156,8 +2157,13 @@ let _ = poly seems like enough to get reasonable behavior in practice *) let name = Id.of_string "ltac_gen" in - let (c, sigma) = Proof.refine_by_tactic ~name ~poly env sigma ty tac in - (EConstr.of_constr c, sigma) + let sigma, ty = match tycon with + | Some ty -> sigma, ty + | None -> GlobEnv.new_type_evar env sigma ~src:(loc,Evar_kinds.InternalHole) + in + let (c, sigma) = Proof.refine_by_tactic ~name ~poly (GlobEnv.renamed_env env) sigma ty tac in + let j = { Environ.uj_val = EConstr.of_constr c; uj_type = ty } in + (j, sigma) in GlobEnv.register_constr_interp0 wit_tactic eval diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index 34fae613bf..ad28b54900 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -51,6 +51,8 @@ let make ~hypnaming env sigma lvar = } let env env = env.static_env +let renamed_env env = env.renamed_env +let lfun env = env.lvar.ltac_genargs let vars_of_env env = Id.Set.union (Id.Map.domain env.lvar.ltac_genargs) (vars_of_env env.static_env) @@ -183,10 +185,13 @@ let interp_ltac_variable ?loc typing_fun env sigma id : Evd.evar_map * unsafe_ju let interp_ltac_id env id = ltac_interp_id env.lvar id +type 'a obj_interp_fun = + ?loc:Loc.t -> poly:bool -> t -> Evd.evar_map -> Evardefine.type_constraint -> + 'a -> unsafe_judgment * Evd.evar_map + module ConstrInterpObj = struct - type ('r, 'g, 't) obj = - unbound_ltac_var_map -> bool -> env -> Evd.evar_map -> types -> 'g -> constr * Evd.evar_map + type ('r, 'g, 't) obj = 'g obj_interp_fun let name = "constr_interp" let default _ = None end @@ -195,8 +200,8 @@ module ConstrInterp = Genarg.Register(ConstrInterpObj) let register_constr_interp0 = ConstrInterp.register0 -let interp_glob_genarg env poly sigma ty arg = +let interp_glob_genarg ?loc ~poly env sigma ty arg = let open Genarg in let GenArg (Glbwit tag, arg) = arg in let interp = ConstrInterp.obj tag in - interp env.lvar.ltac_genargs poly env.renamed_env sigma ty arg + interp ?loc ~poly env sigma ty arg diff --git a/pretyping/globEnv.mli b/pretyping/globEnv.mli index 023e24e6d8..40feb8206b 100644 --- a/pretyping/globEnv.mli +++ b/pretyping/globEnv.mli @@ -15,11 +15,18 @@ open EConstr open Ltac_pretype open Evarutil +(** Type of environment extended with naming and ltac interpretation data *) + +type t + (** To embed constr in glob_constr *) +type 'a obj_interp_fun = + ?loc:Loc.t -> poly:bool -> t -> Evd.evar_map -> Evardefine.type_constraint -> + 'a -> unsafe_judgment * Evd.evar_map + val register_constr_interp0 : - ('r, 'g, 't) Genarg.genarg_type -> - (unbound_ltac_var_map -> bool -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit + ('r, 'g, 't) Genarg.genarg_type -> 'g obj_interp_fun -> unit (** {6 Pretyping name management} *) @@ -32,10 +39,6 @@ val register_constr_interp0 : variables used to build purely-named evar contexts *) -(** Type of environment extended with naming and ltac interpretation data *) - -type t - (** Build a pretyping environment from an ltac environment *) val make : hypnaming:naming_mode -> env -> evar_map -> ltac_var_map -> t @@ -43,6 +46,8 @@ val make : hypnaming:naming_mode -> env -> evar_map -> ltac_var_map -> t (** Export the underlying environment *) val env : t -> env +val renamed_env : t -> env +val lfun : t -> unbound_ltac_var_map val vars_of_env : t -> Id.Set.t @@ -85,5 +90,5 @@ val interp_ltac_id : t -> Id.t -> Id.t (** Interpreting a generic argument, typically a "ltac:(...)", taking into account the possible renaming *) -val interp_glob_genarg : t -> bool -> evar_map -> constr -> - Genarg.glob_generic_argument -> constr * evar_map +val interp_glob_genarg : ?loc:Loc.t -> poly:bool -> t -> evar_map -> Evardefine.type_constraint -> + Genarg.glob_generic_argument -> unsafe_judgment * evar_map diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 2c107502f4..b19dbd46be 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -135,8 +135,9 @@ let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = let construct_of_constr const env sigma tag typ = - let t, l = app_type env typ in - match EConstr.kind_upto sigma t with + let typ = Reductionops.clos_whd_flags CClosure.all env sigma (EConstr.of_constr typ) in + let t, l = decompose_appvect (EConstr.Unsafe.to_constr typ) in + match Constr.kind t with | Ind (ind,u) -> construct_of_constr_notnative const env tag ind u l | _ -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 3ccc6ea125..800096f2b3 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -653,12 +653,8 @@ struct sigma, { uj_val; uj_type } | Some arg -> - let sigma, ty = - match tycon with - | Some ty -> sigma, ty - | None -> new_type_evar env sigma ~src:(loc,Evar_kinds.InternalHole) in - let c, sigma = GlobEnv.interp_glob_genarg env poly sigma ty arg in - sigma, { uj_val = c; uj_type = ty } + let j, sigma = GlobEnv.interp_glob_genarg ?loc ~poly env sigma tycon arg in + sigma, j let pretype_rec self (fixkind, names, bl, lar, vdef) = fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index cf6d581066..9939764069 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -78,8 +78,9 @@ let type_constructor mind mib u (ctx, typ) params = -let construct_of_constr const env tag typ = - let (t, allargs) = decompose_appvect (whd_all env typ) in +let construct_of_constr const env sigma tag typ = + let typ = Reductionops.clos_whd_flags CClosure.all env sigma (EConstr.of_constr typ) in + let t, allargs = decompose_appvect (EConstr.Unsafe.to_constr typ) in match Constr.kind t with | Ind ((mind,_ as ind), u as indu) -> let mib,mip = lookup_mind_specif env ind in @@ -92,8 +93,8 @@ let construct_of_constr const env tag typ = assert (Constr.equal t (Typeops.type_of_int env)); (mkInt (Uint63.of_int tag), t) -let construct_of_constr_const env tag typ = - fst (construct_of_constr true env tag typ) +let construct_of_constr_const env sigma tag typ = + fst (construct_of_constr true env sigma tag typ) let construct_of_constr_block = construct_of_constr false @@ -156,7 +157,7 @@ and nf_whd env sigma whd typ = let _, args = nf_args env sigma vargs t in mkApp(cfd,args) | Vconstr_const n -> - construct_of_constr_const env n typ + construct_of_constr_const env sigma n typ | Vconstr_block b -> let tag = btag b in let (tag,ofs) = @@ -165,7 +166,7 @@ and nf_whd env sigma whd typ = | Vconstr_const tag -> (tag+Obj.last_non_constant_constructor_tag, 1) | _ -> assert false else (tag, 0) in - let capp,ctyp = construct_of_constr_block env tag typ in + let capp,ctyp = construct_of_constr_block env sigma tag typ in let args = nf_bargs env sigma b ofs ctyp in mkApp(capp,args) | Vint64 i -> i |> Uint63.of_int64 |> mkInt @@ -414,9 +415,9 @@ let cbv_vm env sigma c t = if Termops.occur_meta sigma c then CErrors.user_err Pp.(str "vm_compute does not support metas."); (* This evar-normalizes terms beforehand *) - let c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c in - let t = EConstr.to_constr ~abort_on_undefined_evars:false sigma t in - let v = Vmsymtable.val_of_constr env c in + let c = EConstr.Unsafe.to_constr c in + let t = EConstr.Unsafe.to_constr t in + let v = Vmsymtable.val_of_constr env (Evd.existential_opt_value0 sigma) c in EConstr.of_constr (nf_val env sigma v t) let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = diff --git a/sysinit/usage.ml b/sysinit/usage.ml index d00b916f23..5886b1c5b5 100644 --- a/sysinit/usage.ml +++ b/sysinit/usage.ml @@ -73,8 +73,6 @@ let print_usage_common co command = \n -debug debug mode (implies -bt)\ \n -xml-debug debug mode and print XML messages to/from coqide\ \n -diffs (on|off|removed) highlight differences between proof steps\ -\n -noglob do not dump globalizations\ -\n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -impredicative-set set sort Set impredicative\ \n -allow-sprop allow using the proof irrelevant SProp sort\ \n -disallow-sprop forbid using the proof irrelevant SProp sort\ diff --git a/tactics/tactics.ml b/tactics/tactics.ml index cbf12ac22f..67bf8d0d29 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2796,7 +2796,24 @@ let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let open Context.Rel.Declaration in let decls,cl = decompose_prod_n_assum sigma i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in - let newdecls,_ = decompose_prod_n_assum sigma i (subst_term_gen sigma EConstr.eq_constr_nounivs c dummy_prod) in + let newdecls,_ = + let c = Termops.collapse_appl sigma c in + let arity = Array.length (snd (Termops.decompose_app_vect sigma c)) in + let cache = ref Int.Map.empty in + let eq sigma k t = + let c = + try Int.Map.find k !cache + with Not_found -> + let c = EConstr.Vars.lift k c in + let () = cache := Int.Map.add k c !cache in + c + in + (* We use a nounivs equality because generalize morally takes a pattern as + argument, so we have to ignore freshly generated sorts. *) + EConstr.eq_constr_nounivs sigma c t + in + decompose_prod_n_assum sigma i (replace_term_gen sigma eq arity (mkRel 1) dummy_prod) + in let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name env sigma c t ids cl' na in let r = Retyping.relevance_of_type env sigma t in diff --git a/test-suite/bugs/closed/bug_13841.v b/test-suite/bugs/closed/bug_13841.v new file mode 100644 index 0000000000..60fca8b49c --- /dev/null +++ b/test-suite/bugs/closed/bug_13841.v @@ -0,0 +1,11 @@ +Goal True. +evar (p : bool). +unify ?p true. +let v := eval vm_compute in (orb p false) in +match v with true => idtac end. +assert (orb p false = true). +vm_compute. +match goal with |- true = _ => idtac end. +easy. +easy. +Qed. diff --git a/test-suite/bugs/closed/bug_13896.v b/test-suite/bugs/closed/bug_13896.v new file mode 100644 index 0000000000..10f24d8564 --- /dev/null +++ b/test-suite/bugs/closed/bug_13896.v @@ -0,0 +1,24 @@ +Inductive type : Set := + Tptr : type -> type + | Tref : type -> type + | Trv_ref : type -> type + | Tint : type -> type -> type + | Tvoid : type + | Tarray : type -> type -> type + | Tnamed : type -> type + | Tfunction : type -> type -> type -> type + | Tbool : type + | Tmember_pointer : type -> type -> type + | Tfloat : type -> type + | Tqualified : type -> type -> type + | Tnullptr : type + | Tarch : type -> type -> type +. +Definition type_eq_dec : forall (ty1 ty2 : type), { ty1 = ty2 } + { ty1 <> ty2 }. +Proof. fix IHty1 1. decide equality. Defined. + +Goal (if type_eq_dec (Tptr Tvoid) (Tptr Tvoid) then True else False). +Proof. +timeout 1 cbn. +constructor. +Qed. diff --git a/test-suite/bugs/closed/bug_7631.v b/test-suite/bugs/closed/bug_7631.v index 93aeb83e28..14ab4de9b7 100644 --- a/test-suite/bugs/closed/bug_7631.v +++ b/test-suite/bugs/closed/bug_7631.v @@ -21,3 +21,9 @@ Definition bar (x := foo) := Eval native_compute in x. Definition barvm (x := foo) := Eval vm_compute in x. End RelContext. + +Definition bar (t:=_) (x := true : t) := Eval native_compute in x. +Definition barvm (t:=_) (x := true : t) := Eval vm_compute in x. + +Definition baz (z:nat) (t:=_ z) (x := true : t) := Eval native_compute in x. +Definition bazvm (z:nat) (t:=_ z) (x := true : t) := Eval vm_compute in x. diff --git a/test-suite/ltac2/ind.v b/test-suite/ltac2/ind.v new file mode 100644 index 0000000000..6f7352d224 --- /dev/null +++ b/test-suite/ltac2/ind.v @@ -0,0 +1,25 @@ +Require Import Ltac2.Ltac2. +Require Import Ltac2.Option. + +Ltac2 Eval + let nat := Option.get (Env.get [@Coq; @Init; @Datatypes; @nat]) in + let nat := match nat with + | Std.IndRef nat => nat + | _ => Control.throw Not_found + end in + let data := Ind.data nat in + (* Check that there is only one inductive in the block *) + let ntypes := Ind.nblocks data in + let () := if Int.equal ntypes 1 then () else Control.throw Not_found in + let nat' := Ind.repr (Ind.get_block data 0) in + (* Check it corresponds *) + let () := if Ind.equal nat nat' then () else Control.throw Not_found in + let () := if Int.equal (Ind.index nat) 0 then () else Control.throw Not_found in + (* Check the number of constructors *) + let nconstr := Ind.nconstructors data in + let () := if Int.equal nconstr 2 then () else Control.throw Not_found in + (* Create a fresh instance *) + let s := Ind.get_constructor data 1 in + let s := Env.instantiate (Std.ConstructRef s) in + constr:($s 0) +. diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v index 6978fa1ddf..a1a4da6f37 100644 --- a/theories/Classes/EquivDec.v +++ b/theories/Classes/EquivDec.v @@ -87,7 +87,7 @@ Program Instance unit_eqdec : EqDec unit eq := fun x y => in_left. Next Obligation. Proof. - destruct x ; destruct y. + do 2 match goal with [ x : () |- _ ] => destruct x end. reflexivity. Qed. @@ -142,7 +142,10 @@ Program Instance list_eqdec `(eqa : EqDec A eq) : EqDec (list A) eq := | _, _ => in_right end }. - Next Obligation. destruct y ; unfold not in *; eauto. Defined. + Next Obligation. + match goal with y : list _ |- _ => destruct y end ; + unfold not in *; eauto. + Defined. Solve Obligations with unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto). diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index 6a98af39aa..3e71a60fa6 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -87,7 +87,7 @@ Tactic Notation "clsubst" "*" := clsubst_nofail. Lemma nequiv_equiv_trans : forall `{Setoid A} (x y z : A), x =/= y -> y == z -> x =/= z. Proof with auto. - intros; intro. + intros A ? x y z H H0 H1. assert(z == y) by (symmetry ; auto). assert(x == y) by (transitivity z ; eauto). contradiction. @@ -95,7 +95,7 @@ Qed. Lemma equiv_nequiv_trans : forall `{Setoid A} (x y z : A), x == y -> y =/= z -> x =/= z. Proof. - intros; intro. + intros A ? x y z **; intro. assert(y == x) by (symmetry ; auto). assert(y == z) by (transitivity x ; eauto). contradiction. diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v index 2947c4831f..f4220e3aa1 100644 --- a/theories/Classes/SetoidDec.v +++ b/theories/Classes/SetoidDec.v @@ -96,7 +96,7 @@ Program Instance unit_eqdec : EqDec (eq_setoid unit) := Next Obligation. Proof. - destruct x ; destruct y. + do 2 match goal with x : () |- _ => destruct x end. reflexivity. Qed. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index 826815410a..69b158a87e 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -71,7 +71,7 @@ Hint Constructors NoDupA : core. Lemma NoDupA_altdef : forall l, NoDupA l <-> ForallOrdPairs (complement eqA) l. Proof. - split; induction 1; constructor; auto. + split; induction 1 as [|a l H rest]; constructor; auto. rewrite Forall_forall. intros b Hb. intro Eq; elim H. rewrite InA_alt. exists b; auto. rewrite InA_alt; intros (a' & Haa' & Ha'). @@ -85,7 +85,7 @@ Definition inclA l l' := forall x, InA x l -> InA x l'. Definition equivlistA l l' := forall x, InA x l <-> InA x l'. Lemma incl_nil l : inclA nil l. -Proof. intro. intros. inversion H. Qed. +Proof. intros a H. inversion H. Qed. #[local] Hint Resolve incl_nil : list. @@ -128,7 +128,7 @@ Qed. Global Instance eqlistA_equiv : Equivalence eqlistA. Proof. constructor; red. - induction x; auto. + intros x; induction x; auto. induction 1; auto. intros x y z H; revert z; induction H; auto. inversion 1; subst; auto. invlist eqlistA; eauto with *. @@ -138,9 +138,9 @@ Qed. Global Instance eqlistA_equivlistA : subrelation eqlistA equivlistA. Proof. - intros x x' H. induction H. + intros x x' H. induction H as [|? ? ? ? H ? IHeqlistA]. intuition. - red; intros. + red; intros x0. rewrite 2 InA_cons. rewrite (IHeqlistA x0), H; intuition. Qed. @@ -165,7 +165,7 @@ Hint Immediate InA_eqA : core. Lemma In_InA : forall l x, In x l -> InA x l. Proof. - simple induction l; simpl; intuition. + intros l; induction l; simpl; intuition. subst; auto. Qed. #[local] @@ -174,8 +174,9 @@ Hint Resolve In_InA : core. Lemma InA_split : forall l x, InA x l -> exists l1 y l2, eqA x y /\ l = l1++y::l2. Proof. -induction l; intros; inv. +intros l; induction l as [|a l IHl]; intros x H; inv. exists (@nil A); exists a; exists l; auto. +match goal with H' : InA x l |- _ => rename H' into H0 end. destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))). exists (a::l1); exists y; exists l2; auto. split; simpl; f_equal; auto. @@ -184,9 +185,10 @@ Qed. Lemma InA_app : forall l1 l2 x, InA x (l1 ++ l2) -> InA x l1 \/ InA x l2. Proof. - induction l1; simpl in *; intuition. + intros l1; induction l1 as [|a l1 IHl1]; simpl in *; intuition. inv; auto. - elim (IHl1 l2 x H0); auto. + match goal with H0' : InA _ (l1 ++ _) |- _ => rename H0' into H0 end. + elim (IHl1 _ _ H0); auto. Qed. Lemma InA_app_iff : forall l1 l2 x, @@ -194,7 +196,7 @@ Lemma InA_app_iff : forall l1 l2 x, Proof. split. apply InA_app. - destruct 1; generalize H; do 2 rewrite InA_alt. + destruct 1 as [H|H]; generalize H; do 2 rewrite InA_alt. destruct 1 as (y,(H1,H2)); exists y; split; auto. apply in_or_app; auto. destruct 1 as (y,(H1,H2)); exists y; split; auto. @@ -240,11 +242,12 @@ Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' -> (forall x, InA x l -> InA x l' -> False) -> NoDupA (l++l'). Proof. -induction l; simpl; auto; intros. +intros l; induction l as [|a l IHl]; simpl; auto; intros l' H H0 H1. inv. constructor. rewrite InA_alt; intros (y,(H4,H5)). destruct (in_app_or _ _ _ H5). +match goal with H2' : ~ InA a l |- _ => rename H2' into H2 end. elim H2. rewrite InA_alt. exists y; auto. @@ -253,13 +256,13 @@ auto. rewrite InA_alt. exists y; auto. apply IHl; auto. -intros. +intros x ? ?. apply (H1 x); auto. Qed. Lemma NoDupA_rev : forall l, NoDupA l -> NoDupA (rev l). Proof. -induction l. +intros l; induction l. simpl; auto. simpl; intros. inv. @@ -270,17 +273,17 @@ intros x. rewrite InA_alt. intros (x1,(H2,H3)). intro; inv. -destruct H0. -rewrite <- H4, H2. +match goal with H0 : ~ InA _ _ |- _ => destruct H0 end. +match goal with H4 : eqA x ?x' |- InA ?x' _ => rewrite <- H4, H2 end. apply In_InA. rewrite In_rev; auto. Qed. Lemma NoDupA_split : forall l l' x, NoDupA (l++x::l') -> NoDupA (l++l'). Proof. - induction l; simpl in *; intros; inv; auto. + intros l; induction l; simpl in *; intros; inv; auto. constructor; eauto. - contradict H0. + match goal with H0 : ~ InA _ _ |- _ => contradict H0 end. rewrite InA_app_iff in *. rewrite InA_cons. intuition. @@ -288,17 +291,17 @@ Qed. Lemma NoDupA_swap : forall l l' x, NoDupA (l++x::l') -> NoDupA (x::l++l'). Proof. - induction l; simpl in *; intros; inv; auto. + intros l; induction l as [|a l IHl]; simpl in *; intros l' x H; inv; auto. constructor; eauto. - assert (H2:=IHl _ _ H1). + match goal with H1 : NoDupA (l ++ x :: l') |- _ => assert (H2:=IHl _ _ H1) end. inv. rewrite InA_cons. red; destruct 1. - apply H0. + match goal with H0 : ~ InA a (l ++ x :: l') |- _ => apply H0 end. rewrite InA_app_iff in *; rewrite InA_cons; auto. - apply H; auto. + auto. constructor. - contradict H0. + match goal with H0 : ~ InA a (l ++ x :: l') |- _ => contradict H0 end. rewrite InA_app_iff in *; rewrite InA_cons; intuition. eapply NoDupA_split; eauto. Qed. @@ -356,19 +359,21 @@ Lemma equivlistA_NoDupA_split l l1 l2 x y : eqA x y -> NoDupA (x::l) -> NoDupA (l1++y::l2) -> equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2). Proof. - intros; intro a. + intros H H0 H1 H2; intro a. generalize (H2 a). rewrite !InA_app_iff, !InA_cons. inv. assert (SW:=NoDupA_swap H1). inv. - rewrite InA_app_iff in H0. + rewrite InA_app_iff in *. split; intros. - assert (~eqA a x) by (contradict H3; rewrite <- H3; auto). + match goal with H3 : ~ InA x l |- _ => + assert (~eqA a x) by (contradict H3; rewrite <- H3; auto) + end. assert (~eqA a y) by (rewrite <- H; auto). tauto. - assert (OR : eqA a x \/ InA a l) by intuition. clear H6. + assert (OR : eqA a x \/ InA a l) by intuition. destruct OR as [EQN|INA]; auto. - elim H0. + match goal with H0 : ~ (InA y l1 \/ InA y l2) |- _ => elim H0 end. rewrite <-H,<-EQN; auto. Qed. @@ -448,7 +453,7 @@ Qed. Lemma ForallOrdPairs_inclA : forall l l', NoDupA l' -> inclA l' l -> ForallOrdPairs R l -> ForallOrdPairs R l'. Proof. -induction l' as [|x l' IH]. +intros l l'. induction l' as [|x l' IH]. constructor. intros ND Incl FOP. apply FOP_cons; inv; unfold inclA in *; auto. rewrite Forall_forall; intros y Hy. @@ -476,7 +481,7 @@ Lemma fold_right_commutes_restr : forall s1 s2 x, ForallOrdPairs R (s1++x::s2) -> eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). Proof. -induction s1; simpl; auto; intros. +intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x H. reflexivity. transitivity (f a (f x (fold_right f i (s1++s2)))). apply Comp; auto. @@ -484,7 +489,9 @@ apply IHs1. invlist ForallOrdPairs; auto. apply TraR. invlist ForallOrdPairs; auto. -rewrite Forall_forall in H0; apply H0. +match goal with H0 : Forall (R a) (s1 ++ x :: s2) |- R a x => + rewrite Forall_forall in H0; apply H0 +end. apply in_or_app; simpl; auto. Qed. @@ -492,14 +499,14 @@ Lemma fold_right_equivlistA_restr : forall s s', NoDupA s -> NoDupA s' -> ForallOrdPairs R s -> equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). Proof. - simple induction s. - destruct s'; simpl. + intros s; induction s as [|x l Hrec]. + intros s'; destruct s' as [|a s']; simpl. intros; reflexivity. - unfold equivlistA; intros. + unfold equivlistA; intros H H0 H1 H2. destruct (H2 a). assert (InA a nil) by auto; inv. - intros x l Hrec s' N N' F E; simpl in *. - assert (InA x s') by (rewrite <- (E x); auto). + intros s' N N' F E; simpl in *. + assert (InA x s') as H by (rewrite <- (E x); auto). destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). subst s'. transitivity (f x (fold_right f i (s1++s2))). @@ -520,7 +527,7 @@ Lemma fold_right_add_restr : forall s' s x, NoDupA s -> NoDupA s' -> ForallOrdPairs R s' -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). Proof. - intros; apply (@fold_right_equivlistA_restr s' (x::s)); auto. + intros s' s x **; apply (@fold_right_equivlistA_restr s' (x::s)); auto. Qed. End Fold_With_Restriction. @@ -532,7 +539,7 @@ Variable Tra :transpose f. Lemma fold_right_commutes : forall s1 s2 x, eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). Proof. -induction s1; simpl; auto; intros. +intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x. reflexivity. transitivity (f a (f x (fold_right f i (s1++s2)))); auto. apply Comp; auto. @@ -542,7 +549,7 @@ Lemma fold_right_equivlistA : forall s s', NoDupA s -> NoDupA s' -> equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). Proof. -intros; apply fold_right_equivlistA_restr with (R:=fun _ _ => True); +intros; apply (fold_right_equivlistA_restr (R:=fun _ _ => True)); repeat red; auto. apply ForallPairs_ForallOrdPairs; try red; auto. Qed. @@ -551,7 +558,7 @@ Lemma fold_right_add : forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). Proof. - intros; apply (@fold_right_equivlistA s' (x::s)); auto. + intros s' s x **; apply (@fold_right_equivlistA s' (x::s)); auto. Qed. End Fold. @@ -571,7 +578,7 @@ Lemma fold_right_eqlistA2 : eqB (fold_right f i s) (fold_right f j s'). Proof. intros s. - induction s;intros. + induction s as [|a s IHs];intros s' i j heqij heqss'. - inversion heqss'. subst. simpl. @@ -604,7 +611,7 @@ Lemma fold_right_commutes_restr2 : forall s1 s2 x (i j:B) (heqij: eqB i j), ForallOrdPairs R (s1++x::s2) -> eqB (fold_right f i (s1++x::s2)) (f x (fold_right f j (s1++s2))). Proof. -induction s1; simpl; auto; intros. +intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x i j heqij ?. - apply Comp. + destruct eqA_equiv. apply Equivalence_Reflexive. + eapply fold_right_eqlistA2. @@ -617,7 +624,9 @@ induction s1; simpl; auto; intros. invlist ForallOrdPairs; auto. apply TraR. invlist ForallOrdPairs; auto. - rewrite Forall_forall in H0; apply H0. + match goal with H0 : Forall (R a) (s1 ++ x :: s2) |- _ => + rewrite Forall_forall in H0; apply H0 + end. apply in_or_app; simpl; auto. reflexivity. Qed. @@ -628,14 +637,14 @@ Lemma fold_right_equivlistA_restr2 : equivlistA s s' -> eqB i j -> eqB (fold_right f i s) (fold_right f j s'). Proof. - simple induction s. - destruct s'; simpl. + intros s; induction s as [|x l Hrec]. + intros s'; destruct s' as [|a s']; simpl. intros. assumption. - unfold equivlistA; intros. + unfold equivlistA; intros ? ? H H0 H1 H2 **. destruct (H2 a). assert (InA a nil) by auto; inv. - intros x l Hrec s' i j N N' F E eqij; simpl in *. - assert (InA x s') by (rewrite <- (E x); auto). + intros s' i j N N' F E eqij; simpl in *. + assert (InA x s') as H by (rewrite <- (E x); auto). destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). subst s'. transitivity (f x (fold_right f j (s1++s2))). @@ -663,7 +672,7 @@ Lemma fold_right_add_restr2 : forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ForallOrdPairs R s' -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)). Proof. - intros; apply (@fold_right_equivlistA_restr2 s' (x::s) i j); auto. + intros s' s i j x **; apply (@fold_right_equivlistA_restr2 s' (x::s) i j); auto. Qed. End Fold2_With_Restriction. @@ -674,7 +683,7 @@ Lemma fold_right_commutes2 : forall s1 s2 i x x', eqA x x' -> eqB (fold_right f i (s1++x::s2)) (f x' (fold_right f i (s1++s2))). Proof. - induction s1;simpl;intros. + intros s1; induction s1 as [|a s1 IHs1];simpl;intros s2 i x x' H. - apply Comp;auto. reflexivity. - transitivity (f a (f x' (fold_right f i (s1++s2)))); auto. @@ -688,7 +697,7 @@ Lemma fold_right_equivlistA2 : equivlistA s s' -> eqB (fold_right f i s) (fold_right f j s'). Proof. red in Tra. -intros; apply fold_right_equivlistA_restr2 with (R:=fun _ _ => True); +intros; apply (fold_right_equivlistA_restr2 (R:=fun _ _ => True)); repeat red; auto. apply ForallPairs_ForallOrdPairs; try red; auto. Qed. @@ -697,9 +706,9 @@ Lemma fold_right_add2 : forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)). Proof. - intros. + intros s' s i j x **. replace (f x (fold_right f j s)) with (fold_right f j (x::s)) by auto. - eapply fold_right_equivlistA2;auto. + eapply fold_right_equivlistA2;auto. Qed. End Fold2. @@ -710,7 +719,7 @@ Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }. Proof. -induction l. +intros x l; induction l as [|a l IHl]. right; auto. intro; inv. destruct (eqA_dec x a). @@ -729,28 +738,30 @@ Fixpoint removeA (x : A) (l : list A) : list A := Lemma removeA_filter : forall x l, removeA x l = filter (fun y => if eqA_dec x y then false else true) l. Proof. -induction l; simpl; auto. +intros x l; induction l as [|a l IHl]; simpl; auto. destruct (eqA_dec x a); auto. rewrite IHl; auto. Qed. Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y. Proof. -induction l; simpl; auto. -split. +intros l; induction l as [|a l IHl]; simpl; auto. +intros x y; split. intro; inv. destruct 1; inv. -intros. +intros x y. destruct (eqA_dec x a) as [Heq|Hnot]; simpl; auto. rewrite IHl; split; destruct 1; split; auto. inv; auto. -destruct H0; transitivity a; auto. +match goal with H0 : ~ eqA x y |- _ => destruct H0 end; transitivity a; auto. split. intro; inv. split; auto. contradict Hnot. transitivity y; auto. -rewrite (IHl x y) in H0; destruct H0; auto. +match goal with H0 : InA y (removeA x l) |- _ => + rewrite (IHl x y) in H0; destruct H0; auto +end. destruct 1; inv; auto. right; rewrite IHl; auto. Qed. @@ -758,7 +769,7 @@ Qed. Lemma removeA_NoDupA : forall s x, NoDupA s -> NoDupA (removeA x s). Proof. -simple induction s; simpl; intros. +intros s; induction s as [|a s IHs]; simpl; intros x ?. auto. inv. destruct (eqA_dec x a); simpl; auto. @@ -770,16 +781,16 @@ Qed. Lemma removeA_equivlistA : forall l l' x, ~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l'). Proof. -unfold equivlistA; intros. +unfold equivlistA; intros l l' x H H0 x0. rewrite removeA_InA. -split; intros. +split; intros H1. rewrite <- H0; split; auto. contradict H. apply InA_eqA with x0; auto. rewrite <- (H0 x0) in H1. destruct H1. inv; auto. -elim H2; auto. +match goal with H2 : ~ eqA x x0 |- _ => elim H2; auto end. Qed. End Remove. @@ -806,7 +817,7 @@ Hint Constructors lelistA sort : core. Lemma InfA_ltA : forall l x y, ltA x y -> InfA y l -> InfA x l. Proof. - destruct l; constructor. inv; eauto. + intros l; destruct l; constructor. inv; eauto. Qed. Global Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA. @@ -815,8 +826,8 @@ Proof using eqA_equiv ltA_compat. (* and not ltA_strorder *) inversion_clear Hll'. intuition. split; intro; inv; constructor. - rewrite <- Hxx', <- H; auto. - rewrite Hxx', H; auto. + match goal with H : eqA _ _ |- _ => rewrite <- Hxx', <- H; auto end. + match goal with H : eqA _ _ |- _ => rewrite Hxx', H; auto end. Qed. (** For compatibility, can be deduced from [InfA_compat] *) @@ -830,9 +841,9 @@ Hint Immediate InfA_ltA InfA_eqA : core. Lemma SortA_InfA_InA : forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x. Proof. - simple induction l. - intros. inv. - intros. inv. + intros l; induction l as [|a l IHl]. + intros x a **. inv. + intros x a0 **. inv. setoid_replace x with a; auto. eauto. Qed. @@ -840,13 +851,13 @@ Qed. Lemma In_InfA : forall l x, (forall y, In y l -> ltA x y) -> InfA x l. Proof. - simple induction l; simpl; intros; constructor; auto. + intros l; induction l; simpl; intros; constructor; auto. Qed. Lemma InA_InfA : forall l x, (forall y, InA y l -> ltA x y) -> InfA x l. Proof. - simple induction l; simpl; intros; constructor; auto. + intros l; induction l; simpl; intros; constructor; auto. Qed. (* In fact, this may be used as an alternative definition for InfA: *) @@ -861,7 +872,7 @@ Qed. Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2). Proof. - induction l1; simpl; auto. + intros l1; induction l1; simpl; auto. intros; inv; auto. Qed. @@ -870,7 +881,7 @@ Lemma SortA_app : (forall x y, InA x l1 -> InA y l2 -> ltA x y) -> SortA (l1 ++ l2). Proof. - induction l1; simpl in *; intuition. + intros l1; induction l1; intros l2; simpl in *; intuition. inv. constructor; auto. apply InfA_app; auto. @@ -879,8 +890,8 @@ Qed. Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l. Proof. - simple induction l; auto. - intros x l' H H0. + intros l; induction l as [|x l' H]; auto. + intros H0. inv. constructor; auto. intro. @@ -922,7 +933,7 @@ Qed. Global Instance rev_eqlistA_compat : Proper (eqlistA==>eqlistA) (@rev A). Proof. -repeat red. intros. +repeat red. intros x y ?. rewrite <- (app_nil_r (rev x)), <- (app_nil_r (rev y)). apply eqlistA_rev_app; auto. Qed. @@ -936,15 +947,15 @@ Qed. Lemma SortA_equivlistA_eqlistA : forall l l', SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'. Proof. -induction l; destruct l'; simpl; intros; auto. -destruct (H1 a); assert (InA a nil) by auto; inv. +intros l; induction l as [|a l IHl]; intros l'; destruct l' as [|a0 l']; simpl; intros H H0 H1; auto. +destruct (H1 a0); assert (InA a0 nil) by auto; inv. destruct (H1 a); assert (InA a nil) by auto; inv. inv. assert (forall y, InA y l -> ltA a y). -intros; eapply SortA_InfA_InA with (l:=l); eauto. +intros; eapply (SortA_InfA_InA (l:=l)); eauto. assert (forall y, InA y l' -> ltA a0 y). -intros; eapply SortA_InfA_InA with (l:=l'); eauto. -clear H3 H4. +intros; eapply (SortA_InfA_InA (l:=l')); eauto. +do 2 match goal with H : InfA _ _ |- _ => clear H end. assert (eqA a a0). destruct (H1 a). destruct (H1 a0). @@ -953,13 +964,19 @@ assert (eqA a a0). elim (StrictOrder_Irreflexive a); eauto. constructor; auto. apply IHl; auto. -split; intros. +intros x; split; intros. destruct (H1 x). assert (InA x (a0::l')) by auto. inv; auto. -rewrite H9,<-H3 in H4. elim (StrictOrder_Irreflexive a); eauto. +match goal with H3 : eqA a a0, H4 : InA x l, H9 : eqA x a0 |- InA x l' => + rewrite H9,<-H3 in H4 +end. +elim (StrictOrder_Irreflexive a); eauto. destruct (H1 x). assert (InA x (a::l)) by auto. inv; auto. -rewrite H9,H3 in H4. elim (StrictOrder_Irreflexive a0); eauto. +match goal with H3 : eqA a a0, H4 : InA x l', H9 : eqA x a |- InA x l => + rewrite H9,H3 in H4 +end. +elim (StrictOrder_Irreflexive a0); eauto. Qed. End EqlistA. @@ -970,12 +987,12 @@ Section Filter. Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l). Proof. -induction l; simpl; auto. +intros f l; induction l as [|a l IHl]; simpl; auto. intros; inv; auto. destruct (f a); auto. constructor; auto. apply In_InfA; auto. -intros. +intros y H. rewrite filter_In in H; destruct H. eapply SortA_InfA_InA; eauto. Qed. @@ -984,12 +1001,14 @@ Arguments eq {A} x _. Lemma filter_InA : forall f, Proper (eqA==>eq) f -> forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true. Proof. +(* Unset Mangle Names. *) clear sotrans ltA ltA_strorder ltA_compat. -intros; do 2 rewrite InA_alt; intuition. -destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition. -destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; intuition. +intros f H l x; do 2 rewrite InA_alt; intuition; + match goal with Hex' : exists _, _ |- _ => rename Hex' into Hex end. +destruct Hex as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition. +destruct Hex as (y,(H0,H1)); rewrite filter_In in H1; intuition. rewrite (H _ _ H0); auto. -destruct H1 as (y,(H0,H1)); exists y; rewrite filter_In; intuition. +destruct Hex as (y,(H0,H1)); exists y; rewrite filter_In; intuition. rewrite <- (H _ _ H0); auto. Qed. @@ -997,19 +1016,20 @@ Lemma filter_split : forall f, (forall x y, f x = true -> f y = false -> ltA x y) -> forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l. Proof. -induction l; simpl; intros; auto. +intros f H l; induction l as [|a l IHl]; simpl; intros H0; auto. inv. +match goal with H1' : SortA l, H2' : InfA a l |- _ => rename H1' into H1, H2' into H2 end. rewrite IHl at 1; auto. case_eq (f a); simpl; intros; auto. -assert (forall e, In e l -> f e = false). - intros. +assert (forall e, In e l -> f e = false) as H3. + intros e H3. assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)). case_eq (f e); simpl; intros; auto. elim (StrictOrder_Irreflexive e). transitivity a; auto. replace (List.filter f l) with (@nil A); auto. -generalize H3; clear; induction l; simpl; auto. -case_eq (f a); auto; intros. +generalize H3; clear; induction l as [|a l IHl]; simpl; auto. +case_eq (f a); auto; intros H H3. rewrite H3 in H; auto; try discriminate. Qed. @@ -1043,23 +1063,24 @@ Lemma findA_NoDupA : Proof. set (eqk := fun p p' : A*B => eqA (fst p) (fst p')). set (eqke := fun p p' : A*B => eqA (fst p) (fst p') /\ snd p = snd p'). -induction l; intros; simpl. -split; intros; try discriminate. +intros l; induction l as [|a l IHl]; intros a0 b H; simpl. +split; intros H0; try discriminate. invlist InA. destruct a as (a',b'); rename a0 into a. invlist NoDupA. split; intros. invlist InA. -compute in H2; destruct H2. subst b'. +match goal with H2 : eqke (a, b) (a', b') |- _ => compute in H2; destruct H2 end. +subst b'. destruct (eqA_dec a a'); intuition. destruct (eqA_dec a a') as [HeqA|]; simpl. -contradict H0. -revert HeqA H2; clear - eqA_equiv. +match goal with H0 : ~ InA eqk (a', b') l |- _ => contradict H0 end. +match goal with H2 : InA eqke (a, b) l |- _ => revert HeqA H2; clear - eqA_equiv end. induction l. intros; invlist InA. intros; invlist InA; auto. -destruct a0. -compute in H; destruct H. +match goal with |- InA eqk _ (?p :: _) => destruct p as [a0 b0] end. +match goal with H : eqke (a, b) (a0, b0) |- _ => compute in H; destruct H end. subst b. left; auto. compute. diff --git a/theories/Logic/ProofIrrelevanceFacts.v b/theories/Logic/ProofIrrelevanceFacts.v index 131668154e..7560ea96b5 100644 --- a/theories/Logic/ProofIrrelevanceFacts.v +++ b/theories/Logic/ProofIrrelevanceFacts.v @@ -27,7 +27,7 @@ Module ProofIrrelevanceTheory (M:ProofIrrelevance). forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. Proof. - intros; rewrite M.proof_irrelevance with (p1:=h) (p2:=eq_refl p). + intros U p Q x h; rewrite (M.proof_irrelevance _ h (eq_refl p)). reflexivity. Qed. End Eq_rect_eq. @@ -45,8 +45,8 @@ Module ProofIrrelevanceTheory (M:ProofIrrelevance). forall (U:Type) (P:U->Prop) (x y:U) (p:P x) (q:P y), x = y -> exist P x p = exist P y q. Proof. - intros. - rewrite M.proof_irrelevance with (p1:=q) (p2:=eq_rect x P p y H). + intros U P x y p q H. + rewrite (M.proof_irrelevance _ q (eq_rect x P p y H)). elim H using eq_indd. reflexivity. Qed. @@ -55,8 +55,8 @@ Module ProofIrrelevanceTheory (M:ProofIrrelevance). forall (U:Type) (P:U->Prop) (x y:U) (p:P x) (q:P y), x = y -> existT P x p = existT P y q. Proof. - intros. - rewrite M.proof_irrelevance with (p1:=q) (p2:=eq_rect x P p y H). + intros U P x y p q H. + rewrite (M.proof_irrelevance _ q (eq_rect x P p y H)). elim H using eq_indd. reflexivity. Qed. diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v index 9788ad50dc..9540bc1075 100644 --- a/theories/Program/Subset.v +++ b/theories/Program/Subset.v @@ -68,10 +68,11 @@ Ltac pi := repeat f_equal ; apply proof_irrelevance. Lemma subset_eq : forall A (P : A -> Prop) (n m : sig P), n = m <-> `n = `m. Proof. + intros A P n m. destruct n as (x,p). destruct m as (x',p'). simpl. - split ; intros ; subst. + split ; intros H ; subst. - inversion H. reflexivity. @@ -92,7 +93,7 @@ Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : {y : A | y = x} -> B) (y : {y:A | y = x}), match_eq A B x fn = fn y. Proof. - intros. + intros A B x fn y. unfold match_eq. f_equal. destruct y. diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v index 206eb606d2..422316d879 100644 --- a/theories/Sorting/Sorted.v +++ b/theories/Sorting/Sorted.v @@ -71,6 +71,7 @@ Section defs. (forall a l, Sorted l -> P l -> HdRel a l -> P (a :: l)) -> forall l:list A, Sorted l -> P l. Proof. + intros P ? ? l. induction l. firstorder using Sorted_inv. firstorder using Sorted_inv. Qed. @@ -78,7 +79,8 @@ Section defs. Proof. split; [induction 1 as [|a l [|]]| induction 1]; auto using Sorted, LocallySorted, HdRel. - inversion H1; subst; auto using LocallySorted. + match goal with H1 : HdRel a (_ :: _) |- _ => inversion H1 end. + subst; auto using LocallySorted. Qed. (** Strongly sorted: elements of the list are pairwise ordered *) @@ -90,7 +92,7 @@ Section defs. Lemma StronglySorted_inv : forall a l, StronglySorted (a :: l) -> StronglySorted l /\ Forall (R a) l. Proof. - intros; inversion H; auto. + intros a l H; inversion H; auto. Defined. Lemma StronglySorted_rect : @@ -99,7 +101,7 @@ Section defs. (forall a l, StronglySorted l -> P l -> Forall (R a) l -> P (a :: l)) -> forall l, StronglySorted l -> P l. Proof. - induction l; firstorder using StronglySorted_inv. + intros P ? ? l; induction l; firstorder using StronglySorted_inv. Defined. Lemma StronglySorted_rec : @@ -120,7 +122,8 @@ Section defs. Lemma Sorted_extends : Transitive R -> forall a l, Sorted (a::l) -> Forall (R a) l. Proof. - intros. change match a :: l with [] => True | a :: l => Forall (R a) l end. + intros H a l H0. + change match a :: l with [] => True | a :: l => Forall (R a) l end. induction H0 as [|? ? ? ? H1]; [trivial|]. destruct H1; constructor; trivial. eapply Forall_impl; [|eassumption]. diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v index c923b503a7..a49e21fa92 100644 --- a/theories/Structures/DecidableType.v +++ b/theories/Structures/DecidableType.v @@ -93,7 +93,7 @@ Module KeyDecidableType(D:DecidableType). Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. Proof. - intros; apply InA_eqA with p; auto using eqk_equiv. + intros p q m **; apply InA_eqA with p; auto using eqk_equiv. Qed. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). @@ -106,18 +106,18 @@ Module KeyDecidableType(D:DecidableType). Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. Proof. - firstorder. - exists x; auto. - induction H. - destruct y. - exists e; auto. - destruct IHInA as [e H0]. + intros k l; split; intros [y H]. + exists y; auto. + induction H as [a l eq|a l H IH]. + destruct a as [k' y']. + exists y'; auto. + destruct IH as [e H0]. exists e; auto. Qed. Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. Proof. - intros; unfold MapsTo in *; apply InA_eqA with (x,e); auto using eqke_equiv. + intros l x y e **; unfold MapsTo in *; apply InA_eqA with (x,e); auto using eqke_equiv. Qed. Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. @@ -127,21 +127,21 @@ Module KeyDecidableType(D:DecidableType). Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. Proof. - inversion 1. - inversion_clear H0; eauto. + inversion 1 as [? H0]. + inversion_clear H0 as [? ? H1|]; eauto. destruct H1; simpl in *; intuition. Qed. Lemma In_inv_2 : forall k k' e e' l, InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. Proof. - inversion_clear 1; compute in H0; intuition. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. Qed. Lemma In_inv_3 : forall x x' l, InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. Proof. - inversion_clear 1; compute in H0; intuition. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. Qed. End Elt. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index dc7a48cd6b..7bc9f97e2b 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -65,7 +65,7 @@ Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType. Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. Proof with auto with ordered_type. - intros; elim (compare x y); intro H; [ right | left | right ]... + intros x y; elim (compare x y); intro H; [ right | left | right ]... assert (~ eq y x)... Defined. @@ -83,7 +83,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_antirefl : forall x, ~ lt x x. Proof. - intros; intro; absurd (eq x x); auto with ordered_type. + intros x; intro; absurd (eq x x); auto with ordered_type. Qed. Instance lt_strorder : StrictOrder lt. @@ -91,14 +91,14 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. Proof with auto with ordered_type. - intros; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. + intros x y z H ?; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. elim (lt_not_eq H); apply eq_trans with z... elim (lt_not_eq (lt_trans Hlt H))... Qed. Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. Proof with auto with ordered_type. - intros; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. + intros x y z H H0; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. elim (lt_not_eq H0); apply eq_trans with x... elim (lt_not_eq (lt_trans H0 Hlt))... Qed. @@ -111,7 +111,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Qed. Lemma lt_total : forall x y, lt x y \/ eq x y \/ lt y x. - Proof. intros; destruct (compare x y); auto. Qed. + Proof. intros x y; destruct (compare x y); auto. Qed. Module TO. Definition t := t. @@ -157,7 +157,7 @@ Module OrderedTypeFacts (Import O: OrderedType). forall x y : t, eq x y -> exists H : eq x y, compare x y = EQ H. Proof. - intros; case (compare x y); intros H'; try (exfalso; order). + intros x y H; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. Qed. @@ -165,7 +165,7 @@ Module OrderedTypeFacts (Import O: OrderedType). forall x y : t, lt x y -> exists H : lt x y, compare x y = LT H. Proof. - intros; case (compare x y); intros H'; try (exfalso; order). + intros x y H; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. Qed. @@ -173,7 +173,7 @@ Module OrderedTypeFacts (Import O: OrderedType). forall x y : t, lt y x -> exists H : lt y x, compare x y = GT H. Proof. - intros; case (compare x y); intros H'; try (exfalso; order). + intros x y H; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. Qed. @@ -203,7 +203,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. Proof. - intros; elim (compare x y); [ left | right | right ]; auto with ordered_type. + intros x y; elim (compare x y); [ left | right | right ]; auto with ordered_type. Defined. Definition eqb x y : bool := if eq_dec x y then true else false. @@ -211,7 +211,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma eqb_alt : forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. Proof. - unfold eqb; intros; destruct (eq_dec x y); elim_comp; auto. + unfold eqb; intros x y; destruct (eq_dec x y); elim_comp; auto. Qed. (* Specialization of results about lists modulo. *) @@ -327,7 +327,7 @@ Module KeyOrderedType(O:OrderedType). Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. Proof. unfold eqke, ltk; intuition; simpl in *; subst. - exact (lt_not_eq H H1). + match goal with H : lt _ _, H1 : eq _ _ |- _ => exact (lt_not_eq H H1) end. Qed. #[local] @@ -398,18 +398,18 @@ Module KeyOrderedType(O:OrderedType). Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. Proof with auto with ordered_type. - firstorder. - exists x... - induction H. - destruct y. - exists e... - destruct IHInA as [e H0]. + intros k l; split; intros [y H]. + exists y... + induction H as [a l eq|a l H IH]. + destruct a as [k' y']. + exists y'... + destruct IH as [e H0]. exists e... Qed. Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. Proof. - intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *. + intros l x y e **; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *. Qed. Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. @@ -437,7 +437,7 @@ Module KeyOrderedType(O:OrderedType). Lemma Sort_Inf_NotIn : forall l k e, Sort l -> Inf (k,e) l -> ~In k l. Proof. - intros; red; intros. + intros l k e H H0; red; intros H1. destruct H1 as [e' H2]. elim (@ltk_not_eqk (k,e) (k,e')). eapply Sort_Inf_In; eauto with ordered_type. @@ -457,34 +457,34 @@ Module KeyOrderedType(O:OrderedType). Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> ltk e e' \/ eqk e e'. Proof. - inversion_clear 2; auto with ordered_type. + intros l; inversion_clear 2; auto with ordered_type. left; apply Sort_In_cons_1 with l; auto. Qed. Lemma Sort_In_cons_3 : forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k. Proof. - inversion_clear 1; red; intros. + inversion_clear 1 as [|? ? H0 H1]; red; intros H H2. destruct (Sort_Inf_NotIn H0 H1 (In_eq H2 H)). Qed. Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. Proof. - inversion 1. - inversion_clear H0; eauto with ordered_type. + inversion 1 as [? H0]. + inversion_clear H0 as [? ? H1|]; eauto with ordered_type. destruct H1; simpl in *; intuition. Qed. Lemma In_inv_2 : forall k k' e e' l, InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. Proof. - inversion_clear 1; compute in H0; intuition. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. Qed. Lemma In_inv_3 : forall x x' l, InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. Proof. - inversion_clear 1; compute in H0; intuition. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. Qed. End Elt. diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index b7af66b2ee..b78bcce6db 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -26,6 +26,8 @@ let coqc_specific_usage = Usage.{ coqc specific options:\ \n -o f.vo use f.vo as the output file name\ \n -verbose compile and output the input file\ +\n -noglob do not dump globalizations\ +\n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\ \n into fi.vo\ \n -schedule-vio-checking j f1..fn run up to j instances of Coq to check all\ diff --git a/user-contrib/Ltac2/Ind.v b/user-contrib/Ltac2/Ind.v new file mode 100644 index 0000000000..f397a0e2c8 --- /dev/null +++ b/user-contrib/Ltac2/Ind.v @@ -0,0 +1,45 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +From Ltac2 Require Import Init. + +Ltac2 Type t := inductive. + +Ltac2 @ external equal : t -> t -> bool := "ltac2" "ind_equal". +(** Equality test. *) + +Ltac2 Type data. +(** Type of data representing inductive blocks. *) + +Ltac2 @ external data : t -> data := "ltac2" "ind_data". +(** Get the mutual blocks corresponding to an inductive type in the current + environment. Panics if there is no such inductive. *) + +Ltac2 @ external repr : data -> t := "ltac2" "ind_repr". +(** Returns the inductive corresponding to the block. Inverse of [data]. *) + +Ltac2 @ external index : t -> int := "ltac2" "ind_index". +(** Returns the index of the inductive type inside its mutual block. Guaranteed + to range between [0] and [nblocks data - 1] where [data] was retrieved + using the above function. *) + +Ltac2 @ external nblocks : data -> int := "ltac2" "ind_nblocks". +(** Returns the number of inductive types appearing in a mutual block. *) + +Ltac2 @ external nconstructors : data -> int := "ltac2" "ind_nconstructors". +(** Returns the number of constructors appearing in the current block. *) + +Ltac2 @ external get_block : data -> int -> data := "ltac2" "ind_get_block". +(** Returns the block corresponding to the nth inductive type. Index must range + between [0] and [nblocks data - 1], otherwise the function panics. *) + +Ltac2 @ external get_constructor : data -> int -> constructor := "ltac2" "ind_get_constructor". +(** Returns the nth constructor of the inductive type. Index must range between + [0] and [nconstructors data - 1], otherwise the function panics. *) diff --git a/user-contrib/Ltac2/Ltac2.v b/user-contrib/Ltac2/Ltac2.v index ccfc7e4a70..e55c6c13d3 100644 --- a/user-contrib/Ltac2/Ltac2.v +++ b/user-contrib/Ltac2/Ltac2.v @@ -22,6 +22,7 @@ Require Ltac2.Fresh. Require Ltac2.Pattern. Require Ltac2.Std. Require Ltac2.Env. +Require Ltac2.Ind. Require Ltac2.Printf. Require Ltac2.Ltac1. Require Export Ltac2.Notations. diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 948a359124..bcf9ece7c8 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -1075,6 +1075,54 @@ let () = define1 "env_instantiate" reference begin fun r -> return (Value.of_constr c) end +(** Ind *) + +let () = define2 "ind_equal" (repr_ext val_inductive) (repr_ext val_inductive) begin fun ind1 ind2 -> + return (Value.of_bool (Ind.UserOrd.equal ind1 ind2)) +end + +let () = define1 "ind_data" (repr_ext val_inductive) begin fun ind -> + Proofview.tclENV >>= fun env -> + if Environ.mem_mind (fst ind) env then + let mib = Environ.lookup_mind (fst ind) env in + return (Value.of_ext val_ind_data (ind, mib)) + else + throw err_notfound +end + +let () = define1 "ind_repr" (repr_ext val_ind_data) begin fun (ind, _) -> + return (Value.of_ext val_inductive ind) +end + +let () = define1 "ind_index" (repr_ext val_inductive) begin fun (ind, n) -> + return (Value.of_int n) +end + +let () = define1 "ind_nblocks" (repr_ext val_ind_data) begin fun (ind, mib) -> + return (Value.of_int (Array.length mib.Declarations.mind_packets)) +end + +let () = define1 "ind_nconstructors" (repr_ext val_ind_data) begin fun ((_, n), mib) -> + let open Declarations in + return (Value.of_int (Array.length mib.mind_packets.(n).mind_consnames)) +end + +let () = define2 "ind_get_block" (repr_ext val_ind_data) int begin fun (ind, mib) n -> + if 0 <= n && n < Array.length mib.Declarations.mind_packets then + return (Value.of_ext val_ind_data ((fst ind, n), mib)) + else throw err_notfound +end + +let () = define2 "ind_get_constructor" (repr_ext val_ind_data) int begin fun ((mind, n), mib) i -> + let open Declarations in + let ncons = Array.length mib.mind_packets.(n).mind_consnames in + if 0 <= i && i < ncons then + (* WARNING: In the ML API constructors are indexed from 1 for historical + reasons, but Ltac2 uses 0-indexing instead. *) + return (Value.of_ext val_constructor ((mind, n), i + 1)) + else throw err_notfound +end + (** Ltac1 in Ltac2 *) let ltac1 = Tac2ffi.repr_ext Value.val_ltac1 @@ -1388,24 +1436,35 @@ let () = (** Ltac2 in terms *) let () = - let interp ist poly env sigma concl (ids, tac) = + let interp ?loc ~poly env sigma tycon (ids, tac) = (* Syntax prevents bound notation variables in constr quotations *) let () = assert (Id.Set.is_empty ids) in - let ist = Tac2interp.get_env ist in + let ist = Tac2interp.get_env @@ GlobEnv.lfun env in let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in let name, poly = Id.of_string "ltac2", poly in - let c, sigma = Proof.refine_by_tactic ~name ~poly env sigma concl tac in - (EConstr.of_constr c, sigma) + let sigma, concl = match tycon with + | Some ty -> sigma, ty + | None -> GlobEnv.new_type_evar env sigma ~src:(loc,Evar_kinds.InternalHole) + in + let c, sigma = Proof.refine_by_tactic ~name ~poly (GlobEnv.renamed_env env) sigma concl tac in + let j = { Environ.uj_val = EConstr.of_constr c; Environ.uj_type = concl } in + (j, sigma) in GlobEnv.register_constr_interp0 wit_ltac2_constr interp let () = - let interp ist poly env sigma concl id = - let ist = Tac2interp.get_env ist in + let interp ?loc ~poly env sigma tycon id = + let ist = Tac2interp.get_env @@ GlobEnv.lfun env in let c = Id.Map.find id ist.env_ist in let c = Value.to_constr c in - let sigma = Typing.check env sigma c concl in - (c, sigma) + let t = Retyping.get_type_of (GlobEnv.renamed_env env) sigma c in + match tycon with + | None -> + { Environ.uj_val = c; Environ.uj_type = t }, sigma + | Some ty -> + let sigma = Evarconv.unify_leq_delay (GlobEnv.renamed_env env) sigma t ty in + let j = { Environ.uj_val = c; Environ.uj_type = ty } in + j, sigma in GlobEnv.register_constr_interp0 wit_ltac2_quotation interp diff --git a/user-contrib/Ltac2/tac2ffi.ml b/user-contrib/Ltac2/tac2ffi.ml index a09438c6bf..5f9fbc4e41 100644 --- a/user-contrib/Ltac2/tac2ffi.ml +++ b/user-contrib/Ltac2/tac2ffi.ml @@ -104,6 +104,7 @@ let val_binder = Val.create "binder" let val_univ = Val.create "universe" let val_free : Names.Id.Set.t Val.tag = Val.create "free" let val_ltac1 : Geninterp.Val.t Val.tag = Val.create "ltac1" +let val_ind_data : (Names.Ind.t * Declarations.mutual_inductive_body) Val.tag = Val.create "ind_data" let extract_val (type a) (type b) (tag : a Val.tag) (tag' : b Val.tag) (v : b) : a = match Val.eq tag tag' with diff --git a/user-contrib/Ltac2/tac2ffi.mli b/user-contrib/Ltac2/tac2ffi.mli index c9aa50389e..e87ad7139c 100644 --- a/user-contrib/Ltac2/tac2ffi.mli +++ b/user-contrib/Ltac2/tac2ffi.mli @@ -184,6 +184,7 @@ val val_binder : (Name.t Context.binder_annot * types) Val.tag val val_univ : Univ.Level.t Val.tag val val_free : Id.Set.t Val.tag val val_ltac1 : Geninterp.Val.t Val.tag +val val_ind_data : (Names.Ind.t * Declarations.mutual_inductive_body) Val.tag val val_exn : Exninfo.iexn Tac2dyn.Val.tag (** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] |