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

Merge branch 'master' into propagate

parents 72828c95 96d3231d
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 ()
...@@ -58,6 +58,20 @@ let tlv_tests = [ "is_var", [ ...@@ -58,6 +58,20 @@ let tlv_tests = [ "is_var", [
"Any \\ `$A", Types.has_tlv, true; "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 = let test_tlv_operations =
......
...@@ -1633,36 +1633,34 @@ struct ...@@ -1633,36 +1633,34 @@ struct
let add u = slot.def <- u :: slot.def in let add u = slot.def <- u :: slot.def in
let prepare_boolvar displayvars displayatoms get is_full print tlv bdd = let prepare_boolvar get is_full print tlv bdd =
List.iter (fun (p,n) -> let ll =
let l1 = List.fold_left (fun acc (p,n) ->
let tlv_only = ref true in let (_,l1) =
List.fold_left (fun acc -> function List.fold_left (fun (has_tlv,acc) -> function
|(`Var v) as x -> |(`Var v) as x when (TLV.mem (x,true) tlv) -> (true,acc)
if not(TLV.mem (x,true) tlv) then begin |(`Var v) as x -> (has_tlv,(Atomic (fun ppf -> Var.print ppf x))::acc)
tlv_only := false; |`Atm bdd ->
(Atomic (fun ppf -> Var.print ppf x))::acc begin match has_tlv,acc with
end else acc |true,[] -> if is_full bdd then (has_tlv,[]) else (has_tlv,print bdd)
(* the bdd is printed if there one var that is not a tlv var or it |false,[] -> if is_full bdd then (has_tlv,[]) else (has_tlv,print bdd)
* is not empty . It is not printed if it is full and there are only |_,_ -> (has_tlv,acc @ (print bdd))
* tlv variables or it is empty *) end
|`Atm bdd when (is_full bdd) && !tlv_only -> acc ) (false,[]) p
|`Atm bdd -> print bdd in
) [] p let l2 =
in List.fold_left (fun acc -> function
let l2 = |(`Var v) as x when (TLV.mem (x,false) tlv) -> acc
List.fold_left (fun acc -> function |(`Var v) as x -> (Atomic (fun ppf -> Format.fprintf ppf "~ %a" Var.print x))::acc
|(`Var v) as x -> |`Atm bdd -> assert false
if not(TLV.mem (x,false) tlv) then ) [] n
(Atomic (fun ppf -> Format.fprintf ppf "~ %a" Var.print x))::acc in
else acc match (l1@l2) with
|`Atm bdd -> assert false |[] -> acc
) [] n |l -> l::acc
in ) [] (get bdd)
match (l1@l2) with in
|[] -> () List.iter (fun l -> add (Intersection (alloc (List.rev l)))) ll
|l -> add (Intersection (alloc (List.rev l)))
) (get bdd)
in in
if (non_empty seq) then add (Regexp (decompile seq)); if (non_empty seq) then add (Regexp (decompile seq));
...@@ -1679,17 +1677,14 @@ struct ...@@ -1679,17 +1677,14 @@ struct
add (Intersection (alloc l)) add (Intersection (alloc l))
end; end;
let displayatoms = true in
let displayvars = false in
(* base types *) (* 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 match Chars.is_char bdd with
| Some c -> [(Char c)] | Some c -> [(Char c)]
| None -> List.map (fun x -> (Atomic x)) (Chars.print bdd) | None -> List.map (fun x -> (Atomic x)) (Chars.print bdd)
) not_seq.toplvars not_seq.chars; ) 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) List.map (fun x -> (Atomic x)) (Intervals.print bdd)
) not_seq.toplvars not_seq.ints; ) not_seq.toplvars not_seq.ints;
...@@ -1698,19 +1693,20 @@ struct ...@@ -1698,19 +1693,20 @@ struct
(Atoms.atom (Atoms.V.mk_ascii "false")) (Atoms.atom (Atoms.V.mk_ascii "false"))
(Atoms.atom (Atoms.V.mk_ascii "true")) (Atoms.atom (Atoms.V.mk_ascii "true"))
in 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")] if Atoms.equal bool bdd then [Atomic (fun ppf -> Format.fprintf ppf "Bool")]
else List.map (fun x -> (Atomic x)) (Atoms.print bdd) else List.map (fun x -> (Atomic x)) (Atoms.print bdd)
) not_seq.toplvars not_seq.atoms; ) not_seq.toplvars not_seq.atoms;
(* pairs *) (* 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) -> List.map (fun (t1,t2) ->
(Pair (prepare t1, prepare t2)) Pair (prepare t1, prepare t2)
) (Product.partition any x)) not_seq.toplvars not_seq.times; ) (Product.partition any x)
) not_seq.toplvars not_seq.times;
(* xml pairs *) (* 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.flatten (
List.map (fun (t1,t2) -> List.map (fun (t1,t2) ->
try let n = DescrPairMap.find (t1,t2) !named_xml in [(Name n)] try let n = DescrPairMap.find (t1,t2) !named_xml in [(Name n)]
...@@ -1728,7 +1724,7 @@ struct ...@@ -1728,7 +1724,7 @@ struct
)) not_seq.toplvars not_seq.xml; )) not_seq.toplvars not_seq.xml;
(* arrows *) (* 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) -> List.map (fun (p,n) ->
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
......
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