BIG FAT COMMIT REGARDING COERCIONS:

[helm.git] / components / cic / cicUtil.ml

diff --git a/components/cic/cicUtil.ml b/components/cic/cicUtil.ml
index 7c6e3eabe28619cc14fdd0cb812f998566d38b52..6e07a4995d8ed5d436f43138a1374123b6f79f65 100644 (file)
--- a/components/cic/cicUtil.ml
+++ b/components/cic/cicUtil.ml
@@ -207,6 +207,17 @@ let attributes_of_obj = function
   | Cic.CurrentProof (_, _, _, _, _, attributes)
   | Cic.InductiveDefinition (_, _, _, attributes) ->
       attributes
+
+let arity_of_composed_coercion obj =
+  let attrs = attributes_of_obj obj in
+  try
+    let tag=List.find (function `Class (`Coercion _) -> true|_->false) attrs in
+    match tag with
+    |  `Class (`Coercion n) -> n
+    | _-> assert false 
+  with Not_found -> 0
+;;
+      
 let rec mk_rels howmany from =
   match howmany with 
   | 0 -> []
@@ -363,3 +374,77 @@ let rehash_obj =
      in
      C.InductiveDefinition (tl', params', paramsno, attrs)
 
+let rec metas_of_term = function
+  | Cic.Meta (i, c) -> [i,c]
+  | Cic.Var (_, ens) 
+  | Cic.Const (_, ens) 
+  | Cic.MutInd (_, _, ens) 
+  | Cic.MutConstruct (_, _, _, ens) ->
+      List.flatten (List.map (fun (u, t) -> metas_of_term t) ens)
+  | Cic.Cast (s, t)
+  | Cic.Prod (_, s, t)
+  | Cic.Lambda (_, s, t)
+  | Cic.LetIn (_, s, t) -> (metas_of_term s) @ (metas_of_term t)
+  | Cic.Appl l -> List.flatten (List.map metas_of_term l)
+  | Cic.MutCase (uri, i, s, t, l) ->
+      (metas_of_term s) @ (metas_of_term t) @
+        (List.flatten (List.map metas_of_term l))
+  | Cic.Fix (i, il) ->
+      List.flatten
+        (List.map (fun (s, i, t1, t2) ->
+                     (metas_of_term t1) @ (metas_of_term t2)) il)
+  | Cic.CoFix (i, il) ->
+      List.flatten
+        (List.map (fun (s, t1, t2) ->
+                     (metas_of_term t1) @ (metas_of_term t2)) il)
+  | _ -> []
+;;      
+
+module MetaOT = struct
+  type t = int * Cic.term option list
+  let compare = Pervasives.compare
+end
+
+module S = Set.Make(MetaOT)
+
+let rec metas_of_term_set = function
+  | Cic.Meta (i, c) -> S.singleton (i,c)
+  | Cic.Var (_, ens) 
+  | Cic.Const (_, ens) 
+  | Cic.MutInd (_, _, ens) 
+  | Cic.MutConstruct (_, _, _, ens) ->
+      List.fold_left 
+        (fun s (_,t) -> S.union s (metas_of_term_set t)) 
+        S.empty ens
+  | Cic.Cast (s, t)
+  | Cic.Prod (_, s, t)
+  | Cic.Lambda (_, s, t)
+  | Cic.LetIn (_, s, t) -> S.union (metas_of_term_set s) (metas_of_term_set t)
+  | Cic.Appl l -> 
+      List.fold_left 
+        (fun s t -> S.union s (metas_of_term_set t)) 
+        S.empty l
+  | Cic.MutCase (uri, i, s, t, l) ->
+      S.union 
+        (S.union (metas_of_term_set s)  (metas_of_term_set t))
+        (List.fold_left 
+          (fun s t -> S.union s (metas_of_term_set t)) 
+          S.empty l)
+  | Cic.Fix (_, il) ->
+      (List.fold_left 
+        (fun s (_,_,t1,t2) -> 
+          S.union s (S.union (metas_of_term_set t1) (metas_of_term_set t2))))
+        S.empty il
+  | Cic.CoFix (i, il) ->
+      (List.fold_left 
+        (fun s (_,t1,t2) -> 
+          S.union s (S.union (metas_of_term_set t1) (metas_of_term_set t2))))
+        S.empty il
+  | _ -> S.empty
+;;      
+
+let metas_of_term_set t = 
+  let s = metas_of_term_set t in
+  S.elements s
+;;
+