Commit 62d4041a authored by Pietro Abate's avatar Pietro Abate
Browse files

Minor changes to the TVL code

parent 28b75cf5
......@@ -13,23 +13,8 @@ let to_string pp t =
Format.fprintf Format.str_formatter "%a@." pp t;
Format.flush_str_formatter ()
;;
(*
let variance_test = [
"`$A -> `$B", [("A",`Covariant);("B",`ContraVariant)];
]
let test_variance =
"test variance annotations" >:::
List.map (fun (t1,expected) ->
(Printf.sprintf " %s" t1) >:: (fun _ ->
let t = parse_typ t1 in
assert_equal ~cmp:Types.equal ~printer:(to_string Types.Print.print) t1 t2
)
) set_op_tests
;;
*)
let tlv_tests = [
let tlv_tests = [ "is_var", [
"`$A", Types.is_var, true;
"Int", Types.is_var, false;
"Empty", Types.is_var, false;
......@@ -38,7 +23,9 @@ let tlv_tests = [
"`$A & Any", Types.is_var, true;
"`$A | Int", Types.is_var, false;
"(`$A,Int)", Types.is_var, false;
];
"no_var", [
"Int", Types.no_var, true;
"Any", Types.no_var, true;
"Empty", Types.no_var, true;
......@@ -48,28 +35,40 @@ let tlv_tests = [
"`$A | Int", Types.no_var, false;
"(`$A,Int)", Types.no_var, false;
"(Char,Int)", Types.no_var, true;
];
"has_tlv", [
"Int", Types.has_tlv, false;
"Any", Types.has_tlv, false;
"Empty", Types.has_tlv, false;
"`A", Types.has_tlv, false;
"`$A", Types.has_tlv, true;
"`$A & Int", Types.has_tlv, true;
"`$A | Int", Types.has_tlv, true;
"(`$A,Int)", Types.has_tlv, false;
"`$B | (`$A,Int)", Types.has_tlv, false;
"`$A & Int", Types.has_tlv, false;
"`$A | Int", Types.has_tlv, true;
"`$A | (`$B,Int)", Types.has_tlv, false;
"`$A | (Char,Int)", Types.has_tlv, false;
];
]
let test_tlv_operations =
"test TLV operations" >:::
List.map (fun (t,f,e) ->
(Printf.sprintf "test %s " t) >:: (fun _ ->
let t = parse_typ t in
assert_equal ~pp_diff:(fun fmt _ -> Types.Print.print fmt t) (f t) e
)
) tlv_tests
List.flatten (
List.map (fun (s,l) ->
List.map (fun (t,f,e) ->
(Printf.sprintf "test %s %s " s t) >:: (fun _ ->
let t = (parse_typ t) in
assert_equal ~pp_diff:(fun fmt _ ->
Format.fprintf fmt "%s = %b\ndump = %s\nrepr = %s\n"
s e
(to_string Types.dump t)
(to_string Types.Print.print t))
(f t) e
)
) l
) tlv_tests
)
;;
let set_op_tests = [
......
......@@ -163,37 +163,37 @@ module TLV = struct
aux ppf (elements s)
end
(* s : top level variables
* f : all free variables in the subtree
* b : true if the type contains only variables *)
type t = { s : Set.t ; f : Var.Set.t ; b : bool }
(* tlv : top level variables
* fv : all free variables in the subtree
* varonly : true if the type contains only variables *)
type t = { tlv : Set.t ; fv : Var.Set.t ; varonly : bool }
let empty = { s = Set.empty ; f = Var.Set.empty ; b = false }
let any = { s = Set.empty ; f = Var.Set.empty ; b = false }
let empty = { tlv = Set.empty ; fv = Var.Set.empty ; varonly = false }
let any = { tlv = Set.empty ; fv = Var.Set.empty ; varonly = false }
let singleton (v,p) = { s = Set.singleton (v,p); f = Var.Set.singleton v; b = true }
let singleton (v,p) = { tlv = Set.singleton (v,p); fv = Var.Set.singleton v; varonly = true }
(* return the max of top level variables *)
let max x = Set.max_elt x.s
let max x = Set.max_elt x.tlv
let pair x y = {
b = false ;
s = Set.empty ;
f = Var.Set.union x.f y.f
varonly = false ;
tlv = Set.empty ;
fv = Var.Set.union x.fv y.fv
}
(* true if it contains only one variable *)
let is_single x = x.b && (Var.Set.cardinal x.f = 1) && (Set.cardinal x.s = 1)
let is_single x = x.varonly && (Var.Set.cardinal x.fv = 1) && (Set.cardinal x.tlv = 1)
let no_variables x = (x.b == false) && (Var.Set.cardinal x.f = 0) && (Set.cardinal x.s = 0)
let no_variables x = (x.varonly == false) && (Var.Set.cardinal x.fv = 0) && (Set.cardinal x.tlv = 0)
let has_toplevel x = Set.cardinal x.s > 0
let has_toplevel x = Set.cardinal x.tlv > 0
let print ppf x = if x.b then Set.print ";" ppf x.s
let print ppf x = if x.varonly then Set.print ";" ppf x.tlv
let dump ppf x =
Format.fprintf ppf "<b = %b ; f = {%a} ; s = {%a}>"
x.b Var.Set.print x.f (Set.print ";") x.s
let mem v x = Set.mem v x.s
Format.fprintf ppf "<varonly = %b ; fv = {%a} ; tlv = {%a}>"
x.varonly Var.Set.print x.fv (Set.print ";") x.tlv
let mem v x = Set.mem v x.tlv
end
......@@ -453,7 +453,7 @@ let is_var t = TLV.is_single t.toplvars
let no_var t = TLV.no_variables t.toplvars
let has_tlv t = TLV.has_toplevel t.toplvars
let all_vars t = t.toplvars.TLV.f
let all_vars t = t.toplvars.TLV.fv
(* XXX this function could be potentially costly. There should be
* better way to take trace of top level variables in a type *)
......@@ -492,8 +492,12 @@ let update_tlv x y t =
(aux BoolRec.get t.record)
]
in
let s = tlv t in
{ t with toplvars = { s = s ; f = Var.Set.union x.toplvars.f y.toplvars.f ; b = x.toplvars.b && x.toplvars.b } }
{ t with toplvars =
{
tlv = tlv t ;
fv = Var.Set.union x.toplvars.fv y.toplvars.fv ;
varonly = x.toplvars.varonly && x.toplvars.varonly
} }
;;
let char c = { empty with chars = BoolChars.atom (`Atm c) }
......
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