Commit 36e3637d authored by John van Groningen's avatar John van Groningen

refactor, change type of fields class_args and me_class_vars to ClassArgs

parent 25d47784
......@@ -950,12 +950,11 @@ where
determine_kinds_of_context_class modules {tc_class=TCGeneric {gtc_kind}} infos_and_as
= infos_and_as
bind_kind_vars type_vars kind_ptrs type_var_heap
= fold2St bind_kind_var type_vars kind_ptrs type_var_heap
where
bind_kind_var {tv_info_ptr} kind_info_ptr type_var_heap
= type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr)
bind_kind_vars (ClassArg {tv_info_ptr} type_vars) [kind_info_ptr:kind_ptrs] type_var_heap
= bind_kind_vars type_vars kind_ptrs (writePtr tv_info_ptr (TVI_TypeKind kind_info_ptr) type_var_heap)
bind_kind_vars NoClassArgs [] type_var_heap
= type_var_heap
clear_variables type_vars type_var_heap
= foldSt clear_variable type_vars type_var_heap
where
......@@ -964,7 +963,7 @@ where
determine_kinds_of_members modules members member_defs class_kind_vars (class_infos, as)
= iFoldSt (determine_kind_of_member modules members member_defs class_kind_vars) 0 (size members) (class_infos, as)
determine_kind_of_member modules members member_defs class_kind_vars loc_member_index class_infos_and_as
# glob_member_index = members.[loc_member_index].ds_index
{me_class_vars,me_type={st_vars,st_args,st_result,st_context}} = member_defs.[glob_member_index]
......
......@@ -14,7 +14,7 @@ checkDclMacros :: !Index !Level !Index !Index !*ExpressionInfo !*Heaps !*CheckSt
checkForeignExportedFunctionTypes :: ![ForeignExport] !*ErrorAdmin !*{#FunDef}
-> (!*ErrorAdmin,!*{#FunDef})
determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !*ErrorAdmin
determineTypeOfMemberInstance :: !SymbolType !ClassArgs !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !*ErrorAdmin
-> (!SymbolType, !FunSpecials, !*TypeHeaps,!u: Optional (v:{#DclModule}, w:{#CheckedTypeDef}), !*ErrorAdmin)
arrayFunOffsetToPD_IndexTable :: !w:{# MemberDef} !v:{# PredefinedSymbol} -> (!{# Index}, !x:{#MemberDef}, !v:{#PredefinedSymbol}) , [w<=x]
......
......@@ -51,13 +51,18 @@ checkSpecial mod_index fun_type=:{ft_type} fun_index subst (next_inst_index, spe
= ( { spec_index = { glob_module = mod_index, glob_object = next_inst_index }, spec_types = spec_types, spec_vars = subst.ss_vars, spec_attrs = subst.ss_attrs },
((inc next_inst_index), [{ fun_type & ft_type = ft_type, ft_specials = FSP_FunIndex fun_index, ft_type_ptr = new_info_ptr} : special_types ],
{ heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap }, predef_symbols, error))
where
substitute_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment type_heaps error
where
substitute_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} {ss_environ,ss_vars,ss_attrs,ss_context} type_heaps error
# ss_environ_vars = class_args_of_ss_environ ss_environ
# ss_environ_types = [bind_src\\{bind_src}<-ss_environ]
# (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, _, type_heaps, error)
= instantiateTypes environment st_vars st_attr_vars [st_result : st_args] st_context st_attr_env [] type_heaps error
= instantiateTypes ss_environ_vars {it_types=ss_environ_types,it_vars=ss_vars,it_attr_vars=ss_attrs,it_context=ss_context} st_vars st_attr_vars [st_result : st_args] st_context st_attr_env [] type_heaps error
= ({st & st_vars = st_vars, st_args = st_args, st_result = st_result, st_attr_vars = st_attr_vars,
st_context = st_context, st_attr_env = st_attr_env }, type_heaps, error)
class_args_of_ss_environ [{bind_dst}:envs] = ClassArg bind_dst (class_args_of_ss_environ envs)
class_args_of_ss_environ [] = NoClassArgs
checkDclFunctions :: !Index !Index ![FunType] !v:{#CheckedTypeDef} !x:{#ClassDef} !v:{#.DclModule} !*Heaps !*CheckState
-> (!Index, ![FunType], ![FunType], !v:{#CheckedTypeDef}, !x:{#ClassDef}, !v:{#DclModule}, !*Heaps, !*CheckState)
checkDclFunctions module_index first_inst_index fun_types type_defs class_defs modules heaps cs
......@@ -179,7 +184,7 @@ where
(me_type, type_defs, class_defs, modules, type_heaps, cs)
= checkMemberType module_index me_type type_defs class_defs modules type_heaps cs
(me_default_implementation,cs) = check_generic_default me_default_implementation module_index cs
me_class_vars = [ type_var \\ (TV type_var) <- (hd me_type.st_context).tc_types ]
me_class_vars = tv_list_to_class_args (hd me_type.st_context).tc_types
(me_type_ptr, var_heap) = newPtr VI_Empty var_heap
member_def & me_type=me_type, me_class_vars=me_class_vars, me_type_ptr=me_type_ptr, me_default_implementation=me_default_implementation
= ({member_defs & [member_index] = member_def}, type_defs, class_defs, modules, type_heaps, var_heap, cs)
......@@ -190,6 +195,11 @@ where
has_to_be_checked (Yes ({copied_class_defs}, n_cached_dcl_mods)) {glob_module,glob_object}
= not (glob_module < n_cached_dcl_mods && glob_object < size copied_class_defs && copied_class_defs.[glob_object])
tv_list_to_class_args [TV type_var:tv_list]
= ClassArg type_var (tv_list_to_class_args tv_list)
tv_list_to_class_args []
= NoClassArgs
check_generic_default (DeriveDefault generic_ident _ No) module_index cs
# (generic_index,cs) = get_generic_index generic_ident module_index cs
= (DeriveDefault generic_ident generic_index No,cs)
......@@ -267,18 +277,18 @@ where
check_class_instance :: ClassDef !Index !Index !Index !ClassInstance !u:InstanceSymbols !*TypeHeaps !*CheckState
-> (!ClassInstance, !u:InstanceSymbols, !*TypeHeaps, !*CheckState)
check_class_instance class_def module_index class_index class_mod_index
check_class_instance {class_arity,class_args} module_index class_index class_mod_index
ins=:{ins_class_ident=ins_class_ident=:{ci_ident,ci_arity},ins_type,ins_specials,ins_pos,ins_ident}
is=:{is_class_defs,is_modules} type_heaps cs=:{cs_symbol_table}
| class_def.class_arity == ci_arity
| class_arity == ci_arity
# ins_class_index = {gi_index = class_index, gi_module = class_mod_index}
(ins_type, ins_specials, is_type_defs, is_class_defs, is_modules, type_heaps, cs)
= checkInstanceType module_index ins_class_index ins_class_ident ins_type ins_specials
is.is_type_defs is.is_class_defs is.is_modules type_heaps cs
= checkInstanceType module_index ins_class_index ins_class_ident
ins_type ins_specials is.is_type_defs is.is_class_defs is.is_modules type_heaps cs
is = { is & is_type_defs = is_type_defs, is_class_defs = is_class_defs, is_modules = is_modules }
= ({ins & ins_class_index = ins_class_index, ins_type = ins_type, ins_specials = ins_specials}, is, type_heaps, cs)
# (Ident {id_name}) = ci_ident
# cs = {cs & cs_error = checkError id_name ("wrong arity: expected "+++toString class_def.class_arity+++" found "+++toString ci_arity) cs.cs_error}
# cs & cs_error = checkError id_name ("wrong arity: expected "+++toString class_arity+++" found "+++toString ci_arity) cs.cs_error
= (ins, is, type_heaps, cs)
check_derived_local_functions_in_member :: !Int !Int !Int !DclInstanceMemberTypeAndFunctions !*{#FunDef} !*CheckState
......@@ -504,7 +514,7 @@ where
instance_types = [(ins_member_index, instance_type) : instance_types]
= (instance_types,icl_functions,member_defs,type_defs,modules,var_heap,type_heaps,cs)
make_class_member_instance_type :: InstanceType SymbolType [TypeVar] z:{#CheckedTypeDef} u:{#DclModule} *VarHeap *TypeHeaps *CheckState
make_class_member_instance_type :: InstanceType SymbolType ClassArgs z:{#CheckedTypeDef} u:{#DclModule} *VarHeap *TypeHeaps *CheckState
-> *(!SymbolType,!z:{#CheckedTypeDef},!u:{#DclModule},!*VarHeap,!*TypeHeaps,!*CheckState)
make_class_member_instance_type ins_type me_type me_class_vars type_defs modules var_heap type_heaps cs=:{cs_x={x_main_dcl_module_n}}
# (instance_type, _, type_heaps, Yes (modules, type_defs), cs_error)
......@@ -585,18 +595,18 @@ getMemberDef mem_mod mem_index mod_index member_defs modules
# (dcl_mod,modules) = modules![mem_mod]
= (dcl_mod.dcl_common.com_member_defs.[mem_index], member_defs, modules)
instantiateTypes :: !SpecialSubstitution
instantiateTypes :: !ClassArgs !InstanceType
![TypeVar] ![AttributeVar] ![AType] ![TypeContext] ![AttrInequality] ![SpecialSubstitution] !*TypeHeaps !*ErrorAdmin
-> (![TypeVar],![AttributeVar],![AType],![TypeContext],![AttrInequality],![SpecialSubstitution],!*TypeHeaps,!*ErrorAdmin)
instantiateTypes {ss_environ, ss_vars, ss_attrs, ss_context}
instantiateTypes class_vars {it_types,it_vars,it_attr_vars,it_context}
old_type_vars old_attr_vars types type_contexts attr_env special_subst_list type_heaps=:{th_vars, th_attrs} error
# th_vars = clear_vars old_type_vars th_vars
(new_type_vars, th_vars) = foldSt build_var_subst ss_vars ([], th_vars)
(new_attr_vars, th_attrs) = foldSt build_attr_var_subst ss_attrs ([], th_attrs)
(new_type_vars, th_vars) = foldSt build_var_subst it_vars ([], th_vars)
(new_attr_vars, th_attrs) = foldSt build_attr_var_subst it_attr_vars ([], th_attrs)
(erroneous_types,type_heaps) = foldSt build_type_subst ss_environ ([],{type_heaps & th_vars = th_vars, th_attrs = th_attrs})
(_, new_ss_context, erroneous_types, type_heaps) = substitute_special ss_context erroneous_types type_heaps
(erroneous_types,type_heaps,error) = build_type_substs class_vars it_types [] {type_heaps & th_vars = th_vars, th_attrs = th_attrs} error
(_, new_ss_context, erroneous_types, type_heaps) = substitute_special it_context erroneous_types type_heaps
(inst_vars, th_vars) = foldSt determine_free_var old_type_vars (new_type_vars, type_heaps.th_vars)
(inst_attr_vars, th_attrs) = foldSt build_attr_var_subst old_attr_vars (new_attr_vars, type_heaps.th_attrs)
......@@ -619,7 +629,7 @@ where
_
-> (free_vars, type_var_heap)
build_type_subst {bind_src,bind_dst} (erroneous_types,type_heaps)
build_type_substs (ClassArg bind_dst type_vars) [bind_src:types] erroneous_types type_heaps error
# (_, bind_src, erroneous_types, type_heaps) = substitute_special bind_src erroneous_types type_heaps
/*
FIXME: this is a patch for the following incorrect function type (in a dcl module)
......@@ -632,9 +642,11 @@ where
phase. Probably it's a better solution to change the order of checking.
*/
| isNilPtr bind_dst.tv_info_ptr
= (erroneous_types, type_heaps)
= build_type_substs type_vars types erroneous_types type_heaps error
# type_heaps & th_vars = writePtr bind_dst.tv_info_ptr (TVI_Type bind_src) type_heaps.th_vars
= (erroneous_types, type_heaps)
= build_type_substs type_vars types erroneous_types type_heaps error
build_type_substs NoClassArgs [] erroneous_types type_heaps error
= (erroneous_types, type_heaps, error)
substitue_arg_type at=:{at_type = TFA type_vars type} (erroneous_types, type_heaps)
# (fresh_type_vars, type_heaps) = foldSt build_avar_subst type_vars ([], type_heaps)
......@@ -647,7 +659,7 @@ where
substitue_arg_type type (erroneous_types, type_heaps)
# (_, type, erroneous_types, type_heaps) = substitute_special type erroneous_types type_heaps
= (type, (erroneous_types, type_heaps))
build_var_subst var (free_vars, type_var_heap)
# (new_info_ptr, type_var_heap) = newPtr TVI_Empty type_var_heap
new_fv = { var & tv_info_ptr = new_info_ptr}
......@@ -688,29 +700,27 @@ where
report_erroneous_types [] error
= error
determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !*ErrorAdmin
determineTypeOfMemberInstance :: !SymbolType !ClassArgs !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !*ErrorAdmin
-> (!SymbolType, !FunSpecials, !*TypeHeaps,!u: Optional (v:{#DclModule}, w:{#CheckedTypeDef}), !*ErrorAdmin)
determineTypeOfMemberInstance mem_st class_vars {it_types,it_vars,it_attr_vars,it_context} specials type_heaps opt_modules error
# env = { ss_environ = foldl2 (\binds var type -> [ {bind_src = type, bind_dst = var} : binds]) [] class_vars it_types,
ss_context = it_context, ss_vars = it_vars, ss_attrs = it_attr_vars}
(st, specials, type_heaps, error)
= determine_type_of_member_instance mem_st env specials type_heaps error
determineTypeOfMemberInstance mem_st class_vars ins_type specials type_heaps opt_modules error
# (st, specials, type_heaps, error)
= determine_type_of_member_instance mem_st class_vars ins_type specials type_heaps error
(type_heaps, opt_modules, error)
= check_attribution_consistency mem_st type_heaps opt_modules error
= (st, specials, type_heaps, opt_modules, error)
where
determine_type_of_member_instance mem_st=:{st_context} env (SP_Substitutions substs) type_heaps error
determine_type_of_member_instance mem_st=:{st_context} class_vars ins_type (SP_Substitutions substs) type_heaps error
# (mem_st, substs, type_heaps, error)
= substitute_symbol_type { mem_st & st_context = tl st_context } env substs type_heaps error
= substitute_symbol_type {mem_st & st_context = tl st_context} class_vars ins_type substs type_heaps error
= (mem_st, FSP_Substitutions substs, type_heaps, error)
determine_type_of_member_instance mem_st=:{st_context} env SP_None type_heaps error
determine_type_of_member_instance mem_st=:{st_context} class_vars ins_type SP_None type_heaps error
# (mem_st, _, type_heaps, error)
= substitute_symbol_type { mem_st & st_context = tl st_context } env [] type_heaps error
= substitute_symbol_type {mem_st & st_context = tl st_context} class_vars ins_type [] type_heaps error
= (mem_st, FSP_None, type_heaps, error)
substitute_symbol_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment specials type_heaps error
substitute_symbol_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} class_vars ins_type specials type_heaps error
# (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, specials, type_heaps, error)
= instantiateTypes environment st_vars st_attr_vars [st_result : st_args] st_context st_attr_env specials type_heaps error
= instantiateTypes class_vars ins_type st_vars st_attr_vars [st_result : st_args] st_context st_attr_env specials type_heaps error
= ({st & st_vars = st_vars, st_args = st_args, st_result = st_result, st_attr_vars = st_attr_vars,
st_context = st_context, st_attr_env = st_attr_env }, specials, type_heaps, error)
......@@ -746,28 +756,21 @@ where
-> (False, th_vars, modules, type_defs, error)
where
must_not_be_essentially_unique_for_TA type_ident type_index th_vars
# (type_def, type_defs, modules)
= getTypeDef x_main_dcl_module_n type_index type_defs modules
= case type_def.td_attribute of
TA_Unique
-> (True, th_vars, modules, type_defs,
| is_unique_type_def x_main_dcl_module_n type_index type_defs modules
= (True, th_vars, modules, type_defs,
checkError type_ident
( "is unique but instanciates class variable "
+++tv_ident.id_name
+++" that is non uniquely used in a member type"
) error
)
_
-> (False, th_vars, modules, type_defs, error)
getTypeDef :: !Index !(Global Index) !v:{#CheckedTypeDef} !w:{#DclModule}
-> (!CheckedTypeDef, !v:{#CheckedTypeDef}, !w:{#DclModule})
getTypeDef x_main_dcl_module_n {glob_module,glob_object} type_defs modules
| glob_module==x_main_dcl_module_n
# (type_def, type_defs) = type_defs![glob_object]
= (type_def, type_defs, modules)
# (type_def, modules) = modules![glob_module].dcl_common.com_type_defs.[glob_object]
= (type_def, type_defs, modules)
= (False, th_vars, modules, type_defs, error)
is_unique_type_def :: !Int !(Global Int) !{#CheckedTypeDef} !{#DclModule} -> Bool
is_unique_type_def x_main_dcl_module_n {glob_module,glob_object} type_defs modules
| glob_module==x_main_dcl_module_n
= type_defs.[glob_object].td_attribute=:TA_Unique
= modules.[glob_module].dcl_common.com_type_defs.[glob_object].td_attribute=:TA_Unique
determineTypesOfDclInstances :: !Index !Index !*{#ClassInstance} !*{# ClassDef} !*{# MemberDef}
!*{#DclModule} !*TypeHeaps !*VarHeap !*CheckState
......@@ -866,10 +869,12 @@ where
[{ inst & ins_type = { special_type & it_context = [] }, ins_specials = SP_TypeOffset type_offset} : all_instances ] type_heaps predef_symbols error
where
substitute_instance_type :: !InstanceType !SpecialSubstitution !*TypeHeaps !*ErrorAdmin -> (!InstanceType,!*TypeHeaps,!.ErrorAdmin)
substitute_instance_type it=:{it_vars,it_attr_vars,it_types,it_context} environment type_heaps cs_error
substitute_instance_type it=:{it_vars,it_attr_vars,it_types,it_context} {ss_environ,ss_vars,ss_attrs,ss_context} type_heaps cs_error
# ss_environ_vars = class_args_of_ss_environ ss_environ
# ss_environ_types = [bind_src\\{bind_src}<-ss_environ]
# (it_vars, it_attr_vars, it_atypes, it_context, _, _, type_heaps, cs_error)
= instantiateTypes environment it_vars it_attr_vars [MakeAttributedType type \\ type <- it_types] it_context [] [] type_heaps cs_error
= ({it & it_vars = it_vars, it_types = [ at_type \\ {at_type} <- it_atypes ], it_attr_vars = it_attr_vars, it_context = it_context }, type_heaps, cs_error)
= instantiateTypes ss_environ_vars {it_types=ss_environ_types,it_vars=ss_vars,it_attr_vars=ss_attrs,it_context=ss_context} it_vars it_attr_vars [MakeAttributedType type \\ type <- it_types] it_context [] [] type_heaps cs_error
= ({it & it_vars = it_vars, it_types = [ at_type \\ {at_type} <- it_atypes ], it_attr_vars = it_attr_vars, it_context = it_context }, type_heaps, cs_error)
check_specials mod_index inst=:{ins_type} type_offset [] list_of_specials next_inst_index all_instances type_heaps predef_symbols error
= (list_of_specials, next_inst_index, all_instances, type_heaps, predef_symbols, error)
check_instance_specials mod_index fun_type fun_index SP_None next_inst_index all_instances type_heaps predef_symbols error
......
......@@ -15,8 +15,8 @@ checkMemberType :: !Index !SymbolType !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{
checkInstanceType :: !Index !GlobalIndex !ClassIdent !InstanceType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!InstanceType,!Specials,!u:{# CheckedTypeDef},!v:{# ClassDef},!u:{# DclModule},!*TypeHeaps,!*CheckState)
checkSuperClasses :: ![TypeVar] ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (![TypeVar], ![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkSuperClasses :: !ClassArgs ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!ClassArgs, ![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType)
!u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState
......
......@@ -1263,35 +1263,49 @@ where
NewEntry symbol_table symb_ptr def_kind def_index level previous :==
symbol_table <:= (symb_ptr,{ ste_kind = def_kind, ste_index = def_index, ste_def_level = level, ste_previous = previous })
checkSuperClasses :: ![TypeVar] ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (![TypeVar], ![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkSuperClasses :: !ClassArgs ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!ClassArgs, ![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkSuperClasses class_args class_contexts mod_index type_defs class_defs modules heaps=:{th_vars} cs=:{cs_symbol_table,cs_error}
# (rev_class_args, cs_symbol_table, th_vars, cs_error)
= foldSt add_variable_to_symbol_table class_args ([], cs_symbol_table, th_vars, cs_error)
# (class_args, symbol_ptrs, cs_symbol_table, th_vars, cs_error)
= add_class_args_to_symbol_table class_args [] cs_symbol_table th_vars cs_error
cs = {cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error }
ots = { ots_modules = modules, ots_type_defs = type_defs }
oti = { oti_heaps = { heaps & th_vars = th_vars }, oti_all_vars = [], oti_all_attrs = [], oti_global_vars = [] }
(class_contexts, type_defs, class_defs, modules, type_heaps, cs)
= checkTypeContexts class_contexts mod_index class_defs ots oti cs
(class_args, cs_symbol_table) = retrieve_variables_from_symbol_table rev_class_args [] cs.cs_symbol_table
cs_symbol_table = remove_variables_from_symbol_table symbol_ptrs cs.cs_symbol_table
= (class_args, class_contexts, type_defs, class_defs, modules, type_heaps, {cs & cs_symbol_table = cs_symbol_table})
where
add_variable_to_symbol_table :: !TypeVar !(![TypeVar], !*SymbolTable, !*TypeVarHeap, !*ErrorAdmin)
-> (![TypeVar],!*SymbolTable,!*TypeVarHeap,!*ErrorAdmin)
add_variable_to_symbol_table tv=:{tv_ident={id_name,id_info}} (rev_class_args, symbol_table, th_vars, error)
add_class_args_to_symbol_table :: !ClassArgs ![SymbolPtr] !*SymbolTable !*TypeVarHeap !*ErrorAdmin
-> (!ClassArgs,![SymbolPtr],!*SymbolTable,!*TypeVarHeap,!*ErrorAdmin)
add_class_args_to_symbol_table (ClassArg tv class_args) symbol_ptrs symbol_table th_vars error
# (class_args, symbol_ptrs, symbol_table, th_vars, error)
= add_class_args_to_symbol_table class_args symbol_ptrs symbol_table th_vars error
# (ok, tv, symbol_ptrs, symbol_table, th_vars, error)
= add_variable_to_symbol_table tv symbol_ptrs symbol_table th_vars error
| ok
= (ClassArg tv class_args, symbol_ptrs, symbol_table, th_vars, error)
= (class_args, symbol_ptrs, symbol_table, th_vars, error)
add_class_args_to_symbol_table NoClassArgs symbol_ptrs symbol_table th_vars error
= (NoClassArgs, symbol_ptrs, symbol_table, th_vars, error)
add_variable_to_symbol_table :: !TypeVar ![SymbolPtr] !*SymbolTable !*TypeVarHeap !*ErrorAdmin
-> (!Bool,!TypeVar,![SymbolPtr],!*SymbolTable,!*TypeVarHeap,!*ErrorAdmin)
add_variable_to_symbol_table tv=:{tv_ident={id_name,id_info}} symbol_ptrs symbol_table th_vars error
# (entry, symbol_table) = readPtr id_info symbol_table
| entry.ste_kind =: STE_Empty || entry.ste_def_level < cGlobalScope
# (new_var_ptr, th_vars) = newPtr TVI_Empty th_vars
# symbol_table = NewEntry symbol_table id_info (STE_TypeVariable new_var_ptr) NoIndex cGlobalScope entry
= ([{ tv & tv_info_ptr = new_var_ptr} : rev_class_args], symbol_table, th_vars, error)
= (rev_class_args, symbol_table, th_vars, checkError id_name "(variable) already defined" error)
= (True, {tv & tv_info_ptr = new_var_ptr}, [id_info:symbol_ptrs], symbol_table, th_vars, error)
# error = checkError id_name "(variable) already defined" error
= (False, tv, symbol_ptrs, symbol_table, th_vars, error)
retrieve_variables_from_symbol_table :: ![TypeVar] ![TypeVar] !*SymbolTable -> (![TypeVar],!*SymbolTable)
retrieve_variables_from_symbol_table [var=:{tv_ident={id_name,id_info}} : vars] class_args symbol_table
remove_variables_from_symbol_table :: ![SymbolPtr] !*SymbolTable -> *SymbolTable
remove_variables_from_symbol_table [id_info:id_infos] symbol_table
# (entry, symbol_table) = readPtr id_info symbol_table
= retrieve_variables_from_symbol_table vars [var : class_args] (symbol_table <:= (id_info,entry.ste_previous))
retrieve_variables_from_symbol_table [] class_args symbol_table
= (class_args, symbol_table)
= remove_variables_from_symbol_table id_infos (writePtr id_info entry.ste_previous symbol_table)
remove_variables_from_symbol_table [] symbol_table
= symbol_table
checkTypeContext :: !Index !TypeContext !(!v:{# ClassDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)
-> (!TypeContext,!(!v:{# ClassDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState))
......@@ -1882,7 +1896,7 @@ create_class_dictionary mod_index class_index class_defs =:{[class_index] = clas
, cons_pos = NoPos
}
(td_args, type_var_heap) = mapSt new_attributed_type_variable class_args type_var_heap
(td_args, type_var_heap) = new_attributed_type_variables class_args type_var_heap
type_def =
{ td_ident = rec_type_id
......@@ -1906,9 +1920,13 @@ create_class_dictionary mod_index class_index class_defs =:{[class_index] = clas
type_id_info, { index_type = inc index_type, index_cons = inc index_cons, index_selector = index_selector },
type_var_heap, var_heap, symbol_table)
where
new_attributed_type_variable tv type_var_heap
new_attributed_type_variables (ClassArg tv class_args) type_var_heap
# (new_tv_ptr, type_var_heap) = newPtr TVI_Empty type_var_heap
= ({atv_attribute = TA_Multi, atv_variable = { tv & tv_info_ptr = new_tv_ptr }}, type_var_heap)
# atv = {atv_attribute = TA_Multi, atv_variable = {tv & tv_info_ptr = new_tv_ptr}}
# (atvs,type_var_heap) = new_attributed_type_variables class_args type_var_heap
= ([atv:atvs],type_var_heap)
new_attributed_type_variables NoClassArgs type_var_heap
= ([],type_var_heap);
build_fields field_nr nr_of_fields class_members rec_type field_type rec_type_index next_selector_index rev_fields
args_strictness var_heap symbol_table
......@@ -1970,8 +1988,8 @@ where
= (field, var_heap, symbol_table <:= (id_info, { ste_kind = STE_DictField sel_def, ste_index = selector_index,
ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" }))
same_args_as_root_class [TV tv1:tvs1] [tv2:tvs2] = tv1.tv_ident.id_name==tv2.tv_ident.id_name && same_args_as_root_class tvs1 tvs2
same_args_as_root_class [] [] = True
same_args_as_root_class [TV tv1:tvs1] (ClassArg tv2 tvs2) = tv1.tv_ident.id_name==tv2.tv_ident.id_name && same_args_as_root_class tvs1 tvs2
same_args_as_root_class [] NoClassArgs = True
same_args_as_root_class _ _ = False
class toVariable var :: !STE_Kind !Ident -> var
......
......@@ -196,7 +196,7 @@ where
= (icl_class_defs, icl_member_defs, comp_st)
compare_classes dcl_class_def dcl_member_defs icl_class_def icl_member_defs comp_st=:{comp_type_var_heap}
# comp_type_var_heap = initialyseTypeVars dcl_class_def.class_args icl_class_def.class_args comp_type_var_heap
# comp_type_var_heap = initialyseClassArgs dcl_class_def.class_args icl_class_def.class_args comp_type_var_heap
comp_st = { comp_st & comp_type_var_heap = comp_type_var_heap }
# (ok, comp_st) = compare dcl_class_def.class_context icl_class_def.class_context comp_st
| not ok
......@@ -525,6 +525,19 @@ initialyseATypeVars [] [{atv_variable={tv_info_ptr}}:icl_type_vars] type_var_hea
initialyseATypeVars [] [] type_var_heap
= type_var_heap
initialyseClassArgs (ClassArg {tv_info_ptr=dcl_tv_info_ptr} dcl_type_vars) (ClassArg {tv_info_ptr=icl_tv_info_ptr} icl_type_vars) type_var_heap
# type_var_heap = type_var_heap <:= (icl_tv_info_ptr, TVI_TypeVar dcl_tv_info_ptr) <:= (dcl_tv_info_ptr, TVI_TypeVar icl_tv_info_ptr)
= initialyseClassArgs dcl_type_vars icl_type_vars type_var_heap
initialyseClassArgs NoClassArgs NoClassArgs type_var_heap
= type_var_heap
initialyseClassArgs dcl_class_args icl_class_args type_var_heap
= initialyseClassArgsEmpty icl_class_args (initialyseClassArgsEmpty dcl_class_args type_var_heap)
initialyseClassArgsEmpty (ClassArg {tv_info_ptr} type_vars) type_var_heap
= initialyseClassArgsEmpty type_vars (writePtr tv_info_ptr TVI_Empty type_var_heap)
initialyseClassArgsEmpty NoClassArgs type_var_heap
= type_var_heap
initialyseAttributeVars [{av_info_ptr=dcl_av_info_ptr}:dcl_type_vars] [{av_info_ptr=icl_av_info_ptr}:icl_type_vars] type_var_heap
# type_var_heap = type_var_heap <:= (icl_av_info_ptr, AVI_AttrVar dcl_av_info_ptr) <:= (dcl_av_info_ptr, AVI_AttrVar icl_av_info_ptr)
= initialyseAttributeVars dcl_type_vars icl_type_vars type_var_heap
......@@ -720,7 +733,17 @@ init_type_vars type_vars1 type_vars2 tc_state=:{tc_type_vars=tc_type_vars=:{hwn_
where
init_type_var {tv_info_ptr} heap
= writePtr tv_info_ptr TVI_Empty heap
init_class_args type_vars1 type_vars2 tc_state=:{tc_type_vars=tc_type_vars=:{hwn_heap}}
# hwn_heap = init_class_args type_vars1 hwn_heap
# hwn_heap = init_class_args type_vars2 hwn_heap
= {tc_state & tc_type_vars = {tc_type_vars & hwn_heap = hwn_heap}}
where
init_class_args (ClassArg {tv_info_ptr} class_args) heap
= init_class_args class_args (writePtr tv_info_ptr TVI_Empty heap)
init_class_args NoClassArgs heap
= heap
generate_error message iclDef iclDefs tc_state error_admin
# ident_pos = getIdentPos iclDef
error_admin = pushErrorAdmin ident_pos error_admin
......@@ -1101,6 +1124,15 @@ instance t_corresponds TypeVar where
# (unifiable, tc_type_vars) = tryToUnifyVars dclDef.tv_info_ptr iclDef.tv_info_ptr tc_type_vars
= (unifiable, { tc_state & tc_type_vars = tc_type_vars })
instance t_corresponds ClassArgs where
t_corresponds NoClassArgs NoClassArgs
= return True
t_corresponds (ClassArg dclDef dclDefs) (ClassArg iclDef iclDefs)
= t_corresponds dclDef iclDef
&&& t_corresponds dclDefs iclDefs
t_corresponds _ _
= return False
instance t_corresponds TypeRhs where
t_corresponds (AlgType dclConstructors) (AlgType iclConstructors)
= t_corresponds dclConstructors iclConstructors
......@@ -1178,7 +1210,7 @@ instance t_corresponds AttrInequality where
instance t_corresponds ClassDef where
t_corresponds dclDef iclDef
= do (init_type_vars dclDef.class_args iclDef.class_args)
= do (init_class_args dclDef.class_args iclDef.class_args)
&&& equal dclDef.class_ident iclDef.class_ident
&&& t_corresponds dclDef.class_args iclDef.class_args
&&& t_corresponds dclDef.class_context iclDef.class_context
......
......@@ -2091,7 +2091,7 @@ where
me_offset = 0,
me_type = member_type,
me_type_ptr = type_ptr, // empty
me_class_vars = [class_var], // the same variable as in the class
me_class_vars = ClassArg class_var NoClassArgs, // the same variable as in the class
me_pos = gen_pos,
me_priority = NoPrio,
me_default_implementation = NoMemberDefault
......@@ -2111,7 +2111,7 @@ where
}
= { class_ident = class_ident,
class_arity = 1,
class_args = [class_var],
class_args = ClassArg class_var NoClassArgs,
class_context = [],
class_pos = gen_pos,
class_members = createArray 1 class_member,
......@@ -2851,7 +2851,7 @@ determine_type_of_member_instance_from_symbol_type :: !SymbolType !InstanceType
-> (!SymbolType, !*TypeHeaps, !*VarHeap, !*ErrorAdmin)
determine_type_of_member_instance_from_symbol_type me_type=:{st_context=[{tc_types = [TV class_var]}:_]} ins_type hp_type_heaps hp_var_heap error
#! (symbol_type, _, hp_type_heaps, _, error)
= determineTypeOfMemberInstance me_type [class_var] ins_type SP_None hp_type_heaps No error
= determineTypeOfMemberInstance me_type (ClassArg class_var NoClassArgs) ins_type SP_None hp_type_heaps No error
#! (st_context, hp_var_heap) = initializeContextVariables symbol_type.st_context hp_var_heap
#! hp_type_heaps = clearSymbolType me_type hp_type_heaps
#! symbol_type = {symbol_type & st_context = st_context}
......
......@@ -249,8 +249,6 @@ where
= (CA_Instance class_appls, rs_state)
reduce_context :: !ReduceInfo !TypeContext !*ReduceState -> *(!ReducedContexts, !*ReduceState)
reduce_context info tc=:{tc_class=TCGeneric {gtc_class}} rs_state
= reduce_context info {tc & tc_class = TCClass gtc_class} rs_state
reduce_context info=:{ri_defs,ri_instance_info,ri_main_dcl_module_n} {tc_class=tc_class=:TCClass class_symb=:{glob_object={ds_index},glob_module},tc_types}
rs_state
# {class_members,class_context,class_args,class_ident} = ri_defs.[glob_module].com_class_defs.[ds_index]
......@@ -302,12 +300,12 @@ where
= ({ rcs_class_context = { rc_class_index = {gi_module=glob_module,gi_index=ds_index}, rc_inst_module = NoIndex, rc_inst_members = {}, rc_types = tc_types, rc_red_contexts = [] },
rcs_constraints_contexts = constraints }, rs_state)
reduce_contexts_in_constraints :: !ReduceInfo ![Type] ![TypeVar] ![TypeContext] *ReduceState
reduce_contexts_in_constraints :: !ReduceInfo ![Type] !ClassArgs ![TypeContext] *ReduceState
-> *([ClassApplication],*ReduceState)
reduce_contexts_in_constraints info types class_args [] rs_state
= ([],rs_state)
reduce_contexts_in_constraints info types class_args class_context rs_state=:{rs_type_heaps=rs_type_heaps=:{th_vars}}
# th_vars = fold2St (\ type {tv_info_ptr} -> writePtr tv_info_ptr (TVI_Type type)) types class_args th_vars
# th_vars = set_class_args_types class_args types th_vars
(instantiated_context, rs_type_heaps) = fresh_contexts class_context { rs_type_heaps & th_vars = th_vars }
# rs_state = {rs_state & rs_type_heaps=rs_type_heaps}
= mapSt (reduce_any_context info) instantiated_context rs_state
......@@ -1370,12 +1368,11 @@ where
= generate_super_classes {tc & tc_class=TCClass gtc_class} st
generate_super_classes {tc_class=TCClass {glob_object={ds_index},glob_module},tc_types} (super_classes, type_heaps)
# {class_args,class_members,class_context} = defs.[glob_module].com_class_defs.[ds_index]
th_vars = fold2St set_type class_args tc_types type_heaps.th_vars
= foldSt subst_context_and_generate_super_classes class_context (super_classes, { type_heaps & th_vars = th_vars })
| class_context=:[]
= (super_classes, type_heaps)
# th_vars = set_class_args_types class_args tc_types type_heaps.th_vars
= foldSt subst_context_and_generate_super_classes class_context (super_classes, { type_heaps & th_vars = th_vars })
where
set_type {tv_info_ptr} type type_var_heap
= type_var_heap <:= (tv_info_ptr, TVI_Type type)
subst_context_and_generate_super_classes class_context (super_classes, type_heaps)
# (_, super_class, type_heaps) = substitute class_context type_heaps
| containsContext super_class super_classes
......@@ -1671,7 +1668,9 @@ where
= (Yes address, type_heaps)
# {tc_class=TCClass {glob_object={ds_index},glob_module}} = tc2
{class_args,class_members,class_context,class_dictionary} = defs.[glob_module].com_class_defs.[ds_index]
th_vars = foldr2 (\{tv_info_ptr} type -> writePtr tv_info_ptr (TVI_Type type)) th_vars class_args tc2.tc_types
| class_context=:[]
= (No, type_heaps)
# th_vars = set_class_args_types class_args tc2.tc_types th_vars
(_, super_instances, type_heaps) = substitute class_context {type_heaps & th_vars = th_vars}
= find_super_instance tc1 super_instances (size class_members) address glob_module class_dictionary.ds_index defs type_heaps
where
......
......@@ -1753,12 +1753,12 @@ wantClassDefinition parseContext pos pState
= (succ, (False, type_var), pState)
convert_class_variables [] arg_nr cons_vars
= (arg_nr, [], cons_vars)
= (arg_nr, NoClassArgs, cons_vars)
convert_class_variables [(annot, var) : class_vars] arg_nr cons_vars
# (arity, class_vars, cons_vars) = convert_class_variables class_vars (inc arg_nr) cons_vars
| annot
= (arity, [var : class_vars], cons_vars bitor (1 << arg_nr))
= (arity, [var : class_vars], cons_vars)
= (arity, ClassArg var class_vars, cons_vars bitor (1 << arg_nr))
= (arity, ClassArg var class_vars, cons_vars)
wantInstanceDeclaration :: !ParseContext !Position !ParseState -> (!ParsedDefinition, !ParseState)
wantInstanceDeclaration parseContext pi_pos pState
......
......@@ -1529,7 +1529,7 @@ reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = MoreConses type_ex