coercions

a slightly different representation of coercions
(using trees instead of lists)
bench files for coercions

bench/typing/bad/coercion_already.mlw

+type a
+type b
+type c
+
+function b_to_c b : c
+meta coercion function b_to_c
+function a_to_b a : b
+meta coercion function a_to_b
+function a_to_c a : c
+meta coercion function a_to_c

bench/typing/bad/coercion_already1.mlw

+type a
+type b
+
+function f a : b
+meta coercion function f
+
+function g a : b
+meta coercion function g
+

bench/typing/bad/coercion_already3.mlw

+type a
+type b
+type c
+
+function f a : c
+meta coercion function f
+function g b : c
+meta coercion function g
+function h a : b
+meta coercion function h
+

bench/typing/bad/coercion_cycle1.mlw

+type a
+type b
+
+function f a : b
+meta coercion function f
+
+function g b : a
+meta coercion function g
+

bench/typing/bad/coercion_cycle2.mlw

+type a
+type b
+type c
+
+function f a : b
+meta coercion function f
+function g b : c
+meta coercion function g
+
+function h c : a
+meta coercion function h
+
+

bench/typing/bad/coercion_cycle3.mlw

+type a
+type b
+type c
+
+function g b : c
+meta coercion function g
+function f a : b
+meta coercion function f
+
+function h c : a
+meta coercion function h
+
+

bench/typing/good/coercions.mlw

+
+type t
+function f t : int
+meta coercion function f
+goal G: forall x: t. 42 = x
+
+type a
+type b
+type c
+
+function b_to_c b : c
+meta coercion function b_to_c
+function a_to_b a : b
+meta coercion function a_to_b
+
+predicate is_c c
+goal G2: forall x: a. is_c x
+
+function is_zero int : bool
+meta coercion function is_zero
+
+goal G3: if 42 then 1=2 else 3=4
+

examples/vstte10_queens.mlw

@@ -155,19 +155,19 @@ module NQueens63
 
   predicate is_board (board: array int63) (pos: int) =
     forall q: int. 0 <= q < pos ->
-    0 <= to_int board[q] < to_int (length board)
+    0 <= board[q] < (length board)
 
   exception MInconsistent
 
   let check_is_consistent (board: array int63) (pos: int63)
-    requires { 0 <= to_int pos < to_int (length board) }
-    requires { is_board board (to_int pos + 1) }
+    requires { 0 <= pos < (length board) }
+    requires { is_board board (pos + 1) }
   = try
       let q = ref (of_int 0) in
       while !q < pos do
-        invariant { 0 <= to_int !q <= to_int pos }
-        invariant { is_board board (to_int pos + 1) }
-        variant   { to_int pos - to_int !q }
+        invariant { 0 <= !q <= pos }
+        invariant { is_board board (pos + 1) }
+        variant   { pos - !q }
         let bq   = board[!q]   in
         let bpos = board[pos] in
         if bq        = bpos     then raise MInconsistent;
@@ -184,20 +184,20 @@ module NQueens63
 
   let rec count_bt_queens
     (solutions: ref P.t) (board: array int63) (n: int63) (pos: int63)
-    requires { to_int (length board) = to_int n }
-    requires { 0 <= to_int pos <= to_int n }
-    requires { is_board board (to_int pos) }
-    variant  { to_int n - to_int pos }
-    ensures  { is_board board (to_int pos) }
+    requires { (length board) = n }
+    requires { 0 <= pos <= n }
+    requires { is_board board (pos) }
+    variant  { n - pos }
+    ensures  { is_board board (pos) }
   =
     if eq pos n then
       solutions := P.succ !solutions
     else
       let i = ref (of_int 0) in
       while !i < n do
-        invariant { 0 <= to_int !i <= to_int n }
-        invariant { is_board board (to_int pos) }
-        variant   { to_int n - to_int !i }
+        invariant { 0 <= !i <= n }
+        invariant { is_board board (pos) }
+        variant   { n - !i }
         board[pos] <- !i;
         if check_is_consistent board pos then
           count_bt_queens solutions board n (pos + of_int 1);
@@ -205,7 +205,7 @@ module NQueens63
       done
 
   let count_queens (n: int63) : P.t
-    requires { to_int n >= 0 }
+    requires { n >= 0 }
     ensures  { true }
   =
      let solutions = ref (P.zero ()) in

examples/vstte10_queens/why3session.xml

@@ -2,147 +2,97 @@
 <!DOCTYPE why3session PUBLIC "-//Why3//proof session v5//EN"
 "http://why3.lri.fr/why3session.dtd">
 <why3session shape_version="4">
-<prover id="0" name="CVC4" version="1.4" timelimit="6" steplimit="0" memlimit="1000"/>
-<prover id="1" name="CVC3" version="2.4.1" timelimit="20" steplimit="0" memlimit="0"/>
-<prover id="2" name="Z3" version="4.3.2" timelimit="6" steplimit="0" memlimit="1000"/>
+<prover id="0" name="CVC4" version="1.4" timelimit="5" steplimit="0" memlimit="1000"/>
 <prover id="3" name="Z3" version="3.2" timelimit="8" steplimit="0" memlimit="1000"/>
-<prover id="6" name="Alt-Ergo" version="0.99.1" timelimit="6" steplimit="0" memlimit="1000"/>
+<prover id="4" name="Alt-Ergo" version="1.30" timelimit="5" steplimit="0" memlimit="1000"/>
 <file name="../vstte10_queens.mlw" expanded="true">
-<theory name="NQueens" sum="bd54a466f42b418faffacb9470dabda3" expanded="true">
+<theory name="NQueens" sum="409b3951ae957384bbb25de0839f6b15" expanded="true">
  <goal name="eq_board_set">
- <proof prover="6" timelimit="5"><result status="valid" time="0.00" steps="7"/></proof>
+ <proof prover="4"><result status="valid" time="0.00" steps="12"/></proof>
  </goal>
  <goal name="eq_board_sym">
- <proof prover="6" timelimit="20" memlimit="0"><result status="valid" time="0.01" steps="7"/></proof>
+ <proof prover="4" timelimit="20" memlimit="0"><result status="valid" time="0.01" steps="3"/></proof>
  </goal>
  <goal name="eq_board_trans">
- <proof prover="6" timelimit="20" memlimit="0"><result status="valid" time="0.01" steps="10"/></proof>
+ <proof prover="4" timelimit="20" memlimit="0"><result status="valid" time="0.01" steps="9"/></proof>
  </goal>
  <goal name="eq_board_extension">
- <proof prover="6" timelimit="20" memlimit="0"><result status="valid" time="0.01" steps="10"/></proof>
+ <proof prover="4" timelimit="20" memlimit="0"><result status="valid" time="0.01" steps="10"/></proof>
  </goal>
  <goal name="consistent_row_eq">
- <proof prover="6" timelimit="20" memlimit="0"><result status="valid" time="0.06" steps="37"/></proof>
+ <proof prover="4" timelimit="20" memlimit="0"><result status="valid" time="0.06" steps="32"/></proof>
  </goal>
- <goal name="WP_parameter check_is_consistent" expl="VC for check_is_consistent">
- <proof prover="1"><result status="valid" time="0.02"/></proof>
+ <goal name="VC check_is_consistent" expl="VC for check_is_consistent" expanded="true">
+ <proof prover="4"><result status="valid" time="0.02" steps="62"/></proof>
  </goal>
  <goal name="solution_eq_board">
  <proof prover="3"><result status="valid" time="0.06"/></proof>
  </goal>
- <goal name="WP_parameter bt_queens" expl="VC for bt_queens">
- <proof prover="1"><result status="valid" time="1.42"/></proof>
- </goal>
- <goal name="WP_parameter queens" expl="VC for queens">
- <proof prover="6" timelimit="20" memlimit="0"><result status="valid" time="0.02" steps="25"/></proof>
- </goal>
- <goal name="WP_parameter test8" expl="VC for test8">
- <proof prover="6" timelimit="5"><result status="valid" time="0.01" steps="2"/></proof>
- </goal>
- <goal name="WP_parameter count_bt_queens" expl="VC for count_bt_queens">
- <proof prover="0" timelimit="5" memlimit="4000"><result status="valid" time="0.27"/></proof>
- </goal>
- <goal name="WP_parameter count_queens" expl="VC for count_queens">
- <proof prover="6"><result status="valid" time="0.01" steps="7"/></proof>
- </goal>
- <goal name="WP_parameter test_count_8" expl="VC for test_count_8">
- <proof prover="6"><result status="valid" time="0.01" steps="2"/></proof>
- </goal>
-</theory>
-<theory name="NQueens63" sum="f2313c3331066814cd7f4f7313021e3c" expanded="true">
- <goal name="WP_parameter check_is_consistent" expl="VC for check_is_consistent">
- <proof prover="0"><result status="valid" time="0.09"/></proof>
- </goal>
- <goal name="WP_parameter count_bt_queens" expl="VC for count_bt_queens">
- <transf name="split_goal_wp">
-  <goal name="WP_parameter count_bt_queens.1" expl="1. postcondition">
-  <proof prover="6"><result status="valid" time="0.02" steps="9"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.2" expl="2. integer overflow">
-  <proof prover="6"><result status="valid" time="0.02" steps="8"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.3" expl="3. loop invariant init">
-  <proof prover="6"><result status="valid" time="0.02" steps="9"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.4" expl="4. loop invariant init">
-  <proof prover="6"><result status="valid" time="0.02" steps="9"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.5" expl="5. type invariant">
-  <proof prover="6"><result status="valid" time="0.02" steps="14"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.6" expl="6. index in array63 bounds">
-  <proof prover="6"><result status="valid" time="0.02" steps="14"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.7" expl="7. precondition">
-  <proof prover="6"><result status="valid" time="0.02" steps="16"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.8" expl="8. precondition">
-  <proof prover="6"><result status="valid" time="0.17" steps="115"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.9" expl="9. integer overflow">
-  <proof prover="6"><result status="valid" time="0.02" steps="21"/></proof>
+ <goal name="VC bt_queens" expl="VC for bt_queens" expanded="true">
+ <transf name="split_goal_wp" expanded="true">
+  <goal name="VC bt_queens.1" expl="1. exceptional postcondition">
+  <proof prover="4"><result status="valid" time="0.01" steps="6"/></proof>
   </goal>
-  <goal name="WP_parameter count_bt_queens.10" expl="10. integer overflow">
-  <proof prover="6"><result status="valid" time="0.04" steps="48"/></proof>
+  <goal name="VC bt_queens.2" expl="2. loop bounds">
+  <proof prover="4"><result status="valid" time="0.01" steps="6"/></proof>
   </goal>
-  <goal name="WP_parameter count_bt_queens.11" expl="11. variant decrease">
-  <proof prover="6"><result status="valid" time="0.02" steps="22"/></proof>
+  <goal name="VC bt_queens.3" expl="3. loop invariant init">
+  <proof prover="4"><result status="valid" time="0.01" steps="7"/></proof>
   </goal>
-  <goal name="WP_parameter count_bt_queens.12" expl="12. precondition">
-  <proof prover="6"><result status="valid" time="0.02" steps="22"/></proof>
+  <goal name="VC bt_queens.4" expl="4. index in array bounds">
+  <proof prover="4"><result status="valid" time="0.01" steps="10"/></proof>
   </goal>
-  <goal name="WP_parameter count_bt_queens.13" expl="13. precondition">
-  <proof prover="6"><result status="valid" time="0.02" steps="22"/></proof>
+  <goal name="VC bt_queens.5" expl="5. precondition">
+  <proof prover="4"><result status="valid" time="0.01" steps="12"/></proof>
   </goal>
-  <goal name="WP_parameter count_bt_queens.14" expl="14. precondition">
-  <proof prover="0"><result status="valid" time="0.05"/></proof>
-  <proof prover="6"><result status="valid" time="0.00" steps="22"/></proof>
+  <goal name="VC bt_queens.6" expl="6. variant decrease">
+  <proof prover="4"><result status="valid" time="0.01" steps="13"/></proof>
   </goal>
-  <goal name="WP_parameter count_bt_queens.15" expl="15. integer overflow">
-  <proof prover="6"><result status="valid" time="0.02" steps="26"/></proof>
+  <goal name="VC bt_queens.7" expl="7. precondition">
+  <proof prover="0"><result status="valid" time="0.16"/></proof>
   </goal>
-  <goal name="WP_parameter count_bt_queens.16" expl="16. integer overflow">
-  <proof prover="6"><result status="valid" time="0.13" steps="62"/></proof>
+  <goal name="VC bt_queens.8" expl="8. loop invariant preservation">
+  <proof prover="4"><result status="valid" time="0.06" steps="236"/></proof>
   </goal>
-  <goal name="WP_parameter count_bt_queens.17" expl="17. loop invariant preservation">
-  <proof prover="6"><result status="valid" time="0.02" steps="30"/></proof>
+  <goal name="VC bt_queens.9" expl="9. exceptional postcondition">
+  <proof prover="4"><result status="valid" time="0.01" steps="15"/></proof>
   </goal>
-  <goal name="WP_parameter count_bt_queens.18" expl="18. loop invariant preservation">
-  <proof prover="6"><result status="valid" time="0.02" steps="58"/></proof>
+  <goal name="VC bt_queens.10" expl="10. loop invariant preservation">
+  <proof prover="4"><result status="valid" time="0.51" steps="895"/></proof>
   </goal>
-  <goal name="WP_parameter count_bt_queens.19" expl="19. loop variant decrease">
-  <proof prover="6"><result status="valid" time="0.02" steps="30"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.20" expl="20. integer overflow">
-  <proof prover="6"><result status="valid" time="0.01" steps="21"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.21" expl="21. integer overflow">
-  <proof prover="6"><result status="valid" time="0.02" steps="48"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.22" expl="22. loop invariant preservation">
-  <proof prover="6"><result status="valid" time="0.02" steps="23"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.23" expl="23. loop invariant preservation">
-  <proof prover="6"><result status="valid" time="0.11" steps="46"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.24" expl="24. loop variant decrease">
-  <proof prover="6"><result status="valid" time="0.02" steps="23"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.25" expl="25. type invariant">
-  <proof prover="0"><result status="valid" time="0.05"/></proof>
-  <proof prover="6"><result status="valid" time="0.02" steps="14"/></proof>
-  </goal>
-  <goal name="WP_parameter count_bt_queens.26" expl="26. postcondition">
-  <proof prover="6"><result status="valid" time="0.01" steps="14"/></proof>
+  <goal name="VC bt_queens.11" expl="11. postcondition">
+  <proof prover="4"><result status="valid" time="0.01" steps="32"/></proof>
   </goal>
  </transf>
  </goal>
- <goal name="WP_parameter count_queens" expl="VC for count_queens">
- <proof prover="6"><result status="valid" time="0.01" steps="12"/></proof>
+ <goal name="VC queens" expl="VC for queens" expanded="true">
+ <proof prover="4"><result status="valid" time="0.00" steps="24"/></proof>
+ </goal>
+ <goal name="VC test8" expl="VC for test8" expanded="true">
+ <proof prover="4"><result status="valid" time="0.00" steps="1"/></proof>
+ </goal>
+ <goal name="VC count_bt_queens" expl="VC for count_bt_queens" expanded="true">
+ <proof prover="4"><result status="valid" time="1.26" steps="438"/></proof>
+ </goal>
+ <goal name="VC count_queens" expl="VC for count_queens" expanded="true">
+ <proof prover="4"><result status="valid" time="0.00" steps="7"/></proof>
+ </goal>
+ <goal name="VC test_count_8" expl="VC for test_count_8" expanded="true">
+ <proof prover="4"><result status="valid" time="0.00" steps="1"/></proof>
+ </goal>
+</theory>
+<theory name="NQueens63" sum="8c5fcf08811dad3a40f6c343ffc3660e" expanded="true">
+ <goal name="VC check_is_consistent" expl="VC for check_is_consistent" expanded="true">
+ <proof prover="4"><result status="valid" time="0.09" steps="287"/></proof>
+ </goal>
+ <goal name="VC count_bt_queens" expl="VC for count_bt_queens" expanded="true">
+ <proof prover="4"><result status="valid" time="0.32" steps="1264"/></proof>
+ </goal>
+ <goal name="VC count_queens" expl="VC for count_queens" expanded="true">
+ <proof prover="4"><result status="valid" time="0.01" steps="11"/></proof>
  </goal>
- <goal name="WP_parameter test_count_8" expl="VC for test_count_8">
- <proof prover="2"><result status="valid" time="0.01"/></proof>
- <proof prover="6"><result status="valid" time="0.00" steps="2"/></proof>
+ <goal name="VC test_count_8" expl="VC for test_count_8" expanded="true">
+ <proof prover="4"><result status="valid" time="0.01" steps="2"/></proof>
  </goal>
 </theory>
 </file>

src/core/coercion.ml

+
 open Ident
 open Ty
 open Term
 
-type crc = { crc_lsl : lsymbol list;
-             crc_src : Ty.tysymbol;
-             crc_tar : Ty.tysymbol;
-             crc_len : int }
+type coercion_kind =
+  | CRCleaf of lsymbol
+  | CRCcomp of coercion_kind * coercion_kind
+
+type coercion = {
+  crc_kind: coercion_kind;
+  crc_src : Ty.tysymbol;
+  crc_tar : Ty.tysymbol;
+  crc_len : int;
+}
 
-type t = (crc Mts.t) Mts.t
+type t = (coercion Mts.t) Mts.t
   (** invariant: transitively closed *)
 
 let empty = Mts.empty
 
 exception NotACoercion of lsymbol
-exception CoercionCycle of lsymbol
-exception CoercionAlreadyDefined of tysymbol * tysymbol
+exception CoercionCycle of coercion
+exception CoercionAlreadyDefined of coercion
 
 let create_crc ls =
   match ls.ls_args, ls.ls_value with
   | [{ty_node = Tyapp (ty1,_)}], Some {ty_node = Tyapp (ty2,_)} ->
      if ts_equal ty1 ty2 then raise (NotACoercion ls);
-     { crc_lsl = [ls]; crc_src = ty1; crc_tar = ty2; crc_len = 1 }
+     { crc_kind = CRCleaf ls; crc_src = ty1; crc_tar = ty2; crc_len = 1 }
   | _ -> raise (NotACoercion ls)
 
-let mem ts1 ts2 crcmap =
+let mem crcmap ts1 ts2 =
   try let m = Mts.find ts1 crcmap in Mts.mem ts2 m
   with Not_found -> false
 
-let decide c_old c_new _m1 m =
-  match c_old.crc_lsl, c_new.crc_lsl with
-  | [ls_old], [ls_new] when ls_equal ls_old ls_new -> m
-  | _  -> raise (CoercionAlreadyDefined (c_old.crc_src, c_old.crc_tar))
-
-let insert c m =
-  let put c m1 m2 = Mts.add c.crc_src (Mts.add c.crc_tar c m1) m2 in
-  if mem c.crc_tar c.crc_src m then
-    begin match c.crc_lsl with
-      | ls :: _ -> raise (CoercionCycle ls)
-      | _ -> assert false (* there is always at least one coercion *)
-    end;
-  let m1 = Mts.find_def empty c.crc_src m in
-  if Mts.mem c.crc_tar m1 then decide (Mts.find c.crc_tar m1) c m1 m
-  else put c m1 m
-
-let join crc1 crc2 =
-  { crc_lsl = crc1.crc_lsl @ crc2.crc_lsl;
+let find crcmap ts1 ts2 =
+  Mts.find ts2 (Mts.find ts1 crcmap)
+
+(* replace an old coercion by a new one, or fail *)
+let replace c_old c_new _m1 m =
+  match c_old.crc_kind, c_new.crc_kind with
+  | CRCleaf ls_old, CRCleaf ls_new when ls_equal ls_old ls_new -> m
+  | _  -> raise (CoercionAlreadyDefined c_old)
+
+(* add a new coercion c, without making the transitive closure *)
+let insert crc m =
+  let put crc m1 m2 = Mts.add crc.crc_src (Mts.add crc.crc_tar crc m1) m2 in
+  if mem m crc.crc_tar crc.crc_src then
+    raise (CoercionCycle (find m crc.crc_tar crc.crc_src));
+  let m1 = Mts.find_def Mts.empty crc.crc_src m in
+  if Mts.mem crc.crc_tar m1 then replace (Mts.find crc.crc_tar m1) crc m1 m
+  else put crc m1 m
+
+let compose crc1 crc2 =
+  { crc_kind = CRCcomp (crc1.crc_kind, crc2.crc_kind);
     crc_src = crc1.crc_src;
     crc_tar = crc2.crc_tar;
     crc_len = crc1.crc_len + crc2.crc_len }
 
+(* add a new coercion crc, and make the transitive closure *)
 let add_crc crcmap crc =
-  let close_right c1 _ty c2 macc =
-    insert (join c1 c2) macc in
-  (* add_crc macc (join c1 c2) false in *)
+  let close_right c1 _ty c2 macc = insert (compose c1 c2) macc in
   let close_left_right _ty1 m1 macc =
-    if Mts.mem crc.crc_src m1
-    then
+    if Mts.mem crc.crc_src m1 then
       let c1 = Mts.find crc.crc_src m1 in
-      let m2 = Mts.find_def empty crc.crc_tar macc in
+      let m2 = Mts.find_def Mts.empty crc.crc_tar macc in
       Mts.fold (close_right c1) (Mts.add crc.crc_tar crc m2) macc
     else macc in
   let crcmap_uc1 = insert crc crcmap in
   let crcmap_uc2 =
-    let m1 = Mts.find_def empty crc.crc_tar crcmap_uc1 in
+    let m1 = Mts.find_def Mts.empty crc.crc_tar crcmap_uc1 in
     Mts.fold (close_right crc) m1 crcmap_uc1 in
   Mts.fold (close_left_right) crcmap_uc2 crcmap_uc2
 
-let find crcmap ts1 ts2 =
-  Mts.find ts2 (Mts.find ts1 crcmap)
-
 let add crcmap ls =
   add_crc crcmap (create_crc ls)
 
 let union s1 s2 =
   Mts.fold (fun _ m1 s -> Mts.fold (fun _ c s -> add_crc s c) m1 s) s2 s1
 
+let rec print_kind fmt = function
+  | CRCleaf ls ->
+    Format.fprintf fmt "%s" ls.ls_name.id_string
+  | CRCcomp (k1, k2) ->
+    Format.fprintf fmt "%a o %a" print_kind k2 print_kind k1
+
+let already_a_coercion fmt crc =
+  Format.fprintf fmt "already a coercion from type %s to type %s@ (%a)"
+    crc.crc_src.ts_name.id_string crc.crc_tar.ts_name.id_string
+    print_kind crc.crc_kind
+
 let () = Exn_printer.register
   begin fun fmt exn -> match exn with
   | NotACoercion ls ->
     Format.fprintf fmt "Function %s cannot be used as a coercion"
       ls.ls_name.id_string
-  | CoercionCycle ls ->
-    Format.fprintf fmt "Coercion %s introduces a cycle" ls.ls_name.id_string
-  | CoercionAlreadyDefined (ts1, ts2) ->
-    Format.fprintf fmt "A coercion from type %s to type %s@ is already defined"
-      ts1.ts_name.id_string ts2.ts_name.id_string
+  | CoercionCycle crc ->
+    Format.fprintf fmt "This coercion introduces a cycle;@ ";
+    already_a_coercion fmt crc
+  | CoercionAlreadyDefined crc ->
+    already_a_coercion fmt crc
   | _ -> raise exn end

src/core/coercion.mli

 
 
-type crc = private
-           { crc_lsl : Term.lsymbol list;
-             crc_src : Ty.tysymbol;
-             crc_tar : Ty.tysymbol;
-             crc_len : int }
+type coercion_kind =
+  | CRCleaf of Term.lsymbol
+  | CRCcomp of coercion_kind * coercion_kind
+
+type coercion = private {
+  crc_kind: coercion_kind;
+  crc_src : Ty.tysymbol;
+  crc_tar : Ty.tysymbol;
+  crc_len : int;
+}
 
 type t
   (** a set of coercions *)
@@ -15,7 +20,7 @@ val add: t -> Term.lsymbol -> t
   (** adds a new coercion
       raises an error if this introduces a cycle *)
 
-val find: t -> Ty.tysymbol -> Ty.tysymbol -> crc
+val find: t -> Ty.tysymbol -> Ty.tysymbol -> coercion
   (** returns the coercion, or raises [Not_found] *)
 
 val union: t -> t -> t

src/core/dterm.ml

@@ -296,15 +296,16 @@ let dpattern ?loc node =
 
 let slab_coercion = Slab.singleton Pretty.label_coercion
 
+let rec apply_coercion ~loc k dt = match k with
+  | Coercion.CRCleaf ls ->
+    let (_, dty) = specialize_ls ls in
+    let dt =
+      { dt_node = DTapp (ls, [dt]); dt_dty  = dty; dt_loc  = loc } in
+    { dt with dt_node = DTlabel (dt, slab_coercion) }
+  | Coercion.CRCcomp (k1, k2) ->
+    apply_coercion ~loc k2 (apply_coercion ~loc k1 dt)
+
 let dterm tuc ?loc node =
-  let compose l dt =
-    let mk_dt dacc ls =
-      let (_, dty) = specialize_ls ls in
-      let dt =
-        { dt_node = DTapp (ls, [dacc]); dt_dty  = dty; dt_loc  = loc } in
-      { dt with dt_node = DTlabel (dt, slab_coercion) } in
-    let dt = List.fold_left mk_dt dt l in
-    dt.dt_node in
   let rec dterm_expected dt dty =
     let loc = dt.dt_loc in
     match dt.dt_dty with
@@ -317,7 +318,7 @@ let dterm tuc ?loc node =
              let open Theory in
              let open Coercion in
              let crc = find tuc.uc_crcmap ts1 ts2 in
-             dterm_node loc (compose crc.crc_lsl dt)
+             dterm_node loc (apply_coercion ~loc crc.crc_kind dt).dt_node
           | _  ->
               raise Not_found
         end with Not_found ->
@@ -329,6 +330,21 @@ let dterm tuc ?loc node =
       try dty_unify dty_bool dty; dt with Exit ->
         Loc.error ?loc TermExpected
 
+  and dfmla_expected dt = match dt.dt_dty with
+    | Some dt_dty ->
+      begin try dty_unify dt_dty dty_bool; dt with Exit ->
+        let ty1 = ty_of_dty ~strict:false dt_dty in
+        try begin match ty1 with
+          | { ty_node = Tyapp (ts1, _) } ->
+             let crc = Coercion.find tuc.Theory.uc_crcmap ts1 ts_bool in