diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/analunitypes.icl | 64 | ||||
| -rw-r--r-- | frontend/generics.icl | 15 |
2 files changed, 40 insertions, 39 deletions
diff --git a/frontend/analunitypes.icl b/frontend/analunitypes.icl index 695b28a..9541732 100644 --- a/frontend/analunitypes.icl +++ b/frontend/analunitypes.icl @@ -71,7 +71,7 @@ determineSignClassOfTypeDef type_index module_index td_args {tdi_classification, -> (ts_type_sign, type_var_heap, td_infos) No # signs_of_group_vars = foldSt (determine_signs_of_group_var tdi_cons_vars hio_signs) tdi_group_vars [] - -> newSignClassOfTypeDefGroup tdi_group_nr { glob_module = module_index, glob_object = type_index} + -> newSignClassOfTypeDefGroup tdi_group_nr { gi_module = module_index, gi_index = type_index} // tdi_group (signs_of_group_vars ---> ("determine_signs_of_group_var", (module_index, type_index), signs_of_group_vars, tdi_group_vars)) ci type_var_heap td_infos tdi_group signs_of_group_vars ci type_var_heap td_infos @@ -107,38 +107,38 @@ where newGroupSigns :: !Int -> *{# SignRequirements} newGroupSigns group_size = createArray group_size { sr_hio_signs = [], sr_classification = BottomSignClass, sr_type_applications = [] } -newSignClassOfTypeDefGroup :: !Int !(Global Int) ![Global Int] ![(Int, SignClassification)] !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos +newSignClassOfTypeDefGroup :: !Int !GlobalIndex ![GlobalIndex] ![(Int, SignClassification)] !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos -> *(!SignClassification, !*TypeVarHeap, !*TypeDefInfos) -newSignClassOfTypeDefGroup group_nr {glob_module,glob_object} group signs_of_group_vars ci type_var_heap td_infos +newSignClassOfTypeDefGroup group_nr {gi_module,gi_index} group signs_of_group_vars ci type_var_heap td_infos # (group_signs, type_var_heap, td_infos) = collect_sign_class_of_type_defs group_nr group signs_of_group_vars ci (newGroupSigns (length group)) type_var_heap td_infos group_signs = determine_fixed_point group_signs td_infos = update_sign_class_of_group group group_signs td_infos - (tdi=:{tdi_tmp_index},td_infos) = td_infos![glob_module].[glob_object] - = (group_signs.[tdi_tmp_index].sr_classification, type_var_heap, td_infos) + (tdi=:{tdi_index_in_group},td_infos) = td_infos![gi_module].[gi_index] + = (group_signs.[tdi_index_in_group].sr_classification, type_var_heap, td_infos) where update_sign_class_of_group group group_signs td_infos = foldSt (update_sign_class_of_type_def group_signs) group td_infos where - update_sign_class_of_type_def group_signs {glob_module,glob_object} td_infos - # (tdi=:{tdi_classification,tdi_tmp_index},td_infos) = td_infos![glob_module].[glob_object] - {sr_hio_signs, sr_classification} = group_signs.[tdi_tmp_index] + update_sign_class_of_type_def group_signs {gi_module,gi_index} td_infos + # (tdi=:{tdi_classification,tdi_index_in_group},td_infos) = td_infos![gi_module].[gi_index] + {sr_hio_signs, sr_classification} = group_signs.[tdi_index_in_group] tdi_classification = addSignClassification sr_hio_signs sr_classification tdi_classification - = { td_infos & [glob_module].[glob_object] = { tdi & tdi_classification = tdi_classification }} + = { td_infos & [gi_module].[gi_index] = { tdi & tdi_classification = tdi_classification }} collect_sign_class_of_type_defs group_nr group signs_of_group_vars ci sign_requirements type_var_heap td_infos = foldSt (collect_sign_class_of_type_def group_nr signs_of_group_vars ci) group (sign_requirements, type_var_heap, td_infos) where - collect_sign_class_of_type_def group_nr signs_of_group_vars ci {glob_module,glob_object} (sign_requirements, type_var_heap, td_infos) - # ({tdi_group_vars,tdi_kinds,tdi_tmp_index},td_infos) = td_infos![glob_module].[glob_object] - {td_name,td_args,td_rhs} = ci.[glob_module].com_type_defs.[glob_object] + collect_sign_class_of_type_def group_nr signs_of_group_vars ci {gi_module,gi_index} (sign_requirements, type_var_heap, td_infos) + # ({tdi_group_vars,tdi_kinds,tdi_index_in_group},td_infos) = td_infos![gi_module].[gi_index] + {td_name,td_args,td_rhs} = ci.[gi_module].com_type_defs.[gi_index] // (rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args (tdi_group_vars ---> ("bind_type_vars_to_signs",td_name, (glob_module, glob_object), tdi_group_vars)) tdi_kinds signs_of_group_vars ([], type_var_heap) (rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args tdi_group_vars tdi_kinds signs_of_group_vars ([], type_var_heap) - (sign_env, scs) = sign_class_of_type_def glob_module td_rhs group_nr ci + (sign_env, scs) = sign_class_of_type_def gi_module td_rhs group_nr ci {scs_type_var_heap = type_var_heap, scs_type_def_infos = td_infos, scs_rec_appls = [] } type_var_heap = foldSt restore_binds_of_type_var td_args scs.scs_type_var_heap - = ({sign_requirements & [tdi_tmp_index] = { sr_hio_signs = reverse rev_hio_signs, sr_classification = sign_env, + = ({sign_requirements & [tdi_index_in_group] = { sr_hio_signs = reverse rev_hio_signs, sr_classification = sign_env, sr_type_applications = scs.scs_rec_appls }}, type_var_heap, scs.scs_type_def_infos) determine_fixed_point sign_requirements @@ -242,9 +242,9 @@ signClassOfType (TV tv) sign use_top_sign group_nr ci scs = (sign *+ sign_class, type_class, scs) signClassOfType (TA {type_index = {glob_module, glob_object}} types) sign use_top_sign group_nr ci scs - # (td_info=:{tdi_group_nr,tdi_tmp_index,tdi_kinds}, scs) = scs!scs_type_def_infos.[glob_module].[glob_object] + # (td_info=:{tdi_group_nr,tdi_index_in_group,tdi_kinds}, scs) = scs!scs_type_def_infos.[glob_module].[glob_object] | tdi_group_nr == group_nr - = sign_class_of_type_list_of_rec_type types sign use_top_sign tdi_tmp_index ci [] scs + = sign_class_of_type_list_of_rec_type types sign use_top_sign tdi_index_in_group ci [] scs # {td_args,td_arity} = ci.[glob_module].com_type_defs.[glob_object] (sign_classes, hio_signs, scs) = collect_sign_classes_of_type_list types tdi_kinds group_nr ci scs (type_class, scs_type_var_heap, scs_type_def_infos) @@ -326,7 +326,7 @@ determinePropClassOfTypeDef type_index module_index td_args {tdi_classification, No # props_of_group_vars = foldSt (determine_props_of_group_var tdi_cons_vars hio_props) tdi_group_vars [] - -> newPropClassOfTypeDefGroup tdi_group_nr { glob_module = module_index, glob_object = type_index} + -> newPropClassOfTypeDefGroup tdi_group_nr { gi_module = module_index, gi_index = type_index} tdi_group props_of_group_vars ci type_var_heap td_infos where @@ -367,36 +367,36 @@ where newGroupProps :: !Int -> *{# PropRequirements} newGroupProps group_size = createArray group_size { pr_hio_signs = [], pr_classification = NoPropClass, pr_type_applications = [] } -newPropClassOfTypeDefGroup :: !Int !(Global Int) ![Global Int] ![(Int, PropClassification)] !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos +newPropClassOfTypeDefGroup :: !Int !GlobalIndex ![GlobalIndex] ![(Int, PropClassification)] !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos -> *(!PropClassification, !*TypeVarHeap, !*TypeDefInfos) -newPropClassOfTypeDefGroup group_nr {glob_module,glob_object} group props_of_group_vars ci type_var_heap td_infos +newPropClassOfTypeDefGroup group_nr {gi_module,gi_index} group props_of_group_vars ci type_var_heap td_infos # (group_props, type_var_heap, td_infos) = collect_prop_class_of_type_defs group_nr group props_of_group_vars ci (newGroupProps (length group)) type_var_heap td_infos group_props = determine_fixed_point group_props td_infos = update_prop_class_of_group group group_props td_infos - (tdi=:{tdi_tmp_index},td_infos) = td_infos![glob_module].[glob_object] - = (group_props.[tdi_tmp_index].pr_classification, type_var_heap, td_infos) + (tdi=:{tdi_index_in_group},td_infos) = td_infos![gi_module].[gi_index] + = (group_props.[tdi_index_in_group].pr_classification, type_var_heap, td_infos) where update_prop_class_of_group group group_props td_infos = foldSt (update_prop_class_of_type_def group_props) group td_infos where - update_prop_class_of_type_def group_props {glob_module,glob_object} td_infos - # (tdi=:{tdi_classification,tdi_tmp_index},td_infos) = td_infos![glob_module].[glob_object] - {pr_hio_signs, pr_classification} = group_props.[tdi_tmp_index] + update_prop_class_of_type_def group_props {gi_module,gi_index} td_infos + # (tdi=:{tdi_classification,tdi_index_in_group},td_infos) = td_infos![gi_module].[gi_index] + {pr_hio_signs, pr_classification} = group_props.[tdi_index_in_group] tdi_classification = addPropClassification pr_hio_signs pr_classification tdi_classification - = { td_infos & [glob_module].[glob_object] = { tdi & tdi_classification = tdi_classification }} + = { td_infos & [gi_module].[gi_index] = { tdi & tdi_classification = tdi_classification }} collect_prop_class_of_type_defs group_nr group props_of_group_vars ci prop_requirements type_var_heap td_infos = foldSt (collect_sign_class_of_type_def group_nr props_of_group_vars ci) group (prop_requirements, type_var_heap, td_infos) where - collect_sign_class_of_type_def group_nr props_of_group_vars ci {glob_module,glob_object} (prop_requirements, type_var_heap, td_infos) - # ({tdi_group_vars,tdi_kinds,tdi_tmp_index},td_infos) = td_infos![glob_module].[glob_object] - {td_name,td_args,td_rhs} = ci.[glob_module].com_type_defs.[glob_object] + collect_sign_class_of_type_def group_nr props_of_group_vars ci {gi_module,gi_index} (prop_requirements, type_var_heap, td_infos) + # ({tdi_group_vars,tdi_kinds,tdi_index_in_group},td_infos) = td_infos![gi_module].[gi_index] + {td_name,td_args,td_rhs} = ci.[gi_module].com_type_defs.[gi_index] (rev_hio_props, type_var_heap) = bind_type_vars_to_props td_args tdi_group_vars tdi_kinds props_of_group_vars ([], type_var_heap) - (prop_env, pcs) = prop_class_of_type_def glob_module td_rhs group_nr ci + (prop_env, pcs) = prop_class_of_type_def gi_module td_rhs group_nr ci {pcs_type_var_heap = type_var_heap, pcs_type_def_infos = td_infos, pcs_rec_appls = [] } type_var_heap = foldSt restore_binds_of_type_var td_args pcs.pcs_type_var_heap - = ({prop_requirements & [tdi_tmp_index] = { pr_hio_signs = reverse rev_hio_props, pr_classification = prop_env, + = ({prop_requirements & [tdi_index_in_group] = { pr_hio_signs = reverse rev_hio_props, pr_classification = prop_env, pr_type_applications = pcs.pcs_rec_appls }}, type_var_heap, pcs.pcs_type_def_infos) determine_fixed_point sign_requirements @@ -490,9 +490,9 @@ propClassOfType (TV tv) _ ci pcs = propClassOfTypeVariable tv ci pcs propClassOfType (TA {type_name,type_index = {glob_module, glob_object}} types) group_nr ci pcs - # (td_info=:{tdi_group_nr,tdi_tmp_index,tdi_kinds}, pcs) = pcs!pcs_type_def_infos.[glob_module].[glob_object] + # (td_info=:{tdi_group_nr,tdi_index_in_group,tdi_kinds}, pcs) = pcs!pcs_type_def_infos.[glob_module].[glob_object] | tdi_group_nr == group_nr - = prop_class_of_type_list_of_rec_type types tdi_tmp_index ci [] pcs + = prop_class_of_type_list_of_rec_type types tdi_index_in_group ci [] pcs # {td_args,td_arity} = ci.[glob_module].com_type_defs.[glob_object] (prop_classes, hio_props, pcs) = collect_prop_classes_of_type_list types tdi_kinds group_nr ci pcs (type_class, pcs_type_var_heap, pcs_type_def_infos) diff --git a/frontend/generics.icl b/frontend/generics.icl index fde0048..014d7ef 100644 --- a/frontend/generics.icl +++ b/frontend/generics.icl @@ -1230,12 +1230,12 @@ where get_group :: !Index !Index !*GenericState -> (!Index, !*GenericState) get_group module_index type_def_index gs=:{gs_gtd_infos} - #! gtd_info = gs_gtd_infos . [module_index, type_def_index] + #! (gtd_info,gs_gtd_infos) = gs_gtd_infos![module_index, type_def_index] #! gt = case gtd_info of (GTDI_Generic gt) -> gt _ -> abort "no generic representation for a type\n" | gt.gtr_isomap_group <> NoIndex // group index already allocated - = (gt.gtr_isomap_group, gs) + = (gt.gtr_isomap_group, { gs & gs_gtd_infos = gs_gtd_infos}) //---> ("group for type already exists", module_index, type_def_index, gt.gtr_isomap_group) # (group_index, gs=:{gs_td_infos, gs_gtd_infos}) = newGroupIndex {gs & gs_gtd_infos = gs_gtd_infos} @@ -1245,20 +1245,21 @@ where = (group_index, { gs & gs_gtd_infos = gs_gtd_infos, gs_td_infos = gs_td_infos}) //---> ("type group of type ", module_index, type_def_index, type_def_info.tdi_group_nr) - update_group :: !Index ![Global Index] !*GenericTypeDefInfos -> !*GenericTypeDefInfos +// Sjaak ... + update_group :: !Index ![GlobalIndex] !*GenericTypeDefInfos -> !*GenericTypeDefInfos update_group group_index [] gtd_infos = gtd_infos - update_group group_index [{glob_module, glob_object}:type_def_global_indexes] gtd_infos - #! (gtd_info, gtd_infos) = gtd_infos ! [glob_module, glob_object] + update_group group_index [{gi_module, gi_index}:type_def_global_indexes] gtd_infos + #! (gtd_info, gtd_infos) = gtd_infos ! [gi_module, gi_index] #! gtd_info = case gtd_info of (GTDI_Generic gt) | gt.gtr_isomap_group <> NoIndex -> abort "sanity check: updating already updated group\n" -> GTDI_Generic {gt & gtr_isomap_group = group_index } _ -> gtd_info - #! gtd_infos = {gtd_infos & [glob_module, glob_object] = gtd_info} + #! gtd_infos = {gtd_infos & [gi_module, gi_index] = gtd_info} = update_group group_index type_def_global_indexes gtd_infos - +/// ... Sjaak buildIsomapsForGenerics :: !*GenericState -> (![FunDef], ![Group], !*GenericState) buildIsomapsForGenerics gs |