update in helena

[helm.git] / helm / software / helena / src / basic_rg / brgValidity.ml

diff --git a/helm/software/helena/src/basic_rg/brgValidity.ml b/helm/software/helena/src/basic_rg/brgValidity.ml
index ea3ce2f42b40e90f647fe608cdd092881b6f30b5..a1401c125a1a01c114daeac350170b88a0c80288 100644 (file)
--- a/helm/software/helena/src/basic_rg/brgValidity.ml
+++ b/helm/software/helena/src/basic_rg/brgValidity.ml
@@ -11,24 +11,24 @@
 
 module L  = Log
 module G  = Options
+module N  = Layer
 module E  = Entity
-module S  = Status
 module B  = Brg
 module BE = BrgEnvironment
 module BR = BrgReduction
 
 (* Internal functions *******************************************************)
 
-let level = 3
+let level = 4
 
-let warn s = L.warn level s
+let warn s = L.warn (pred level) s
 
 let message1 st1 m t1 =
    L.et_items1 "In the environment" m st1 t1
 
 let log1 st s m t =
    let s =  s ^ " the term" in
-   L.log st BR.specs level (message1 s m t) 
+   L.log st BR.specs (pred level) (message1 s m t) 
 
 let error1 err s m t =
    err (message1 s m t)
@@ -46,55 +46,67 @@ let zero = Some 0
 let one = Some 1
 
 let assert_convertibility err f st m u t =
-   if !G.trace >= level then warn "Asserting convertibility for cast";
+IFDEF TRACE THEN
+   if !G.ct >= level then warn "Asserting convertibility for cast"
+ELSE () END;
    if BR.are_convertible st m zero u m one t then f () else
    error2 err m u m t
 
-let assert_applicability err f st m v t =
-   if !G.trace >= level then warn "Asserting applicability";
-   match BR.xwhd st m None t with 
-      | _, B.Sort _                      ->
+let assert_applicability err f st m a v t =
+   let mode, msg = if a.E.a_rest then one, "restricted" else None, "extended" in 
+IFDEF TRACE THEN
+   if !G.ct >= level then warn ("Asserting " ^ msg ^ " applicability")
+ELSE () END;
+   match BR.xwhd st m mode t with 
+      | mw, B.Bind (_, B.Abst (true, n, w), _) ->
+         if !G.cc && not (N.assert_not_zero st n) then error1 err "not a function" m t
+         else begin
+IFDEF TRACE THEN
+            if !G.ct >= level then warn "Asserting convertibility for application"
+ELSE () END;
+            if BR.are_convertible st mw zero w m one v then f () else
+           error2 err mw w m v
+         end
+      | _, B.Sort _                            ->
          error1 err "not a function" m t
-      | mw, B.Bind (_, B.Abst (_, w), _) ->
-         if !G.trace >= level then warn "Asserting convertibility for application";
-         if BR.are_convertible st mw zero w m one v then f () else
-        error2 err mw w m v
-      | _                                -> assert false (**)
-
-let rec b_validate err f st m x =
-   if !G.trace >= level then log1 st.S.lenv "Now checking" m x;
-   match x with
+      | _                                      -> assert false (**)
+
+let rec b_validate err f st m y =
+IFDEF TRACE THEN
+   if !G.ct >= level then log1 st "Now checking" m y
+ELSE () END;
+   match y with
    | B.Sort _         -> f ()
    | B.LRef (_, i)    ->
       begin match BR.get m i with
          | B.Abst _
         | B.Abbr _ -> f ()
         | B.Void   -> 
-           error1 err "reference to excluded variable" m x
+           error1 err "reference to excluded variable" m y
       end
    | B.GRef (_, uri)  ->
       begin match BE.get_entity uri with
          | _, _, _, E.Abst _
         | _, _, _, E.Abbr _ -> f ()
         | _, _, _, E.Void   ->
-            error1 err "reference to unknown entry" m x
+            error1 err "reference to unknown entry" m y
       end
-   | B.Bind (a, b, t) ->
-      let f () = b_validate err f st (BR.push m a b) t in
+   | B.Bind (y, b, t) ->
+      let f () = b_validate err f st (BR.push m y b) t in
       begin match b with 
-         | B.Abst (n, u) -> validate err f st m u
-         | B.Abbr v      -> validate err f st m v
-         | B.Void        -> f ()
+         | B.Abst (_, n, u) -> validate err f st m u
+         | B.Abbr v         -> validate err f st m v
+         | B.Void           -> f ()
       end
-   | B.Appl (_, v, t)        ->
-      let f () = assert_applicability err f st m v t in
+   | B.Appl (a, v, t)       ->
+      let f () = assert_applicability err f st m a v t in
       let f () = b_validate err f st m t in
       validate err f st m v
-   | B.Cast (_, u, t)        ->
+   | B.Cast (u, t)          ->
       let f () = assert_convertibility err f st m u t in
       let f () = b_validate err f st m t in
       validate err f st m u
 
 (* Interface functions ******************************************************)
 
-and validate err f st m x = b_validate err f st m x
+and validate err f st m t = b_validate err f st m t