Add delta to Positive.clean_type and Tallying.norm

tests/libtest/tallyingTest.ml

@@ -39,8 +39,8 @@ and vv = V of string
 let mk_s ll =
   let aux l =
     List.fold_left (fun acc -> function
-      |P(V alpha,t) -> Tallying.CS.M.add ((*true,*)Var.mk alpha) (Types.empty,parse_typ t) acc
-      |N(t,V alpha) -> Tallying.CS.M.add ((*false,*)Var.mk alpha) (parse_typ t,Types.any) acc
+      |P(V alpha,t) -> Tallying.CS.M.add Var.Set.empty (Var.mk alpha) (Types.empty,parse_typ t) acc
+      |N(t,V alpha) -> Tallying.CS.M.add Var.Set.empty (Var.mk alpha) (parse_typ t,Types.any) acc
     ) Tallying.CS.M.empty l
   in
   List.fold_left (fun acc l ->
@@ -50,8 +50,8 @@ let mk_s ll =
 let mk_union_res l1 l2 =
   let aux l =
     List.fold_left (fun acc -> function
-      |P(V v,s) -> Tallying.CS.M.merge acc (Tallying.CS.M.singleton (Var.mk v) (Types.empty, parse_typ s))
-      |N(s,V v) -> Tallying.CS.M.merge acc (Tallying.CS.M.singleton (Var.mk v) (parse_typ s, Types.any))
+      |P(V v,s) -> Tallying.CS.M.inter Var.Set.empty acc (Tallying.CS.M.singleton (Var.mk v) (Types.empty, parse_typ s))
+      |N(s,V v) -> Tallying.CS.M.inter Var.Set.empty acc (Tallying.CS.M.singleton (Var.mk v) (parse_typ s, Types.any))
     ) Tallying.CS.M.empty l
   in
   match l1,l2 with
@@ -62,12 +62,12 @@ let mk_union_res l1 l2 =
 
 (* check invariants on the constraints sets *)
 let mk_pp = function
-  |P(V alpha,t) -> Tallying.CS.singleton (Tallying.Pos (Var.mk alpha,parse_typ t))
-  |N(t,V alpha) -> Tallying.CS.singleton (Tallying.Neg (parse_typ t,Var.mk alpha))
+  |P(V alpha,t) -> Tallying.CS.singleton Var.Set.empty (Tallying.Pos (Var.mk alpha,parse_typ t))
+  |N(t,V alpha) -> Tallying.CS.singleton Var.Set.empty (Tallying.Neg (parse_typ t,Var.mk alpha))
 
 let mk_prod l =
     List.fold_left (fun acc c ->
-      Tallying.CS.prod (mk_pp c) acc
+      Tallying.CS.prod Var.Set.empty (mk_pp c) acc
     ) Tallying.CS.sat l
 
 let mk_union l1 l2 =

types/boolVar.mli

+module type E = sig
+  type elem
+  include Custom.T
+
+  val empty : t
+  val full  : t
+  val cup   : t -> t -> t
+  val cap   : t -> t -> t
+  val diff  : t -> t -> t
+  val atom  : elem -> t
+
+end
+
+module type S = sig
+
+  type s
+  type elem = s Var.pairvar
+  include Custom.T
+
+  (** returns the union of all leaves in the BDD *)
+  val leafconj: t -> s
+
+  val get: t -> (elem list * elem list) list
+
+  val empty : t
+  val full  : t
+  (* same as full, but we keep it for the moment to avoid chaging the code everywhere *)
+  val any  : t
+  val cup   : t -> t -> t
+  val cap   : t -> t -> t
+  val diff  : t -> t -> t
+  val atom  : elem -> t
+
+  val trivially_disjoint: t -> t -> bool
+
+  (** vars a : return a bdd that is ( Any ^ Var a ) *)
+  val vars  : Var.var -> t
+
+  val iter: (elem-> unit) -> t -> unit
+
+  val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b)
+    -> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
+    atom:(elem -> 'b) -> t -> 'b
+
+  val is_empty : t -> bool
+
+  val pp_print : Format.formatter -> t -> unit
+
+  val print : ?f:(Format.formatter -> elem -> unit) -> t -> (Format.formatter -> unit) list
+
+end
+
+module type MAKE = functor (T : E) -> S with type s = T.t
+module Make : MAKE 

types/types.mli

@@ -164,11 +164,11 @@ module Positive : sig
   val times: v -> v -> v
   val xml: v -> v -> v
 
-  (* val decompose : t -> v *)
   val substitute : t -> (Var.var * t) -> t
   val substituterec : t -> Var.var -> t
   val solve: v -> Node.t
   val substitutefree : Var.Set.t -> t -> t
+  val clean_type : Var.Set.t -> t -> t
 end
 
 (** Normalization **)
@@ -203,7 +203,6 @@ module Product : sig
   val need_second: t -> bool
     (* Is there more than a single rectangle ? *)
 
-
   val clean_normal: t -> t
     (* Merge rectangles with same second component *)
 end
@@ -383,10 +382,10 @@ module Tallying : sig
       type t
       val compare  : t -> t -> int
       val empty : t
-      val add : key -> descr*descr -> t -> t
+      val add : Var.Set.t -> key -> descr*descr -> t -> t
       val singleton : key -> descr*descr -> t
       val pp : Format.formatter -> t -> unit
-      val merge : t -> t -> t
+      val inter : Var.Set.t -> t -> t -> t
     end
     module E : sig
       include Map.S with type key = Var.var
@@ -418,12 +417,12 @@ module Tallying : sig
     val pp_e  : Format.formatter -> sigma -> unit
     val pp_sl : Format.formatter -> sl -> unit
 
-    val merge : m -> m -> m
-    val singleton : constr -> s
+    (* val merge : m -> m -> m *)
+    val singleton : Var.Set.t -> constr -> s
     val sat : s
     val unsat : s
     val union : s -> s -> s
-    val prod : s -> s -> s
+    val prod : Var.Set.t -> s -> s -> s
   end
 
   val norm : Var.Set.t -> t -> CS.s
@@ -458,7 +457,7 @@ end
 (** Square Subtype relation. [squaresubtype delta s t] . 
     True if there exists a substitution such that s < t only 
     considering variables that are not in delta *)
-val squaresubtype : Var.Set.t -> t -> t -> (Tallying.CS.sl * bool)
+val squaresubtype : Var.Set.t -> t -> t -> Tallying.CS.sl
 val is_squaresubtype : Var.Set.t -> t -> t -> bool
 
 (** apply_raw s t returns the 4-tuple (subst,ss, tt, res) where

typing/typer.ml

@@ -912,7 +912,7 @@ and type_check' loc env ed constr precise = match ed with
           if not (Types.subtype t1 acc) then
             raise_loc loc (NonExhaustive (Types.diff t1 acc));
           let t = type_check_branches loc env t1 a.fun_body t2 false in
-          (fst(Types.squaresubtype env.delta t t2))::tacc (* H_j *)
+          (Types.squaresubtype env.delta t t2)::tacc (* H_j *)
         ) [] a.fun_iface
       in
       List.iter (fun sl ->