diff options
| -rw-r--r-- | frontend/check.icl | 24 | ||||
| -rw-r--r-- | frontend/checkgenerics.icl | 129 | ||||
| -rw-r--r-- | frontend/generics1.icl | 137 | ||||
| -rw-r--r-- | frontend/parse.icl | 30 | ||||
| -rw-r--r-- | frontend/postparse.icl | 60 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 23 | ||||
| -rw-r--r-- | frontend/syntax.icl | 2 |
7 files changed, 200 insertions, 205 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 4e2ae52..be97a42 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -980,7 +980,7 @@ where # member_decl = Declaration { decl_ident = gen_member_ident, decl_pos = gen_pos, decl_kind = STE_Generic, decl_index = decl_index } = (inc decl_index, [generic_decl, member_decl : decls]) - gen_case_def_to_dcl {gc_ident, gc_pos} (decl_index, decls) + gen_case_def_to_dcl {gc_gcf=GCF gc_ident _, gc_pos} (decl_index, decls) = (inc decl_index, [Declaration {decl_ident = gc_ident, decl_pos = gc_pos, decl_kind = STE_GenericCase, decl_index = decl_index} : decls]) createCommonDefinitions :: (CollectedDefinitions ClassInstance) -> .CommonDefs; @@ -2027,13 +2027,14 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra = (new_table, icl_gencases, error) build_conversion_table_for_generic_case dcl_index dcl_gencases icl_gencases new_table error - #! icl_index = dcl_index - #! (icl_gencase, icl_gencases) = icl_gencases ! [icl_index] - #! dcl_gencase = dcl_gencases.[dcl_index] - # (GCB_FunIndex icl_fun) = icl_gencase.gc_body - # (GCB_FunIndex dcl_fun) = dcl_gencase.gc_body - #! new_table = { new_table & [dcl_fun] = icl_fun } - = (new_table, icl_gencases, error) + # icl_index = dcl_index + (icl_gencase, icl_gencases) = icl_gencases![icl_index] + dcl_gencase = dcl_gencases.[dcl_index] + = case (dcl_gencase,icl_gencase) of + ({gc_gcf=GCF _ {gcf_body = GCB_FunIndex dcl_fun}}, + {gc_gcf=GCF _ {gcf_body = GCB_FunIndex icl_fun}}) + #! new_table = { new_table & [dcl_fun] = icl_fun } + -> (new_table, icl_gencases, error) build_conversion_table_for_instances dcl_class_inst_index dcl_instances instances_conversion_table_size icl_instances new_table error | dcl_class_inst_index < instances_conversion_table_size @@ -2082,10 +2083,11 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra where renumber gencase_index gencases | gencase_index < size gencases - # (gencase=:{gc_body = GCB_FunIndex icl_index}, gencases) = gencases ! [gencase_index] + # (gencase,gencases) = gencases![gencase_index] + # {gc_gcf=GCF gc_ident gcf=:{gcf_body=GCB_FunIndex icl_index}} = gencase # dcl_index = function_conversion_table.[icl_index] - # gencase = { gencase & gc_body = GCB_FunIndex dcl_index } - # gencases = { gencases & [gencase_index] = gencase } + # gencase = {gencase & gc_gcf=GCF gc_ident {gcf & gcf_body = GCB_FunIndex dcl_index}} + # gencases = {gencases & [gencase_index] = gencase} = renumber (inc gencase_index) gencases = gencases diff --git a/frontend/checkgenerics.icl b/frontend/checkgenerics.icl index 16a039a..f9414cf 100644 --- a/frontend/checkgenerics.icl +++ b/frontend/checkgenerics.icl @@ -154,30 +154,21 @@ where = check_instances (inc index) mod_index gen_case_defs generic_defs type_defs modules heaps cs check_instance index mod_index gen_case_defs generic_defs type_defs modules heaps cs - - #! (case_def=:{gc_ident,gc_gident,gc_pos,gc_type}, gen_case_defs) = gen_case_defs ! [index] - - #! cs = pushErrorAdmin (newPosition gc_ident gc_pos) cs - - #! (gc_type, gc_type_cons, type_defs, modules, heaps, cs) - = check_instance_type mod_index gc_type type_defs modules heaps cs - - #! (generic_gi, cs) = get_generic_index gc_gident mod_index cs - | not cs.cs_error.ea_ok - # cs = popErrorAdmin cs - = (gen_case_defs, generic_defs, type_defs, modules, heaps, cs) - - #! case_def = - { case_def - & gc_generic = generic_gi - , gc_type = gc_type - , gc_type_cons = gc_type_cons - } - #! gen_case_defs = { gen_case_defs & [index] = case_def } - - #! (cs=:{cs_x}) = popErrorAdmin cs - #! cs = { cs & cs_x = {cs_x & x_needed_modules = cs_x.x_needed_modules bitor cNeedStdGeneric}} - = (gen_case_defs, generic_defs, type_defs, modules, heaps, cs) + # (case_def=:{gc_pos,gc_type,gc_gcf}, gen_case_defs) = gen_case_defs![index] + = case gc_gcf of + GCF gc_ident gcf=:{gcf_gident} + # cs = pushErrorAdmin (newPosition gc_ident gc_pos) cs + # (gc_type, gc_type_cons, type_defs, modules, heaps, cs) + = check_instance_type mod_index gc_type type_defs modules heaps cs + # (generic_gi, cs) = get_generic_index gcf_gident mod_index cs + | not cs.cs_error.ea_ok + # cs = popErrorAdmin cs + -> (gen_case_defs, generic_defs, type_defs, modules, heaps, cs) + # case_def = {case_def & gc_gcf=GCF gc_ident {gcf & gcf_generic = generic_gi}, gc_type=gc_type, gc_type_cons=gc_type_cons} + # gen_case_defs = {gen_case_defs & [index] = case_def} + # (cs=:{cs_x}) = popErrorAdmin cs + # cs = { cs & cs_x = {cs_x & x_needed_modules = cs_x.x_needed_modules bitor cNeedStdGeneric}} + -> (gen_case_defs, generic_defs, type_defs, modules, heaps, cs) check_instance_type module_index (TA type_cons []) type_defs modules heaps=:{hp_type_heaps} cs # (entry, cs_symbol_table) = readPtr type_cons.type_ident.id_info cs.cs_symbol_table @@ -213,44 +204,39 @@ where # cs_error = checkError {id_name="<>",id_info=nilPtr} "invalid generic type argument" cs_error = (ins_type, TypeConsArrow, type_defs, modules, heaps, {cs & cs_error=cs_error}) - get_generic_index :: !Ident !Index !*CheckState -> (!GlobalIndex, !*CheckState) - get_generic_index {id_name,id_info} mod_index cs=:{cs_symbol_table} - # (ste, cs_symbol_table) = readPtr id_info cs_symbol_table - # cs = {cs & cs_symbol_table = cs_symbol_table} - = case ste.ste_kind of - STE_Generic - -> ({gi_module=mod_index,gi_index = ste.ste_index}, cs) - STE_Imported STE_Generic imported_generic_module - -> ({gi_module=imported_generic_module,gi_index = ste.ste_index}, cs) - _ -> ( {gi_module=NoIndex,gi_index = NoIndex} - , {cs & cs_error = checkError id_name "generic undefined" cs.cs_error}) +get_generic_index :: !Ident !Index !*CheckState -> (!GlobalIndex, !*CheckState) +get_generic_index {id_name,id_info} mod_index cs=:{cs_symbol_table} + # (ste, cs_symbol_table) = readPtr id_info cs_symbol_table + # cs = {cs & cs_symbol_table = cs_symbol_table} + = case ste.ste_kind of + STE_Generic + -> ({gi_module=mod_index,gi_index = ste.ste_index}, cs) + STE_Imported STE_Generic imported_generic_module + -> ({gi_module=imported_generic_module,gi_index = ste.ste_index}, cs) + _ -> ( {gi_module=NoIndex,gi_index = NoIndex} + , {cs & cs_error = checkError id_name "undefined generic function" cs.cs_error}) convert_generic_instances :: !Int !Int !*{#GenericCaseDef} !*{#ClassDef} !*SymbolTable !*ErrorAdmin !*{#DclModule} -> (!.[FunDef],!*{#GenericCaseDef},!*{#ClassDef},!*SymbolTable,!*ErrorAdmin,!*{#DclModule}) - convert_generic_instances gci next_fun_index gencase_defs class_defs symbol_table error dcl_modules | gci<size gencase_defs # (gencase_def,gencase_defs)=gencase_defs![gci] = case gencase_def of - gc=:{gc_ident, gc_body=GCB_FunDef fun_def} - # gc = { gc & gc_body = GCB_FunIndex next_fun_index } + gc=:{gc_gcf=GCF gc_ident gcf=:{gcf_body=GCB_FunDef fun_def}} + # gc = {gc & gc_gcf=GCF gc_ident {gcf & gcf_body = GCB_FunIndex next_fun_index}} gencase_defs = {gencase_defs & [gci]=gc} (fun_defs,gencase_defs,class_defs,symbol_table,error,dcl_modules) = convert_generic_instances (gci+1) (next_fun_index+1) gencase_defs class_defs symbol_table error dcl_modules -> ([fun_def : fun_defs],gencase_defs,class_defs,symbol_table,error,dcl_modules) - gc=:{gc_ident,gc_pos, gc_type_cons, gc_body=GCB_None} - # fun_def = - { fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons - , fun_arity = 0 - , fun_priority = NoPrio - , fun_body = GeneratedBody - , fun_type = No - , fun_pos = gc_pos - , fun_kind = FK_Unknown - , fun_lifted = 0 - , fun_info = EmptyFunInfo - } - # gc = { gc & gc_body = GCB_FunIndex next_fun_index } + gc=:{gc_pos, gc_type_cons, gc_gcf=GCF gc_ident gcf=:{gcf_body=GCB_None}} + # fun_def = + { fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons + , fun_arity = 0, fun_priority = NoPrio + , fun_body = GeneratedBody, fun_type = No + , fun_pos = gc_pos, fun_kind = FK_Unknown + , fun_lifted = 0, fun_info = EmptyFunInfo + } + gc = {gc & gc_gcf=GCF gc_ident {gcf & gcf_body = GCB_FunIndex next_fun_index}} gencase_defs = {gencase_defs & [gci]=gc} (fun_defs,gencase_defs,class_defs,symbol_table,error,dcl_modules) = convert_generic_instances (gci+1) (next_fun_index+1) gencase_defs class_defs symbol_table error dcl_modules @@ -267,26 +253,29 @@ where create_funs gc_index fun_index gencase_defs hp_var_heap | gc_index == size gencase_defs = (fun_index, [], gencase_defs, hp_var_heap) - #! (fun, gencase_defs,hp_var_heap) - = create_fun gc_index fun_index gencase_defs hp_var_heap - #! (fun_index, funs, gencase_defs,hp_var_heap) - = create_funs (inc gc_index) (inc fun_index) gencase_defs hp_var_heap - = (fun_index, [fun:funs], gencase_defs, hp_var_heap) + # (gencase_def,gencase_defs) = gencase_defs![gc_index] + = case gencase_def of + {gc_gcf=GCF gc_ident gcf,gc_pos,gc_type_cons} + # gencase_def & gc_gcf=GCF gc_ident {gcf & gcf_body = GCB_FunIndex fun_index} + gencase_defs & [gc_index] = gencase_def + (fun,hp_var_heap) = create_gencase_function_type gc_ident gc_type_cons gc_pos hp_var_heap + #! (fun_index, funs, gencase_defs,hp_var_heap) + = create_funs (inc gc_index) (inc fun_index) gencase_defs hp_var_heap + -> (fun_index, [fun:funs], gencase_defs, hp_var_heap) - create_fun gc_index fun_index gencase_defs hp_var_heap - # (gencase_def=:{gc_ident, gc_pos, gc_type_cons}, gencase_defs) = gencase_defs ! [gc_index] - # gencase_def = { gencase_def & gc_body = GCB_FunIndex fun_index } - # gencase_defs = {gencase_defs & [gc_index] = gencase_def} - #! fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons - #! (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - #! fun = { ft_ident = fun_ident - , ft_arity = 0 - , ft_priority = NoPrio - , ft_type = {st_vars=[],st_attr_vars=[],st_arity=0,st_args=[],st_result={at_type=TE,at_attribute=TA_Multi},st_attr_env=[],st_context=[],st_args_strictness=NotStrict} - , ft_pos = gc_pos - , ft_specials = FSP_None - , ft_type_ptr = var_info_ptr } - = (fun, gencase_defs, hp_var_heap) + create_gencase_function_type {id_name} gc_type_cons gc_pos var_heap + #! fun_ident = genericIdentToFunIdent id_name gc_type_cons + #! (var_info_ptr, var_heap) = newPtr VI_Empty var_heap + #! fun = + { ft_ident = fun_ident + , ft_arity = 0 + , ft_priority = NoPrio + , ft_type = {st_vars=[],st_attr_vars=[],st_arity=0,st_args=[],st_result={at_type=TE,at_attribute=TA_Multi},st_attr_env=[],st_context=[],st_args_strictness=NotStrict} + , ft_pos = gc_pos + , ft_specials = FSP_None + , ft_type_ptr = var_info_ptr + } + = (fun, var_heap) NewEntry symbol_table symb_ptr def_kind def_index level previous :== symbol_table <:= (symb_ptr,{ ste_kind = def_kind, ste_index = def_index, ste_def_level = level, ste_previous = previous }) diff --git a/frontend/generics1.icl b/frontend/generics1.icl index 2d372b7..65b6a48 100644 --- a/frontend/generics1.icl +++ b/frontend/generics1.icl @@ -238,34 +238,36 @@ buildGenericRepresentations gs=:{gs_main_module, gs_modules, gs_funs, gs_groups} = (range, fg_bimap_functions, {gs & gs_funs = gs_funs, gs_groups = gs_groups}) where build_generic_representation - {gc_type_cons=TypeConsSymb {type_index={glob_module,glob_object},type_ident},gc_body=GCB_FunIndex fun_index,gc_ident,gc_pos} + {gc_type_cons=TypeConsSymb {type_index={glob_module,glob_object},type_ident},gc_gcf,gc_pos} (funs_and_groups, gs) # (type_def,gs) = gs!gs_modules.[glob_module].com_type_defs.[glob_object] # (td_info, gs) = gs!gs_td_infos.[glob_module,glob_object] - = case gs.gs_funs.[fun_index].fun_body of - TransformedBody _ - // does not need a generic representation - -> (funs_and_groups, gs) - GeneratedBody - // needs a generic representation - -> case type_def.td_rhs of - SynType _ - # gs_error = reportError gc_ident.id_name gc_pos ("cannot derive a generic instance for a synonym type " +++ type_def.td_ident.id_name) gs.gs_error - -> (funs_and_groups, {gs & gs_error = gs_error}) - AbstractType _ - # gs_error = reportError gc_ident.id_name gc_pos ("cannot derive a generic instance for an abstract type " +++ type_def.td_ident.id_name) gs.gs_error - -> (funs_and_groups, {gs & gs_error = gs_error}) - _ - -> case td_info.tdi_gen_rep of - Yes _ - -> (funs_and_groups, gs) // generic representation is already built - No - # type_def_gi = {gi_module=glob_module,gi_index=glob_object} - # (gen_type_rep, funs_and_groups, gs) - = buildGenericTypeRep type_def_gi funs_and_groups gs - # td_info = {td_info & tdi_gen_rep = Yes gen_type_rep} - # gs = {gs & gs_td_infos.[glob_module,glob_object] = td_info} - -> (funs_and_groups, gs) + = case gc_gcf of + GCF gc_ident {gcf_body=GCB_FunIndex fun_index} + -> case gs.gs_funs.[fun_index].fun_body of + TransformedBody _ + // does not need a generic representation + -> (funs_and_groups, gs) + GeneratedBody + // needs a generic representation + -> case type_def.td_rhs of + SynType _ + # gs_error = reportError gc_ident.id_name gc_pos ("cannot derive a generic instance for a synonym type " +++ type_def.td_ident.id_name) gs.gs_error + -> (funs_and_groups, {gs & gs_error = gs_error}) + AbstractType _ + # gs_error = reportError gc_ident.id_name gc_pos ("cannot derive a generic instance for an abstract type " +++ type_def.td_ident.id_name) gs.gs_error + -> (funs_and_groups, {gs & gs_error = gs_error}) + _ + -> case td_info.tdi_gen_rep of + Yes _ + -> (funs_and_groups, gs) // generic representation is already built + No + # type_def_gi = {gi_module=glob_module,gi_index=glob_object} + # (gen_type_rep, funs_and_groups, gs) + = buildGenericTypeRep type_def_gi funs_and_groups gs + # td_info = {td_info & tdi_gen_rep = Yes gen_type_rep} + # gs = {gs & gs_td_infos.[glob_module,glob_object] = td_info} + -> (funs_and_groups, gs) build_generic_representation _ st = st :: TypeInfos @@ -664,10 +666,10 @@ buildTypeDefInfo td=:{td_rhs = AlgType alts} td_module main_module_index predefs buildTypeDefInfo td=:{td_rhs = RecordType {rt_constructor, rt_fields}} td_module main_module_index predefs funs_and_groups modules heaps error = buildRecordTypeDefInfo td rt_constructor [x\\x<-:rt_fields] td_module main_module_index predefs funs_and_groups modules heaps error buildTypeDefInfo td=:{td_rhs = SynType type, td_ident, td_pos} td_module main_module_index predefs funs_and_groups modules heaps error - # error = reportError td_ident.id_name td_pos "cannot build constructor uinformation for a synonym type" error + # error = reportError td_ident.id_name td_pos "cannot build constructor information for a synonym type" error = buildAlgebraicTypeDefInfo td [] td_module main_module_index predefs funs_and_groups modules heaps error buildTypeDefInfo td=:{td_rhs = AbstractType _, td_ident, td_pos} td_module main_module_index predefs funs_and_groups modules heaps error - # error = reportError td_ident.id_name td_pos "cannot build constructor uinformation for an abstract type" error + # error = reportError td_ident.id_name td_pos "cannot build constructor information for an abstract type" error = buildAlgebraicTypeDefInfo td [] td_module main_module_index predefs funs_and_groups modules heaps error buildAlgebraicTypeDefInfo {td_ident, td_pos, td_arity} alts td_module main_module_index predefs @@ -1286,28 +1288,29 @@ where !GenericCaseDef (![ClassDef], ![MemberDef], !Index, Index) !*GenericState -> (!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] + gencase=:{gc_gcf=GCF gc_ident gcf=:{gcf_generic}, gc_type_cons, gc_type, gc_pos} + st gs=:{gs_modules, gs_td_infos} + #! (gen_def, gs_modules) = gs_modules![gcf_generic.gi_module].com_generic_defs.[gcf_generic.gi_index] #! (kind, gs_td_infos) = get_kind_of_type_cons gc_type_cons gs_td_infos // To generate all partially applied shorthand instances we need - // classes for all partial applications of the gc_kind and for + // classes for all partial applications of the gcf_kind and for // all the argument kinds. // Additionally, we always need classes for base cases *, *->* and *->*->* #! gs = {gs & gs_modules = gs_modules, gs_td_infos = gs_td_infos} #! subkinds = determine_subkinds kind - #! kinds = + #! kinds = [ KindConst , KindArrow [KindConst] , KindArrow [KindConst, KindConst] : subkinds] #! (st, gs) = foldSt (build_class_if_needed gen_def) kinds (st, gs) - #! gencase = {gencase & gc_kind = kind} + #! gencase = {gencase & gc_gcf = GCF gc_ident {gcf & gcf_kind = kind}} #! type_index = index_gen_cons_with_info_type gencase.gc_type gs.gs_predefs | type_index>=0 - # ({gc_body = GCB_FunIndex fun_index}) = gencase + # (GCF _ {gcf_body = GCB_FunIndex fun_index}) = gencase.gc_gcf gen_info_ptr = gen_def.gen_info_ptr fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons @@ -1493,13 +1496,13 @@ buildClassAndMember gen_def=:{gen_ident, gen_pos} gs=:{gs_tvarh} # (class_var, gs_tvarh) = freshTypeVar (makeIdent "class_var") gs_tvarh - #! (member_def, gs) + #! (member_def, gs) = build_class_member class_var {gs & gs_tvarh = gs_tvarh} #! class_def = build_class class_var member_def = (class_def, member_def, gs) where - class_ident = genericIdentToClassIdent gen_def.gen_ident.id_name kind - member_ident = genericIdentToMemberIdent gen_def.gen_ident.id_name kind + class_ident = genericIdentToClassIdent gen_def.gen_ident.id_name kind + member_ident = genericIdentToMemberIdent gen_def.gen_ident.id_name kind class_ds = {ds_index = class_index, ds_ident = class_ident, ds_arity = 1} build_class_member class_var gs=:{gs_varh} @@ -1637,9 +1640,13 @@ where (!*{#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} + {gc_gcf=GCF gc_ident {gcf_body,gcf_kind,gcf_generic}, gc_type, gc_type_cons,gc_pos} (dcl_functions, modules, (fun_info, ins_info, heaps, error)) - #! (class_info, (modules, heaps)) = get_class_for_kind gc_generic gc_kind (modules, heaps) + # fun_index + = case gcf_body of + GCB_FunIndex fun_index + -> fun_index + #! (class_info, (modules, heaps)) = get_class_for_kind gcf_generic gcf_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] @@ -1655,7 +1662,7 @@ where = 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 + #! ins_info = build_class_instance class_info.gci_class gc_ident gc_pos gcf_kind class_instance_member ins_type ins_info = (dcl_functions, modules, (fun_info, ins_info, heaps, error)) # fun_type_with_generic_info @@ -1682,9 +1689,9 @@ where (!*{#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} + gencase=:{gc_gcf=GCF gc_ident {gcf_body = GCB_FunIndex fun_index,gcf_kind,gcf_generic}, gc_type, gc_type_cons,gc_pos} (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_info, (modules, heaps)) = get_class_for_kind gcf_generic gcf_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] @@ -1700,11 +1707,11 @@ where = 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 + = update_icl_function fun_index fun_ident gencase gc_ident 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 + #! ins_info = build_class_instance class_info.gci_class gc_ident gc_pos gcf_kind class_instance_member ins_type ins_info = (dcl_functions, modules, (fun_info, ins_info, fun_defs, td_infos, heaps, error)) # fun_type_with_generic_info @@ -1714,7 +1721,7 @@ where = 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 fun_index fun_ident gencase fun_type_with_generic_info has_generic_info + = update_icl_function fun_index fun_ident gencase gc_ident fun_type_with_generic_info has_generic_info fun_info fun_defs td_infos modules heaps error = (dcl_functions, modules, (fun_info, ins_info, fun_defs, td_infos, heaps, error)) @@ -1742,26 +1749,28 @@ where build_shorthand_instances :: !Index !GenericCaseDef (!*Modules, (FunsAndGroups, (!Index, ![ClassInstance]), !*Heaps, !*ErrorAdmin)) -> (!*Modules, (FunsAndGroups, (!Index, ![ClassInstance]), !*Heaps, !*ErrorAdmin)) - build_shorthand_instances module_index gencase=:{gc_kind=KindConst} st + build_shorthand_instances module_index gencase=:{gc_gcf=GCF _ {gcf_kind=KindConst}} st = st - build_shorthand_instances module_index - 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 + build_shorthand_instances module_index gencase=:{gc_gcf=GCF gc_ident {gcf_kind=KindArrow kinds,gcf_generic,gcf_body},gc_type,gc_type_cons,gc_pos} st | is_gen_cons_without_instances gc_type gs_predefs // no shorthand instances for OBJECT, RECORD, CONS, FIELD, PAIR and EITHER = st - = foldSt build_shorthand_instance [1 .. length kinds] st + # fun_index + = case gcf_body of + GCB_FunIndex fun_index + -> fun_index + = foldSt (build_shorthand_instance fun_index) [1 .. length kinds] st where - build_shorthand_instance num_args + build_shorthand_instance fun_index num_args (modules, (fun_info, ins_info, heaps, error)) #! (consumed_kinds, rest_kinds) = splitAt num_args kinds #! this_kind = case rest_kinds of [] -> KindConst _ -> KindArrow rest_kinds - #! (class_info, (modules, heaps)) = get_class_for_kind gc_generic this_kind (modules, heaps) + #! (class_info, (modules, heaps)) = get_class_for_kind gcf_generic this_kind (modules, heaps) #! (arg_class_infos, (modules, heaps)) - = mapSt (get_class_for_kind gc_generic) consumed_kinds (modules, heaps) + = mapSt (get_class_for_kind gcf_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) @@ -1774,7 +1783,7 @@ where #! has_generic_info = is_gen_cons_without_instances 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 + = build_shorthand_instance_member module_index this_kind gcf_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)) @@ -1830,7 +1839,7 @@ where 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 + build_shorthand_instance_member module_index this_kind gcf_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 @@ -1838,7 +1847,7 @@ where #! heaps = {heaps & hp_expression_heap = hp_expression_heap} #! fun_name = genericIdentToMemberIdent gc_ident.id_name this_kind - # (gen_exprs, heaps) = mapSt (build_generic_app gc_generic gc_ident) class_infos heaps + # (gen_exprs, heaps) = mapSt (build_generic_app gcf_generic gc_ident) class_infos heaps #! arg_exprs = gen_exprs ++ arg_var_exprs # (body_expr, heaps) @@ -1899,10 +1908,10 @@ where = (dcl_functions, heaps) = (dcl_functions, heaps) - update_icl_function :: !Index !Ident !GenericCaseDef !SymbolType !Bool + update_icl_function :: !Index !Ident !GenericCaseDef !Ident !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 has_generic_info funs_and_groups fun_defs td_infos modules heaps error + update_icl_function fun_index fun_ident gencase=:{gc_type_cons,gc_pos} gc_ident 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 @@ -1934,8 +1943,8 @@ where -> (funs_and_groups, fun_defs, td_infos, modules, heaps, error) build_class_instance :: Int Ident Position TypeKind ClassInstanceMember InstanceType !(!Int,![ClassInstance]) -> (!Int,![ClassInstance]) - build_class_instance class_index gc_ident gc_pos gc_kind class_instance_member ins_type (ins_index, instances) - # class_ident = genericIdentToClassIdent gc_ident.id_name gc_kind + build_class_instance class_index gc_ident gc_pos gcf_kind class_instance_member ins_type (ins_index, instances) + # class_ident = genericIdentToClassIdent gc_ident.id_name gcf_kind # class_ds = {ds_index = class_index, ds_arity=1, ds_ident=class_ident} #! ins = { ins_class_index = {gi_module=gs_main_module, gi_index=class_index} @@ -2006,15 +2015,15 @@ is_gen_cons_without_instances _ predefs buildGenericCaseBody :: !Index // current icl module - !GenericCaseDef !Bool + !GenericCaseDef !Bool !SymbolType // type of the instance function !PredefinedSymbols !FunsAndGroups !*TypeDefInfos !*{#CommonDefs} !*Heaps !*ErrorAdmin -> (!FunctionBody, !FunsAndGroups, !*TypeDefInfos,!*{#CommonDefs},!*Heaps,!*ErrorAdmin) -buildGenericCaseBody main_module_index gc=:{gc_type_cons=TypeConsSymb {type_ident,type_index},gc_kind,gc_generic,gc_ident,gc_pos} has_generic_info st predefs +buildGenericCaseBody main_module_index gc=:{gc_type_cons=TypeConsSymb {type_ident,type_index},gc_gcf=GCF gc_ident {gcf_kind,gcf_generic},gc_pos} has_generic_info 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] + #! (gen_def, modules) = modules![gcf_generic.gi_module].com_generic_defs.[gcf_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 @@ -2034,7 +2043,7 @@ buildGenericCaseBody main_module_index gc=:{gc_type_cons=TypeConsSymb {type_iden -> (arg_vars,heaps) #! (specialized_expr, funs_and_groups, td_infos, heaps, error) - = build_specialized_expr gc_pos gc_ident gc_generic gtr_type td_args generated_arg_exprs gen_def.gen_info_ptr funs_and_groups td_infos heaps error + = build_specialized_expr gc_pos gc_ident gcf_generic gtr_type td_args generated_arg_exprs gen_def.gen_info_ptr funs_and_groups td_infos heaps error #! (body_expr, funs_and_groups, modules, td_infos, heaps, error) = adapt_specialized_expr gc_pos gen_def gen_type_rep original_arg_exprs specialized_expr funs_and_groups modules td_infos heaps error @@ -2138,7 +2147,7 @@ where #! (expr, heaps) = buildGenericApp bimap_module bimap_index bimap_ident kind [] heaps = ((non_gen_var, TVI_Expr False expr), funs_and_groups, heaps) -buildGenericCaseBody main_module_index {gc_ident,gc_pos} has_generic_info st predefs funs_and_groups td_infos modules heaps error +buildGenericCaseBody main_module_index {gc_pos,gc_gcf=GCF gc_ident _} has_generic_info st predefs funs_and_groups td_infos modules heaps error # error = reportError gc_ident.id_name gc_pos "cannot specialize to this type" error = (TransformedBody {tb_args=[], tb_rhs=EE}, funs_and_groups, td_infos, modules, heaps, error) diff --git a/frontend/parse.icl b/frontend/parse.icl index 0ad3c60..f733712 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -635,17 +635,17 @@ where # localsExpected = has_args || isGlobalContext parseContext || ~ ss_useLayout # (rhs, _, pState) = wantRhs localsExpected (ruleDefiningRhsSymbol parseContext has_args) pState - # generic_case = - { gc_ident = ident - , gc_gident = generic_ident - , gc_generic = {gi_module=NoIndex,gi_index=NoIndex} - , gc_arity = length args - , gc_pos = pos + # generic_case = + { gc_pos = pos , gc_type = type , gc_type_cons = type_cons - , gc_body = GCB_ParsedBody args rhs - , gc_kind = KindError - } + , gc_gcf = GCF ident { + gcf_gident = generic_ident, + gcf_generic = {gi_module=NoIndex,gi_index=NoIndex}, + gcf_arity = length args, + gcf_body = GCB_ParsedBody args rhs, + gcf_kind = KindError } + } = (True, PD_GenericCase generic_case, pState) wantForeignExportDefinition pState @@ -1724,16 +1724,12 @@ where # (ident, pState) = stringToIdent name (IC_GenericCase type) pState # (generic_ident, pState) = stringToIdent name IC_Generic pState # (type_cons, pState) = get_type_cons type pState - # derive_def = - { gc_ident = ident - , gc_gident = generic_ident - , gc_generic = {gi_module=NoIndex,gi_index=NoIndex} - , gc_arity = 0 - , gc_pos = pos + # derive_def = + { gc_pos = pos , gc_type = type , gc_type_cons = type_cons - , gc_body = GCB_None - , gc_kind = KindError + , gc_gcf = GCF ident {gcf_gident = generic_ident, gcf_generic = {gi_module=NoIndex,gi_index=NoIndex}, gcf_arity = 0, + gcf_body = GCB_None, gcf_kind = KindError} } = (derive_def, pState) diff --git a/frontend/postparse.icl b/frontend/postparse.icl index d47b3d0..fb733cf 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -360,10 +360,10 @@ instance collectFunctions (ScannedInstanceAndMembersR FunDef) where = ({inst & sim_members = sim_members }, ca) instance collectFunctions GenericCaseDef where - collectFunctions gc=:{gc_body=GCB_FunDef fun_def} icl_module ca + collectFunctions gc=:{gc_gcf=GCF gc_ident gcf=:{gcf_body=GCB_FunDef fun_def}} icl_module ca # (fun_def, ca) = collectFunctions fun_def icl_module ca - = ({gc & gc_body = GCB_FunDef fun_def}, ca) - collectFunctions gc=:{gc_body=GCB_None} icl_module ca + = ({gc & gc_gcf = GCF gc_ident {gcf & gcf_body=GCB_FunDef fun_def}}, ca) + collectFunctions gc=:{gc_gcf=GCF _ {gcf_body=GCB_None}} icl_module ca = (gc, ca) instance collectFunctions FunDef where @@ -1192,25 +1192,20 @@ collectFunctionBodies fun_name fun_arity fun_prio fun_kind all_defs=:[PD_Functio collectFunctionBodies fun_name fun_arity fun_prio fun_kind defs ca = ([], fun_kind, defs, ca) -collectGenericBodies :: !GenericCaseDef ![ParsedDefinition] !*CollectAdmin - -> (![ParsedBody], ![ParsedDefinition],!*CollectAdmin) -collectGenericBodies first_case all_defs=:[PD_GenericCase gc : defs] ca - | first_case.gc_ident == gc.gc_ident && first_case.gc_type_cons == gc.gc_type_cons - #! (bodies, rest_defs, ca) = collectGenericBodies first_case defs ca - # (GCB_ParsedBody args rhs) = gc.gc_body - #! body = - { pb_args = args - , pb_rhs = rhs - , pb_position = gc.gc_pos - } - | first_case.gc_arity == gc.gc_arity - = ([body : bodies ], rest_defs, ca) - #! msg = "This generic alternative has " + toString gc.gc_arity + " argument" - + (if (gc.gc_arity <> 1) "s" "")+" instead of " + toString first_case.gc_arity - #! ca = postParseError gc.gc_pos msg ca - = ([body : bodies ], rest_defs, ca) - = ([], all_defs, ca) -collectGenericBodies first_case defs ca +collectGenericBodies :: ![ParsedDefinition] !Ident !Int !TypeCons !*CollectAdmin -> (![ParsedBody], ![ParsedDefinition],!*CollectAdmin) +collectGenericBodies all_defs=:[PD_GenericCase gc=:{gc_gcf=GCF gc_ident2 gcf} : defs] gc_ident1 gcf_arity1 gc_type_cons1 ca + | gc_ident2==gc_ident1 && gc.gc_type_cons == gc_type_cons1 + #! (bodies, rest_defs, ca) = collectGenericBodies defs gc_ident1 gcf_arity1 gc_type_cons1 ca + # (GCF _ {gcf_body=GCB_ParsedBody args rhs,gcf_arity}) = gc.gc_gcf + #! body = {pb_args = args, pb_rhs = rhs, pb_position = gc.gc_pos} + | gcf_arity==gcf_arity1 + = ([body : bodies], rest_defs, ca) + #! msg = "This generic alternative has " +++ toString gcf_arity +++ " argument" + + (if (gcf_arity <> 1) "s" "")+++" instead of " +++ toString gcf_arity1 + #! ca = postParseError gc.gc_pos msg ca + = ([body : bodies], rest_defs, ca) + = ([], all_defs, ca) +collectGenericBodies defs gc_ident1 gcf_arity1 gc_type_cons1 ca = ([], defs, ca) strictness_from_fields :: ![ParsedSelector] -> StrictnessList @@ -1453,20 +1448,17 @@ reorganiseDefinitions icl_module [PD_Generic gen : defs] def_counts ca # (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca c_defs = {c_defs & def_generics = [gen : c_defs.def_generics]} = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) -reorganiseDefinitions icl_module [PD_GenericCase gc : defs] def_counts ca - #! (bodies, defs, ca) = collectGenericBodies gc defs ca +reorganiseDefinitions icl_module [PD_GenericCase gc=:{gc_type_cons} : defs] def_counts ca + # (GCF gc_ident gcf=:{gcf_body=GCB_ParsedBody args rhs,gcf_arity}) = gc.gc_gcf + #! (bodies, defs, ca) = collectGenericBodies defs gc_ident gcf_arity gc_type_cons ca #! (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca - # (GCB_ParsedBody args rhs) = gc.gc_body - # body = - { pb_args = args - , pb_rhs = rhs - , pb_position = gc.gc_pos - } - #! bodies = [body : bodies ] - #! fun_name = genericIdentToFunIdent gc.gc_ident.id_name gc.gc_type_cons - #! fun = MakeNewImpOrDefFunction fun_name gc.gc_arity bodies (FK_Function cNameNotLocationDependent) NoPrio No gc.gc_pos - #! inst = { gc & gc_body = GCB_FunDef fun } + # body = {pb_args = args, pb_rhs = rhs, pb_position = gc.gc_pos} + #! bodies = [body : bodies] + #! fun_name = genericIdentToFunIdent gc_ident.id_name gc.gc_type_cons + #! fun = MakeNewImpOrDefFunction fun_name gcf_arity bodies (FK_Function cNameNotLocationDependent) NoPrio No gc.gc_pos + # gcf & gcf_body=GCB_FunDef fun, gcf_arity=gcf_arity + #! inst = {gc & gc_gcf = GCF gc_ident gcf} #! c_defs = {c_defs & def_generic_cases = [inst : c_defs.def_generic_cases]} = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) reorganiseDefinitions icl_module [PD_Derive derive_defs : defs] def_counts=:{type_count} ca diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 24d77ec..688887d 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -432,17 +432,24 @@ cNameLocationDependent :== True | TypeConsArrow | TypeConsVar TypeVar -:: GenericCaseDef = - { gc_ident :: !Ident // name in IC_GenricCase namespace - , gc_gident :: !Ident // name in IC_Generic namespace - , gc_generic :: !GlobalIndex // index of the generic - , gc_arity :: !Int // arity of the function - , gc_pos :: !Position // position in the source file +:: GenericCaseDef = + { gc_pos :: !Position // position in the source file , gc_type :: !Type // the instance type , gc_type_cons :: !TypeCons // type constructor of the type argument - , gc_body :: !GenericCaseBody // the body function or NoIndex - , gc_kind :: !TypeKind // kind of the instance type + , gc_gcf :: !GenericCaseFunctions } + +:: GenericCaseFunctions + = GCF !Ident !GCF + +:: GCF = { + gcf_gident :: !Ident, // name in IC_GenricCase namespace + gcf_generic :: !GlobalIndex, // index of the generic + gcf_arity :: !Int, // arity of the function + gcf_body :: !GenericCaseBody, // the body function or NoIndex + gcf_kind :: !TypeKind // kind of the instance type + } + :: GenericCaseBody = GCB_None // to be generated | GCB_FunIndex !Index diff --git a/frontend/syntax.icl b/frontend/syntax.icl index fa89199..d6f1d50 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -753,7 +753,7 @@ where (<<<) file (PD_TypeSpec _ name prio st sp) = file <<< name <<< st (<<<) file (PD_Type td) = file <<< td (<<<) file (PD_Generic {gen_ident}) = file <<< "generic " <<< gen_ident - (<<<) file (PD_GenericCase {gc_ident,gc_type_cons}) = file <<< gc_ident <<< "{|" <<< gc_type_cons <<< "|}" + (<<<) file (PD_GenericCase {gc_gcf=GCF gc_ident _,gc_type_cons}) = file <<< gc_ident <<< "{|" <<< gc_type_cons <<< "|}" (<<<) file _ = file instance <<< Rhs |