diff options
-rw-r--r-- | pretyping/clenv.ml | 91 | ||||
-rw-r--r-- | pretyping/clenv.mli | 8 | ||||
-rw-r--r-- | pretyping/evd.ml | 6 | ||||
-rw-r--r-- | pretyping/evd.mli | 2 | ||||
-rw-r--r-- | pretyping/reductionops.ml | 19 | ||||
-rw-r--r-- | pretyping/reductionops.mli | 1 | ||||
-rw-r--r-- | pretyping/unification.ml | 2 | ||||
-rw-r--r-- | proofs/clenvtac.ml | 27 | ||||
-rw-r--r-- | tactics/auto.ml | 6 | ||||
-rw-r--r-- | tactics/class_tactics.ml4 | 21 | ||||
-rw-r--r-- | tactics/equality.ml | 2 | ||||
-rw-r--r-- | tactics/setoid_replace.ml | 2 | ||||
-rw-r--r-- | tactics/tactics.ml | 6 | ||||
-rw-r--r-- | test-suite/success/apply.v | 19 |
14 files changed, 70 insertions, 142 deletions
diff --git a/pretyping/clenv.ml b/pretyping/clenv.ml index c5c246877..732ff1e69 100644 --- a/pretyping/clenv.ml +++ b/pretyping/clenv.ml @@ -54,77 +54,11 @@ let subst_clenv sub clenv = env = clenv.env } let clenv_nf_meta clenv c = nf_meta clenv.evd c -let clenv_direct_nf_meta clenv c = direct_nf_meta clenv.evd c let clenv_term clenv c = meta_instance clenv.evd c let clenv_meta_type clenv mv = Typing.meta_type clenv.evd mv let clenv_value clenv = meta_instance clenv.evd clenv.templval -let clenv_direct_value clenv = nf_betaiota clenv.templval.rebus let clenv_type clenv = meta_instance clenv.evd clenv.templtyp -let clenv_direct_nf_type clenv = nf_betaiota clenv.templtyp.rebus - -let plain_instance find c = - let rec irec u = match kind_of_term u with - | Meta p -> find p - | App (f,l) when isCast f -> - let (f,_,t) = destCast f in - let l' = Array.map irec l in - (match kind_of_term f with - | Meta p -> - (* Don't flatten application nodes: this is used to extract a - proof-term from a proof-tree and we want to keep the structure - of the proof-tree *) - let g = find p in - (match kind_of_term g with - | App _ -> - let h = id_of_string "H" in - mkLetIn (Name h,g,t,mkApp(mkRel 1,Array.map (lift 1) l')) - | _ -> mkApp (g,l')) - | _ -> mkApp (irec f,l')) - | Cast (m,_,_) when isMeta m -> find (destMeta m) - | _ -> map_constr irec u - in - local_strong whd_betaiota - (if c.freemetas = Metaset.empty then c.rebus else irec c.rebus) - -let clenv_expand_metas clenv = - let seen = ref Metamap.empty in - let ongoing = ref Metaset.empty in - let todo = ref (meta_list clenv.evd) in - - let rec process_all () = match !todo with - | [] -> () - | (mv,cl)::_ -> let _ = process_meta mv cl in process_all () - - and process_meta mv cl = - ongoing := Metaset.add mv !ongoing; - let (body,typ) = match cl with - | Clval (na,(body,status),typ) -> - let body = plain_instance instance_of_meta body in - let typ = plain_instance instance_of_meta typ in - (body,Clval(na,(mk_freelisted body,status),mk_freelisted typ)) - | Cltyp (na,typ) -> - let typ = plain_instance instance_of_meta typ in - (mkMeta mv,Cltyp(na,mk_freelisted typ)) in - ongoing := Metaset.remove mv !ongoing; - seen := Metamap.add mv (body,typ) !seen; - todo := List.remove_assoc mv !todo; - body - - and instance_of_meta mv = - try fst (Metamap.find mv !seen) - with Not_found -> - if Metaset.mem mv !ongoing then - error "Cannot instantiate an existential variable with a term which depends on itself"; - process_meta mv (find_meta clenv.evd mv) in - - process_all (); - - { clenv with - evd = replace_metas (Metamap.map snd !seen) clenv.evd; - templtyp = mk_freelisted(plain_instance instance_of_meta clenv.templtyp); - templval = mk_freelisted(plain_instance instance_of_meta clenv.templval)} - -let instantiated_clenv_template clenv = (clenv.templval,clenv.templtyp) + let clenv_hnf_constr ce t = hnf_constr (cl_env ce) (cl_sigma ce) t @@ -134,8 +68,7 @@ let clenv_get_type_of ce c = exception NotExtensibleClause let clenv_push_prod cl = - let typ = - whd_betadeltaiota (cl_env cl) (cl_sigma cl) (clenv_direct_nf_type cl) in + let typ = whd_betadeltaiota (cl_env cl) (cl_sigma cl) (clenv_type cl) in let rec clrec typ = match kind_of_term typ with | Cast (t,_,_) -> clrec t | Prod (na,t,u) -> @@ -280,9 +213,13 @@ let clenv_wtactic f clenv = {clenv with evd = f clenv.evd } * returns a list of the metavars which appear in the type of * the metavar mv. The list is unordered. *) +let clenv_metavars evd mv = + (mk_freelisted (meta_instance evd (meta_ftype evd mv))).freemetas + let dependent_metas clenv mvs conclmetas = List.fold_right - (fun mv deps -> Metaset.union deps (meta_ftype clenv.evd mv).freemetas) + (fun mv deps -> + Metaset.union deps (clenv_metavars clenv.evd mv)) mvs conclmetas let duplicated_metas c = @@ -294,14 +231,14 @@ let duplicated_metas c = snd (collrec ([],[]) c) let clenv_dependent hyps_only clenv = - let (body,typ) = instantiated_clenv_template clenv in let mvs = undefined_metas clenv.evd in - let deps = dependent_metas clenv mvs typ.freemetas in - let nonlinear = duplicated_metas body.rebus in + let ctyp_mvs = (mk_freelisted (clenv_type clenv)).freemetas in + let deps = dependent_metas clenv mvs ctyp_mvs in + let nonlinear = duplicated_metas (clenv_value clenv) in (* Make the assumption that duplicated metas have internal dependencies *) List.filter (fun mv -> (Metaset.mem mv deps && - not (hyps_only && Metaset.mem mv typ.freemetas)) + not (hyps_only && Metaset.mem mv ctyp_mvs)) or List.mem mv nonlinear) mvs @@ -430,9 +367,9 @@ type arg_bindings = open_constr explicit_bindings * of cval, ctyp. *) let clenv_independent clenv = - let (body,typ) = instantiated_clenv_template clenv in - let mvs = Metaset.elements body.freemetas in - let deps = dependent_metas clenv mvs typ.freemetas in + let mvs = collect_metas (clenv_value clenv) in + let ctyp_mvs = (mk_freelisted (clenv_type clenv)).freemetas in + let deps = dependent_metas clenv mvs ctyp_mvs in List.filter (fun mv -> not (Metaset.mem mv deps)) mvs let check_bindings bl = diff --git a/pretyping/clenv.mli b/pretyping/clenv.mli index de5a1e375..dfa751349 100644 --- a/pretyping/clenv.mli +++ b/pretyping/clenv.mli @@ -43,16 +43,10 @@ val subst_clenv : substitution -> clausenv -> clausenv (* subject of clenv (instantiated) *) val clenv_value : clausenv -> constr -(* subject of clenv (assume it is pre-instantiated) *) -val clenv_direct_value : clausenv -> constr (* type of clenv (instantiated) *) val clenv_type : clausenv -> types -(* type of clenv (assume it is pre-instantiated) *) -val clenv_direct_nf_type : clausenv -> types (* substitute resolved metas *) val clenv_nf_meta : clausenv -> constr -> constr -(* substitute resolved metas (assume the metas in clausenv are expanded) *) -val clenv_direct_nf_meta : clausenv -> constr -> constr (* type of a meta in clenv context *) val clenv_meta_type : clausenv -> metavariable -> types @@ -89,8 +83,6 @@ val clenv_dependent : bool -> clausenv -> metavariable list val clenv_pose_metas_as_evars : clausenv -> metavariable list -> clausenv -val clenv_expand_metas : clausenv -> clausenv - (***************************************************************) (* Bindings *) diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 2b9a0ed82..b29afc0cb 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -610,18 +610,12 @@ let meta_with_name evd id = (str "Binder name \"" ++ pr_id id ++ strbrk "\" occurs more than once in clause.") -let mk_meta_subst evd = - Metamap.fold (fun mv cl subst -> match cl with - | Clval(_,(b,_),typ) -> (mv, b.rebus) :: subst - | Cltyp (_,typ) -> subst) evd.metas [] let meta_merge evd1 evd2 = {evd2 with metas = List.fold_left (fun m (n,v) -> Metamap.add n v m) evd2.metas (metamap_to_list evd1.metas) } -let replace_metas metas evd = { evd with metas = metas } - type metabinding = metavariable * constr * instance_status let retract_coercible_metas evd = diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 2fd668043..825096acc 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -218,7 +218,6 @@ val meta_declare : metavariable -> types -> ?name:name -> evar_defs -> evar_defs val meta_assign : metavariable -> constr * instance_status -> evar_defs -> evar_defs val meta_reassign : metavariable -> constr * instance_status -> evar_defs -> evar_defs -val mk_meta_subst : evar_defs -> meta_value_map (* [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *) val meta_merge : evar_defs -> evar_defs -> evar_defs @@ -226,7 +225,6 @@ val meta_merge : evar_defs -> evar_defs -> evar_defs val undefined_metas : evar_defs -> metavariable list val metas_of : evar_defs -> meta_type_map val map_metas_fvalue : (constr -> constr) -> evar_defs -> evar_defs -val replace_metas : clbinding Metamap.t -> evar_defs -> evar_defs type metabinding = metavariable * constr * instance_status diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 7fdcded00..e24cf62bb 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -887,19 +887,28 @@ let meta_value evd mv = in valrec mv -let meta_instance evd b = +let meta_instance env b = let c_sigma = List.map - (fun mv -> (mv,meta_value evd mv)) (Metaset.elements b.freemetas) + (fun mv -> (mv,meta_value env mv)) (Metaset.elements b.freemetas) in if c_sigma = [] then b.rebus else instance c_sigma b.rebus -let nf_meta evd c = meta_instance evd (mk_freelisted c) - -let direct_nf_meta evd c = instance (mk_meta_subst evd) c +let nf_meta env c = meta_instance env (mk_freelisted c) (* Instantiate metas that create beta/iota redexes *) +let meta_value evd mv = + let rec valrec mv = + match meta_opt_fvalue evd mv with + | Some (b,_) -> + instance + (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas)) + b.rebus + | None -> mkMeta mv + in + valrec mv + let meta_reducible_instance evd b = let fm = Metaset.elements b.freemetas in let metas = List.fold_left (fun l mv -> diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 397377473..371a66a9d 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -223,5 +223,4 @@ val whd_betaiota_deltazeta_for_iota_state : state_reduction_function (*s Meta-related reduction functions *) val meta_instance : evar_defs -> constr freelisted -> constr val nf_meta : evar_defs -> constr -> constr -val direct_nf_meta : evar_defs -> constr -> constr val meta_reducible_instance : evar_defs -> constr freelisted -> constr diff --git a/pretyping/unification.ml b/pretyping/unification.ml index a18db9026..a2671b5d1 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -467,7 +467,7 @@ let unify_to_type env evd flags c u = let sigma = evars_of evd in let c = refresh_universes c in let t = get_type_of_with_meta env sigma (metas_of evd) c in - let t = Tacred.hnf_constr env sigma (nf_meta evd t) in + let t = Tacred.hnf_constr env sigma (nf_betaiota (nf_meta evd t)) in let u = Tacred.hnf_constr env sigma u in try unify_0 env sigma Cumul flags t u with e when precatchable_exception e -> ([],[]) diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index b1dc7c896..50529d32a 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -40,31 +40,29 @@ open Clenv let clenv_cast_meta clenv = let rec crec u = - match kind_of_term2 u with + match kind_of_term u with | App _ | Case _ -> crec_hd u - | Cast (Meta mv,_,_) | Meta mv -> - (match Evd.meta_opt_fvalue clenv.evd mv with - | Some (c,_) -> c.rebus - | None -> u) + | Cast (c,_,_) when isMeta c -> u | _ -> map_constr crec u and crec_hd u = match kind_of_term (strip_outer_cast u) with | Meta mv -> - (match Evd.find_meta clenv.evd mv with - | Clval (_,(body,_),_) -> body.rebus - | Cltyp (_,typ) -> - if occur_meta typ.rebus then - raise (RefinerError (MetaInType typ.rebus)); - mkCast (mkMeta mv, DEFAULTcast, typ.rebus)) + (try + let b = Typing.meta_type clenv.evd mv in + assert (not (occur_meta b)); + if occur_meta b then u + else mkCast (mkMeta mv, DEFAULTcast, b) + with Not_found -> u) | App(f,args) -> mkApp (crec_hd f, Array.map crec args) - | Case(ci,p,c,br) -> mkCase (ci, crec p, crec_hd c, Array.map crec br) + | Case(ci,p,c,br) -> + mkCase (ci, crec_hd p, crec_hd c, Array.map crec br) | _ -> u in crec let clenv_value_cast_meta clenv = - clenv_cast_meta clenv (clenv_direct_value clenv) + clenv_cast_meta clenv (clenv_value clenv) let clenv_pose_dependent_evars with_evars clenv = let dep_mvs = clenv_dependent false clenv in @@ -75,14 +73,13 @@ let clenv_pose_dependent_evars with_evars clenv = let clenv_refine with_evars clenv gls = - let clenv = clenv_expand_metas clenv in let clenv = clenv_pose_dependent_evars with_evars clenv in let evd' = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd in tclTHEN (tclEVARS (evars_of evd')) - (refine (clenv_value_cast_meta clenv)) + (refine (clenv_cast_meta clenv (clenv_value clenv))) gls let dft = Unification.default_unify_flags diff --git a/tactics/auto.ml b/tactics/auto.ml index 42d74f9ed..aa7ce1290 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -264,7 +264,7 @@ let make_exact_entry pri (c,cty) = failwith "make_exact_entry" | _ -> let ce = mk_clenv_from dummy_goal (c,cty) in - let c' = clenv_direct_nf_type ce in + let c' = clenv_type ce in let pat = Pattern.pattern_of_constr c' in (Some (head_of_constr_reference (List.hd (head_constr cty))), { pri=(match pri with Some pri -> pri | None -> 0); pat=Some pat; code=Give_exact c }) @@ -274,7 +274,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) = match kind_of_term cty with | Prod _ -> let ce = mk_clenv_from dummy_goal (c,cty) in - let c' = clenv_direct_nf_type ce in + let c' = clenv_type ce in let pat = Pattern.pattern_of_constr c' in let hd = (try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry") in @@ -342,7 +342,7 @@ let make_trivial env sigma c = let hd = head_of_constr_reference (List.hd (head_constr t)) in let ce = mk_clenv_from dummy_goal (c,t) in (Some hd, { pri=1; - pat = Some (Pattern.pattern_of_constr (clenv_direct_nf_type ce)); + pat = Some (Pattern.pattern_of_constr (clenv_type ce)); code=Res_pf_THEN_trivial_fail(c,{ce with env=empty_env}) }) open Vernacexpr diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index 1ae1196a3..bda1fabbc 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -751,7 +751,7 @@ let evd_convertible env evd x y = let decompose_setoid_eqhyp env sigma c left2right = let ctype = Typing.type_of env sigma c in let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ctype) in - let (equiv, args) = decompose_app (Clenv.clenv_direct_nf_type eqclause) in + let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in let rec split_last_two = function | [c1;c2] -> [],(c1, c2) | x::y::z -> @@ -764,7 +764,7 @@ let decompose_setoid_eqhyp env sigma c left2right = if not (evd_convertible env eqclause.evd ty1 ty2) then error "The term does not end with an applied homogeneous relation." else - { cl=eqclause; prf=(Clenv.clenv_direct_value eqclause); + { cl=eqclause; prf=(Clenv.clenv_value eqclause); car=ty1; rel=mkApp (equiv, Array.of_list others); l2r=left2right; c1=c1; c2=c2; c=Some c; abs=None } @@ -808,7 +808,6 @@ let unify_eqn env sigma hypinfo t = cl, prf, c1, c2, car, rel else raise Not_found*) let env' = clenv_unify allowK ~flags:rewrite2_unif_flags CONV left t cl in - let env' = clenv_expand_metas env' in let env' = let mvs = clenv_dependent false env' in clenv_pose_metas_as_evars env' mvs @@ -819,8 +818,7 @@ let unify_eqn env sigma hypinfo t = and rel = Clenv.clenv_nf_meta env' rel in hypinfo := { !hypinfo with cl = env'; - abs = Some (Clenv.clenv_direct_value env', - Clenv.clenv_direct_nf_type env') }; + abs = Some (Clenv.clenv_value env', Clenv.clenv_type env') }; env', prf, c1, c2, car, rel | None -> let env' = @@ -831,7 +829,6 @@ let unify_eqn env sigma hypinfo t = clenv_unify allowK ~flags:rewrite2_unif_flags CONV left t cl in - let env' = clenv_expand_metas env' in let env' = let mvs = clenv_dependent false env' in clenv_pose_metas_as_evars env' mvs @@ -841,7 +838,7 @@ let unify_eqn env sigma hypinfo t = let nf c = Evarutil.nf_evar (Evd.evars_of evd') (Clenv.clenv_nf_meta env' c) in let c1 = nf c1 and c2 = nf c2 and car = nf car and rel = nf rel - and prf = nf (Clenv.clenv_direct_value env') in + and prf = nf (Clenv.clenv_value env') in let ty1 = Typing.mtype_of env'.env env'.evd c1 and ty2 = Typing.mtype_of env'.env env'.evd c2 in @@ -1577,12 +1574,12 @@ let unification_rewrite l2r c1 c2 cl car rel but gl = Unification.w_unify_to_subterm ~flags:rewrite2_unif_flags (pf_env gl) ((if l2r then c1 else c2),but) cl.evd in - let cl' = clenv_expand_metas {cl with evd = env'} in - let c1 = Clenv.clenv_direct_nf_meta cl' c1 - and c2 = Clenv.clenv_direct_nf_meta cl' c2 in + let cl' = {cl with evd = env'} in + let c1 = Clenv.clenv_nf_meta cl' c1 + and c2 = Clenv.clenv_nf_meta cl' c2 in check_evar_map_of_evars_defs env'; - let prf = Clenv.clenv_direct_value cl' in - let prfty = Clenv.clenv_direct_nf_type cl' in + let prf = Clenv.clenv_value cl' in + let prfty = Clenv.clenv_type cl' in let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty)} diff --git a/tactics/equality.ml b/tactics/equality.ml index 123c83e40..9994bd784 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -565,7 +565,7 @@ let apply_on_clause (f,t) clause = (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with | Meta mv -> mv | _ -> errorlabstrm "" (str "Ill-formed clause applicator.")) in - clenv_expand_metas (clenv_fchain argmv f_clause clause) + clenv_fchain argmv f_clause clause let discr_positions env sigma (lbeq,(t,t1,t2)) eq_clause cpath dirn sort = let e = next_ident_away eq_baseid (ids_of_context env) in diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml index 22596ac3c..644a68666 100644 --- a/tactics/setoid_replace.ml +++ b/tactics/setoid_replace.ml @@ -1815,7 +1815,7 @@ let relation_rewrite c1 c2 (input_direction,cl) ~new_goals gl = let analyse_hypothesis gl c = let ctype = pf_type_of gl c in let eqclause = Clenv.make_clenv_binding gl (c,ctype) Rawterm.NoBindings in - let (equiv, args) = decompose_app (Clenv.clenv_direct_nf_type eqclause) in + let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in let rec split_last_two = function | [c1;c2] -> [],(c1, c2) | x::y::z -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index be15311b9..87ef65d7c 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -560,12 +560,11 @@ let error_uninstantiated_metas t clenv = in errorlabstrm "" (str "Cannot find an instance for " ++ pr_id id ++ str".") let clenv_refine_in with_evars id clenv gl = - let clenv = clenv_expand_metas clenv in let clenv = clenv_pose_dependent_evars with_evars clenv in let new_hyp_typ = clenv_type clenv in if not with_evars & occur_meta new_hyp_typ then error_uninstantiated_metas new_hyp_typ clenv; - let new_hyp_prf = clenv_value_cast_meta clenv in + let new_hyp_prf = clenv_value clenv in tclTHEN (tclEVARS (evars_of clenv.evd)) (cut_replacing id new_hyp_typ @@ -960,8 +959,7 @@ let specialize mopt (c,lbind) g = else let clause = make_clenv_binding g (c,pf_type_of g c) lbind in let clause = clenv_unify_meta_types clause in - let clause = clenv_expand_metas clause in - let (thd,tstack) = whd_stack (clenv_direct_value clause) in + let (thd,tstack) = whd_stack (clenv_value clause) in let nargs = List.length tstack in let tstack = match mopt with | Some m -> diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v index dbb0d7e4f..319ed6880 100644 --- a/test-suite/success/apply.v +++ b/test-suite/success/apply.v @@ -224,11 +224,18 @@ intros x H; eapply trans_equal; [apply H | unfold x;match goal with |- ?x = ?x => reflexivity end]. Qed. - (* This does not work (oct 2008) because "match goal" sees "?evar = O" - and not "O = O" +(* Test non-regression of (temporary) bug 1981 *) -Lemma eapply_evar : O=O -> 0=O. -intro H; eapply trans_equal; - [apply H | match goal with |- ?x = ?x => reflexivity end]. +Goal exists n : nat, True. +eapply ex_intro. +exact O. +trivial. +Qed. + +(* Test non-regression of (temporary) bug 1980 *) + +Goal True. +try eapply ex_intro. +trivial. Qed. -*) + |