Skip to content
GitLab
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
b17ef0fc
Commit
b17ef0fc
authored
Mar 30, 2015
by
Kim Nguyễn
Browse files
Refactor the Var module to use saner names.
parent
d53ca3c7
Changes
9
Expand all
Hide whitespace changes
Inline
Side-by-side
compile/compile.ml
View file @
b17ef0fc
...
...
@@ -16,7 +16,7 @@ let pp_vars ppf vars =
Ident
.
pp_env
pp_item
ppf
vars
let
pp_xi
ppf
xi
=
let
pp_item
ppf
(
s
,
t
)
=
Format
.
fprintf
ppf
"%s : %a"
s
Var
.
Set
.
p
p
t
in
let
pp_item
ppf
(
s
,
t
)
=
Format
.
fprintf
ppf
"%s : %a"
s
Var
.
Set
.
p
rint
t
in
Ident
.
pp_idmap
pp_item
ppf
xi
let
pp_env
ppf
env
=
...
...
types/type_tallying.ml
View file @
b17ef0fc
...
...
@@ -8,8 +8,8 @@ let cap_product any_left any_right l =
(
any_left
,
any_right
)
l
type
constr
=
|
Pos
of
(
Var
.
var
*
Types
.
t
)
(** alpha <= t | alpha \in P *)
|
Neg
of
(
Types
.
t
*
Var
.
var
)
(** t <= alpha | alpha \in N *)
|
Pos
of
(
Var
.
t
*
Types
.
t
)
(** alpha <= t | alpha \in P *)
|
Neg
of
(
Types
.
t
*
Var
.
t
)
(** t <= alpha | alpha \in N *)
exception
UnSatConstr
of
string
...
...
@@ -28,7 +28,7 @@ module CS = struct
module
M
=
struct
module
Key
=
struct
type
t
=
Var
.
var
type
t
=
Var
.
t
let
compare
v1
v2
=
Var
.
compare
v1
v2
end
type
key
=
Key
.
t
...
...
@@ -52,7 +52,7 @@ module CS = struct
let
pp
ppf
map
=
Utils
.
pp_list
~
delim
:
(
"{"
,
"}"
)
(
fun
ppf
(
v
,
(
i
,
s
))
->
Format
.
fprintf
ppf
"%a <= %a <= %a"
Print
.
pp_type
i
Var
.
p
p
v
Print
.
pp_type
s
Format
.
fprintf
ppf
"%a <= %a <= %a"
Print
.
pp_type
i
Var
.
p
rint
v
Print
.
pp_type
s
)
ppf
(
VarMap
.
bindings
map
)
let
compare
map1
map2
=
...
...
@@ -83,13 +83,13 @@ module CS = struct
{ alpha -> ((s v beta) ^ t) } with beta fresh *)
module
E
=
struct
include
Map
.
Make
(
struct
type
t
=
Var
.
var
type
t
=
Var
.
t
let
compare
=
Var
.
compare
end
)
let
pp
ppf
e
=
Utils
.
pp_list
~
delim
:
(
"{"
,
"}"
)
(
fun
ppf
->
fun
(
v
,
t
)
->
Format
.
fprintf
ppf
"%a = %a@,"
Var
.
p
p
v
Print
.
pp_type
t
Format
.
fprintf
ppf
"%a = %a@,"
Var
.
p
rint
v
Print
.
pp_type
t
)
ppf
(
bindings
e
)
end
...
...
@@ -548,7 +548,7 @@ let solve delta s =
let
aux
alpha
(
s
,
t
)
acc
=
(* we cannot solve twice the same variable *)
assert
(
not
(
CS
.
E
.
mem
alpha
acc
));
let
v
=
Var
.
mk
(
Printf
.
sprintf
"#
fr_
%s"
(
Var
.
id
alpha
))
in
let
v
=
Var
.
mk
~
internal
:
true
(
Printf
.
sprintf
"#%s"
(
Var
.
id
ent
alpha
))
in
let
b
=
var
v
in
(* s <= alpha <= t --> alpha = ( s v fresh ) ^ t *)
CS
.
E
.
add
alpha
(
cap
(
cup
s
b
)
t
)
acc
...
...
@@ -581,14 +581,14 @@ let unify e =
if
CS
.
E
.
is_empty
e
then
sol
else
begin
let
(
alpha
,
t
)
=
CS
.
E
.
min_binding
e
in
(* Format.printf "Unify -> %a = %a\n" Var.p
p
alpha Print.pp_type t; *)
(* Format.printf "Unify -> %a = %a\n" Var.p
rint
alpha Print.pp_type t; *)
let
e1
=
CS
.
E
.
remove
alpha
e
in
(* Format.printf "e1 = %a\n" CS.print_e e1; *)
(* remove from E \ { (alpha,t) } every occurrences of alpha
* by mu X . (t{X/alpha}) with X fresh . X is a recursion variale *)
(* solve_rectype remove also all previously introduced fresh variables *)
let
x
=
Substitution
.
solve_rectype
t
alpha
in
(* Format.printf "X = %a %a %a\n" Var.p
p
alpha Print.print x dump t; *)
(* Format.printf "X = %a %a %a\n" Var.p
rint
alpha Print.print x dump t; *)
let
es
=
CS
.
E
.
fold
(
fun
beta
s
acc
->
CS
.
E
.
add
beta
(
Substitution
.
single
s
(
alpha
,
x
))
acc
...
...
types/type_tallying.mli
View file @
b17ef0fc
open
Types
type
constr
=
|
Pos
of
(
Var
.
var
*
t
)
(** alpha <= t | alpha \in P *)
|
Neg
of
(
t
*
Var
.
var
)
(** t <= alpha | alpha \in N *)
|
Pos
of
(
Var
.
t
*
t
)
(** alpha <= t | alpha \in P *)
|
Neg
of
(
t
*
Var
.
t
)
(** t <= alpha | alpha \in N *)
exception
UnSatConstr
of
string
exception
Step1Fail
...
...
@@ -10,7 +10,7 @@ exception Step2Fail
module
CS
:
sig
module
M
:
sig
type
key
=
Var
.
var
type
key
=
Var
.
t
type
t
val
compare
:
t
->
t
->
int
val
empty
:
t
...
...
@@ -20,7 +20,7 @@ module CS : sig
val
inter
:
Var
.
Set
.
t
->
t
->
t
->
t
end
module
E
:
sig
include
Map
.
S
with
type
key
=
Var
.
var
include
Map
.
S
with
type
key
=
Var
.
t
val
pp
:
Format
.
formatter
->
descr
t
->
unit
end
module
ES
:
sig
...
...
types/types.ml
View file @
b17ef0fc
This diff is collapsed.
Click to expand it.
types/types.mli
View file @
b17ef0fc
...
...
@@ -139,7 +139,7 @@ val non_constructed_or_absent : t
type
pair_kind
=
[
`Normal
|
`XML
]
val
var
:
Var
.
var
->
t
val
var
:
Var
.
t
->
t
val
interval
:
Intervals
.
t
->
t
val
atom
:
Atoms
.
t
->
t
val
times
:
Node
.
t
->
Node
.
t
->
t
...
...
@@ -185,16 +185,15 @@ module Positive : sig
end
module
Variable
:
sig
val
extract
:
t
->
Var
.
var
*
bool
val
extract
:
t
->
Var
.
t
*
bool
end
module
Substitution
:
sig
val
full
:
t
->
(
Var
.
var
*
t
)
list
->
t
val
single
:
t
->
(
Var
.
var
*
t
)
->
t
val
full
:
t
->
(
Var
.
t
*
t
)
list
->
t
val
single
:
t
->
(
Var
.
t
*
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
solve_rectype
:
t
->
Var
.
t
->
t
val
clean_type
:
Var
.
Set
.
t
->
t
->
t
end
...
...
@@ -365,7 +364,7 @@ val cond_partition: t -> (t * t) list -> t list
to answer all the questions. *)
module
Print
:
sig
type
gname
=
string
*
Ns
.
QName
.
t
*
(
Var
.
var
*
t
)
list
type
gname
=
string
*
Ns
.
QName
.
t
*
(
Var
.
t
*
t
)
list
val
register_global
:
gname
->
t
->
unit
val
pp_const
:
Format
.
formatter
->
const
->
unit
val
pp_type
:
Format
.
formatter
->
t
->
unit
...
...
types/var.ml
View file @
b17ef0fc
module
V
=
struct
type
t
=
{
id
:
Ident
.
U
.
t
;
fr
:
int
;
kind
:
int
}
type
kind
=
int
let
function_kind
=
1
let
argument_kind
=
2
let
dump
ppf
t
=
Format
.
fprintf
ppf
"%a(%d_%d)"
Ident
.
U
.
print
t
.
id
t
.
fr
t
.
kind
let
compare
x
y
=
Pervasives
.
compare
(
x
.
kind
,
x
.
id
,
x
.
fr
)
(
y
.
kind
,
y
.
id
,
y
.
fr
)
type
kind
=
Source
|
Internal
type
t
=
{
name
:
Ident
.
U
.
t
;
id
:
int
;
kind
:
kind
}
let
print_kind
ppf
k
=
Format
.
fprintf
ppf
"%s"
(
match
k
with
Source
->
"Source"
|
Internal
->
"Internal"
)
let
compare_kind
k1
k2
=
if
k1
==
k2
then
0
else
if
k1
<
k2
then
-
1
else
1
let
dump
ppf
t
=
Format
.
fprintf
ppf
"%a(%d_%a)"
Ident
.
U
.
print
t
.
name
t
.
id
print_kind
t
.
kind
let
compare
x
y
=
let
c
=
compare_kind
x
.
kind
y
.
kind
in
if
c
==
0
then
let
c
=
Pervasives
.
compare
x
.
id
y
.
id
in
if
c
==
0
then
Ident
.
U
.
compare
x
.
name
y
.
name
else
c
else
c
let
equal
x
y
=
x
==
y
||
(
x
.
kind
==
y
.
kind
&&
x
.
fr
==
y
.
fr
&&
Ident
.
U
.
equal
x
.
id
y
.
id
)
let
hash
x
=
Hashtbl
.
hash
(
x
.
id
,
x
.
fr
,
x
.
kind
)
let
check
_
=
()
x
==
y
||
(
x
.
kind
==
y
.
kind
&&
x
.
id
==
y
.
id
&&
Ident
.
U
.
equal
x
.
name
y
.
name
)
let
freshcounter
=
ref
0
let
hash
x
=
Hashtbl
.
hash
(
x
.
id
,
x
.
name
,
x
.
kind
)
let
is_fresh
x
=
x
.
fr
>
0
let
check
x
=
assert
(
x
.
id
>
=
0
)
let
fresh
v
=
{
v
with
fr
=
(
incr
freshcounter
;
!
freshcounter
)
}
let
refresh
v
=
(* according to Alain, a thread safe way to generate a unique ID *)
{
v
with
id
=
Oo
.
id
(
object
end
)
}
let
mk
id
=
{
id
=
Ident
.
U
.
mk
id
;
fr
=
0
;
kind
=
0
;
}
let
mk
?
(
internal
=
false
)
id
=
{
name
=
Ident
.
U
.
mk
id
;
id
=
0
;
kind
=
if
internal
then
Internal
else
Source
;
}
let
is_internal
x
=
x
.
kind
==
Internal
let
id
x
=
Ident
.
U
.
get_str
x
.
id
let
set_kind
k
v
=
{
v
with
kind
=
k
}
let
pp
ppf
x
=
Format
.
fprintf
ppf
"'%a"
Ident
.
U
.
print
x
.
id
let
ident
x
=
Ident
.
U
.
get_str
x
.
name
let
print
ppf
x
=
Format
.
fprintf
ppf
"'%a"
Ident
.
U
.
print
x
.
name
end
include
V
type
var
=
t
module
Set
=
struct
include
SortedList
.
Make
(
V
)
let
dump
ppf
s
=
Utils
.
pp_list
~
sep
:
";"
~
delim
:
(
"{"
,
"}"
)
V
.
dump
ppf
(
get
s
)
let
pp
ppf
s
=
Utils
.
pp_list
~
sep
:
";"
~
delim
:
(
"{"
,
"}"
)
V
.
pp
ppf
(
get
s
)
let
printf
=
pp
Format
.
std_formatter
let
print
ppf
s
=
Utils
.
pp_list
~
sep
:
";"
~
delim
:
(
"{"
,
"}"
)
V
.
print
ppf
(
get
s
)
end
include
V
let
gen
set
=
let
idx
=
ref
0
in
let
rec
freshvar
()
=
let
rec
pretty
i
acc
=
let
ni
,
nm
=
i
/
26
,
i
mod
26
in
let
acc
=
acc
^
(
String
.
make
1
(
Char
.
chr
(
Char
.
code
'
a'
+
nm
)))
in
if
ni
==
0
then
acc
else
pretty
ni
acc
in
let
x
=
mk
(
pretty
!
idx
""
)
in
if
Set
.
mem
set
x
then
(* if the name is taken by a variable in delta, restart *)
(
incr
idx
;
freshvar
()
)
else
x
in
freshvar
()
type
'
a
var_or_atom
=
[
`Atm
of
'
a
|
`Var
of
t
]
module
Make
(
X
:
Custom
.
T
)
=
struct
...
...
@@ -55,3 +93,4 @@ module Make (X : Custom.T) = struct
|
`Atm
x
->
X
.
dump
ppf
x
|
`Var
x
->
V
.
dump
ppf
x
end
types/var.mli
View file @
b17ef0fc
include
Custom
.
T
type
kind
type
var
=
t
val
print
:
Format
.
formatter
->
t
->
unit
val
mk
:
?
internal
:
bool
->
string
->
t
val
ident
:
t
->
string
val
refresh
:
t
->
t
val
function_kind
:
kind
val
argument_kind
:
kind
val
set_kind
:
kind
->
t
->
t
val
pp
:
Format
.
formatter
->
t
->
unit
val
mk
:
string
->
t
val
id
:
t
->
string
val
fresh
:
t
->
t
(*
val is_fresh : t -> bool
val is_internal : t -> bool
*)
module
Set
:
sig
include
SortedList
.
S
with
type
Elem
.
t
=
var
val
p
p
:
Format
.
formatter
->
t
->
unit
include
SortedList
.
S
with
type
Elem
.
t
=
t
val
p
rint
:
Format
.
formatter
->
t
->
unit
val
dump
:
Format
.
formatter
->
t
->
unit
end
val
gen
:
Set
.
t
->
t
type
'
a
var_or_atom
=
[
`Atm
of
'
a
|
`Var
of
t
]
module
Make
(
X
:
Custom
.
T
)
:
Custom
.
T
with
type
t
=
X
.
t
var_or_atom
typing/typed.ml
View file @
b17ef0fc
...
...
@@ -187,7 +187,7 @@ module Print = struct
and
pp_fv
ppf
fv
=
Utils
.
pp_list
pp_v
ppf
(
IdSet
.
get
fv
)
and
pp_vars_poly
ppf
m
=
let
pp_aux
ppf
(
x
,
s
)
=
Format
.
fprintf
ppf
"%a : %a"
Ident
.
print
x
Var
.
Set
.
p
p
s
in
let
pp_aux
ppf
(
x
,
s
)
=
Format
.
fprintf
ppf
"%a : %a"
Ident
.
print
x
Var
.
Set
.
p
rint
s
in
Utils
.
pp_list
~
sep
:
";"
pp_aux
ppf
(
Ident
.
IdMap
.
get
m
)
let
string_of_typed
=
Utils
.
string_of_formatter
pp
...
...
typing/typer.ml
View file @
b17ef0fc
...
...
@@ -54,7 +54,7 @@ let pp_env ppf env =
|
Type
(
t
,
[]
)
->
Format
.
fprintf
ppf
"type %s = %a"
s
Types
.
Print
.
pp_noname
t
|
Type
(
t
,
al
)
->
Format
.
fprintf
ppf
"type %s(%a) = %a"
s
(
Utils
.
pp_list
~
delim
:
(
""
,
""
)
Var
.
p
p
)
al
(
Utils
.
pp_list
~
delim
:
(
""
,
""
)
Var
.
p
rint
)
al
Types
.
Print
.
pp_noname
t
|_
->
()
in
...
...
@@ -72,7 +72,7 @@ let pp_env ppf env =
in
Format
.
printf
"{ids=%a;delta=%a}"
(
Ident
.
pp_env
pp_item
)
ids
Var
.
Set
.
p
p
env
.
delta
Var
.
Set
.
p
rint
env
.
delta
;;
(* Namespaces *)
...
...
@@ -390,7 +390,7 @@ module IType = struct
type
penv
=
{
penv_tenv
:
t
;
penv_derec
:
(
node
*
U
.
t
list
)
Env
.
t
;
penv_var
:
(
string
,
Var
.
var
)
Hashtbl
.
t
;
penv_var
:
(
string
,
Var
.
t
)
Hashtbl
.
t
;
}
let
penv
tenv
=
{
penv_tenv
=
tenv
;
penv_derec
=
Env
.
empty
;
penv_var
=
Hashtbl
.
create
17
}
...
...
@@ -454,7 +454,7 @@ module IType = struct
[]
,
[]
->
true
|
v
::
vll
,
{
descr
=
Internal
(
p
);
_
}
::
pll
->
Types
.
is_var
p
&&
(
U
.
equal
v
(
U
.
mk
(
Var
.(
id
(
Set
.
choose
(
Types
.
all_vars
p
))))))
&&
(
U
.
equal
v
(
U
.
mk
(
Var
.(
id
ent
(
Set
.
choose
(
Types
.
all_vars
p
))))))
&&
comp_var_pat
vll
pll
|
_
->
false
...
...
@@ -619,7 +619,7 @@ module IType = struct
(
Printf
.
sprintf
"Definition of type %s contains unbound type variables"
(
Ident
.
to_string
v
));
let
vars_mapping
=
(* create a sequence 'a -> 'a_0 for all variables *)
List
.
map
(
fun
v
->
let
vv
=
Var
.
mk
(
U
.
to_string
v
)
in
vv
,
Var
.
fresh
vv
)
args
List
.
map
(
fun
v
->
let
vv
=
Var
.
mk
(
U
.
to_string
v
)
in
vv
,
Var
.
re
fresh
vv
)
args
in
let
sub_list
=
List
.
map
(
fun
(
v
,
vt
)
->
v
,
Types
.
var
vt
)
vars_mapping
in
let
t_rhs
=
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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