aboutsummaryrefslogtreecommitdiff
path: root/kernel
diff options
context:
space:
mode:
Diffstat (limited to 'kernel')
-rw-r--r--kernel/cbytecodes.ml5
-rw-r--r--kernel/cbytecodes.mli1
-rw-r--r--kernel/cbytegen.ml33
-rw-r--r--kernel/constr.ml16
-rw-r--r--kernel/inductive.ml11
-rw-r--r--kernel/modops.ml1
-rw-r--r--kernel/modops.mli1
-rw-r--r--kernel/nativecode.ml6
-rw-r--r--kernel/nativelambda.ml3
-rw-r--r--kernel/nativevalues.ml2
-rw-r--r--kernel/reduction.ml65
-rw-r--r--kernel/sorts.ml57
-rw-r--r--kernel/sorts.mli7
-rw-r--r--kernel/subtyping.ml81
-rw-r--r--kernel/term.ml5
-rw-r--r--kernel/term.mli5
-rw-r--r--kernel/typeops.ml16
-rw-r--r--kernel/typeops.mli1
-rw-r--r--kernel/uGraph.ml39
-rw-r--r--kernel/uGraph.mli3
-rw-r--r--kernel/univ.ml9
21 files changed, 157 insertions, 210 deletions
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
index 521f540d22..3095ce148b 100644
--- a/kernel/cbytecodes.ml
+++ b/kernel/cbytecodes.ml
@@ -217,6 +217,7 @@ type vm_env = {
type comp_env = {
+ arity : int; (* arity of the current function, 0 if none *)
nb_uni_stack : int ; (* number of universes on the stack, *)
(* universes are always at the bottom. *)
nb_stack : int; (* number of variables on the stack *)
@@ -235,8 +236,8 @@ open Util
let pp_sort s =
let open Sorts in
match s with
- | Prop Null -> str "Prop"
- | Prop Pos -> str "Set"
+ | Prop -> str "Prop"
+ | Set -> str "Set"
| Type u -> str "Type@{" ++ Univ.pr_uni u ++ str "}"
let rec pp_struct_const = function
diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli
index 238edc0af5..de21401b31 100644
--- a/kernel/cbytecodes.mli
+++ b/kernel/cbytecodes.mli
@@ -159,6 +159,7 @@ type vm_env = {
type comp_env = {
+ arity : int; (* arity of the current function, 0 if none *)
nb_uni_stack : int ; (** number of universes on the stack *)
nb_stack : int; (** number of variables on the stack *)
in_stack : int list; (** position in the stack *)
diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml
index 7a27a3d206..6677db2fd9 100644
--- a/kernel/cbytegen.ml
+++ b/kernel/cbytegen.ml
@@ -112,8 +112,9 @@ let push_fv d e = {
let fv r = !(r.in_env)
-let empty_comp_env ?(univs=0) ()=
- { nb_uni_stack = univs;
+let empty_comp_env ()=
+ { arity = 0;
+ nb_uni_stack = 0;
nb_stack = 0;
in_stack = [];
nb_rec = 0;
@@ -148,7 +149,8 @@ let rec add_param n sz l =
if Int.equal n 0 then l else add_param (n - 1) sz (n+sz::l)
let comp_env_fun ?(univs=0) arity =
- { nb_uni_stack = univs ;
+ { arity;
+ nb_uni_stack = univs ;
nb_stack = arity;
in_stack = add_param arity 0 [];
nb_rec = 0;
@@ -159,7 +161,8 @@ let comp_env_fun ?(univs=0) arity =
let comp_env_fix_type rfv =
- { nb_uni_stack = 0;
+ { arity = 0;
+ nb_uni_stack = 0;
nb_stack = 0;
in_stack = [];
nb_rec = 0;
@@ -173,7 +176,8 @@ let comp_env_fix ndef curr_pos arity rfv =
for i = ndef downto 1 do
prec := Koffsetclosure (2 * (ndef - curr_pos - i)) :: !prec
done;
- { nb_uni_stack = 0;
+ { arity;
+ nb_uni_stack = 0;
nb_stack = arity;
in_stack = add_param arity 0 [];
nb_rec = ndef;
@@ -183,7 +187,8 @@ let comp_env_fix ndef curr_pos arity rfv =
}
let comp_env_cofix_type ndef rfv =
- { nb_uni_stack = 0;
+ { arity = 0;
+ nb_uni_stack = 0;
nb_stack = 0;
in_stack = [];
nb_rec = 0;
@@ -197,7 +202,8 @@ let comp_env_cofix ndef arity rfv =
for i = 1 to ndef do
prec := Kenvacc i :: !prec
done;
- { nb_uni_stack = 0;
+ { arity;
+ nb_uni_stack = 0;
nb_stack = arity;
in_stack = add_param arity 0 [];
nb_rec = ndef;
@@ -249,8 +255,15 @@ let pos_rel i r sz =
Kenvacc(r.offset + pos)
let pos_universe_var i r sz =
- if i < r.nb_uni_stack then
- Kacc (sz - r.nb_stack - (r.nb_uni_stack - i))
+ (* Compilation of a universe variable can happen either at toplevel (the
+ current closure correspond to a constant and has local universes) or in a
+ local closure (which has no local universes). *)
+ if r.nb_uni_stack != 0 then
+ (* Universe variables are represented by De Bruijn levels (not indices),
+ starting at 0. The shape of the stack will be [v1|..|vn|u1..up|arg1..argq]
+ with size = n + p + q, and q = r.arity. So Kacc (sz - r.arity - 1) will access
+ the last universe. *)
+ Kacc (sz - r.arity - (r.nb_uni_stack - i))
else
let env = !(r.in_env) in
let db = FVuniv_var i in
@@ -498,7 +511,7 @@ let rec compile_lam env cenv lam sz cont =
else comp_app compile_structured_constant compile_universe cenv
(Const_ind ind) (Univ.Instance.to_array u) sz cont
- | Lsort (Sorts.Prop _ as s) ->
+ | Lsort (Sorts.Prop | Sorts.Set as s) ->
compile_structured_constant cenv (Const_sort s) sz cont
| Lsort (Sorts.Type u) ->
(* We represent universes as a global constant with local universes
diff --git a/kernel/constr.ml b/kernel/constr.ml
index 4182293301..45812b5a1e 100644
--- a/kernel/constr.ml
+++ b/kernel/constr.ml
@@ -130,8 +130,8 @@ let mkProp = Sort Sorts.prop
let mkSet = Sort Sorts.set
let mkType u = Sort (Sorts.Type u)
let mkSort = function
- | Sorts.Prop Sorts.Null -> mkProp (* Easy sharing *)
- | Sorts.Prop Sorts.Pos -> mkSet
+ | Sorts.Prop -> mkProp (* Easy sharing *)
+ | Sorts.Set -> mkSet
| s -> Sort s
(* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
@@ -260,17 +260,17 @@ let isSort c = match kind c with
| _ -> false
let rec isprop c = match kind c with
- | Sort (Sorts.Prop _) -> true
+ | Sort (Sorts.Prop | Sorts.Set) -> true
| Cast (c,_,_) -> isprop c
| _ -> false
let rec is_Prop c = match kind c with
- | Sort (Sorts.Prop Sorts.Null) -> true
+ | Sort Sorts.Prop -> true
| Cast (c,_,_) -> is_Prop c
| _ -> false
let rec is_Set c = match kind c with
- | Sort (Sorts.Prop Sorts.Pos) -> true
+ | Sort Sorts.Set -> true
| Cast (c,_,_) -> is_Set c
| _ -> false
@@ -828,8 +828,10 @@ let leq_constr_univs_infer univs m n =
let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in
if UGraph.check_leq univs u1 u2 then true
else
- (cstrs := Univ.enforce_leq u1 u2 !cstrs;
- true)
+ (try let c, _ = UGraph.enforce_leq_alg u1 u2 univs in
+ cstrs := Univ.Constraint.union c !cstrs;
+ true
+ with Univ.UniverseInconsistency _ -> false)
in
let rec eq_constr' nargs m n =
m == n || compare_head_gen eq_universes eq_sorts eq_constr' nargs m n
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index 9130b8778c..584c1af036 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -130,11 +130,6 @@ where
Remark: Set (predicative) is encoded as Type(0)
*)
-let sort_as_univ = let open Sorts in function
-| Type u -> u
-| Prop Null -> Universe.type0m
-| Prop Pos -> Universe.type0
-
(* Template polymorphism *)
(* cons_subst add the mapping [u |-> su] in subst if [u] is not *)
@@ -168,7 +163,7 @@ let make_subst env =
(* arity is a global level which, at typing time, will be enforce *)
(* to be greater than the level of the argument; this is probably *)
(* a useless extra constraint *)
- let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in
+ let s = Sorts.univ_of_sort (snd (dest_arity env (Lazy.force a))) in
make (cons_subst u s subst) (sign, exp, args)
| LocalAssum (na,t) :: sign, Some u::exp, [] ->
(* No more argument here: we add the remaining universes to the *)
@@ -236,8 +231,8 @@ let type_of_inductive_knowing_parameters env ?(polyprop=true) mip args =
(* The max of an array of universes *)
let cumulate_constructor_univ u = let open Sorts in function
- | Prop Null -> u
- | Prop Pos -> Universe.sup Universe.type0 u
+ | Prop -> u
+ | Set -> Universe.sup Universe.type0 u
| Type u' -> Universe.sup u u'
let max_inductive_sort =
diff --git a/kernel/modops.ml b/kernel/modops.ml
index 22f523a9ae..02bab581aa 100644
--- a/kernel/modops.ml
+++ b/kernel/modops.ml
@@ -47,7 +47,6 @@ type signature_mismatch_error =
| RecordFieldExpected of bool
| RecordProjectionsExpected of Name.t list
| NotEqualInductiveAliases
- | NoTypeConstraintExpected
| IncompatibleInstances
| IncompatibleUniverses of Univ.univ_inconsistency
| IncompatiblePolymorphism of env * types * types
diff --git a/kernel/modops.mli b/kernel/modops.mli
index ac76d28cf3..8e7e618fcd 100644
--- a/kernel/modops.mli
+++ b/kernel/modops.mli
@@ -106,7 +106,6 @@ type signature_mismatch_error =
| RecordFieldExpected of bool
| RecordProjectionsExpected of Name.t list
| NotEqualInductiveAliases
- | NoTypeConstraintExpected
| IncompatibleInstances
| IncompatibleUniverses of Univ.univ_inconsistency
| IncompatiblePolymorphism of env * types * types
diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml
index 6821fc980c..74d12f3cde 100644
--- a/kernel/nativecode.ml
+++ b/kernel/nativecode.ml
@@ -71,6 +71,8 @@ let eq_gname gn1 gn2 =
String.equal s1 s2 && eq_constructor c1 c2
| Gconstant (s1, c1), Gconstant (s2, c2) ->
String.equal s1 s2 && Constant.equal c1 c2
+ | Gproj (s1, ind1, i1), Gproj (s2, ind2, i2) ->
+ String.equal s1 s2 && eq_ind ind1 ind2 && Int.equal i1 i2
| Gcase (None, i1), Gcase (None, i2) -> Int.equal i1 i2
| Gcase (Some l1, i1), Gcase (Some l2, i2) -> Int.equal i1 i2 && Label.equal l1 l2
| Gpred (None, i1), Gpred (None, i2) -> Int.equal i1 i2
@@ -86,7 +88,9 @@ let eq_gname gn1 gn2 =
| Ginternal s1, Ginternal s2 -> String.equal s1 s2
| Grel i1, Grel i2 -> Int.equal i1 i2
| Gnamed id1, Gnamed id2 -> Id.equal id1 id2
- | _ -> false
+ | (Gind _| Gconstruct _ | Gconstant _ | Gproj _ | Gcase _ | Gpred _
+ | Gfixtype _ | Gnorm _ | Gnormtbl _ | Ginternal _ | Grel _ | Gnamed _), _ ->
+ false
let dummy_gname =
Grel 0
diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml
index a809e1b181..244e5e0dd9 100644
--- a/kernel/nativelambda.ml
+++ b/kernel/nativelambda.ml
@@ -432,7 +432,6 @@ module Renv =
r
end
-(* What about pattern matching ?*)
let is_lazy prefix t =
match kind t with
| App (f,args) ->
@@ -448,7 +447,7 @@ let is_lazy prefix t =
with Not_found -> true)
| _ -> true
end
- | LetIn _ -> true
+ | LetIn _ | Case _ | Proj _ -> true
| _ -> false
let evar_value sigma ev = sigma.evars_val ev
diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml
index da4413a0ad..3901cb9ce4 100644
--- a/kernel/nativevalues.ml
+++ b/kernel/nativevalues.ml
@@ -116,7 +116,7 @@ let mk_ind_accu ind u =
let mk_sort_accu s u =
let open Sorts in
match s with
- | Prop _ -> mk_accu (Asort s)
+ | Prop | Set -> mk_accu (Asort s)
| Type s ->
let u = Univ.Instance.of_array u in
let s = Univ.subst_instance_universe u s in
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index f4af313867..3228a155f3 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -649,23 +649,19 @@ let check_leq univs u u' =
let check_sort_cmp_universes env pb s0 s1 univs =
let open Sorts in
if not (type_in_type env) then
+ let check_pb u0 u1 =
+ match pb with
+ | CUMUL -> check_leq univs u0 u1
+ | CONV -> check_eq univs u0 u1
+ in
match (s0,s1) with
- | (Prop c1, Prop c2) when is_cumul pb ->
- begin match c1, c2 with
- | Null, _ | _, Pos -> () (* Prop <= Set *)
- | _ -> raise NotConvertible
- end
- | (Prop c1, Prop c2) -> if c1 != c2 then raise NotConvertible
- | (Prop c1, Type u) ->
- let u0 = univ_of_sort s0 in
- (match pb with
- | CUMUL -> check_leq univs u0 u
- | CONV -> check_eq univs u0 u)
- | (Type u, Prop c) -> raise NotConvertible
- | (Type u1, Type u2) ->
- (match pb with
- | CUMUL -> check_leq univs u1 u2
- | CONV -> check_eq univs u1 u2)
+ | Prop, Prop | Set, Set -> ()
+ | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible
+ | Set, Prop -> raise NotConvertible
+ | Set, Type u -> check_pb Univ.type0_univ u
+ | Type u, Prop -> raise NotConvertible
+ | Type u, Set -> check_pb u Univ.type0_univ
+ | Type u0, Type u1 -> check_pb u0 u1
let checked_sort_cmp_universes env pb s0 s1 univs =
check_sort_cmp_universes env pb s0 s1 univs; univs
@@ -693,30 +689,27 @@ let infer_eq (univs, cstrs as cuniv) u u' =
let infer_leq (univs, cstrs as cuniv) u u' =
if UGraph.check_leq univs u u' then cuniv
else
- let cstrs' = Univ.enforce_leq u u' cstrs in
- univs, cstrs'
+ let cstrs', _ = UGraph.enforce_leq_alg u u' univs in
+ univs, Univ.Constraint.union cstrs cstrs'
let infer_cmp_universes env pb s0 s1 univs =
- let open Sorts in
- if type_in_type env then univs
+ if type_in_type env
+ then univs
else
+ let open Sorts in
+ let infer_pb u0 u1 =
+ match pb with
+ | CUMUL -> infer_leq univs u0 u1
+ | CONV -> infer_eq univs u0 u1
+ in
match (s0,s1) with
- | (Prop c1, Prop c2) when is_cumul pb ->
- begin match c1, c2 with
- | Null, _ | _, Pos -> univs (* Prop <= Set *)
- | _ -> raise NotConvertible
- end
- | (Prop c1, Prop c2) -> if c1 == c2 then univs else raise NotConvertible
- | (Prop c1, Type u) ->
- let u0 = univ_of_sort s0 in
- (match pb with
- | CUMUL -> infer_leq univs u0 u
- | CONV -> infer_eq univs u0 u)
- | (Type u, Prop c) -> raise NotConvertible
- | (Type u1, Type u2) ->
- (match pb with
- | CUMUL -> infer_leq univs u1 u2
- | CONV -> infer_eq univs u1 u2)
+ | Prop, Prop | Set, Set -> univs
+ | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible else univs
+ | Set, Prop -> raise NotConvertible
+ | Set, Type u -> infer_pb Univ.type0_univ u
+ | Type u, Prop -> raise NotConvertible
+ | Type u, Set -> infer_pb u Univ.type0_univ
+ | Type u0, Type u1 -> infer_pb u0 u1
let infer_convert_instances ~flex u u' (univs,cstrs) =
let cstrs' =
diff --git a/kernel/sorts.ml b/kernel/sorts.ml
index daeb90be7f..a7bb08f5b6 100644
--- a/kernel/sorts.ml
+++ b/kernel/sorts.ml
@@ -10,22 +10,21 @@
open Univ
-type contents = Pos | Null
-
type family = InProp | InSet | InType
type t =
- | Prop of contents (* proposition types *)
+ | Prop
+ | Set
| Type of Universe.t
-let prop = Prop Null
-let set = Prop Pos
+let prop = Prop
+let set = Set
let type1 = Type type1_univ
let univ_of_sort = function
| Type u -> u
- | Prop Pos -> Universe.type0
- | Prop Null -> Universe.type0m
+ | Set -> Universe.type0
+ | Prop -> Universe.type0m
let sort_of_univ u =
if is_type0m_univ u then prop
@@ -34,36 +33,34 @@ let sort_of_univ u =
let compare s1 s2 =
if s1 == s2 then 0 else
- match s1, s2 with
- | Prop c1, Prop c2 ->
- begin match c1, c2 with
- | Pos, Pos | Null, Null -> 0
- | Pos, Null -> -1
- | Null, Pos -> 1
- end
- | Type u1, Type u2 -> Universe.compare u1 u2
- | Prop _, Type _ -> -1
- | Type _, Prop _ -> 1
+ match s1, s2 with
+ | Prop, Prop -> 0
+ | Prop, _ -> -1
+ | Set, Prop -> 1
+ | Set, Set -> 0
+ | Set, _ -> -1
+ | Type u1, Type u2 -> Universe.compare u1 u2
+ | Type _, _ -> -1
let equal s1 s2 = Int.equal (compare s1 s2) 0
let is_prop = function
- | Prop Null -> true
+ | Prop -> true
| Type u when Universe.equal Universe.type0m u -> true
| _ -> false
let is_set = function
- | Prop Pos -> true
+ | Set -> true
| Type u when Universe.equal Universe.type0 u -> true
| _ -> false
let is_small = function
- | Prop _ -> true
+ | Prop | Set -> true
| Type u -> is_small_univ u
let family = function
- | Prop Null -> InProp
- | Prop Pos -> InSet
+ | Prop -> InProp
+ | Set -> InSet
| Type u when is_type0m_univ u -> InProp
| Type u when is_type0_univ u -> InSet
| Type _ -> InType
@@ -73,15 +70,11 @@ let family_equal = (==)
open Hashset.Combine
let hash = function
-| Prop p ->
- let h = match p with
- | Pos -> 0
- | Null -> 1
- in
- combinesmall 1 h
-| Type u ->
- let h = Univ.Universe.hash u in
- combinesmall 2 h
+ | Prop -> combinesmall 1 0
+ | Set -> combinesmall 1 1
+ | Type u ->
+ let h = Univ.Universe.hash u in
+ combinesmall 2 h
module List = struct
let mem = List.memq
@@ -101,7 +94,7 @@ module Hsorts =
if u' == u then c else Type u'
| s -> s
let eq s1 s2 = match (s1,s2) with
- | (Prop c1, Prop c2) -> c1 == c2
+ | Prop, Prop | Set, Set -> true
| (Type u1, Type u2) -> u1 == u2
|_ -> false
diff --git a/kernel/sorts.mli b/kernel/sorts.mli
index 1bbde26083..cac6229b91 100644
--- a/kernel/sorts.mli
+++ b/kernel/sorts.mli
@@ -10,13 +10,12 @@
(** {6 The sorts of CCI. } *)
-type contents = Pos | Null
-
type family = InProp | InSet | InType
type t =
-| Prop of contents (** Prop and Set *)
-| Type of Univ.Universe.t (** Type *)
+ | Prop
+ | Set
+ | Type of Univ.Universe.t
val set : t
val prop : t
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index 13701d4894..1e58f5c240 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.ml
@@ -17,7 +17,6 @@
open Names
open Univ
open Util
-open Term
open Constr
open Declarations
open Declareops
@@ -138,39 +137,8 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
in
let mib2 = Declareops.subst_mind_body subst2 mib2 in
let check_inductive_type cst name t1 t2 =
-
- (* Due to template polymorphism, the conclusions of
- t1 and t2, if in Type, are generated as the least upper bounds
- of the types of the constructors.
-
- By monotonicity of the infered l.u.b. wrt subtyping (i.e. if X:U
- |- T(X):s and |- M:U' and U'<=U then infer_type(T(M))<=s), each
- universe in the conclusion of t1 has an bounding universe in
- the conclusion of t2, so that we don't need to check the
- subtyping of the conclusions of t1 and t2.
-
- Even if we'd like to recheck it, the inference of constraints
- is not designed to deal with algebraic constraints of the form
- max-univ(u1..un) <= max-univ(u'1..u'n), so that it is not easy
- to recheck it (in short, we would need the actual graph of
- constraints as input while type checking is currently designed
- to output a set of constraints instead) *)
-
- (* So we cheat and replace the subtyping problem on algebraic
- constraints of the form max-univ(u1..un) <= max-univ(u'1..u'n)
- (that we know are necessary true) by trivial constraints that
- the constraint generator knows how to deal with *)
-
- let (ctx1,s1) = dest_arity env t1 in
- let (ctx2,s2) = dest_arity env t2 in
- let s1,s2 =
- match s1, s2 with
- | Type _, Type _ -> (* shortcut here *) Sorts.prop, Sorts.prop
- | (Prop _, Type _) | (Type _,Prop _) ->
- error (NotConvertibleInductiveField name)
- | _ -> (s1, s2) in
check_conv (NotConvertibleInductiveField name)
- cst (inductive_is_polymorphic mib1) infer_conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
+ cst (inductive_is_polymorphic mib1) infer_conv_leq env t1 t2
in
let check_packet cst p1 p2 =
@@ -260,53 +228,8 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
let error why = error_signature_mismatch l spec2 why in
let check_conv cst poly f = check_conv_error error cst poly f in
let check_type poly cst env t1 t2 =
-
let err = NotConvertibleTypeField (env, t1, t2) in
-
- (* If the type of a constant is generated, it may mention
- non-variable algebraic universes that the general conversion
- algorithm is not ready to handle. Anyway, generated types of
- constants are functions of the body of the constant. If the
- bodies are the same in environments that are subtypes one of
- the other, the types are subtypes too (i.e. if Gamma <= Gamma',
- Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T').
- Hence they don't have to be checked again *)
-
- let t1,t2 =
- if isArity t2 then
- let (ctx2,s2) = destArity t2 in
- match s2 with
- | Type v when not (is_univ_variable v) ->
- (* The type in the interface is inferred and is made of algebraic
- universes *)
- begin try
- let (ctx1,s1) = dest_arity env t1 in
- match s1 with
- | Type u when not (is_univ_variable u) ->
- (* Both types are inferred, no need to recheck them. We
- cheat and collapse the types to Prop *)
- mkArity (ctx1,Sorts.prop), mkArity (ctx2,Sorts.prop)
- | Prop _ ->
- (* The type in the interface is inferred, it may be the case
- that the type in the implementation is smaller because
- the body is more reduced. We safely collapse the upper
- type to Prop *)
- mkArity (ctx1,Sorts.prop), mkArity (ctx2,Sorts.prop)
- | Type _ ->
- (* The type in the interface is inferred and the type in the
- implementation is not inferred or is inferred but from a
- more reduced body so that it is just a variable. Since
- constraints of the form "univ <= max(...)" are not
- expressible in the system of algebraic universes: we fail
- (the user has to use an explicit type in the interface *)
- error NoTypeConstraintExpected
- with NotArity ->
- error err end
- | _ ->
- t1,t2
- else
- (t1,t2) in
- check_conv err cst poly infer_conv_leq env t1 t2
+ check_conv err cst poly infer_conv_leq env t1 t2
in
match info1 with
| Constant cb1 ->
diff --git a/kernel/term.ml b/kernel/term.ml
index b44e038e9f..81e344e73a 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -16,14 +16,11 @@ open Vars
open Constr
(* Deprecated *)
-type contents = Sorts.contents = Pos | Null
-[@@ocaml.deprecated "Alias for Sorts.contents"]
-
type sorts_family = Sorts.family = InProp | InSet | InType
[@@ocaml.deprecated "Alias for Sorts.family"]
type sorts = Sorts.t =
- | Prop of Sorts.contents (** Prop and Set *)
+ | Prop | Set
| Type of Univ.Universe.t (** Type *)
[@@ocaml.deprecated "Alias for Sorts.t"]
diff --git a/kernel/term.mli b/kernel/term.mli
index f651d1a580..4d340399d3 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -190,13 +190,10 @@ type ('constr, 'types) kind_of_type =
val kind_of_type : types -> (constr, types) kind_of_type
(* Deprecated *)
-type contents = Sorts.contents = Pos | Null
-[@@ocaml.deprecated "Alias for Sorts.contents"]
-
type sorts_family = Sorts.family = InProp | InSet | InType
[@@ocaml.deprecated "Alias for Sorts.family"]
type sorts = Sorts.t =
- | Prop of Sorts.contents (** Prop and Set *)
+ | Prop | Set
| Type of Univ.Universe.t (** Type *)
[@@ocaml.deprecated "Alias for Sorts.t"]
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index 34ed2afb27..7c0057696e 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -69,7 +69,7 @@ let type_of_type u =
mkType uu
let type_of_sort = function
- | Prop c -> type1
+ | Prop | Set -> type1
| Type u -> type_of_type u
(*s Type of a de Bruijn index. *)
@@ -178,11 +178,11 @@ let type_of_apply env func funt argsv argstv =
let sort_of_product env domsort rangsort =
match (domsort, rangsort) with
(* Product rule (s,Prop,Prop) *)
- | (_, Prop Null) -> rangsort
+ | (_, Prop) -> rangsort
(* Product rule (Prop/Set,Set,Set) *)
- | (Prop _, Prop Pos) -> rangsort
+ | ((Prop | Set), Set) -> rangsort
(* Product rule (Type,Set,?) *)
- | (Type u1, Prop Pos) ->
+ | (Type u1, Set) ->
if is_impredicative_set env then
(* Rule is (Type,Set,Set) in the Set-impredicative calculus *)
rangsort
@@ -190,9 +190,9 @@ let sort_of_product env domsort rangsort =
(* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *)
Type (Universe.sup Universe.type0 u1)
(* Product rule (Prop,Type_i,Type_i) *)
- | (Prop Pos, Type u2) -> Type (Universe.sup Universe.type0 u2)
+ | (Set, Type u2) -> Type (Universe.sup Universe.type0 u2)
(* Product rule (Prop,Type_i,Type_i) *)
- | (Prop Null, Type _) -> rangsort
+ | (Prop, Type _) -> rangsort
(* Product rule (Type_i,Type_i,Type_i) *)
| (Type u1, Type u2) -> Type (Universe.sup u1 u2)
@@ -481,10 +481,6 @@ let judge_of_prop = make_judge mkProp type1
let judge_of_set = make_judge mkSet type1
let judge_of_type u = make_judge (mkType u) (type_of_type u)
-let judge_of_prop_contents = function
- | Null -> judge_of_prop
- | Pos -> judge_of_set
-
let judge_of_relative env k = make_judge (mkRel k) (type_of_relative env k)
let judge_of_variable env x = make_judge (mkVar x) (type_of_variable env x)
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index 546f2d2b4d..3b2abc7771 100644
--- a/kernel/typeops.mli
+++ b/kernel/typeops.mli
@@ -43,7 +43,6 @@ val type1 : types
val type_of_sort : Sorts.t -> types
val judge_of_prop : unsafe_judgment
val judge_of_set : unsafe_judgment
-val judge_of_prop_contents : Sorts.contents -> unsafe_judgment
val judge_of_type : Universe.t -> unsafe_judgment
(** {6 Type of a bound variable. } *)
diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml
index 4a9467de52..bc624ba56d 100644
--- a/kernel/uGraph.ml
+++ b/kernel/uGraph.ml
@@ -747,6 +747,45 @@ let check_constraint g (l,d,r) =
let check_constraints c g =
Constraint.for_all (check_constraint g) c
+let leq_expr (u,m) (v,n) =
+ let d = match m - n with
+ | 1 -> Lt
+ | diff -> assert (diff <= 0); Le
+ in
+ (u,d,v)
+
+let enforce_leq_alg u v g =
+ let enforce_one (u,v) = function
+ | Inr _ as orig -> orig
+ | Inl (cstrs,g) as orig ->
+ if check_smaller_expr g u v then orig
+ else
+ (let c = leq_expr u v in
+ match enforce_constraint c g with
+ | g -> Inl (Constraint.add c cstrs,g)
+ | exception (UniverseInconsistency _ as e) -> Inr e)
+ in
+ (* max(us) <= max(vs) <-> forall u in us, exists v in vs, u <= v *)
+ let c = Universe.map (fun u -> Universe.map (fun v -> (u,v)) v) u in
+ let c = List.cartesians enforce_one (Inl (Constraint.empty,g)) c in
+ (* We pick a best constraint: smallest number of constraints, not an error if possible. *)
+ let order x y = match x, y with
+ | Inr _, Inr _ -> 0
+ | Inl _, Inr _ -> -1
+ | Inr _, Inl _ -> 1
+ | Inl (c,_), Inl (c',_) ->
+ Int.compare (Constraint.cardinal c) (Constraint.cardinal c')
+ in
+ match List.min order c with
+ | Inl x -> x
+ | Inr e -> raise e
+
+(* sanity check wrapper *)
+let enforce_leq_alg u v g =
+ let _,g as cg = enforce_leq_alg u v g in
+ assert (check_leq g u v);
+ cg
+
(* Normalization *)
(** [normalize_universes g] returns a graph where all edges point
diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli
index e6dd629e45..8c2d877b0b 100644
--- a/kernel/uGraph.mli
+++ b/kernel/uGraph.mli
@@ -42,6 +42,9 @@ val merge_constraints : Constraint.t -> t -> t
val check_constraint : t -> univ_constraint -> bool
val check_constraints : Constraint.t -> t -> bool
+(** Picks an arbitrary set of constraints sufficient to ensure [u <= v]. *)
+val enforce_leq_alg : Universe.t -> Universe.t -> t -> Constraint.t * t
+
(** Adds a universe to the graph, ensuring it is >= or > Set.
@raise AlreadyDeclared if the level is already declared in the graph. *)
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 9782312cae..311477daca 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -666,7 +666,7 @@ let constraint_add_leq v u c =
else (* j >= 1 *) (* m = n + k, u <= v+k *)
if Level.equal x y then c (* u <= u+k, trivial *)
else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *)
- else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints.")
+ else Constraint.add (x,Le,y) c (* u <= v implies u <= v+k *)
let check_univ_leq_one u v = Universe.exists (Expr.leq u) v
@@ -674,12 +674,7 @@ let check_univ_leq u v =
Universe.for_all (fun u -> check_univ_leq_one u v) u
let enforce_leq u v c =
- let rec aux acc v =
- match v with
- | v :: l ->
- aux (List.fold_right (fun u -> constraint_add_leq u v) u c) l
- | [] -> acc
- in aux c v
+ List.fold_left (fun c v -> (List.fold_left (fun c u -> constraint_add_leq u v c) c u)) c v
let enforce_leq u v c =
if check_univ_leq u v then c
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-02 18:26:26 +0000