height of constants properly handled

[helm.git] / helm / software / components / ng_kernel / nCicTypeChecker.ml

diff --git a/helm/software/components/ng_kernel/nCicTypeChecker.ml b/helm/software/components/ng_kernel/nCicTypeChecker.ml
index dea9d32c6a1cf3100c6f79ee213cc6618704fbe5..6ce59e2631f26d37a6abb8535d0975539a613fdd 100644 (file)
--- a/helm/software/components/ng_kernel/nCicTypeChecker.ml
+++ b/helm/software/components/ng_kernel/nCicTypeChecker.ml
@@ -104,8 +104,8 @@ let debruijn uri number_of_types context =
       let l1 = HExtlib.sharing_map (aux (k-s)) l in
       if l1 == l then t else C.Meta (i,(s,C.Ctx l1))
    | C.Meta _ -> t
-   | C.Const (Ref.Ref (_,uri1,(Ref.Fix (no,_) | Ref.CoFix no))) 
-   | C.Const (Ref.Ref (_,uri1,Ref.Ind (_,no))) when NUri.eq uri uri1 ->
+   | C.Const (Ref.Ref (uri1,(Ref.Fix (no,_,_) | Ref.CoFix no))) 
+   | C.Const (Ref.Ref (uri1,Ref.Ind (_,no))) when NUri.eq uri uri1 ->
       C.Rel (k + number_of_types - no)
    | t -> U.map (fun _ k -> k+1) k aux t
  in
@@ -182,8 +182,8 @@ let rec instantiate_parameters params c =
 
 let specialize_inductive_type_constrs ~subst context ty_term =
   match R.whd ~subst context ty_term with
-  | C.Const (Ref.Ref (_,uri,Ref.Ind (_,i)) as ref)  
-  | C.Appl (C.Const (Ref.Ref (_,uri,Ref.Ind (_,i)) as ref) :: _ ) as ty ->
+  | C.Const (Ref.Ref (uri,Ref.Ind (_,i)) as ref)  
+  | C.Appl (C.Const (Ref.Ref (uri,Ref.Ind (_,i)) as ref) :: _ ) as ty ->
       let args = match ty with C.Appl (_::tl) -> tl | _ -> [] in
       let is_ind, leftno, itl, attrs, i = E.get_checked_indtys ref in
       let left_args,_ = HExtlib.split_nth leftno args in
@@ -268,14 +268,14 @@ let rec weakly_positive ~subst context n nn uri te =
   let dummy = C.Sort (C.Type ~-1) in
   (*CSC: mettere in cicSubstitution *)
   let rec subst_inductive_type_with_dummy _ = function
-    | C.Const (Ref.Ref (_,uri',Ref.Ind (true,0))) when NUri.eq uri' uri -> dummy
-    | C.Appl ((C.Const (Ref.Ref (_,uri',Ref.Ind (true,0))))::tl) 
+    | C.Const (Ref.Ref (uri',Ref.Ind (true,0))) when NUri.eq uri' uri -> dummy
+    | C.Appl ((C.Const (Ref.Ref (uri',Ref.Ind (true,0))))::tl) 
         when NUri.eq uri' uri -> dummy
     | t -> U.map (fun _ x->x) () subst_inductive_type_with_dummy t
   in
   match R.whd context te with
-   | C.Const (Ref.Ref (_,uri',Ref.Ind _))
-   | C.Appl ((C.Const (Ref.Ref (_,uri',Ref.Ind _)))::_) 
+   | C.Const (Ref.Ref (uri',Ref.Ind _))
+   | C.Appl ((C.Const (Ref.Ref (uri',Ref.Ind _)))::_) 
       when NUri.eq uri' uri -> true
    | C.Prod (name,source,dest) when
       does_not_occur ~subst ((name,C.Decl source)::context) 0 1 dest ->
@@ -301,7 +301,7 @@ and strictly_positive ~subst context n nn te =
        strictly_positive ~subst ((name,C.Decl so)::context) (n+1) (nn+1) ta
    | C.Appl ((C.Rel m)::tl) when m > n && m <= nn ->
       List.for_all (does_not_occur ~subst context n nn) tl
-   | C.Appl (C.Const (Ref.Ref (_,uri,Ref.Ind (_,i)) as r)::tl) -> 
+   | C.Appl (C.Const (Ref.Ref (uri,Ref.Ind (_,i)) as r)::tl) -> 
       let _,paramsno,tyl,_,i = E.get_checked_indtys r in
       let _,name,ity,cl = List.nth tyl i in
       let ok = List.length tyl = 1 in
@@ -435,7 +435,7 @@ let rec typeof ~subst ~metasenv context term =
 *)
        eat_prods ~subst ~metasenv context he ty_he args_with_ty
    | C.Appl _ -> raise (AssertFailure (lazy "Appl of length < 2"))
-   | C.Match (Ref.Ref (_,_,Ref.Ind (_,tyno)) as r,outtype,term,pl) ->
+   | C.Match (Ref.Ref (_,Ref.Ind (_,tyno)) as r,outtype,term,pl) ->
       let outsort = typeof_aux context outtype in
       let inductive,leftno,itl,_,_ = E.get_checked_indtys r in
       let constructorsno =
@@ -445,8 +445,8 @@ let rec typeof ~subst ~metasenv context term =
         let ty = R.whd ~subst context (typeof_aux context term) in
         let r',tl =
          match ty with
-            C.Const (Ref.Ref (_,_,Ref.Ind _) as r') -> r',[]
-          | C.Appl (C.Const (Ref.Ref (_,_,Ref.Ind _) as r') :: tl) -> r',tl
+            C.Const (Ref.Ref (_,Ref.Ind _) as r') -> r',[]
+          | C.Appl (C.Const (Ref.Ref (_,Ref.Ind _) as r') :: tl) -> r',tl
           | _ ->
              raise 
                (TypeCheckerFailure (lazy (Printf.sprintf
@@ -512,8 +512,8 @@ let rec typeof ~subst ~metasenv context term =
 
   and type_of_branch ~subst context leftno outty cons tycons liftno = 
     match R.whd ~subst context tycons with
-    | C.Const (Ref.Ref (_,_,Ref.Ind _)) -> C.Appl [S.lift liftno outty ; cons]
-    | C.Appl (C.Const (Ref.Ref (_,_,Ref.Ind _))::tl) ->
+    | C.Const (Ref.Ref (_,Ref.Ind _)) -> C.Appl [S.lift liftno outty ; cons]
+    | C.Appl (C.Const (Ref.Ref (_,Ref.Ind _))::tl) ->
         let _,arguments = HExtlib.split_nth leftno tl in
         C.Appl (S.lift liftno outty::arguments@[cons])
     | C.Prod (name,so,de) ->
@@ -756,7 +756,7 @@ and guarded_by_destructors r_uri r_len ~subst ~metasenv context recfuns t =
      | _,C.Decl _ -> ()
      | _,C.Def (bo,_) -> aux k (S.lift m bo))
   | C.Meta _ -> ()
-  | C.Appl (C.Const ((Ref.Ref (_,uri,Ref.Fix (i,recno))) as r)::args) ->
+  | C.Appl (C.Const ((Ref.Ref (uri,Ref.Fix (i,recno,_))) as r)::args) ->
       if List.exists (fun t -> try aux k t;false with NotGuarded _ -> true) args
       then
       let fl,_,_ = E.get_checked_fixes_or_cofixes r in
@@ -805,7 +805,7 @@ and guarded_by_destructors r_uri r_len ~subst ~metasenv context recfuns t =
          ) bos
       in
        List.iter (fun (bo,k) -> aux k bo) bos_and_ks
-  | C.Match (Ref.Ref (_,uri,Ref.Ind (true,_)),outtype,term,pl) as t ->
+  | C.Match (Ref.Ref (uri,Ref.Ind (true,_)),outtype,term,pl) as t ->
      (match R.whd ~subst context term with
      | C.Rel m | C.Appl (C.Rel m :: _ ) as t when is_safe m recfuns || m = x ->
          let ty = typeof ~subst ~metasenv context term in
@@ -839,15 +839,15 @@ and guarded_by_constructors ~subst ~metasenv context t indURI indlen nn =
    | C.Sort _
    | C.Implicit _
    | C.Prod _
-   | C.Const (Ref.Ref (_,_,Ref.Ind _))
+   | C.Const (Ref.Ref (_,Ref.Ind _))
    | C.LetIn _ -> raise (AssertFailure (lazy "17"))
    | C.Lambda (name,so,de) ->
       does_not_occur ~subst context n nn so &&
       aux ((name,C.Decl so)::context) (n + 1) (nn + 1) h de
    | C.Appl ((C.Rel m)::tl) when m > n && m <= nn ->
       h && List.for_all (does_not_occur ~subst context n nn) tl
-   | C.Const (Ref.Ref (_,_,Ref.Con _)) -> true
-   | C.Appl (C.Const (Ref.Ref (_,uri, Ref.Con (_,j)) as ref) :: tl) as t ->
+   | C.Const (Ref.Ref (_,Ref.Con _)) -> true
+   | C.Appl (C.Const (Ref.Ref (uri, Ref.Con (_,j)) as ref) :: tl) as t ->
       let _, paramsno, _, _, _ = E.get_checked_indtys ref in
       let ty_t = typeof ~subst ~metasenv context t in
       let dc_ctx, dcl, start, stop = 
@@ -877,8 +877,8 @@ and guarded_by_constructors ~subst ~metasenv context t indURI indlen nn =
        does_not_occur ~subst context n nn out &&
        does_not_occur ~subst context n nn te &&
        List.for_all (aux context n nn h) pl
-   | C.Const (Ref.Ref (_,u,(Ref.Fix _| Ref.CoFix _)) as ref)
-   | C.Appl(C.Const (Ref.Ref(_,u,(Ref.Fix _| Ref.CoFix _)) as ref) :: _) as t ->
+   | C.Const (Ref.Ref (u,(Ref.Fix _| Ref.CoFix _)) as ref)
+   | C.Appl(C.Const (Ref.Ref(u,(Ref.Fix _| Ref.CoFix _)) as ref) :: _) as t ->
       let tl = match t with C.Appl (_::tl) -> tl | _ -> [] in
       let fl,_,_ = E.get_checked_fixes_or_cofixes ref in 
       let len = List.length fl in
@@ -923,11 +923,11 @@ and is_really_smaller
  | C.Appl (he::_) ->
     is_really_smaller r_uri r_len ~subst ~metasenv k he
  | C.Rel _ 
- | C.Const (Ref.Ref (_,_,Ref.Con _)) -> false
+ | C.Const (Ref.Ref (_,Ref.Con _)) -> false
  | C.Appl [] 
- | C.Const (Ref.Ref (_,_,Ref.Fix _)) -> assert false
+ | C.Const (Ref.Ref (_,Ref.Fix _)) -> assert false
  | C.Meta _ -> true 
- | C.Match (Ref.Ref (_,uri,_) as ref,outtype,term,pl) ->
+ | C.Match (Ref.Ref (uri,_) as ref,outtype,term,pl) ->
     (match term with
     | C.Rel m | C.Appl (C.Rel m :: _ ) when is_safe m recfuns || m = x ->
         (* TODO: add CoInd to references so that this call is useless *)
@@ -949,26 +949,26 @@ and is_really_smaller
 
 and returns_a_coinductive ~subst context ty =
   match R.whd ~subst context ty with
-  | C.Const (Ref.Ref (_,uri,Ref.Ind (false,_)) as ref) 
-  | C.Appl (C.Const (Ref.Ref (_,uri,Ref.Ind (false,_)) as ref)::_) ->
+  | C.Const (Ref.Ref (uri,Ref.Ind (false,_)) as ref) 
+  | C.Appl (C.Const (Ref.Ref (uri,Ref.Ind (false,_)) as ref)::_) ->
      let _, _, itl, _, _ = E.get_checked_indtys ref in
      Some (uri,List.length itl)
   | C.Prod (n,so,de) ->
      returns_a_coinductive ~subst ((n,C.Decl so)::context) de
   | _ -> None
 
-and type_of_constant ((Ref.Ref (_,uri,_)) as ref) = 
+and type_of_constant ((Ref.Ref (uri,_)) as ref) = 
   match E.get_checked_obj uri, ref with
-  | (_,_,_,_,C.Inductive (_,_,tl,_)), Ref.Ref (_,_,Ref.Ind (_,i))  ->
+  | (_,_,_,_,C.Inductive (_,_,tl,_)), Ref.Ref (_,Ref.Ind (_,i))  ->
       let _,_,arity,_ = List.nth tl i in arity
-  | (_,_,_,_,C.Inductive (_,_,tl,_)), Ref.Ref (_,_,Ref.Con (i,j))  ->
+  | (_,_,_,_,C.Inductive (_,_,tl,_)), Ref.Ref (_,Ref.Con (i,j))  ->
       let _,_,_,cl = List.nth tl i in 
       let _,_,arity = List.nth cl (j-1) in 
       arity
-  | (_,_,_,_,C.Fixpoint (_,fl,_)), Ref.Ref (_,_,(Ref.Fix (i,_)|Ref.CoFix i)) ->
+  | (_,_,_,_,C.Fixpoint (_,fl,_)), Ref.Ref (_,(Ref.Fix (i,_,_)|Ref.CoFix i)) ->
       let _,_,_,arity,_ = List.nth fl i in
       arity
-  | (_,_,_,_,C.Constant (_,_,_,ty,_)), Ref.Ref (_,_,(Ref.Def |Ref.Decl)) -> ty
+  | (_,_,_,_,C.Constant (_,_,_,ty,_)), Ref.Ref (_,(Ref.Def _|Ref.Decl)) -> ty
   | _ -> raise (AssertFailure (lazy "type_of_constant: environment/reference"))
 ;;
 
@@ -1077,8 +1077,8 @@ let typecheck_obj (uri,height,metasenv,subst,kind) =
              match List.hd context with _,C.Decl t -> t | _ -> assert false
             in
             match R.whd ~subst (List.tl context) he with
-            | C.Const (Ref.Ref (_,uri,Ref.Ind _) as ref)
-            | C.Appl (C.Const (Ref.Ref (_,uri,Ref.Ind _) as ref) :: _) ->
+            | C.Const (Ref.Ref (uri,Ref.Ind _) as ref)
+            | C.Appl (C.Const (Ref.Ref (uri,Ref.Ind _) as ref) :: _) ->
                 let _,_,itl,_,_ = E.get_checked_indtys ref in
                   uri, List.length itl
             | _ -> assert false