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
a2da41f0
Commit
a2da41f0
authored
Dec 03, 2013
by
Pietro Abate
Browse files
Adapt Types.Descr.t to use the new BDD base data structure
parent
1c1ca633
Changes
18
Expand all
Hide whitespace changes
Inline
Side-by-side
_tags
View file @
a2da41f0
...
...
@@ -8,8 +8,8 @@ true: -traverse
<compile>: include
<schema>: include
<runtime>: include
#
<{misc,types,typing,schema,compile,runtime}/*.cmx>: for-pack(Cduce_test)
<{misc,types}/*.cmx>: for-pack(Cduce_test)
<{misc,types,typing,schema,compile,runtime}/*.cmx>: for-pack(Cduce_test)
#
<{misc,types}/*.cmx>: for-pack(Cduce_test)
<{misc,types}/*.cmx>: for-pack(Cduce_boolvar)
<parser/**>: package(ulex), package(netstring), syntax(camlp4o)
...
...
cduce_boolvar.mlpack
View file @
a2da41f0
...
...
@@ -17,4 +17,3 @@ Normal
Pretty
Stats
BoolVar
Types
cduce_test.mlpack
View file @
a2da41f0
...
...
@@ -10,6 +10,7 @@ SortedList
Atoms
Bool
Chars
BoolVar
Ident
Intervals
Inttbl
...
...
@@ -23,7 +24,6 @@ Parser
Builtin_defs
Cduce_loc
Sequence
Sample
Patterns
Lambda
Value
...
...
misc/custom.ml
View file @
a2da41f0
...
...
@@ -170,21 +170,22 @@ module Sum(X : T)(Y : T) = struct
|
Right
t
->
Format
.
fprintf
ppf
"R%a"
Y
.
dump
t
end
type
'
a
pairvar
=
Atm
of
'
a
|
Var
of
String
.
t
type
var
=
[
`Var
of
String
.
t
]
type
'
a
pairvar
=
[
`Atm
of
'
a
|
var
]
module
Var
(
X
:
T
)
=
struct
type
t
=
X
.
t
pairvar
let
hash
=
function
Atm
t
->
X
.
hash
t
|
Var
s
->
String
.
hash
s
let
check
=
function
Atm
t
->
X
.
check
t
|
Var
_
->
()
let
hash
=
function
`
Atm
t
->
X
.
hash
t
|
`
Var
s
->
(*
String.hash s
*)
Hashtbl
.
hash
(
`Var
s
)
let
check
=
function
`
Atm
t
->
X
.
check
t
|
`
Var
_
->
()
let
compare
t1
t2
=
match
t1
,
t2
with
|
Atm
x
,
Atm
y
->
X
.
compare
x
y
|
Var
x
,
Var
y
->
String
.
compare
x
y
|
Var
_
,
Atm
_
->
-
1
|
Atm
_
,
Var
_
->
1
|
`
Atm
x
,
`
Atm
y
->
X
.
compare
x
y
|
`
Var
x
,
`
Var
y
->
String
.
compare
x
y
|
`
Var
_
,
`
Atm
_
->
-
1
|
`
Atm
_
,
`
Var
_
->
1
let
equal
t1
t2
=
(
compare
t1
t2
)
=
0
let
dump
ppf
=
function
|
Atm
x
->
X
.
dump
ppf
x
|
Var
x
->
String
.
dump
ppf
x
|
`
Atm
x
->
X
.
dump
ppf
x
|
`
Var
x
->
String
.
dump
ppf
x
end
parser/ast.ml
View file @
a2da41f0
...
...
@@ -46,7 +46,7 @@ and pexpr =
(* CDuce is a Lambda-calculus ... *)
|
Var
of
U
.
t
|
TVar
of
Types
.
Vars
.
V
.
t
|
TVar
of
BoolVar
.
Vars
.
V
.
t
|
Apply
of
pexpr
*
pexpr
|
Abstraction
of
abstr
...
...
parser/parser.ml
View file @
a2da41f0
...
...
@@ -62,7 +62,7 @@ let tuple_queue =
List
.
fold_right
(
fun
x
q
->
Pair
(
x
,
q
))
let
char
=
mknoloc
(
Internal
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
Chars
.
any
))))
let
char
=
mknoloc
(
Internal
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
Chars
.
any
))))
let
string_regexp
=
Star
(
Elem
char
)
let
seq_of_string
s
=
...
...
@@ -298,7 +298,7 @@ EXTEND Gram
|
e1
=
expr
;
"&&"
;
e2
=
expr
->
exp
_loc
(
logical_and
e1
e2
)
|
e
=
expr
;
op
=
"/"
;
p
=
pat
LEVEL
"simple"
->
(* transform e with <(Atom)>[($$$::t|_)*] -> [$$$] *)
let
tag
=
mk
_loc
(
Internal
(
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
Custom
.
Atm
(
Atoms
.
any
)))))
in
let
tag
=
mk
_loc
(
Internal
(
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
`
Atm
(
Atoms
.
any
)))))
in
let
att
=
mk
_loc
(
Internal
Types
.
Record
.
any
)
in
let
any
=
mk
_loc
(
Internal
Types
.
any
)
in
let
re
=
Star
(
Alt
(
SeqCapture
(
noloc
,
id_dummy
,
Elem
p
)
,
Elem
any
))
in
...
...
@@ -307,7 +307,7 @@ EXTEND Gram
exp
_loc
(
Transform
(
e
,
[
p
,
Var
id_dummy
]))
|
e
=
expr
;
"/@"
;
a
=
ident_or_keyword
->
(* transform e with <(Atom) {a=$$$}>_ -> [$$$] *)
let
tag
=
mk
_loc
(
Internal
(
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
Custom
.
Atm
(
Atoms
.
any
)))))
in
let
tag
=
mk
_loc
(
Internal
(
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
`
Atm
(
Atoms
.
any
)))))
in
let
any
=
mk
_loc
(
Internal
Types
.
any
)
in
let
att
=
mk
_loc
(
Record
(
true
,
[(
label
a
,
...
...
@@ -330,7 +330,7 @@ EXTEND Gram
set_ref
(
Var
stk
)
(
concat
(
get_ref
(
Var
stk
))
(
Pair
(
Var
id_dummy
,
cst_nil
)))
in
let
tag
=
mknoloc
(
Internal
(
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
Custom
.
Atm
(
Atoms
.
any
)))))
in
let
tag
=
mknoloc
(
Internal
(
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
`
Atm
(
Atoms
.
any
)))))
in
let
att
=
mknoloc
(
Internal
Types
.
Record
.
any
)
in
let
any
=
mknoloc
(
Internal
Types
.
any
)
in
let
re
=
(
SeqCapture
(
noloc
,
y
,
Star
(
Elem
(
any
))))
in
...
...
@@ -403,7 +403,7 @@ EXTEND Gram
tag
:
[
[
a
=
ident_or_keyword
->
exp
_loc
(
Atom
(
ident
a
))
]
];
tag_type
:
[
[
"_"
->
mk
_loc
(
Internal
(
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
Custom
.
Atm
(
Atoms
.
any
)))))
[
"_"
->
mk
_loc
(
Internal
(
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
`
Atm
(
Atoms
.
any
)))))
|
"$"
;
a
=
ident_or_keyword
->
mk
_loc
(
Cst
(
TVar
a
))
|
a
=
ident_or_keyword
->
mk
_loc
(
Cst
(
Atom
(
ident
a
)))
|
t
=
ANY_IN_NS
->
mk
_loc
(
NsT
(
ident
t
))
...
...
@@ -569,13 +569,13 @@ EXTEND Gram
|
i
=
STRING1
;
"--"
;
j
=
STRING1
->
let
i
=
Chars
.
V
.
mk_int
(
parse_char
_loc
i
)
and
j
=
Chars
.
V
.
mk_int
(
parse_char
_loc
j
)
in
Elem
(
mk
_loc
(
Internal
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
char_class
i
j
))))))
Elem
(
mk
_loc
(
Internal
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
char_class
i
j
))))))
|
s
=
STRING1
->
List
.
fold_right
(
fun
c
accu
->
let
c
=
Chars
.
V
.
mk_int
c
in
let
c
=
Chars
.
atom
c
in
Seq
(
Elem
(
mknoloc
(
Internal
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
c
)))))
,
accu
))
Seq
(
Elem
(
mknoloc
(
Internal
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
c
)))))
,
accu
))
(
seq_of_string
s
)
Epsilon
]
|
[
e
=
pat
LEVEL
"simple"
->
Elem
e
...
...
@@ -619,20 +619,20 @@ EXTEND Gram
|
i
=
INT
;
"--"
;
j
=
INT
->
let
i
=
Intervals
.
V
.
mk
i
and
j
=
Intervals
.
V
.
mk
j
in
mk
_loc
(
Internal
(
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
Custom
.
Atm
(
Intervals
.
bounded
i
j
)))))
mk
_loc
(
Internal
(
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
`
Atm
(
Intervals
.
bounded
i
j
)))))
|
i
=
INT
->
let
i
=
Intervals
.
V
.
mk
i
in
mk
_loc
(
Internal
(
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
Custom
.
Atm
(
Intervals
.
atom
i
)))))
mk
_loc
(
Internal
(
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
`
Atm
(
Intervals
.
atom
i
)))))
|
"*"
;
"--"
;
j
=
INT
->
let
j
=
Intervals
.
V
.
mk
j
in
mk
_loc
(
Internal
(
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
Custom
.
Atm
(
Intervals
.
left
j
)))))
mk
_loc
(
Internal
(
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
`
Atm
(
Intervals
.
left
j
)))))
|
i
=
INT
;
"--"
;
"*"
->
let
i
=
Intervals
.
V
.
mk
i
in
mk
_loc
(
Internal
(
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
Custom
.
Atm
(
Intervals
.
right
i
)))))
mk
_loc
(
Internal
(
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
`
Atm
(
Intervals
.
right
i
)))))
|
i
=
char
->
mk
_loc
(
Internal
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
char_class
i
i
)))))
mk
_loc
(
Internal
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
char_class
i
i
)))))
|
i
=
char
;
"--"
;
j
=
char
->
mk
_loc
(
Internal
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
char_class
i
j
)))))
mk
_loc
(
Internal
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
char_class
i
j
)))))
|
"`"
;
c
=
tag_type
->
c
|
"("
;
l
=
LIST1
pat
SEP
","
;
")"
->
multi_prod
_loc
l
|
"["
;
r
=
[
r
=
regexp
->
r
|
->
Epsilon
];
...
...
@@ -657,7 +657,7 @@ EXTEND Gram
(
fun
c
->
mknoloc
(
Internal
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
(
Types
.
BoolChars
.
atom
(
`
Atm
(
(
Chars
.
atom
(
Chars
.
V
.
mk_int
c
))))))))
(
seq_of_string
s
)
in
...
...
schema/schema_builtin.ml
View file @
a2da41f0
...
...
@@ -480,7 +480,7 @@ let int_type (name,min,max) =
|
None
,
None
->
Intervals
.
any
in
ignore
(
primitive
name
(
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
Custom
.
Atm
ival
)))
(
validate_interval
ival
name
))
ignore
(
primitive
name
(
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
`
Atm
ival
)))
(
validate_interval
ival
name
))
let
()
=
List
.
iter
int_type
[
...
...
schema/schema_common.ml
View file @
a2da41f0
...
...
@@ -192,7 +192,7 @@ let simple_union name members =
let
xsi_nil_atom
=
Atoms
.
V
.
mk
(
Schema_xml
.
xsi
,
Utf8
.
mk
"nil"
)
let
xsi_nil_type
=
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
Custom
.
Atm
(
Atoms
.
atom
xsi_nil_atom
)))
let
xsi_nil_type
=
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
`
Atm
(
Atoms
.
atom
xsi_nil_atom
)))
let
xsi_nil_label
=
Ns
.
Label
.
mk
(
Schema_xml
.
xsi
,
Utf8
.
mk
"nil"
)
let
merge_attribute_uses
l
=
...
...
tests/libtest/tests-boolvar.ml
View file @
a2da41f0
...
...
@@ -7,22 +7,28 @@ module type S = sig
val
mk_atm
:
string
->
t
end
module
BoolChars
:
S
=
struct
module
BoolChars
:
S
with
type
s
=
Chars
.
t
=
struct
include
BoolVar
.
Make
(
Chars
)
let
mk_var
s
=
atom
(
Custom
.
Var
s
)
let
mk_atm
c
=
atom
(
Custom
.
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
c
.
[
0
]
)))
let
mk_var
s
=
atom
(
`
Var
s
)
let
mk_atm
c
=
atom
(
`
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
c
.
[
0
]
)))
end
module
BoolAtoms
:
S
with
type
bt
=
Atoms
.
t
=
struct
module
BoolAtoms
:
S
with
type
s
=
Atoms
.
t
=
struct
include
BoolVar
.
Make
(
Atoms
)
let
mk_var
s
=
atom
(
Custom
.
Var
s
)
let
mk_atm
s
=
atom
(
Custom
.
Atm
(
Atoms
.
atom
(
Atoms
.
V
.
mk_ascii
s
)))
let
mk_var
s
=
atom
(
`
Var
s
)
let
mk_atm
s
=
atom
(
`
Atm
(
Atoms
.
atom
(
Atoms
.
V
.
mk_ascii
s
)))
end
module
BoolIntervals
:
S
=
struct
module
BoolIntervals
:
S
with
type
s
=
Intervals
.
t
=
struct
include
BoolVar
.
Make
(
Intervals
)
let
mk_var
s
=
atom
(
Custom
.
Var
s
)
let
mk_atm
s
=
atom
(
Custom
.
Atm
(
Intervals
.
atom
(
Intervals
.
V
.
mk
s
)))
let
mk_var
s
=
atom
(
`Var
s
)
let
mk_atm
s
=
atom
(
`Atm
(
Intervals
.
atom
(
Intervals
.
V
.
mk
s
)))
end
module
BoolVars
:
S
with
type
s
=
BoolVar
.
Vars
.
t
=
struct
include
BoolVar
.
BoolVars
let
mk_var
s
=
atom
(
`Var
s
)
let
mk_atm
s
=
failwith
"AA"
end
module
ExprParser
(
B
:
S
)
=
struct
...
...
@@ -58,6 +64,7 @@ end
module
BCP
=
ExprParser
(
BoolChars
)
module
BAP
=
ExprParser
(
BoolAtoms
)
module
BIP
=
ExprParser
(
BoolIntervals
)
module
BVP
=
ExprParser
(
BoolVars
)
(*
XXX this needs much more infrastructure as in types.ml
...
...
@@ -73,14 +80,59 @@ let atoms_tests = [
"associativity union"
,
BAP
.
os
"(atm foo v atm bar) v atm baz"
,
BAP
.
os
"atm foo v (atm bar v atm baz)"
;
"difference"
,
BAP
.
os
"(atm foo ^ atm bar) v var alpha"
,
BAP
.
os
"var alpha"
;
"difference empty"
,
BAP
.
os
"atm foo ^ atm bar"
,
BAP
.
os
"Empty"
;
"splitvar vars empty"
,
fst
(
BoolAtoms
.
splitvars
(
BAP
.
os
"atm foo"
))
,
BAP
.
os
"Empty"
;
"splitvar atm empty"
,
snd
(
BoolAtoms
.
splitvars
(
BAP
.
os
"var alpha"
))
,
BAP
.
os
"Empty"
;
"splitvar vars 1 "
,
fst
(
BoolAtoms
.
splitvars
(
BAP
.
os
"var alpha v (atm foo ^ var beta) v var gamma"
))
,
BAP
.
os
"var alpha v var gamma"
;
"splitvar atm 1"
,
snd
(
BoolAtoms
.
splitvars
(
BAP
.
os
"var alpha v (atm foo ^ var beta) v var gamma"
))
,
BAP
.
os
"atm foo ^ var beta"
;
"splitvar atm 2"
,
snd
(
BoolAtoms
.
splitvars
(
BAP
.
os
"var alpha v atm foo"
))
,
BAP
.
os
"atm foo"
;
"splitvar vars 2"
,
fst
(
BoolAtoms
.
splitvars
(
BAP
.
os
"var alpha v atm foo"
))
,
BAP
.
os
"var alpha"
;
];;
let
atoms_splitvar_vars
=
"vars splitvar"
>:::
List
.
map
(
fun
(
descr
,
s1
,
s2
)
->
(
Printf
.
sprintf
"test %s"
descr
)
>::
(
fun
_
->
assert_equal
(
BoolVar
.
BoolVars
.
equal
(
s1
:>
BoolVar
.
BoolVars
.
t
)
s2
)
true
)
)
[
"vars empty"
,
fst
(
BoolAtoms
.
extractvars
(
BAP
.
os
"atm foo"
))
,
BVP
.
os
"Empty"
;
"vars 1 "
,
fst
(
BoolAtoms
.
extractvars
(
BAP
.
os
"var alpha v (atm foo ^ var beta) v var gamma"
))
,
BVP
.
os
"var alpha v var gamma"
;
"vars 2"
,
fst
(
BoolAtoms
.
extractvars
(
BAP
.
os
"var alpha v atm foo"
))
,
BVP
.
os
"var alpha"
;
"vars 2"
,
fst
(
BoolAtoms
.
extractvars
(
BAP
.
os
"var alpha v atm foo"
))
,
fst
(
BoolChars
.
extractvars
(
BCP
.
os
"var alpha v atm c"
));
]
;;
let
atoms_splitvar_atm
=
"atoms splitvar"
>:::
List
.
map
(
fun
(
descr
,
s1
,
s2
)
->
(
Printf
.
sprintf
"test %s"
descr
)
>::
(
fun
_
->
assert_equal
(
BoolAtoms
.
equal
s1
s2
)
true
)
)
[
"atm empty"
,
snd
(
BoolAtoms
.
extractvars
(
BAP
.
os
"var alpha"
))
,
BAP
.
os
"Empty"
;
"atm 1"
,
snd
(
BoolAtoms
.
extractvars
(
BAP
.
os
"var alpha v (atm foo ^ var beta) v var gamma"
))
,
BAP
.
os
"atm foo ^ var beta"
;
"atm 2"
,
snd
(
BoolAtoms
.
extractvars
(
BAP
.
os
"var alpha v atm foo"
))
,
BAP
.
os
"atm foo"
;
]
;;
let
splitvar_mixed_union_var
=
"splitvar union"
>:::
List
.
map
(
fun
(
descr
,
s1
,
s2
,
r
)
->
(
Printf
.
sprintf
"test %s"
descr
)
>::
(
fun
_
->
assert_equal
(
BoolVar
.
BoolVars
.
equal
(
BoolVar
.
BoolVars
.
cup
s1
s2
)
r
)
true
)
)
[
"atoms/chars"
,
fst
(
BoolAtoms
.
extractvars
(
BAP
.
os
"atm foo"
))
,
fst
(
BoolChars
.
extractvars
(
BCP
.
os
"var alpha v atm x"
))
,
BVP
.
os
"var alpha"
;
"atoms/chars"
,
fst
(
BoolAtoms
.
extractvars
(
BAP
.
os
"var alpha v atm foo"
))
,
fst
(
BoolChars
.
extractvars
(
BCP
.
os
"var alpha v atm c"
))
,
BVP
.
os
"var alpha"
;
]
;;
let
splitvar_mixed_union_atm
=
"splitvar union"
>:::
List
.
map
(
fun
(
descr
,
s1
,
s2
,
r
)
->
(
Printf
.
sprintf
"test %s"
descr
)
>::
(
fun
_
->
assert_equal
(
BoolAtoms
.
equal
(
BoolAtoms
.
cup
s1
s2
)
r
)
true
)
)
[
"atoms/chars"
,
snd
(
BoolAtoms
.
extractvars
(
BAP
.
os
"atm foo"
))
,
fst
(
BoolChars
.
extractvars
(
BCP
.
os
"var alpha v atm x"
))
,
BAP
.
os
"var alpha v atm foo"
;
]
;;
let
atoms_structure
=
"atoms structure"
>:::
List
.
map
(
fun
(
descr
,
s1
,
s2
)
->
...
...
@@ -115,6 +167,11 @@ let atoms_contains =
let
all
=
"all tests"
>:::
[
atoms_structure
;
atoms_contains
;
atoms_splitvar_atm
;
atoms_splitvar_vars
;
splitvar_mixed_union_atm
;
splitvar_mixed_union_var
]
let
main
()
=
...
...
tests/libtest/tests.ml
View file @
a2da41f0
...
...
@@ -17,7 +17,15 @@ Types.subtype t1 t2 ;;
let
subtype_tests
=
[
"Int"
,
"Any"
,
true
;
"`a | Int"
,
"`a"
,
false
;
"`A | Int"
,
"`A"
,
false
;
"`A | ( 0--* | *--0)"
,
"`A"
,
false
;
"42 | Int"
,
"42"
,
false
;
"Int"
,
"Empty"
,
false
;
"'c' | Int"
,
"1"
,
false
;
"`A | Char"
,
"`A"
,
false
;
"`A | (`A,`B)"
,
"`A"
,
false
;
"`A -> `B | Int"
,
"`A -> `B"
,
false
;
"(`A,`B) | Int"
,
"(`A,`B)"
,
false
;
"Any"
,
"Any"
,
true
;
"Empty"
,
"Empty"
,
true
;
"Empty"
,
"Any"
,
true
;
...
...
@@ -28,17 +36,16 @@ let subtype_tests = [
"1--5"
,
"1--*"
,
true
;
"1--5"
,
"1--5"
,
true
;
"Any -> `a"
,
"Any"
,
true
;
"`a -> `b | Int"
,
"`a -> `b"
,
false
;
"Any -> `A"
,
"Any"
,
true
;
"`
a
-> `
b
"
,
"`
a
-> `
b
"
,
true
;
"`
A
-> `
B
"
,
"`
A
-> `
B
"
,
true
;
"Any -> `a"
,
"Any -> Any"
,
true
;
"`
a
-> `
b
"
,
"Empty -> Any"
,
true
;
"(`
a
-> `
c
) | (`
b
-> `
c
)"
,
"(`
a
& `
b
) -> `
c
"
,
true
;
"(`
a
& `
b
) | (`
a
& `
c
)"
,
"`
a
& (`
b
| `
c
)"
,
true
;
"`
a
& (`
b
| `
c
)"
,
"(`
a
& `
b
) | (`
a
& `
c
)"
,
true
;
"(`
a
,`
b
) | (`
c
,`
d
)"
,
"((`
a
| `
c
) , (`
b
| `
d
))"
,
true
;
"(`
a
, `
b
& `
c
)"
,
"(`
a
,`
b
) & (`
a
,`
c
)"
,
true
;
"`
A
-> `
B
"
,
"Empty -> Any"
,
true
;
"(`
A
-> `
C
) | (`
B
-> `
C
)"
,
"(`
A
& `
B
) -> `
C
"
,
true
;
"(`
A
& `
B
) | (`
A
& `
C
)"
,
"`
A
& (`
B
| `
C
)"
,
true
;
"`
A
& (`
B
| `
C
)"
,
"(`
A
& `
B
) | (`
A
& `
C
)"
,
true
;
"(`
A
,`
B
) | (`
C
,`
D
)"
,
"((`
A
| `
C
) , (`
B
| `
D
))"
,
true
;
"(`
A
, `
B
& `
C
)"
,
"(`
A
,`
B
) & (`
A
,`
C
)"
,
true
;
(*
"mu x . Int -> (Nat , x)" , "mu x . Nat -> (Int , x)", true;
"mu x . (a,x)" , "mu y . (a,y)", true;
...
...
@@ -46,16 +53,21 @@ let subtype_tests = [
"Any"
,
"Int"
,
false
;
"Any"
,
"Empty"
,
false
;
"`
a
-> `
b
"
,
"`
a
"
,
false
;
"Any -> `
a
"
,
"Empty"
,
false
;
"Any -> `
a
"
,
"Any -> Empty"
,
false
;
"`
a
-> `
b
"
,
"`
a
-> `
c
"
,
false
;
"`
A
-> `
B
"
,
"`
A
"
,
false
;
"Any -> `
A
"
,
"Empty"
,
false
;
"Any -> `
A
"
,
"Any -> Empty"
,
false
;
"`
A
-> `
B
"
,
"`
A
-> `
C
"
,
false
;
"Int"
,
"0--*"
,
false
;
"1--5"
,
"1--4"
,
false
;
"Int"
,
"0--*"
,
false
;
"`$X"
,
"Any"
,
true
;
"`$X | Int"
,
"Any"
,
true
;
"Any"
,
"`$X | (Any
\\
`$X)"
,
true
;
"Any"
,
"(42 & `$X) | (Any
\\
(42 & `$X))"
,
true
;
"Any"
,
"(41 & `$X) | (Any
\\
(42 & `$X))"
,
false
;
"Any"
,
"Any
\\
Char"
,
false
;
];;
let
test_subtype
=
...
...
@@ -64,7 +76,7 @@ let test_subtype =
(
Printf
.
sprintf
" %s <: %s "
s1
s2
)
>::
(
fun
_
->
let
t1
=
parse_typ
s1
in
let
t2
=
parse_typ
s2
in
let
result
=
Types
.
subtype
t1
t2
in
let
result
=
Types
.
subtype
t1
t2
in
if
result
<>
expected
then
begin
(* Printf.printf "subtyping error %s <: %s\n" s1 s2; *)
...
...
types/boolVar.ml
View file @
a2da41f0
This diff is collapsed.
Click to expand it.
types/builtin.ml
View file @
a2da41f0
...
...
@@ -13,7 +13,7 @@ let types =
"Empty"
,
Types
.
empty
;
"Any"
,
any
;
"Int"
,
int
;
"Char"
,
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
any
)));
"Char"
,
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
any
)));
"Byte"
,
char_latin1
;
"Atom"
,
atom
;
"Pair"
,
Types
.
Product
.
any
;
...
...
@@ -167,7 +167,7 @@ binary_op_cst ">"
(* I/O *)
register_fun
"char_of_int"
int
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
any
)
)))
int
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
any
)
)))
(
function
|
Value
.
Integer
x
->
(
try
Value
.
Char
(
Chars
.
V
.
mk_int
(
Intervals
.
V
.
get_int
x
))
...
...
@@ -175,7 +175,7 @@ register_fun "char_of_int"
|
_
->
assert
false
);;
register_fun
"int_of_char"
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
any
)
)))
int
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
any
)
)))
int
(
function
|
Value
.
Char
x
->
Value
.
Integer
(
Intervals
.
V
.
from_int
(
Chars
.
V
.
to_int
x
))
...
...
@@ -342,7 +342,7 @@ binary_op_cst "dump_to_file_utf8"
let
intop
f
x
y
=
let
s
=
Types
.
BoolIntervals
.
get
x
in
let
t
=
Types
.
BoolIntervals
.
get
y
in
Types
.
BoolIntervals
.
atom
(
Custom
.
Atm
(
f
s
t
))
Types
.
BoolIntervals
.
atom
(
`
Atm
(
f
s
t
))
;;
binary_op_gen
"+"
...
...
types/builtin_defs.ml
View file @
a2da41f0
open
Encodings
let
pos_int
=
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
Custom
.
Atm
(
Intervals
.
right
(
Intervals
.
V
.
mk
"1"
))))
let
non_neg_int
=
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
Custom
.
Atm
(
Intervals
.
right
(
Intervals
.
V
.
mk
"0"
))))
let
neg_int
=
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
Custom
.
Atm
(
Intervals
.
left
(
Intervals
.
V
.
mk
"-1"
))))
let
non_pos_int
=
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
Custom
.
Atm
(
Intervals
.
left
(
Intervals
.
V
.
mk
"0"
))))
let
pos_int
=
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
`
Atm
(
Intervals
.
right
(
Intervals
.
V
.
mk
"1"
))))
let
non_neg_int
=
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
`
Atm
(
Intervals
.
right
(
Intervals
.
V
.
mk
"0"
))))
let
neg_int
=
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
`
Atm
(
Intervals
.
left
(
Intervals
.
V
.
mk
"-1"
))))
let
non_pos_int
=
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
`
Atm
(
Intervals
.
left
(
Intervals
.
V
.
mk
"0"
))))
let
mk_interval_type
l
r
=
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
Custom
.
Atm
(
Intervals
.
bounded
(
Intervals
.
V
.
mk
l
)
(
Intervals
.
V
.
mk
r
))))
Types
.
interval
(
Types
.
BoolIntervals
.
atom
(
`
Atm
(
Intervals
.
bounded
(
Intervals
.
V
.
mk
l
)
(
Intervals
.
V
.
mk
r
))))
let
long_int
=
mk_interval_type
"-9223372036854775808"
"9223372036854775807"
let
int_int
=
mk_interval_type
"-2147483648"
"2147483647"
let
short_int
=
mk_interval_type
"-32768"
"32767"
...
...
@@ -17,21 +17,21 @@ let byte_int = mk_interval_type "0" "255"
let
non_zero_int
=
Types
.
cup
pos_int
neg_int
let
decimal_intstr
=
Sequence
.
plus
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
char_class
Sequence
.
plus
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
char_class
(
Chars
.
V
.
mk_char
'
0
'
)
(
Chars
.
V
.
mk_char
'
9
'
)
)
)))
let
octal_intstr
=
Sequence
.
plus
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
char_class
Sequence
.
plus
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
char_class
(
Chars
.
V
.
mk_char
'
0
'
)
(
Chars
.
V
.
mk_char
'
7
'
)
)
)))
let
binary_intstr
=
Sequence
.
plus
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
char_class
Sequence
.
plus
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
char_class
(
Chars
.
V
.
mk_char
'
0
'
)
(
Chars
.
V
.
mk_char
'
1
'
)
)
...
...
@@ -40,18 +40,18 @@ let binary_intstr =
let
hex_intstr
=
Sequence
.
plus
(
Types
.
cup
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
char_class
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
char_class
(
Chars
.
V
.
mk_char
'
0
'
)
(
Chars
.
V
.
mk_char
'
9
'
)
)
)))
(
Types
.
cup
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
char_class
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
char_class
(
Chars
.
V
.
mk_char
'
a'
)
(
Chars
.
V
.
mk_char
'
f'
)
)
)))
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
char_class
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
char_class
(
Chars
.
V
.
mk_char
'
A'
)
(
Chars
.
V
.
mk_char
'
F'
)
)
...
...
@@ -62,13 +62,13 @@ let hex_intstr =
let
hex_str
=
Types
.
times
(
Types
.
cons
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
0
'
))))))
(
Types
.
cons
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
0
'
))))))
(
Types
.
cons
(
Types
.
times
(
Types
.
cons
(
Types
.
cup
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
X'
)))))
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
x'
)))))
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
X'
)))))
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
x'
)))))
)
)
(
Types
.
cons
hex_intstr
)
...
...
@@ -77,13 +77,13 @@ let hex_str =
let
oct_str
=
Types
.
times
(
Types
.
cons
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
0
'
))))))
(
Types
.
cons
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
0
'
))))))
(
Types
.
cons
(
Types
.
times
(
Types
.
cons
(
Types
.
cup
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
O'
)))))
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
o'
)))))
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
O'
)))))
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
o'
)))))
)
)
(
Types
.
cons
octal_intstr
)
...
...
@@ -93,13 +93,13 @@ let oct_str =
let
bin_str
=
Types
.
times
(
Types
.
cons
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
0
'
))))))
(
Types
.
cons
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
0
'
))))))
(
Types
.
cons
(
Types
.
times
(
Types
.
cons
(
Types
.
cup
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
B'
)))))
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
b'
)))))
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
B'
)))))
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
b'
)))))
)
)
(
Types
.
cons
binary_intstr
)
...
...
@@ -111,7 +111,7 @@ let pos_intstr =
let
neg_intstr
=
Types
.
times
(
Types
.
cons
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
-
'
))))))
(
Types
.
cons
(
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
atom
(
Chars
.
V
.
mk_char
'
-
'
))))))
(
Types
.
cons
pos_intstr
)
let
intstr
=
Types
.
cup
pos_intstr
neg_intstr
(* [ '-'? '0'--'9'+ ] *)
...
...
@@ -119,8 +119,8 @@ let intstr = Types.cup pos_intstr neg_intstr (* [ '-'? '0'--'9'+ ] *)
let
true
_atom
=
Atoms
.
V
.
mk_ascii
"true"
let
false
_atom
=
Atoms
.
V
.
mk_ascii
"false"
let
true
_type
=
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
Custom
.
Atm
(
Atoms
.
atom
true
_atom
)))
let
false
_type
=
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
Custom
.
Atm
(
Atoms
.
atom
false
_atom
)))
let
true
_type
=
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
`
Atm
(
Atoms
.
atom
true
_atom
)))
let
false
_type
=
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
`
Atm
(
Atoms
.
atom
false
_atom
)))
let
bool
=
Types
.
cup
true
_type
false
_type
let
nil
=
Sequence
.
nil_type
...
...
@@ -128,15 +128,15 @@ let string = Sequence.string
let
char
=
Types
.
Char
.
any
let
any
=
Types
.
any
let
int
=
Types
.
Int
.
any
let
atom
=
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
Custom
.
Atm
Atoms
.
any
))
let
atom
=
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
`
Atm
Atoms
.
any
))
let
char_latin1
=
Types
.
char
(
Types
.
BoolChars
.
atom
(
Custom
.
Atm
(
Chars
.
mk_classes
[
(
0
,
255
)
])))
let
char_latin1
=
Types
.
char
(
Types
.
BoolChars
.
atom
(
`
Atm
(
Chars
.
mk_classes
[
(
0
,
255
)
])))
let
string_latin1
=
Sequence
.
star
char_latin1
let
time_kind
=
List
.
fold_left
(
fun
acc
t
->
Types
.
cup
acc
t
)
Types
.
empty
(
List
.
map
(
fun
s
->
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
Custom
.
Atm
(
Atoms
.
atom
(
Atoms
.
V
.
mk_ascii
s
)))))
(
fun
s
->
Types
.
atom
(
Types
.
BoolAtoms
.
atom
(
`
Atm
(
Atoms
.
atom
(
Atoms
.
V
.