Commit 6fbe0922 authored by John van Groningen's avatar John van Groningen
Browse files

No commit message

No commit message
parent 4067a82e
......@@ -1155,8 +1155,8 @@ adjustArrayFunctions array_first_instance_indices predefs main_dcl_module_n func
= foldStateA (adjustStdArrayInstance arrayClassIndex arrayInfo) instances
where
adjustStdArrayInstance :: Index AdjustStdArrayInfo ClassInstance -> BackEnder
adjustStdArrayInstance arrayClassIndex arrayInfo=:{asai_moduleIndex} instance`=:{ins_class}
| ins_class.glob_object.ds_index == arrayClassIndex && ins_class.glob_module == asai_moduleIndex
adjustStdArrayInstance arrayClassIndex arrayInfo=:{asai_moduleIndex} instance`=:{ins_class_index}
| ins_class_index.gi_index == arrayClassIndex && ins_class_index.gi_module == asai_moduleIndex
= adjustArrayClassInstance arrayInfo instance`
// otherwise
= identity
......
......@@ -615,7 +615,7 @@ emptyIdent name :== { id_name = name, id_info = nilPtr }
newKindVariables td_args (type_var_heap, as_kind_heap)
= mapSt new_kind td_args (type_var_heap, as_kind_heap)
where
new_kind :: ATypeVar *(*Heap TypeVarInfo,*Heap KindInfo) -> (!.TypeKind,!(!.Heap TypeVarInfo,!.Heap KindInfo));
new_kind :: ATypeVar *(*TypeVarHeap,*KindHeap) -> (!.TypeKind,!(!*TypeVarHeap,!*KindHeap));
new_kind {atv_variable={tv_info_ptr}} (type_var_heap, kind_heap)
# (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap
= (KindVar kind_info_ptr, (type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr)))
......@@ -1018,11 +1018,12 @@ where
= check_kinds_of_class_instances common_defs (inc instance_index) instance_defs class_infos as
where
check_kinds_of_class_instance :: !{#CommonDefs} !ClassInstance !*ClassDefInfos !*AnalyseState -> (!*ClassDefInfos, !*AnalyseState)
check_kinds_of_class_instance common_defs {ins_class,ins_ident,ins_pos,ins_type={it_vars,it_types,it_context}} class_infos
check_kinds_of_class_instance common_defs {ins_class_index,ins_class_ident={ci_ident,ci_arity},ins_ident,ins_pos,ins_type={it_vars,it_types,it_context}} class_infos
as=:{as_type_var_heap,as_kind_heap,as_error}
# as_error = pushErrorAdmin (newPosition ins_ident ins_pos) as_error
(as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars it_vars as_type_var_heap as_kind_heap
as = { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap, as_error = as_error }
ins_class = {glob_module=ins_class_index.gi_module,glob_object={ds_index=ins_class_index.gi_index,ds_ident=ci_ident,ds_arity=ci_arity}}
context = {tc_class = TCClass ins_class, tc_types = it_types, tc_var = nilPtr}
(class_infos, as) = determine_kinds_of_type_contexts common_defs [context : it_context] class_infos as
= (class_infos, { as & as_error = popErrorAdmin as.as_error})
......
......@@ -175,14 +175,12 @@ where
check_instance_defs inst_index mod_index instance_defs is type_heaps cs
| inst_index < size instance_defs
# (instance_def, instance_defs) = instance_defs![inst_index]
(instance_def, is, type_heaps, cs) = check_instance mod_index instance_def is type_heaps cs
(instance_def, is, type_heaps, cs) = check_instance instance_def mod_index is type_heaps cs
= check_instance_defs (inc inst_index) mod_index { instance_defs & [inst_index] = instance_def } is type_heaps cs
= (instance_defs, is, type_heaps, cs)
check_instance :: !Index !ClassInstance !u:InstanceSymbols !*TypeHeaps !*CheckState -> (!ClassInstance, !u:InstanceSymbols, !*TypeHeaps, !*CheckState)
check_instance module_index
ins=:{ins_class={glob_object = class_ident =: {ds_ident = {id_name,id_info},ds_arity}},ins_type,ins_specials,ins_pos,ins_ident}
is=:{is_class_defs,is_modules} type_heaps cs=:{cs_symbol_table}
check_instance :: !ClassInstance !Index !u:InstanceSymbols !*TypeHeaps !*CheckState -> (!ClassInstance, !u:InstanceSymbols, !*TypeHeaps, !*CheckState)
check_instance ins=:{ins_class_ident={ci_ident={id_name,id_info}},ins_pos,ins_ident} module_index is type_heaps cs=:{cs_symbol_table}
# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
# cs = pushErrorAdmin (newPosition ins_ident ins_pos) { cs & cs_symbol_table = cs_symbol_table }
# (ins, is, type_heaps, cs) = case entry.ste_kind of
......@@ -198,19 +196,17 @@ 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
ins=:{ins_class={glob_object = class_ident =: {ds_ident = {id_name,id_info},ds_arity}},ins_type,ins_specials,ins_pos,ins_ident}
ins=:{ins_class_ident=ins_class_ident=:{ci_ident={id_name,id_info},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 == ds_arity
# ins_class = { glob_object = { class_ident & ds_index = class_index }, glob_module = class_mod_index}
| class_def.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 ins_type ins_specials
= 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 = ins_class, ins_type = ins_type, ins_specials = ins_specials}, is, type_heaps, cs)
// otherwise
= ( ins, is, type_heaps
, { cs & cs_error = checkError id_name ("wrong arity: expected "+++toString class_def.class_arity+++" found "+++toString ds_arity) cs.cs_error }
)
= ({ins & ins_class_index = ins_class_index, ins_type = ins_type, ins_specials = ins_specials}, is, type_heaps, cs)
# cs = {cs & cs_error = checkError id_name ("wrong arity: expected "+++toString class_def.class_arity+++" found "+++toString ci_arity) cs.cs_error}
= (ins, is, type_heaps, cs)
checkIclInstances :: !Index !*CommonDefs !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
-> (![(Index,SymbolType)], !*CommonDefs, !u:{# DclModule}, !*VarHeap , !*TypeHeaps, !*CheckState)
......@@ -231,25 +227,22 @@ where
# (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs) =
check_class_instance instance_def mod_index instance_types class_defs member_defs generic_defs type_defs modules var_heap type_heaps cs
= check_icl_instances (inc inst_index) mod_index instance_types instance_defs class_defs member_defs generic_defs type_defs modules var_heap type_heaps cs
// otherwise
= (instance_types, instance_defs, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
check_class_instance {ins_pos,ins_class,ins_members,ins_type} mod_index instance_types class_defs member_defs generic_defs type_defs modules var_heap type_heaps cs
# ({class_members,class_ident}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules
class_size = size class_members
| class_size == size ins_members
# (instance_types, member_defs, type_defs, modules, var_heap, type_heaps, cs)
= check_icl_instance_members mod_index ins_class.glob_module
0 class_size ins_members class_members class_ident ins_pos ins_type instance_types member_defs type_defs modules var_heap type_heaps cs
= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
// otherwise
# cs = { cs & cs_error = checkErrorWithIdentPos (newPosition class_ident ins_pos) "different number of members specified" cs.cs_error }
= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
check_class_instance {ins_pos,ins_class_index,ins_members,ins_type} mod_index instance_types class_defs member_defs generic_defs type_defs modules var_heap type_heaps cs
# ({class_members,class_ident}, class_defs, modules) = getClassDef ins_class_index mod_index class_defs modules
class_size = size class_members
| class_size == size ins_members
# (instance_types, member_defs, type_defs, modules, var_heap, type_heaps, cs)
= check_icl_instance_members mod_index ins_class_index.gi_module
0 class_size ins_members class_members class_ident ins_pos ins_type instance_types member_defs type_defs modules var_heap type_heaps cs
= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
# cs = { cs & cs_error = checkErrorWithIdentPos (newPosition class_ident ins_pos) "different number of members specified" cs.cs_error }
= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
check_icl_instance_members :: !Index !Index !Int !Int !{#ClassInstanceMember} !{#DefinedSymbol} Ident !Position !InstanceType ![(Index,SymbolType)]
!v:{# MemberDef} !blah:{# CheckedTypeDef} !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
-> (![(Index,SymbolType)], !v:{# MemberDef}, !blah:{# CheckedTypeDef}, !u:{# DclModule},!*VarHeap, !*TypeHeaps, !*CheckState)
check_icl_instance_members module_index member_mod_index mem_offset class_size ins_members class_members
class_ident ins_pos ins_type instance_types member_defs type_defs modules var_heap type_heaps cs=:{cs_x={x_main_dcl_module_n}}
| mem_offset == class_size
......@@ -272,13 +265,13 @@ where
= check_icl_instance_members module_index member_mod_index (inc mem_offset) class_size ins_members class_members class_ident ins_pos ins_type
[ (ins_member.cim_index, { instance_type & st_context = st_context }) : instance_types ] member_defs type_defs modules var_heap type_heaps { cs & cs_error = cs_error }
getClassDef :: !(Global DefinedSymbol) !Int !u:{#ClassDef} !v:{#DclModule} -> (!ClassDef,!u:{#ClassDef},!v:{#DclModule})
getClassDef {glob_module, glob_object={ds_ident, ds_index}} mod_index class_defs modules
| glob_module == mod_index
# (class_def, class_defs) = class_defs![ds_index]
getClassDef :: !GlobalIndex !Int !u:{#ClassDef} !v:{#DclModule} -> (!ClassDef,!u:{#ClassDef},!v:{#DclModule})
getClassDef {gi_module,gi_index} mod_index class_defs modules
| gi_module == mod_index
# (class_def, class_defs) = class_defs![gi_index]
= (class_def, class_defs, modules)
# (dcl_mod, modules) = modules![glob_module]
= (dcl_mod.dcl_common.com_class_defs.[ds_index], class_defs, modules)
# (dcl_mod, modules) = modules![gi_module]
= (dcl_mod.dcl_common.com_class_defs.[gi_index], class_defs, modules)
getMemberDef :: !Int Int !Int !u:{#MemberDef} !v:{#DclModule} -> (!MemberDef,!u:{#MemberDef},!v:{#DclModule})
getMemberDef mem_mod mem_index mod_index member_defs modules
......@@ -480,11 +473,11 @@ where
determine_types_of_dcl_instances x_main_dcl_module_n inst_index next_class_inst_index next_mem_inst_index mod_index all_class_specials
class_defs member_defs modules instance_defs type_heaps var_heap predef_symbols error
| inst_index < size instance_defs
# (instance_def=:{ins_class,ins_pos,ins_type,ins_specials}, instance_defs) = instance_defs![inst_index]
# ({class_ident, class_members}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules
# (instance_def=:{ins_class_index,ins_pos,ins_type,ins_specials}, instance_defs) = instance_defs![inst_index]
# ({class_ident, class_members}, class_defs, modules) = getClassDef ins_class_index mod_index class_defs modules
class_size = size class_members
(ins_members, memb_inst_defs1, member_defs, modules, type_heaps, var_heap, error)
= determine_dcl_instance_symbols_and_types x_main_dcl_module_n next_mem_inst_index 0 mod_index ins_class.glob_module class_size class_members
= determine_dcl_instance_symbols_and_types x_main_dcl_module_n next_mem_inst_index 0 mod_index ins_class_index.gi_module class_size class_members
ins_type ins_specials class_ident ins_pos member_defs modules type_heaps var_heap error
instance_def = { instance_def & ins_members = { member \\ member <- ins_members }}
(ins_specials, next_class_inst_index, all_class_specials, type_heaps, predef_symbols,error)
......@@ -2444,8 +2437,8 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m
adjust_instance_types_of_array_functions :: !Index !{#.Index} !Int !*(!u:{# ClassInstance},!*{# FunDef},!v:{#PredefinedSymbol})
-> (!u:{# ClassInstance},!*{# FunDef},!v:{#PredefinedSymbol})
adjust_instance_types_of_array_functions array_class_index offset_table inst_index (class_instances, fun_defs, predef_symbols)
# ({ins_class={glob_module,glob_object={ds_index}},ins_type,ins_members}, class_instances) = class_instances![inst_index]
| glob_module == main_dcl_module_n && ds_index == array_class_index && elemTypeIsStrict ins_type.it_types predef_symbols
# ({ins_class_index={gi_module,gi_index},ins_type,ins_members}, class_instances) = class_instances![inst_index]
| gi_module == main_dcl_module_n && gi_index == array_class_index && elemTypeIsStrict ins_type.it_types predef_symbols
# fun_defs = iFoldSt (make_instance_strict ins_members offset_table) 0 (size ins_members) fun_defs
= (class_instances, fun_defs, predef_symbols)
= (class_instances, fun_defs, predef_symbols)
......@@ -2455,7 +2448,7 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m
# {cim_index} = instances.[ins_offset]
(inst_def, instance_defs) = instance_defs![cim_index]
(Yes symbol_type) = inst_def.fun_type
= {instance_defs & [cim_index] = {inst_def & fun_type = Yes (makeElemTypeOfArrayFunctionStrict symbol_type ins_offset offset_table)}}
= { instance_defs & [cim_index] = { inst_def & fun_type = Yes (makeElemTypeOfArrayFunctionStrict symbol_type ins_offset offset_table) } }
checkSpecifiedInstanceType (index_of_member_fun, derived_symbol_type) (icl_functions, type_heaps, cs_error)
# ({fun_type, fun_pos, fun_ident}, icl_functions) = icl_functions![index_of_member_fun]
......@@ -2936,7 +2929,7 @@ checkInstancesOfDclModule mod_index (nr_of_dcl_functions_and_instances, nr_of_dc
dcl_modules = { dcl_modules & [mod_index] = dcl_mod }
= (dcl_modules, heaps, cs)
where
where
adjust_instance_types_of_array_functions_in_std_array_dcl array_mod_index class_members class_instances fun_types cs=:{cs_predef_symbols}
#! nr_of_instances = size class_instances
# ({pds_def}, cs_predef_symbols) = cs_predef_symbols![PD_ArrayClass]
......@@ -2949,8 +2942,8 @@ checkInstancesOfDclModule mod_index (nr_of_dcl_functions_and_instances, nr_of_dc
adjust_instance_types_of_array_functions :: .Index !Index !{#.Index} !Int !*(!u:{# ClassInstance},!*{# FunType},!v:{#PredefinedSymbol})
-> (!u:{# ClassInstance},!*{# FunType},!v:{#PredefinedSymbol})
adjust_instance_types_of_array_functions array_mod_index array_class_index offset_table inst_index (class_instances, fun_types, predef_symbols)
# ({ins_class={glob_module,glob_object={ds_index}},ins_type,ins_members}, class_instances) = class_instances![inst_index]
| glob_module == array_mod_index && ds_index == array_class_index && elemTypeIsStrict ins_type.it_types predef_symbols
# ({ins_class_index={gi_module,gi_index},ins_type,ins_members}, class_instances) = class_instances![inst_index]
| gi_module == array_mod_index && gi_index == array_class_index && elemTypeIsStrict ins_type.it_types predef_symbols
# fun_types = iFoldSt (make_instance_strict ins_members offset_table) 0 (size ins_members) fun_types
= (class_instances, fun_types, predef_symbols)
= (class_instances, fun_types, predef_symbols)
......@@ -3153,9 +3146,8 @@ where
= foldlArraySt (count_members_of_instance mod_index) com_instance_defs (0, com_class_defs, modules)
= sum
count_members_of_instance mod_index {ins_class} (sum, com_class_defs, modules)
# ({class_members}, com_class_defs, modules)
= getClassDef ins_class mod_index com_class_defs modules
count_members_of_instance mod_index {ins_class_index} (sum, com_class_defs, modules)
# ({class_members}, com_class_defs, modules) = getClassDef ins_class_index mod_index com_class_defs modules
= (size class_members + sum, com_class_defs, modules)
adjustPredefSymbol predef_index mod_index symb_kind cs=:{cs_symbol_table,cs_error}
......
......@@ -11,8 +11,8 @@ checkFunctionType :: !Index !SymbolType !FunSpecials !u:{#CheckedTypeDef} !v:{#C
checkMemberType :: !Index !SymbolType !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkInstanceType :: !Index !(Global DefinedSymbol) !InstanceType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!InstanceType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
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)
......
......@@ -772,9 +772,9 @@ checkOpenType mod_index scope dem_attr type cot_state
checkOpenATypes mod_index scope types cot_state
= mapSt (checkOpenAType mod_index scope DAK_None) types cot_state
checkInstanceType :: !Index !(Global DefinedSymbol) !InstanceType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!InstanceType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_defs class_defs modules heaps cs
checkInstanceType :: !Index !GlobalIndex !ClassIdent !InstanceType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!InstanceType,!Specials,!u:{# CheckedTypeDef},!v:{# ClassDef},!u:{# DclModule},!*TypeHeaps,!*CheckState)
checkInstanceType mod_index ins_class_index ins_class_ident it=:{it_types,it_context} specials type_defs class_defs modules heaps cs
# cs_error = check_fully_polymorphity it_types it_context cs.cs_error
ots = { ots_type_defs = type_defs, ots_modules = modules }
oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars= [] }
......@@ -783,7 +783,7 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de
(heaps, cs) = check_linearity_of_type_vars it_vars oti.oti_heaps cs
oti = { oti & oti_all_vars = [], oti_all_attrs = [], oti_heaps = heaps }
(it_context, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts it_context mod_index class_defs ots oti cs
cs_error = foldSt (compare_context_and_instance_types ins_class it_types) it_context cs.cs_error
cs_error = foldSt (compare_context_and_instance_types ins_class_index ins_class_ident it_types) it_context cs.cs_error
(specials, cs) = checkSpecialTypeVars specials { cs & cs_error = cs_error }
cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope it_vars cs.cs_symbol_table
cs_symbol_table = removeAttributesFromSymbolTable it_attr_vars cs_symbol_table
......@@ -809,15 +809,15 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de
= (th_vars, checkError tv_ident ": this type variable occurs more than once in an instance type" error)
= (th_vars, error)
compare_context_and_instance_types ins_class it_types {tc_class=TCGeneric _, tc_types} cs_error
compare_context_and_instance_types ins_class_index ins_class_ident it_types {tc_class=TCGeneric _, tc_types} cs_error
= cs_error
compare_context_and_instance_types ins_class it_types {tc_class=TCClass clazz, tc_types} cs_error
| ins_class<>clazz
compare_context_and_instance_types ins_class_index ins_class_ident it_types {tc_class=TCClass clazz, tc_types} cs_error
| ins_class_index.gi_module<>clazz.glob_module || ins_class_index.gi_index<>clazz.glob_object.ds_index
= cs_error
# are_equal
= fold2St compare_context_and_instance_type it_types tc_types True
| are_equal
= checkError ins_class.glob_object.ds_ident "context restriction equals instance type" cs_error
= checkError ins_class_ident.ci_ident "context restriction equals instance type" cs_error
= cs_error
where
compare_context_and_instance_type (TA {type_index=ti1} _) (TA {type_index=ti2} _) are_equal_accu
......
......@@ -600,9 +600,9 @@ instance check_completeness ClassDef where
= check_completeness class_context cci ccs
instance check_completeness ClassInstance where
check_completeness {ins_class={glob_module,glob_object={ds_ident,ds_index}}, ins_type} cci ccs
check_completeness {ins_class_index={gi_module,gi_index},ins_class_ident={ci_ident},ins_type} cci ccs
= check_completeness ins_type cci
(check_whether_ident_is_imported ds_ident glob_module ds_index STE_Class cci ccs)
(check_whether_ident_is_imported ci_ident gi_module gi_index STE_Class cci ccs)
instance check_completeness ConsDef
where
......
......@@ -273,8 +273,8 @@ buildGenericTypeRep type_index funs_and_groups
, hp_var_heap = gs_varh
, hp_generic_heap = gs_genh
, hp_type_heaps = { th_vars = gs_tvarh, th_attrs = gs_avarh }
}
}
# (type_def, gs_modules) = gs_modules![type_index.gi_module].com_type_defs.[type_index.gi_index]
# (type_info, cons_infos, funs_and_groups, gs_modules, heaps, gs_error)
......@@ -1381,7 +1381,7 @@ buildMemberType gen_def=:{gen_ident,gen_pos,gen_type,gen_vars} kind class_var gs
#! th = {th_vars = gs.gs_tvarh, th_attrs = gs.gs_avarh}
#! (kind_indexed_st, gatvs, th, gs_error)
= buildKindIndexedType gen_type gen_vars kind gen_ident gen_pos th gs.gs_error
#! (member_st, th, gs_error)
= replace_generic_vars_with_class_var kind_indexed_st gatvs th gs_error
......@@ -1839,9 +1839,9 @@ where
build_shorthand_class_instance :: TypeKind Int Ident Position DefinedSymbol InstanceType !(!Int,![ClassInstance]) -> (!Int,![ClassInstance])
build_shorthand_class_instance this_kind class_index gc_ident gc_pos {ds_ident,ds_arity,ds_index} ins_type (ins_index, instances)
#! class_ident = genericIdentToClassIdent gc_ident.id_name this_kind
#! class_ds = {ds_index = class_index, ds_arity=1, ds_ident=class_ident}
#! ins =
{ ins_class = {glob_module=gs_main_module, glob_object=class_ds}
{ ins_class_index = {gi_module=gs_main_module, gi_index=class_index}
, ins_class_ident = {ci_ident=class_ident, ci_arity=1}
, ins_ident = class_ident
, ins_type = ins_type
, ins_members = {{cim_ident=ds_ident,cim_arity=ds_arity,cim_index=ds_index}}
......@@ -1919,7 +1919,8 @@ where
# class_ident = genericIdentToClassIdent gc_ident.id_name gc_kind
# class_ds = {ds_index = class_index, ds_arity=1, ds_ident=class_ident}
#! ins =
{ ins_class = {glob_module=gs_main_module, glob_object=class_ds}
{ ins_class_index = {gi_module=gs_main_module, gi_index=class_index}
, ins_class_ident = {ci_ident=class_ident, ci_arity=1}
, ins_ident = class_ident
, ins_type = ins_type
, ins_members = {class_instance_member}
......@@ -3836,15 +3837,8 @@ curryGenericArgType1 :: !SymbolType !String !*TypeHeaps
-> (!SymbolType, !*TypeHeaps)
curryGenericArgType1 st=:{st_args, st_result, st_attr_env, st_attr_vars} attr_var_name th=:{th_attrs}
# (atype, attr_vars, av_num, th_attrs) = curry st_args st_result 1 th_attrs
# curried_st =
{ st
& st_args = []
, st_arity = 0
, st_result = atype
, st_attr_vars = attr_vars
}
# curried_st = {st & st_args = [], st_arity = 0, st_result = atype, st_attr_vars = attr_vars}
= (curried_st, {th & th_attrs = th_attrs})
//---> ("curryGenericArgType", st, curried_st)
where
// outermost closure gets TA_Multi attribute
curry [] res av_num th_attrs
......@@ -3868,7 +3862,6 @@ where
clearType t th
= foldType clear_type clear_atype t th
where
clear_type (TV tv) th = clear_type_var tv th
clear_type (GTV tv) th = clear_type_var tv th
clear_type (CV tv :@: _) th = clear_type_var tv th
......@@ -3876,7 +3869,6 @@ where
#! th = foldSt clear_attr [atv_attribute \\ {atv_attribute} <- atvs] th
#! th = foldSt clear_type_var [atv_variable \\ {atv_variable} <- atvs] th
= th
clear_type _ th = th
clear_atype {at_attribute} th
......@@ -3888,6 +3880,7 @@ where
clear_type_var {tv_info_ptr} th=:{th_vars}
= {th & th_vars = writePtr tv_info_ptr TVI_Empty th_vars}
clear_attr_var {av_info_ptr} th=:{th_attrs}
= {th & th_attrs = writePtr av_info_ptr AVI_Empty th_attrs}
......@@ -3953,7 +3946,6 @@ collectAttrVars type th
collectAttrsOfTypeVars :: ![TypeVar] type !*TypeHeaps -> (![ATypeVar], !*TypeHeaps) | foldType type
collectAttrsOfTypeVars tvs type th
#! (th=:{th_vars}) = clearType type th
//---> ("collectAttrsOfTypeVars called for", tvs)
# th_vars = foldSt (\{tv_info_ptr} h->writePtr tv_info_ptr TVI_Used h) tvs th_vars
......@@ -3963,7 +3955,6 @@ collectAttrsOfTypeVars tvs type th
#! th = clearType type {th & th_vars= th_vars}
= (atvs, th)
//---> ("collectAttrsOfTypeVars returns", atvs)
where
on_type type st = st
......
This diff is collapsed.
......@@ -439,7 +439,8 @@ cNameLocationDependent :== True
}
:: ClassInstance =
{ ins_class :: !Global DefinedSymbol
{ ins_class_index :: !GlobalIndex
, ins_class_ident :: !ClassIdent
, ins_ident :: !Ident
, ins_type :: !InstanceType
, ins_members :: !{#ClassInstanceMember}
......@@ -447,6 +448,11 @@ cNameLocationDependent :== True
, ins_pos :: !Position
}
:: ClassIdent =
{ ci_ident :: !Ident
, ci_arity :: !Int
}
:: ClassInstanceMember =
{ cim_ident :: !Ident
, cim_arity :: !Int // module number if cim_index<0
......@@ -1491,10 +1497,11 @@ ParsedConstructorToConsDef pc :==
cons_exi_vars = pc.pc_exi_vars, cons_type_ptr = nilPtr }
ParsedInstanceToClassInstance pi members :==
{ ins_class = {glob_object = MakeDefinedSymbol pi.pi_class NoIndex (length pi.pi_types), glob_module = NoIndex}, ins_ident = pi.pi_ident,
ins_type = { it_vars = [], it_types = pi.pi_types, it_attr_vars = [],
it_context = pi.pi_context },
ins_members = members, ins_specials = pi.pi_specials, ins_pos = pi.pi_pos}
{ ins_class_index = {gi_module=NoIndex, gi_index=NoIndex},
ins_class_ident = {ci_ident=pi.pi_class, ci_arity=length pi.pi_types}, ins_ident = pi.pi_ident,
ins_type = { it_vars = [], it_types = pi.pi_types, it_attr_vars = [],
it_context = pi.pi_context },
ins_members = members, ins_specials = pi.pi_specials, ins_pos = pi.pi_pos}
MakeTypeDef name lhs rhs attr pos :==
{ td_ident = name, td_index = -1, td_arity = length lhs, td_args = lhs, td_attrs = [], td_attribute = attr,
......
implementation module syntax
import StdEnv, compare_constructor // ,RWSDebug
import scanner, general, Heap, typeproperties, utilities, compilerSwitches
import StdEnv, compare_constructor
import scanner, general, Heap, typeproperties, utilities
import syntax
instance toString Ident
......@@ -722,7 +721,7 @@ where
instance <<< ClassInstance
where
(<<<) file {ins_class,ins_type} = file <<< ins_class <<< " :: " <<< ins_type
(<<<) file {ins_class_ident,ins_type} = file <<< ins_class_ident.ci_ident <<< " :: " <<< ins_type
instance <<< (Optional a) | <<< a
where
......
......@@ -2250,10 +2250,10 @@ typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_de
ti_functions = {dcl_functions \\ {dcl_functions} <-: dcl_modules }
class_instances = { { IT_Empty \\ i <- [0 .. dec (size com_class_defs)] } \\ {com_class_defs} <-: ti_common_defs }
state = collect_imported_instances imports ti_common_defs {} ts_error class_instances hp_type_heaps.th_vars td_infos
state = collect_imported_instances imports ti_common_defs ts_error class_instances hp_type_heaps.th_vars td_infos
state = collect_qualified_imported_instances icl_qualified_imports ti_common_defs state
(_, ts_error, class_instances, th_vars, td_infos) = collect_and_check_instances (size icl_defs.com_instance_defs) ti_common_defs state
(ts_error, class_instances, th_vars, td_infos) = collect_and_check_instances (size icl_defs.com_instance_defs) ti_common_defs state
ts = { ts_fun_env = InitFunEnv fun_env_size, ts_var_heap = hp_var_heap, ts_expr_heap = hp_expression_heap, ts_generic_heap = hp_generic_heap, ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [],
ts_type_heaps = { hp_type_heaps & th_vars = th_vars }, ts_td_infos = td_infos, ts_error = ts_error, ts_fun_defs=fun_defs }
......@@ -2276,10 +2276,9 @@ typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_de
= (not type_error, fun_defs, array_and_list_instances, ti_common_defs, ti_functions,
ts_td_infos, {hp_var_heap = ts_var_heap, hp_expression_heap = ts_expr_heap, hp_type_heaps = ts_type_heaps, hp_generic_heap=ts_generic_heap },
predef_symbols, ts_error.ea_file, out)
// ---> ("typeProgram", array_inst_types)
where
collect_imported_instances imports common_defs dummy error class_instances type_var_heap td_infos
= foldlArraySt (collect_imported_instance common_defs) imports (dummy, error, class_instances, type_var_heap, td_infos)
collect_imported_instances imports common_defs error class_instances type_var_heap td_infos
= foldlArraySt (collect_imported_instance common_defs) imports (error, class_instances, type_var_heap, td_infos)
collect_qualified_imported_instances icl_qualified_imports common_defs state
= foldSt (\ (declarations,_,_) state -> foldSt (collect_imported_instance common_defs) declarations state)
......@@ -2293,16 +2292,14 @@ where
collect_and_check_instances nr_of_instances common_defs state
= iFoldSt (update_instances_of_class common_defs main_dcl_module_n) 0 nr_of_instances state
update_instances_of_class common_defs mod_index ins_index (dummy, error, class_instances, type_var_heap, td_infos)
#!{ins_class={glob_object={ds_ident={id_name}, ds_index},glob_module},ins_type={it_types},ins_pos} = common_defs.[mod_index].com_instance_defs.[ins_index]
(mod_instances, class_instances) = replace class_instances glob_module dummy
(instances, mod_instances) = replace mod_instances ds_index IT_Empty
update_instances_of_class common_defs mod_index ins_index (error, class_instances, type_var_heap, td_infos)
#!{ins_class_index={gi_module,gi_index},ins_type={it_types},ins_pos} = common_defs.[mod_index].com_instance_defs.[ins_index]
(instances, class_instances) = class_instances![gi_module,gi_index]
(error, instances) = insert it_types ins_index mod_index common_defs error instances
(_, mod_instances) = replace mod_instances ds_index instances
(dummy, class_instances) = replace class_instances glob_module mod_instances
class_instances = {class_instances & [gi_module,gi_index]=instances}
(error, type_var_heap, td_infos)
= check_types_of_instances ins_pos common_defs glob_module ds_index it_types (error, type_var_heap, td_infos)
= (dummy, error, class_instances, type_var_heap, td_infos)
= check_types_of_instances ins_pos common_defs gi_module gi_index it_types (error, type_var_heap, td_infos)
= (error, class_instances, type_var_heap, td_infos)
where
insert :: ![Type] !Index !Index !{# CommonDefs } !*ErrorAdmin !*InstanceTree -> (!*ErrorAdmin, !*InstanceTree)
insert ins_types new_ins_index new_ins_module modules error IT_Empty
......
Supports Markdown
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