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
32780738
Commit
32780738
authored
Mar 30, 2015
by
Kim Nguyễn
Browse files
Code refactoring. Move the Tallying code outside of the Types module.
parent
ae31d5c7
Changes
14
Expand all
Hide whitespace changes
Inline
Side-by-side
Makefile.distrib
View file @
32780738
...
...
@@ -167,7 +167,7 @@ OBJECTS = \
\
types/compunit.cmo types/sortedList.cmo types/ident.cmo types/var.cmo types/bool.cmo
\
types/intervals.cmo types/chars.cmo types/atoms.cmo types/normal.cmo
\
types/types.cmo compile/auto_pat.cmo
\
types/types.cmo compile/auto_pat.cmo
types/type_tallying.cmo
\
types/sequence.cmo types/builtin_defs.cmo
\
\
runtime/value.cmo
\
...
...
compile/compile.ml
View file @
32780738
...
...
@@ -75,13 +75,13 @@ let enter_global_cu cu env x =
let
rec
domain
=
function
|
Identity
->
Var
.
Set
.
empty
|
List
l
->
Type
s
.
T
allying
.
domain
l
|
List
l
->
Type
_t
allying
.
domain
l
|
Comp
(
s1
,
s2
)
->
Var
.
Set
.
cup
(
domain
s1
)
(
domain
s2
)
|
Sel
(
_
,_,
sigma
)
->
(
domain
sigma
)
let
rec
codomain
=
function
|
Identity
->
Var
.
Set
.
empty
|
List
(
l
)
->
Type
s
.
T
allying
.
codomain
l
|
List
(
l
)
->
Type
_t
allying
.
codomain
l
|
Comp
(
s1
,
s2
)
->
Var
.
Set
.
cup
(
codomain
s1
)
(
codomain
s2
)
|
Sel
(
_
,_,
sigma
)
->
(
codomain
sigma
)
...
...
compile/lambda.ml
View file @
32780738
...
...
@@ -26,7 +26,7 @@ type iface = (Types.descr * Types.descr) list
type
sigma
=
|
Identity
(* this is basically as Types.Tallying.CS.sat *)
|
List
of
Type
s
.
T
allying
.
CS
.
sl
|
List
of
Type
_t
allying
.
CS
.
sl
|
Comp
of
(
sigma
*
sigma
)
|
Sel
of
(
var_loc
*
iface
*
sigma
)
...
...
@@ -104,7 +104,7 @@ module Print = struct
)
ppf
in
function
|
List
ll
->
Type
s
.
T
allying
.
CS
.
pp_sl
ppf
ll
|
List
ll
->
Type
_t
allying
.
CS
.
pp_sl
ppf
ll
|
Comp
(
s1
,
s2
)
->
Format
.
fprintf
ppf
"Comp(%a,%a)"
pp_sigma
s1
pp_sigma
s2
|
Sel
(
x
,
iface
,
s
)
->
Format
.
fprintf
ppf
"Sel(%a,%a,%a)"
pp_vloc
x
pp_aux
iface
pp_sigma
s
|
Identity
->
Format
.
fprintf
ppf
"Id"
...
...
compile/lambda.mli
View file @
32780738
...
...
@@ -26,7 +26,7 @@ type iface = (Types.t * Types.t) list
type
sigma
=
|
Identity
|
List
of
Type
s
.
T
allying
.
CS
.
sl
|
List
of
Type
_t
allying
.
CS
.
sl
|
Comp
of
(
sigma
*
sigma
)
|
Sel
of
(
var_loc
*
iface
*
sigma
)
...
...
depend
View file @
32780738
...
...
@@ -56,6 +56,12 @@ compile/auto_pat.cmo : types/types.cmi types/ident.cmo types/chars.cmi \
types/atoms.cmi compile/auto_pat.cmi
compile/auto_pat.cmx : types/types.cmx types/ident.cmx types/chars.cmx \
types/atoms.cmx compile/auto_pat.cmi
types/type_tallying.cmo : types/var.cmi misc/utils.cmo types/types.cmi \
types/sortedList.cmi types/intervals.cmi misc/custom.cmo types/chars.cmi \
types/atoms.cmi types/type_tallying.cmi
types/type_tallying.cmx : types/var.cmx misc/utils.cmx types/types.cmx \
types/sortedList.cmx types/intervals.cmx misc/custom.cmx types/chars.cmx \
types/atoms.cmx types/type_tallying.cmi
types/sequence.cmo : types/types.cmi misc/custom.cmo types/chars.cmi \
types/atoms.cmi types/sequence.cmi
types/sequence.cmx : types/types.cmx misc/custom.cmx types/chars.cmx \
...
...
@@ -67,13 +73,13 @@ types/builtin_defs.cmx : types/types.cmx types/sequence.cmx \
types/intervals.cmx types/ident.cmx misc/encodings.cmx types/chars.cmx \
types/atoms.cmx types/builtin_defs.cmi
runtime/value.cmo : types/var.cmi misc/utils.cmo misc/upool.cmi \
types/types.cmi types/
sequence.cmi misc/ns.cmi types/interval
s.cmi \
misc/imap.cmi types/ident.cmo misc/encodings.cmi
types/chars.cmi
\
types/atoms.cmi runtime/value.cmi
types/types.cmi types/
type_tallying.cmi types/sequence.cmi misc/n
s.cmi \
types/intervals.cmi
misc/imap.cmi types/ident.cmo misc/encodings.cmi \
types/chars.cmi
types/atoms.cmi runtime/value.cmi
runtime/value.cmx : types/var.cmx misc/utils.cmx misc/upool.cmx \
types/types.cmx types/
sequence.cmx misc/ns.cmx types/interval
s.cmx \
misc/imap.cmx types/ident.cmx misc/encodings.cmx
types/chars.cmx
\
types/atoms.cmx runtime/value.cmi
types/types.cmx types/
type_tallying.cmx types/sequence.cmx misc/n
s.cmx \
types/intervals.cmx
misc/imap.cmx types/ident.cmx misc/encodings.cmx \
types/chars.cmx
types/atoms.cmx runtime/value.cmi
schema/schema_pcre.cmo : misc/encodings.cmi schema/schema_pcre.cmi
schema/schema_pcre.cmx : misc/encodings.cmx schema/schema_pcre.cmi
schema/schema_types.cmo : runtime/value.cmi misc/ns.cmi misc/encodings.cmi \
...
...
@@ -121,19 +127,21 @@ compile/print_auto.cmo : types/types.cmi types/ident.cmo \
compile/print_auto.cmx : types/types.cmx types/ident.cmx \
compile/auto_pat.cmx compile/print_auto.cmi
compile/lambda.cmo : runtime/value.cmi misc/utils.cmo misc/upool.cmi \
types/types.cmi
schema/schema_validator.cmi misc/ns.cmi misc/imap
.cmi \
types/ident.cmo misc/encodings.cmi
types/compunit.cmi
\
compile/auto_pat.cmi compile/lambda.cmi
types/types.cmi
types/type_tallying.cmi schema/schema_validator
.cmi \
misc/ns.cmi misc/imap.cmi
types/ident.cmo misc/encodings.cmi \
types/compunit.cmi
compile/auto_pat.cmi compile/lambda.cmi
compile/lambda.cmx : runtime/value.cmx misc/utils.cmx misc/upool.cmx \
types/types.cmx
schema/schema_validator.cmx misc/ns.cmx misc/imap
.cmx \
types/ident.cmx misc/encodings.cmx
types/compunit.cmx
\
compile/auto_pat.cmx compile/lambda.cmi
types/types.cmx
types/type_tallying.cmx schema/schema_validator
.cmx \
misc/ns.cmx misc/imap.cmx
types/ident.cmx misc/encodings.cmx \
types/compunit.cmx
compile/auto_pat.cmx compile/lambda.cmi
runtime/run_dispatch.cmo : runtime/value.cmi misc/upool.cmi types/types.cmi \
misc/imap.cmi types/ident.cmo misc/encodings.cmi types/chars.cmi \
compile/auto_pat.cmi types/atoms.cmi runtime/run_dispatch.cmi
types/type_tallying.cmi misc/imap.cmi types/ident.cmo misc/encodings.cmi \
types/chars.cmi compile/auto_pat.cmi types/atoms.cmi \
runtime/run_dispatch.cmi
runtime/run_dispatch.cmx : runtime/value.cmx misc/upool.cmx types/types.cmx \
misc/imap.cmx types/ident.cmx misc/encodings.cmx types/chars.cmx \
compile/auto_pat.cmx types/atoms.cmx runtime/run_dispatch.cmi
types/type_tallying.cmx misc/imap.cmx types/ident.cmx misc/encodings.cmx \
types/chars.cmx compile/auto_pat.cmx types/atoms.cmx \
runtime/run_dispatch.cmi
runtime/explain.cmo : runtime/value.cmi misc/upool.cmi types/types.cmi \
runtime/run_dispatch.cmi misc/imap.cmi types/ident.cmo misc/encodings.cmi \
types/chars.cmi compile/auto_pat.cmi types/atoms.cmi runtime/explain.cmi
...
...
@@ -169,13 +177,15 @@ parser/parser.cmx : types/var.cmx parser/ulexer.cmx types/types.cmx \
misc/encodings.cmx types/chars.cmx parser/cduce_loc.cmx types/atoms.cmx \
parser/ast.cmx parser/parser.cmi
typing/typed.cmo : types/var.cmi misc/utils.cmo misc/upool.cmi \
types/types.cmi schema/schema_validator.cmi types/patterns.cmi \
misc/ns.cmi types/intervals.cmi types/ident.cmo misc/encodings.cmi \
types/compunit.cmi types/chars.cmi parser/cduce_loc.cmi types/atoms.cmi
types/types.cmi types/type_tallying.cmi schema/schema_validator.cmi \
types/patterns.cmi misc/ns.cmi types/intervals.cmi types/ident.cmo \
misc/encodings.cmi types/compunit.cmi types/chars.cmi \
parser/cduce_loc.cmi types/atoms.cmi
typing/typed.cmx : types/var.cmx misc/utils.cmx misc/upool.cmx \
types/types.cmx schema/schema_validator.cmx types/patterns.cmx \
misc/ns.cmx types/intervals.cmx types/ident.cmx misc/encodings.cmx \
types/compunit.cmx types/chars.cmx parser/cduce_loc.cmx types/atoms.cmx
types/types.cmx types/type_tallying.cmx schema/schema_validator.cmx \
types/patterns.cmx misc/ns.cmx types/intervals.cmx types/ident.cmx \
misc/encodings.cmx types/compunit.cmx types/chars.cmx \
parser/cduce_loc.cmx types/atoms.cmx
typing/typepat.cmo : types/types.cmi types/sequence.cmi types/patterns.cmi \
types/ident.cmo misc/encodings.cmi types/chars.cmi typing/typepat.cmi
typing/typepat.cmx : types/types.cmx types/sequence.cmx types/patterns.cmx \
...
...
@@ -183,26 +193,26 @@ typing/typepat.cmx : types/types.cmx types/sequence.cmx types/patterns.cmx \
types/externals.cmo : parser/cduce_loc.cmi types/externals.cmi
types/externals.cmx : parser/cduce_loc.cmx types/externals.cmi
typing/typer.cmo : types/var.cmi misc/utils.cmo types/types.cmi \
typing/typepat.cmi typing/typed.cmo types/
sequence
.cmi \
schema/schema_validator.cmi types/patterns.cmi
misc/ns.cmi
\
types/ident.cmo types/externals.cmi types/compunit.cmi
types/chars.cmi
\
parser/cduce_loc.cmi types/builtin_defs.cmi
types/atoms.cmi
\
parser/ast.cmo typing/typer.cmi
typing/typepat.cmi typing/typed.cmo types/
type_tallying
.cmi \
types/sequence.cmi
schema/schema_validator.cmi types/patterns.cmi \
misc/ns.cmi
types/ident.cmo types/externals.cmi types/compunit.cmi \
types/chars.cmi
parser/cduce_loc.cmi types/builtin_defs.cmi \
types/atoms.cmi
parser/ast.cmo typing/typer.cmi
typing/typer.cmx : types/var.cmx misc/utils.cmx types/types.cmx \
typing/typepat.cmx typing/typed.cmx types/
sequence
.cmx \
schema/schema_validator.cmx types/patterns.cmx
misc/ns.cmx
\
types/ident.cmx types/externals.cmx types/compunit.cmx
types/chars.cmx
\
parser/cduce_loc.cmx types/builtin_defs.cmx
types/atoms.cmx
\
parser/ast.cmx typing/typer.cmi
typing/typepat.cmx typing/typed.cmx types/
type_tallying
.cmx \
types/sequence.cmx
schema/schema_validator.cmx types/patterns.cmx \
misc/ns.cmx
types/ident.cmx types/externals.cmx types/compunit.cmx \
types/chars.cmx
parser/cduce_loc.cmx types/builtin_defs.cmx \
types/atoms.cmx
parser/ast.cmx typing/typer.cmi
compile/compile.cmo : types/var.cmi runtime/value.cmi misc/upool.cmi \
types/types.cmi typing/typer.cmi typing/typed.cmo types/
patterns
.cmi \
misc/ns.cmi compile/lambda.cmi misc/imap.cmi
types/ident.cmo
\
runtime/eval.cmi types/compunit.cmi parser/cduce_loc.cmi \
types/types.cmi typing/typer.cmi typing/typed.cmo types/
type_tallying
.cmi \
types/patterns.cmi
misc/ns.cmi compile/lambda.cmi misc/imap.cmi \
types/ident.cmo
runtime/eval.cmi types/compunit.cmi parser/cduce_loc.cmi \
compile/auto_pat.cmi parser/ast.cmo compile/compile.cmi
compile/compile.cmx : types/var.cmx runtime/value.cmx misc/upool.cmx \
types/types.cmx typing/typer.cmx typing/typed.cmx types/
patterns
.cmx \
misc/ns.cmx compile/lambda.cmx misc/imap.cmx
types/ident.cmx
\
runtime/eval.cmx types/compunit.cmx parser/cduce_loc.cmx \
types/types.cmx typing/typer.cmx typing/typed.cmx types/
type_tallying
.cmx \
types/patterns.cmx
misc/ns.cmx compile/lambda.cmx misc/imap.cmx \
types/ident.cmx
runtime/eval.cmx types/compunit.cmx parser/cduce_loc.cmx \
compile/auto_pat.cmx parser/ast.cmx compile/compile.cmi
schema/schema_parser.cmo : parser/url.cmi schema/schema_xml.cmi \
schema/schema_validator.cmi schema/schema_types.cmi \
...
...
@@ -290,9 +300,9 @@ query/query_aggregates.cmo : runtime/value.cmi types/sequence.cmi \
compile/operators.cmi types/intervals.cmi types/builtin_defs.cmi
query/query_aggregates.cmx : runtime/value.cmx types/sequence.cmx \
compile/operators.cmx types/intervals.cmx types/builtin_defs.cmx
parser/cduce_
netclient
.cmo : runtime/value.cmi parser/url.cmi \
parser/cduce_
curl
.cmo : runtime/value.cmi parser/url.cmi \
driver/cduce_config.cmi
parser/cduce_
netclient
.cmx : runtime/value.cmx parser/url.cmx \
parser/cduce_
curl
.cmx : runtime/value.cmx parser/url.cmx \
driver/cduce_config.cmx
runtime/cduce_pxp.cmo : runtime/value.cmi parser/url.cmi \
schema/schema_xml.cmi runtime/load_xml.cmi driver/cduce_config.cmi \
...
...
@@ -376,11 +386,12 @@ types/types.cmi : types/var.cmi misc/ns.cmi types/intervals.cmi \
types/atoms.cmi
compile/auto_pat.cmi : types/types.cmi types/ident.cmo types/chars.cmi \
types/atoms.cmi
types/type_tallying.cmi : types/var.cmi types/types.cmi
types/sequence.cmi : types/types.cmi types/atoms.cmi
types/builtin_defs.cmi : types/types.cmi types/ident.cmo types/atoms.cmi
runtime/value.cmi : types/types.cmi
misc/ns.cmi types/interval
s.cmi \
misc/imap.cmi types/ident.cmo misc/encodings.cmi
types/chars.cmi
\
types/atoms.cmi
runtime/value.cmi : types/types.cmi
types/type_tallying.cmi misc/n
s.cmi \
types/intervals.cmi
misc/imap.cmi types/ident.cmo misc/encodings.cmi \
types/chars.cmi
types/atoms.cmi
schema/schema_pcre.cmi : misc/encodings.cmi
schema/schema_types.cmi : runtime/value.cmi misc/ns.cmi misc/encodings.cmi \
types/atoms.cmi
...
...
@@ -396,8 +407,8 @@ types/patterns.cmi : types/types.cmi types/ident.cmo misc/custom.cmo \
compile/auto_pat.cmi
compile/print_auto.cmi : compile/auto_pat.cmi
compile/lambda.cmi : runtime/value.cmi types/types.cmi \
schema/schema_validator.cmi misc/ns.cmi
misc/imap.cmi types/ident.cmo
\
types/compunit.cmi compile/auto_pat.cmi
types/type_tallying.cmi
schema/schema_validator.cmi misc/ns.cmi \
misc/imap.cmi types/ident.cmo
types/compunit.cmi compile/auto_pat.cmi
runtime/run_dispatch.cmi : runtime/value.cmi compile/auto_pat.cmi
runtime/explain.cmi : runtime/value.cmi compile/auto_pat.cmi
runtime/eval.cmi : runtime/value.cmi misc/ns.cmi compile/lambda.cmi \
...
...
runtime/run_dispatch.ml
View file @
32780738
...
...
@@ -201,7 +201,7 @@ let rec eval_sigma env =
List
.
fold_left
(
fun
acc
sigma_j
->
let
exists_sub
=
List
.
exists
(
fun
(
_
,
s_i
)
->
inzero
env
env
.
(
x
)
(
Type
s
.
T
allying
.(
s_i
>>
sigma_j
))
inzero
env
env
.
(
x
)
(
Type
_t
allying
.(
s_i
>>
sigma_j
))
)
iface
in
if
exists_sub
then
sigma_j
::
acc
else
acc
...
...
@@ -219,7 +219,7 @@ and inzero env v t =
|
Abstraction
(
Some
iface
,_,
sigma
)
->
let
s
=
List
.
fold_left
(
fun
acc
t
->
Types
.
cap
acc
(
snd
t
))
Types
.
any
iface
in
List
.
for_all
(
fun
si
->
Types
.
subtype
(
Type
s
.
T
allying
.(
s
>>
si
))
t
Types
.
subtype
(
Type
_t
allying
.(
s
>>
si
))
t
)
(
eval_sigma
env
sigma
)
|
_
->
true
...
...
runtime/value.ml
View file @
32780738
...
...
@@ -3,7 +3,7 @@ open Encodings
type
iface
=
(
Types
.
t
*
Types
.
t
)
list
type
sigma
=
|
List
of
Type
s
.
T
allying
.
CS
.
sl
|
List
of
Type
_t
allying
.
CS
.
sl
|
Comp
of
(
sigma
*
sigma
)
|
Sel
of
(
int
*
iface
*
sigma
)
|
Identity
...
...
@@ -26,13 +26,13 @@ and t =
let
rec
domain
=
function
|
Identity
|
Mono
->
Var
.
Set
.
empty
|
List
(
l
)
->
Type
s
.
T
allying
.
domain
l
|
List
(
l
)
->
Type
_t
allying
.
domain
l
|
Comp
(
s1
,
s2
)
->
Var
.
Set
.
cup
(
domain
s1
)
(
domain
s2
)
|
Sel
(
_
,_,
sigma
)
->
(
domain
sigma
)
let
rec
codomain
=
function
|
Identity
|
Mono
->
Var
.
Set
.
empty
|
List
(
l
)
->
Type
s
.
T
allying
.
codomain
l
|
List
(
l
)
->
Type
_t
allying
.
codomain
l
|
Comp
(
s1
,
s2
)
->
Var
.
Set
.
cup
(
codomain
s1
)
(
codomain
s2
)
|
Sel
(
_
,_,
sigma
)
->
(
codomain
sigma
)
...
...
@@ -313,7 +313,7 @@ module Print = struct
)
ppf
in
function
|
List
ll
->
Type
s
.
T
allying
.
CS
.
pp_sl
ppf
ll
|
List
ll
->
Type
_t
allying
.
CS
.
pp_sl
ppf
ll
|
Comp
(
s1
,
s2
)
->
Format
.
fprintf
ppf
"Comp(%a,%a)"
pp_sigma
s1
pp_sigma
s2
|
Sel
(
x
,
iface
,
s
)
->
Format
.
fprintf
ppf
"Sel(%d,%a,%a)"
x
pp_aux
iface
pp_sigma
s
|
Identity
->
Format
.
fprintf
ppf
"Id"
...
...
@@ -506,7 +506,7 @@ let rec compare_sigma x y =
| List(sl1), List(sl2) ->
if List.for_all2 (fun v1 v2 ->
Type
s.T
allying.E.comparea v1 v2 ) sl1 sl2 = 0 then 0
Type
_t
allying.E.comparea v1 v2 ) sl1 sl2 = 0 then 0
else (List.length sl1) - (List.length sl2)
| Sel(t1,if1,s1), Sel(t2,if2,s2) ->
...
...
runtime/value.mli
View file @
32780738
...
...
@@ -3,7 +3,7 @@ open Encodings
type
iface
=
(
Types
.
t
*
Types
.
t
)
list
type
sigma
=
|
List
of
Type
s
.
T
allying
.
CS
.
sl
|
List
of
Type
_t
allying
.
CS
.
sl
|
Comp
of
(
sigma
*
sigma
)
|
Sel
of
(
int
*
iface
*
sigma
)
|
Identity
...
...
types/type_tallying.ml
0 → 100644
View file @
32780738
This diff is collapsed.
Click to expand it.
types/type_tallying.mli
0 → 100644
View file @
32780738
open
Types
type
constr
=
|
Pos
of
(
Var
.
var
*
t
)
(** alpha <= t | alpha \in P *)
|
Neg
of
(
t
*
Var
.
var
)
(** t <= alpha | alpha \in N *)
exception
UnSatConstr
of
string
exception
Step1Fail
exception
Step2Fail
module
CS
:
sig
module
M
:
sig
type
key
=
Var
.
var
type
t
val
compare
:
t
->
t
->
int
val
empty
:
t
val
add
:
Var
.
Set
.
t
->
key
->
descr
*
descr
->
t
->
t
val
singleton
:
key
->
descr
*
descr
->
t
val
pp
:
Format
.
formatter
->
t
->
unit
val
inter
:
Var
.
Set
.
t
->
t
->
t
->
t
end
module
E
:
sig
include
Map
.
S
with
type
key
=
Var
.
var
val
pp
:
Format
.
formatter
->
descr
t
->
unit
end
module
ES
:
sig
include
Set
.
S
with
type
elt
=
descr
E
.
t
val
pp
:
Format
.
formatter
->
t
->
unit
end
module
S
:
sig
type
t
=
M
.
t
list
val
empty
:
t
val
add
:
M
.
t
->
t
->
t
val
singleton
:
M
.
t
->
t
val
union
:
t
->
t
->
t
val
elements
:
t
->
M
.
t
list
val
fold
:
(
M
.
t
->
'
b
->
'
b
)
->
M
.
t
list
->
'
b
->
'
b
val
pp
:
Format
.
formatter
->
t
->
unit
end
type
s
=
S
.
t
type
m
=
M
.
t
type
es
=
ES
.
t
type
sigma
=
t
E
.
t
type
sl
=
sigma
list
val
pp_s
:
Format
.
formatter
->
s
->
unit
val
pp_m
:
Format
.
formatter
->
m
->
unit
val
pp_e
:
Format
.
formatter
->
sigma
->
unit
val
pp_sl
:
Format
.
formatter
->
sl
->
unit
(* val merge : m -> m -> m *)
val
singleton
:
constr
->
s
val
sat
:
s
val
unsat
:
s
val
union
:
s
->
s
->
s
val
prod
:
Var
.
Set
.
t
->
s
->
s
->
s
end
val
norm
:
Var
.
Set
.
t
->
t
->
CS
.
s
val
merge
:
Var
.
Set
.
t
->
CS
.
m
->
CS
.
s
val
solve
:
Var
.
Set
.
t
->
CS
.
s
->
CS
.
es
val
unify
:
CS
.
sigma
->
CS
.
sigma
(* [s1 ... sn] . si is a solution for tallying problem
if si # delta and for all (s,t) in C si @ s < si @ t *)
val
tallying
:
Var
.
Set
.
t
->
(
t
*
t
)
list
->
CS
.
sl
val
(
>>
)
:
t
->
CS
.
sigma
->
t
(** Symbolic Substitution Set *)
type
symsubst
=
|
I
(** Identity *)
|
S
of
CS
.
sigma
(** Substitution *)
|
A
of
(
symsubst
*
symsubst
)
(** Composition si (sj t) *)
(** Cartesian Product of two symbolic substitution sets *)
val
(
++
)
:
symsubst
list
->
symsubst
list
->
symsubst
list
(** Evaluation of a substitution *)
val
(
@@
)
:
t
->
symsubst
->
t
val
domain
:
CS
.
sl
->
Var
.
Set
.
t
val
codomain
:
CS
.
sl
->
Var
.
Set
.
t
val
is_identity
:
CS
.
sl
->
bool
val
identity
:
CS
.
sl
val
filter
:
(
Var
.
t
->
bool
)
->
CS
.
sl
->
CS
.
sl
(** Square Subtype relation. [squaresubtype delta s t] .
True if there exists a substitution such that s < t only
considering variables that are not in delta *)
val
squaresubtype
:
Var
.
Set
.
t
->
t
->
t
->
CS
.
sl
val
is_squaresubtype
:
Var
.
Set
.
t
->
t
->
t
->
bool
(** apply_raw s t returns the 4-tuple (subst,ss, tt, res) where
subst is the set of substitution that make the application succeed,
ss and tt are the expansions of s and t corresponding to that substitution
and res is the type of the result of the application *)
val
apply_full
:
Var
.
Set
.
t
->
t
->
t
->
t
val
apply_raw
:
Var
.
Set
.
t
->
t
->
t
->
CS
.
sl
*
t
*
t
*
t
val
squareapply
:
Var
.
Set
.
t
->
t
->
t
->
(
CS
.
sl
*
t
)
types/types.ml
View file @
32780738
...
...
@@ -397,7 +397,7 @@ and VarRec : VarTypeSig with module Atom = Rec
end
module
type
VarType
=
VarTypeSig
with
type
descr
=
Descr
.
t
type
var_type
=
(
module
VarType
)
module
DescrHash
=
Hashtbl
.
Make
(
Descr
)
module
DescrMap
=
Map
.
Make
(
Descr
)
...
...
types/types.mli
View file @
32780738
...
...
@@ -69,20 +69,43 @@ end
(** Algebra **)
module
VarAtoms
:
Bool
.
V
with
type
Atom
.
t
=
Atoms
.
t
module
VarIntervals
:
Bool
.
V
with
type
Atom
.
t
=
Intervals
.
t
module
Descr
:
Custom
.
T
module
VarChars
:
Bool
.
V
with
type
Atom
.
t
=
Chars
.
t
include
Custom
.
T
with
type
t
=
Descr
.
t
module
VarAbstracts
:
Bool
.
V
with
type
Atom
.
t
=
Abstracts
.
t
include
Custom
.
T
module
Node
:
Custom
.
T
type
descr
=
t
module
type
VarType
=
sig
include
Bool
.
V
type
descr
=
Descr
.
t
val
inj
:
t
->
descr
val
proj
:
descr
->
t
val
update
:
descr
->
t
->
descr
end
type
var_type
=
(
module
VarType
)
module
VarAtoms
:
VarType
with
type
Atom
.
t
=
Atoms
.
t
module
VarIntervals
:
VarType
with
type
Atom
.
t
=
Intervals
.
t
module
VarChars
:
VarType
with
type
Atom
.
t
=
Chars
.
t
module
VarAbstracts
:
VarType
with
type
Atom
.
t
=
Abstracts
.
t
module
Pair
:
Bool
.
S
with
type
elem
=
Node
.
t
*
Node
.
t
module
Rec
:
Bool
.
S
with
type
elem
=
bool
*
Node
.
t
Ident
.
LabelMap
.
map
module
VarTimes
:
VarType
with
module
Atom
=
Pair
module
VarXml
:
VarType
with
module
Atom
=
Pair
module
VarArrow
:
VarType
with
module
Atom
=
Pair
module
VarRec
:
VarType
with
module
Atom
=
Rec
val
make
:
unit
->
Node
.
t
val
define
:
Node
.
t
->
t
->
unit
...
...
@@ -139,6 +162,15 @@ val rec_of_list: bool -> (bool * Ns.Label.t * t) list -> t
val
empty_closed_record
:
t
val
empty_open_record
:
t
module
Iter
:
sig
val
simplify
:
t
->
t
val
map
:
?
abs
:
(
bool
->
bool
)
->
(
var_type
->
t
->
t
)
->
t
->
t
val
iter
:
?
abs
:
(
bool
->
unit
)
->
(
var_type
->
t
->
unit
)
->
t
->
unit
val
fold
:
?
abs
:
(
bool
->
'
a
->
'
a
)
->
(
var_type
->
t
->
'
a
->
'
a
)
->
t
->
'
a
->
'
a
end
(** Positive systems and least solutions **)
module
Positive
:
sig
...
...
@@ -152,11 +184,18 @@ module Positive : sig
val
solve
:
v
->
Node
.
t
end
module
Variable
:
sig
val
extract
:
t
->
Var
.
var
*
bool
end
module
Substitution
:
sig
val
full
:
t
->
(
Var
.
var
*
t
)
list
->
t
val
single
:
t
->
(
Var
.
var
*
t
)
->
t
val
freshen
:
Var
.
Set
.
t
->
t
->
t
val
hide_vars
:
t
->
t
val
solve_rectype
:
t
->
Var
.
var
->
t
val
kind
:
Var
.
Set
.
t
->
Var
.
kind
->
t
->
t
val
clean_type
:
Var
.
Set
.
t
->
t
->
t
end
...
...
@@ -310,6 +349,13 @@ val subtype : t -> t -> bool
val
disjoint
:
t
->
t
->
bool
val
equiv
:
t
->
t
->
bool
(** intermediary representation for records *)
(*** TODO : SEAL OFF *)
val
get_record
:
Rec
.
t
->
(
Label
.
t
list
*
(
bool
*
t
array
)
*
((
bool
*
t
array
)
list
))
list
(** Tools for compilation of PM **)
val
cond_partition
:
t
->
(
t
*
t
)
list
->
t
list
...
...
@@ -352,112 +398,7 @@ module Cache : sig
type
'
a
cache
val
emp
:
'
a
cache
val
find
:
(
t
->
'
a
)
->
t
->
'
a
cache
->
'
a
cache
*
'
a
val
lookup
:
t
->
'
a
cache
->
'
a
option
val
memo
:
(
t
->
'
a
)
->
(
t
->
'
a
)
end
module
Tallying
:
sig
type
constr
=
|
Pos
of
(
Var
.
var
*
t
)
(** alpha <= t | alpha \in P *)
|
Neg
of
(
t
*
Var
.
var
)
(** t <= alpha | alpha \in N *)
exception
UnSatConstr
of
string
exception
Step1Fail
exception
Step2Fail
module
CS
:
sig
module
M
:
sig
type
key
=
Var
.
var
type
t
val
compare
:
t
->
t
->
int
val
empty
:
t
val
add
:
Var
.
Set
.
t
->
key
->
descr
*
descr
->
t
->
t
val
singleton
:
key
->
descr
*
descr
->
t
val
pp
:
Format
.
formatter
->
t
->
unit
val
inter
:
Var
.
Set
.
t
->
t
->
t
->
t
end
module
E
:
sig
include
Map
.
S
with
type
key
=
Var
.
var
val
pp
:
Format
.
formatter
->
descr
t
->
unit
end
module
ES
:
sig
include
Set
.
S
with
type
elt
=
descr
E
.
t
val
pp
:
Format
.
formatter
->
t
->
unit
end
module
S
:
sig
type
t
=
M
.
t
list
val
empty
:
t
val
add
:
M
.
t
->
t
->
t
val
singleton
:
M
.
t
->
t
val
union
:
t
->
t
->
t
val
elements
:
t
->
M
.
t
list
val
fold
:
(
M
.
t
->
'
b
->
'
b
)
->
M
.
t
list
->
'
b
->
'
b
val
pp
:
Format
.
formatter
->
t
->
unit
end
type
s
=
S
.
t
type
m
=
M
.
t
type
es
=
ES
.
t
type
sigma
=
t
E
.
t
type
sl
=
sigma
list
val
pp_s
:
Format
.
formatter
->
s
->
unit
val
pp_m
:
Format
.
formatter
->
m
->
unit
val
pp_e
:
Format
.
formatter
->
sigma
->
unit
val
pp_sl
:
Format
.
formatter
->
sl
->
unit
(* val merge : m -> m -> m *)
val
singleton
:
constr
->
s
val
sat
:
s
val
unsat
:
s
val
union
:
s
->
s
->
s
val
prod
:
Var
.
Set
.
t
->
s
->
s
->
s
end
val
norm
:
Var
.
Set
.
t
->
t
->
CS
.
s
val
merge
:
Var
.
Set
.
t
->
CS
.
m
->
CS
.
s
val
solve
:
Var
.
Set
.
t
->
CS
.
s
->
CS
.
es
val
unify
:
CS
.
sigma
->
CS
.
sigma
(* [s1 ... sn] . si is a solution for tallying problem
if si # delta and for all (s,t) in C si @ s < si @ t *)
val
tallying
:
Var
.
Set
.
t
->
(
t
*
t
)
list
->
CS
.
sl
val
(
>>
)
:
t
->
CS
.
sigma
->
t
(** Symbolic Substitution Set *)
type
symsubst
=
|
I
(** Identity *)
|
S
of
CS
.
sigma
(** Substitution *)
|
A
of
(
symsubst
*
symsubst
)
(** Composition si (sj t) *)
(** Cartesian Product of two symbolic substitution sets *)
val
(
++
)
:
symsubst
list
->
symsubst
list
->
symsubst
list
(** Evaluation of a substitution *)
val
(
@@
)
:
t
->
symsubst
->
t
val
domain
:
CS
.
sl
->
Var
.
Set
.
t
val
codomain
:
CS
.
sl
->
Var
.
Set
.
t
val
is_identity
:
CS
.
sl
->
bool
val
identity
:
CS
.
sl
val
filter
:
(
Var
.
t
->
bool
)
->
CS
.
sl
->
CS
.
sl
end
(** Square Subtype relation. [squaresubtype delta s t] .
True if there exists a substitution such that s < t only
considering variables that are not in delta *)
val
squaresubtype
:
Var
.
Set
.
t
->
t
->
t
->
Tallying
.
CS
.
sl
val
is_squaresubtype
:
Var
.
Set
.
t
->
t
->
t
->
bool
(** apply_raw s t returns the 4-tuple (subst,ss, tt, res) where
subst is the set of substitution that make the application succeed,
ss and tt are the expansions of s and t corresponding to that substitution
and res is the type of the result of the application *)
val
apply_full
:
Var
.
Set
.
t
->
t
->
t
->
t