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
49d173b7
Commit
49d173b7
authored
Sep 02, 2014
by
Pietro Abate
Browse files
Fix type substition for parametric types
parent
0d3a9e60
Changes
3
Hide whitespace changes
Inline
Side-by-side
types/types.ml
View file @
49d173b7
...
...
@@ -1008,8 +1008,6 @@ let get_variables main_memo temp_memo t =
(
Var
.
Set
.
union
tvpos
tpos
,
Var
.
Set
.
union
tvneg
tneg
,
Var
.
Set
.
union
tvars
vars
)
in
get_variables
true
Var
.
Set
.(
empty
,
empty
,
empty
)
t
...
...
@@ -2816,6 +2814,17 @@ module Positive = struct
descr
(
solve
new_t
)
end
let
substitute_list
t
l
=
if
no_var
t
then
t
else
begin
let
subst
l
d
=
try
ty
(
snd
(
List
.
find
(
fun
(
alpha
,_
)
->
Var
.
equal
d
alpha
)
l
))
with
Not_found
->
var
d
in
let
new_t
=
(
substitute_aux
Var
.
Set
.
empty
(
decompose
t
)
(
subst
l
))
in
descr
(
solve
new_t
)
end
let
substitutefree
delta
t
=
if
no_var
t
then
t
else
let
h
=
Hashtbl
.
create
17
in
...
...
types/types.mli
View file @
49d173b7
...
...
@@ -165,6 +165,7 @@ module Positive : sig
val
xml
:
v
->
v
->
v
val
substitute
:
t
->
(
Var
.
var
*
t
)
->
t
val
substitute_list
:
t
->
(
Var
.
var
*
t
)
list
->
t
val
substituterec
:
t
->
Var
.
var
->
t
val
solve
:
v
->
Node
.
t
val
substitutefree
:
Var
.
Set
.
t
->
t
->
t
...
...
typing/typer.ml
View file @
49d173b7
...
...
@@ -59,11 +59,9 @@ let pp_env ppf env =
let
pp_item
ppf
(
s
,
t
)
=
match
t
with
|
Val
t
->
Format
.
fprintf
ppf
"val %s : %a"
s
Types
.
Print
.
pp_type
t
|
Type
(
t
,
[
||
])
->
Format
.
fprintf
ppf
"type %s = %a"
s
Types
.
Print
.
pp_noname
t
|
Type
(
t
,
[
|
a
|
])
->
Format
.
fprintf
ppf
"type %s %a = %a"
s
Var
.
pp
a
Types
.
Print
.
pp_noname
t
|
Type
(
t
,
al
)
->
Format
.
fprintf
ppf
"type %s %a = %a"
s
(
Utils
.
pp_list
~
delim
:
(
"
(
"
,
"
)
"
)
Var
.
pp
)
(
Array
.
to_list
al
)
(
Utils
.
pp_list
~
delim
:
(
"
{[
"
,
"
]}
"
)
Var
.
pp
)
(
Array
.
to_list
al
)
Types
.
Print
.
pp_noname
t
|_
->
()
in
...
...
@@ -273,7 +271,8 @@ let type_ns env loc p ns =
let
find_global_type
env
loc
ids
=
match
find_global
env
loc
ids
with
|
Type
(
t
,_
)
|
ESchemaComponent
(
t
,_
)
->
t
|
Type
(
t
,
pargs
)
->
(
t
,
pargs
)
|
ESchemaComponent
(
t
,_
)
->
(
t
,
[
||
])
(* XXX *)
|
_
->
error
loc
"This path does not refer to a type"
let
find_global_schema_component
env
loc
ids
=
...
...
@@ -283,7 +282,7 @@ let find_global_schema_component env loc ids =
let
find_local_type
env
loc
id
=
match
Env
.
find
id
env
.
ids
with
|
Type
(
t
,
_
)
->
t
|
Type
(
t
,
pargs
)
->
(
t
,
pargs
)
|
_
->
raise
Not_found
let
find_value
id
env
=
...
...
@@ -381,16 +380,27 @@ module IType = struct
and
derecurs_var
env
loc
ids
=
match
ids
with
|
([
v
]
,
_
)
->
|
([
v
]
,
a
)
->
let
v
=
ident
env
.
penv_tenv
loc
v
in
begin
try
Env
.
find
v
env
.
penv_derec
with
Not_found
->
try
mk_type
(
find_local_type
env
.
penv_tenv
loc
v
)
try
let
(
t
,
pargs
)
=
find_local_type
env
.
penv_tenv
loc
v
in
let
palen
=
Array
.
length
pargs
in
if
palen
<>
List
.
length
a
then
raise_loc_generic
loc
(
Printf
.
sprintf
"Parametric type %s is not fully qualified"
(
Ident
.
to_string
v
));
let
a
=
Array
.
of_list
a
in
let
l
=
ref
[]
in
for
i
=
0
to
(
Array
.
length
pargs
)
-
1
do
l
:=
(
pargs
.
(
i
)
,
typ
(
derecurs
env
a
.
(
i
)))
::!
l
done
;
mk_type
(
Types
.
Positive
.
substitute_list
t
!
l
)
with
Not_found
->
mk_capture
v
end
|
(
ids
,_
)
->
mk_type
(
find_global_type
env
.
penv_tenv
loc
ids
)
mk_type
(
fst
(
find_global_type
env
.
penv_tenv
loc
ids
)
)
and
derecurs_def
env
b
=
let
seen
=
ref
IdSet
.
empty
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