Commit 1db0d21a authored by Kim Nguyễn's avatar Kim Nguyễn

Rename the Bool* modules into Var* (which makes way more sense).

parent 062d5039
......@@ -349,8 +349,8 @@ binary_op_cst "dump_to_file_utf8"
(* Integer operators *)
let intop f x y =
let s = Types.BoolIntervals.leafconj x in
let t = Types.BoolIntervals.leafconj y in
let s = Types.VarIntervals.leafconj x in
let t = Types.VarIntervals.leafconj y in
(f s t)
;;
......
......@@ -870,8 +870,8 @@ module Compile = struct
let split_kind basic prod xml record = {
basic = 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.leafconj (Types.Char.get t), r) basic);
atoms = Atoms.mk_map (List.map (fun (t,r) -> Types.VarAtoms.leafconj (Types.Atom.get t), r) basic);
chars = Chars.mk_map (List.map (fun (t,r) -> Types.VarChars.leafconj (Types.Char.get t), r) basic);
prod = prod;
xml = xml;
record = record
......
......@@ -55,9 +55,9 @@ let rec single memo t =
let memo = D.add t memo in
let pair (t1,t2) = Types.Pair (single memo t1, single memo t2) in
let xml (t1,t2) = Types.Xml (single memo t1, single memo t2) in
let int t = Types.Integer (Intervals.single (Types.BoolIntervals.leafconj (Types.Int.get t))) in
let atom t = Types.Atom (Atoms.single (Types.BoolAtoms.leafconj (Types.Atom.get t))) in
let char t = Types.Char (Chars.single (Types.BoolChars.leafconj (Types.Char.get t))) in
let int t = Types.Integer (Intervals.single (Types.VarIntervals.leafconj (Types.Int.get t))) in
let atom t = Types.Atom (Atoms.single (Types.VarAtoms.leafconj (Types.Atom.get t))) in
let char t = Types.Char (Chars.single (Types.VarChars.leafconj (Types.Char.get t))) in
let fields = function
| (true,_) -> assert false
| (false,t) -> single memo t in
......
......@@ -168,16 +168,16 @@ let empty_descr_ = { atoms = Bool.empty;
module rec Descr :
sig
include Custom.T with
type t = (BoolAtoms.t, BoolIntervals.t, BoolChars.t, BoolTimes.t,
BoolXml.t, BoolArrow.t, BoolRec.t, BoolAbstracts.t) descr_
type t = (VarAtoms.t, VarIntervals.t, VarChars.t, VarTimes.t,
VarXml.t, VarArrow.t, VarRec.t, VarAbstracts.t) descr_
val empty: t
val any : t
val is_empty : t -> bool
end =
struct
type t = (BoolAtoms.t, BoolIntervals.t, BoolChars.t, BoolTimes.t,
BoolXml.t, BoolArrow.t, BoolRec.t, BoolAbstracts.t) descr_
type t = (VarAtoms.t, VarIntervals.t, VarChars.t, VarTimes.t,
VarXml.t, VarArrow.t, VarRec.t, VarAbstracts.t) descr_
let dump ppf d =
Format.fprintf ppf "@[<v 1>types:@\n\
......@@ -190,87 +190,87 @@ struct
@<1> record: %a@\n\
@<1> abstract: %a@\n\
@<1> absent: %b@]@\n"
BoolAtoms.dump d.atoms
BoolIntervals.dump d.ints
BoolChars.dump d.chars
BoolTimes.dump d.times
BoolXml.dump d.xml
BoolArrow.dump d.arrow
BoolRec.dump d.record
BoolAbstracts.dump d.abstract
VarAtoms.dump d.atoms
VarIntervals.dump d.ints
VarChars.dump d.chars
VarTimes.dump d.times
VarXml.dump d.xml
VarArrow.dump d.arrow
VarRec.dump d.record
VarAbstracts.dump d.abstract
d.absent
let empty = empty_descr_
let any = {
ints = BoolIntervals.full;
atoms = BoolAtoms.full;
chars = BoolChars.full;
times = BoolTimes.full;
xml = BoolXml.full;
arrow = BoolArrow.full;
record = BoolRec.full;
abstract = BoolAbstracts.full;
ints = VarIntervals.full;
atoms = VarAtoms.full;
chars = VarChars.full;
times = VarTimes.full;
xml = VarXml.full;
arrow = VarArrow.full;
record = VarRec.full;
abstract = VarAbstracts.full;
absent = false;
}
let check a =
BoolChars.check a.chars;
BoolIntervals.check a.ints;
BoolAtoms.check a.atoms;
BoolTimes.check a.times;
BoolXml.check a.xml;
BoolArrow.check a.arrow;
BoolRec.check a.record;
BoolAbstracts.check a.abstract;
VarChars.check a.chars;
VarIntervals.check a.ints;
VarAtoms.check a.atoms;
VarTimes.check a.times;
VarXml.check a.xml;
VarArrow.check a.arrow;
VarRec.check a.record;
VarAbstracts.check a.abstract;
()
let equal a b =
(a == b) || (
(BoolAtoms.equal a.atoms b.atoms) &&
(BoolChars.equal a.chars b.chars) &&
(BoolIntervals.equal a.ints b.ints) &&
(BoolTimes.equal a.times b.times) &&
(BoolXml.equal a.xml b.xml) &&
(BoolArrow.equal a.arrow b.arrow) &&
(BoolRec.equal a.record b.record) &&
(BoolAbstracts.equal a.abstract b.abstract) &&
(VarAtoms.equal a.atoms b.atoms) &&
(VarChars.equal a.chars b.chars) &&
(VarIntervals.equal a.ints b.ints) &&
(VarTimes.equal a.times b.times) &&
(VarXml.equal a.xml b.xml) &&
(VarArrow.equal a.arrow b.arrow) &&
(VarRec.equal a.record b.record) &&
(VarAbstracts.equal a.abstract b.abstract) &&
(a.absent == b.absent)
)
let is_empty a =
(BoolAtoms.is_empty a.atoms) &&
(BoolChars.is_empty a.chars) &&
(BoolIntervals.is_empty a.ints) &&
(BoolTimes.is_empty a.times) &&
(BoolXml.is_empty a.xml) &&
(BoolArrow.is_empty a.arrow) &&
(BoolRec.is_empty a.record) &&
(BoolAbstracts.is_empty a.abstract)
(VarAtoms.is_empty a.atoms) &&
(VarChars.is_empty a.chars) &&
(VarIntervals.is_empty a.ints) &&
(VarTimes.is_empty a.times) &&
(VarXml.is_empty a.xml) &&
(VarArrow.is_empty a.arrow) &&
(VarRec.is_empty a.record) &&
(VarAbstracts.is_empty a.abstract)
let compare a b =
if a == b then 0
else let c = BoolAtoms.compare a.atoms b.atoms in if c <> 0 then c
else let c = BoolChars.compare a.chars b.chars in if c <> 0 then c
else let c = BoolIntervals.compare a.ints b.ints in if c <> 0 then c
else let c = BoolTimes.compare a.times b.times in if c <> 0 then c
else let c = BoolXml.compare a.xml b.xml in if c <> 0 then c
else let c = BoolArrow.compare a.arrow b.arrow in if c <> 0 then c
else let c = BoolRec.compare a.record b.record in if c <> 0 then c
else let c = BoolAbstracts.compare a.abstract b.abstract in if c <> 0 then c
else let c = VarAtoms.compare a.atoms b.atoms in if c <> 0 then c
else let c = VarChars.compare a.chars b.chars in if c <> 0 then c
else let c = VarIntervals.compare a.ints b.ints in if c <> 0 then c
else let c = VarTimes.compare a.times b.times in if c <> 0 then c
else let c = VarXml.compare a.xml b.xml in if c <> 0 then c
else let c = VarArrow.compare a.arrow b.arrow in if c <> 0 then c
else let c = VarRec.compare a.record b.record in if c <> 0 then c
else let c = VarAbstracts.compare a.abstract b.abstract in if c <> 0 then c
else if a.absent && not b.absent then -1
else if b.absent && not a.absent then 1
else 0
let hash a =
let accu = BoolChars.hash a.chars in
let accu = 17 * accu + BoolIntervals.hash a.ints in
let accu = 17 * accu + BoolAtoms.hash a.atoms in
let accu = 17 * accu + BoolTimes.hash a.times in
let accu = 17 * accu + BoolXml.hash a.xml in
let accu = 17 * accu + BoolArrow.hash a.arrow in
let accu = 17 * accu + BoolRec.hash a.record in
let accu = 17 * accu + BoolAbstracts.hash a.abstract in
let accu = VarChars.hash a.chars in
let accu = 17 * accu + VarIntervals.hash a.ints in
let accu = 17 * accu + VarAtoms.hash a.atoms in
let accu = 17 * accu + VarTimes.hash a.times in
let accu = 17 * accu + VarXml.hash a.xml in
let accu = 17 * accu + VarArrow.hash a.arrow in
let accu = 17 * accu + VarRec.hash a.record in
let accu = 17 * accu + VarAbstracts.hash a.abstract in
let accu = if a.absent then accu+5 else accu in
accu
......@@ -297,10 +297,8 @@ struct
let mk id d = { id = id; cu = Compunit.current (); descr = d }
end
and BoolAtoms : VarType with type Atom.t = Atoms.t
and VarAtoms : VarType with type Atom.t = Atoms.t
and type descr = Descr.t
=
struct
......@@ -310,7 +308,7 @@ and BoolAtoms : VarType with type Atom.t = Atoms.t
let proj t = t.atoms
end
and BoolIntervals : VarType with type Atom.t = Intervals.t
and VarIntervals : VarType with type Atom.t = Intervals.t
and type descr = Descr.t
=
struct
......@@ -320,7 +318,7 @@ and BoolIntervals : VarType with type Atom.t = Intervals.t
let proj t = t.ints
end
and BoolChars : VarType with type Atom.t = Chars.t
and VarChars : VarType with type Atom.t = Chars.t
and type descr = Descr.t
=
struct
......@@ -330,7 +328,7 @@ and BoolChars : VarType with type Atom.t = Chars.t
let proj t = t.chars
end
and BoolAbstracts : VarType with type Atom.t = Abstracts.t
and VarAbstracts : VarType with type Atom.t = Abstracts.t
and type descr = Descr.t
=
struct
......@@ -343,7 +341,7 @@ and BoolAbstracts : VarType with type Atom.t = Abstracts.t
and Pair : Bool.S with type elem = (Node.t * Node.t) =
Bool.Make(Custom.Pair(Node)(Node))
and BoolTimes : VarType with module Atom = Pair
and VarTimes : VarType with module Atom = Pair
and type descr = Descr.t
=
struct include Bool.MakeVar(Pair)
......@@ -352,7 +350,7 @@ and BoolTimes : VarType with module Atom = Pair
let proj (t : descr) : t = t.times
end
and BoolXml : VarType with module Atom = Pair
and VarXml : VarType with module Atom = Pair
and type descr = Descr.t
=
struct include Bool.MakeVar(Pair)
......@@ -361,7 +359,7 @@ and BoolXml : VarType with module Atom = Pair
let proj (t : descr) : t = t.xml
end
and BoolArrow : VarType with module Atom = Pair
and VarArrow : VarType with module Atom = Pair
and type descr = Descr.t
=
struct include Bool.MakeVar(Pair)
......@@ -377,7 +375,7 @@ end
and Rec : Bool.S with type elem = bool * Node.t Ident.label_map =
Bool.Make(Custom.Pair(Custom.Bool)(LabelSet.MakeMap(Node)))
and BoolRec : VarType with module Atom = Rec
and VarRec : VarType with module Atom = Rec
and type descr = Descr.t
=
struct include Bool.MakeVar(Rec)
......@@ -421,88 +419,88 @@ let non_constructed_or_absent =
{ non_constructed with absent = true }
(* Descr.t type constructors *)
let times x y = { empty with times = BoolTimes.atom (`Atm (Pair.atom (x,y))) }
let xml x y = { empty with xml = BoolXml.atom (`Atm (Pair.atom (x,y))) }
let arrow x y = { empty with arrow = BoolArrow.atom (`Atm (Pair.atom (x,y))) }
let times x y = { empty with times = VarTimes.atom (`Atm (Pair.atom (x,y))) }
let xml x y = { empty with xml = VarXml.atom (`Atm (Pair.atom (x,y))) }
let arrow x y = { empty with arrow = VarArrow.atom (`Atm (Pair.atom (x,y))) }
let record label t =
{ empty with record = BoolRec.atom (`Atm (Rec.atom (true,LabelMap.singleton label t))) }
{ empty with record = VarRec.atom (`Atm (Rec.atom (true,LabelMap.singleton label t))) }
let record_fields x =
{ empty with record = BoolRec.atom (`Atm (Rec.atom x)) }
{ empty with record = VarRec.atom (`Atm (Rec.atom x)) }
let atom a = { empty with atoms = BoolAtoms.atom (`Atm a) }
let atom a = { empty with atoms = VarAtoms.atom (`Atm a) }
(* Atm = Any ^ a *)
let var a =
{
ints = BoolIntervals.var a;
atoms = BoolAtoms.var a;
chars = BoolChars.var a;
times = BoolTimes.var a;
xml = BoolXml.var a;
arrow = BoolArrow.var a;
record= BoolRec.var a;
abstract = BoolAbstracts.var a;
ints = VarIntervals.var a;
atoms = VarAtoms.var a;
chars = VarChars.var a;
times = VarTimes.var a;
xml = VarXml.var a;
arrow = VarArrow.var a;
record= VarRec.var a;
abstract = VarAbstracts.var a;
absent = false;
}
let char c = { empty with chars = BoolChars.atom (`Atm c) }
let interval i = { empty with ints = BoolIntervals.atom (`Atm i) }
let abstract a = { empty with abstract = BoolAbstracts.atom (`Atm a) }
let char c = { empty with chars = VarChars.atom (`Atm c) }
let interval i = { empty with ints = VarIntervals.atom (`Atm i) }
let abstract a = { empty with abstract = VarAbstracts.atom (`Atm a) }
let cup x y =
if x == y then x else
{
ints = BoolIntervals.cup x.ints y.ints;
atoms = BoolAtoms.cup x.atoms y.atoms;
chars = BoolChars.cup x.chars y.chars;
times = BoolTimes.cup x.times y.times;
xml = BoolXml.cup x.xml y.xml;
arrow = BoolArrow.cup x.arrow y.arrow;
record= BoolRec.cup x.record y.record;
abstract = BoolAbstracts.cup x.abstract y.abstract;
ints = VarIntervals.cup x.ints y.ints;
atoms = VarAtoms.cup x.atoms y.atoms;
chars = VarChars.cup x.chars y.chars;
times = VarTimes.cup x.times y.times;
xml = VarXml.cup x.xml y.xml;
arrow = VarArrow.cup x.arrow y.arrow;
record= VarRec.cup x.record y.record;
abstract = VarAbstracts.cup x.abstract y.abstract;
absent = x.absent || y.absent;
}
let cap x y =
if x == y then x else
{
atoms = BoolAtoms.cap x.atoms y.atoms;
ints = BoolIntervals.cap x.ints y.ints;
chars = BoolChars.cap x.chars y.chars;
times = BoolTimes.cap x.times y.times;
xml = BoolXml.cap x.xml y.xml;
arrow = BoolArrow.cap x.arrow y.arrow;
record = BoolRec.cap x.record y.record;
abstract = BoolAbstracts.cap x.abstract y.abstract;
atoms = VarAtoms.cap x.atoms y.atoms;
ints = VarIntervals.cap x.ints y.ints;
chars = VarChars.cap x.chars y.chars;
times = VarTimes.cap x.times y.times;
xml = VarXml.cap x.xml y.xml;
arrow = VarArrow.cap x.arrow y.arrow;
record = VarRec.cap x.record y.record;
abstract = VarAbstracts.cap x.abstract y.abstract;
absent= x.absent && y.absent;
}
let diff x y =
if x == y then empty else
{
atoms = BoolAtoms.diff x.atoms y.atoms;
ints = BoolIntervals.diff x.ints y.ints;
chars = BoolChars.diff x.chars y.chars;
times = BoolTimes.diff x.times y.times;
xml = BoolXml.diff x.xml y.xml;
arrow = BoolArrow.diff x.arrow y.arrow;
record= BoolRec.diff x.record y.record;
abstract = BoolAbstracts.diff x.abstract y.abstract;
atoms = VarAtoms.diff x.atoms y.atoms;
ints = VarIntervals.diff x.ints y.ints;
chars = VarChars.diff x.chars y.chars;
times = VarTimes.diff x.times y.times;
xml = VarXml.diff x.xml y.xml;
arrow = VarArrow.diff x.arrow y.arrow;
record= VarRec.diff x.record y.record;
abstract = VarAbstracts.diff x.abstract y.abstract;
absent= x.absent && not y.absent;
}
(* TODO: optimize disjoint check for boolean combinations *)
let trivially_disjoint a b =
(BoolChars.trivially_disjoint a.chars b.chars) &&
(BoolIntervals.trivially_disjoint a.ints b.ints) &&
(BoolAtoms.trivially_disjoint a.atoms b.atoms) &&
(BoolTimes.trivially_disjoint a.times b.times) &&
(BoolXml.trivially_disjoint a.xml b.xml) &&
(BoolArrow.trivially_disjoint a.arrow b.arrow) &&
(BoolRec.trivially_disjoint a.record b.record) &&
(BoolAbstracts.trivially_disjoint a.abstract b.abstract) &&
(VarChars.trivially_disjoint a.chars b.chars) &&
(VarIntervals.trivially_disjoint a.ints b.ints) &&
(VarAtoms.trivially_disjoint a.atoms b.atoms) &&
(VarTimes.trivially_disjoint a.times b.times) &&
(VarXml.trivially_disjoint a.xml b.xml) &&
(VarArrow.trivially_disjoint a.arrow b.arrow) &&
(VarRec.trivially_disjoint a.record b.record) &&
(VarAbstracts.trivially_disjoint a.abstract b.abstract) &&
(not (a.absent && b.absent))
let rec constant = function
......@@ -764,17 +762,17 @@ module Witness = struct
(* 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
| WInt i -> Intervals.contains i (BoolIntervals.leafconj t.ints)
| WChar c -> Chars.contains c (BoolChars.leafconj t.chars)
| WAtom a -> Atoms.contains_sample a (BoolAtoms.leafconj t.atoms)
| WInt i -> Intervals.contains i (VarIntervals.leafconj t.ints)
| WChar c -> Chars.contains c (VarChars.leafconj t.chars)
| WAtom a -> Atoms.contains_sample a (VarAtoms.leafconj t.atoms)
| WPair (w1,w2,_) ->
bool_pair
(fun (n1,n2) -> node_has n1 w1 && node_has n2 w2)
(BoolTimes.leafconj t.times)
(VarTimes.leafconj t.times)
| WXml (w1,w2,_) ->
bool_pair
(fun (n1,n2) -> node_has n1 w1 && node_has n2 w2)
(BoolXml.leafconj t.xml)
(VarXml.leafconj t.xml)
| WFun (f,_) ->
bool_pair
(fun (n1,n2) ->
......@@ -784,7 +782,7 @@ module Witness = struct
(match y with None -> false
| Some y -> node_has n2 y))
f)
(BoolArrow.leafconj t.arrow)
(VarArrow.leafconj t.arrow)
| WRecord (f,o,_) ->
bool_rec
(fun (o',f') ->
......@@ -803,9 +801,9 @@ module Witness = struct
because of an invariant. Otherwise, we must
check that all are WAbsent here. *)
with Exit -> false))
(BoolRec.leafconj t.record)
(VarRec.leafconj t.record)
| WAbsent -> t.absent
| WAbstract a -> Abstracts.contains_sample a (BoolAbstracts.leafconj t.abstract)
| WAbstract a -> Abstracts.contains_sample a (VarAbstracts.leafconj t.abstract)
end
type slot = { mutable status : status;
......@@ -859,24 +857,24 @@ let rec slot d =
Stats.Counter.incr count_subtype;
(* XXX here I call leafconj a zilliontime. REWRITE !!! *)
if d.absent then slot_nempty Witness.WAbsent
else if not (Intervals.is_empty (BoolIntervals.leafconj d.ints))
then slot_nempty (Witness.WInt (Intervals.sample (BoolIntervals.leafconj d.ints)))
else if not (Atoms.is_empty (BoolAtoms.leafconj d.atoms))
then slot_nempty (Witness.WAtom (Atoms.sample (BoolAtoms.leafconj d.atoms)))
else if not (Chars.is_empty (BoolChars.leafconj d.chars))
then slot_nempty (Witness.WChar (Chars.sample (BoolChars.leafconj d.chars)))
else if not (Abstracts.is_empty (BoolAbstracts.leafconj d.abstract))
then slot_nempty (Witness.WAbstract (Abstracts.sample (BoolAbstracts.leafconj d.abstract)))
else if not (Intervals.is_empty (VarIntervals.leafconj d.ints))
then slot_nempty (Witness.WInt (Intervals.sample (VarIntervals.leafconj d.ints)))
else if not (Atoms.is_empty (VarAtoms.leafconj d.atoms))
then slot_nempty (Witness.WAtom (Atoms.sample (VarAtoms.leafconj d.atoms)))
else if not (Chars.is_empty (VarChars.leafconj d.chars))
then slot_nempty (Witness.WChar (Chars.sample (VarChars.leafconj d.chars)))
else if not (Abstracts.is_empty (VarAbstracts.leafconj d.abstract))
then slot_nempty (Witness.WAbstract (Abstracts.sample (VarAbstracts.leafconj d.abstract)))
else try
DescrHash.find memo d
with Not_found ->
let s = { status = Maybe; active = false; notify = Nothing } in
DescrHash.add memo d s;
(try
iter_s s check_times (Pair.get (BoolTimes.leafconj d.times));
iter_s s check_xml (Pair.get (BoolXml.leafconj d.xml));
iter_s s check_arrow (Pair.get (BoolArrow.leafconj d.arrow));
iter_s s check_record (get_record (BoolRec.leafconj d.record));
iter_s s check_times (Pair.get (VarTimes.leafconj d.times));
iter_s s check_xml (Pair.get (VarXml.leafconj d.xml));
iter_s s check_arrow (Pair.get (VarArrow.leafconj d.arrow));
iter_s s check_record (get_record (VarRec.leafconj d.record));
if s.active then marks := s :: !marks else s.status <- Empty;
with NotEmpty -> ());
s
......@@ -1003,8 +1001,8 @@ let equiv d1 d2 = (subtype d1 d2) && (subtype d2 d1)
let atom a =
let atm =
if Atoms.(is_empty (diff full a)) then
BoolAtoms.full
else BoolAtoms.atom (`Atm a)
VarAtoms.full
else VarAtoms.atom (`Atm a)
in
{ empty with atoms = atm }
......@@ -1012,14 +1010,14 @@ let times x y =
if subtype any x.Node.descr
&& subtype any y.Node.descr
then
{ empty with times = BoolTimes.full }
{ empty with times = VarTimes.full }
else times x y
let xml x y =
if subtype any x.Node.descr
&& subtype any y.Node.descr
then
{ empty with xml = BoolXml.full }
{ empty with xml = VarXml.full }
else xml x y
module Cache = struct
......@@ -1150,8 +1148,8 @@ struct
let get ?(kind=`Normal) d =
match kind with
| `Normal -> partition any (BoolTimes.leafconj d.times)
| `XML -> partition any_pair (BoolXml.leafconj d.xml)
| `Normal -> partition any (VarTimes.leafconj d.times)
| `XML -> partition any_pair (VarXml.leafconj d.xml)
let pi1 = List.fold_left (fun acc (t1,_) -> cup acc t1) empty
let pi2 = List.fold_left (fun acc (_,t2) -> cup acc t2) empty
......@@ -1195,8 +1193,8 @@ struct
let normal ?(kind=`Normal) d =
match kind with
| `Normal -> normal_times (BoolTimes.leafconj d.times)
| `XML -> normal_xml (BoolXml.leafconj d.xml)
| `Normal -> normal_times (VarTimes.leafconj d.times)
| `XML -> normal_xml (VarXml.leafconj d.xml)
(*
......@@ -1276,7 +1274,7 @@ struct
end
module TR = Normal.Make(T)(R)
let any_record = { empty with record = BoolRec.full }
let any_record = { empty with record = VarRec.full }
let atom o l =
if o && LabelMap.is_empty l then any_record else
......@@ -1312,7 +1310,7 @@ struct
| [] -> (p,accu) :: b in
aux_p [] p)
[]
(Rec.get (BoolRec.leafconj d.record))
(Rec.get (VarRec.leafconj d.record))
let split (d : descr) l =
TR.boolean (aux_split d l)
......@@ -1345,15 +1343,15 @@ struct
let aux (_,r) =
let ls = LabelMap.domain r in
res := LabelSet.cup ls !res in
(* XXX every times I use BoolRec.leafconj I'm trowing away all variables ! *)
Rec.iter aux (BoolRec.leafconj d.record);
(* XXX every times I use VarRec.leafconj I'm trowing away all variables ! *)
Rec.iter aux (VarRec.leafconj d.record);
!res
let first_label d =
let min = ref Label.dummy in
let aux (_,r) = match LabelMap.get r with
(l,_)::_ -> min := Label.min l !min | _ -> () in
Rec.iter aux (BoolRec.leafconj d.record);
Rec.iter aux (VarRec.leafconj d.record);
!min
let empty_cases d =
......@@ -1366,7 +1364,7 @@ struct
assert (LabelMap.get r == []);
if o then 3 else 1
)
(BoolRec.leafconj d.record) in
(VarRec.leafconj d.record) in
(x land 2 <> 0, x land 1 <> 0)
let has_empty_record d =
......@@ -1378,7 +1376,7 @@ struct
(fun (l,t) -> (descr t).absent)
(LabelMap.get r)
)
(BoolRec.leafconj d.record)
(VarRec.leafconj d.record)
(*TODO: optimize merge
- pre-compute the sequence of labels
......@@ -1461,7 +1459,7 @@ struct
not (List.exists (check_simple left) right)
let sample t =
let (left,right) = List.find check_line_non_empty (Pair.get (BoolArrow.leafconj t.arrow)) in
let (left,right) = List.find check_line_non_empty (Pair.get (VarArrow.leafconj t.arrow)) in
List.fold_left (fun accu (t,s) -> cap accu (arrow t s))
{ empty with arrow = any.arrow } left
......@@ -1491,7 +1489,7 @@ struct
in
(* considering only arrows here and not poly variables is correct as
* the iface is just an intersection of arrows *)
aux (Pair.get (BoolArrow.leafconj s.arrow))
aux (Pair.get (VarArrow.leafconj s.arrow))
type t = descr * (descr * descr) list list
......@@ -1506,7 +1504,7 @@ struct
else accu
)
(any, [])
(Pair.get (BoolArrow.leafconj t.arrow))
(Pair.get (VarArrow.leafconj t.arrow))
let domain (dom,_) = dom
......@@ -1548,28 +1546,28 @@ struct
end
module Int = struct
let has_int d i = Intervals.contains i (BoolIntervals.leafconj d.ints)
let has_int d i = Intervals.contains i (VarIntervals.leafconj d.ints)
let get d = d.ints
let any = { empty with ints = any.ints }
(* let any = { empty with ints = BoolIntervals.full } *)
(* let any = { empty with ints = VarIntervals.full } *)
end
module Atom = struct
let has_atom d a = Atoms.contains a (BoolAtoms.leafconj d.atoms)
let has_atom d a = Atoms.contains a (VarAtoms.leafconj d.atoms)
let get d = d.atoms
let any = { empty with atoms = any.atoms }
end
module OldChar = Char
module Char = struct
let has_char d c = Chars.contains c (BoolChars.leafconj d.chars)
let is_empty d = Chars.is_empty (BoolChars.leafconj d.chars)
let has_char d c = Chars.contains c (VarChars.leafconj d.chars)
let is_empty d = Chars.is_empty (VarChars.leafconj d.chars)
let get d = d.chars
let any = { empty with chars = any.chars }
end
module Abstract = struct
let has_abstract d a = Abstracts.contains a (BoolAbstracts.leafconj d.abstract)
let has_abstract d a = Abstracts.contains a (VarAbstracts.leafconj d.abstract)
let get d = d.abstract
let any = { empty with abstract = any.abstract }
end
......@@ -1611,8 +1609,8 @@ module Iter =
if normalize && Pervasives.(kind <> `Arrow) then
let rects =
match kind with
`Times -> Product.normal ~kind:`Normal { Descr.empty with times = BoolTimes.atom (`Atm p) }
| `Xml -> Product.normal ~kind:`XML { Descr.empty with xml = BoolXml.atom (`Atm p) }
`Times -> Product.normal ~kind:`Normal { Descr.empty with times = VarTimes.atom (`Atm p) }
| `Xml -> Product.normal ~kind:`XML { Descr.empty with xml = VarXml.atom (`Atm p) }
| _ -> assert false
in
List.fold_left (fun acc (d1, d2) -> cup acc (mk (cons d1, cons d2))) empty rects
......@@ -1621,21 +1619,21 @@ module Iter =
in
List.fold_left (fun acc e -> cup acc e)
(opt t.absent)
[ (BoolAtoms.compute
[ (VarAtoms.compute
~empty ~full:any_atom ~cup ~cap ~diff ~atom:(var_or atom) t.atoms);
(BoolIntervals.compute
(VarIntervals.compute
~empty ~full:any_int ~cup ~cap ~diff ~atom:(var_or int) t.ints);
(BoolChars.compute
(VarChars.compute
~empty ~full:any_char ~cup ~cap ~diff ~atom:(var_or char) t.chars);
(BoolAbstracts.compute
(VarAbstracts.compute
~empty ~full:any_abs ~cup ~cap ~diff ~atom:(var_or abs) t.abstract);
(BoolTimes.compute
(VarTimes.compute
~empty ~full:any_times ~cup ~cap ~diff ~atom:(var_or (prod_bdd `Times)) t.times);
(BoolXml.compute
(VarXml.compute
~empty ~full:any_xml ~cup ~cap ~diff ~atom:(var_or (prod_bdd `Xml)) t.xml);
(BoolArrow.compute
(VarArrow.compute
~empty ~full:any_arrow ~cup ~cap ~diff ~atom:(var_or (prod_bdd `Arrow)) t.arrow);