]> matita.cs.unibo.it Git - helm.git/blobdiff - helm/software/components/ng_refiner/nCicUnification.ml
unification pps can be activated by the menu debug
[helm.git] / helm / software / components / ng_refiner / nCicUnification.ml
index bfa1388a98b965d0489b34aebbff4721b0e714df..5353363d507bcbac84e6e939daa89dc0a343c038 100644 (file)
@@ -78,23 +78,43 @@ let eta_reduce subst t =
 module C = NCic;;
 module Ref = NReference;;
 
+let debug = ref false;;
 let indent = ref "";;
-let inside c = indent := !indent ^ String.make 1 c;;
-let outside () = indent := String.sub !indent 0 (String.length !indent -1);;
-
-let pp s = 
+let pp s =
+ if !debug then
   prerr_endline (Printf.sprintf "%-20s" !indent ^ " " ^ Lazy.force s)
-;;  
+ else 
+  ()
+;;
+let inside c =
+ indent := !indent ^ String.make 1 c;
+ if !debug then prerr_endline ("{{{" ^ !indent ^ " ")
+;;
+let outside ok =
+ if !debug then prerr_endline "}}}";
+ if not ok then pp (lazy "exception raised!");
+ try
+  indent := String.sub !indent 0 (String.length !indent -1)
+ with
+  Invalid_argument _ -> indent := "??"; ()
+;;
 
-let pp _ = ();;
+let ppcontext ~metasenv ~subst c = 
+      "\nctx:\n"^ NCicPp.ppcontext ~metasenv ~subst c
+;;
+let ppmetasenv ~subst m = "\nmenv:\n" ^ NCicPp.ppmetasenv ~subst m;;
 
-let fix_sorts swap metasenv subst context meta t =
+let ppcontext ~metasenv:_metasenv ~subst:_subst _context = "";;
+let ppmetasenv ~subst:_subst _metasenv = "";;
+
+let fix_sorts swap exc t =
   let rec aux () = function
     | NCic.Sort (NCic.Type u) as orig ->
         if swap then
          match NCicEnvironment.sup u with
-         | None -> prerr_endline "no sup for" ;
-            raise (fail_exc metasenv subst context meta t)
+         | None ->
+            prerr_endline ("no sup for " ^ NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] orig) ;
+            raise exc
          | Some u1 -> if u = u1 then orig else NCic.Sort (NCic.Type u1)
         else
          NCic.Sort (NCic.Type (
@@ -110,29 +130,67 @@ let fix_sorts swap metasenv subst context meta t =
 let is_locked n subst =
    try
      match NCicUtils.lookup_subst n subst with
-     | Some tag, _,_,_ when NCicMetaSubst.is_out_scope_tag tag -> true
+     | tag, _,_,_ when NCicMetaSubst.is_out_scope_tag tag -> true
      | _ -> false
    with NCicUtils.Subst_not_found _ -> false
 ;;
 
+let rec mk_irl stop base =
+  if base > stop then []
+  else (NCic.Rel base) :: mk_irl stop (base+1) 
+;;
+
+(* the argument must be a term in whd *)
+let rec could_reduce =
+ function
+  | C.Meta _ -> true
+  | C.Appl (C.Const (Ref.Ref (_,Ref.Fix (_,recno,_)))::args)
+     when List.length args > recno -> could_reduce (List.nth args recno)
+  | C.Match (_,_,arg,_) -> could_reduce arg
+  | C.Appl (he::_) -> could_reduce he
+  | C.Sort _ | C.Rel _ | C.Prod _ | C.Lambda _ | C.Const _ -> false
+  | C.Appl [] | C.LetIn _ | C.Implicit _ -> assert false
+;;
 
-let rec lambda_intros metasenv subst context t args =
+let rec lambda_intros rdb metasenv subst context t args =
  let tty = NCicTypeChecker.typeof ~metasenv ~subst context t in
- let argsty = List.map (NCicTypeChecker.typeof ~metasenv ~subst context) args in
- let rec mk_lambda context n = function
-   | [] -> 
+ let argsty =
+  List.map
+  (fun arg -> arg, NCicTypeChecker.typeof ~metasenv ~subst context arg) args in
+ let context_of_args = context in
+ let rec mk_lambda metasenv subst context n processed_args = function
+   | [] ->
        let metasenv, _, bo, _ = 
          NCicMetaSubst.mk_meta metasenv context 
            (`WithType (NCicSubstitution.lift n tty))
        in
-       metasenv, bo
-   | ty::tail -> 
+       metasenv, subst, bo
+   | (arg,ty)::tail ->
+       pp(lazy("arg{ " ^ 
+         NCicPp.ppterm ~metasenv ~subst ~context:context_of_args arg ^  " : " ^
+         NCicPp.ppterm ~metasenv ~subst ~context:context_of_args ty));
+       let metasenv, subst, telescopic_ty = 
+         if processed_args = [] then metasenv, subst, ty else
+         let _ = pp(lazy("delift")) in
+         delift_type_wrt_terms rdb metasenv subst context 
+           (NCicSubstitution.lift n ty)
+           (List.map (NCicSubstitution.lift n) (List.rev processed_args))
+       in
+       pp(lazy("arg} "^NCicPp.ppterm ~metasenv ~subst ~context telescopic_ty));
        let name = "HBeta"^string_of_int n in
-       let ty = NCicSubstitution.lift n ty in
-       let metasenv, bo = mk_lambda ((name,NCic.Decl ty)::context) (n+1) tail in
-       metasenv, NCic.Lambda (name, ty, bo)
+       let metasenv, subst, bo =
+        mk_lambda metasenv subst ((name,NCic.Decl telescopic_ty)::context) (n+1)
+         (arg::processed_args) tail
+       in
+        metasenv, subst, NCic.Lambda (name, telescopic_ty, bo)
  in
-   mk_lambda context 0 argsty
+ pp(lazy("LAMBDA_INTROS{ " ^ 
+   NCicPp.ppterm ~metasenv ~subst ~context t ^  ":" ^
+   NCicPp.ppterm ~metasenv ~subst ~context tty ^ " over " ^ 
+   String.concat "," (List.map (NCicPp.ppterm ~metasenv ~subst ~context)args)));
+ let rc = mk_lambda metasenv subst context 0 [] argsty in
+ pp(lazy("LAMBDA_INTROS}"));
+ rc
 
 and instantiate rdb test_eq_only metasenv subst context n lc t swap =
  (*D*)  inside 'I'; try let rc =  
@@ -142,58 +200,105 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap =
     if swap then unify rdb test_eq_only m s c t2 t1 
     else unify rdb test_eq_only m s c t1 t2
   in
-  let name, ctx, ty = NCicUtils.lookup_meta n metasenv in
+  let has_tag = List.exists in
+  let tags, _, ty = NCicUtils.lookup_meta n metasenv in
+  (* on the types *)
   let metasenv, subst, t = 
     match ty with 
     | NCic.Implicit (`Typeof _) -> 
-       metasenv,subst, t
-         (* fix_sorts swap metasenv subst context (NCic.Meta(n,lc)) t *)
+         pp(lazy("meta with no type"));
+         assert(has_tag ((=)`IsSort) tags); 
+         metasenv, subst, t
     | _ ->
-       pp (lazy (
-         "typeof: " ^ NCicPp.ppterm ~metasenv ~subst ~context t ^ "\nctx:\n"^
-          NCicPp.ppcontext ~metasenv ~subst context ^ "\nmenv:\n"^
-          NCicPp.ppmetasenv ~subst metasenv));
+       let exc_to_be = fail_exc metasenv subst context (NCic.Meta (n,lc)) t in
        let t, ty_t = 
          try t, NCicTypeChecker.typeof ~subst ~metasenv context t 
          with 
-         | NCicTypeChecker.AssertFailure msg -> 
-           (pp (lazy "fine typeof (fallimento)");
-           let ft=fix_sorts swap metasenv subst context (NCic.Meta (n,lc)) t in
-           if ft == t then 
-             (prerr_endline ( ("ILLTYPED: " ^ 
-                NCicPp.ppterm ~metasenv ~subst ~context t
-            ^ "\nBECAUSE:" ^ Lazy.force msg ^ "\nCONTEXT:\n" ^
-            NCicPp.ppcontext ~metasenv ~subst context ^ "\nMENV:\n" ^
-            NCicPp.ppmetasenv ~subst metasenv
-            ));
-                     assert false)
-           else
-            try 
-              pp (lazy ("typeof: " ^ 
-                NCicPp.ppterm ~metasenv ~subst ~context ft));
-              ft, NCicTypeChecker.typeof ~subst ~metasenv context ft 
-            with NCicTypeChecker.AssertFailure _ -> 
-              assert false)
+         | NCicTypeChecker.AssertFailure msg as exn -> 
+              pp(lazy("we try to fix the sort\n"^
+                Lazy.force msg^"\n"^NCicPp.ppmetasenv ~subst metasenv));
+              let ft = fix_sorts swap exc_to_be t in
+              pp(lazy("unable to fix the sort"));
+              if ft == t then raise exn;
+              (try ft, NCicTypeChecker.typeof ~subst ~metasenv context ft 
+               with NCicTypeChecker.AssertFailure _ -> raise exn)
          | NCicTypeChecker.TypeCheckerFailure msg ->
               prerr_endline (Lazy.force msg);
-              pp msg; assert false
+              prerr_endline (NCicPp.ppterm ~metasenv ~subst ~context t);
+              prerr_endline (ppcontext ~metasenv ~subst context); 
+              prerr_endline (ppmetasenv ~subst metasenv);
+              assert false
        in
-       let lty = NCicSubstitution.subst_meta lc ty in
        match ty_t with
-       | NCic.Implicit _ -> 
-           raise (UnificationFailure 
-             (lazy "trying to unify a term with a type"))
-       | ty_t -> 
+       | NCic.Implicit (`Typeof _) -> 
+           raise (UnificationFailure(lazy "trying to unify a term with a type"))
+       | _ -> 
+          let lty = NCicSubstitution.subst_meta lc ty in
           pp (lazy ("On the types: " ^
-           NCicPp.ppterm ~metasenv ~subst ~context:ctx ty ^ " ~~~ " ^
-           NCicPp.ppterm ~metasenv ~subst ~context lty ^ " === "
-            ^ NCicPp.ppterm ~metasenv ~subst ~context ty_t)); 
+              NCicPp.ppterm ~metasenv ~subst ~context lty ^ " === " ^ 
+              NCicPp.ppterm ~metasenv ~subst ~context ty_t)); 
           let metasenv,subst = 
-            unify test_eq_only metasenv subst context lty ty_t in
-          metasenv, subst, t
+           try unify test_eq_only metasenv subst context lty ty_t
+           with NCicEnvironment.BadConstraint _ as exc ->
+            let ty_t = fix_sorts swap exc_to_be ty_t in 
+             try unify test_eq_only metasenv subst context lty ty_t
+             with 
+             | NCicEnvironment.BadConstraint _ 
+             | UnificationFailure _ -> raise exc 
+          in
+           metasenv, subst, t
+  in 
+  (* viral sortification *)
+  let is_sort metasenv subst context t = 
+    match NCicReduction.whd ~subst context t with
+    | NCic.Meta (i,_) ->
+         let tags, _, _ = NCicUtils.lookup_meta i metasenv in
+         has_tag ((=) `IsSort) tags
+    | NCic.Sort _ -> true
+    | _ -> false
   in
-         pp (lazy(string_of_int n ^ " := 111 = "^
-           NCicPp.ppterm ~metasenv ~subst ~context t));
+  let rec sortify metasenv subst = function
+    | NCic.Implicit (`Typeof _) -> assert false 
+    | NCic.Sort _ as t -> metasenv, subst, t, 0
+    | NCic.Meta (i,_) as t -> 
+         let tags, context, ty = NCicUtils.lookup_meta i metasenv in
+         if has_tag ((=) `IsSort) tags then metasenv, subst, t, i
+         else
+           let ty = NCicReduction.whd ~subst context ty in
+           let metasenv, subst, ty, _ = sortify metasenv subst ty in
+           let metasenv, j, m, _ = 
+             NCicMetaSubst.mk_meta metasenv ~attrs:[`IsSort] [] (`WithType ty)
+           in
+           pp(lazy("rimpiazzo " ^ string_of_int i^" con "^string_of_int j));
+           let subst_entry = i, (tags, context, m, ty) in
+           let subst = subst_entry :: subst in
+           let metasenv = List.filter (fun x,_ -> i <> x) metasenv in
+           metasenv, subst, m, j 
+    | NCic.Appl (NCic.Meta _ as hd :: args) as t -> 
+           let metasenv, subst, lambda_Mj =
+             lambda_intros rdb metasenv subst context t args
+           in
+           let metasenv,subst= unify true metasenv subst context hd lambda_Mj in
+           let t = NCicReduction.whd ~subst context t in
+           let _result = sortify metasenv subst t in       
+           (* untested, maybe dead, code *) assert false;
+    | t -> 
+         if could_reduce t then raise (Uncertain(lazy "not a sort"))
+         else raise (UnificationFailure(lazy "not a sort"))
+  in
+  let metasenv, subst, _, n = 
+    if has_tag ((=) `IsSort) tags then
+      let m,s,x,_ = sortify metasenv subst (NCicReduction.whd ~subst context t)
+      in m,s,x,n
+    else if is_sort metasenv subst context t then
+      sortify metasenv subst (NCic.Meta (n,lc))
+    else
+      metasenv, subst, NCic.Rel ~-1,n
+  in
+  let tags, ctx, ty = NCicUtils.lookup_meta n metasenv in
+  (* instantiation *)
+  pp (lazy(string_of_int n ^ " := 111 = "^ 
+    NCicPp.ppterm ~metasenv ~subst ~context t));
   let (metasenv, subst), t = 
     try 
       NCicMetaSubst.delift 
@@ -214,7 +319,7 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap =
   in
          pp (lazy(string_of_int n ^ " := 222 = "^
            NCicPp.ppterm ~metasenv ~subst ~context:ctx t
-         ^ "\n" ^ NCicPp.ppmetasenv ~subst metasenv));
+         ^ ppmetasenv ~subst metasenv));
   (* Unifying the types may have already instantiated n. *)
   try
     let _, _,oldt,_ = NCicUtils.lookup_subst n subst in
@@ -223,23 +328,38 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap =
     (* conjecture: always fail --> occur check *)
     unify test_eq_only metasenv subst context oldt t
   with NCicUtils.Subst_not_found _ -> 
+    let metasenv, tags = 
+      let rec aux = function
+        | NCic.Meta (j,lc) -> 
+            (try 
+              let _, _, t, _ = NCicUtils.lookup_subst j subst in
+              aux (NCicSubstitution.subst_meta lc t)
+            with NCicUtils.Subst_not_found _ -> 
+              let tags', ctx, ty = NCicUtils.lookup_meta j metasenv in
+              let metasenv = List.remove_assoc j metasenv in
+              let tags = tags @ tags' in
+              (j, (tags, ctx, ty)) :: metasenv, tags)
+        | _ -> metasenv, tags
+      in 
+        aux t
+    in
     (* by cumulativity when unify(?,Type_i) 
      * we could ? := Type_j with j <= i... *)
-    let subst = (n, (name, ctx, t, ty)) :: subst in
+    let subst = (n, (tags, ctx, t, ty)) :: subst in
     pp (lazy ("?"^string_of_int n^" := "^NCicPp.ppterm
       ~metasenv ~subst ~context (NCicSubstitution.subst_meta lc t)));
     let metasenv = 
       List.filter (fun (m,_) -> not (n = m)) metasenv 
     in
     metasenv, subst
- (*D*)  in outside(); rc with exn -> outside (); raise exn 
+ (*D*)  in outside true; rc with exn -> outside false; raise exn 
 
 and unify rdb test_eq_only metasenv subst context t1 t2 =
  (*D*) inside 'U'; try let rc =
    let fo_unif test_eq_only metasenv subst t1 t2 =
     (*D*) inside 'F'; try let rc =  
      pp (lazy("  " ^ NCicPp.ppterm ~metasenv ~subst ~context t1 ^ " ==?== " ^ 
-         NCicPp.ppterm ~metasenv ~subst ~context t2 ^ "\n" ^ NCicPp.ppmetasenv
+         NCicPp.ppterm ~metasenv ~subst ~context t2 ^ ppmetasenv
          ~subst metasenv));
      if t1 === t2 then
        metasenv, subst
@@ -305,17 +425,17 @@ and unify rdb test_eq_only metasenv subst context t1 t2 =
        | _, NCic.Meta (n, _) when is_locked n subst ->
            (let (metasenv, subst), i = 
               match NCicReduction.whd ~subst context t1 with
-              | NCic.Appl (NCic.Meta (i,l)::args) when
-                  not (NCicMetaSubst.flexible subst args) 
-                ->
-                 let metasenv, lambda_Mj =
-                   lambda_intros metasenv subst context t1 args
+              | NCic.Appl (NCic.Meta (i,l)::args) ->
+                 let metasenv, subst, lambda_Mj =
+                   lambda_intros rdb metasenv subst context t1 args
                  in
                    unify rdb test_eq_only metasenv subst context 
                     (C.Meta (i,l)) lambda_Mj,
                    i
               | NCic.Meta (i,_) -> (metasenv, subst), i
-              | _ -> assert false
+              | _ ->
+                 raise (UnificationFailure (lazy "Locked term vs non
+                  flexible term; probably not saturated enough yet!"))
              in
               let t1 = NCicReduction.whd ~subst context t1 in
               let j, lj = 
@@ -324,6 +444,17 @@ and unify rdb test_eq_only metasenv subst context t1 t2 =
               let metasenv, subst = 
                 instantiate rdb test_eq_only metasenv subst context j lj t2 true
               in
+              (* We need to remove the out_scope_tags to avoid propagation of
+                 them that triggers again the ad-hoc case *)
+              let subst =
+               List.map (fun (i,(tag,ctx,bo,ty)) ->
+                let tag =
+                 List.filter
+                  (function `InScope | `OutScope _ -> false | _ -> true) tag
+                in
+                  i,(tag,ctx,bo,ty)
+                ) subst
+              in
               (try
                 let name, ctx, term, ty = NCicUtils.lookup_subst i subst in
                 let term = eta_reduce subst term in
@@ -371,45 +502,41 @@ and unify rdb test_eq_only metasenv subst context t1 t2 =
             with Invalid_argument _ -> 
               raise (fail_exc metasenv subst context t1 t2))
 
-       | NCic.Appl (NCic.Meta (i,l)::args), _ when 
-         not (NCicMetaSubst.flexible subst args) ->
-           (* we verify that none of the args is a Meta, 
-              since beta expanding w.r.t a metavariable makes no sense  *)
-              let metasenv, lambda_Mj =
-                lambda_intros metasenv subst context t1 args
-              in
-              let metasenv, subst = 
-                unify rdb test_eq_only metasenv subst context 
-                  (C.Meta (i,l)) lambda_Mj
-              in
-              let metasenv, subst = 
-                unify rdb test_eq_only metasenv subst context t1 t2 
-              in
-              (try
-                let name, ctx, term, ty = NCicUtils.lookup_subst i subst in
-                let term = eta_reduce subst term in
-                let subst = List.filter (fun (j,_) -> j <> i) subst in
-                metasenv, ((i, (name, ctx, term, ty)) :: subst)
-              with Not_found -> assert false)
+       | NCic.Appl (NCic.Meta (i,l)::args), _ ->
+          let metasenv, subst, lambda_Mj =
+            lambda_intros rdb metasenv subst context t1 args
+          in
+          let metasenv, subst = 
+            unify rdb test_eq_only metasenv subst context 
+              (C.Meta (i,l)) lambda_Mj
+          in
+          let metasenv, subst = 
+            unify rdb test_eq_only metasenv subst context t1 t2 
+          in
+          (try
+            let name, ctx, term, ty = NCicUtils.lookup_subst i subst in
+            let term = eta_reduce subst term in
+            let subst = List.filter (fun (j,_) -> j <> i) subst in
+            metasenv, ((i, (name, ctx, term, ty)) :: subst)
+          with Not_found -> assert false)
 
-       | _, NCic.Appl (NCic.Meta (i,l)::args) when 
-         not(NCicMetaSubst.flexible subst args) ->
-              let metasenv, lambda_Mj =
-                lambda_intros metasenv subst context t2 args
-              in
-              let metasenv, subst =
-                unify rdb test_eq_only metasenv subst context 
-                 lambda_Mj (C.Meta (i,l))
-              in
-              let metasenv, subst = 
-                unify rdb test_eq_only metasenv subst context t1 t2 
-              in
-              (try
-                let name, ctx, term, ty = NCicUtils.lookup_subst i subst in
-                let term = eta_reduce subst term in
-                let subst = List.filter (fun (j,_) -> j <> i) subst in
-                metasenv, ((i, (name, ctx, term, ty)) :: subst)
-              with Not_found -> assert false)
+       | _, NCic.Appl (NCic.Meta (i,l)::args) ->
+         let metasenv, subst, lambda_Mj =
+           lambda_intros rdb metasenv subst context t2 args
+         in
+         let metasenv, subst =
+           unify rdb test_eq_only metasenv subst context 
+            lambda_Mj (C.Meta (i,l))
+         in
+         let metasenv, subst = 
+           unify rdb test_eq_only metasenv subst context t1 t2 
+         in
+         (try
+           let name, ctx, term, ty = NCicUtils.lookup_subst i subst in
+           let term = eta_reduce subst term in
+           let subst = List.filter (fun (j,_) -> j <> i) subst in
+           metasenv, ((i, (name, ctx, term, ty)) :: subst)
+         with Not_found -> assert false)
 
        (* processing this case here we avoid a useless small delta step *)
        | (C.Appl ((C.Const r1) as _hd1::tl1), C.Appl (C.Const r2::tl2)) 
@@ -474,29 +601,26 @@ and unify rdb test_eq_only metasenv subst context t1 t2 =
                (fun (metasenv,subst) -> 
                   unify rdb test_eq_only metasenv subst context)
                (metasenv, subst) pl1 pl2
-             with Invalid_argument _ -> 
-               raise (uncert_exc metasenv subst context t1 t2))
+             with Invalid_argument _ -> assert false)
        | (C.Implicit _, _) | (_, C.Implicit _) -> assert false
        | _ when NCicUntrusted.metas_of_term subst context t1 = [] && 
                 NCicUntrusted.metas_of_term subst context t2 = [] -> 
                   raise (fail_exc metasenv subst context t1 t2)
        | _ -> raise (uncert_exc metasenv subst context t1 t2)
-     (*D*)  in outside(); rc with exn -> outside (); raise exn 
+     (*D*)  in outside true; rc with exn -> outside false; raise exn 
     in
     let try_hints metasenv subst t1 t2 (* exc*) =
-(*
-      prerr_endline ("\nProblema:\n" ^
+    (*D*) inside 'H'; try let rc =  
+     pp(lazy ("\nProblema:\n" ^
         NCicPp.ppterm ~metasenv ~subst ~context t1 ^ " =?= " ^
-        NCicPp.ppterm ~metasenv ~subst ~context t2);
-*)
+        NCicPp.ppterm ~metasenv ~subst ~context t2));
       let candidates = 
         NCicUnifHint.look_for_hint rdb metasenv subst context t1 t2
       in
       let rec cand_iter = function
         | [] -> None (* raise exc *)
         | (metasenv,(c1,c2),premises)::tl -> 
-(*
-            prerr_endline ("\nProvo il candidato:\n" ^ 
+            pp (lazy ("\nProvo il candidato:\n" ^ 
               String.concat "\n"
                 (List.map 
                   (fun (a,b) ->
@@ -504,9 +628,9 @@ and unify rdb test_eq_only metasenv subst context t1 t2 =
                    NCicPp.ppterm ~metasenv ~subst ~context b) premises) ^
               "\n-------------------------------------------\n"^
               NCicPp.ppterm ~metasenv ~subst ~context c1 ^  " = " ^
-              NCicPp.ppterm ~metasenv ~subst ~context c2);
-*)
+              NCicPp.ppterm ~metasenv ~subst ~context c2));
             try 
+    (*D*) inside 'K'; try let rc =  
               let metasenv,subst = 
                 fo_unif test_eq_only metasenv subst t1 c1 in
               let metasenv,subst = 
@@ -517,12 +641,15 @@ and unify rdb test_eq_only metasenv subst context t1 t2 =
                      unify rdb test_eq_only metasenv subst context x y)
                   (metasenv, subst) premises
               in
+              pp(lazy("FUNZIONA!"));
               Some (metasenv, subst)
+     (*D*)  in outside true; rc with exn -> outside false; raise exn 
             with
               UnificationFailure _ | Uncertain _ ->
                 cand_iter tl
       in
         cand_iter candidates
+     (*D*)  in outside true; rc with exn -> outside false; raise exn 
     in
     let height_of = function
      | NCic.Const (Ref.Ref (_,Ref.Def h)) 
@@ -567,8 +694,8 @@ pp (lazy (string_of_bool norm1 ^ " ?? " ^ string_of_bool norm2));
             | _ -> [] *) in
           let unif_from_stack t1 t2 b metasenv subst =
               try
-                let t1 = NCicReduction.from_stack t1 in
-                let t2 = NCicReduction.from_stack t2 in
+                let t1 = NCicReduction.from_stack ~delta:max_int t1 in
+                let t2 = NCicReduction.from_stack ~delta:max_int t2 in
                 unif_machines metasenv subst (put_in_whd t1 t2)
               with UnificationFailure _ | Uncertain _ when not b ->
                 metasenv, subst
@@ -591,7 +718,7 @@ pp (lazy (string_of_bool norm1 ^ " ?? " ^ string_of_bool norm2));
           ) (metasenv,subst) todo
         with UnificationFailure _ | Uncertain _ when not (norm1 && norm2) ->
            unif_machines metasenv subst (small_delta_step ~subst m1 m2)
-      (*D*)  in outside(); rc with exn -> outside (); raise exn 
+      (*D*)  in outside true; rc with exn -> outside false; raise exn 
      in
      try fo_unif test_eq_only metasenv subst t1 t2
      with 
@@ -603,18 +730,46 @@ pp (lazy (string_of_bool norm1 ^ " ?? " ^ string_of_bool norm2));
           | UnificationFailure _ -> raise (UnificationFailure msg)
           | Uncertain _ -> raise exn)
      | Uncertain msg as exn -> 
-       match try_hints metasenv subst t1 t2 with
+(*
+       prerr_endline "PROBLEMA";
+       prerr_endline (NCicPp.ppterm ~metasenv ~subst ~context t1);
+       prerr_endline (NCicPp.ppterm ~metasenv ~subst ~context t2);
+*)
+       let (t1,_ as t1m),(t2,_ as t2m) = put_in_whd (0,[],t1,[]) (0,[],t2,[]) in
+       match 
+         try_hints metasenv subst 
+           (NCicReduction.unwind t1) (NCicReduction.unwind t2) 
+       with
        | Some x -> x
        | None -> 
           try 
-            unif_machines metasenv subst 
-             (put_in_whd (0,[],t1,[]) (0,[],t2,[]))
+            unif_machines metasenv subst (t1m, t2m)
           with 
           | UnificationFailure _ -> raise (UnificationFailure msg)
           | Uncertain _ -> raise exn
- (*D*)  in outside(); rc with exn -> outside (); raise exn 
+ (*D*)  in outside true; rc with exn -> outside false; raise exn 
+
+and delift_type_wrt_terms rdb metasenv subst context t args =
+  let lc = List.rev args @ mk_irl (List.length context) (List.length args+1) in
+  let (metasenv, subst), t =
+   try
+    NCicMetaSubst.delift 
+      ~unify:(fun m s c t1 t2 -> 
+         let ind = !indent in
+         let res = 
+           try Some (unify rdb false m s c t1 t2 )
+           with UnificationFailure _ | Uncertain _ -> None
+         in
+         indent := ind; res)
+      metasenv subst context 0 (0,NCic.Ctx lc) t
+   with NCicMetaSubst.MetaSubstFailure _ -> (metasenv, subst), t
+  in
+   metasenv, subst, t
 ;;
 
+
 let unify rdb ?(test_eq_only=false) = 
   indent := "";      
   unify rdb test_eq_only;;
+
+let fix_sorts = fix_sorts true (UnificationFailure (lazy "no sup"));;