diff options
Diffstat (limited to 'kernel/constr.ml')
| -rw-r--r-- | kernel/constr.ml | 208 |
1 files changed, 193 insertions, 15 deletions
diff --git a/kernel/constr.ml b/kernel/constr.ml index cec00c04b3..5930cfadc6 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -233,7 +233,6 @@ let mkMeta n = Meta n (* Constructs a Variable named id *) let mkVar id = Var id - (************************************************************************) (* kind_of_term = constructions as seen by the user *) (************************************************************************) @@ -250,6 +249,168 @@ let of_kind = function | Cast (c, knd, t) -> mkCast (c, knd, t) | k -> k +(**********************************************************************) +(* Non primitive term destructors *) +(**********************************************************************) + +(* Destructor operations : partial functions + Raise [DestKO] if the const has not the expected form *) + +exception DestKO + +let isMeta c = match kind c with Meta _ -> true | _ -> false + +(* Destructs a type *) +let isSort c = match kind c with + | Sort _ -> true + | _ -> false + +let rec isprop c = match kind c with + | Sort (Sorts.Prop _) -> true + | Cast (c,_,_) -> isprop c + | _ -> false + +let rec is_Prop c = match kind c with + | Sort (Sorts.Prop Sorts.Null) -> true + | Cast (c,_,_) -> is_Prop c + | _ -> false + +let rec is_Set c = match kind c with + | Sort (Sorts.Prop Sorts.Pos) -> true + | Cast (c,_,_) -> is_Set c + | _ -> false + +let rec is_Type c = match kind c with + | Sort (Sorts.Type _) -> true + | Cast (c,_,_) -> is_Type c + | _ -> false + +let is_small = Sorts.is_small +let iskind c = isprop c || is_Type c + +(* Tests if an evar *) +let isEvar c = match kind c with Evar _ -> true | _ -> false +let isEvar_or_Meta c = match kind c with + | Evar _ | Meta _ -> true + | _ -> false + +let isCast c = match kind c with Cast _ -> true | _ -> false +(* Tests if a de Bruijn index *) +let isRel c = match kind c with Rel _ -> true | _ -> false +let isRelN n c = + match kind c with Rel n' -> Int.equal n n' | _ -> false +(* Tests if a variable *) +let isVar c = match kind c with Var _ -> true | _ -> false +let isVarId id c = match kind c with Var id' -> Id.equal id id' | _ -> false +(* Tests if an inductive *) +let isInd c = match kind c with Ind _ -> true | _ -> false +let isProd c = match kind c with | Prod _ -> true | _ -> false +let isLambda c = match kind c with | Lambda _ -> true | _ -> false +let isLetIn c = match kind c with LetIn _ -> true | _ -> false +let isApp c = match kind c with App _ -> true | _ -> false +let isConst c = match kind c with Const _ -> true | _ -> false +let isConstruct c = match kind c with Construct _ -> true | _ -> false +let isCase c = match kind c with Case _ -> true | _ -> false +let isProj c = match kind c with Proj _ -> true | _ -> false +let isFix c = match kind c with Fix _ -> true | _ -> false +let isCoFix c = match kind c with CoFix _ -> true | _ -> false + +(* Destructs a de Bruijn index *) +let destRel c = match kind c with + | Rel n -> n + | _ -> raise DestKO + +(* Destructs an existential variable *) +let destMeta c = match kind c with + | Meta n -> n + | _ -> raise DestKO + +(* Destructs a variable *) +let destVar c = match kind c with + | Var id -> id + | _ -> raise DestKO + +let destSort c = match kind c with + | Sort s -> s + | _ -> raise DestKO + +(* Destructs a casted term *) +let destCast c = match kind c with + | Cast (t1,k,t2) -> (t1,k,t2) + | _ -> raise DestKO + +(* Destructs the product (x:t1)t2 *) +let destProd c = match kind c with + | Prod (x,t1,t2) -> (x,t1,t2) + | _ -> raise DestKO + +(* Destructs the abstraction [x:t1]t2 *) +let destLambda c = match kind c with + | Lambda (x,t1,t2) -> (x,t1,t2) + | _ -> raise DestKO + +(* Destructs the let [x:=b:t1]t2 *) +let destLetIn c = match kind c with + | LetIn (x,b,t1,t2) -> (x,b,t1,t2) + | _ -> raise DestKO + +(* Destructs an application *) +let destApp c = match kind c with + | App (f,a) -> (f, a) + | _ -> raise DestKO + +(* Destructs a constant *) +let destConst c = match kind c with + | Const kn -> kn + | _ -> raise DestKO + +(* Destructs an existential variable *) +let destEvar c = match kind c with + | Evar (kn, a as r) -> r + | _ -> raise DestKO + +(* Destructs a (co)inductive type named kn *) +let destInd c = match kind c with + | Ind (kn, a as r) -> r + | _ -> raise DestKO + +(* Destructs a constructor *) +let destConstruct c = match kind c with + | Construct (kn, a as r) -> r + | _ -> raise DestKO + +(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) +let destCase c = match kind c with + | Case (ci,p,c,v) -> (ci,p,c,v) + | _ -> raise DestKO + +let destProj c = match kind c with + | Proj (p, c) -> (p, c) + | _ -> raise DestKO + +let destFix c = match kind c with + | Fix fix -> fix + | _ -> raise DestKO + +let destCoFix c = match kind c with + | CoFix cofix -> cofix + | _ -> raise DestKO + + +(******************************************************************) +(* Flattening and unflattening of embedded applications and casts *) +(******************************************************************) + +let decompose_app c = + match kind c with + | App (f,cl) -> (f, Array.to_list cl) + | _ -> (c,[]) + +let decompose_appvect c = + match kind c with + | App (f,cl) -> (f, cl) + | _ -> (c,[||]) + (****************************************************************************) (* Functions to recur through subterms *) (****************************************************************************) @@ -513,6 +674,7 @@ let compare_head_gen_leq_with kind1 kind2 eq_universes leq_sorts eq leq t1 t2 = | Prod (_,t1,c1), Prod (_,t2,c2) -> eq t1 t2 && leq c1 c2 | Lambda (_,t1,c1), Lambda (_,t2,c2) -> eq t1 t2 && eq c1 c2 | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> eq b1 b2 && eq t1 t2 && leq c1 c2 + (* Why do we suddenly make a special case for Cast here? *) | App (Cast(c1, _, _),l1), _ -> leq (mkApp (c1,l1)) t2 | _, App (Cast (c2, _, _),l2) -> leq t1 (mkApp (c2,l2)) | App (c1,l1), App (c2,l2) -> @@ -530,7 +692,9 @@ let compare_head_gen_leq_with kind1 kind2 eq_universes leq_sorts eq leq t1 t2 = && Array.equal_norefl eq tl1 tl2 && Array.equal_norefl eq bl1 bl2 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> Int.equal ln1 ln2 && Array.equal_norefl eq tl1 tl2 && Array.equal_norefl eq bl1 bl2 - | _ -> false + | (Rel _ | Meta _ | Var _ | Sort _ | Prod _ | Lambda _ | LetIn _ | App _ + | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ | Fix _ + | CoFix _), _ -> false (* [compare_head_gen_leq u s eq leq c1 c2] compare [c1] and [c2] using [eq] to compare the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, @@ -650,9 +814,6 @@ let always_true _ _ = true let rec eq_constr_nounivs m n = (m == n) || compare_head_gen (fun _ -> always_true) always_true eq_constr_nounivs m n -(** We only use this function over blocks! *) -let tag t = Obj.tag (Obj.repr t) - let constr_ord_int f t1 t2 = let (=?) f g i1 i2 j1 j2= let c = f i1 i2 in @@ -664,35 +825,50 @@ let constr_ord_int f t1 t2 = ((Array.compare Int.compare) =? Int.compare) a1 a2 i1 i2 in match kind t1, kind t2 with + | Cast (c1,_,_), _ -> f c1 t2 + | _, Cast (c2,_,_) -> f t1 c2 + (* Why this special case? *) + | App (Cast(c1,_,_),l1), _ -> f (mkApp (c1,l1)) t2 + | _, App (Cast(c2, _,_),l2) -> f t1 (mkApp (c2,l2)) | Rel n1, Rel n2 -> Int.compare n1 n2 - | Meta m1, Meta m2 -> Int.compare m1 m2 + | Rel _, _ -> -1 | _, Rel _ -> 1 | Var id1, Var id2 -> Id.compare id1 id2 + | Var _, _ -> -1 | _, Var _ -> 1 + | Meta m1, Meta m2 -> Int.compare m1 m2 + | Meta _, _ -> -1 | _, Meta _ -> 1 + | Evar (e1,l1), Evar (e2,l2) -> + (Evar.compare =? (Array.compare f)) e1 e2 l1 l2 + | Evar _, _ -> -1 | _, Evar _ -> 1 | Sort s1, Sort s2 -> Sorts.compare s1 s2 - | Cast (c1,_,_), _ -> f c1 t2 - | _, Cast (c2,_,_) -> f t1 c2 + | Sort _, _ -> -1 | _, Sort _ -> 1 | Prod (_,t1,c1), Prod (_,t2,c2) | Lambda (_,t1,c1), Lambda (_,t2,c2) -> (f =? f) t1 t2 c1 c2 + | Prod _, _ -> -1 | _, Prod _ -> 1 + | Lambda _, _ -> -1 | _, Lambda _ -> 1 | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> ((f =? f) ==? f) b1 b2 t1 t2 c1 c2 - | App (Cast(c1,_,_),l1), _ -> f (mkApp (c1,l1)) t2 - | _, App (Cast(c2, _,_),l2) -> f t1 (mkApp (c2,l2)) + | LetIn _, _ -> -1 | _, LetIn _ -> 1 | App (c1,l1), App (c2,l2) -> (f =? (Array.compare f)) c1 c2 l1 l2 - | Proj (p1,c1), Proj (p2,c2) -> (Projection.compare =? f) p1 p2 c1 c2 - | Evar (e1,l1), Evar (e2,l2) -> - (Evar.compare =? (Array.compare f)) e1 e2 l1 l2 + | App _, _ -> -1 | _, App _ -> 1 | Const (c1,u1), Const (c2,u2) -> Constant.CanOrd.compare c1 c2 + | Const _, _ -> -1 | _, Const _ -> 1 | Ind (ind1, u1), Ind (ind2, u2) -> ind_ord ind1 ind2 + | Ind _, _ -> -1 | _, Ind _ -> 1 | Construct (ct1,u1), Construct (ct2,u2) -> constructor_ord ct1 ct2 + | Construct _, _ -> -1 | _, Construct _ -> 1 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> ((f =? f) ==? (Array.compare f)) p1 p2 c1 c2 bl1 bl2 + | Case _, _ -> -1 | _, Case _ -> 1 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> ((fix_cmp =? (Array.compare f)) ==? (Array.compare f)) ln1 ln2 tl1 tl2 bl1 bl2 + | Fix _, _ -> -1 | _, Fix _ -> 1 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> ((Int.compare =? (Array.compare f)) ==? (Array.compare f)) ln1 ln2 tl1 tl2 bl1 bl2 - | t1, t2 -> Int.compare (tag t1) (tag t2) + | CoFix _, _ -> -1 | _, CoFix _ -> 1 + | Proj (p1,c1), Proj (p2,c2) -> (Projection.compare =? f) p1 p2 c1 c2 let rec compare m n= constr_ord_int compare m n @@ -776,7 +952,9 @@ let hasheq t1 t2 = && array_eqeq lna1 lna2 && array_eqeq tl1 tl2 && array_eqeq bl1 bl2 - | _ -> false + | (Rel _ | Meta _ | Var _ | Sort _ | Cast _ | Prod _ | Lambda _ | LetIn _ + | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ + | Fix _ | CoFix _), _ -> false (** Note that the following Make has the side effect of creating once and for all the table we'll use for hash-consing all constr *) |