Commit ab86763f authored by johnvg@science.ru.nl's avatar johnvg@science.ru.nl

restrict default instances to instances with at least one type variable...

restrict default instances to instances with at least one type variable argument, only type constructors at the root, and all type variables are used once, fix instance lookup of other instances: search if no instance was found in the instance group
parent 616e33c0
......@@ -30,9 +30,9 @@ check_class_instances_of_module class_n module_n class_instances common_defs tvh
(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
= check_class_instances_of_module (class_n+1) module_n class_instances common_defs tvh error_admin
= (class_instances,tvh,error_admin)
......@@ -48,7 +48,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
......@@ -83,23 +83,23 @@ check_if_other_instances_overlap :: SortedInstances SortedInstances ![Global Ind
check_if_other_instances_overlap normal_instances 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
# instances = add_instances_from_tree normal_instances [] common_defs
# instances = add_instances_from_tree default_instances instances common_defs
# instances = add_instances_from_tree_to_list normal_instances [] common_defs
# instances = add_instances_from_tree_to_list default_instances instances common_defs
# (_,tvh,error_admin) = check_if_instances_overlap other_instances instances common_defs tvh error_admin
= (tvh,error_admin)
add_instances_from_tree :: !SortedInstances ![([Type],Global Int)] !{#CommonDefs} -> [([Type],Global Int)]
add_instances_from_tree (SI_Node instances left right) l common_defs
# l = add_instances_from_tree left l common_defs
add_instances_from_tree_to_list :: !SortedInstances ![([Type],Global Int)] !{#CommonDefs} -> [([Type],Global Int)]
add_instances_from_tree_to_list (SI_Node instances left right) l common_defs
# l = add_instances_from_tree_to_list left l common_defs
# l = add_instances_from_list instances l common_defs
= add_instances_from_tree right l common_defs
= add_instances_from_tree_to_list right l common_defs
where
add_instances_from_list [instance_index=:{glob_module,glob_object}:instances] l common_defs
#! it_types = common_defs.[glob_module].com_instance_defs.[glob_object].ins_type.it_types
= [(it_types,instance_index):add_instances_from_list instances l common_defs]
add_instances_from_list [] l common_defs
= l
add_instances_from_tree SI_Empty l common_defs
add_instances_from_tree_to_list SI_Empty l common_defs
= l
check_if_sorted_instances_overlap :: !SortedInstances !{#CommonDefs} !*TypeVarHeap !*ErrorAdmin -> (!*TypeVarHeap,!*ErrorAdmin)
......@@ -579,18 +579,6 @@ instance_root_types_specified [type:types] common_defs tvh
instance_root_types_specified [] 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]
......@@ -625,21 +613,57 @@ 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_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 _}
# (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 _ :@: _)}
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
-> 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)
......@@ -7,7 +7,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}}
......
......@@ -313,11 +313,17 @@ where
= mapSt (reduce_any_context info) instantiated_context rs_state
find_instance :: [Type] !InstanceTree {#CommonDefs} *TypeHeaps !*Coercions -> *(!Global Int,![TypeContext],!Bool,!*TypeHeaps,!*Coercions)
find_instance co_types (IT_Trees sorted_instances instance_tree) defs type_heaps coercion_env
find_instance co_types (IT_Trees sorted_instances other_instance_tree default_instance_tree) defs type_heaps coercion_env
# (found, instances, type_heaps) = find_instance_group co_types sorted_instances defs type_heaps
| found
= find_root_monomorphic_instance_in_group co_types instances defs type_heaps coercion_env
= find_root_polymorphic_instance co_types instance_tree defs type_heaps coercion_env
# (instance_index,context,uni_ok,type_heaps,coercion_env) = find_instance_in_group co_types instances defs type_heaps coercion_env
| FoundObject instance_index
= (instance_index,context,uni_ok,type_heaps,coercion_env)
= find_instance_in_tree co_types other_instance_tree defs type_heaps coercion_env
# (instance_index,context,uni_ok,type_heaps,coercion_env) = find_instance_in_tree co_types other_instance_tree defs type_heaps coercion_env
| FoundObject instance_index
= (instance_index,context,uni_ok,type_heaps,coercion_env)
= find_instance_in_tree co_types default_instance_tree defs type_heaps coercion_env
find_instance_group :: [Type] !SortedInstances !{#CommonDefs} !*TypeHeaps -> *(!Bool,![Global Int],!*TypeHeaps)
find_instance_group co_types (SI_Node instances=:[this_inst_index=:{glob_object,glob_module}:_] left right) defs type_heaps
......@@ -333,8 +339,8 @@ where
find_instance_group co_types SI_Empty defs type_heaps
= (False, [], type_heaps)
find_root_monomorphic_instance_in_group :: [Type] ![Global Index] {#CommonDefs} *TypeHeaps *Coercions -> *(Global Int,[TypeContext],Bool,*TypeHeaps,*Coercions)
find_root_monomorphic_instance_in_group co_types [this_inst_index=:{glob_object,glob_module}:instances] defs type_heaps coercion_env
find_instance_in_group :: [Type] ![Global Index] {#CommonDefs} *TypeHeaps *Coercions -> *(Global Int,[TypeContext],Bool,*TypeHeaps,*Coercions)
find_instance_in_group co_types [this_inst_index=:{glob_object,glob_module}:instances] defs type_heaps coercion_env
# {ins_type={it_types,it_context}, ins_specials} = defs.[glob_module].com_instance_defs.[glob_object]
(matched, type_heaps) = match defs it_types co_types type_heaps
| matched
......@@ -344,13 +350,13 @@ where
| FoundObject spec_inst
= (spec_inst, [], uni_ok, type_heaps, coercion_env)
= (this_inst_index, subst_context, uni_ok, type_heaps, coercion_env)
= find_root_monomorphic_instance_in_group co_types instances defs type_heaps coercion_env
find_root_monomorphic_instance_in_group co_types [] defs heaps coercion_env
= find_instance_in_group co_types instances defs type_heaps coercion_env
find_instance_in_group co_types [] defs heaps coercion_env
= (ObjectNotFound, [], True, heaps, coercion_env)
find_root_polymorphic_instance :: [Type] !InstanceTree {#CommonDefs} *TypeHeaps *Coercions -> *(Global Int,[TypeContext],Bool,*TypeHeaps,*Coercions)
find_root_polymorphic_instance co_types (IT_Node this_inst_index=:{glob_object,glob_module} left right) defs type_heaps coercion_env
# (left_index, types, uni_ok, type_heaps, coercion_env) = find_root_polymorphic_instance co_types left defs type_heaps coercion_env
find_instance_in_tree :: [Type] !InstanceTree {#CommonDefs} *TypeHeaps *Coercions -> *(Global Int,[TypeContext],Bool,*TypeHeaps,*Coercions)
find_instance_in_tree co_types (IT_Node this_inst_index=:{glob_object,glob_module} left right) defs type_heaps coercion_env
# (left_index, types, uni_ok, type_heaps, coercion_env) = find_instance_in_tree co_types left defs type_heaps coercion_env
| FoundObject left_index
= (left_index, types, uni_ok, type_heaps, coercion_env)
# {ins_type={it_types,it_context}, ins_specials} = defs.[glob_module].com_instance_defs.[glob_object]
......@@ -362,8 +368,8 @@ where
| FoundObject spec_inst
= (spec_inst, [], uni_ok, type_heaps, coercion_env)
= (this_inst_index, subst_context, uni_ok, type_heaps, coercion_env)
= find_root_polymorphic_instance co_types right defs type_heaps coercion_env
find_root_polymorphic_instance co_types IT_Empty defs heaps coercion_env
= find_instance_in_tree co_types right defs type_heaps coercion_env
find_instance_in_tree co_types IT_Empty defs heaps coercion_env
= (ObjectNotFound, [], True, heaps, coercion_env)
get_specials :: Specials -> [Special]
......@@ -701,11 +707,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
......@@ -743,11 +753,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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment