Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
cduce
cduce
Commits
0feb7c64
Commit
0feb7c64
authored
May 26, 2014
by
Pietro Abate
Browse files
Merge branch 'master' into propagate
parents
72828c95
96d3231d
Changes
3
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
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment