aboutsummaryrefslogtreecommitdiff
path: root/engine
diff options
context:
space:
mode:
Diffstat (limited to 'engine')
-rw-r--r--engine/eConstr.ml5
-rw-r--r--engine/eConstr.mli1
-rw-r--r--engine/evarutil.ml119
-rw-r--r--engine/evarutil.mli5
-rw-r--r--engine/logic_monad.ml1
-rw-r--r--engine/logic_monad.mli1
-rw-r--r--engine/proofview.ml5
-rw-r--r--engine/proofview.mli2
-rw-r--r--engine/termops.ml12
-rw-r--r--engine/termops.mli10
-rw-r--r--engine/uState.ml20
-rw-r--r--engine/universes.ml11
-rw-r--r--engine/universes.mli6
13 files changed, 127 insertions, 71 deletions
diff --git a/engine/eConstr.ml b/engine/eConstr.ml
index a65b3941ef..9ac16b5b48 100644
--- a/engine/eConstr.ml
+++ b/engine/eConstr.ml
@@ -695,6 +695,10 @@ let cast_rel_context :
type a b. (a,b) eq -> (a, a) Rel.pt -> (b, b) Rel.pt =
fun Refl x -> x
+let cast_rec_decl :
+ type a b. (a,b) eq -> (a, a) Constr.prec_declaration -> (b, b) Constr.prec_declaration =
+ fun Refl x -> x
+
let cast_named_decl :
type a b. (a,b) eq -> (a, a) Named.Declaration.pt -> (b, b) Named.Declaration.pt =
fun Refl x -> x
@@ -817,6 +821,7 @@ let it_mkLambda_or_LetIn t ctx = List.fold_left (fun c d -> mkLambda_or_LetIn d
let push_rel d e = push_rel (cast_rel_decl unsafe_eq d) e
let push_rel_context d e = push_rel_context (cast_rel_context unsafe_eq d) e
+let push_rec_types d e = push_rec_types (cast_rec_decl unsafe_eq d) e
let push_named d e = push_named (cast_named_decl unsafe_eq d) e
let push_named_context d e = push_named_context (cast_named_context unsafe_eq d) e
let push_named_context_val d e = push_named_context_val (cast_named_decl unsafe_eq d) e
diff --git a/engine/eConstr.mli b/engine/eConstr.mli
index 30de748a19..6fa338c73d 100644
--- a/engine/eConstr.mli
+++ b/engine/eConstr.mli
@@ -251,6 +251,7 @@ end
val push_rel : rel_declaration -> env -> env
val push_rel_context : rel_context -> env -> env
+val push_rec_types : (t, t) Constr.prec_declaration -> env -> env
val push_named : named_declaration -> env -> env
val push_named_context : named_context -> env -> env
diff --git a/engine/evarutil.ml b/engine/evarutil.ml
index 374fdce722..f82ffccdc3 100644
--- a/engine/evarutil.ml
+++ b/engine/evarutil.ml
@@ -257,22 +257,6 @@ let make_pure_subst evi args =
* we have the property that u and phi(t) are convertible in env.
*)
-let csubst_subst (k, s) c =
- (** Safe because this is a substitution *)
- let c = EConstr.Unsafe.to_constr c in
- let rec subst n c = match Constr.kind c with
- | Rel m ->
- if m <= n then c
- else if m - n <= k then EConstr.Unsafe.to_constr (Int.Map.find (k - m + n) s)
- else mkRel (m - k)
- | _ -> Constr.map_with_binders succ subst n c
- in
- let c = if k = 0 then c else subst 0 c in
- EConstr.of_constr c
-
-let subst2 subst vsubst c =
- csubst_subst subst (EConstr.Vars.replace_vars vsubst c)
-
let next_ident_away id avoid =
let avoid id = Id.Set.mem id avoid in
next_ident_away_from id avoid
@@ -282,19 +266,79 @@ let next_name_away na avoid =
let id = match na with Name id -> id | Anonymous -> default_non_dependent_ident in
next_ident_away_from id avoid
-type csubst = int * EConstr.t Int.Map.t
+type subst_val =
+| SRel of int
+| SVar of Id.t
+
+type csubst = {
+ csubst_len : int;
+ (** Cardinal of [csubst_rel] *)
+ csubst_var : Constr.t Id.Map.t;
+ (** A mapping of variables to variables. We use the more general
+ [Constr.t] to share allocations, but all values are of shape [Var _]. *)
+ csubst_rel : Constr.t Int.Map.t;
+ (** A contiguous mapping of integers to variables. Same remark for values. *)
+ csubst_rev : subst_val Id.Map.t;
+ (** Reverse mapping of the substitution *)
+}
+(** This type represent a name substitution for the named and De Bruijn parts of
+ a environment. For efficiency we also store the reverse substitution.
+ Invariant: all identifiers in the codomain of [csubst_var] and [csubst_rel]
+ must be pairwise distinct. *)
+
+let empty_csubst = {
+ csubst_len = 0;
+ csubst_rel = Int.Map.empty;
+ csubst_var = Id.Map.empty;
+ csubst_rev = Id.Map.empty;
+}
-let empty_csubst = (0, Int.Map.empty)
+let csubst_subst { csubst_len = k; csubst_var = v; csubst_rel = s } c =
+ (** Safe because this is a substitution *)
+ let c = EConstr.Unsafe.to_constr c in
+ let rec subst n c = match Constr.kind c with
+ | Rel m ->
+ if m <= n then c
+ else if m - n <= k then Int.Map.find (k - m + n) s
+ else mkRel (m - k)
+ | Var id ->
+ begin try Id.Map.find id v with Not_found -> c end
+ | _ -> Constr.map_with_binders succ subst n c
+ in
+ let c = if k = 0 && Id.Map.is_empty v then c else subst 0 c in
+ EConstr.of_constr c
type ext_named_context =
- csubst * (Id.t * EConstr.constr) list *
- Id.Set.t * EConstr.named_context
-
-let push_var id (n, s) =
- let s = Int.Map.add n (EConstr.mkVar id) s in
- (succ n, s)
-
-let push_rel_decl_to_named_context sigma decl (subst, vsubst, avoid, nc) =
+ csubst * Id.Set.t * EConstr.named_context
+
+let push_var id { csubst_len = n; csubst_var = v; csubst_rel = s; csubst_rev = r } =
+ let s = Int.Map.add n (Constr.mkVar id) s in
+ let r = Id.Map.add id (SRel n) r in
+ { csubst_len = succ n; csubst_var = v; csubst_rel = s; csubst_rev = r }
+
+(** Post-compose the substitution with the generator [src ↦ tgt] *)
+let update_var src tgt subst =
+ let cur =
+ try Some (Id.Map.find src subst.csubst_rev)
+ with Not_found -> None
+ in
+ match cur with
+ | None ->
+ (** Missing keys stand for identity substitution [src ↦ src] *)
+ let csubst_var = Id.Map.add src (Constr.mkVar tgt) subst.csubst_var in
+ let csubst_rev = Id.Map.add tgt (SVar src) subst.csubst_rev in
+ { subst with csubst_var; csubst_rev }
+ | Some bnd ->
+ let csubst_rev = Id.Map.add tgt bnd (Id.Map.remove src subst.csubst_rev) in
+ match bnd with
+ | SRel m ->
+ let csubst_rel = Int.Map.add m (Constr.mkVar tgt) subst.csubst_rel in
+ { subst with csubst_rel; csubst_rev }
+ | SVar id ->
+ let csubst_var = Id.Map.add id (Constr.mkVar tgt) subst.csubst_var in
+ { subst with csubst_var; csubst_rev }
+
+let push_rel_decl_to_named_context sigma decl (subst, avoid, nc) =
let open EConstr in
let open Vars in
let map_decl f d =
@@ -330,18 +374,17 @@ let push_rel_decl_to_named_context sigma decl (subst, vsubst, avoid, nc) =
binding named [id], we will keep [id0] (the name given
by the user) and rename [id0] into [id] in the named
context. Unless [id] is a section variable. *)
- let subst = (fst subst, Int.Map.map (replace_vars [id0,mkVar id]) (snd subst)) in
- let vsubst = (id0,mkVar id)::vsubst in
- let d = decl |> NamedDecl.of_rel_decl (fun _ -> id0) |> map_decl (subst2 subst vsubst) in
+ let subst = update_var id0 id subst in
+ let d = decl |> NamedDecl.of_rel_decl (fun _ -> id0) |> map_decl (csubst_subst subst) in
let nc = List.map (replace_var_named_declaration id0 id) nc in
- (push_var id0 subst, vsubst, Id.Set.add id avoid, d :: nc)
+ (push_var id0 subst, Id.Set.add id avoid, d :: nc)
| _ ->
(* spiwack: if [id0] is a section variable renaming it is
incorrect. We revert to a less robust behaviour where
the new binder has name [id]. Which amounts to the same
behaviour than when [id=id0]. *)
- let d = decl |> NamedDecl.of_rel_decl (fun _ -> id) |> map_decl (subst2 subst vsubst) in
- (push_var id subst, vsubst, Id.Set.add id avoid, d :: nc)
+ let d = decl |> NamedDecl.of_rel_decl (fun _ -> id) |> map_decl (csubst_subst subst) in
+ (push_var id subst, Id.Set.add id avoid, d :: nc)
let push_rel_context_to_named_context env sigma typ =
(* compute the instances relative to the named context and rel_context *)
@@ -350,17 +393,17 @@ let push_rel_context_to_named_context env sigma typ =
let ids = List.map get_id (named_context env) in
let inst_vars = List.map mkVar ids in
if List.is_empty (Environ.rel_context env) then
- (named_context_val env, typ, inst_vars, empty_csubst, [])
+ (named_context_val env, typ, inst_vars, empty_csubst)
else
let avoid = List.fold_right Id.Set.add ids Id.Set.empty in
let inst_rels = List.rev (rel_list 0 (nb_rel env)) in
(* move the rel context to a named context and extend the named instance *)
(* with vars of the rel context *)
(* We do keep the instances corresponding to local definition (see above) *)
- let (subst, vsubst, _, env) =
+ let (subst, _, env) =
Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context sigma d acc)
- (rel_context env) ~init:(empty_csubst, [], avoid, named_context env) in
- (val_of_named_context env, subst2 subst vsubst typ, inst_rels@inst_vars, subst, vsubst)
+ (rel_context env) ~init:(empty_csubst, avoid, named_context env) in
+ (val_of_named_context env, csubst_subst subst typ, inst_rels@inst_vars, subst)
(*------------------------------------*
* Entry points to define new evars *
@@ -425,8 +468,8 @@ let new_evar_from_context sign evd ?src ?filter ?candidates ?store ?naming ?prin
(* [new_evar] declares a new existential in an env env with type typ *)
(* Converting the env into the sign of the evar to define *)
let new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ =
- let sign,typ',instance,subst,vsubst = push_rel_context_to_named_context env evd typ in
- let map c = subst2 subst vsubst c in
+ let sign,typ',instance,subst = push_rel_context_to_named_context env evd typ in
+ let map c = csubst_subst subst c in
let candidates = Option.map (fun l -> List.map map l) candidates in
let instance =
match filter with
diff --git a/engine/evarutil.mli b/engine/evarutil.mli
index 37f5968ad8..923bf49a9c 100644
--- a/engine/evarutil.mli
+++ b/engine/evarutil.mli
@@ -222,14 +222,13 @@ val empty_csubst : csubst
val csubst_subst : csubst -> constr -> constr
type ext_named_context =
- csubst * (Id.t * constr) list *
- Id.Set.t * named_context
+ csubst * Id.Set.t * named_context
val push_rel_decl_to_named_context :
evar_map -> rel_declaration -> ext_named_context -> ext_named_context
val push_rel_context_to_named_context : Environ.env -> evar_map -> types ->
- named_context_val * types * constr list * csubst * (Id.t*constr) list
+ named_context_val * types * constr list * csubst
val generalize_evar_over_rels : evar_map -> existential -> types * constr list
diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml
index 9dc5d473b9..3674bb9432 100644
--- a/engine/logic_monad.ml
+++ b/engine/logic_monad.ml
@@ -107,7 +107,6 @@ struct
let print_debug s = make (fun _ -> Feedback.msg_info s)
let print_info s = make (fun _ -> Feedback.msg_info s)
let print_warning s = make (fun _ -> Feedback.msg_warning s)
- let print_error s = make (fun _ -> Feedback.msg_error s)
let print_notice s = make (fun _ -> Feedback.msg_notice s)
let run = fun x ->
diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli
index 8c8f9fe935..50b4abd8bd 100644
--- a/engine/logic_monad.mli
+++ b/engine/logic_monad.mli
@@ -61,7 +61,6 @@ module NonLogical : sig
val print_warning : Pp.t -> unit t
val print_notice : Pp.t -> unit t
val print_info : Pp.t -> unit t
- val print_error : Pp.t -> unit t
(** [Pervasives.raise]. Except that exceptions are wrapped with
{!Exception}. *)
diff --git a/engine/proofview.ml b/engine/proofview.ml
index 0a64351950..47b9b406d8 100644
--- a/engine/proofview.ml
+++ b/engine/proofview.ml
@@ -1086,7 +1086,7 @@ module Goal = struct
end
end
- let enter_one f =
+ let enter_one ?(__LOC__=__LOC__) f =
let open Proof in
Comb.get >>= function
| [goal] -> begin
@@ -1097,7 +1097,8 @@ module Goal = struct
let (e, info) = CErrors.push e in
tclZERO ~info e
end
- | _ -> assert false (* unsatisfied not-exactly-one-goal precondition *)
+ | _ ->
+ CErrors.anomaly Pp.(str __LOC__ ++ str " enter_one")
let goals =
Pv.get >>= fun step ->
diff --git a/engine/proofview.mli b/engine/proofview.mli
index 59728a2fd1..b02fde3a80 100644
--- a/engine/proofview.mli
+++ b/engine/proofview.mli
@@ -499,7 +499,7 @@ module Goal : sig
(** Like {!enter}, but assumes exactly one goal under focus, raising *)
(** a fatal error otherwise. *)
- val enter_one : ([ `LZ ] t -> 'a tactic) -> 'a tactic
+ val enter_one : ?__LOC__:string -> ([ `LZ ] t -> 'a tactic) -> 'a tactic
(** Recover the list of current goals under focus, without evar-normalization.
FIXME: encapsulate the level in an existential type. *)
diff --git a/engine/termops.ml b/engine/termops.ml
index a71bdff31e..40b3d0d8b6 100644
--- a/engine/termops.ml
+++ b/engine/termops.ml
@@ -1463,6 +1463,18 @@ let prod_applist sigma c l =
| _ -> anomaly (Pp.str "Not enough prod's.") in
app [] c l
+let prod_applist_assum sigma n c l =
+ let open EConstr in
+ let rec app n subst c l =
+ if Int.equal n 0 then
+ if l == [] then Vars.substl subst c
+ else anomaly (Pp.str "Not enough arguments.")
+ else match EConstr.kind sigma c, l with
+ | Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l
+ | LetIn(_,b,_,c), _ -> app (n-1) (Vars.substl subst b::subst) c l
+ | _ -> anomaly (Pp.str "Not enough prod/let's.") in
+ app n [] c l
+
(* Combinators on judgments *)
let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type }
diff --git a/engine/termops.mli b/engine/termops.mli
index c1600abe80..a3559a693b 100644
--- a/engine/termops.mli
+++ b/engine/termops.mli
@@ -159,8 +159,18 @@ val eta_reduce_head : Evd.evar_map -> constr -> constr
(** Flattens application lists *)
val collapse_appl : Evd.evar_map -> constr -> constr
+(** [prod_applist] [forall (x1:B1;...;xn:Bn), B] [a1...an] @return [B[a1...an]] *)
val prod_applist : Evd.evar_map -> constr -> constr list -> constr
+(** In [prod_applist_assum n c args], [c] is supposed to have the
+ form [∀Γ.c] with [Γ] of length [m] and possibly with let-ins; it
+ returns [c] with the assumptions of [Γ] instantiated by [args] and
+ the local definitions of [Γ] expanded.
+ Note that [n] counts both let-ins and prods, while the length of [args]
+ only counts prods. In other words, varying [n] changes how many
+ trailing let-ins are expanded. *)
+val prod_applist_assum : Evd.evar_map -> int -> constr -> constr list -> constr
+
(** Remove recursively the casts around a term i.e.
[strip_outer_cast (Cast (Cast ... (Cast c, t) ... ))] is [c]. *)
val strip_outer_cast : Evd.evar_map -> constr -> constr
diff --git a/engine/uState.ml b/engine/uState.ml
index 6f2b3c4b26..4b650c9c94 100644
--- a/engine/uState.ml
+++ b/engine/uState.ml
@@ -201,14 +201,18 @@ let process_universe_constraints ctx cstrs =
| None -> user_err Pp.(str "Algebraic universe on the right")
| Some r' ->
if Univ.Level.is_small r' then
- let levels = Univ.Universe.levels l in
- let fold l' local =
- let l = Univ.Universe.make l' in
- if Univ.Level.is_small l' || is_local l' then
- equalize_variables false l l' r r' local
- else raise (Univ.UniverseInconsistency (Univ.Le, l, r, None))
- in
- Univ.LSet.fold fold levels local
+ if not (Univ.Universe.is_levels l)
+ then
+ raise (Univ.UniverseInconsistency (Univ.Le, l, r, None))
+ else
+ let levels = Univ.Universe.levels l in
+ let fold l' local =
+ let l = Univ.Universe.make l' in
+ if Univ.Level.is_small l' || is_local l' then
+ equalize_variables false l l' r r' local
+ else raise (Univ.UniverseInconsistency (Univ.Le, l, r, None))
+ in
+ Univ.LSet.fold fold levels local
else
Univ.enforce_leq l r local
end
diff --git a/engine/universes.ml b/engine/universes.ml
index eaddf98a83..3a00f0fd1d 100644
--- a/engine/universes.ml
+++ b/engine/universes.ml
@@ -1103,14 +1103,3 @@ let solve_constraints_system levels level_bounds level_min =
done;
done;
v
-
-
-(** Operations for universe_info_ind *)
-
-(** Given a universe context representing constraints of an inductive
- this function produces a UInfoInd.t that with the trivial subtyping relation. *)
-let univ_inf_ind_from_universe_context univcst =
- let freshunivs = Instance.of_array
- (Array.map (fun _ -> new_univ_level ())
- (Instance.to_array (UContext.instance univcst)))
- in CumulativityInfo.from_universe_context univcst freshunivs
diff --git a/engine/universes.mli b/engine/universes.mli
index 130dcf8bb8..cb6e2ba1b6 100644
--- a/engine/universes.mli
+++ b/engine/universes.mli
@@ -221,9 +221,3 @@ val pr_universe_opt_subst : universe_opt_subst -> Pp.t
val solve_constraints_system : Universe.t option array -> Universe.t array -> Universe.t array ->
Universe.t array
-
-(** Operations for universe_info_ind *)
-
-(** Given a universe context representing constraints of an inductive
- this function produces a UInfoInd.t that with the trivial subtyping relation. *)
-val univ_inf_ind_from_universe_context : UContext.t -> CumulativityInfo.t
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-08 08:10:09 +0000