Skip to content

GitLab

Commit 0feb7c64 authored by Pietro Abate's avatar Pietro Abate
Browse files

Merge branch 'master' into propagate

parents 72828c95 96d3231d
Hide whitespace changes
Inline Side-by-side
tests/libtest/printTest.ml 0 → 100644
View file @ 0feb7c64
open OUnit
open Types
let parse_typ s =
let st = Stream.of_string s in
let astpat = Parser.pat st in
let nodepat = Typer.typ Builtin.env astpat in
Types.descr nodepat
;;
let to_string pp t =
Format.fprintf Format.str_formatter "%a@." pp t;
Format.flush_str_formatter ()
;;
let print_tests = [
"Int";
"Empty";
"(Int,Int)";
"Int -> Int";
"Bool -> Bool";
"Int -> `$A";
"[] -> []";
"Int -> `$A";
"(`$A -> Bool)";
"(`$B -> `$B)";
"(Int -> Bool)";
"(Int -> Int) | (Bool -> Bool)";
"(Int -> Int) | (Bool -> Bool)";
"([0--*] & `true)";
"(`$A | Int) & ((Any \\ `$A) | Bool)";
"(`$A | (`$B , `$C))";
"(Int , Int)";
"(`$A -> `$B) -> [ `$A ] -> [ `$B ]";
"((Int -> Bool) | ((`$A \\ Int) -> (`$B \\ Int))) -> `$Gamma";
"((`$A , Int) & (`$B , Bool))";
"(Int , (*Int & Bool*) Empty)";
"((`$A , Int) | (`$B , Bool))";
"(Int , (Int | Bool))";
"((Int | Bool) -> Int)";
"((Int | Bool) -> Int)";
"(Int -> Int) | (Bool -> Bool)";
"((Int,Int) , (Int | Bool))";
"(`$A,Int) | ((`$B,Int),Bool)";
"((`$A , Int) | (`$B , Bool))";
"(Int , (Int | Bool))";
"((`$A , Int) & (`$B , Bool))";
"(Int , (Int & Bool))";
"(`$A -> `$B) -> [`$A ] -> [`$B ]";
"((Int -> Bool) & ((`$A \\ Int) -> (`$A \\ Int)))";
"((Int -> Int) & (Bool -> Bool)) -> `$T";
]
let test_print =
"test print module" >:::
List.map (fun s ->
(Printf.sprintf " Printing %s " s) >:: (fun _ ->
let t = parse_typ s in
Format.printf "String : %s\n" s;
Format.printf "Print : %a\n\n" Types.Print.print t;
(*
Format.printf "Dump : %a\n\n" Types.dump t;
*)
assert_equal true true
)
) print_tests
;;
let suite =
"tests" >::: [
test_print;
]
let main () =
OUnit.run_test_tt_main suite
;;
main ()
tests/libtest/typesTest.ml
View file @ 0feb7c64
......@@ -58,6 +58,20 @@ let tlv_tests = [ "is_var", [
"Any \\ `$A", Types.has_tlv, true;
];
"var_only", [
"Int", Types.TLV.var_only, 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, false;
"`$A & Int", Types.has_tlv, false;
"`$A | Int", Types.has_tlv, false;
"`$A | Char", Types.has_tlv, false;
"`$A | (Any,Any)", Types.has_tlv, false;
"`$A | (`$B,Int)", Types.has_tlv, true;
"`$A | (Char,Int)", Types.has_tlv, true;
];
]
let test_tlv_operations =
......
types/types.ml
View file @ 0feb7c64
......@@ -1633,36 +1633,34 @@ struct
let add u = slot.def <- u :: slot.def in
let prepare_boolvar displayvars displayatoms get is_full print tlv bdd =
List.iter (fun (p,n) ->
let l1 =
let tlv_only = ref true in
List.fold_left (fun acc -> function
|(`Var v) as x ->
if not(TLV.mem (x,true) tlv) then begin
tlv_only := false;
(Atomic (fun ppf -> Var.print ppf x))::acc
end else acc
(* the bdd is printed if there one var that is not a tlv var or it
* is not empty . It is not printed if it is full and there are only
* tlv variables or it is empty *)
|`Atm bdd when (is_full bdd) && !tlv_only -> acc
|`Atm bdd -> print bdd
) [] p
in
let l2 =
List.fold_left (fun acc -> function
|(`Var v) as x ->
if not(TLV.mem (x,false) tlv) then
(Atomic (fun ppf -> Format.fprintf ppf "~ %a" Var.print x))::acc
else acc
|`Atm bdd -> assert false
) [] n
in
match (l1@l2) with
|[] -> ()
|l -> add (Intersection (alloc (List.rev l)))
) (get bdd)
let prepare_boolvar get is_full print tlv bdd =
let ll =
List.fold_left (fun acc (p,n) ->
let (_,l1) =
List.fold_left (fun (has_tlv,acc) -> function
|(`Var v) as x when (TLV.mem (x,true) tlv) -> (true,acc)
|(`Var v) as x -> (has_tlv,(Atomic (fun ppf -> Var.print ppf x))::acc)
|`Atm bdd ->
begin match has_tlv,acc with
|true,[] -> if is_full bdd then (has_tlv,[]) else (has_tlv,print bdd)
|false,[] -> if is_full bdd then (has_tlv,[]) else (has_tlv,print bdd)
|_,_ -> (has_tlv,acc @ (print bdd))
end
) (false,[]) p
in
let l2 =
List.fold_left (fun acc -> function
|(`Var v) as x when (TLV.mem (x,false) tlv) -> acc
|(`Var v) as x -> (Atomic (fun ppf -> Format.fprintf ppf "~ %a" Var.print x))::acc
|`Atm bdd -> assert false
) [] n
in
match (l1@l2) with
|[] -> acc
|l -> l::acc
) [] (get bdd)
in
List.iter (fun l -> add (Intersection (alloc (List.rev l)))) ll
in
if (non_empty seq) then add (Regexp (decompile seq));
......@@ -1679,17 +1677,14 @@ struct
add (Intersection (alloc l))
end;
let displayatoms = true in
let displayvars = false in
(* base types *)
prepare_boolvar displayvars displayatoms BoolChars.get (Chars.equal Chars.full) (fun bdd ->
prepare_boolvar BoolChars.get (Chars.equal Chars.full) (fun bdd ->
match Chars.is_char bdd with
| Some c -> [(Char c)]
| None -> List.map (fun x -> (Atomic x)) (Chars.print bdd)
) not_seq.toplvars not_seq.chars;
prepare_boolvar displayvars displayatoms BoolIntervals.get (Intervals.equal Intervals.full) (fun bdd ->
prepare_boolvar BoolIntervals.get (Intervals.equal Intervals.full) (fun bdd ->
List.map (fun x -> (Atomic x)) (Intervals.print bdd)
) not_seq.toplvars not_seq.ints;
......@@ -1698,19 +1693,20 @@ struct
(Atoms.atom (Atoms.V.mk_ascii "false"))
(Atoms.atom (Atoms.V.mk_ascii "true"))
in
prepare_boolvar displayvars displayatoms BoolAtoms.get (Atoms.equal Atoms.full) (fun bdd ->
prepare_boolvar BoolAtoms.get (Atoms.equal Atoms.full) (fun bdd ->
if Atoms.equal bool bdd then [Atomic (fun ppf -> Format.fprintf ppf "Bool")]
else List.map (fun x -> (Atomic x)) (Atoms.print bdd)
) not_seq.toplvars not_seq.atoms;
(* pairs *)
prepare_boolvar displayvars displayatoms BoolPair.get (Pair.equal Pair.full) (fun x ->
prepare_boolvar BoolPair.get (Pair.equal Pair.full) (fun x ->
List.map (fun (t1,t2) ->
(Pair (prepare t1, prepare t2))
) (Product.partition any x)) not_seq.toplvars not_seq.times;
Pair (prepare t1, prepare t2)
) (Product.partition any x)
) not_seq.toplvars not_seq.times;
(* xml pairs *)
prepare_boolvar displayvars displayatoms BoolPair.get (Pair.equal Pair.full) (fun x ->
prepare_boolvar BoolPair.get (Pair.equal Pair.full) (fun x ->
List.flatten (
List.map (fun (t1,t2) ->
try let n = DescrPairMap.find (t1,t2) !named_xml in [(Name n)]
......@@ -1728,7 +1724,7 @@ struct
)) not_seq.toplvars not_seq.xml;
(* arrows *)
prepare_boolvar displayvars displayatoms BoolPair.get (Pair.equal Pair.full) (fun x ->
prepare_boolvar BoolPair.get (Pair.equal Pair.full) (fun x ->
List.map (fun (p,n) ->
let aux (t,s) = prepare (descr t), prepare (descr s) in
let p = List.map aux p and n = List.map aux n in
......
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