aboutsummaryrefslogtreecommitdiff
path: root/kernel/term.ml
diff options
context:
space:
mode:
Diffstat (limited to 'kernel/term.ml')
-rw-r--r--kernel/term.ml82
1 files changed, 26 insertions, 56 deletions
diff --git a/kernel/term.ml b/kernel/term.ml
index 15f187e5c4..07a85329ef 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -71,20 +71,21 @@ type pconstant = constant puniverses
type pinductive = inductive puniverses
type pconstructor = constructor puniverses
-type ('constr, 'types) kind_of_term = ('constr, 'types) Constr.kind_of_term =
+type ('constr, 'types, 'sort, 'univs) kind_of_term =
+ ('constr, 'types, 'sort, 'univs) Constr.kind_of_term =
| Rel of int
| Var of Id.t
| Meta of metavariable
| Evar of 'constr pexistential
- | Sort of sorts
+ | Sort of 'sort
| Cast of 'constr * cast_kind * 'types
| Prod of Name.t * 'types * 'types
| Lambda of Name.t * 'types * 'constr
| LetIn of Name.t * 'constr * 'types * 'constr
| App of 'constr * 'constr array
- | Const of pconstant
- | Ind of pinductive
- | Construct of pconstructor
+ | Const of (constant * 'univs)
+ | Ind of (inductive * 'univs)
+ | Construct of (constructor * 'univs)
| Case of case_info * 'constr * 'constr * 'constr array
| Fix of ('constr, 'types) pfixpoint
| CoFix of ('constr, 'types) pcofixpoint
@@ -168,7 +169,7 @@ let hcons_types = Constr.hcons
exception DestKO
-(* Destructs a DeBrujin index *)
+(* Destructs a de Bruijn index *)
let destRel c = match kind_of_term c with
| Rel n -> n
| _ -> raise DestKO
@@ -179,8 +180,6 @@ let destMeta c = match kind_of_term c with
| _ -> raise DestKO
let isMeta c = match kind_of_term c with Meta _ -> true | _ -> false
-let isMetaOf mv c =
- match kind_of_term c with Meta mv' -> Int.equal mv mv' | _ -> false
(* Destructs a variable *)
let destVar c = match kind_of_term c with
@@ -328,38 +327,9 @@ let destCoFix c = match kind_of_term c with
let isCoFix c = match kind_of_term c with CoFix _ -> true | _ -> false
(******************************************************************)
-(* Cast management *)
-(******************************************************************)
-
-let rec strip_outer_cast c = match kind_of_term c with
- | Cast (c,_,_) -> strip_outer_cast c
- | _ -> c
-
-(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *)
-
-let under_outer_cast f c = match kind_of_term c with
- | Cast (b,k,t) -> mkCast (f b, k, f t)
- | _ -> f c
-
-let rec under_casts f c = match kind_of_term c with
- | Cast (c,k,t) -> mkCast (under_casts f c, k, t)
- | _ -> f c
-
-(******************************************************************)
(* Flattening and unflattening of embedded applications and casts *)
(******************************************************************)
-(* flattens application lists throwing casts in-between *)
-let collapse_appl c = match kind_of_term c with
- | App (f,cl) ->
- let rec collapse_rec f cl2 =
- match kind_of_term (strip_outer_cast f) with
- | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
- | _ -> mkApp (f,cl2)
- in
- collapse_rec f cl
- | _ -> c
-
let decompose_app c =
match kind_of_term c with
| App (f,cl) -> (f, Array.to_list cl)
@@ -465,7 +435,7 @@ let rec to_lambda n prod =
match kind_of_term prod with
| Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd)
| Cast (c,_,_) -> to_lambda n c
- | _ -> errorlabstrm "to_lambda" (mt ())
+ | _ -> user_err ~hdr:"to_lambda" (mt ())
let rec to_prod n lam =
if Int.equal n 0 then
@@ -474,7 +444,7 @@ let rec to_prod n lam =
match kind_of_term lam with
| Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd)
| Cast (c,_,_) -> to_prod n c
- | _ -> errorlabstrm "to_prod" (mt ())
+ | _ -> user_err ~hdr:"to_prod" (mt ())
let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c)
let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c)
@@ -486,7 +456,7 @@ let lambda_applist c l =
match kind_of_term c, l with
| Lambda(_,_,c), arg::l -> app (arg::subst) c l
| _, [] -> substl subst c
- | _ -> anomaly (Pp.str "Not enough lambda's") in
+ | _ -> anomaly (Pp.str "Not enough lambda's.") in
app [] c l
let lambda_appvect c v = lambda_applist c (Array.to_list v)
@@ -495,11 +465,11 @@ let lambda_applist_assum n c l =
let rec app n subst t l =
if Int.equal n 0 then
if l == [] then substl subst t
- else anomaly (Pp.str "Not enough arguments")
+ else anomaly (Pp.str "Not enough arguments.")
else match kind_of_term t, l with
| Lambda(_,_,c), arg::l -> app (n-1) (arg::subst) c l
| LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l
- | _ -> anomaly (Pp.str "Not enough lambda/let's") in
+ | _ -> anomaly (Pp.str "Not enough lambda/let's.") in
app n [] c l
let lambda_appvect_assum n c v = lambda_applist_assum n c (Array.to_list v)
@@ -510,7 +480,7 @@ let prod_applist c l =
match kind_of_term c, l with
| Prod(_,_,c), arg::l -> app (arg::subst) c l
| _, [] -> substl subst c
- | _ -> anomaly (Pp.str "Not enough prod's") in
+ | _ -> anomaly (Pp.str "Not enough prod's.") in
app [] c l
(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *)
@@ -520,11 +490,11 @@ let prod_applist_assum n c l =
let rec app n subst t l =
if Int.equal n 0 then
if l == [] then substl subst t
- else anomaly (Pp.str "Not enough arguments")
+ else anomaly (Pp.str "Not enough arguments.")
else match kind_of_term t, l with
| Prod(_,_,c), arg::l -> app (n-1) (arg::subst) c l
| LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l
- | _ -> anomaly (Pp.str "Not enough prod/let's") in
+ | _ -> anomaly (Pp.str "Not enough prod/let's.") in
app n [] c l
let prod_appvect_assum n c v = prod_applist_assum n c (Array.to_list v)
@@ -556,26 +526,26 @@ let decompose_lam =
(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T
into the pair ([(xn,Tn);...;(x1,T1)],T) *)
let decompose_prod_n n =
- if n < 0 then error "decompose_prod_n: integer parameter must be positive";
+ if n < 0 then user_err (str "decompose_prod_n: integer parameter must be positive");
let rec prodec_rec l n c =
if Int.equal n 0 then l,c
else match kind_of_term c with
| Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c
| Cast (c,_,_) -> prodec_rec l n c
- | _ -> error "decompose_prod_n: not enough products"
+ | _ -> user_err (str "decompose_prod_n: not enough products")
in
prodec_rec [] n
(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T
into the pair ([(xn,Tn);...;(x1,T1)],T) *)
let decompose_lam_n n =
- if n < 0 then error "decompose_lam_n: integer parameter must be positive";
+ if n < 0 then user_err (str "decompose_lam_n: integer parameter must be positive");
let rec lamdec_rec l n c =
if Int.equal n 0 then l,c
else match kind_of_term c with
| Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c
| Cast (c,_,_) -> lamdec_rec l n c
- | _ -> error "decompose_lam_n: not enough abstractions"
+ | _ -> user_err (str "decompose_lam_n: not enough abstractions")
in
lamdec_rec [] n
@@ -611,7 +581,7 @@ let decompose_lam_assum =
ci,Ti);..;(x1,None,T1)] and of the inner type [T]) *)
let decompose_prod_n_assum n =
if n < 0 then
- error "decompose_prod_n_assum: integer parameter must be positive";
+ user_err (str "decompose_prod_n_assum: integer parameter must be positive");
let rec prodec_rec l n c =
if Int.equal n 0 then l,c
else
@@ -620,7 +590,7 @@ let decompose_prod_n_assum n =
| Prod (x,t,c) -> prodec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
| LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c
| Cast (c,_,_) -> prodec_rec l n c
- | c -> error "decompose_prod_n_assum: not enough assumptions"
+ | c -> user_err (str "decompose_prod_n_assum: not enough assumptions")
in
prodec_rec Context.Rel.empty n
@@ -632,7 +602,7 @@ let decompose_prod_n_assum n =
but n is the actual number of destructurated lambdas. *)
let decompose_lam_n_assum n =
if n < 0 then
- error "decompose_lam_n_assum: integer parameter must be positive";
+ user_err (str "decompose_lam_n_assum: integer parameter must be positive");
let rec lamdec_rec l n c =
if Int.equal n 0 then l,c
else
@@ -641,14 +611,14 @@ let decompose_lam_n_assum n =
| Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
| LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) n c
| Cast (c,_,_) -> lamdec_rec l n c
- | c -> error "decompose_lam_n_assum: not enough abstractions"
+ | c -> user_err (str "decompose_lam_n_assum: not enough abstractions")
in
lamdec_rec Context.Rel.empty n
(* Same, counting let-in *)
let decompose_lam_n_decls n =
if n < 0 then
- error "decompose_lam_n_decls: integer parameter must be positive";
+ user_err (str "decompose_lam_n_decls: integer parameter must be positive");
let rec lamdec_rec l n c =
if Int.equal n 0 then l,c
else
@@ -657,7 +627,7 @@ let decompose_lam_n_decls n =
| Lambda (x,t,c) -> lamdec_rec (Context.Rel.add (LocalAssum (x,t)) l) (n-1) c
| LetIn (x,b,t,c) -> lamdec_rec (Context.Rel.add (LocalDef (x,b,t)) l) (n-1) c
| Cast (c,_,_) -> lamdec_rec l n c
- | c -> error "decompose_lam_n_decls: not enough abstractions"
+ | c -> user_err (str "decompose_lam_n_decls: not enough abstractions")
in
lamdec_rec Context.Rel.empty n
@@ -690,7 +660,7 @@ let destArity =
| LetIn (x,b,t,c) -> prodec_rec (LocalDef (x,b,t) :: l) c
| Cast (c,_,_) -> prodec_rec l c
| Sort s -> l,s
- | _ -> anomaly ~label:"destArity" (Pp.str "not an arity")
+ | _ -> anomaly ~label:"destArity" (Pp.str "not an arity.")
in
prodec_rec []
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-01 15:56:20 +0000