to me, the problem:

[helm.git] / helm / software / components / ng_refiner / nCicUnification.ml

diff --git a/helm/software/components/ng_refiner/nCicUnification.ml b/helm/software/components/ng_refiner/nCicUnification.ml
index 325cd3e5f1e5520365a8bcb90712cd4f84e8c8a2..c224708533e5c6789606d943ac37fa4d23a609fb 100644 (file)
--- a/helm/software/components/ng_refiner/nCicUnification.ml
+++ b/helm/software/components/ng_refiner/nCicUnification.ml
@@ -95,6 +95,8 @@ let outside () =
 let pp s = 
   prerr_endline (Printf.sprintf "%-20s" !indent ^ " " ^ Lazy.force s)
 ;;
+let pp _ = ();;
+
 
 let ppcontext = NCicPp.ppcontext;;
 let ppmetasenv = NCicPp.ppmetasenv;;
@@ -102,14 +104,14 @@ let ppmetasenv = NCicPp.ppmetasenv;;
 let ppcontext ~metasenv:_metasenv ~subst:_subst _context = "...";;
 let ppmetasenv ~subst:_subst _metasenv = "...";;
 
-let pp _ = ();;
-
 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 exc
+         | 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 (
@@ -217,7 +219,6 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap =
               prerr_endline (Lazy.force msg);
               pp msg; assert false
        in
-       let ty_t = fix_sorts swap exc_to_be ty_t in 
        let lty = NCicSubstitution.subst_meta lc ty in
        match ty_t with
        | NCic.Implicit _ -> 
@@ -229,7 +230,12 @@ and instantiate rdb test_eq_only metasenv subst context n lc t swap =
            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
+           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 _ -> raise exc in
           metasenv, subst, t
   in
          pp (lazy(string_of_int n ^ " := 111 = "^
@@ -353,7 +359,9 @@ and unify rdb test_eq_only metasenv subst context t1 t2 =
                     (C.Meta (i,l)) lambda_Mj,
                    i
               | NCic.Meta (i,_) -> (metasenv, subst), i
-              | _ -> prerr_endline ("XXX: " ^ NCicPp.ppterm ~metasenv ~subst ~context (NCicReduction.whd ~subst context t1)); 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 = 
@@ -615,8 +623,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
@@ -666,3 +674,5 @@ pp (lazy (string_of_bool norm1 ^ " ?? " ^ string_of_bool norm2));
 let unify rdb ?(test_eq_only=false) = 
   indent := "";      
   unify rdb test_eq_only;;
+
+let fix_sorts = fix_sorts false (UnificationFailure (lazy "no sup"));;