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

pass generic info only to instances for OBJECT, CONS and FIELD, 

call instance functions for OBJECT, CONS and FIELD directly, with generic info
parent d4bda591
Hide whitespace changes
Inline Side-by-side
frontend/checkFunctionBodies.icl
View file @ cddeafa2
......@@ -1162,38 +1162,16 @@ checkExpression free_vars (PE_Generic id=:{id_name,id_info} kind) e_input e_stat
check_generic_expr free_vars entry=:{ste_kind=STE_Empty} id kind e_input e_state e_info cs=:{cs_error}
= (EE, free_vars, e_state, e_info, { cs & cs_error = checkError id "undefined generic" cs_error })
check_generic_expr free_vars entry id kind e_input e_state e_info cs=:{cs_error}
= (EE, free_vars, e_state, e_info, { cs & cs_error = checkError id "not a generic" cs_error })
= (EE, free_vars, e_state, e_info, { cs & cs_error = checkError id "not a generic" cs_error })
check_it free_vars mod_index gen_index id kind e_input e_state=:{es_expr_heap} e_info cs
#! (app_args, es_expr_heap, cs)
= case kind of
KindArrow [KindConst]
# (generic_info_expr, es_expr_heap, cs) = build_generic_info es_expr_heap cs
-> ([generic_info_expr], es_expr_heap, cs)
_
-> ([], es_expr_heap, cs)
#! symb_kind = SK_Generic { glob_object = gen_index, glob_module = mod_index} kind
#! symb_kind = SK_Generic {glob_object = gen_index, glob_module = mod_index} kind
#! symbol = { symb_ident = id, symb_kind = symb_kind }
#! (new_info_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
#! app = { app_symb = symbol, app_args = app_args, app_info_ptr = new_info_ptr }
#! app = { app_symb = symbol, app_args = [], app_info_ptr = new_info_ptr }
#! e_state = { e_state & es_expr_heap = es_expr_heap }
#! cs = { cs & cs_x.x_needed_modules = cs.cs_x.x_needed_modules bitor cNeedStdGeneric }
= (App app, free_vars, e_state, e_info, cs)
where
// adds NoGenericInfo argument to each generic call
build_generic_info es_expr_heap cs=:{cs_predef_symbols}
#! pds_ident = predefined_idents.[PD_NoGenericInfo]
#! ({pds_module, pds_def}, cs_predef_symbols) = cs_predef_symbols ! [PD_NoGenericInfo]
#! (new_info_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
#! app =
{ app_symb =
{ symb_ident = pds_ident
, symb_kind = SK_Constructor {glob_module=pds_module, glob_object=pds_def}
}
, app_args = []
, app_info_ptr = new_info_ptr
}
= (App app, es_expr_heap, {cs & cs_predef_symbols = cs_predef_symbols})
checkExpression free_vars (PE_TypeSignature array_kind expr) e_input e_state e_info cs
# (expr,free_vars,e_state,e_info,cs) = checkExpression free_vars expr e_input e_state e_info cs
......
frontend/checkgenerics.icl
View file @ cddeafa2
......@@ -44,6 +44,7 @@ where
# initial_info =
{ gen_classes = createArray 32 []
, gen_var_kinds = []
, gen_OBJECT_CONS_FIELD_indices = createArray 3 {ocf_module = -1,ocf_index = -1,ocf_ident={id_name="",id_info=nilPtr}}
}
# (gen_info_ptr, hp_generic_heap) = newPtr initial_info hp_generic_heap
= ( {gen_def & gen_info_ptr = gen_info_ptr},
......
frontend/generics1.icl
View file @ cddeafa2
......@@ -153,6 +153,7 @@ where
// clear stuff that might have been left over
// from compilation of other icl modules
clearTypeDefInfos :: !*{#*{#TypeDefInfo}} -> *{#*{#TypeDefInfo}}
clearTypeDefInfos td_infos
= clear_modules 0 td_infos
where
......@@ -171,6 +172,7 @@ where
#! td_infos = {td_infos & [n] = {td_info & tdi_gen_rep = No}}
= clear_td_infos (inc n) td_infos
clearGenericDefs :: !*{#CommonDefs} !*Heaps -> (!*{#CommonDefs},!*Heaps)
clearGenericDefs modules heaps
= clear_module 0 modules heaps
where
......@@ -656,7 +658,7 @@ buildTypeDefInfo1 td_module {td_ident, td_pos, td_arity} alts fields main_module
= (type_info_ds, cons_infos, funs_and_groups, modules, heaps, error)
where
build_type_def_dsc group_index cons_info_dss {ds_index, ds_ident} heaps
build_type_def_dsc group_index cons_info_dss {ds_ident} heaps
# td_name_expr = makeStringExpr td_ident.id_name
# td_arity_expr = makeIntExpr td_arity
# num_conses_expr = makeIntExpr (length alts)
......@@ -672,7 +674,7 @@ where
]
predefs heaps
# fun = makeFunction ds_ident ds_index group_index [] body_expr No main_module_index td_pos
# fun = makeFunction ds_ident group_index [] body_expr No main_module_index td_pos
= (fun, heaps)
build_cons_dsc group_index type_def_info_ds field_dsc_dss cons_info_ds cons_ds (modules, heaps)
......@@ -698,7 +700,7 @@ where
]
predefs heaps
# fun = makeFunction cons_info_ds.ds_ident cons_info_ds.ds_index group_index [] body_expr No main_module_index td_pos
# fun = makeFunction cons_info_ds.ds_ident group_index [] body_expr No main_module_index td_pos
= (fun, (modules, heaps))
where
make_prio_expr NoPrio heaps
......@@ -807,7 +809,7 @@ where
, cons_expr
]
predefs heaps
# fun = makeFunction field_dsc_ds.ds_ident field_dsc_ds.ds_index group_index [] body_expr No main_module_index td_pos
# fun = makeFunction field_dsc_ds.ds_ident group_index [] body_expr No main_module_index td_pos
= (fun, (modules, heaps))
build_cons_info cons_dsc_ds (funs_and_groups, heaps)
......@@ -1221,8 +1223,25 @@ where
, KindArrow [KindConst, KindConst]
: subkinds]
#! (st, gs) = foldSt (build_class_if_needed gen_def) kinds (st, gs)
#! gencase = {gencase & gc_kind = kind}
= (gencase, st, gs)
#! gencase = {gencase & gc_kind = kind}
#! type_index = index_OBJECT_CONS_FIELD_type gencase.gc_type gs.gs_predefs
| type_index>=0
# ({gc_body = GCB_FunIndex fun_index}) = gencase
gen_info_ptr = gen_def.gen_info_ptr
fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
ocf_index = {ocf_module=module_index,ocf_index=fun_index,ocf_ident=fun_ident}
(gen_info,generic_heap) = readPtr gen_info_ptr gs.gs_genh
gen_OBJECT_CONS_FIELD_indices = {gi\\gi<-:gen_info.gen_OBJECT_CONS_FIELD_indices}
gen_OBJECT_CONS_FIELD_indices = {gen_OBJECT_CONS_FIELD_indices & [type_index]=ocf_index}
gen_info = {gen_info & gen_OBJECT_CONS_FIELD_indices=gen_OBJECT_CONS_FIELD_indices}
generic_heap = writePtr gen_info_ptr gen_info generic_heap
gs = {gs & gs_genh=generic_heap}
= (gencase, st, gs)
= (gencase, st, gs)
build_class_if_needed :: !GenericDef !TypeKind ((![ClassDef], ![MemberDef], !Index, Index), *GenericState)
-> ((![ClassDef], ![MemberDef], !Index, Index), *GenericState)
......@@ -1309,8 +1328,7 @@ where
// limitations:
// - context restrictions on generic variables are not allowed
buildMemberType :: !GenericDef !TypeKind !TypeVar !*GenericState
-> ( !SymbolType, !*GenericState)
buildMemberType :: !GenericDef !TypeKind !TypeVar !*GenericState -> ( !SymbolType, !*GenericState)
buildMemberType gen_def=:{gen_ident,gen_pos,gen_type,gen_vars} kind class_var gs=:{gs_predefs}
#! (gen_type, gs) = add_bimap_contexts gen_def gs
......@@ -1319,15 +1337,8 @@ buildMemberType gen_def=:{gen_ident,gen_pos,gen_type,gen_vars} kind class_var gs
= 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 kind th gs_error
#! (member_st, th)
= case kind of
KindArrow [KindConst]
-> add_generic_info member_st th
_
-> (member_st, th)
= replace_generic_vars_with_class_var kind_indexed_st gatvs th gs_error
#! th = assertSymbolType member_st th // just paranoied about cleared variables
#! th = assertSymbolType gen_type th
......@@ -1372,26 +1383,17 @@ where
}
=({tc_class = tc_class, tc_types = [TV tv], tc_var = var_info_ptr}, gs_varh)
replace_generic_vars_with_class_var st atvs kind th error
replace_generic_vars_with_class_var st atvs th error
#! th = subst_gvs atvs th
//---> ("replace_generic_vars_with_class_var called for", atvs, st)
#! (new_st, th) = applySubstInSymbolType st th
= (new_st, th, error)
//---> ("replace_generic_vars_with_class_var returns", new_st)
where
subst_gvs atvs th=:{th_vars, th_attrs}
#! tvs = [atv_variable \\ {atv_variable} <- atvs ]
#! avs = [av \\ {atv_attribute=TA_Var av} <- atvs ]
# th_vars = foldSt subst_tv tvs th_vars
/*
# th_attrs = case kind of
KindConst -> case avs of
[av:avs] -> foldSt (subst_av av) avs th_attrs
[] -> th_attrs
_ -> th_attrs
*/
// all generic vars get the same uniqueness variable
# th_attrs = case avs of
[av:avs] -> foldSt (subst_av av) avs th_attrs
......@@ -1404,18 +1406,6 @@ where
subst_av av {av_info_ptr} th_attrs
= writePtr av_info_ptr (AVI_Attr (TA_Var av)) th_attrs
//---> ("(1) writePtr av_info_ptr", ptrToInt av_info_ptr, av)
// add an argument for generic info at the beginning
add_generic_info st=:{st_arity, st_args, st_args_strictness} th=:{th_vars}
#! {pds_module, pds_def} = gs_predefs.[PD_GenericInfo]
#! pds_ident = predefined_idents.[PD_GenericInfo]
#! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} pds_ident 0
#! st = {st & st_args = [makeAType (TA type_symb []) TA_Multi : st_args]
, st_arity = st_arity + 1
, st_args_strictness = insert_n_lazy_values_at_beginning 1 st_args_strictness
}
= (st, {th & th_vars = th_vars})
buildClassAndMember :: Int Int Int TypeKind GenericDef *GenericState -> (ClassDef,MemberDef,*GenericState)
buildClassAndMember
......@@ -1504,8 +1494,13 @@ convertGenericCases bimap_functions
#! first_instance_index = size main_module_instances
#! instance_info = (first_instance_index, [])
#! (gs_modules, gs_dcl_modules, (fun_info, instance_info, heaps, gs_error))
= build_exported_main_instances_in_modules 0 gs_modules gs_dcl_modules (fun_info, instance_info, heaps, gs_error)
#! first_main_instance_fun_index = fun_info.fg_fun_index
#! (gs_modules, gs_dcl_modules, (fun_info, instance_info, gs_funs, gs_td_infos, heaps, gs_error))
= build_main_instances_in_modules 0 gs_modules gs_dcl_modules (fun_info, instance_info, gs_funs, gs_td_infos, heaps, gs_error)
= build_main_instances_in_main_module gs_main_module gs_modules gs_dcl_modules (fun_info, instance_info, gs_funs, gs_td_infos, heaps, gs_error)
#! first_shorthand_function_index = fun_info.fg_fun_index
......@@ -1516,13 +1511,13 @@ convertGenericCases bimap_functions
#! gs_funs = arrayPlusRevList gs_funs new_funs
#! gs_groups = arrayPlusRevList gs_groups new_groups
#! (instance_index, new_instances) = instance_info
#! (instance_index, new_instances) = instance_info
#! com_instance_defs = arrayPlusRevList main_module_instances new_instances
#! main_common_defs = {main_common_defs & com_instance_defs = com_instance_defs}
#! gs_modules = {gs_modules & [gs_main_module] = main_common_defs}
#! instance_fun_range = {ir_from=first_fun_index, ir_to=first_shorthand_function_index}
#! instance_fun_range = {ir_from=first_main_instance_fun_index, ir_to=first_shorthand_function_index}
# {hp_expression_heap, hp_var_heap, hp_generic_heap, hp_type_heaps={th_vars, th_attrs}} = heaps
# gs = {gs & gs_modules = gs_modules
......@@ -1539,53 +1534,129 @@ convertGenericCases bimap_functions
}
= (instance_fun_range, gs)
where
build_main_instances_in_modules :: !Index
!*{#CommonDefs} !*{#DclModule} (FunsAndGroups, (!Index, ![ClassInstance]), !*{#FunDef}, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> (!*{#CommonDefs}, *{#DclModule},(FunsAndGroups, (!Index, ![ClassInstance]), !*{#FunDef}, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
build_main_instances_in_modules module_index modules dcl_modules st
build_exported_main_instances_in_modules :: !Index
!*{#CommonDefs} !*{#DclModule} !(FunsAndGroups, !(!Index, ![ClassInstance]), !*Heaps, !*ErrorAdmin)
-> (!*{#CommonDefs},!*{#DclModule},!(FunsAndGroups, !(!Index, ![ClassInstance]), !*Heaps, !*ErrorAdmin))
build_exported_main_instances_in_modules module_index modules dcl_modules st
| module_index == size modules
= (modules, dcl_modules, st)
| not (inNumberSet module_index gs_used_modules)
= build_main_instances_in_modules (inc module_index) modules dcl_modules st
| not (inNumberSet module_index gs_used_modules) || module_index==gs_main_module
= build_exported_main_instances_in_modules (module_index+1) modules dcl_modules st
#! (com_gencase_defs,modules) = modules![module_index].com_gencase_defs
| size com_gencase_defs==0
= build_exported_main_instances_in_modules (module_index+1) modules dcl_modules st
#! (dcl_functions,dcl_modules) = dcl_modules![module_index].dcl_functions
#! (dcl_functions, modules, st)
= build_main_instances_in_module module_index com_gencase_defs {x\\x<-:dcl_functions} modules st
= build_exported_main_instances_in_module module_index com_gencase_defs {x\\x<-:dcl_functions} modules st
#! dcl_modules = {dcl_modules & [module_index].dcl_functions = dcl_functions}
= build_main_instances_in_modules (inc module_index) modules dcl_modules st
= build_exported_main_instances_in_modules (module_index+1) modules dcl_modules st
where
build_main_instances_in_module module_index com_gencase_defs dcl_functions modules st
= foldArraySt (build_main_instance module_index) com_gencase_defs (dcl_functions, modules, st)
build_exported_main_instances_in_module module_index com_gencase_defs dcl_functions modules st
= foldArraySt (build_exported_main_instance module_index) com_gencase_defs (dcl_functions, modules, st)
build_exported_main_instance :: !Index !GenericCaseDef
(!*{#FunType} ,!*Modules, !(FunsAndGroups, !(!Index, ![ClassInstance]), !*Heaps, !*ErrorAdmin))
-> (!*{#FunType} ,!*Modules, !(FunsAndGroups, !(!Index, ![ClassInstance]), !*Heaps, !*ErrorAdmin))
build_exported_main_instance module_index
gencase=:{gc_ident, gc_kind, gc_generic, gc_pos, gc_type, gc_type_cons, gc_body = GCB_FunIndex fun_index}
(dcl_functions, modules, (fun_info, ins_info, heaps, error))
#! (class_info, (modules, heaps)) = get_class_for_kind gc_generic gc_kind (modules, heaps)
#! ({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]
build_main_instance :: !Index !GenericCaseDef
(!*{#FunType} ,!*Modules, (FunsAndGroups, (!Index, ![ClassInstance]), !*{#FunDef}, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
-> (!*{#FunType} ,!*Modules, (FunsAndGroups, (!Index, ![ClassInstance]), !*{#FunDef}, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
build_main_instance module_index
gencase=:{gc_ident, gc_kind, gc_generic, gc_pos, gc_type, gc_type_cons, gc_body = GCB_FunIndex fun_index}
(dcl_functions, modules, (fun_info, ins_info, fun_defs, td_infos, heaps, error))
#! (class_info, (modules, heaps)) = get_class_for_kind gc_generic gc_kind (modules, heaps)
#! ({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]
#! has_generic_info = is_OBJECT_CONS_FIELD_type gc_type gs_predefs
#! ins_type = {it_vars = instance_vars_from_type_cons gc_type_cons, it_types = [gc_type], it_attr_vars = [], it_context = []}
#! (fun_type, heaps, error)
= determine_type_of_member_instance member_def ins_type heaps error
# it_vars = case gc_type_cons of
TypeConsVar tv -> [tv]
_ -> []
#! ins_type = {it_vars = it_vars, it_types = [gc_type], it_attr_vars = [], it_context = []}
#! (fun_type, heaps, error)
= determine_type_of_member_instance member_def ins_type heaps error
#! fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
| not has_generic_info
#! (dcl_functions, heaps)
= update_dcl_function fun_index fun_ident fun_type dcl_functions heaps
# class_instance_member = {cim_ident=fun_ident,cim_arity=module_index,cim_index= -1-fun_index}
#! ins_info = build_class_instance class_info.gci_class gc_ident gc_pos gc_kind class_instance_member ins_type ins_info
= (dcl_functions, modules, (fun_info, ins_info, heaps, error))
# (fun_type_with_generic_info,type_heaps)
= add_generic_info_to_type fun_type gs_predefs heaps.hp_type_heaps
# heaps = {heaps & hp_type_heaps=type_heaps}
#! (dcl_functions, heaps)
= update_dcl_function fun_index fun_ident fun_type_with_generic_info dcl_functions heaps
#! ({ds_ident,ds_arity,ds_index}, fun_info, heaps)
= build_instance_member_with_generic_info module_index gc_ident gc_pos gc_kind fun_ident fun_index fun_type gs_predefs fun_info heaps
# class_instance_member = {cim_ident=ds_ident,cim_arity=ds_arity,cim_index=ds_index}
#! ins_info = build_class_instance class_info.gci_class gc_ident gc_pos gc_kind class_instance_member ins_type ins_info
= (dcl_functions, modules, (fun_info, ins_info, heaps, error))
build_main_instances_in_main_module :: !Index
!*{#CommonDefs} !*{#DclModule} !(FunsAndGroups, !(!Index, ![ClassInstance]), !*{#FunDef}, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> (!*{#CommonDefs},!*{#DclModule},!(FunsAndGroups, !(!Index, ![ClassInstance]), !*{#FunDef}, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
build_main_instances_in_main_module gs_main_module modules dcl_modules st
#! (com_gencase_defs,modules) = modules![gs_main_module].com_gencase_defs
| size com_gencase_defs==0
= (modules,dcl_modules,st)
#! (dcl_functions,dcl_modules) = dcl_modules![gs_main_module].dcl_functions
#! (dcl_functions, modules, st)
= foldArraySt (build_main_instance gs_main_module) com_gencase_defs ({x\\x<-:dcl_functions}, modules, st)
#! dcl_modules = {dcl_modules & [gs_main_module].dcl_functions = dcl_functions}
= (modules,dcl_modules,st)
where
build_main_instance :: !Index !GenericCaseDef
(!*{#FunType}, !*Modules, !(FunsAndGroups, !(!Index, ![ClassInstance]), !*{#FunDef}, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
-> (!*{#FunType}, !*Modules, !(FunsAndGroups, !(!Index, ![ClassInstance]), !*{#FunDef}, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
build_main_instance module_index
gencase=:{gc_ident, gc_kind, gc_generic, gc_pos, gc_type, gc_type_cons, gc_body = GCB_FunIndex fun_index}
(dcl_functions, modules, (fun_info, ins_info, fun_defs, td_infos, heaps, error))
#! (class_info, (modules, heaps)) = get_class_for_kind gc_generic gc_kind (modules, heaps)
#! ({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 = instance_vars_from_type_cons gc_type_cons, it_types = [gc_type], it_attr_vars = [], it_context = []}
#! has_generic_info = is_OBJECT_CONS_FIELD_type gc_type gs_predefs
#! (fun_type, heaps, error)
= determine_type_of_member_instance member_def ins_type heaps error
#! fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
| not has_generic_info
#! (dcl_functions, heaps)
= update_dcl_function fun_index fun_ident fun_type dcl_functions heaps
#! (fun_info, fun_defs, td_infos, modules, heaps, error)
= update_icl_function fun_index fun_ident gencase fun_type has_generic_info
fun_info fun_defs td_infos modules heaps error
# class_instance_member = {cim_ident=fun_ident,cim_arity=module_index,cim_index= -1-fun_index}
#! ins_info = build_class_instance class_info.gci_class gc_ident gc_pos gc_kind class_instance_member ins_type ins_info
= (dcl_functions, modules, (fun_info, ins_info, fun_defs, td_infos, heaps, error))
# fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
# (fun_type_with_generic_info,type_heaps)
= add_generic_info_to_type fun_type gs_predefs heaps.hp_type_heaps
# heaps = {heaps & hp_type_heaps=type_heaps}
#! (dcl_functions, heaps)
= update_dcl_function fun_index fun_ident fun_type dcl_functions heaps
#! (dcl_functions, heaps)
= update_dcl_function fun_index fun_ident fun_type_with_generic_info dcl_functions heaps
#! (fun_info, fun_defs, td_infos, modules, heaps, error)
= update_icl_function_if_needed module_index fun_index fun_ident gencase fun_type
fun_info fun_defs td_infos modules heaps error
#! (fun_info, fun_defs, td_infos, modules, heaps, error)
= update_icl_function fun_index fun_ident gencase fun_type_with_generic_info has_generic_info
fun_info fun_defs td_infos modules heaps error
#! ins_info = build_exported_class_instance class_info.gci_class gc_ident gc_pos gc_kind fun_ident fun_index module_index ins_type ins_info
#! ({ds_ident,ds_arity,ds_index}, fun_info, heaps)
= build_instance_member_with_generic_info module_index gc_ident gc_pos gc_kind fun_ident fun_index fun_type gs_predefs fun_info heaps
# class_instance_member = {cim_ident=ds_ident,cim_arity=ds_arity,cim_index=ds_index}
#! ins_info = build_class_instance class_info.gci_class gc_ident gc_pos gc_kind class_instance_member ins_type ins_info
= (dcl_functions, modules, (fun_info, ins_info, fun_defs, td_infos, heaps, error))
= (dcl_functions, modules, (fun_info, ins_info, fun_defs, td_infos, heaps, error))
instance_vars_from_type_cons (TypeConsVar tv)
= [tv]
instance_vars_from_type_cons _
= []
build_shorthand_instances_in_modules :: !Index
!*{#CommonDefs} !*{#DclModule} (FunsAndGroups, (!Index, ![ClassInstance]), !*Heaps, !*ErrorAdmin)
......@@ -1594,11 +1665,11 @@ where
| module_index == size modules
= (modules, dcl_modules, st)
| not (inNumberSet module_index gs_used_modules)
= build_shorthand_instances_in_modules (inc module_index) modules dcl_modules st
= build_shorthand_instances_in_modules (module_index+1) modules dcl_modules st
#! (com_gencase_defs,modules) = modules![module_index].com_gencase_defs
#! (modules, st)
= build_shorthand_instances_in_module module_index com_gencase_defs modules st
= build_shorthand_instances_in_modules (inc module_index) modules dcl_modules st
= build_shorthand_instances_in_modules (module_index+1) modules dcl_modules st
where
build_shorthand_instances_in_module module_index com_gencase_defs modules st
= foldArraySt (build_shorthand_instances module_index) com_gencase_defs (modules, st)
......@@ -1609,7 +1680,7 @@ where
build_shorthand_instances module_index gencase=:{gc_kind=KindConst} st
= st
build_shorthand_instances module_index
gencase=:{gc_kind=KindArrow kinds,gc_body=GCB_FunIndex fun_index,gc_type,gc_type_cons,gc_generic,gc_ident,gc_pos}
gencase=:{gc_kind=gc_kind=:KindArrow kinds,gc_body=GCB_FunIndex fun_index,gc_type,gc_type_cons,gc_generic,gc_ident,gc_pos}
st
= foldSt build_shorthand_instance [1 .. length kinds] st
where
......@@ -1626,19 +1697,19 @@ where
= mapSt (get_class_for_kind gc_generic) consumed_kinds (modules, heaps)
#! ({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, heaps)
#! (ins_type, heaps)
= build_instance_type gc_type arg_class_infos heaps
#! (fun_type, heaps, error)
= determine_type_of_member_instance member_def ins_type heaps error
# fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
#! (memfun_ds, fun_info, heaps)
= build_shorthand_instance_member module_index this_kind gencase fun_index fun_ident fun_type arg_class_infos fun_info heaps
#! ins_info
= build_class_instance this_kind class_info.gci_class gencase memfun_ds ins_type ins_info
#! has_generic_info = is_OBJECT_CONS_FIELD_type gc_type gs_predefs
#! (memfun_ds, fun_info, heaps)
= build_shorthand_instance_member module_index this_kind gc_generic has_generic_info fun_index fun_ident gc_pos fun_type arg_class_infos fun_info heaps
#! ins_info = build_shorthand_class_instance this_kind class_info.gci_class gc_ident gc_pos memfun_ds ins_type ins_info
= (modules, (fun_info, ins_info, heaps, error))
build_instance_type type class_infos heaps=:{hp_type_heaps=th=:{th_vars},hp_var_heap}
......@@ -1690,9 +1761,10 @@ where
}
= (type_context, hp_var_heap)
build_shorthand_instance_member module_index this_kind {gc_generic, gc_ident, gc_kind, gc_pos} fun_index fun_ident st class_infos fun_info heaps
# function_has_generic_info_arg = case this_kind of KindArrow [KindConst] -> True ; _ -> False
#! arg_var_names = ["x" +++ toString i \\ i <- [1..st.st_arity-(if function_has_generic_info_arg 1 0)]]
build_shorthand_instance_member :: Int TypeKind GlobalIndex Bool Int Ident Position SymbolType [GenericClassInfo] !FunsAndGroups !*Heaps
-> (!DefinedSymbol,!FunsAndGroups,!*Heaps)
build_shorthand_instance_member module_index this_kind gc_generic has_generic_info fun_index fun_ident gc_pos st class_infos fun_info heaps
#! 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
......@@ -1702,23 +1774,11 @@ where
# (gen_exprs, heaps) = mapSt (build_generic_app gc_generic gc_ident) class_infos heaps
#! arg_exprs = gen_exprs ++ arg_var_exprs
# (arg_vars,heaps)
= case function_has_generic_info_arg of
True
#! (fv_info_ptr, hp_var_heap) = newPtr VI_Empty heaps.hp_var_heap
#! fv = {fv_count = 0, fv_ident = makeIdent "geninfo", fv_info_ptr = fv_info_ptr, fv_def_level = NotALevel}
-> ([fv : arg_vars], {heaps & hp_var_heap = hp_var_heap})
False
-> (arg_vars, heaps)
# (body_expr, heaps)
= case gc_kind of
KindArrow [KindConst]
# (generic_info_expr, heaps) = buildPredefConsApp PD_NoGenericInfo [] gs_predefs heaps
-> buildFunApp2 module_index fun_index fun_ident [generic_info_expr:arg_exprs] heaps
_
-> buildFunApp2 module_index fun_index fun_ident arg_exprs heaps
= if has_generic_info
(let (generic_info_expr, heaps2) = buildPredefConsApp PD_NoGenericInfo [] gs_predefs heaps
in buildFunApp2 module_index fun_index fun_ident [generic_info_expr:arg_exprs] heaps2)
(buildFunApp2 module_index fun_index fun_ident arg_exprs heaps)
#! (st, heaps) = fresh_symbol_type st heaps
......@@ -1727,15 +1787,12 @@ where
= (fun_ds, fun_info, heaps)
where
build_generic_app {gi_module, gi_index} gc_ident {gci_kind=gci_kind=:KindArrow [KindConst]} heaps
# (generic_info_expr, heaps) = buildPredefConsApp PD_NoGenericInfo [] gs_predefs heaps
= buildGenericApp gi_module gi_index gc_ident gci_kind [generic_info_expr] heaps
build_generic_app {gi_module, gi_index} gc_ident {gci_kind} heaps
= buildGenericApp gi_module gi_index gc_ident gci_kind [] heaps
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
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}
......@@ -1745,7 +1802,7 @@ where
, ins_specials = SP_None
, ins_pos = gc_pos
}
= (inc ins_index, [ins:instances])
= (ins_index+1, [ins:instances])
get_class_for_kind :: !GlobalIndex !TypeKind !(!*{#CommonDefs},!*Heaps) -> (!GenericClassInfo,!(!*{#CommonDefs},!*Heaps))
get_class_for_kind {gi_module, gi_index} kind (modules,heaps=:{hp_generic_heap})
......@@ -1777,74 +1834,134 @@ where
= (dcl_functions, heaps)
= (dcl_functions, heaps)
update_icl_function_if_needed module_index fun_index fun_ident gencase fun_type funs_and_groups fun_defs td_infos modules heaps error
| module_index == gs_main_module // current module
= update_icl_function fun_index fun_ident gencase fun_type funs_and_groups fun_defs td_infos modules heaps error
= (funs_and_groups, fun_defs, td_infos, modules, heaps, error)
update_icl_function :: !Index !Ident !GenericCaseDef !SymbolType
update_icl_function :: !Index !Ident !GenericCaseDef !SymbolType !Bool
!FunsAndGroups !*{#FunDef} !*TypeDefInfos !*{#CommonDefs} !*Heaps !*ErrorAdmin
-> (!FunsAndGroups,!*{#FunDef},!*TypeDefInfos,!*{#CommonDefs},!*Heaps,!*ErrorAdmin)
update_icl_function fun_index fun_ident gencase=:{gc_ident,gc_type_cons,gc_kind,gc_pos} st funs_and_groups fun_defs td_infos modules heaps error
update_icl_function fun_index fun_ident gencase=:{gc_ident,gc_type_cons,gc_kind,gc_pos} st has_generic_info funs_and_groups fun_defs td_infos modules heaps error
#! (st, heaps) = fresh_symbol_type st heaps
#! (fun=:{fun_body, fun_arity}, fun_defs) = fun_defs![fun_index]
= case fun_body of
TransformedBody {tb_args,tb_rhs} // user defined case
-> case gc_kind of
KindArrow [KindConst]
| fun_arity<>st.st_arity
# error = reportError gc_ident gc_pos ("incorrect arity " +++ toString (fun_arity-1)
+++ ", expected " +++ toString (st.st_arity-1)) error
-> (funs_and_groups, fun_defs, td_infos, modules, heaps, error)
#! fun = {fun & fun_ident = fun_ident, fun_type = Yes st}
#! fun_defs = {fun_defs & [fun_index] = fun}