Now CicMetaSubst.delift_rels restricts the Metas when a failure is faced.

This closes yet another bug in the inference of the outtype for matches.

diff --git a/helm/ocaml/cic_unification/cicMetaSubst.ml b/helm/ocaml/cic_unification/cicMetaSubst.ml
index 021e87ea5c6a6c1221566fcf42b3b0dfe6bca738..768255a1493db265c087ecad4355b934d8354b19 100644 (file)
--- a/helm/ocaml/cic_unification/cicMetaSubst.ml
+++ b/helm/ocaml/cic_unification/cicMetaSubst.ml
@@ -761,77 +761,139 @@ debug_print(sprintf
 (* delifts a term t of n levels strating from k, that is changes (Rel m)
  * to (Rel (m - n)) when m > (k + n). if k <= m < k + n delift fails
  *)
-let delift_rels_from k n =
- let rec liftaux k =
+let delift_rels_from subst metasenv k n =
+ let rec liftaux subst metasenv k =
   let module C = Cic in
    function
       C.Rel m ->
        if m < k then
-        C.Rel m
+        C.Rel m, subst, metasenv
        else if m < k + n then
          raise DeliftingARelWouldCaptureAFreeVariable
        else
-        C.Rel (m - n)
+        C.Rel (m - n), subst, metasenv
     | C.Var (uri,exp_named_subst) ->
-       let exp_named_subst' = 
-        List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
+       let exp_named_subst',subst,metasenv = 
+        List.fold_right
+         (fun (uri,t) (l,subst,metasenv) ->
+           let t',subst,metasenv = liftaux subst metasenv k t in
+            (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv)
        in
-        C.Var (uri,exp_named_subst')
+        C.Var (uri,exp_named_subst'),subst,metasenv
     | C.Meta (i,l) ->
-       let l' =
-        List.map
-         (function
-             None -> None
-           | Some t -> Some (liftaux k t)
-         ) l
-       in
-        C.Meta(i,l')
-    | C.Sort _ as t -> t
-    | C.Implicit _ as t -> t
-    | C.Cast (te,ty) -> C.Cast (liftaux k te, liftaux k ty)
-    | C.Prod (n,s,t) -> C.Prod (n, liftaux k s, liftaux (k+1) t)
-    | C.Lambda (n,s,t) -> C.Lambda (n, liftaux k s, liftaux (k+1) t)
-    | C.LetIn (n,s,t) -> C.LetIn (n, liftaux k s, liftaux (k+1) t)
-    | C.Appl l -> C.Appl (List.map (liftaux k) l)
+        (try
+          let (_, t,_) = lookup_subst i subst in
+           liftaux subst metasenv k (CicSubstitution.subst_meta l t)
+         with CicUtil.Subst_not_found _ -> 
+          let l',to_be_restricted,subst,metasenv =
+           let rec aux con l subst metasenv =
+            match l with
+               [] -> [],[],subst,metasenv
+             | he::tl ->
+                let tl',to_be_restricted,subst,metasenv =
+                 aux (con + 1) tl subst metasenv in
+                let he',more_to_be_restricted,subst,metasenv =
+                 match he with
+                    None -> None,[],subst,metasenv
+                  | Some t ->
+                     try
+                      let t',subst,metasenv = liftaux subst metasenv k t in
+                       Some t',[],subst,metasenv
+                     with
+                      DeliftingARelWouldCaptureAFreeVariable ->
+                       None,[i,con],subst,metasenv
+                in
+                 he'::tl',more_to_be_restricted@to_be_restricted,subst,metasenv
+           in
+            aux 1 l subst metasenv in
+          let metasenv,subst = restrict subst to_be_restricted metasenv in
+           C.Meta(i,l'),subst,metasenv)
+    | C.Sort _ as t -> t,subst,metasenv
+    | C.Implicit _ as t -> t,subst,metasenv
+    | C.Cast (te,ty) ->
+       let te',subst,metasenv = liftaux subst metasenv k te in
+       let ty',subst,metasenv = liftaux subst metasenv k ty in
+        C.Cast (te',ty'),subst,metasenv
+    | C.Prod (n,s,t) ->
+       let s',subst,metasenv = liftaux subst metasenv k s in
+       let t',subst,metasenv = liftaux subst metasenv (k+1) t in
+        C.Prod (n,s',t'),subst,metasenv
+    | C.Lambda (n,s,t) ->
+       let s',subst,metasenv = liftaux subst metasenv k s in
+       let t',subst,metasenv = liftaux subst metasenv (k+1) t in
+        C.Lambda (n,s',t'),subst,metasenv
+    | C.LetIn (n,s,t) ->
+       let s',subst,metasenv = liftaux subst metasenv k s in
+       let t',subst,metasenv = liftaux subst metasenv (k+1) t in
+        C.LetIn (n,s',t'),subst,metasenv
+    | C.Appl l ->
+       let l',subst,metasenv =
+        List.fold_right
+         (fun t (l,subst,metasenv) ->
+           let t',subst,metasenv = liftaux subst metasenv k t in
+            t'::l,subst,metasenv) l ([],subst,metasenv) in
+       C.Appl l',subst,metasenv
     | C.Const (uri,exp_named_subst) ->
-       let exp_named_subst' = 
-        List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
+       let exp_named_subst',subst,metasenv = 
+        List.fold_right
+         (fun (uri,t) (l,subst,metasenv) ->
+           let t',subst,metasenv = liftaux subst metasenv k t in
+            (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv)
        in
-        C.Const (uri,exp_named_subst')
+        C.Const (uri,exp_named_subst'),subst,metasenv
     | C.MutInd (uri,tyno,exp_named_subst) ->
-       let exp_named_subst' = 
-        List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
+       let exp_named_subst',subst,metasenv = 
+        List.fold_right
+         (fun (uri,t) (l,subst,metasenv) ->
+           let t',subst,metasenv = liftaux subst metasenv k t in
+            (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv)
        in
-        C.MutInd (uri,tyno,exp_named_subst')
+        C.MutInd (uri,tyno,exp_named_subst'),subst,metasenv
     | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
-       let exp_named_subst' = 
-        List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
+       let exp_named_subst',subst,metasenv = 
+        List.fold_right
+         (fun (uri,t) (l,subst,metasenv) ->
+           let t',subst,metasenv = liftaux subst metasenv k t in
+            (uri,t')::l,subst,metasenv) exp_named_subst ([],subst,metasenv)
        in
-        C.MutConstruct (uri,tyno,consno,exp_named_subst')
+        C.MutConstruct (uri,tyno,consno,exp_named_subst'),subst,metasenv
     | C.MutCase (sp,i,outty,t,pl) ->
-       C.MutCase (sp, i, liftaux k outty, liftaux k t,
-        List.map (liftaux k) pl)
+       let outty',subst,metasenv = liftaux subst metasenv k outty in
+       let t',subst,metasenv = liftaux subst metasenv k t in
+       let pl',subst,metasenv =
+        List.fold_right
+         (fun t (l,subst,metasenv) ->
+           let t',subst,metasenv = liftaux subst metasenv k t in
+            t'::l,subst,metasenv) pl ([],subst,metasenv)
+       in
+        C.MutCase (sp,i,outty',t',pl'),subst,metasenv
     | C.Fix (i, fl) ->
        let len = List.length fl in
-       let liftedfl =
-        List.map
-         (fun (name, i, ty, bo) -> (name, i, liftaux k ty, liftaux (k+len) bo))
-          fl
+       let liftedfl,subst,metasenv =
+        List.fold_right
+         (fun (name, i, ty, bo) (l,subst,metasenv) ->
+           let ty',subst,metasenv = liftaux subst metasenv k ty in
+           let bo',subst,metasenv = liftaux subst metasenv (k+len) bo in
+            (name,i,ty',bo')::l,subst,metasenv
+         ) fl ([],subst,metasenv)
        in
-        C.Fix (i, liftedfl)
+        C.Fix (i, liftedfl),subst,metasenv
     | C.CoFix (i, fl) ->
        let len = List.length fl in
-       let liftedfl =
-        List.map
-         (fun (name, ty, bo) -> (name, liftaux k ty, liftaux (k+len) bo))
-          fl
+       let liftedfl,subst,metasenv =
+        List.fold_right
+         (fun (name, ty, bo) (l,subst,metasenv) ->
+           let ty',subst,metasenv = liftaux subst metasenv k ty in
+           let bo',subst,metasenv = liftaux subst metasenv (k+len) bo in
+            (name,ty',bo')::l,subst,metasenv
+         ) fl ([],subst,metasenv)
        in
-        C.CoFix (i, liftedfl)
+        C.CoFix (i, liftedfl),subst,metasenv
  in
- liftaux k
+  liftaux subst metasenv k
 
-let delift_rels n t =
-  delift_rels_from 1 n t
+let delift_rels subst metasenv n t =
+  delift_rels_from subst metasenv 1 n t
  
 
 (**** END OF DELIFT ****)

diff --git a/helm/ocaml/cic_unification/cicMetaSubst.mli b/helm/ocaml/cic_unification/cicMetaSubst.mli
index 04e493ec27b46fce5f0c403a4096b4e469deac82..a816d86b9cc8af9d333263a18b9a59e98927ae9d 100644 (file)
--- a/helm/ocaml/cic_unification/cicMetaSubst.mli
+++ b/helm/ocaml/cic_unification/cicMetaSubst.mli
@@ -55,7 +55,9 @@ val restrict :
 (** delifts the Rels in t of n
  *  @raise DeliftingARelWouldCaptureAFreeVariable
  *)
-val delift_rels : int -> Cic.term -> Cic.term
+val delift_rels :
+ Cic.substitution -> Cic.metasenv -> int -> Cic.term ->
+  Cic.term * Cic.substitution * Cic.metasenv
  
 (** {2 Pretty printers} *)
 

diff --git a/helm/ocaml/cic_unification/cicRefine.ml b/helm/ocaml/cic_unification/cicRefine.ml
index e64499b3b94a819723a603fe803efab7fc067a91..a9593c67fb617782815a6631fcc3cfa18c9b5f06 100644 (file)
--- a/helm/ocaml/cic_unification/cicRefine.ml
+++ b/helm/ocaml/cic_unification/cicRefine.ml
@@ -506,9 +506,9 @@ and type_of_aux' metasenv context t ugraph =
                      (Some candidate),ugraph4,metasenv,subst
                  | (constructor_args_no,_,instance,_)::tl -> 
                      try
-                       let instance' = 
-                         CicMetaSubst.delift_rels constructor_args_no
-                           (CicMetaSubst.apply_subst subst instance)
+                       let instance',subst,metasenv = 
+                         CicMetaSubst.delift_rels subst metasenv
+                          constructor_args_no instance
                        in
                        let candidate,ugraph,metasenv,subst =
                          List.fold_left (
@@ -518,10 +518,9 @@ and type_of_aux' metasenv context t ugraph =
                                | None -> None,ugraph,metasenv,subst
                                | Some ty ->
                                  try 
-                                   let instance' = 
-                                     CicMetaSubst.delift_rels
-                                      constructor_args_no
-                                       (CicMetaSubst.apply_subst subst instance)
+                                   let instance',subst,metasenv = 
+                                     CicMetaSubst.delift_rels subst metasenv
+                                      constructor_args_no instance
                                    in
                                    let subst,metasenv,ugraph =
                                     fo_unif_subst subst context metasenv