Skip to content
GitLab
Commit b15604a7 authored by John van Groningen's avatar John van Groningen
Browse files

use ClassInstanceMember array for ins_members instead of DefinedSymbol array, 

call exported generic instances directly
parent 9c080226
Hide whitespace changes
Inline Side-by-side
backend/backendconvert.icl
View file @ b15604a7
......@@ -1052,12 +1052,12 @@ where
adjust_strict_list_members i members backEnd
| i<size members
# member=members.[i]
# member_name=member.ds_ident.id_name
# member_name=member.cim_ident.id_name
| size member_name>1 && member_name.[1]=='c' // && trace_tn ("member: "+++member_name)
# (ft_type,backEnd) = read_from_var_heap std_strict_lists.dcl_functions.[member.ds_index].ft_type_ptr backEnd
# (ft_type,backEnd) = read_from_var_heap std_strict_lists.dcl_functions.[member.cim_index].ft_type_ptr backEnd
= case ft_type of
VI_ExpandedType _
# backEnd=appBackEnd (BEAdjustStrictListConsInstance member.ds_index std_strict_list_module_index) backEnd
# backEnd=appBackEnd (BEAdjustStrictListConsInstance member.cim_index std_strict_list_module_index) backEnd
-> adjust_strict_list_members (i+1) members backEnd
_
-> adjust_strict_list_members (i+1) members backEnd
......@@ -1166,15 +1166,15 @@ adjustArrayFunctions array_first_instance_indices predefs main_dcl_module_n func
adjustArrayClassInstance arrayInfo {ins_members, ins_ident}
= foldStateWithIndexA (adjustMember arrayInfo) ins_members
where
adjustMember :: AdjustStdArrayInfo Int DefinedSymbol -> BackEnder
adjustMember {asai_moduleIndex, asai_mapping, asai_funs} offset {ds_index}
adjustMember :: AdjustStdArrayInfo Int ClassInstanceMember -> BackEnder
adjustMember {asai_moduleIndex, asai_mapping, asai_funs} offset {cim_index}
| asai_moduleIndex == main_dcl_module_n
= beAdjustArrayFunction asai_mapping.[offset] ds_index asai_moduleIndex
= beAdjustArrayFunction asai_mapping.[offset] cim_index asai_moduleIndex
// otherwise
= \be0 -> let (ft_type,be) = read_from_var_heap asai_funs.[ds_index].ft_type_ptr be0 in
= \be0 -> let (ft_type,be) = read_from_var_heap asai_funs.[cim_index].ft_type_ptr be0 in
(case ft_type of
VI_ExpandedType _
-> beAdjustArrayFunction asai_mapping.[offset] ds_index asai_moduleIndex
-> beAdjustArrayFunction asai_mapping.[offset] cim_index asai_moduleIndex
_
-> identity) be
......
frontend/check.icl
View file @ b15604a7
......@@ -111,19 +111,21 @@ checkSpecialsOfInstances mod_index first_mem_index [class_inst=:{ins_members,ins
-> checkSpecialsOfInstances mod_index first_mem_index class_insts next_inst_index [class_inst : all_class_instances]
all_specials new_inst_defs all_spec_types heaps predef_symbols error
where
check_and_build_members :: !Index !Index !Int {# DefinedSymbol} !Int !Index ![DefinedSymbol] ![FunType] !{#FunType} !*{! [Special]} !*Heaps !*PredefinedSymbols !*ErrorAdmin
-> (!Index, ![DefinedSymbol], ![FunType], !*{! [Special]}, !*Heaps, !*PredefinedSymbols,!*ErrorAdmin)
check_and_build_members :: !Index !Index !Int {#ClassInstanceMember} !Int !Index ![ClassInstanceMember] ![FunType] !{#FunType}
!*{![Special]} !*Heaps !*PredefinedSymbols !*ErrorAdmin
-> (!Index,![ClassInstanceMember],![FunType],
!*{![Special]},!*Heaps,!*PredefinedSymbols,!*ErrorAdmin)
check_and_build_members mod_index first_mem_index member_offset ins_members type_offset next_inst_index rev_mem_specials all_specials inst_spec_defs
all_spec_types heaps predef_symbols error
| member_offset < size ins_members
# member = ins_members.[member_offset]
member_index = member.ds_index
member_index = member.cim_index
spec_member_index = member_index - first_mem_index
# (spec_types, all_spec_types) = all_spec_types![spec_member_index]
# mem_inst = inst_spec_defs.[spec_member_index]
(SP_Substitutions specials) = mem_inst.ft_specials
env = specials !! type_offset
member = { member & ds_index = next_inst_index }
member = {member & cim_index = next_inst_index}
(spec_type, (next_inst_index, all_specials, heaps, predef_symbols,error))
= checkSpecial mod_index mem_inst member_index env (next_inst_index, all_specials, heaps, predef_symbols,error)
all_spec_types = { all_spec_types & [spec_member_index] = [ spec_type : spec_types] }
......@@ -273,7 +275,7 @@ where
// otherwise
= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
*/
check_icl_instance_members :: !Index !Index !Int !Int !{#DefinedSymbol} !{#DefinedSymbol} Ident !Position !InstanceType ![(Index,SymbolType)]
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)
......@@ -284,11 +286,11 @@ where
# ins_member = ins_members.[mem_offset]
class_member = class_members.[mem_offset]
cs = setErrorAdmin (newPosition class_ident ins_pos) cs
| ins_member.ds_ident <> class_member.ds_ident
| ins_member.cim_ident <> class_member.ds_ident
= check_icl_instance_members module_index member_mod_index (inc 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_error = checkError class_member.ds_ident "instance of class member expected" cs.cs_error}
| ins_member.ds_arity <> class_member.ds_arity
| ins_member.cim_arity <> class_member.ds_arity
= check_icl_instance_members module_index member_mod_index (inc 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_error = checkError class_member.ds_ident "used with wrong arity" cs.cs_error}
......@@ -297,7 +299,7 @@ where
= determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None type_heaps (Yes (modules, type_defs, x_main_dcl_module_n)) cs.cs_error
(st_context, var_heap) = initializeContextVariables instance_type.st_context var_heap
= 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.ds_index, { instance_type & st_context = st_context }) : instance_types ] member_defs type_defs modules var_heap type_heaps { cs & cs_error = cs_error }
[ (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})
......@@ -536,12 +538,13 @@ where
determine_dcl_instance_symbols_and_types :: !Index !Index !Index !Index !Index !Int !{#DefinedSymbol} !InstanceType !Specials Ident !Position
!w:{#MemberDef} !u:{#DclModule} !*TypeHeaps !*VarHeap !*ErrorAdmin
-> (![DefinedSymbol], ![FunType], !w:{#MemberDef}, !u:{#DclModule}, !*TypeHeaps, !*VarHeap, !.ErrorAdmin)
-> (![ClassInstanceMember], ![FunType], !w:{#MemberDef}, !u:{#DclModule}, !*TypeHeaps, !*VarHeap, !.ErrorAdmin)
determine_dcl_instance_symbols_and_types x_main_dcl_module_n first_inst_index mem_offset module_index member_mod_index class_size class_members
ins_type ins_specials class_ident ins_pos member_defs modules type_heaps var_heap cs_error
| mem_offset == class_size
= ([], [], member_defs, modules, type_heaps, var_heap, cs_error)
# class_member = class_members.[mem_offset]
class_instance_member = {cim_ident=class_member.ds_ident, cim_arity=class_member.ds_arity, cim_index = first_inst_index + mem_offset}
({me_ident,me_type,me_priority,me_class_vars}, member_defs, modules) = getMemberDef member_mod_index class_member.ds_index module_index member_defs modules
cs_error = pushErrorAdmin (newPosition class_ident ins_pos) cs_error
(instance_type, new_ins_specials, type_heaps, Yes (modules, _), cs_error)
......@@ -552,7 +555,7 @@ where
(inst_symbols, memb_inst_defs, member_defs, modules, type_heaps, var_heap, cs_error)
= determine_dcl_instance_symbols_and_types x_main_dcl_module_n first_inst_index (inc mem_offset) module_index member_mod_index
class_size class_members ins_type ins_specials class_ident ins_pos member_defs modules type_heaps var_heap cs_error
= ([{ class_member & ds_index = first_inst_index + mem_offset } : inst_symbols], [inst_def : memb_inst_defs], member_defs, modules, type_heaps, var_heap, cs_error)
= ([class_instance_member : inst_symbols], [inst_def : memb_inst_defs], member_defs, modules, type_heaps, var_heap, cs_error)
check_instance_specials :: !Index !ClassInstance !Index !Specials !Index ![ClassInstance] !*TypeHeaps !*PredefinedSymbols !*ErrorAdmin
-> (!Specials, !Index, ![ClassInstance], !*TypeHeaps, !*PredefinedSymbols,!*ErrorAdmin)
......@@ -1106,7 +1109,7 @@ renumber_member_indexes_of_class_instances (Yes icl_to_dcl_index_table) class_in
renumber_member_indexes_of_class_instances class_inst_index class_instances
| class_inst_index < size class_instances
# (class_instance,class_instances) = class_instances![class_inst_index]
# new_members = {{icl_member & ds_index=function_conversion_table.[icl_member.ds_index]} \\ icl_member<-:class_instance.ins_members}
# new_members = {{icl_member & cim_index=function_conversion_table.[icl_member.cim_index]} \\ icl_member<-:class_instance.ins_members}
# class_instances = {class_instances & [class_inst_index]={class_instance & ins_members=new_members}}
= renumber_member_indexes_of_class_instances (class_inst_index+1) class_instances
= class_instances
......@@ -1988,7 +1991,7 @@ renumber_icl_module mod_type icl_global_function_range icl_instance_range icl_ge
| mem_index < size dcl_members
# dcl_member = dcl_members.[mem_index]
# icl_member = icl_members.[mem_index]
# new_table = {new_table & [dcl_member.ds_index] = icl_member.ds_index}
# new_table = {new_table & [dcl_member.cim_index] = icl_member.cim_index}
= build_conversion_table_for_instances_of_members (inc mem_index) dcl_members icl_members new_table
= new_table
......@@ -2166,7 +2169,7 @@ check_module1 cdefs icl_global_function_range fun_defs optional_dcl_mod optional
determine_indexes_of_members [{fun_ident,fun_arity}:members] next_fun_index
#! (member_symbols, last_fun_index) = determine_indexes_of_members members (inc next_fun_index)
= ([{ds_ident = fun_ident, ds_index = next_fun_index, ds_arity = fun_arity} : member_symbols], last_fun_index)
= ([{cim_ident = fun_ident, cim_index = next_fun_index, cim_arity = fun_arity} : member_symbols], last_fun_index)
determine_indexes_of_members [] next_fun_index
= ([], next_fun_index)
......@@ -2498,13 +2501,13 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m
# 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)
make_instance_strict :: !{#DefinedSymbol} !{#Index} !Int !*{# FunDef} -> *{# FunDef}
make_instance_strict :: !{#ClassInstanceMember} !{#Index} !Int !*{# FunDef} -> *{# FunDef}
make_instance_strict instances offset_table ins_offset instance_defs
# {ds_index} = instances.[ins_offset]
(inst_def, instance_defs) = instance_defs![ds_index]
# {cim_index} = instances.[ins_offset]
(inst_def, instance_defs) = instance_defs![cim_index]
(Yes symbol_type) = inst_def.fun_type
= { instance_defs & [ds_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]
......@@ -3058,13 +3061,13 @@ checkInstancesOfDclModule mod_index (nr_of_dcl_functions_and_instances, nr_of_dc
# 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)
make_instance_strict :: !{#DefinedSymbol} !{#Index} !Int !*{# FunType} -> *{# FunType}
make_instance_strict :: !{#ClassInstanceMember} !{#Index} !Int !*{# FunType} -> *{# FunType}
make_instance_strict instances offset_table ins_offset instance_defs
# {ds_index} = instances.[ins_offset]
(inst_def, instance_defs) = instance_defs![ds_index]
# {cim_index} = instances.[ins_offset]
(inst_def, instance_defs) = instance_defs![cim_index]
(Yes symbol_type) = inst_def.ft_type
= { instance_defs & [ds_index] = { inst_def & ft_type = makeElemTypeOfArrayFunctionStrict inst_def.ft_type ins_offset offset_table } }
= {instance_defs & [cim_index] = {inst_def & ft_type = makeElemTypeOfArrayFunctionStrict inst_def.ft_type ins_offset offset_table}}
checkPredefinedDclModule :: !NumberSet ![Int] !(IntKeyHashtable SolvedImports) !Int !Bool !LargeBitvect !Bool
!(Module (CollectedDefinitions ClassInstance)) !Index !*ExplImpInfos !*{#DclModule} !*{#*{#FunDef}} !*Heaps !*CheckState
......
frontend/generics1.icl
View file @ b15604a7
......@@ -1280,7 +1280,6 @@ where
-> (!GenericCaseDef,(![ClassDef], ![MemberDef], !Index, Index), !*GenericState)
on_gencase module_index index
gencase=:{gc_ident,gc_generic, gc_type_cons} st gs=:{gs_modules, gs_td_infos}
#! (gen_def, gs_modules) = gs_modules ! [gc_generic.gi_module].com_generic_defs.[gc_generic.gi_index]
#! (kind, gs_td_infos) = get_kind_of_type_cons gc_type_cons gs_td_infos
......@@ -1665,10 +1664,8 @@ where
# (Yes class_info)
= lookupGenericClassInfo gc_kind gen_classes
#! ({class_members}, modules)
= modules ! [class_info.gci_module].com_class_defs.[class_info.gci_class]
#! (member_def, modules)
= modules ! [class_info.gci_module].com_member_defs.[class_members.[0].ds_index]
#! ({class_members}, modules) = modules![class_info.gci_module].com_class_defs.[class_info.gci_class]
#! (member_def, modules) = modules![class_info.gci_module].com_member_defs.[class_members.[0].ds_index]
#! ins_type =
{ it_vars = case gc_type_cons of
......@@ -1691,9 +1688,8 @@ where
fun_index gencase fun_type
fun_info fun_defs td_infos modules heaps error
#! (fun_info, ins_info, heaps)
= build_instance_and_member module_index class_info.gci_class gencase fun_type ins_type fun_info ins_info heaps
#! ins_info = build_exported_class_instance class_info.gci_class gencase module_index ins_type ins_info
= (dcl_functions, modules, (fun_info, ins_info, fun_defs, td_infos, heaps, error))
build_shorthand_instances module_index gc_index gencase=:{gc_kind=KindConst} st
......@@ -1817,26 +1813,22 @@ where
build_generic_info_expr heaps
= buildPredefConsApp PD_NoGenericInfo [] gs_predefs heaps
build_class_instance this_kind class_index gencase member_fun_ds ins_type (ins_index, instances)
# {gc_pos, gc_ident, gc_kind} = gencase
build_class_instance this_kind class_index gencase {ds_ident,ds_arity,ds_index} ins_type (ins_index, instances)
# {gc_pos, gc_ident, gc_kind} = gencase
#! 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_ident = class_ident
, ins_type = ins_type
, ins_members = {member_fun_ds}
, ins_members = {{cim_ident=ds_ident,cim_arity=ds_arity,cim_index=ds_index}}
, ins_specials = SP_None
, ins_pos = gc_pos
}
= (inc ins_index, [ins:instances])
get_generic_info {gi_module, gi_index} modules heaps=:{hp_generic_heap}
#! ({gen_info_ptr}, modules)
= modules ! [gi_module] . com_generic_defs . [gi_index]
#! ({gen_info_ptr}, modules) = modules![gi_module].com_generic_defs.[gi_index]
#! (gen_info, hp_generic_heap) = readPtr gen_info_ptr hp_generic_heap
= (gen_info, modules, {heaps & hp_generic_heap = hp_generic_heap})
......@@ -1906,62 +1898,21 @@ where
# group = {group_members=[fun_index]}
funs_and_groups = {funs_and_groups & fg_group_index=fg_group_index+1,fg_groups=[group:fg_groups]}
-> (funs_and_groups, fun_defs, td_infos, modules, heaps, error)
// build wrapping instance for the generic case function
build_instance_and_member :: !Index !Index !GenericCaseDef !SymbolType !InstanceType !FunsAndGroups (!Index, ![ClassInstance]) !*Heaps
-> (!FunsAndGroups, (!Index, ![ClassInstance]), !*Heaps)
build_instance_and_member module_index class_index gencase symbol_type ins_type fun_info ins_info heaps
#! (memfun_ds, fun_info, heaps)
= build_instance_member module_index gencase symbol_type fun_info heaps
#! ins_info = build_class_instance class_index gencase memfun_ds ins_type ins_info
= (fun_info, ins_info, heaps)
where
// Creates a function that just calls the generic case function
// It is needed because the instance member must be in the same
// module as the instance itself
build_instance_member module_index gencase st fun_info heaps
# {gc_ident, gc_pos, gc_type_cons, gc_kind, gc_body=GCB_FunIndex fun_index} = gencase
#! arg_var_names = ["x" +++ toString i \\ i <- [1..st.st_arity]]
#! (arg_var_exprs, arg_vars, heaps) = buildVarExprs arg_var_names heaps
#! (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty heaps.hp_expression_heap
#! heaps = {heaps & hp_expression_heap = hp_expression_heap}
#! fun_name = genericIdentToFunIdent gc_ident.id_name gc_type_cons
#! expr = App
{ app_symb =
{ symb_ident=fun_name
, symb_kind=SK_Function {glob_module=module_index, glob_object=fun_index}
}
, app_args = arg_var_exprs
, app_info_ptr = expr_info_ptr
}
#! (st, heaps) = fresh_symbol_type st heaps
#! memfun_name = genericIdentToMemberIdent gc_ident.id_name gc_kind
#! (fun_ds, fun_info)
= buildFunAndGroup memfun_name arg_vars expr (Yes st) gs_main_module gc_pos fun_info
= (fun_ds, fun_info, heaps)
build_class_instance class_index gencase member_fun_ds ins_type (ins_index, instances)
# {gc_pos, gc_ident, gc_kind} = gencase
#! class_ident = genericIdentToClassIdent gc_ident.id_name gc_kind
#! class_ds = {ds_index = class_index, ds_arity=1, ds_ident=class_ident}
build_exported_class_instance class_index {gc_ident,gc_pos,gc_type_cons,gc_kind,gc_body=GCB_FunIndex fun_index} fun_module_index ins_type (ins_index, instances)
# fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
# 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_ident = class_ident
, ins_type = ins_type
, ins_members = {member_fun_ds}
, ins_members = {{cim_ident=fun_ident,cim_arity=fun_module_index,cim_index= -1-fun_index}}
, ins_specials = SP_None
, ins_pos = gc_pos
}
= (inc ins_index, [ins:instances])
fresh_symbol_type :: !SymbolType !*Heaps -> (!SymbolType, !*Heaps)
fresh_symbol_type st heaps=:{hp_type_heaps}
# (fresh_st, hp_type_heaps) = freshSymbolType st hp_type_heaps
......@@ -1977,10 +1928,8 @@ buildGenericCaseBody ::
!FunsAndGroups, !*TypeDefInfos,!*{#CommonDefs},!*Heaps,!*ErrorAdmin)
buildGenericCaseBody main_module_index gc=:{gc_ident, gc_pos, gc_generic, gc_type_cons=TypeConsSymb {type_ident,type_index}} st predefs
funs_and_groups td_infos modules heaps error
#! (gen_def, modules)
= modules ! [gc_generic.gi_module].com_generic_defs.[gc_generic.gi_index]
#! (td_info=:{tdi_gen_rep}, td_infos)
= td_infos ! [type_index.glob_module, type_index.glob_object]
#! (gen_def, modules) = modules![gc_generic.gi_module].com_generic_defs.[gc_generic.gi_index]
#! (td_info=:{tdi_gen_rep}, td_infos) = td_infos![type_index.glob_module,type_index.glob_object]
# (gen_type_rep=:{gtr_iso, gtr_type}) = case tdi_gen_rep of
Yes x -> x
No -> abort "sanity check: no generic representation\n"
......@@ -2256,9 +2205,8 @@ where
convert_context :: !Ident !Position !TypeContext (!*Modules, !*Heaps, !*ErrorAdmin)
-> (!Bool, !TypeContext, (!*Modules, !*Heaps, !*ErrorAdmin))
convert_context fun_name fun_pos tc=:{tc_class=TCGeneric gtc=:{gtc_generic, gtc_kind, gtc_class}} (modules, heaps=:{hp_generic_heap}, error)
# ({gen_info_ptr}, modules) = modules ! [gtc_generic.glob_module] . com_generic_defs . [gtc_generic.glob_object.ds_index]
convert_context fun_name fun_pos tc=:{tc_class=TCGeneric gtc=:{gtc_generic, gtc_kind, gtc_class}} (modules, heaps=:{hp_generic_heap}, error)
# ({gen_info_ptr}, modules) = modules![gtc_generic.glob_module].com_generic_defs.[gtc_generic.glob_object.ds_index]
# ({gen_classes}, hp_generic_heap) = readPtr gen_info_ptr hp_generic_heap
# opt_class_info = lookupGenericClassInfo gtc_kind gen_classes
# (tc_class, error) = case opt_class_info of
......
frontend/overloading.dcl
View file @ b15604a7
......@@ -9,7 +9,7 @@ import syntax, check, typesupport
:: ArrayInstance =
{ ai_record :: !TypeSymbIdent
, ai_members :: !{# DefinedSymbol}
, ai_members :: !{#ClassInstanceMember}
}
:: GlobalTCInstance =
......
frontend/overloading.icl
View file @ b15604a7
......@@ -14,7 +14,7 @@ import genericsupport, compilerSwitches, type_io_common
{ rc_class :: !Global DefinedSymbol
, rc_types :: ![Type]
, rc_inst_module :: !Index
, rc_inst_members :: !{# DefinedSymbol}
, rc_inst_members :: !{#ClassInstanceMember}
, rc_red_contexts :: ![ClassApplication]
}
......@@ -398,7 +398,7 @@ where
is_unboxed_array _ predef_symbols
= False
check_unboxed_array_type :: Int Int (Global DefinedSymbol) {#DefinedSymbol} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
check_unboxed_array_type :: Int Int (Global DefinedSymbol) {#ClassInstanceMember} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
-> (ReducedContext,*SpecialInstances,(*PredefinedSymbols,*TypeHeaps), *ErrorAdmin)
check_unboxed_array_type main_dcl_module_n ins_module ins_class ins_members types=:[ _, elem_type :_] class_members defs special_instances predef_symbols_type_heaps error
# (unboxable, opt_record, predef_symbols_type_heaps) = try_to_unbox elem_type defs predef_symbols_type_heaps
......@@ -414,7 +414,7 @@ where
= ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
special_instances, predef_symbols_type_heaps, unboxError "Array" elem_type error)
where
add_record_to_array_instances :: !TypeSymbIdent !{# DefinedSymbol} !*SpecialInstances -> (!{#DefinedSymbol},!*SpecialInstances)
add_record_to_array_instances :: !TypeSymbIdent !{#DefinedSymbol} !*SpecialInstances -> (!{#ClassInstanceMember},!*SpecialInstances)
add_record_to_array_instances record members special_instances=:{si_next_array_member_index,si_array_instances}
# may_be_there = look_up_array_or_list_instance record si_array_instances
= case may_be_there of
......@@ -425,7 +425,7 @@ where
-> (inst.ai_members, { special_instances & si_next_array_member_index = si_next_array_member_index + size members,
si_array_instances = [ inst : si_array_instances ] })
check_unboxed_list_type :: Int Int (Global DefinedSymbol) {#DefinedSymbol} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
check_unboxed_list_type :: Int Int (Global DefinedSymbol) {#ClassInstanceMember} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
-> (ReducedContext,*SpecialInstances,(*PredefinedSymbols,*TypeHeaps), *ErrorAdmin)
check_unboxed_list_type main_dcl_module_n ins_module ins_class ins_members types=:[elem_type:_] class_members defs special_instances predef_symbols_type_heaps error
# (unboxable, opt_record, predef_symbols_type_heaps) = try_to_unbox elem_type defs predef_symbols_type_heaps
......@@ -441,7 +441,7 @@ where
= ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
special_instances, predef_symbols_type_heaps, unboxError "UList" elem_type error)
where
add_record_to_list_instances :: !TypeSymbIdent !{# DefinedSymbol} !*SpecialInstances -> (!{#DefinedSymbol},!*SpecialInstances)
add_record_to_list_instances :: !TypeSymbIdent !{#DefinedSymbol} !*SpecialInstances -> (!{#ClassInstanceMember},!*SpecialInstances)
add_record_to_list_instances record members special_instances=:{si_next_array_member_index,si_list_instances}
# may_be_there = look_up_array_or_list_instance record si_list_instances
= case may_be_there of
......@@ -452,7 +452,7 @@ where
-> (inst.ai_members, { special_instances & si_next_array_member_index = si_next_array_member_index + size members,
si_list_instances = [ inst : si_list_instances ] })
check_unboxed_tail_strict_list_type :: Int Int (Global DefinedSymbol) {#DefinedSymbol} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
check_unboxed_tail_strict_list_type :: Int Int (Global DefinedSymbol) {#ClassInstanceMember} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
-> (ReducedContext,*SpecialInstances,(*PredefinedSymbols,*TypeHeaps), *ErrorAdmin)
check_unboxed_tail_strict_list_type main_dcl_module_n ins_module ins_class ins_members types=:[elem_type:_] class_members defs special_instances predef_symbols_type_heaps error
# (unboxable, opt_record, predef_symbols_type_heaps) = try_to_unbox elem_type defs predef_symbols_type_heaps
......@@ -468,7 +468,7 @@ where
= ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
special_instances, predef_symbols_type_heaps, unboxError "UTSList" elem_type error)
where
add_record_to_tail_strict_list_instances :: !TypeSymbIdent !{# DefinedSymbol} !*SpecialInstances -> (!{#DefinedSymbol},!*SpecialInstances)
add_record_to_tail_strict_list_instances :: !TypeSymbIdent !{#DefinedSymbol} !*SpecialInstances -> (!{#ClassInstanceMember},!*SpecialInstances)
add_record_to_tail_strict_list_instances record members special_instances=:{si_next_array_member_index,si_tail_strict_list_instances}
# may_be_there = look_up_array_or_list_instance record si_tail_strict_list_instances
= case may_be_there of
......@@ -479,7 +479,6 @@ where
-> (inst.ai_members, { special_instances & si_next_array_member_index = si_next_array_member_index + size members,
si_tail_strict_list_instances = [ inst : si_tail_strict_list_instances ] })
try_to_unbox :: Type !{#CommonDefs} (!*PredefinedSymbols, !*TypeHeaps) -> (!Bool, !Optional TypeSymbIdent, !(!*PredefinedSymbols, !*TypeHeaps))
try_to_unbox (TB _) _ predef_symbols_type_heaps
= (True, No, predef_symbols_type_heaps)
......@@ -517,9 +516,9 @@ where
new_array_instance :: !TypeSymbIdent !{# DefinedSymbol} !Index -> ArrayInstance
new_array_instance record members next_member_index
= { ai_members = { { class_member & ds_index = next_inst_index } \\ class_member <-: members & next_inst_index <- [next_member_index .. ]},
= { ai_members = { {cim_ident=ds_ident,cim_arity=ds_arity,cim_index=next_inst_index} \\ {ds_ident,ds_arity} <-: members & next_inst_index <- [next_member_index .. ]},
ai_record = record }
disallow_abstract_types_in_dynamics :: {#CommonDefs} (Global Index) *ErrorAdmin -> *ErrorAdmin
disallow_abstract_types_in_dynamics defs type_index=:{glob_module,glob_object} error
| cPredefinedModuleIndex == glob_module
......@@ -904,7 +903,10 @@ where
find_instance_of_member :: (Global Int) Int ReducedContexts -> ((Global Int),[ClassApplication])
find_instance_of_member me_class me_offset { rcs_class_context = {rc_class, rc_inst_module, rc_inst_members, rc_red_contexts}, rcs_constraints_contexts}
| rc_class.glob_module == me_class.glob_module && rc_class.glob_object.ds_index == me_class.glob_object
= ({ glob_module = rc_inst_module, glob_object = rc_inst_members.[me_offset].ds_index }, rc_red_contexts)
# {cim_index,cim_arity} = rc_inst_members.[me_offset]
| cim_index<0
= ({ glob_module = cim_arity, glob_object = -1 - cim_index }, rc_red_contexts)
= ({ glob_module = rc_inst_module, glob_object = cim_index }, rc_red_contexts)
= find_instance_of_member_in_constraints me_class me_offset rcs_constraints_contexts
where
find_instance_of_member_in_constraints me_class me_offset [ CA_Instance rcs=:{rcs_constraints_contexts} : rcss ]
......@@ -1003,14 +1005,18 @@ where
| mem_offset == 0
= dictionary_args
# mem_offset = dec mem_offset
{ds_ident,ds_index} = ins_members.[mem_offset]
mem_expr = App { app_symb = {
symb_ident = ds_ident,
symb_kind = SK_Function { glob_object = ds_index, glob_module = mod_index }
},
app_args = class_arguments,
app_info_ptr = nilPtr }
= build_class_members mem_offset ins_members mod_index class_arguments arity [ mem_expr : dictionary_args ]
{cim_ident,cim_index,cim_arity} = ins_members.[mem_offset]
| cim_index<0
# mem_expr = App { app_symb = { symb_ident = cim_ident,
symb_kind = SK_Function {glob_object = -1 - cim_index, glob_module = cim_arity} },
app_args = class_arguments,
app_info_ptr = nilPtr }
= build_class_members mem_offset ins_members mod_index class_arguments arity [mem_expr : dictionary_args]
# mem_expr = App { app_symb = { symb_ident = cim_ident,
symb_kind = SK_Function {glob_object = cim_index, glob_module = mod_index} },
app_args = class_arguments,
app_info_ptr = nilPtr }
= build_class_members mem_offset ins_members mod_index class_arguments arity [mem_expr : dictionary_args]
build_dictionary class_symbol instance_types dictionary_args defs expr_heap ptrs
# (dict_type, dict_cons) = getDictionaryTypeAndConstructor class_symbol defs
......
frontend/syntax.dcl
View file @ b15604a7
......@@ -439,11 +439,17 @@ cNameLocationDependent :== True
{ ins_class :: !Global DefinedSymbol
, ins_ident :: !Ident
, ins_type :: !InstanceType
, ins_members :: !{# DefinedSymbol}
, ins_members :: !{#ClassInstanceMember}
, ins_specials :: !Specials
, ins_pos :: !Position
}
:: ClassInstanceMember =
{ cim_ident :: !Ident
, cim_arity :: !Int // module number if cim_index<0
, cim_index :: !Index // or -1-index
}
:: Import from_symbol =
{ import_module :: !Ident
, import_symbols :: ![from_symbol]
......
frontend/type.icl
View file @ b15604a7
implementation module type
import StdEnv
import syntax, typesupport, check, analtypes, overloading, unitype, refmark, predef, utilities, compare_constructor // , RWSDebug
import syntax, typesupport, check, analtypes, overloading, unitype, refmark, predef, utilities, compare_constructor
import compilerSwitches
import genericsupport
......@@ -187,16 +187,14 @@ where
= tv_number == var_id
containsTypeVariable var_id (arg_type --> res_type) subst
= containsTypeVariable var_id arg_type subst || containsTypeVariable var_id res_type subst
//AA..
containsTypeVariable var_id (TArrow1 arg_type) subst
= containsTypeVariable var_id arg_type subst
//..AA
containsTypeVariable var_id (TA cons_id cons_args) subst
= containsTypeVariable var_id cons_args subst
containsTypeVariable var_id (TAS cons_id cons_args _) subst
= containsTypeVariable var_id cons_args subst
containsTypeVariable var_id (type :@: types) subst
= containsTypeVariable var_id type subst || containsTypeVariable var_id types subst
containsTypeVariable var_id (TArrow1 arg_type) subst
= containsTypeVariable var_id arg_type subst
containsTypeVariable _ _ _
= False
......@@ -442,14 +440,12 @@ simplifyTypeApplication (TempV tv_number) type_args
= (True, TempCV tv_number :@: type_args)
simplifyTypeApplication (TempQV tv_number) type_args
= (True, TempQCV tv_number :@: type_args)
//AA..
simplifyTypeApplication TArrow [type1, type2]
= (True, type1 --> type2)
simplifyTypeApplication TArrow [type]
= (True, TArrow1 type)
simplifyTypeApplication (TArrow1 type1) [type2]
= (True, type1 --> type2)
//..AA
simplifyTypeApplication type type_args
= (False, type)
......@@ -495,7 +491,6 @@ unifyCVwithType is_exist tv_number type_args type=:(TAS type_cons cons_args stri
= (False, subst, heaps)
= (False, subst, heaps)
// AA..
unifyCVwithType is_exist tv_number [type_arg1, type_arg2] type=:(atype1 --> atype2) modules subst heaps
# (succ, subst, heaps) = unify (type_arg1, type_arg2) (atype1, atype2) modules subst heaps
| succ
......@@ -519,7 +514,6 @@ unifyCVwithType is_exist tv_number [] type=:(TArrow1 atype) modules subst heaps
unifyCVwithType is_exist tv_number [] TArrow modules subst heaps
= unifyTypes (toTV is_exist tv_number) TA_Multi TArrow TA_Multi modules subst heaps
// ..AA