Commit c4aa99cd authored by Pietro Abate's avatar Pietro Abate
Browse files

API change BoolVar.get -> BoolVar.leafconf

BoolVar.get not is reinstated to return a list of pairs
Add new unit test for Types.witness (WIP)
parent 05d29e59
...@@ -78,12 +78,6 @@ let subtype_tests = [ ...@@ -78,12 +78,6 @@ let subtype_tests = [
"(`$A -> `$C) & (`$B -> `$C)", "(`$A | `$B) -> `$C", true; "(`$A -> `$C) & (`$B -> `$C)", "(`$A | `$B) -> `$C", true;
"((`$A -> `$C) & (`$B -> `$C))", "((`$A | `$B) -> `$C)", true; "((`$A -> `$C) & (`$B -> `$C))", "((`$A | `$B) -> `$C)", true;
"((`$A | `$B) -> `$C)", "((`$A -> `$C) & (`$B -> `$C))", true; "((`$A | `$B) -> `$C)", "((`$A -> `$C) & (`$B -> `$C))", true;
"(`$A -> `$B)", "(Any -> Any)", false;
(* { (any , omega) } *)
"(`A , `$X)", "((`A , (Any \\ `A)) | (`$X , `A))", false;
(* (a , a^[ X ]) *)
"(`$X & (`$X , `A))", "`C", false;
(* (any^[ X ] , A)^[ X ] *)
"(((`$A , `$C) -> `$D1) & ((`$B , `$C) -> `$D2))", "(((`$A | `$B) , `$C) -> (`$D1 | `$D2))", true; "(((`$A , `$C) -> `$D1) & ((`$B , `$C) -> `$D2))", "(((`$A | `$B) , `$C) -> (`$D1 | `$D2))", true;
"(`$A & (`$A , `T))", "`$A", true; "(`$A & (`$A , `T))", "`$A", true;
"(Any -> Empty)","(`$A -> `$B)", true; "(Any -> Empty)","(`$A -> `$B)", true;
...@@ -91,10 +85,6 @@ let subtype_tests = [ ...@@ -91,10 +85,6 @@ let subtype_tests = [
"(`$B & `$A) | (`$B & (Any \\ `$A))","`$B", true; "(`$B & `$A) | (`$B & (Any \\ `$A))","`$B", true;
"`$B","(`$B & `$A) | (`$B & (Any \\ `$A))", true; "`$B","(`$B & `$A) | (`$B & (Any \\ `$A))", true;
"Any","(Any \\ (Any \\ ((`$B & `$A) | (`$B & (Any \\ `$A))) | Empty) | (Any \\ (`$B | Empty)))", true; "Any","(Any \\ (Any \\ ((`$B & `$A) | (`$B & (Any \\ `$A))) | Empty) | (Any \\ (`$B | Empty)))", true;
"(`$A & (`$A , `T))","(`T1 -> `T2)", false;
(* (any^[ A ] , t)^[ A ] *)
"(x where x = (`$A & ((`$A , x) | `nil)))", "Empty", false;
(* nil^[ A ] *)
"(Any \\ (`$A -> `$B))","((Any -> Empty) -> `$B)", false; "(Any \\ (`$A -> `$B))","((Any -> Empty) -> `$B)", false;
];; ];;
...@@ -115,10 +105,52 @@ let test_subtype = ...@@ -115,10 +105,52 @@ let test_subtype =
) subtype_tests ) subtype_tests
;; ;;
let witness_tests = [
"(`$A -> Bool, `$B -> `$B)", "(Int | Bool -> Int, `$A -> `$B)", false;
(* ({ (int , true) } , { }) *)
"Int -> Int", "`$A -> `$A", false;
(* { (true^[ A ] , any) } *)
"(`$A -> `$B)", "(Any -> Any)", false;
(* { (any , omega) } *)
"(`A , `$X)", "((`A , (Any \\ `A)) | (`$X , `A))", false;
(* (a , a^[ X ]) *)
"(`$X & (`$X , `A))", "`C", false;
(* (any^[ X ] , A)^[ X ] *)
"(`$A & (`$A , `T))","(`T1 -> `T2)", false;
(* (any^[ A ] , t)^[ A ] *)
"(x where x = (`$A & ((`$A , x) | `nil)))", "Empty", false;
(* nil^[ A ] *)
];;
let test_witness =
"test subtype" >:::
List.map (fun (s1,s2,expected) ->
(Printf.sprintf " %s <: %s " s1 s2) >:: (fun _ ->
let t1 = parse_typ s1 in
let t2 = parse_typ s2 in
let d = Types.diff t1 t2 in
let result = Types.witness d in
Format.printf "subtyping %s <: %s\n" s1 s2;
Format.printf "witness : %a\n" Types.Witness.print_witness result;
Format.printf "diff : %a\n" Types.Print.print d;
(*
if result <> expected then
begin
(* Printf.printf "subtyping error %s <: %s\n" s1 s2; *)
Printf.printf "found %b, should be %b\n" result expected
end;
*)
assert_equal true true
)
) witness_tests
;;
let all = let all =
"all tests" >::: [ "all tests" >::: [
test_subtype; test_subtype;
test_witness;
] ]
let main () = let main () =
......
...@@ -26,20 +26,12 @@ sig ...@@ -26,20 +26,12 @@ sig
| `False | `False
| `Split of int * 'a * ('a bdd) * ('a bdd) * ('a bdd) ] | `Split of int * 'a * ('a bdd) * ('a bdd) * ('a bdd) ]
(* include Custom.T with type t = elem bdd
include Custom.T
*)
type t = elem bdd
val dump : Format.formatter -> t -> unit
val check : t -> unit
val equal : t -> t -> bool
val hash : t -> int
val compare : t -> t -> int
(* returns the union of all leaves in the BDD *) (* returns the union of all leaves in the BDD *)
val get: t -> s val leafconj: t -> s
(* val get': t -> (elem list * (elem list) list) list *) val get: t -> (elem list * elem list) list
val empty : t val empty : t
val full : t val full : t
...@@ -200,32 +192,33 @@ struct ...@@ -200,32 +192,33 @@ struct
| `False -> [] | `False -> []
| c -> [ fun ppf -> print X.dump ppf c ] | c -> [ fun ppf -> print X.dump ppf c ]
(* (* return a list of pairs, where each pair holds the list
let rec get accu pos neg = function * of positive and negative elements on a branch *)
| `True -> (pos,neg) :: accu let get x =
| `False -> accu let rec aux accu pos neg = function
| `Split (_,x, p,i,n) -> | `True -> (pos,neg) :: accu
(*OPT: can avoid creating this list cell when pos or neg =`False *) | `False -> accu
let accu = get accu (x::pos) neg p in | `Split (_,x, p,i,n) ->
let accu = get accu pos (x::neg) n in (*OPT: can avoid creating this list cell when pos or neg =`False *)
let accu = get accu pos neg i in let accu = aux accu (x::pos) neg p in
accu let accu = aux accu pos (x::neg) n in
let accu = aux accu pos neg i in
let get x = get [] [] [] x accu
*) in aux [] [] [] x
let rec get accu = function let leafconj x =
| `True -> accu let rec aux accu = function
| `False -> accu | `True -> accu
| `Split (_,`Atm x, `True,`False,`False) -> x :: accu | `False -> accu
| `Split (_,`Atm x, _,_,_) -> assert false | `Split (_,`Atm x, `True,`False,`False) -> x :: accu
| `Split (_,`Var x, p,i,n) -> | `Split (_,`Atm x, _,_,_) -> assert false
let accu = get accu p in | `Split (_,`Var x, p,i,n) ->
let accu = get accu n in let accu = aux accu p in
let accu = get accu i in let accu = aux accu n in
accu let accu = aux accu i in
accu
let get x = List.fold_left T.cup T.empty (get [] x) in
List.fold_left T.cup T.empty (aux [] x)
(* (*
let rec get' accu pos neg = function let rec get' accu pos neg = function
......
...@@ -340,8 +340,8 @@ binary_op_cst "dump_to_file_utf8" ...@@ -340,8 +340,8 @@ binary_op_cst "dump_to_file_utf8"
(* Integer operators *) (* Integer operators *)
let intop f x y = let intop f x y =
let s = Types.BoolIntervals.get x in let s = Types.BoolIntervals.leafconj x in
let t = Types.BoolIntervals.get y in let t = Types.BoolIntervals.leafconj y in
Types.BoolIntervals.atom (`Atm (f s t)) Types.BoolIntervals.atom (`Atm (f s t))
;; ;;
......
...@@ -858,8 +858,8 @@ module Compile = struct ...@@ -858,8 +858,8 @@ module Compile = struct
let split_kind basic prod xml record = { let split_kind basic prod xml record = {
basic = basic; basic = basic;
atoms = Atoms.mk_map (List.map (fun (t,r) -> Types.BoolAtoms.get (Types.Atom.get t), r) basic); atoms = Atoms.mk_map (List.map (fun (t,r) -> Types.BoolAtoms.leafconj (Types.Atom.get t), r) basic);
chars = Chars.mk_map (List.map (fun (t,r) -> Types.BoolChars.get (Types.Char.get t), r) basic); chars = Chars.mk_map (List.map (fun (t,r) -> Types.BoolChars.leafconj (Types.Char.get t), r) basic);
prod = prod; prod = prod;
xml = xml; xml = xml;
record = record record = record
......
...@@ -697,18 +697,20 @@ module Witness = struct ...@@ -697,18 +697,20 @@ module Witness = struct
r) r)
| w -> type_has (descr n) w | w -> type_has (descr n) w
(* type_has checks if a witness is contained in the union of
* the leafs of a bdd, ignoring all variables. *)
and type_has t = function and type_has t = function
| WInt i -> Intervals.contains i (BoolIntervals.get t.ints) | WInt i -> Intervals.contains i (BoolIntervals.leafconj t.ints)
| WChar c -> Chars.contains c (BoolChars.get t.chars) | WChar c -> Chars.contains c (BoolChars.leafconj t.chars)
| WAtom a -> Atoms.contains_sample a (BoolAtoms.get t.atoms) | WAtom a -> Atoms.contains_sample a (BoolAtoms.leafconj t.atoms)
| WPair (w1,w2,_) -> | WPair (w1,w2,_) ->
bool_pair bool_pair
(fun (n1,n2) -> node_has n1 w1 && node_has n2 w2) (fun (n1,n2) -> node_has n1 w1 && node_has n2 w2)
(BoolPair.get t.times) (BoolPair.leafconj t.times)
| WXml (w1,w2,_) -> | WXml (w1,w2,_) ->
bool_pair bool_pair
(fun (n1,n2) -> node_has n1 w1 && node_has n2 w2) (fun (n1,n2) -> node_has n1 w1 && node_has n2 w2)
(BoolPair.get t.xml) (BoolPair.leafconj t.xml)
| WFun (f,_) -> | WFun (f,_) ->
bool_pair bool_pair
(fun (n1,n2) -> (fun (n1,n2) ->
...@@ -718,7 +720,7 @@ module Witness = struct ...@@ -718,7 +720,7 @@ module Witness = struct
(match y with None -> false (match y with None -> false
| Some y -> node_has n2 y)) | Some y -> node_has n2 y))
f) f)
(BoolPair.get t.arrow) (BoolPair.leafconj t.arrow)
| WRecord (f,o,_) -> | WRecord (f,o,_) ->
bool_rec bool_rec
(fun (o',f') -> (fun (o',f') ->
...@@ -737,7 +739,7 @@ module Witness = struct ...@@ -737,7 +739,7 @@ module Witness = struct
because of an invariant. Otherwise, we must because of an invariant. Otherwise, we must
check that all are WAbsent here. *) check that all are WAbsent here. *)
with Exit -> false)) with Exit -> false))
(BoolRec.get t.record) (BoolRec.leafconj t.record)
| WAbsent -> t.absent | WAbsent -> t.absent
| WAbstract a -> Abstract.contains_sample a t.abstract | WAbstract a -> Abstract.contains_sample a t.abstract
end end
...@@ -792,12 +794,12 @@ let rec slot d = ...@@ -792,12 +794,12 @@ let rec slot d =
incr complex; incr complex;
Stats.Counter.incr count_subtype; Stats.Counter.incr count_subtype;
if d.absent then slot_nempty Witness.WAbsent if d.absent then slot_nempty Witness.WAbsent
else if not (Intervals.is_empty (BoolIntervals.get d.ints)) else if not (Intervals.is_empty (BoolIntervals.leafconj d.ints))
then slot_nempty (Witness.WInt (Intervals.sample (BoolIntervals.get d.ints))) then slot_nempty (Witness.WInt (Intervals.sample (BoolIntervals.leafconj d.ints)))
else if not (Atoms.is_empty (BoolAtoms.get d.atoms)) else if not (Atoms.is_empty (BoolAtoms.leafconj d.atoms))
then slot_nempty (Witness.WAtom (Atoms.sample (BoolAtoms.get d.atoms))) then slot_nempty (Witness.WAtom (Atoms.sample (BoolAtoms.leafconj d.atoms)))
else if not (Chars.is_empty (BoolChars.get d.chars)) else if not (Chars.is_empty (BoolChars.leafconj d.chars))
then slot_nempty (Witness.WChar (Chars.sample (BoolChars.get d.chars))) then slot_nempty (Witness.WChar (Chars.sample (BoolChars.leafconj d.chars)))
else if not (Abstract.is_empty d.abstract) else if not (Abstract.is_empty d.abstract)
then slot_nempty (Witness.WAbstract (Abstract.sample d.abstract)) then slot_nempty (Witness.WAbstract (Abstract.sample d.abstract))
else try DescrHash.find memo d else try DescrHash.find memo d
...@@ -805,10 +807,10 @@ let rec slot d = ...@@ -805,10 +807,10 @@ let rec slot d =
let s = { status = Maybe; active = false; notify = Nothing } in let s = { status = Maybe; active = false; notify = Nothing } in
DescrHash.add memo d s; DescrHash.add memo d s;
(try (try
iter_s s check_times (Pair.get (BoolPair.get d.times)); iter_s s check_times (Pair.get (BoolPair.leafconj d.times));
iter_s s check_xml (Pair.get (BoolPair.get d.xml)); iter_s s check_xml (Pair.get (BoolPair.leafconj d.xml));
iter_s s check_arrow (Pair.get (BoolPair.get d.arrow)); iter_s s check_arrow (Pair.get (BoolPair.leafconj d.arrow));
iter_s s check_record (get_record (BoolRec.get d.record)); iter_s s check_record (get_record (BoolRec.leafconj d.record));
if s.active then marks := s :: !marks else s.status <- Empty; if s.active then marks := s :: !marks else s.status <- Empty;
with NotEmpty -> ()); with NotEmpty -> ());
s s
...@@ -1051,7 +1053,7 @@ struct ...@@ -1051,7 +1053,7 @@ struct
) right in ) right in
if non_empty !resid1 then accu := (!resid1, d2) :: !accu if non_empty !resid1 then accu := (!resid1, d2) :: !accu
in in
List.iter line (Pair.get (BoolPair.get d)); List.iter line (Pair.get (BoolPair.leafconj d));
!accu !accu
(* Maybe, can improve this function with: (* Maybe, can improve this function with:
(t,s) \ (t1,s1) = (t&t',s\s') | (t\t',s), (t,s) \ (t1,s1) = (t&t',s\s') | (t\t',s),
...@@ -1224,7 +1226,7 @@ struct ...@@ -1224,7 +1226,7 @@ struct
| [] -> (p,accu) :: b in | [] -> (p,accu) :: b in
aux_p [] p) aux_p [] p)
[] []
(Rec.get (BoolRec.get d.record)) (Rec.get (BoolRec.leafconj d.record))
let split (d : descr) l = let split (d : descr) l =
TR.boolean (aux_split d l) TR.boolean (aux_split d l)
...@@ -1257,15 +1259,15 @@ struct ...@@ -1257,15 +1259,15 @@ struct
let aux (_,r) = let aux (_,r) =
let ls = LabelMap.domain r in let ls = LabelMap.domain r in
res := LabelSet.cup ls !res in res := LabelSet.cup ls !res in
(* XXX every times I use BoolRec.get I'm trowing away all variables ! *) (* XXX every times I use BoolRec.leafconj I'm trowing away all variables ! *)
Rec.iter aux (BoolRec.get d.record); Rec.iter aux (BoolRec.leafconj d.record);
!res !res
let first_label d = let first_label d =
let min = ref Label.dummy in let min = ref Label.dummy in
let aux (_,r) = match LabelMap.get r with let aux (_,r) = match LabelMap.get r with
(l,_)::_ -> min := Label.min l !min | _ -> () in (l,_)::_ -> min := Label.min l !min | _ -> () in
Rec.iter aux (BoolRec.get d.record); Rec.iter aux (BoolRec.leafconj d.record);
!min !min
let empty_cases d = let empty_cases d =
...@@ -1278,7 +1280,7 @@ struct ...@@ -1278,7 +1280,7 @@ struct
assert (LabelMap.get r == []); assert (LabelMap.get r == []);
if o then 3 else 1 if o then 3 else 1
) )
(BoolRec.get d.record) in (BoolRec.leafconj d.record) in
(x land 2 <> 0, x land 1 <> 0) (x land 2 <> 0, x land 1 <> 0)
let has_empty_record d = let has_empty_record d =
...@@ -1290,7 +1292,7 @@ struct ...@@ -1290,7 +1292,7 @@ struct
(fun (l,t) -> (descr t).absent) (fun (l,t) -> (descr t).absent)
(LabelMap.get r) (LabelMap.get r)
) )
(BoolRec.get d.record) (BoolRec.leafconj d.record)
(*TODO: optimize merge (*TODO: optimize merge
- pre-compute the sequence of labels - pre-compute the sequence of labels
...@@ -1520,7 +1522,7 @@ struct ...@@ -1520,7 +1522,7 @@ struct
add (Name n) add (Name n)
with Not_found -> with Not_found ->
let tag = let tag =
match Atoms.print_tag (BoolAtoms.get t1.atoms) with match Atoms.print_tag (BoolAtoms.leafconj t1.atoms) with
| Some a when is_empty { t1 with atoms = BoolAtoms.empty } -> `Tag a | Some a when is_empty { t1 with atoms = BoolAtoms.empty } -> `Tag a
| _ -> `Type (prepare t1) in | _ -> `Type (prepare t1) in
assert (equal { t2 with times = empty.times } empty); assert (equal { t2 with times = empty.times } empty);
...@@ -1535,7 +1537,7 @@ struct ...@@ -1535,7 +1537,7 @@ struct
let r = LabelMap.map (fun (o,t) -> (o, prepare t)) r in let r = LabelMap.map (fun (o,t) -> (o, prepare t)) r in
add (Record (r,some,none))) add (Record (r,some,none)))
(Record.get not_seq); (Record.get not_seq);
(match Chars.is_char (BoolChars.get not_seq.chars) with (match Chars.is_char (BoolChars.leafconj not_seq.chars) with
| Some c -> add (Char c) | Some c -> add (Char c)
| None -> | None ->
List.iter (fun x -> add (Atomic x)) (BoolChars.print "" not_seq.chars)); List.iter (fun x -> add (Atomic x)) (BoolChars.print "" not_seq.chars));
...@@ -1547,7 +1549,7 @@ struct ...@@ -1547,7 +1549,7 @@ struct
let aux (t,s) = prepare (descr t), prepare (descr s) in let aux (t,s) = prepare (descr t), prepare (descr s) in
let p = List.map aux p and n = List.map aux n in let p = List.map aux p and n = List.map aux n in
add (Arrows (p,n))) add (Arrows (p,n)))
(Pair.get (BoolPair.get not_seq.arrow)); (Pair.get (BoolPair.leafconj not_seq.arrow));
if not_seq.absent then add (Atomic (fun ppf -> Format.fprintf ppf "#ABSENT")); if not_seq.absent then add (Atomic (fun ppf -> Format.fprintf ppf "#ABSENT"));
slot.def <- List.rev slot.def; slot.def <- List.rev slot.def;
slot slot
...@@ -1559,7 +1561,7 @@ struct ...@@ -1559,7 +1561,7 @@ struct
let tr = Product.merge_same_first tr in let tr = Product.merge_same_first tr in
let tr = Product.clean_normal tr in let tr = Product.clean_normal tr in
let eps = Atoms.contains nil_atom (BoolAtoms.get t.atoms) in let eps = Atoms.contains nil_atom (BoolAtoms.leafconj t.atoms) in
let tr_cons = List.map (fun (li,ti) -> (cons li, cons ti)) tr in let tr_cons = List.map (fun (li,ti) -> (cons li, cons ti)) tr in
try try
...@@ -2049,7 +2051,7 @@ struct ...@@ -2049,7 +2051,7 @@ struct
not (List.exists (check_simple left) right) not (List.exists (check_simple left) right)
let sample t = let sample t =
let (left,right) = List.find check_line_non_empty (Pair.get (BoolPair.get t.arrow)) in let (left,right) = List.find check_line_non_empty (Pair.get (BoolPair.leafconj t.arrow)) in
List.fold_left (fun accu (t,s) -> cap accu (arrow t s)) List.fold_left (fun accu (t,s) -> cap accu (arrow t s))
{ empty with arrow = any.arrow } left { empty with arrow = any.arrow } left
...@@ -2078,7 +2080,7 @@ struct ...@@ -2078,7 +2080,7 @@ struct
(List.for_all (fun (a,b) -> not (check_simple_iface iface a b)) n)) (List.for_all (fun (a,b) -> not (check_simple_iface iface a b)) n))
|| (aux rem) || (aux rem)
in in
aux (Pair.get (BoolPair.get s.arrow)) aux (Pair.get (BoolPair.leafconj s.arrow))
type t = descr * (descr * descr) list list type t = descr * (descr * descr) list list
...@@ -2093,7 +2095,7 @@ struct ...@@ -2093,7 +2095,7 @@ struct
else accu else accu
) )
(any, []) (any, [])
(Pair.get (BoolPair.get t.arrow)) (Pair.get (BoolPair.leafconj t.arrow))
let domain (dom,_) = dom let domain (dom,_) = dom
...@@ -2134,23 +2136,22 @@ struct ...@@ -2134,23 +2136,22 @@ struct
let is_empty (_,arr) = arr == [] let is_empty (_,arr) = arr == []
end end
module Int = struct module Int = struct
let has_int d i = Intervals.contains i (BoolIntervals.get d.ints) let has_int d i = Intervals.contains i (BoolIntervals.leafconj d.ints)
let get d = d.ints let get d = d.ints
let any = { empty with ints = any.ints } let any = { empty with ints = any.ints }
let any = { empty with ints = BoolIntervals.full } let any = { empty with ints = BoolIntervals.full }
end end
module Atom = struct module Atom = struct
let has_atom d a = Atoms.contains a (BoolAtoms.get d.atoms) let has_atom d a = Atoms.contains a (BoolAtoms.leafconj d.atoms)
let get d = d.atoms let get d = d.atoms
let any = { empty with atoms = any.atoms } let any = { empty with atoms = any.atoms }
end end
module Char = struct module Char = struct
let has_char d c = Chars.contains c (BoolChars.get d.chars) let has_char d c = Chars.contains c (BoolChars.leafconj d.chars)
let is_empty d = Chars.is_empty (BoolChars.get d.chars) let is_empty d = Chars.is_empty (BoolChars.leafconj d.chars)
let get d = d.chars let get d = d.chars
let any = { empty with chars = any.chars } let any = { empty with chars = any.chars }
end end
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment