diff options
| -rw-r--r-- | engine/termops.ml | 10 | ||||
| -rw-r--r-- | engine/termops.mli | 2 | ||||
| -rw-r--r-- | kernel/vars.ml | 15 | ||||
| -rw-r--r-- | kernel/vars.mli | 18 | ||||
| -rw-r--r-- | pretyping/cases.ml | 8 | ||||
| -rw-r--r-- | pretyping/inductiveops.ml | 10 | ||||
| -rw-r--r-- | pretyping/vnorm.ml | 2 |
7 files changed, 40 insertions, 25 deletions
diff --git a/engine/termops.ml b/engine/termops.ml index 5716a19dd..63baec129 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -953,16 +953,6 @@ let smash_rel_context sign = aux (List.rev (substl_rel_context [b] (List.rev acc))) l in List.rev (aux [] sign) -let adjust_subst_to_rel_context sign l = - let rec aux subst sign l = - match sign, l with - | (_,None,_)::sign', a::args' -> aux (a::subst) sign' args' - | (_,Some c,_)::sign', args' -> - aux (substl subst c :: subst) sign' args' - | [], [] -> List.rev subst - | _ -> anomaly (Pp.str "Instance and signature do not match") - in aux [] (List.rev sign) l - let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init let rec mem_named_context id = function diff --git a/engine/termops.mli b/engine/termops.mli index 5d812131e..94c485a26 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -219,7 +219,7 @@ val assums_of_rel_context : rel_context -> (Name.t * constr) list val lift_rel_context : int -> rel_context -> rel_context val substl_rel_context : constr list -> rel_context -> rel_context val smash_rel_context : rel_context -> rel_context (** expand lets in context *) -val adjust_subst_to_rel_context : rel_context -> constr list -> constr list + val map_rel_context_in_env : (env -> constr -> constr) -> env -> rel_context -> rel_context val map_rel_context_with_binders : diff --git a/kernel/vars.ml b/kernel/vars.ml index f8c0a65e6..a00c7036f 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -164,6 +164,21 @@ let substnl_decl laml k r = map_rel_declaration (fun c -> substnl laml k c) r let substl_decl laml r = map_rel_declaration (fun c -> substnl laml 0 c) r let subst1_decl lam r = map_rel_declaration (fun c -> subst1 lam c) r +(* Build a substitution from an instance, inserting missing let-ins *) + +let subst_of_rel_context_instance sign l = + let rec aux subst sign l = + match sign, l with + | (_,None,_)::sign', a::args' -> aux (a::subst) sign' args' + | (_,Some c,_)::sign', args' -> + aux (substl subst c :: subst) sign' args' + | [], [] -> subst + | _ -> Errors.anomaly (Pp.str "Instance and signature do not match") + in aux [] (List.rev sign) l + +let adjust_subst_to_rel_context sign l = + List.rev (subst_of_rel_context_instance sign l) + (* (thin_val sigma) removes identity substitutions from sigma *) let rec thin_val = function diff --git a/kernel/vars.mli b/kernel/vars.mli index ab10ba93b..a84cf0114 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -56,6 +56,24 @@ val lift : int -> constr -> constr type substl = constr list +(** Let [Γ] be a context interleaving declarations [x₁:T₁..xn:Tn] + and definitions [y₁:=c₁..yp:=cp] in some context [Γ₀]. Let + [u₁..un] be an {e instance} of [Γ], i.e. an instance in [Γ₀] + of the [xi]. Then, [subst_of_rel_context_instance Γ u₁..un] + returns the corresponding {e substitution} of [Γ], i.e. the + appropriate interleaving [σ] of the [u₁..un] with the [c₁..cp], + all of them in [Γ₀], so that a derivation [Γ₀, Γ, Γ₁|- t:T] + can be instantiated into a derivation [Γ₀, Γ₁ |- t[σ]:T[σ]] using + [substnl σ |Γ₁| t]. + Note that the instance [u₁..un] is represented starting with [u₁], + as if usable in [applist] while the substitution is + represented the other way round, i.e. ending with either [u₁] or + [c₁], as if usable for [substl]. *) +val subst_of_rel_context_instance : rel_context -> constr list -> substl + +(** For compatibility: returns the substitution reversed *) +val adjust_subst_to_rel_context : rel_context -> constr list -> constr list + (** [substnl [a₁;...;an] k c] substitutes in parallel [a₁],...,[an] for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates accordingly indexes in [an],...,[a1] and [c]. In terms of typing, if diff --git a/pretyping/cases.ml b/pretyping/cases.ml index a5a7ace22..b894cb8ea 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -837,10 +837,10 @@ let regeneralize_index_predicate n = map_predicate (relocate_index n 1) 0 let substnl_predicate sigma = map_predicate (substnl sigma) (* This is parallel bindings *) -let subst_predicate (args,copt) ccl tms = +let subst_predicate (subst,copt) ccl tms = let sigma = match copt with - | None -> List.rev args - | Some c -> c::(List.rev args) in + | None -> subst + | Some c -> c::subst in substnl_predicate sigma 0 ccl tms let specialize_predicate_var (cur,typ,dep) tms ccl = @@ -1018,7 +1018,7 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = (* We prepare the substitution of X and x:I(X) *) let realargsi = if not (Int.equal nrealargs 0) then - adjust_subst_to_rel_context arsign (Array.to_list cs.cs_concl_realargs) + subst_of_rel_context_instance arsign (Array.to_list cs.cs_concl_realargs) else [] in let copti = match depna with diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 632e00ed7..4c2ae61c3 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -354,14 +354,6 @@ let substnl_rel_context subst n sign = let substl_rel_context subst = substnl_rel_context subst 0 -let instantiate_context sign args = - let rec aux subst = function - | (_,None,_)::sign, a::args -> aux (a::subst) (sign,args) - | (_,Some b,_)::sign, args -> aux (substl subst b::subst) (sign,args) - | [], [] -> subst - | _ -> anomaly (Pp.str "Signature/instance mismatch in inductive family") - in aux [] (List.rev sign,args) - let get_arity env ((ind,u),params) = let (mib,mip) = Inductive.lookup_mind_specif env ind in let parsign = @@ -379,7 +371,7 @@ let get_arity env ((ind,u),params) = let parsign = Vars.subst_instance_context u parsign in let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in let arsign,_ = List.chop arproperlength mip.mind_arity_ctxt in - let subst = instantiate_context parsign params in + let subst = subst_of_rel_context_instance parsign params in let arsign = Vars.subst_instance_context u arsign in (substl_rel_context subst arsign, Inductive.inductive_sort_family mip) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 60140a31d..c59e085e5 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -57,7 +57,7 @@ let type_constructor mind mib u typ params = if Int.equal ndecls 0 then ctyp else let _,ctyp = decompose_prod_n_assum ndecls ctyp in - substl (List.rev (Termops.adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params))) + substl (List.rev (adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params))) ctyp |