Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
C
compiler
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
16
Issues
16
List
Boards
Labels
Service Desk
Milestones
Operations
Operations
Incidents
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
clean-compiler-and-rts
compiler
Commits
c814e59a
Commit
c814e59a
authored
Oct 29, 2019
by
johnvg@science.ru.nl
Browse files
Options
Browse Files
Download
Plain Diff
Merge remote-tracking branch 'origin/master' into itask
parents
cf08eba2
ab86763f
Changes
3
Hide whitespace changes
Inline
Side-by-side
Showing
3 changed files
with
124 additions
and
70 deletions
+124
-70
frontend/check_instances.icl
frontend/check_instances.icl
+68
-33
frontend/overloading.dcl
frontend/overloading.dcl
+1
-1
frontend/overloading.icl
frontend/overloading.icl
+55
-36
No files found.
frontend/check_instances.icl
View file @
c814e59a
...
...
@@ -38,9 +38,9 @@ check_class_instances class_n module_n class_instances common_defs tvh error_adm
(
tvh
,
error_admin
)
=
check_if_sorted_instances_overlap
default_instances
common_defs
tvh
error_admin
(
tvh
,
error_admin
)
=
check_if_other_instances_overlap
normal_instances
default_instances
other_instances
common_defs
tvh
error_admin
(
instance_tree
,
error_admin
)
=
add_sorted_instances_to_instance_tree
default
_instances
common_defs
IT_Empty
error_admin
(
instance_tree
,
error_admin
)
=
add_instances_to_instance_tree
other_instances
common_defs
instance_tree
error_admin
class_instances
&
[
module_n
].[
class_n
]
=
IT_Trees
normal_instances
instance_tree
(
other_instance_tree
,
error_admin
)
=
add_instances_to_instance_tree
other
_instances
common_defs
IT_Empty
error_admin
(
default_instance_tree
,
error_admin
)
=
add_sorted_instances_to_instance_tree
default_instances
common_defs
IT_Empty
error_admin
class_instances
&
[
module_n
].[
class_n
]
=
IT_Trees
normal_instances
other_instance_tree
default_
instance_tree
=
(
class_instances
,
tvh
,
error_admin
)
#
(
normal_instances
,
default_instances
,
other_instances
,
tvh
)
...
...
@@ -50,9 +50,9 @@ check_class_instances class_n module_n class_instances common_defs tvh error_adm
(
tvh
,
error_admin
)
=
check_if_other_instances_with_fundeps_overlap
normal_instances
default_instances
other_instances
class_fun_dep_vars
common_defs
tvh
error_admin
(
instance_tree
,
error_admin
)
=
add_sorted_fun_dep_instances_to_instance_tree
default
_instances
class_fun_dep_vars
common_defs
IT_Empty
error_admin
(
instance_tree
,
error_admin
)
=
add_fun_dep_instances_to_instance_tree
other_instances
class_fun_dep_vars
common_defs
instance_tree
error_admin
class_instances
&
[
module_n
].[
class_n
]
=
IT_Trees
normal_instances
instance_tree
(
other_instance_tree
,
error_admin
)
=
add_fun_dep_instances_to_instance_tree
other
_instances
class_fun_dep_vars
common_defs
IT_Empty
error_admin
(
default_instance_tree
,
error_admin
)
=
add_sorted_fun_dep_instances_to_instance_tree
default_instances
class_fun_dep_vars
common_defs
IT_Empty
error_admin
class_instances
&
[
module_n
].[
class_n
]
=
IT_Trees
normal_instances
other_instance_tree
default_
instance_tree
=
(
class_instances
,
tvh
,
error_admin
)
...
...
@@ -67,7 +67,7 @@ classify_and_sort_instances (IT_Node instance_index=:{glob_module,glob_object} l
|
is_normal_instance
#
(
normal_instances
,
tvh
)
=
add_to_sorted_instances
instance_index
it_types
normal_instances
common_defs
tvh
=
classify_and_sort_left_and_right_instances
left
right
normal_instances
default_instances
other_instances
common_defs
tvh
#
(
is_default_instance
,
tvh
)
=
instance_root_types_specified_or_polymorphic
it_types
[]
common_defs
tvh
#
(
is_default_instance
,
tvh
)
=
check_if_default_instance_types
it_types
[]
common_defs
False
tvh
|
is_default_instance
#
(
default_instances
,
tvh
)
=
add_to_sorted_instances
instance_index
it_types
default_instances
common_defs
tvh
=
classify_and_sort_left_and_right_instances
left
right
normal_instances
default_instances
other_instances
common_defs
tvh
...
...
@@ -91,7 +91,7 @@ classify_and_sort_instances_with_fundeps (IT_Node instance_index=:{glob_module,g
|
is_normal_instance
#
(
normal_instances
,
tvh
)
=
add_to_sorted_instances_with_fundeps
instance_index
it_types
normal_instances
class_fun_dep_vars
common_defs
tvh
=
classify_and_sort_left_and_right_instances_with_fundeps
left
right
class_fun_dep_vars
normal_instances
default_instances
other_instances
common_defs
tvh
#
(
is_default_instance
,
tvh
)
=
instance_root_types_specified_or_polymorphic
it_types
[]
common_defs
tvh
#
(
is_default_instance
,
tvh
)
=
check_if_default_instance_with_fun_deps_types
it_types
[]
class_fun_dep_vars
common_defs
False
tvh
|
is_default_instance
#
(
default_instances
,
tvh
)
=
add_to_sorted_instances_with_fundeps
instance_index
it_types
default_instances
class_fun_dep_vars
common_defs
tvh
=
classify_and_sort_left_and_right_instances_with_fundeps
left
right
class_fun_dep_vars
normal_instances
default_instances
other_instances
common_defs
tvh
...
...
@@ -755,18 +755,6 @@ instance_with_fundeps_root_types_specified [type:types] class_fun_dep_vars commo
instance_with_fundeps_root_types_specified
[]
class_fun_dep_vars
common_defs
tvh
=
(
True
,
tvh
)
instance_root_types_specified_or_polymorphic
::
![
Type
]
![
TypeVarInfoPtr
]
!{#
CommonDefs
}
!*
TypeVarHeap
->
(!
Bool
,!*
TypeVarHeap
)
instance_root_types_specified_or_polymorphic
[
type
:
types
]
previous_type_vars
common_defs
tvh
#
(
can_be_compared
,
tvh
)
=
root_type_can_be_compared
type
common_defs
tvh
|
can_be_compared
=
instance_root_types_specified_or_polymorphic
types
previous_type_vars
common_defs
tvh
#
(
is_polymorphic
,
previous_type_vars
,
tvh
)
=
root_type_polymorphic
type
previous_type_vars
common_defs
tvh
|
is_polymorphic
=
instance_root_types_specified_or_polymorphic
types
previous_type_vars
common_defs
tvh
=
(
False
,
tvh
)
instance_root_types_specified_or_polymorphic
[]
previous_type_vars
common_defs
tvh
=
(
True
,
tvh
)
root_type_can_be_compared
::
!
Type
!{#
CommonDefs
}
!*
TypeVarHeap
->
(!
Bool
,!*
TypeVarHeap
)
root_type_can_be_compared
(
TA
{
type_index
={
glob_object
,
glob_module
}}
type_args
)
common_defs
tvh
#!
{
td_rhs
,
td_args
}
=
common_defs
.[
glob_module
].
com_type_defs
.[
glob_object
]
...
...
@@ -801,21 +789,68 @@ type_is_basic_or_function_type TArrow = True
type_is_basic_or_function_type
(
TArrow1
_)
=
True
type_is_basic_or_function_type
_
=
False
root_type_polymorphic
::
!
Type
![
TypeVarInfoPtr
]
!{#
CommonDefs
}
!*
TypeVarHeap
->
(!
Bool
,![
TypeVarInfoPtr
],!*
TypeVarHeap
)
root_type_polymorphic
(
TA
{
type_index
={
glob_object
,
glob_module
}}
type_args
)
previous_type_vars
common_defs
tvh
check_if_default_instance_types
::
![
Type
]
![
TypeVarInfoPtr
]
!{#
CommonDefs
}
!
Bool
!*
TypeVarHeap
->
(!
Bool
,!*
TypeVarHeap
)
check_if_default_instance_types
[
type
:
types
]
previous_type_vars
common_defs
has_root_type_var
tvh
#
(
is_polymorphic
,
previous_type_vars
,
has_root_type_var
,
tvh
)
=
check_if_default_instance_type_arg
type
previous_type_vars
common_defs
has_root_type_var
tvh
|
is_polymorphic
=
check_if_default_instance_types
types
previous_type_vars
common_defs
has_root_type_var
tvh
=
(
False
,
tvh
)
check_if_default_instance_types
[]
previous_type_vars
common_defs
has_root_type_var
tvh
=
(
has_root_type_var
,
tvh
)
check_if_default_instance_with_fun_deps_types
::
![
Type
]
![
TypeVarInfoPtr
]
!
BITVECT
!{#
CommonDefs
}
!
Bool
!*
TypeVarHeap
->
(!
Bool
,!*
TypeVarHeap
)
check_if_default_instance_with_fun_deps_types
[
type
:
types
]
previous_type_vars
class_fun_dep_vars
common_defs
has_root_type_var
tvh
|
class_fun_dep_vars
bitand
1
==
0
#
(
is_polymorphic
,
previous_type_vars
,
has_root_type_var
,
tvh
)
=
check_if_default_instance_type_arg
type
previous_type_vars
common_defs
has_root_type_var
tvh
|
is_polymorphic
=
check_if_default_instance_with_fun_deps_types
types
previous_type_vars
(
class_fun_dep_vars
>>
1
)
common_defs
has_root_type_var
tvh
=
(
False
,
tvh
)
=
check_if_default_instance_with_fun_deps_types
types
previous_type_vars
(
class_fun_dep_vars
>>
1
)
common_defs
has_root_type_var
tvh
check_if_default_instance_with_fun_deps_types
[]
previous_type_vars
class_fun_dep_vars
common_defs
has_root_type_var
tvh
=
(
has_root_type_var
,
tvh
)
check_if_default_instance_type_arg
::
!
Type
![
TypeVarInfoPtr
]
!{#
CommonDefs
}
!
Bool
!*
TypeVarHeap
->
(!
Bool
,[
TypeVarInfoPtr
],!
Bool
,!*
TypeVarHeap
)
check_if_default_instance_type_arg
(
TV
{
tv_info_ptr
})
previous_type_vars
common_defs
has_root_type_var
tvh
|
IsMember
tv_info_ptr
previous_type_vars
=
(
False
,
previous_type_vars
,
has_root_type_var
,
tvh
)
#
has_root_type_var
=
True
=
(
True
,[
tv_info_ptr
:
previous_type_vars
],
has_root_type_var
,
tvh
)
check_if_default_instance_type_arg
(
TA
{
type_index
={
glob_object
,
glob_module
}}
type_args
)
previous_type_vars
common_defs
has_root_type_var
tvh
#!
{
td_rhs
,
td_args
}
=
common_defs
.[
glob_module
].
com_type_defs
.[
glob_object
]
=
case
td_rhs
of
SynType
{
at_type
=
syn_type_rhs
=:
TV
_
}
SynType
{
at_type
=
syn_type_rhs
}
#
(
expanded_type
,
tvh
)
=
substitute_instance_type
td_args
type_args
syn_type_rhs
tvh
->
root_type_polymorphic
expanded_type
previous_type_vars
common_defs
tvh
SynType
{
at_type
=
syn_type_rhs
=:(
CV
_
:@:
_)}
#
(
expanded_type
,
tvh
)
=
substitute_instance_type
td_args
type_args
syn_type_rhs
tvh
->
root_type_polymorphic
expanded_type
previous_type_vars
common_defs
tvh
->
check_if_default_instance_type_arg
expanded_type
previous_type_vars
common_defs
has_root_type_var
tvh
_
->
(
False
,
previous_type_vars
,
tvh
)
root_type_polymorphic
(
TV
{
tv_info_ptr
})
previous_type_vars
common_defs
tvh
->
only_used_once_type_variables
type_args
previous_type_vars
common_defs
has_root_type_var
tvh
check_if_default_instance_type_arg
(
TAS
_
type_args
_)
previous_type_vars
common_defs
has_root_type_var
tvh
=
only_used_once_type_variables
type_args
previous_type_vars
common_defs
has_root_type_var
tvh
check_if_default_instance_type_arg
(
TB
_)
previous_type_vars
common_defs
has_root_type_var
tvh
=
(
True
,
previous_type_vars
,
has_root_type_var
,
tvh
)
check_if_default_instance_type_arg
(
type1
-->
type2
)
previous_type_vars
common_defs
has_root_type_var
tvh
=
only_used_once_type_variables
[
type1
,
type2
]
previous_type_vars
common_defs
has_root_type_var
tvh
check_if_default_instance_type_arg
TArrow
previous_type_vars
common_defs
has_root_type_var
tvh
=
(
True
,
previous_type_vars
,
has_root_type_var
,
tvh
)
check_if_default_instance_type_arg
(
TArrow1
type
)
previous_type_vars
common_defs
has_root_type_var
tvh
=
only_used_once_type_variables
[
type
]
previous_type_vars
common_defs
has_root_type_var
tvh
check_if_default_instance_type_arg
type
previous_type_vars
common_defs
has_root_type_var
tvh
=
(
False
,
previous_type_vars
,
has_root_type_var
,
tvh
)
only_used_once_type_variables
::
![
AType
]
![
TypeVarInfoPtr
]
!{#
CommonDefs
}
!
Bool
!*
TypeVarHeap
->
(!
Bool
,[
TypeVarInfoPtr
],!
Bool
,!*
TypeVarHeap
)
only_used_once_type_variables
[{
at_type
=
TV
{
tv_info_ptr
}}:
type_args
]
previous_type_vars
common_defs
has_root_type_var
tvh
|
IsMember
tv_info_ptr
previous_type_vars
=
(
False
,
previous_type_vars
,
tvh
);
=
(
True
,[
tv_info_ptr
:
previous_type_vars
],
tvh
)
root_type_polymorphic
type
previous_type_vars
common_defs
tvh
=
(
False
,
previous_type_vars
,
tvh
)
=
(
False
,
previous_type_vars
,
has_root_type_var
,
tvh
)
#
previous_type_vars
=
[
tv_info_ptr
:
previous_type_vars
]
=
only_used_once_type_variables
type_args
previous_type_vars
common_defs
has_root_type_var
tvh
only_used_once_type_variables
[
type_arg1
=:{
at_type
=
TA
{
type_index
={
glob_object
,
glob_module
}}
type_args_TA
}:
type_args
]
previous_type_vars
common_defs
has_root_type_var
tvh
#!
{
td_rhs
,
td_args
}
=
common_defs
.[
glob_module
].
com_type_defs
.[
glob_object
]
=
case
td_rhs
of
SynType
{
at_type
=
syn_type_rhs
}
#
(
expanded_type
,
tvh
)
=
substitute_instance_type
td_args
type_args_TA
syn_type_rhs
tvh
->
only_used_once_type_variables
[{
type_arg1
&
at_type
=
expanded_type
}:
type_args
]
previous_type_vars
common_defs
has_root_type_var
tvh
_
->
(
False
,
previous_type_vars
,
has_root_type_var
,
tvh
)
only_used_once_type_variables
[_:_]
previous_type_vars
common_defs
has_root_type_var
tvh
=
(
False
,
previous_type_vars
,
has_root_type_var
,
tvh
)
only_used_once_type_variables
[]
previous_type_vars
common_defs
has_root_type_var
tvh
=
(
True
,
previous_type_vars
,
has_root_type_var
,
tvh
)
frontend/overloading.dcl
View file @
c814e59a
...
...
@@ -8,7 +8,7 @@ from check_instances import ::SortedInstances
::
InstanceTree
=
IT_Node
!(
Global
Index
)
!
InstanceTree
!
InstanceTree
|
IT_Empty
|
IT_Trees
!
SortedInstances
!
InstanceTree
|
IT_Trees
!
SortedInstances
!
InstanceTree
!
InstanceTree
::
ClassInstanceInfo
:==
{#
.{!
.
InstanceTree
}}
...
...
frontend/overloading.icl
View file @
c814e59a
...
...
@@ -1095,11 +1095,15 @@ where
=
find_unboxed_array_instance
element_type
right
defs
predef_symbols
find_unboxed_array_instance
element_type
IT_Empty
defs
predef_symbols
=
(
ObjectNotFound
,
predef_symbols
)
find_unboxed_array_instance
element_type
(
IT_Trees
sorted_instances
instances
)
defs
predef_symbols
find_unboxed_array_instance
element_type
(
IT_Trees
sorted_instances
other_instances
default_
instances
)
defs
predef_symbols
#
(
index
,
predef_symbols
)
=
find_sorted_unboxed_array_instance
element_type
sorted_instances
defs
predef_symbols
|
FoundObject
index
=
(
index
,
predef_symbols
)
=
find_unboxed_array_instance
element_type
instances
defs
predef_symbols
#
(
index
,
predef_symbols
)
=
find_unboxed_array_instance
element_type
other_instances
defs
predef_symbols
|
FoundObject
index
=
(
index
,
predef_symbols
)
=
find_unboxed_array_instance
element_type
default_instances
defs
predef_symbols
where
find_sorted_unboxed_array_instance
element_type
(
SI_Node
instances
left
right
)
defs
predef_symbols
#
(
left_index
,
predef_symbols
)
=
find_sorted_unboxed_array_instance
element_type
left
defs
predef_symbols
...
...
@@ -1137,11 +1141,14 @@ where
=
find_unboxed_list_instance
element_type
right
defs
find_unboxed_list_instance
element_type
IT_Empty
defs
=
ObjectNotFound
find_unboxed_list_instance
element_type
(
IT_Trees
sorted_instances
instances
)
defs
find_unboxed_list_instance
element_type
(
IT_Trees
sorted_instances
other_instances
default_
instances
)
defs
#
index
=
find_sorted_unboxed_list_instance
element_type
sorted_instances
defs
|
FoundObject
index
=
index
=
find_unboxed_list_instance
element_type
instances
defs
#
index
=
find_unboxed_list_instance
element_type
other_instances
defs
|
FoundObject
index
=
index
=
find_unboxed_list_instance
element_type
default_instances
defs
where
find_sorted_unboxed_list_instance
element_type
(
SI_Node
instances
left
right
)
defs
#
left_index
=
find_sorted_unboxed_list_instance
element_type
left
defs
...
...
@@ -1375,11 +1382,17 @@ where
=
mapSt
(
reduceTCorNormalContext
info
rdla
)
ftcs
{
prs_state
&
prs_type_heaps
=
prs_type_heaps
}
find_instance
::
[
Type
]
!
InstanceTree
{#
CommonDefs
}
*
TypeHeaps
!*
Subst
->
*(!
Global
Int
,
![
TypeContext
],
!*
TypeHeaps
,
!*
Subst
)
find_instance
co_types
(
IT_Trees
sorted_instances
instance_tree
)
defs
type_heaps
subst
#
(
found
,
instances
,
type_heaps
,
subst
)
=
find_instance_group
co_types
sorted_instances
defs
type_heaps
subst
find_instance
co_types
(
IT_Trees
sorted_instances
other_instance_tree
default_
instance_tree
)
defs
type_heaps
subst
#
(
found
,
instances
,
type_heaps
,
subst
)
=
find_instance_group
co_types
sorted_instances
defs
type_heaps
subst
|
found
=
find_root_monomorphic_instance_in_group
co_types
instances
defs
type_heaps
subst
=
find_root_polymorphic_instance
co_types
instance_tree
defs
type_heaps
subst
#
(
instance_index
,
context
,
type_heaps
,
subst
)
=
find_instance_in_group
co_types
instances
defs
type_heaps
subst
|
FoundObject
instance_index
=
(
instance_index
,
context
,
type_heaps
,
subst
)
=
find_instance_in_tree
co_types
other_instance_tree
defs
type_heaps
subst
#
(
instance_index
,
context
,
type_heaps
,
subst
)
=
find_instance_in_tree
co_types
other_instance_tree
defs
type_heaps
subst
|
FoundObject
instance_index
=
(
instance_index
,
context
,
type_heaps
,
subst
)
=
find_instance_in_tree
co_types
default_instance_tree
defs
type_heaps
subst
find_instance_group
::
[
Type
]
!
SortedInstances
!{#
CommonDefs
}
!*
TypeHeaps
!*
Subst
->
*(!
Bool
,
![
Global
Int
],
!*
TypeHeaps
,
!*
Subst
)
find_instance_group
co_types
(
SI_Node
instances
=:[
this_inst_index
=:{
glob_object
,
glob_module
}:_]
left
right
)
defs
type_heaps
subst
...
...
@@ -1398,8 +1411,8 @@ where
find_instance_group
co_types
SI_Empty
defs
type_heaps
subst
=
(
False
,
[],
type_heaps
,
subst
)
find_
root_monomorphic_
instance_in_group
::
[
Type
]
![
Global
Index
]
{#
CommonDefs
}
*
TypeHeaps
!*
Subst
->
*(!
Global
Int
,
![
TypeContext
],
!*
TypeHeaps
,
!*
Subst
)
find_
root_monomorphic_
instance_in_group
co_types
[
this_inst_index
=:{
glob_object
,
glob_module
}:
instances
]
defs
type_heaps
subst
find_instance_in_group
::
[
Type
]
![
Global
Index
]
{#
CommonDefs
}
*
TypeHeaps
!*
Subst
->
*(!
Global
Int
,
![
TypeContext
],
!*
TypeHeaps
,
!*
Subst
)
find_instance_in_group
co_types
[
this_inst_index
=:{
glob_object
,
glob_module
}:
instances
]
defs
type_heaps
subst
#
{
ins_type
={
it_vars
,
it_types
,
it_context
},
ins_specials
}
=
defs
.[
glob_module
].
com_instance_defs
.[
glob_object
]
th_vars
=
clear_binding_of_type_vars
it_vars
type_heaps
.
th_vars
substc
=
{
substc_changes
=[#!],
substc_array
=
subst
.
subst_array
,
substc_next_var_n
=
subst
.
subst_next_var_n
}
...
...
@@ -1417,13 +1430,13 @@ where
=
(
spec_inst
,
[],
type_heaps
,
subst
)
=
(
this_inst_index
,
subst_context
,
type_heaps
,
subst
)
#
subst
&
subst_array
=
undo_substitutions
substc
=
find_
root_monomorphic_
instance_in_group
co_types
instances
defs
type_heaps
subst
find_
root_monomorphic_
instance_in_group
co_types
[]
defs
heaps
subst
=
find_instance_in_group
co_types
instances
defs
type_heaps
subst
find_instance_in_group
co_types
[]
defs
heaps
subst
=
(
ObjectNotFound
,
[],
heaps
,
subst
)
find_
root_polymorphic_instanc
e
::
[
Type
]
!
InstanceTree
{#
CommonDefs
}
*
TypeHeaps
!*
Subst
->
*(!
Global
Int
,
![
TypeContext
],
!*
TypeHeaps
,
!*
Subst
)
find_
root_polymorphic_instanc
e
co_types
(
IT_Node
this_inst_index
=:{
glob_object
,
glob_module
}
left
right
)
defs
type_heaps
subst
#
(
left_index
,
inst_contexts
,
type_heaps
,
subst
)
=
find_
root_polymorphic_instanc
e
co_types
left
defs
type_heaps
subst
find_
instance_in_tre
e
::
[
Type
]
!
InstanceTree
{#
CommonDefs
}
*
TypeHeaps
!*
Subst
->
*(!
Global
Int
,
![
TypeContext
],
!*
TypeHeaps
,
!*
Subst
)
find_
instance_in_tre
e
co_types
(
IT_Node
this_inst_index
=:{
glob_object
,
glob_module
}
left
right
)
defs
type_heaps
subst
#
(
left_index
,
inst_contexts
,
type_heaps
,
subst
)
=
find_
instance_in_tre
e
co_types
left
defs
type_heaps
subst
|
FoundObject
left_index
=
(
left_index
,
inst_contexts
,
type_heaps
,
subst
)
#
{
ins_type
={
it_vars
,
it_types
,
it_context
},
ins_specials
}
=
defs
.[
glob_module
].
com_instance_defs
.[
glob_object
]
...
...
@@ -1434,8 +1447,8 @@ where
#
subst
&
subst_array
=
substc
.
substc_array
,
subst_next_var_n
=
substc
.
substc_next_var_n
=
found_instance
substc
.
substc_changes
it_context
ins_specials
this_inst_index
type_heaps
subst
#
subst
&
subst_array
=
undo_substitutions
substc
=
find_
root_polymorphic_instanc
e
co_types
right
defs
type_heaps
subst
find_
root_polymorphic_instanc
e
co_types
IT_Empty
defs
heaps
subst
=
find_
instance_in_tre
e
co_types
right
defs
type_heaps
subst
find_
instance_in_tre
e
co_types
IT_Empty
defs
heaps
subst
=
(
ObjectNotFound
,
[],
heaps
,
subst
)
found_instance
::
![#
Int
!]
![
TypeContext
]
!
Specials
!(
Global
Index
)
!*
TypeHeaps
!*
Subst
->
*(!
Global
Int
,
![
TypeContext
],
!*
TypeHeaps
,
!*
Subst
)
...
...
@@ -1455,11 +1468,17 @@ where
find_fun_dep_instance
::
[
Type
]
!
InstanceTree
BITVECT
{#
CommonDefs
}
*
TypeHeaps
!*
Subst
->
*(!
Global
Int
,
![
TypeContext
],
![(
TypeVarInfoPtr
,
Int
)],
!*
TypeHeaps
,!*
Subst
)
find_fun_dep_instance
co_types
(
IT_Trees
sorted_instances
instance_tree
)
class_fun_dep_vars
defs
type_heaps
subst
#
(
found
,
instances
,
type_heaps
,
subst
)
=
find_fun_dep_instance_group
co_types
sorted_instances
class_fun_dep_vars
defs
type_heaps
subst
find_fun_dep_instance
co_types
(
IT_Trees
sorted_instances
other_instance_tree
default_
instance_tree
)
class_fun_dep_vars
defs
type_heaps
subst
#
(
found
,
instances
,
type_heaps
,
subst
)
=
find_fun_dep_instance_group
co_types
sorted_instances
class_fun_dep_vars
defs
type_heaps
subst
|
found
=
find_root_monomorphic_fun_dep_instance_in_group
co_types
instances
class_fun_dep_vars
defs
type_heaps
subst
=
find_root_polymorphic_fun_dep_instance
co_types
instance_tree
class_fun_dep_vars
defs
type_heaps
subst
#
(
instance_index
,
context
,
new_vars
,
type_heaps
,
subst
)
=
find_fun_dep_instance_in_group
co_types
instances
class_fun_dep_vars
defs
type_heaps
subst
|
FoundObject
instance_index
=
(
instance_index
,
context
,
new_vars
,
type_heaps
,
subst
)
=
find_fun_dep_instance_in_tree
co_types
other_instance_tree
class_fun_dep_vars
defs
type_heaps
subst
#
(
instance_index
,
context
,
new_vars
,
type_heaps
,
subst
)=
find_fun_dep_instance_in_tree
co_types
other_instance_tree
class_fun_dep_vars
defs
type_heaps
subst
|
FoundObject
instance_index
=
(
instance_index
,
context
,
new_vars
,
type_heaps
,
subst
)
=
find_fun_dep_instance_in_tree
co_types
default_instance_tree
class_fun_dep_vars
defs
type_heaps
subst
find_fun_dep_instance_group
::
[
Type
]
!
SortedInstances
!
BITVECT
!{#
CommonDefs
}
!*
TypeHeaps
!*
Subst
->
*(!
Bool
,
![
Global
Int
],
!*
TypeHeaps
,
!*
Subst
)
find_fun_dep_instance_group
co_types
(
SI_Node
instances
=:[
this_inst_index
=:{
glob_object
,
glob_module
}:_]
left
right
)
class_fun_dep_vars
defs
type_heaps
subst
...
...
@@ -1478,9 +1497,9 @@ where
find_fun_dep_instance_group
co_types
SI_Empty
class_fun_dep_vars
defs
type_heaps
subst
=
(
False
,
[],
type_heaps
,
subst
)
find_
root_monomorphic_
fun_dep_instance_in_group
::
[
Type
]
![
Global
Index
]
BITVECT
{#
CommonDefs
}
*
TypeHeaps
!*
Subst
->
*(!
Global
Int
,
![
TypeContext
],
![(
TypeVarInfoPtr
,
Int
)],
!*
TypeHeaps
,!*
Subst
)
find_
root_monomorphic_
fun_dep_instance_in_group
co_types
[
this_inst_index
=:{
glob_object
,
glob_module
}:
instances
]
class_fun_dep_vars
defs
type_heaps
subst
find_fun_dep_instance_in_group
::
[
Type
]
![
Global
Index
]
BITVECT
{#
CommonDefs
}
*
TypeHeaps
!*
Subst
->
*(!
Global
Int
,
![
TypeContext
],
![(
TypeVarInfoPtr
,
Int
)],
!*
TypeHeaps
,!*
Subst
)
find_fun_dep_instance_in_group
co_types
[
this_inst_index
=:{
glob_object
,
glob_module
}:
instances
]
class_fun_dep_vars
defs
type_heaps
subst
#
{
ins_type
={
it_vars
,
it_types
,
it_context
},
ins_specials
}
=
defs
.[
glob_module
].
com_instance_defs
.[
glob_object
]
th_vars
=
clear_binding_of_type_vars
it_vars
type_heaps
.
th_vars
substc
=
{
substc_changes
=[#!],
substc_array
=
subst
.
subst_array
,
substc_next_var_n
=
subst
.
subst_next_var_n
}
...
...
@@ -1493,23 +1512,23 @@ where
(
False
,
substc
)
|
maybe_non_termination
#
subst
&
subst_array
=
undo_substitutions
substc
=
find_
root_monomorphic_
fun_dep_instance_in_group
co_types
instances
class_fun_dep_vars
defs
type_heaps
subst
=
find_fun_dep_instance_in_group
co_types
instances
class_fun_dep_vars
defs
type_heaps
subst
#
(
matched
,
type_heaps
,
substc
)
=
matchListsOfFunDepTypes
defs
it_types
co_types
class_fun_dep_vars
type_heaps
substc
|
not
matched
#
subst
&
subst_array
=
undo_substitutions
substc
=
find_
root_monomorphic_
fun_dep_instance_in_group
co_types
instances
class_fun_dep_vars
defs
type_heaps
subst
=
find_fun_dep_instance_in_group
co_types
instances
class_fun_dep_vars
defs
type_heaps
subst
#
subst
&
subst_array
=
substc
.
substc_array
,
subst_next_var_n
=
substc
.
substc_next_var_n
=
found_fun_dep_instance
substc
.
substc_changes
all_vars_defined
it_vars
it_context
ins_specials
this_inst_index
type_heaps
subst
#
subst
&
subst_array
=
undo_substitutions
substc
=
find_
root_monomorphic_
fun_dep_instance_in_group
co_types
instances
class_fun_dep_vars
defs
type_heaps
subst
find_
root_monomorphic_
fun_dep_instance_in_group
co_types
[]
class_fun_dep_vars
defs
heaps
subst
=
find_fun_dep_instance_in_group
co_types
instances
class_fun_dep_vars
defs
type_heaps
subst
find_fun_dep_instance_in_group
co_types
[]
class_fun_dep_vars
defs
heaps
subst
=
(
ObjectNotFound
,
[],
[],
heaps
,
subst
)
find_
root_polymorphic_fun_dep_instanc
e
::
[
Type
]
!
InstanceTree
BITVECT
{#
CommonDefs
}
*
TypeHeaps
!*
Subst
->
*(!
Global
Int
,
![
TypeContext
],
![(
TypeVarInfoPtr
,
Int
)],
!*
TypeHeaps
,!*
Subst
)
find_
root_polymorphic_fun_dep_instanc
e
co_types
(
IT_Node
this_inst_index
=:{
glob_object
,
glob_module
}
left
right
)
class_fun_dep_vars
defs
type_heaps
subst
#
(
left_index
,
inst_contexts
,
new_vars
,
type_heaps
,
subst
)
=
find_
root_polymorphic_fun_dep_instanc
e
co_types
left
class_fun_dep_vars
defs
type_heaps
subst
find_
fun_dep_instance_in_tre
e
::
[
Type
]
!
InstanceTree
BITVECT
{#
CommonDefs
}
*
TypeHeaps
!*
Subst
->
*(!
Global
Int
,
![
TypeContext
],
![(
TypeVarInfoPtr
,
Int
)],
!*
TypeHeaps
,!*
Subst
)
find_
fun_dep_instance_in_tre
e
co_types
(
IT_Node
this_inst_index
=:{
glob_object
,
glob_module
}
left
right
)
class_fun_dep_vars
defs
type_heaps
subst
#
(
left_index
,
inst_contexts
,
new_vars
,
type_heaps
,
subst
)
=
find_
fun_dep_instance_in_tre
e
co_types
left
class_fun_dep_vars
defs
type_heaps
subst
|
FoundObject
left_index
=
(
left_index
,
inst_contexts
,
new_vars
,
type_heaps
,
subst
)
#
{
ins_type
={
it_vars
,
it_types
,
it_context
},
ins_specials
}
=
defs
.[
glob_module
].
com_instance_defs
.[
glob_object
]
...
...
@@ -1524,17 +1543,17 @@ where
(
False
,
substc
)
|
maybe_non_termination
#
subst
&
subst_array
=
undo_substitutions
substc
=
find_
root_polymorphic_fun_dep_instanc
e
co_types
right
class_fun_dep_vars
defs
type_heaps
subst
=
find_
fun_dep_instance_in_tre
e
co_types
right
class_fun_dep_vars
defs
type_heaps
subst
#
(
matched
,
type_heaps
,
substc
)
=
matchListsOfFunDepTypes
defs
it_types
co_types
class_fun_dep_vars
type_heaps
substc
|
not
matched
#
subst
&
subst_array
=
undo_substitutions
substc
=
find_
root_polymorphic_fun_dep_instanc
e
co_types
right
class_fun_dep_vars
defs
type_heaps
subst
=
find_
fun_dep_instance_in_tre
e
co_types
right
class_fun_dep_vars
defs
type_heaps
subst
#
subst
&
subst_array
=
substc
.
substc_array
,
subst_next_var_n
=
substc
.
substc_next_var_n
=
found_fun_dep_instance
substc
.
substc_changes
all_vars_defined
it_vars
it_context
ins_specials
this_inst_index
type_heaps
subst
#
subst
&
subst_array
=
undo_substitutions
substc
=
find_
root_polymorphic_fun_dep_instanc
e
co_types
right
class_fun_dep_vars
defs
type_heaps
subst
find_
root_polymorphic_fun_dep_instanc
e
co_types
IT_Empty
class_fun_dep_vars
defs
heaps
subst
=
find_
fun_dep_instance_in_tre
e
co_types
right
class_fun_dep_vars
defs
type_heaps
subst
find_
fun_dep_instance_in_tre
e
co_types
IT_Empty
class_fun_dep_vars
defs
heaps
subst
=
(
ObjectNotFound
,
[],
[],
heaps
,
subst
)
found_fun_dep_instance
::
![#
Int
!]
!
Bool
![
TypeVar
]
![
TypeContext
]
!
Specials
!(
Global
Index
)
!*
TypeHeaps
!*
Subst
...
...
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