From 9894d082bd5a0f3c74a2874f9c9a78fd89a089a5 Mon Sep 17 00:00:00 2001 From: johnvg Date: Mon, 8 Apr 2013 09:16:09 +0000 Subject: add generic function dependencies for generic function definitions, add generic case definitions in definition modules for the types used to make the generic representation, in generic case definitions in definition modules specify what generic info and dependencies are used git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@2227 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d --- frontend/check.icl | 74 +- frontend/checkgenerics.icl | 95 +- frontend/comparedefimp.icl | 77 +- frontend/explicitimports.icl | 8 +- frontend/frontend.icl | 42 +- frontend/generics1.dcl | 5 +- frontend/generics1.icl | 2104 ++++++++++++++++++++++++++++++------------ frontend/genericsupport.dcl | 14 +- frontend/genericsupport.icl | 65 +- frontend/overloading.icl | 25 +- frontend/parse.icl | 338 ++++++- frontend/postparse.icl | 252 ++++- frontend/scanner.dcl | 1 + frontend/scanner.icl | 4 +- frontend/syntax.dcl | 71 +- frontend/syntax.icl | 10 +- frontend/transform.dcl | 14 +- frontend/transform.icl | 242 +++-- 18 files changed, 2601 insertions(+), 840 deletions(-) (limited to 'frontend') diff --git a/frontend/check.icl b/frontend/check.icl index a9e7a36..c2bb18f 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -2033,10 +2033,18 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra (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) + ({gc_gcf=GCF _ {gcf_body = GCB_FunIndex dcl_fun,gcf_generic_info=dcl_generic_info,gcf_generic_instance_deps=dcl_generic_instance_deps}}, + {gc_gcf=GCF _ {gcf_body = GCB_FunIndex icl_fun,gcf_generic_info=icl_generic_info,gcf_generic_instance_deps=icl_generic_instance_deps}}) + #! new_table = {new_table & [dcl_fun] = icl_fun} + # (icl_gencases, error) + = compare_icl_and_dcl_generic_info icl_generic_info dcl_generic_info icl_generic_instance_deps dcl_generic_instance_deps icl_gencase dcl_gencase icl_index icl_gencases error + -> (new_table, icl_gencases, error) + ({gc_gcf=GCF _ {gcf_body = GCB_FunAndMacroIndex dcl_fun dcl_macro,gcf_generic_info=dcl_generic_info,gcf_generic_instance_deps=dcl_generic_instance_deps}}, + {gc_gcf=GCF _ {gcf_body = GCB_FunIndex icl_fun,gcf_generic_info=icl_generic_info,gcf_generic_instance_deps=icl_generic_instance_deps}}) + #! new_table & [dcl_fun] = icl_fun + # (icl_gencases, error) + = compare_icl_and_dcl_generic_info icl_generic_info dcl_generic_info icl_generic_instance_deps dcl_generic_instance_deps icl_gencase dcl_gencase icl_index icl_gencases error + -> (new_table, icl_gencases, error) ({gc_gcf=GCFS dcl_gcfs},{gc_gcf=GCFS icl_gcfs}) #! new_table = build_conversion_table_for_generic_superclasses dcl_gcfs icl_gcfs new_table -> (new_table, icl_gencases, error) @@ -2044,6 +2052,62 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra // error already reported in checkGenericCaseDefs -> (new_table, icl_gencases, error) where + compare_icl_and_dcl_generic_info :: Int Int GenericInstanceDependencies GenericInstanceDependencies GenericCaseDef GenericCaseDef Int + *{#GenericCaseDef} *ErrorAdmin -> (!*{#GenericCaseDef},!*ErrorAdmin) + compare_icl_and_dcl_generic_info icl_generic_info dcl_generic_info icl_generic_instance_deps dcl_generic_instance_deps icl_gencase dcl_gencase icl_index icl_gencases error + | icl_generic_info<>dcl_generic_info + # {gc_gcf=GCF gcf_ident _,gc_type_cons,gc_pos} = icl_gencase + error_message = "different generic info for "+++type_cons_to_string gc_type_cons+++" in implementation and definition module" + error = checkErrorWithIdentPos (newPosition gcf_ident gc_pos) error_message error + = (icl_gencases, error) + = case (dcl_generic_instance_deps,icl_generic_instance_deps) of + (AllGenericInstanceDependencies,AllGenericInstanceDependencies) + -> (icl_gencases, error) + (AllGenericInstanceDependencies,_) + # (GCF gcf_ident gcf) = icl_gencase.gc_gcf + # icl_gencases & [icl_index].gc_gcf = GCF gcf_ident {gcf & gcf_generic_instance_deps=AllGenericInstanceDependencies} + -> (icl_gencases, error) + (_,AllGenericInstanceDependencies) + # {gc_gcf=GCF gcf_ident _,gc_type_cons,gc_pos} = dcl_gencase + error_message = "restricting dependent generic functions not allow for type "+++type_cons_to_string gc_type_cons + error = checkErrorWithIdentPos (newPosition gcf_ident gc_pos) error_message error + -> (icl_gencases, error) + (GenericInstanceDependencies dcl_n_deps dcl_deps,GenericInstanceUsedArgs icl_n_deps icl_deps) + | icl_n_deps==dcl_n_deps + | icl_deps==dcl_deps + # generic_instance_deps = GenericInstanceDependencies icl_n_deps icl_deps + # (GCF gcf_ident gcf) = icl_gencase.gc_gcf + # icl_gencases & [icl_index].gc_gcf = GCF gcf_ident {gcf & gcf_generic_instance_deps=generic_instance_deps} + -> (icl_gencases, error) + -> (icl_gencases, different_restriction_error icl_gencase error) + | icl_n_deps>dcl_n_deps + # icl_deps = icl_deps bitand ((1< (icl_gencases, error) + -> (icl_gencases, different_restriction_error icl_gencase error) + -> (icl_gencases, different_restriction_error icl_gencase error) + (GenericInstanceDependencies dcl_n_deps dcl_deps,GenericInstanceDependencies icl_n_deps icl_deps) + | icl_n_deps==dcl_n_deps && icl_deps==dcl_deps + -> (icl_gencases, error) + -> (icl_gencases, different_restriction_error icl_gencase error) + (GenericInstanceUsedArgs dcl_n_deps dcl_deps, GenericInstanceUsedArgs icl_n_deps icl_deps) + | dcl_n_deps==icl_n_deps && dcl_deps==icl_deps + -> (icl_gencases, error) + -> (icl_gencases, different_restriction_error icl_gencase error) + where + type_cons_to_string (TypeConsSymb {type_ident}) = toString type_ident + type_cons_to_string (TypeConsBasic bt) = toString bt + type_cons_to_string TypeConsArrow = "(->)" + type_cons_to_string (TypeConsVar tv) = tv.tv_ident.id_name + + different_restriction_error icl_gencase error + # {gc_gcf=GCF gcf_ident _,gc_type_cons,gc_pos} = icl_gencase + error_message = "different restriction of dependent generic functions for "+++type_cons_to_string gc_type_cons+++" in implementation and definition module" + = checkErrorWithIdentPos (newPosition gcf_ident gc_pos) error_message error + build_conversion_table_for_generic_superclasses [!{gcf_body=GCB_FunIndex dcl_fun}:dcl_gcfs!] [!{gcf_body=GCB_FunIndex icl_fun}:icl_gcfs!] new_table # new_table = {new_table & [dcl_fun] = icl_fun} = build_conversion_table_for_generic_superclasses dcl_gcfs icl_gcfs new_table @@ -2107,7 +2171,7 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra {gc_gcf=GCFS gcfs} # gcfs = renumber_gcfs gcfs function_conversion_table # gencase = {gencase & gc_gcf=GCFS gcfs} - # gencases = {gencases & [gencase_index] = gencase} + # gencases = {gencases & [gencase_index] = gencase} -> renumber_gencase_members (gencase_index+1) gencases = gencases diff --git a/frontend/checkgenerics.icl b/frontend/checkgenerics.icl index d035c89..6f0345e 100644 --- a/frontend/checkgenerics.icl +++ b/frontend/checkgenerics.icl @@ -1,6 +1,6 @@ implementation module checkgenerics -import syntax,checksupport,checktypes,genericsupport,compare_types,typesupport +import syntax,checksupport,checktypes,genericsupport,explicitimports,compare_types,typesupport checkGenericDefs :: !Index !(Optional (CopiedDefinitions, Int)) !*{#GenericDef} !*{#CheckedTypeDef} !*{#ClassDef} !*{#DclModule} !*Heaps !*CheckState @@ -35,6 +35,8 @@ where # (gen_def, type_defs, class_defs, modules, heaps, cs) = check_generic_type gen_def mod_index type_defs class_defs modules heaps cs + # (gen_def, gen_defs, modules, cs) = check_generic_dependencies index mod_index gen_ident gen_def gen_defs modules cs + # gen_defs = {gen_defs & [index] = gen_def} # (cs=:{cs_x}) = popErrorAdmin cs #! cs = { cs & cs_x = {cs_x & x_needed_modules = cs_x.x_needed_modules bitor cNeedStdGeneric}} @@ -44,7 +46,11 @@ where # initial_info = { gen_classes = createArray 32 [] , gen_var_kinds = [] - , gen_rep_conses = createArray 4 {gcf_module = -1,gcf_index = -1,gcf_ident={id_name="",id_info=nilPtr}} + , gen_rep_conses + = createArray 7 {grc_module = -1, grc_index = GCB_None, grc_local_fun_index = -1, grc_generic_info = -1, + grc_generic_instance_deps = AllGenericInstanceDependencies, + grc_ident={id_name="",id_info=nilPtr}, + grc_optional_fun_type=No} } # (gen_info_ptr, hp_generic_heap) = newPtr initial_info hp_generic_heap = ( {gen_def & gen_info_ptr = gen_info_ptr}, @@ -140,6 +146,70 @@ where -> (th_vars, cs_error) _ -> abort ("check_no_generic_vars_in_contexts: wrong TVI" ---> (tv, tv_info)) + // TODO: TvN: check that a generic function also includes all the dependencies of its dependencies, and so on. This is required when + // deriving generic functions since then the generated function needs to have all the arguments to all the generic functions called. In a + // that process collapses all dependencies. + check_generic_dependencies index mod_index gen_ident gen_def=:{gen_vars, gen_deps} gen_defs modules cs + # (gen_deps, (gen_defs, modules, cs)) = foldSt check_dependency gen_deps ([], (gen_defs, modules, cs)) + = ({gen_def & gen_deps = reverse gen_deps}, gen_defs, modules, cs) + where + check_dependency gen_dep=:{gd_ident, gd_vars} (acc, (gen_defs, modules, cs)) + # (gen_dep, cs) = resolve_dependency_index gen_dep cs + | gen_dep.gd_index.gi_index < 0 + = (acc, (gen_defs, modules, cs)) + # (gen_dep=:{gd_index, gd_vars}, gen_defs, modules, cs) = check_dependency_vars gen_dep gen_defs modules cs + | gd_index.gi_index == index && gd_index.gi_module == mod_index && gd_vars == gen_vars + = (acc, (gen_defs, modules, check_generic_dep_error gd_ident "already implicitly depends on itself" cs)) + | isMember gen_dep acc + = (acc, (gen_defs, modules, check_generic_dep_error gd_ident "duplicate generic dependency" cs)) + // TODO: TvN: This check is to prevent duplicate dependencies with different generic dependency variables + // See functions: generics1.build_specialized_expr and generics1.specialize_type_var + | isMember gen_dep.gd_index [gd_index \\ {gd_index} <- acc] + = (acc, (gen_defs, modules, check_generic_dep_error gd_ident "dependency occurs multiple times with different generic dependency variables, but only one occurrence of the same generic function as a dependency is currently allowed" cs)) + = ([gen_dep:acc], (gen_defs, modules, cs)) + + resolve_dependency_index gen_dep=:{gd_ident} cs + = case gd_ident of + Ident ident + # (index, cs) = get_generic_index ident mod_index cs + = ({gen_dep & gd_index = index}, cs) + QualifiedIdent mod_ident name + # (found, {decl_kind, decl_ident, decl_index}, cs) = search_qualified_ident mod_ident name GenericNameSpaceN cs + | not found + = (gen_dep, check_generic_dep_error gd_ident "generic dependency not defined" cs) + = case decl_kind of + STE_Imported STE_Generic generic_module + -> ({gen_dep & gd_ident = Ident decl_ident, gd_index = {gi_module = generic_module, gi_index = decl_index}}, cs) + _ + -> (gen_dep, check_generic_dep_error gd_ident "not a generic function" cs) + + check_dependency_vars gen_dep=:{gd_ident, gd_vars} gen_defs modules cs + # (gen_defs, modules, cs) = check_dependency_arity gen_dep gen_defs modules cs + # (gd_vars, gd_nums, cs) = mapY2St (resolve_dependency_var 0 gen_vars) gd_vars cs + = ({gen_dep & gd_vars = gd_vars, gd_nums = gd_nums}, gen_defs, modules, cs) + where + check_dependency_arity {gd_ident, gd_index, gd_vars} gen_defs modules cs + # (gen_def, gen_defs, modules) = lookup_dependency_def gd_index gen_defs modules + | not (length gd_vars == length gen_def.gen_vars) + = (gen_defs, modules, check_generic_dep_error gd_ident "incorrect dependency variable arity" cs) + = (gen_defs, modules, cs) + where + lookup_dependency_def {gi_module, gi_index} gen_defs modules + | gi_module == mod_index + # (gen_def, gen_defs) = gen_defs![gi_index] + = (gen_def, gen_defs, modules) + # (gen_def, modules) = modules![gi_module].dcl_common.com_generic_defs.[gi_index] + = (gen_def, gen_defs, modules) + + resolve_dependency_var num [] var cs + = (var, -1, check_generic_dep_error gd_ident "generic dependency is indexed by an unbound generic variable" cs) + resolve_dependency_var num [gen_var:gen_vars] var cs + | var.tv_ident.id_name == gen_var.tv_ident.id_name + = (gen_var, num, cs) + = resolve_dependency_var (inc num) gen_vars var cs + + check_generic_dep_error ident msg cs = {cs & cs_error = checkError ident msg cs.cs_error} + checkGenericCaseDefs :: !Index !*{#GenericCaseDef} !*{#GenericDef} !u:{#CheckedTypeDef} !*{#ClassDef} !*{#DclModule} !*Heaps !*CheckState -> (!*{#GenericCaseDef},!*{#GenericDef},!u:{#CheckedTypeDef},!*{#ClassDef},!*{#DclModule},!.Heaps,!.CheckState) checkGenericCaseDefs mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs @@ -154,7 +224,7 @@ where = (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs) # (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs) = check_generic_case_def index mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs - = check_generic_case_defs (inc index) mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs + = check_generic_case_defs (inc index) mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs check_generic_case_def index mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs # (case_def=:{gc_pos,gc_type,gc_gcf}, gen_case_defs) = gen_case_defs![index] @@ -220,8 +290,10 @@ where gcf_gident = ds_ident, gcf_generic = {gi_module=NoIndex,gi_index=NoIndex}, gcf_arity = 0, + gcf_generic_info = 0, gcf_body = GCB_None, - gcf_kind = KindError } + gcf_kind = KindError, + gcf_generic_instance_deps = AllGenericInstanceDependencies } # gcfs = convert_generic_contexts type_contexts = [!gcf:gcfs!] convert_generic_contexts [_:type_contexts] @@ -345,8 +417,10 @@ convert_generic_instances gci next_fun_index gencase_defs class_defs symbol_tabl gcf_gident = ds_ident, gcf_generic = {gi_module=NoIndex,gi_index=NoIndex}, gcf_arity = 0, + gcf_generic_info = 0, gcf_body = GCB_FunIndex next_fun_index, - gcf_kind = KindError } + gcf_kind = KindError, + gcf_generic_instance_deps = AllGenericInstanceDependencies } # (gcfs,next_fun_index,new_fun_defs) = convert_generic_contexts type_contexts type_cons pos (next_fun_index+1) new_fun_defs = ([!gcf:gcfs!],next_fun_index,[fun_def:new_fun_defs]) convert_generic_contexts [_:type_contexts] type_cons pos next_fun_index new_fun_defs @@ -366,12 +440,19 @@ where = (fun_index, [], gencase_defs, hp_var_heap) # (gencase_def,gencase_defs) = gencase_defs![gc_index] = case gencase_def of + {gc_gcf=GCF gc_ident gcf=:{gcf_body=GCB_MacroIndex macro_index},gc_pos,gc_type_cons} + # gencase_def & gc_gcf=GCF gc_ident {gcf & gcf_body = GCB_FunAndMacroIndex fun_index macro_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 (gc_index+1) (fun_index+1) gencase_defs hp_var_heap + -> (fun_index, [fun:funs], gencase_defs, hp_var_heap) {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 (gc_index+1) (inc fun_index) gencase_defs hp_var_heap + (fun_index,funs,gencase_defs,hp_var_heap) + = create_funs (gc_index+1) (fun_index+1) gencase_defs hp_var_heap -> (fun_index, [fun:funs], gencase_defs, hp_var_heap) {gc_gcf=GCFS gcfs,gc_pos,gc_type_cons} # (gcfs,superclass_funs,fun_index,hp_var_heap) diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index a016b40..4173e51 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -242,13 +242,18 @@ where # (ok1, comp_st) = compare dcl_generic_def.gen_type icl_generic_def.gen_type comp_st # (ok2, comp_st) = compare dcl_generic_def.gen_vars icl_generic_def.gen_vars comp_st - | ok1 && ok2 + # (ok3, comp_st) = compare dcl_generic_def.gen_deps icl_generic_def.gen_deps comp_st + | ok1 && ok2 && ok3 = (icl_generic_defs, comp_st) # comp_error = compareError generic_def_error (newPosition icl_generic_def.gen_ident icl_generic_def.gen_pos) comp_st.comp_error = (icl_generic_defs, { comp_st & comp_error = comp_error }) | otherwise = (icl_generic_defs, comp_st) +collectGenericCaseDefMacros :: !{#GenericCaseDef} -> [(GenericCaseBody,Int)] +collectGenericCaseDefMacros dcl_generic_case_defs + = [(gcf_body,gcf_generic_info) \\ {gc_gcf=GCF _ {gcf_body=gcf_body=:GCB_FunAndMacroIndex _ _,gcf_generic_info}} <-: dcl_generic_case_defs] + class compare a :: !a !a !*CompareState -> (!Bool, !*CompareState) instance compare (a,b) | compare a & compare b @@ -413,6 +418,12 @@ where = compare dcl_tc.tc_types icl_tc.tc_types comp_st = (False, comp_st) +instance compare GenericDependency +where + compare dcl_gd icl_gd comp_st + | dcl_gd.gd_index == icl_gd.gd_index = compare dcl_gd.gd_vars icl_gd.gd_vars comp_st + = (False, comp_st) + initialyseTypeVars [{tv_info_ptr=dcl_tv_info_ptr}:dcl_type_vars] [{tv_info_ptr=icl_tv_info_ptr}:icl_type_vars] type_var_heap # type_var_heap = type_var_heap <:= (icl_tv_info_ptr, TVI_TypeVar dcl_tv_info_ptr) <:= (dcl_tv_info_ptr, TVI_TypeVar icl_tv_info_ptr) = initialyseTypeVars dcl_type_vars icl_type_vars type_var_heap @@ -451,6 +462,7 @@ initialyseAttributeVars [] [] type_var_heap AllowFirstMoreStrictness:==1; FirstHasMoreStrictness:==2; +CompareGenericCaseMacro:==4; // only used from ec_tc_state :: TypesCorrespondMonad :== *TypesCorrespondState -> *(!Bool, !*TypesCorrespondState) @@ -534,9 +546,9 @@ compareDefImp main_dcl_module_n main_dcl_module (Yes macro_conversion_table) {co = compareInstanceDefs main_dcl_module.dcl_sizes dcl_common.com_instance_defs icl_com_instance_defs icl_functions comp_st (icl_com_generic_defs, comp_st) - = compareGenericDefs - main_dcl_module.dcl_sizes copied_generic_defs - dcl_common.com_generic_defs icl_com_generic_defs comp_st + = compareGenericDefs main_dcl_module.dcl_sizes copied_generic_defs dcl_common.com_generic_defs icl_com_generic_defs comp_st + + generic_case_def_macros = collectGenericCaseDefMacros dcl_common.com_gencase_defs { comp_type_var_heap = th_vars, comp_attr_var_heap = th_attrs, comp_error = error_admin } = comp_st @@ -546,7 +558,7 @@ compareDefImp main_dcl_module_n main_dcl_module (Yes macro_conversion_table) {co , tc_strictness_flags = 0 } (icl_functions, macro_defs, hp_var_heap, hp_expression_heap, tc_state, error_admin) - = compareMacrosWithConversion main_dcl_module_n macro_conversion_table dcl_macros icl_functions macro_defs hp_var_heap hp_expression_heap tc_state error_admin + = compareMacrosWithConversion main_dcl_module_n macro_conversion_table dcl_macros generic_case_def_macros icl_functions macro_defs hp_var_heap hp_expression_heap tc_state error_admin (icl_functions, tc_state, error_admin) = compareFunctionTypes n_exported_global_functions dcl_functions icl_functions tc_state error_admin { tc_type_vars, tc_attr_vars } @@ -634,7 +646,7 @@ generate_error message iclDef iclDefs tc_state error_admin error_admin = checkError ident_pos.ip_ident message error_admin = (iclDefs, tc_state, popErrorAdmin error_admin) -compareMacrosWithConversion main_dcl_module_n conversions macro_range icl_functions macro_defs var_heap expr_heap tc_state error_admin +compareMacrosWithConversion main_dcl_module_n conversions macro_range generic_case_def_macros icl_functions macro_defs var_heap expr_heap tc_state error_admin #! n_icl_functions = size icl_functions #! n_dcl_macros_and_functions = size macro_defs.[main_dcl_module_n] # ec_state = { ec_icl_correspondences = createArray n_icl_functions cNoCorrespondence, @@ -647,8 +659,15 @@ compareMacrosWithConversion main_dcl_module_n conversions macro_range icl_functi with compareMacroWithConversion conversions ir_from dclIndex ec_state=:{ec_main_dcl_module_n} = compareTwoMacroFuns ec_main_dcl_module_n dclIndex conversions.[dclIndex-ir_from] ec_state - {ec_icl_functions,ec_macro_defs,ec_var_heap, ec_expr_heap, ec_error_admin, ec_tc_state} = ec_state - = (ec_icl_functions,ec_macro_defs, ec_var_heap.hwn_heap, ec_expr_heap, ec_tc_state, ec_error_admin) + ec_state = compare_generic_case_def_macros generic_case_def_macros ec_state + with + compare_generic_case_def_macros [(GCB_FunAndMacroIndex fun_index macro_index,generic_info):gcbs] ec_state=:{ec_main_dcl_module_n} + # ec_state = compare_generic_case_def_macro_and_function macro_index fun_index generic_info ec_state + = compare_generic_case_def_macros gcbs ec_state + compare_generic_case_def_macros [] ec_state + = ec_state + {ec_icl_functions,ec_macro_defs,ec_var_heap,ec_expr_heap,ec_error_admin,ec_tc_state} = ec_state + = (ec_icl_functions,ec_macro_defs,ec_var_heap.hwn_heap,ec_expr_heap,ec_tc_state,ec_error_admin) compareTwoMacroFuns :: !Int !Int !Int !*ExpressionsCorrespondState -> .ExpressionsCorrespondState; compareTwoMacroFuns macro_module_index dclIndex iclIndex ec_state=:{ec_icl_functions,ec_macro_defs,ec_main_dcl_module_n} @@ -672,13 +691,44 @@ compareTwoMacroFuns macro_module_index dclIndex iclIndex ec_state=:{ec_icl_funct # ident_pos = getIdentPos dcl_function ec_error_admin = pushErrorAdmin ident_pos ec_state.ec_error_admin ec_state = { ec_state & ec_error_admin = ec_error_admin } - | dcl_function.fun_info.fi_properties bitand FI_IsMacroFun <> icl_function.fun_info.fi_properties bitand FI_IsMacroFun || + | (dcl_function.fun_info.fi_properties bitand FI_IsMacroFun <> icl_function.fun_info.fi_properties bitand FI_IsMacroFun + && (ec_state.ec_tc_state.tc_strictness_flags bitand CompareGenericCaseMacro==0 && dcl_function.fun_info.fi_properties bitand FI_IsMacroFun<>0)) || dcl_function.fun_priority<>icl_function.fun_priority # ec_state = give_error dcl_function.fun_ident ec_state = { ec_state & ec_error_admin = popErrorAdmin ec_state.ec_error_admin } # ec_state = e_corresponds dcl_function.fun_body icl_function.fun_body ec_state = { ec_state & ec_error_admin = popErrorAdmin ec_state.ec_error_admin } +compare_generic_case_def_macro_and_function :: !Int !Int !Int !*ExpressionsCorrespondState -> .ExpressionsCorrespondState; +compare_generic_case_def_macro_and_function dclIndex iclIndex generic_info ec_state=:{ec_icl_functions,ec_macro_defs,ec_main_dcl_module_n} + | iclIndex==NoIndex + = ec_state + # (dcl_function, ec_macro_defs) = ec_macro_defs![ec_main_dcl_module_n,dclIndex] + (icl_function, ec_icl_functions) = ec_icl_functions![iclIndex] + ec_state & ec_icl_correspondences.[iclIndex]=dclIndex, ec_dcl_correspondences.[dclIndex]=iclIndex, + ec_icl_functions = ec_icl_functions,ec_macro_defs=ec_macro_defs + ident_pos = getIdentPos dcl_function + ec_state & ec_error_admin = pushErrorAdmin ident_pos ec_state.ec_error_admin + + dcl_args_and_rhs = from_body dcl_function.fun_body + icl_args_and_rhs = from_body icl_function.fun_body + + icl_args_and_rhs + = if (generic_info==0) + (remove_generic_info_arg icl_args_and_rhs) + icl_args_and_rhs + {ec_tc_state} = ec_state + ec_state & ec_tc_state = {ec_tc_state & tc_strictness_flags = ec_tc_state.tc_strictness_flags bitor CompareGenericCaseMacro} + ec_state = e_corresponds dcl_args_and_rhs icl_args_and_rhs ec_state + {ec_tc_state} = ec_state + ec_state & ec_tc_state = {ec_tc_state & tc_strictness_flags = ec_tc_state.tc_strictness_flags bitand (bitnot CompareGenericCaseMacro)} + = {ec_state & ec_error_admin = popErrorAdmin ec_state.ec_error_admin} +where + remove_generic_info_arg ([generic_info_arg:args],rhs) + = (args,rhs) + remove_generic_info_arg args_and_rhs + = args_and_rhs + instance getIdentPos (TypeDef a) where getIdentPos {td_ident, td_pos} = newPosition td_ident td_pos @@ -1313,13 +1363,16 @@ e_corresponds_app_symb {symb_ident, symb_kind=SK_Generic dcl_glob_index dcl_kind = give_error symb_ident ec_state = ec_state e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_DclMacro dcl_glob_index} icl_app_symb=:{symb_kind=SK_IclMacro icl_index} ec_state - = continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_glob_index.glob_module dcl_glob_index.glob_object icl_app_symb icl_index ec_state + = continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_glob_index icl_app_symb icl_index ec_state e_corresponds_app_symb {symb_ident,symb_kind=SK_DclMacro dcl_glob_index} {symb_kind=SK_DclMacro icl_glob_index} ec_state | dcl_glob_index==icl_glob_index = ec_state = give_error symb_ident ec_state e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_LocalDclMacroFunction dcl_glob_index} icl_app_symb=:{symb_kind=SK_LocalMacroFunction icl_index} ec_state - = continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_glob_index.glob_module dcl_glob_index.glob_object icl_app_symb icl_index ec_state + = continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_glob_index icl_app_symb icl_index ec_state +e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_LocalDclMacroFunction dcl_glob_index} icl_app_symb=:{symb_kind=SK_Function {glob_module,glob_object=icl_index}} ec_state + | glob_module==ec_state.ec_main_dcl_module_n && ec_state.ec_tc_state.tc_strictness_flags bitand CompareGenericCaseMacro<>0 + = continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_glob_index icl_app_symb icl_index ec_state e_corresponds_app_symb {symb_ident=dcl_symb_name, symb_kind=SK_Constructor dcl_glob_index} {symb_ident=icl_symb_name, symb_kind=SK_Constructor icl_glob_index} ec_state | dcl_glob_index.glob_module==icl_glob_index.glob_module && dcl_symb_name.id_name==icl_symb_name.id_name = ec_state @@ -1331,7 +1384,7 @@ e_corresponds_app_symb {symb_ident=dcl_symb_name, symb_kind=SK_NewTypeConstructo e_corresponds_app_symb {symb_ident,symb_kind} {symb_kind=symb_kind2} ec_state = give_error symb_ident ec_state -continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_module_index dcl_index icl_app_symb icl_index ec_state +continuation_for_possibly_twice_defined_macros dcl_app_symb {glob_module=dcl_module_index, glob_object=dcl_index} icl_app_symb icl_index ec_state | icl_index==NoIndex = ec_state // two different functions were referenced. In case of macro functions they still could correspond diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl index 564758a..de2c248 100644 --- a/frontend/explicitimports.icl +++ b/frontend/explicitimports.icl @@ -701,8 +701,12 @@ instance check_completeness FunType where = check_completeness ft_type cci ccs instance check_completeness GenericDef where - check_completeness {gen_type} cci ccs - = check_completeness gen_type cci ccs + check_completeness {gen_ident, gen_type, gen_deps} cci ccs + = (check_completeness gen_type cci o foldSt (flip check_completeness cci) gen_deps) ccs + +instance check_completeness GenericDependency where + check_completeness {gd_ident=Ident ident, gd_index={gi_module, gi_index}} cci ccs + = check_whether_ident_is_imported ident gi_module gi_index STE_Generic cci ccs instance check_completeness (Global x) | check_completeness x where check_completeness { glob_object } cci ccs diff --git a/frontend/frontend.icl b/frontend/frontend.icl index e22dfdd..2cc5275 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -4,11 +4,6 @@ import scanner, parse, postparse, check, type, trans, partition, convertcases, o convertimportedtypes, compilerSwitches, analtypes, generics1, typereify, compare_types -// trace macro -(-*->) infixl -(-*->) value trace - :== value // ---> trace - instance == FrontEndPhase where (==) a b = equal_constructor a b @@ -23,8 +18,8 @@ frontSyntaxTree cached_dcl_macros cached_dcl_mods main_dcl_module_n predef_symbo ) frontEndInterface :: !(Optional (*File,{#Char},{#Char})) !FrontEndOptions !Ident !SearchPaths !{#DclModule} !*{#*{#FunDef}} !(Optional Bool) !*PredefinedSymbols !*HashTable (ModTimeFunction *Files) !*Files !*File !*File !*File !(Optional *File) !*Heaps - -> ( !Optional *FrontEndSyntaxTree,!*{#*{#FunDef}},!{#DclModule},!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *File, !*Heaps) -frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_modules cached_dcl_macros list_inferred_types predef_symbols hash_table modtimefunction files error io out tcl_file heaps + -> (!Optional *FrontEndSyntaxTree,!*{#*{#FunDef}},!{#DclModule},!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *File, !*Heaps) +frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_modules cached_dcl_macros list_inferred_types predef_symbols hash_table modtimefunction files error io out tcl_file heaps | case opt_file_dir_time of No -> True; _ -> False # error = moduleCouldNotBeImportedError True mod_ident NoPos error = (No,{},{},0,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) @@ -121,24 +116,17 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo type_heaps = { type_heaps & th_vars = th_vars } # heaps = { heaps & hp_type_heaps = type_heaps, hp_expression_heap = hp_expression_heap, hp_generic_heap = gen_heap, hp_var_heap=hp_var_heap } - # (saved_main_dcl_common, ti_common_defs) = replace (dcl_common_defs dcl_mods) main_dcl_module_n icl_common - with - dcl_common_defs :: .{#DclModule} -> .{#CommonDefs} // needed for Clean 2.0 to disambiguate overloading - dcl_common_defs dcl_mods - = {dcl_common \\ {dcl_common} <-: dcl_mods } + # (saved_main_dcl_common, ti_common_defs) = replace {#dcl_common \\ {dcl_common}<-:dcl_mods} main_dcl_module_n icl_common - #! (ti_common_defs, groups, fun_defs, generic_ranges, td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin) + #! (ti_common_defs, groups, fun_defs, td_infos, heaps, hash_table, predef_symbols, dcl_mods, cached_dcl_macros, error_admin) = case options.feo_generics of True -> convertGenerics main_dcl_module_n icl_used_module_numbers ti_common_defs groups fun_defs - td_infos heaps hash_table predef_symbols dcl_mods error_admin + td_infos heaps hash_table predef_symbols dcl_mods cached_dcl_macros error_admin False - -> (ti_common_defs, groups, fun_defs, [], td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin) + -> (ti_common_defs, groups, fun_defs, td_infos, heaps, hash_table, predef_symbols, dcl_mods, cached_dcl_macros, error_admin) - # (icl_common, ti_common_defs) = replace copied_ti_common_defs main_dcl_module_n saved_main_dcl_common - with - copied_ti_common_defs :: .{#CommonDefs} // needed for Clean 2.0 to disambiguate overloading of replace - copied_ti_common_defs = {x \\ x <-: ti_common_defs} + # (icl_common, ti_common_defs) = replace {#x \\ x<-:ti_common_defs} main_dcl_module_n saved_main_dcl_common # dcl_mods = { {dcl_mod & dcl_common = common} \\ dcl_mod <-: dcl_mods & common <-: ti_common_defs } @@ -153,7 +141,6 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo # (ok,files) = fclose genout files | not ok = abort "could not write genout" */ - #! ok = error_admin.ea_ok | not ok = (No,{},{},main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) @@ -163,8 +150,8 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo | not ok = (No,{},{},main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) - - # icl_gencase_indices = icl_function_indices.ifi_gencase_indices++generic_ranges + + # icl_gencase_indices = icl_function_indices.ifi_gencase_indices # icl_function_indices = {icl_function_indices & ifi_gencase_indices = icl_gencase_indices } # (fun_def_size, fun_defs) = usize fun_defs @@ -190,7 +177,7 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo # (stdStrictLists_module_n,predef_symbols) = get_StdStrictLists_module_n predef_symbols # (cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap) - = analyseGroups common_defs imported_funs array_instances.ali_instances_range main_dcl_module_n stdStrictLists_module_n (components -*-> "Analyse") fun_defs var_heap expression_heap + = analyseGroups common_defs imported_funs array_instances.ali_instances_range main_dcl_module_n stdStrictLists_module_n components fun_defs var_heap expression_heap # (def_max, acc_args) = usize acc_args # (def_min, fun_defs) = usize fun_defs @@ -244,10 +231,10 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo // (components, fun_defs, out) = showComponents components 0 False fun_defs out # (used_funs, components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap) - = convertCasesOfFunctions components main_dcl_module_n imported_funs common_defs fun_defs (dcl_types -*-> "Convert cases") used_conses + = convertCasesOfFunctions components main_dcl_module_n imported_funs common_defs fun_defs dcl_types used_conses var_heap type_heaps expression_heap #! (dcl_types, type_heaps, var_heap) - = convertImportedTypeSpecifications main_dcl_module_n dcl_mods imported_funs common_defs used_conses used_funs (dcl_types -*-> "Convert types") type_heaps var_heap + = convertImportedTypeSpecifications main_dcl_module_n dcl_mods imported_funs common_defs used_conses used_funs dcl_types type_heaps var_heap // # (components, fun_defs, error) = showTypes components 0 fun_defs error // # (dcl_mods, out) = showDclModules dcl_mods out // # (components, fun_defs, out) = showComponents components 0 False fun_defs out @@ -411,10 +398,9 @@ where # (size_dcl_mods, dcl_mods) = usize dcl_mods | mod_index == size_dcl_mods = (dcl_mods, file) - | otherwise - # (dcl_mod, dcl_mods) = dcl_mods ! [mod_index] + # (dcl_mod, dcl_mods) = dcl_mods![mod_index] # file = show_dcl_mod dcl_mod file - = (dcl_mods, file) + = show_dcl_mods (mod_index+1) dcl_mods file show_dcl_mod {dcl_name, dcl_functions} file # file = file <<< dcl_name <<< ":\n" diff --git a/frontend/generics1.dcl b/frontend/generics1.dcl index 661ef10..014f069 100644 --- a/frontend/generics1.dcl +++ b/frontend/generics1.dcl @@ -14,15 +14,16 @@ convertGenerics :: !*HashTable !*PredefinedSymbols !u:{# DclModule} - !*ErrorAdmin + !*{#*{#FunDef}} + !*ErrorAdmin -> ( !{#CommonDefs} , !{!Group} , !*{# FunDef} - , ![IndexRange] , !*TypeDefInfos , !*Heaps , !*HashTable , !*PredefinedSymbols , !u:{# DclModule} + , !*{#*{#FunDef}} , !*ErrorAdmin ) diff --git a/frontend/generics1.icl b/frontend/generics1.icl index dcdb446..e36c9a3 100644 --- a/frontend/generics1.icl +++ b/frontend/generics1.icl @@ -16,6 +16,7 @@ import genericsupport :: Modules :== {#CommonDefs} :: DclModules :== {#DclModule} :: Groups :== {!Group} +:: *DclMacros :== *{#*{#FunDef}} :: FunsAndGroups= ! { fg_fun_index :: !Index, @@ -80,19 +81,20 @@ convertGenerics :: !*HashTable // needed for what creating class dictionaries !*PredefinedSymbols // predefined symbols !u:{# DclModule} // dcl modules + !*{#*{#FunDef}} // dcl macros !*ErrorAdmin // to report errors -> ( !{#CommonDefs} // common definitions of all modules , !{!Group} // groups of functions , !*{# FunDef} // function definitions - , ![IndexRange] // index ranges of generated functions , !*TypeDefInfos // type definition infos , !*Heaps // all heaps , !*HashTable // needed for creating class dictinaries , !*PredefinedSymbols // predefined symbols , !u:{# DclModule} // dcl modules + , !*{#*{#FunDef}} // dcl macros , !*ErrorAdmin // to report errors ) -convertGenerics main_dcl_module_n used_module_numbers modules groups funs td_infos heaps hash_table u_predefs dcl_modules error +convertGenerics main_dcl_module_n used_module_numbers modules groups funs td_infos heaps hash_table u_predefs dcl_modules dcl_macros error #! modules = {x \\ x <-: modules} // unique copy #! dcl_modules = { x \\ x <-: dcl_modules } // unique copy #! size_predefs = size u_predefs @@ -120,7 +122,7 @@ convertGenerics main_dcl_module_n used_module_numbers modules groups funs td_inf , gs_used_modules = used_module_numbers } - # (generic_ranges, gs) = convert_generics gs + # (dcl_macros, gs) = convert_generics dcl_macros gs # { gs_modules = modules, gs_symtab, gs_dcl_modules = dcl_modules, gs_td_infos = td_infos, gs_genh = hp_generic_heap, gs_varh = hp_var_heap, gs_tvarh = th_vars, gs_avarh = th_attrs, @@ -134,22 +136,22 @@ convertGenerics main_dcl_module_n used_module_numbers modules groups funs td_inf , hp_generic_heap = hp_generic_heap , hp_type_heaps = { th_vars = th_vars, th_attrs = th_attrs } } - = (modules, groups, funs, generic_ranges, td_infos, heaps, hash_table, u_predefs, dcl_modules, error) + = (modules, groups, funs, td_infos, heaps, hash_table, u_predefs, dcl_modules, dcl_macros, error) where - convert_generics :: !*GenericState -> (![IndexRange], !*GenericState) - convert_generics gs - # (iso_range, bimap_functions, gs) = buildGenericRepresentations gs - | not gs.gs_error.ea_ok = ([], gs) + convert_generics :: !*DclMacros !*GenericState -> (!*DclMacros, !*GenericState) + convert_generics dcl_macros gs + # (bimap_functions, gs) = buildGenericRepresentations gs + | not gs.gs_error.ea_ok = (dcl_macros, gs) # gs = buildClasses gs - | not gs.gs_error.ea_ok = ([], gs) + | not gs.gs_error.ea_ok = (dcl_macros, gs) - # (instance_range, gs) = convertGenericCases bimap_functions gs - | not gs.gs_error.ea_ok = ([], gs) + # (dcl_macros, gs) = convertGenericCases bimap_functions dcl_macros gs + | not gs.gs_error.ea_ok = (dcl_macros, gs) #! gs = convertGenericTypeContexts gs - = ([/*iso_range,*/instance_range], gs) + = (dcl_macros, gs) // clear stuff that might have been left over // from compilation of other icl modules @@ -179,6 +181,11 @@ clearGenericDefs modules heaps where initial_gen_classes = createArray 32 [] + initial_gen_rep_conses + = createArray 7 {grc_module = -1, grc_index = GCB_None, grc_local_fun_index = -1, grc_generic_info = -1, + grc_generic_instance_deps = AllGenericInstanceDependencies, + grc_ident={id_name="",id_info=nilPtr}, + grc_optional_fun_type=No} clear_module n modules heaps | n == size modules @@ -190,7 +197,7 @@ where clear_generic_def generic_def=:{gen_info_ptr} heaps=:{hp_generic_heap} #! (gen_info, hp_generic_heap) = readPtr gen_info_ptr hp_generic_heap - #! gen_info & gen_classes = initial_gen_classes + # gen_info & gen_classes = initial_gen_classes, gen_rep_conses = initial_gen_rep_conses #! hp_generic_heap = writePtr gen_info_ptr gen_info hp_generic_heap = (generic_def, {heaps & hp_generic_heap = hp_generic_heap}) @@ -198,7 +205,7 @@ where // generic representation is built for each type argument of // generic cases of the current module -buildGenericRepresentations :: !*GenericState -> (!IndexRange,!BimapFunctions,!*GenericState) +buildGenericRepresentations :: !*GenericState -> (!BimapFunctions,!*GenericState) buildGenericRepresentations gs=:{gs_main_module, gs_modules, gs_funs, gs_groups} #! (size_funs, gs_funs) = usize gs_funs #! size_groups = size gs_groups @@ -224,21 +231,19 @@ buildGenericRepresentations gs=:{gs_main_module, gs_modules, gs_funs, gs_groups} bimap_RECORD_function = undefined_function_and_ident, bimap_FIELD_function = undefined_function_and_ident } - funs_and_groups = {fg_fun_index=size_funs, fg_group_index=size_groups, fg_funs=[], fg_groups=[],fg_bimap_functions= bimap_functions} + funs_and_groups = {fg_fun_index=size_funs, fg_group_index=size_groups, fg_funs=[], fg_groups=[],fg_bimap_functions=bimap_functions} #! (funs_and_groups, gs) = foldArraySt build_generic_representation com_gencase_defs (funs_and_groups, gs) - # {fg_fun_index,fg_funs=new_funs,fg_groups=new_groups,fg_bimap_functions} = funs_and_groups + # {fg_funs=new_funs,fg_groups=new_groups,fg_bimap_functions} = funs_and_groups # {gs_funs, gs_groups} = gs #! gs_funs = arrayPlusRevList gs_funs new_funs #! gs_groups = arrayPlusRevList gs_groups new_groups - #! range = {ir_from = size_funs, ir_to = fg_fun_index} - - = (range, fg_bimap_functions, {gs & gs_funs = gs_funs, gs_groups = gs_groups}) + = (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_gcf,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] @@ -277,8 +282,8 @@ where -> (funs_and_groups, gs) :: TypeInfos - = AlgebraicInfo !DefinedSymbol ![DefinedSymbol] - | RecordInfo !DefinedSymbol ![DefinedSymbol] + = AlgebraicInfo !DefinedSymbol !DefinedSymbol ![DefinedSymbol] ![DefinedSymbol] + | RecordInfo !DefinedSymbol !DefinedSymbol !DefinedSymbol ![DefinedSymbol] buildGenericTypeRep :: !GlobalIndex /*type def index*/ !FunsAndGroups !*GenericState -> (!GenericTypeRep,!FunsAndGroups,!*GenericState) buildGenericTypeRep type_index funs_and_groups @@ -517,19 +522,21 @@ where # (x, st) = simplify x st # (y, st) = simplify y st = (GTSEither x y, st) - simplify (GTSCons cons_info_ds x) st + simplify (GTSCons cons_info_ds cons_index type_info gen_type_ds x) st # (x, st) = simplify x st - = (GTSCons cons_info_ds x, st) - simplify (GTSRecord cons_info_ds x) st + = (GTSCons cons_info_ds cons_index type_info gen_type_ds x, st) + simplify (GTSRecord cons_info_ds type_index gen_type_ds field_list_ds x) st # (x, st) = simplify x st - = (GTSRecord cons_info_ds x, st) - simplify (GTSField field_info_ds x) st + = (GTSRecord cons_info_ds type_index gen_type_ds field_list_ds x, st) + simplify (GTSField field_info_ds field_index record_info_ds x) st # (x, st) = simplify x st - = (GTSField field_info_ds x, st) - simplify (GTSObject type_info_ds x) st + = (GTSField field_info_ds field_index record_info_ds x, st) + simplify (GTSObject type_info_ds type_index cons_desc_list_ds x) st # (x, st) = simplify x st - = (GTSObject type_info_ds x, st) - + = (GTSObject type_info_ds type_index cons_desc_list_ds x, st) + simplify GTSUnit st + = (GTSUnit, st) + occurs (GTSAppCons _ args) st = occurs_list args st occurs (GTSAppConsSimpleType _ _ args) st = occurs_list args st occurs (GTSAppBimap _ args) st = occurs_list args st @@ -538,10 +545,11 @@ where occurs (GTSArrow x y) st = occurs2 x y st occurs (GTSPair x y) st = occurs2 x y st occurs (GTSEither x y) st = occurs2 x y st - occurs (GTSCons _ arg) st = occurs arg st - occurs (GTSRecord _ arg) st = occurs arg st - occurs (GTSField _ arg) st = occurs arg st - occurs (GTSObject _ arg) st = occurs arg st + occurs (GTSCons _ _ _ _ arg) st = occurs arg st + occurs (GTSRecord _ _ _ _ arg) st = occurs arg st + occurs (GTSField _ _ _ arg) st = occurs arg st + occurs (GTSObject _ _ _ arg) st = occurs arg st + occurs GTSUnit st = False occurs GTSE st = False occurs2 x y st @@ -578,20 +586,20 @@ buildStructType {gi_module,gi_index} type_infos predefs (modules, td_infos, heap # (type_def=:{td_ident}, modules) = modules![gi_module].com_type_defs.[gi_index] = build_type type_def type_infos (modules, td_infos, heaps, error) where - build_type {td_rhs=AlgType alts, td_ident, td_pos} (AlgebraicInfo type_info cons_infos) st - # (cons_args, st) = zipWithSt (build_alt td_ident td_pos) alts cons_infos st + build_type {td_rhs=AlgType alts, td_ident, td_pos} (AlgebraicInfo type_info cons_desc_list_ds gen_type_dss cons_infos) st + # (cons_args, st) = zipWith3St (build_alt td_ident td_pos type_info) alts cons_infos gen_type_dss st # type = build_sum_type cons_args - = (GTSObject type_info type, st) + = (GTSObject type_info {gi_module=gi_module,gi_index=gi_index} cons_desc_list_ds type, st) build_type - {td_rhs=RecordType {rt_constructor}, td_ident, td_pos} - (RecordInfo ci_record_info ci_field_infos) + {td_rhs=RecordType {rt_constructor,rt_fields}, td_ident, td_pos} + (RecordInfo ci_record_info gen_type_ds field_list_ds ci_field_infos) (modules, td_infos, heaps, error) # ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[rt_constructor.ds_index] | isEmpty cons_exi_vars # (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error) - # args = [GTSField fi arg \\ arg <- args & fi <- ci_field_infos] + # args = [GTSField fi {gi_module=gi_module,gi_index=fs_index} ci_record_info arg \\ arg <- args & fi <- ci_field_infos & {fs_index}<-:rt_fields] # prod_type = build_prod_type args - = (GTSRecord ci_record_info prod_type, st) + = (GTSRecord ci_record_info {gi_module=gi_module,gi_index=gi_index} gen_type_ds field_list_ds prod_type, st) # error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error = (GTSE, (modules, td_infos, heaps, error)) build_type {td_rhs=SynType type,td_ident, td_pos} type_infos (modules, td_infos, heaps, error) @@ -601,12 +609,12 @@ where # error = reportError td_ident.id_name td_pos "cannot build a generic representation of an abstract type" error = (GTSE, (modules, td_infos, heaps, error)) - build_alt td_ident td_pos cons_def_sym=:{ds_index} cons_info (modules, td_infos, heaps, error) + build_alt td_ident td_pos type_info cons_def_sym=:{ds_index} cons_info gen_type_ds (modules, td_infos, heaps, error) # ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[ds_index] | isEmpty cons_exi_vars # (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error) # prod_type = build_prod_type args - = (GTSCons cons_info prod_type, st) + = (GTSCons cons_info {gi_module=gi_module,gi_index=ds_index} type_info gen_type_ds prod_type, st) # error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error = (GTSE, (modules, td_infos, heaps, error)) @@ -615,7 +623,7 @@ where = listToBin build_pair build_unit types where build_pair x y = GTSPair x y - build_unit = GTSAppCons KindConst [] + build_unit = GTSUnit // GTSAppCons KindConst [] build_sum_type :: [GenTypeStruct] -> GenTypeStruct build_sum_type types @@ -702,7 +710,7 @@ buildAlgebraicTypeDefInfo {td_ident, td_pos, td_arity} alts td_module main_modul # (cons_desc_list_fun, heaps) = build_cons_desc_list_function group_index cons_desc_list_ds cons_dsc_dss heaps - (type_def_dsc_fun, heaps) = build_type_def_dsc group_index type_def_dsc_ds cons_desc_list_ds heaps + (type_def_dsc_fun, heaps) = build_type_def_dsc group_index /*cons_dsc_dss*/ type_def_dsc_ds cons_desc_list_ds heaps (gen_type_dsc_funs, (modules, heaps)) = zipWithSt (build_gen_type_function group_index main_module_index td_module td_pos predefs) gen_type_dss alts (modules, heaps) @@ -713,7 +721,7 @@ buildAlgebraicTypeDefInfo {td_ident, td_pos, td_arity} alts td_module main_modul # funs_and_groups = {funs_and_groups & fg_fun_index=new_fun_index, fg_group_index=new_group_index, fg_funs=new_funs, fg_groups=new_groups} - # cons_infos = AlgebraicInfo type_def_dsc_ds cons_dsc_dss + # cons_infos = AlgebraicInfo type_def_dsc_ds cons_desc_list_ds gen_type_dss cons_dsc_dss = (cons_infos, funs_and_groups, modules, heaps, error) where @@ -723,7 +731,7 @@ where # fun = makeFunction ds_ident group_index [] gtd_conses_expr No main_module_index td_pos = (fun, heaps) - build_type_def_dsc group_index {ds_ident} cons_desc_list_ds heaps + build_type_def_dsc group_index /*cons_info_dss*/ {ds_ident} cons_desc_list_ds heaps # td_name_expr = makeStringExpr td_ident.id_name // gtd_name # td_arity_expr = makeIntExpr td_arity // gtd_arity # num_conses_expr = makeIntExpr (length alts) // gtd_num_conses @@ -747,7 +755,7 @@ where = buildPredefConsApp PD_CGenericConsDescriptor [name_expr, arity_expr, prio_expr, type_def_expr, type_expr, cons_index_expr] predefs heaps - # fun = makeFunction ds_ident 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, (modules, heaps)) make_prio_expr NoPrio predefs heaps @@ -795,7 +803,7 @@ buildRecordTypeDefInfo {td_ident, td_pos, td_arity} alt fields td_module main_mo # funs_and_groups = {funs_and_groups & fg_fun_index=new_fun_index, fg_group_index=new_group_index, fg_funs=new_funs, fg_groups=new_groups} - # cons_infos = RecordInfo record_dsc_ds field_dsc_dss + # cons_infos = RecordInfo record_dsc_ds gen_type_ds field_list_ds field_dsc_dss = (cons_infos, funs_and_groups, modules, heaps, error) where @@ -1294,39 +1302,90 @@ where on_gencase :: !Index !Index !GenericCaseDef (![ClassDef], ![MemberDef], !Index, Index) !*GenericState - -> (!GenericCaseDef,(![ClassDef], ![MemberDef], !Index, Index), !*GenericState) + -> (!GenericCaseDef,(![ClassDef], ![MemberDef], !Index, Index),!*GenericState) on_gencase module_index 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] + gencase=:{gc_gcf=GCF gc_ident gcf=:{gcf_generic,gcf_generic_info,gcf_generic_instance_deps}, gc_type_cons, gc_type, gc_pos} + st gs=:{gs_modules, gs_td_infos, gs_error} + #! (gen_def=:{gen_deps}, 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 + # (gcf_generic_instance_deps,gs_error) + = case gcf_generic_instance_deps of + GenericInstanceDependencies n_deps deps + # n_generic_function_arguments = number_of_generic_function_arguments kind gen_deps + | n_deps == n_generic_function_arguments + -> (gcf_generic_instance_deps,gs_error) + # gs_error = reportError gc_ident.id_name gc_pos "incorrect number of dependent generic functions in definition module" gs.gs_error + | n_deps > n_generic_function_arguments + # deps = deps bitand ((1< (GenericInstanceDependencies n_generic_function_arguments deps,gs_error) + # deps = deps bitor ((-1)< (GenericInstanceDependencies n_generic_function_arguments deps,gs_error) + GenericInstanceUsedArgs n_deps deps + # n_generic_function_arguments = number_of_generic_function_arguments kind gen_deps + | n_deps == n_generic_function_arguments + -> (GenericInstanceDependencies n_deps deps,gs_error) + | n_deps > n_generic_function_arguments + # deps = deps bitand ((1< (GenericInstanceDependencies n_generic_function_arguments deps,gs_error) + # deps = deps bitor ((-1)< (GenericInstanceDependencies n_generic_function_arguments deps,gs_error) + _ + -> (gcf_generic_instance_deps,gs_error) + + #! type_index = index_gen_cons_with_info_type gencase.gc_type gs.gs_predefs + // To generate all partially applied shorthand instances we need - // classes for all partial applications of the gcf_kind and for + // classes for all partial applications of the gc_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} + #! gs = {gs & gs_modules = gs_modules, gs_td_infos = gs_td_infos, gs_error = gs_error} #! subkinds = determine_subkinds kind #! kinds = [ KindConst , KindArrow [KindConst] , KindArrow [KindConst, KindConst] : subkinds] - #! (st, gs) = foldSt (build_class_if_needed gen_def) kinds (st, gs) - #! 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 + # (dep_defs, gs_modules) = mapSt lookupDependencyDef gen_deps gs.gs_modules + # gs = {gs & gs_modules = gs_modules} + #! (st, gs) = foldSt (\def -> foldSt (build_class_if_needed def) kinds) [gen_def:dep_defs] (st, gs) + #! gencase = { gencase & gc_gcf = GCF gc_ident {gcf & gcf_kind = kind, gcf_generic_instance_deps = gcf_generic_instance_deps}} | type_index>=0 - # (GCF _ {gcf_body = GCB_FunIndex fun_index}) = gencase.gc_gcf + # (GCF _ {gcf_body = fun_index}) = gencase.gc_gcf gen_info_ptr = gen_def.gen_info_ptr fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons - gcf_index = {gcf_module=module_index,gcf_index=fun_index,gcf_ident=fun_ident} + + (optional_fun_type,gs) + = case gcf_generic_instance_deps of + GenericInstanceDependencies n_deps deps + # (class_var, gs_tvarh) = freshTypeVar (makeIdent "class_var") gs.gs_tvarh + gs & gs_tvarh=gs_tvarh + unused_class = TCClass {glob_module = -1, glob_object = {ds_index = -1, ds_ident = {id_name="",id_info=nilPtr}, ds_arity = 1}} + (member_type, gs) = buildMemberTypeWithPartialDependencies gen_def kind class_var unused_class deps gs + + ins_type = {it_vars = instance_vars_from_type_cons gc_type_cons, it_types = [gc_type], it_attr_vars = [], it_context = []} + + type_heaps = {th_vars = gs.gs_tvarh, th_attrs = gs.gs_avarh} + (fun_type, {th_vars,th_attrs}, var_heap, error) + = determine_type_of_member_instance_from_symbol_type member_type ins_type type_heaps gs.gs_varh gs.gs_error + gs & gs_tvarh=th_vars, gs_avarh=th_attrs, gs_varh=var_heap, gs_error=error + + -> (Yes fun_type,gs) + _ + -> (No,gs) + + gen_rep_cons = {grc_module=module_index, grc_index=fun_index, grc_local_fun_index = -1, grc_ident=fun_ident, + grc_generic_info=gcf_generic_info, grc_generic_instance_deps=gcf_generic_instance_deps, + grc_optional_fun_type=optional_fun_type} (gen_info,generic_heap) = readPtr gen_info_ptr gs.gs_genh gen_rep_conses = {gi\\gi<-:gen_info.gen_rep_conses} - gen_rep_conses = {gen_rep_conses & [type_index]=gcf_index} + gen_rep_conses = {gen_rep_conses & [type_index]=gen_rep_cons} gen_info = {gen_info & gen_rep_conses=gen_rep_conses} generic_heap = writePtr gen_info_ptr gen_info generic_heap gs = {gs & gs_genh=generic_heap} @@ -1355,11 +1414,16 @@ where build_classes_for_generic_superclasses_if_needed [!!] kind kinds st gs = ([!!],st,gs) + number_of_generic_function_arguments (KindArrow kinds) gen_deps + = length kinds * (1 + length gen_deps) + number_of_generic_function_arguments gcf_kind gen_deps + = 0 + build_classes_if_needed gen_def kinds st gs = foldSt (build_class_if_needed gen_def) kinds (st, gs) build_class_if_needed :: !GenericDef !TypeKind ((![ClassDef], ![MemberDef], !Index, Index), *GenericState) - -> ((![ClassDef], ![MemberDef], !Index, Index), *GenericState) + -> ((![ClassDef], ![MemberDef], !Index, Index), *GenericState) build_class_if_needed gen_def kind ((classes, members, class_index, member_index), gs=:{gs_main_module, gs_genh}) #! (opt_class_info, gs_genh) = lookup_generic_class_info gen_def kind gs_genh #! gs = {gs & gs_genh = gs_genh} @@ -1441,86 +1505,123 @@ where , gs_symtab = gs_symtab } = (common_defs, gs) +instance_vars_from_type_cons (TypeConsVar tv) + = [tv] +instance_vars_from_type_cons _ + = [] + +lookupDependencyDef :: GenericDependency !*Modules -> (GenericDef, *Modules) +lookupDependencyDef {gd_index} modules = modules![gd_index.gi_module].com_generic_defs.[gd_index.gi_index] + // limitations: // - context restrictions on generic variables are not allowed -buildMemberType :: !GenericDef !TypeKind !TypeVar !*GenericState -> ( !SymbolType, !*GenericState) -buildMemberType gen_def=:{gen_ident,gen_pos,gen_type,gen_vars} kind class_var gs=:{gs_predefs} +buildMemberType :: !GenericDef !TypeKind !TypeVar !TCClass !*GenericState -> (!SymbolType, !*GenericState) +buildMemberType gen_def=:{gen_ident,gen_pos,gen_type,gen_vars,gen_deps} kind class_var tc_class gs=:{gs_varh} + # (tc_var_ptr, gs_varh) = newPtr VI_Empty gs_varh + # gs & gs_varh = gs_varh + #! type_context = {tc_class = tc_class, tc_types = [TV class_var], tc_var = tc_var_ptr} + #! (gen_type, gs) = add_bimap_contexts gen_def gs #! th = {th_vars = gs.gs_tvarh, th_attrs = gs.gs_avarh} - #! (kind_indexed_st, gatvs, th, gs_error) - = buildKindIndexedType gen_type gen_vars kind gen_ident gen_pos th gs.gs_error + #! (kind_indexed_st, gatvs, th, modules, error) + = buildKindIndexedType gen_type gen_vars gen_deps kind gen_ident gen_pos th gs.gs_modules gs.gs_error - #! (member_st, th, gs_error) - = replace_generic_vars_with_class_var kind_indexed_st gatvs th gs_error + #! (member_st, th) + = replace_generic_vars_with_class_var kind_indexed_st gatvs class_var th #! th = assertSymbolType member_st th // just paranoied about cleared variables #! th = assertSymbolType gen_type th + + # member_st & st_context = [type_context : member_st.st_context] - # {th_vars, th_attrs} = th - #! gs = {gs & gs_avarh = th_attrs, gs_tvarh = th_vars, gs_error = gs_error } + # gs = {gs & gs_avarh = th.th_attrs, gs_tvarh = th.th_vars, gs_modules = modules, gs_error = error } = (member_st, gs) -where - add_bimap_contexts - {gen_type=gen_type=:{st_vars, st_context}, gen_vars, gen_info_ptr} - gs=:{gs_predefs, gs_varh, gs_genh} - #! ({gen_var_kinds}, gs_genh) = readPtr gen_info_ptr gs_genh - #! num_gen_vars = length gen_vars - #! tvs = st_vars -- gen_vars - #! kinds = drop num_gen_vars gen_var_kinds - #! (bimap_contexts, gs_varh) = build_contexts tvs kinds gs_varh - - #! gs = {gs & gs_varh = gs_varh, gs_genh = gs_genh} - = ({gen_type & st_context = st_context ++ bimap_contexts}, gs) - where - build_contexts [] [] st - = ([], st) - build_contexts [x:xs] [KindConst:kinds] st - = build_contexts xs kinds st - build_contexts [x:xs] [kind:kinds] st - # (z, st) = build_context x kind st - # (zs, st) = build_contexts xs kinds st - = ([z:zs], st) - - build_context tv kind gs_varh - #! (var_info_ptr, gs_varh) = newPtr VI_Empty gs_varh - #! {pds_module, pds_def} = gs_predefs . [PD_GenericBimap] - #! pds_ident = predefined_idents . [PD_GenericBimap] - # glob_def_sym = - { glob_module = pds_module - , glob_object = {ds_ident=pds_ident, ds_index=pds_def, ds_arity = 1} - } - # tc_class = TCGeneric - { gtc_generic=glob_def_sym - , gtc_kind = kind - , gtc_class = {glob_module=NoIndex,glob_object={ds_ident=makeIdent "", ds_index=NoIndex, ds_arity=1}} - , gtc_generic_dict = {gi_module=NoIndex, gi_index=NoIndex} - } - =({tc_class = tc_class, tc_types = [TV tv], tc_var = var_info_ptr}, gs_varh) - replace_generic_vars_with_class_var st atvs th error - #! th = subst_gvs atvs th - #! (new_st, th) = applySubstInSymbolType st th - = (new_st, th, error) - 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 +buildMemberTypeWithPartialDependencies :: !GenericDef !TypeKind !TypeVar !TCClass !Int !*GenericState -> (!SymbolType, !*GenericState) +buildMemberTypeWithPartialDependencies gen_def=:{gen_ident,gen_pos,gen_type,gen_vars,gen_deps} kind class_var unused_class deps gs=:{gs_varh} + # (tc_var_ptr, gs_varh) = newPtr VI_Empty gs_varh + # gs & gs_varh = gs_varh + #! type_context = {tc_class = unused_class, tc_types = [TV class_var], tc_var = tc_var_ptr} + + #! (gen_type, gs) = add_bimap_contexts gen_def gs + + #! th = {th_vars = gs.gs_tvarh, th_attrs = gs.gs_avarh} + #! (kind_indexed_st, gatvs, th, modules, error) + = buildKindIndexedTypeWithPartialDependencies gen_type gen_vars gen_deps kind deps gen_ident gen_pos th gs.gs_modules gs.gs_error + + #! (member_st, th) + = replace_generic_vars_with_class_var kind_indexed_st gatvs class_var th + + #! th = assertSymbolType member_st th // just paranoied about cleared variables + #! th = assertSymbolType gen_type th + + # member_st & st_context = [type_context : member_st.st_context] + + # gs = {gs & gs_avarh = th.th_attrs, gs_tvarh = th.th_vars, gs_modules = modules, gs_error = error } + = (member_st, gs) - // all generic vars get the same uniqueness variable - # th_attrs = case avs of - [av:avs] -> foldSt (subst_av av) avs th_attrs - [] -> th_attrs +add_bimap_contexts :: GenericDef *GenericState -> (!SymbolType,!*GenericState) +add_bimap_contexts + {gen_type=gen_type=:{st_vars, st_context}, gen_vars, gen_info_ptr} + gs=:{gs_predefs, gs_varh, gs_genh} + #! ({gen_var_kinds}, gs_genh) = readPtr gen_info_ptr gs_genh + #! num_gen_vars = length gen_vars + #! tvs = st_vars -- gen_vars + #! kinds = drop num_gen_vars gen_var_kinds + #! (bimap_contexts, gs_varh) = build_contexts tvs kinds gs_varh + + #! gs = {gs & gs_varh = gs_varh, gs_genh = gs_genh} + = ({gen_type & st_context = st_context ++ bimap_contexts}, gs) +where + build_contexts [] [] st + = ([], st) + build_contexts [x:xs] [KindConst:kinds] st + = build_contexts xs kinds st + build_contexts [x:xs] [kind:kinds] st + # (z, st) = build_context x kind st + # (zs, st) = build_contexts xs kinds st + = ([z:zs], st) + + build_context tv kind gs_varh + #! (var_info_ptr, gs_varh) = newPtr VI_Empty gs_varh + #! {pds_module, pds_def} = gs_predefs . [PD_GenericBimap] + #! pds_ident = predefined_idents . [PD_GenericBimap] + # glob_def_sym = + { glob_module = pds_module + , glob_object = {ds_ident=pds_ident, ds_index=pds_def, ds_arity = 1} + } + # tc_class = TCGeneric + { gtc_generic=glob_def_sym + , gtc_kind = kind + , gtc_class = {glob_module=NoIndex,glob_object={ds_ident=makeIdent "", ds_index=NoIndex, ds_arity=1}} + , gtc_generic_dict = {gi_module=NoIndex, gi_index=NoIndex} + } + =({tc_class = tc_class, tc_types = [TV tv], tc_var = var_info_ptr}, gs_varh) - = { th & th_vars = th_vars, th_attrs = th_attrs } +replace_generic_vars_with_class_var :: SymbolType [ATypeVar] TypeVar *TypeHeaps -> (!SymbolType,!*TypeHeaps) +replace_generic_vars_with_class_var st atvs class_var th + #! th = subst_gvs atvs th + = applySubstInSymbolType st th +where + subst_gvs atvs th=:{th_vars, th_attrs} + #! tvs = [atv_variable \\ {atv_variable} <- atvs ] + #! avs = [av \\ {atv_attribute=TA_Var av} <- atvs ] - subst_tv {tv_info_ptr} th_vars - = writePtr tv_info_ptr (TVI_Type (TV class_var)) th_vars + # th_vars = foldSt subst_tv tvs th_vars - subst_av av {av_info_ptr} th_attrs - = writePtr av_info_ptr (AVI_Attr (TA_Var av)) th_attrs + // all generic vars get the same uniqueness variable + # th_attrs = case avs of + [av:avs] -> foldSt (subst_av av) avs th_attrs + [] -> th_attrs + + = { th & th_vars = th_vars, th_attrs = th_attrs } + + subst_tv {tv_info_ptr} th_vars + = writePtr tv_info_ptr (TVI_Type (TV class_var)) th_vars + + subst_av av {av_info_ptr} th_attrs + = writePtr av_info_ptr (AVI_Attr (TA_Var av)) th_attrs buildClassAndMember :: Int Int Int TypeKind GenericDef *GenericState -> (ClassDef,MemberDef,*GenericState) buildClassAndMember @@ -1537,18 +1638,11 @@ where 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} - #! (type_ptr, gs_varh) = newPtr VI_Empty gs_varh - #! (tc_var_ptr, gs_varh) = newPtr VI_Empty gs_varh - #! gs = {gs & gs_varh = gs_varh } - #! type_context = - { tc_class = TCClass {glob_module = module_index, glob_object=class_ds} - , tc_types = [TV class_var] - , tc_var = tc_var_ptr - } + build_class_member class_var gs #! (member_type, gs) - = buildMemberType gen_def kind class_var gs - #! member_type = { member_type & st_context = [type_context : member_type.st_context] } + = buildMemberType gen_def kind class_var (TCClass {glob_module = module_index, glob_object=class_ds}) gs + #! (type_ptr, gs_varh) = newPtr VI_Empty gs.gs_varh + #! gs & gs_varh = gs_varh #! member_def = { me_ident = member_ident, me_class = {glob_module = module_index, glob_object = class_index}, @@ -1584,12 +1678,23 @@ where } = class_def -// Convert generic cases +// Convert generic cases + +:: *SpecializeState = { + ss_modules :: !*Modules, + ss_td_infos :: !*TypeDefInfos, + ss_funs_and_groups :: !FunsAndGroups, + ss_heaps :: !*Heaps, + ss_dcl_macros :: !*DclMacros, + ss_funs :: !*{#FunDef}, + ss_symbol_table :: !*SymbolTable, + ss_error :: !*ErrorAdmin + } -convertGenericCases :: !BimapFunctions !*GenericState -> (!IndexRange, !*GenericState) -convertGenericCases bimap_functions +convertGenericCases :: !BimapFunctions !*DclMacros !*GenericState -> (!*DclMacros, !*GenericState) +convertGenericCases bimap_functions dcl_macros gs=:{gs_main_module, gs_used_modules, gs_predefs, gs_funs, gs_groups, gs_modules, gs_dcl_modules, gs_td_infos, - gs_avarh, gs_tvarh, gs_varh, gs_genh, gs_exprh, gs_error} + gs_avarh, gs_tvarh, gs_varh, gs_genh, gs_exprh, gs_symtab, gs_error} # heaps = { hp_expression_heap = gs_exprh @@ -1608,15 +1713,15 @@ convertGenericCases bimap_functions #! first_instance_index = size main_module_instances #! instance_info = (first_instance_index, []) - #! (gs_modules, gs_dcl_modules, (instance_info, heaps, gs_error)) + #! (gs_modules, gs_dcl_modules, (instance_info, heaps, gs_error)) = build_exported_main_instances_in_modules 0 gs_modules gs_dcl_modules (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_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 + # st2 = {ss_modules=gs_modules,ss_td_infos=gs_td_infos,ss_funs_and_groups=fun_info,ss_heaps=heaps,ss_dcl_macros=dcl_macros,ss_funs=gs_funs, + ss_symbol_table=gs_symtab,ss_error=gs_error} + #! (gs_dcl_modules, instance_info, st2) + = build_main_instances_in_main_module gs_main_module gs_dcl_modules instance_info st2 + # {ss_modules=gs_modules,ss_td_infos=gs_td_infos,ss_funs_and_groups=fun_info,ss_heaps=heaps,ss_dcl_macros=dcl_macros,ss_funs=gs_funs, + ss_symbol_table=gs_symtab,ss_error=gs_error} = st2 #! (gs_modules, gs_dcl_modules, (fun_info, instance_info, heaps, gs_error)) = build_shorthand_instances_in_modules 0 gs_modules gs_dcl_modules (fun_info, instance_info, heaps, gs_error) @@ -1631,22 +1736,11 @@ convertGenericCases bimap_functions #! 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_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 - , gs_dcl_modules = gs_dcl_modules - , gs_td_infos = gs_td_infos - , gs_funs = gs_funs - , gs_groups = gs_groups - , gs_error = gs_error - , gs_avarh = th_attrs - , gs_tvarh = th_vars - , gs_varh = hp_var_heap - , gs_genh = hp_generic_heap - , gs_exprh = hp_expression_heap - } - = (instance_fun_range, gs) + # gs & gs_modules = gs_modules, gs_dcl_modules = gs_dcl_modules, gs_td_infos = gs_td_infos, gs_funs = gs_funs, gs_groups = gs_groups, + gs_avarh = th_attrs, gs_tvarh = th_vars, gs_varh = hp_var_heap, gs_genh = hp_generic_heap, gs_exprh = hp_expression_heap, + gs_error = gs_error, gs_symtab = gs_symtab + = (dcl_macros, gs) where build_exported_main_instances_in_modules :: !Index !*{#CommonDefs} !*{#DclModule} !(!(!Index, ![ClassInstance]), !*Heaps, !*ErrorAdmin) @@ -1672,143 +1766,159 @@ where (!*{#FunType} ,!*Modules, !(!(!Index, ![ClassInstance]), !*Heaps, !*ErrorAdmin)) -> (!*{#FunType} ,!*Modules, !(!(!Index, ![ClassInstance]), !*Heaps, !*ErrorAdmin)) build_exported_main_instance module_index - {gc_gcf=GCF gc_ident {gcf_body,gcf_kind,gcf_generic}, gc_type, gc_type_cons,gc_pos} + {gc_gcf=GCF gc_ident {gcf_body,gcf_kind,gcf_generic,gcf_generic_info}, gc_type, gc_type_cons,gc_pos} (dcl_functions, modules, st) - #! has_generic_info = is_gen_cons_without_instances 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 = []} + #! generic_info_index = index_gen_cons_with_info_type gc_type gs_predefs # fun_index = case gcf_body of GCB_FunIndex fun_index -> fun_index - = build_exported_main_instance_ ins_type module_index gc_ident fun_index gcf_kind gcf_generic gc_type_cons gc_pos gc_type has_generic_info + GCB_FunAndMacroIndex fun_index macro_index + -> fun_index + = build_exported_main_instance_ ins_type module_index gc_ident fun_index gcf_kind gcf_generic gc_type_cons gc_pos generic_info_index gcf_generic_info dcl_functions modules st build_exported_main_instance module_index {gc_gcf=GCFS gcfs,gc_type,gc_type_cons,gc_pos} (dcl_functions, modules, st) #! 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_gen_cons_without_instances gc_type gs_predefs - = build_exported_main_instances gcfs ins_type module_index gc_type_cons gc_pos has_generic_info + #! generic_info_index = index_gen_cons_with_info_type gc_type gs_predefs + = build_exported_main_instances gcfs ins_type module_index gc_type_cons gc_pos generic_info_index dcl_functions modules st where - build_exported_main_instances [!{gcf_body = GCB_FunIndex fun_index,gcf_generic,gcf_kind,gcf_gident}:gcfs!] ins_type module_index gc_type_cons gc_pos has_generic_info + build_exported_main_instances [!{gcf_body = GCB_FunIndex fun_index,gcf_generic,gcf_generic_info,gcf_kind,gcf_gident}:gcfs!] ins_type module_index gc_type_cons gc_pos generic_info_index dcl_functions modules st # (dcl_functions, modules, st) - = build_exported_main_instance_ ins_type module_index gcf_gident fun_index gcf_kind gcf_generic gc_type_cons gc_pos gc_type has_generic_info + = build_exported_main_instance_ ins_type module_index gcf_gident fun_index gcf_kind gcf_generic gc_type_cons gc_pos generic_info_index gcf_generic_info dcl_functions modules st - = build_exported_main_instances gcfs ins_type module_index gc_type_cons gc_pos has_generic_info + = build_exported_main_instances gcfs ins_type module_index gc_type_cons gc_pos generic_info_index dcl_functions modules st - build_exported_main_instances [!!] ins_type module_index gc_type_cons gc_pos has_generic_info + build_exported_main_instances [!!] ins_type module_index gc_type_cons gc_pos generic_info_index dcl_functions modules st = (dcl_functions, modules, st) - build_exported_main_instance_ :: InstanceType Int Ident Int TypeKind GlobalIndex TypeCons Position Type Bool + build_exported_main_instance_ :: InstanceType Int Ident Int TypeKind GlobalIndex TypeCons Position Int Int !*{#FunType} !*{#CommonDefs} !(!(!Index, ![ClassInstance]), !*Heaps, !*ErrorAdmin) -> (!*{#FunType},!*{#CommonDefs},!(!(!Index, ![ClassInstance]), !*Heaps, !*ErrorAdmin)) - build_exported_main_instance_ ins_type module_index gc_ident fun_index gcf_kind gcf_generic gc_type_cons gc_pos gc_type has_generic_info + build_exported_main_instance_ ins_type module_index gc_ident fun_index gcf_kind gcf_generic gc_type_cons gc_pos generic_info_index generic_info dcl_functions modules (ins_info, heaps, error) - #! (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] - - #! (fun_type, heaps, error) - = determine_type_of_member_instance member_def ins_type heaps error + # (gen_info_ptr, modules) = modules![gcf_generic.gi_module].com_generic_defs.[gcf_generic.gi_index].gen_info_ptr + ({gen_classes,gen_rep_conses}, hp_generic_heap) = readPtr gen_info_ptr heaps.hp_generic_heap + heaps & hp_generic_heap=hp_generic_heap + (Yes class_info) = lookupGenericClassInfo gcf_kind gen_classes #! fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons - | not has_generic_info + | generic_info_index<0 + #! (member_def, modules) = modules![class_info.gci_module].com_member_defs.[class_info.gci_member] + #! (fun_type, heaps, error) + = determine_type_of_member_instance member_def ins_type heaps error #! (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 gcf_kind class_instance_member ins_type ins_info = (dcl_functions, modules, (ins_info, heaps, error)) + # (fun_type,modules,heaps,error) + = case gen_rep_conses.[generic_info_index].grc_optional_fun_type of + Yes fun_type + -> (fun_type,modules,heaps,error) + No + #! (member_def, modules) = modules![class_info.gci_module].com_member_defs.[class_info.gci_member] + # (fun_type, heaps, error) + = determine_type_of_member_instance member_def ins_type heaps error + -> (fun_type,modules,heaps,error) # fun_type_with_generic_info - = add_generic_info_to_type fun_type (index_gen_cons_with_info_type gc_type gs_predefs) gs_predefs - + = if (generic_info<>0) + (add_generic_info_to_type fun_type generic_info_index generic_info gs_predefs) + fun_type #! (dcl_functions, heaps) = update_dcl_function fun_index fun_ident fun_type_with_generic_info dcl_functions heaps = (dcl_functions, modules, (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 + !*{#DclModule} !(!Index, ![ClassInstance]) !*SpecializeState + -> (!*{#DclModule},!(!Index, ![ClassInstance]), !*SpecializeState) + build_main_instances_in_main_module gs_main_module dcl_modules st1 st2 + #! (com_gencase_defs,st2) = st2!ss_modules.[gs_main_module].com_gencase_defs | size com_gencase_defs==0 - = (modules,dcl_modules,st) + = (dcl_modules,st1,st2) #! (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) + #! (dcl_functions, st1, st2) + = foldArraySt (build_main_instance gs_main_module) com_gencase_defs ({x\\x<-:dcl_functions}, st1, st2) + #! dcl_modules = {dcl_modules & [gs_main_module].dcl_functions = dcl_functions} + = (dcl_modules,st1,st2) where build_main_instance :: !Index !GenericCaseDef - (!*{#FunType}, !*Modules, !(FunsAndGroups, !(!Index, ![ClassInstance]), !*{#FunDef}, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)) - -> (!*{#FunType}, !*Modules, !(FunsAndGroups, !(!Index, ![ClassInstance]), !*{#FunDef}, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)) + (!*{#FunType}, !(!Index, ![ClassInstance]), !*SpecializeState) + -> (!*{#FunType}, !(!Index, ![ClassInstance]), !*SpecializeState) build_main_instance module_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, st) + {gc_gcf=GCF gc_ident {gcf_body = GCB_FunIndex fun_index,gcf_kind,gcf_generic,gcf_generic_info}, gc_type, gc_type_cons,gc_pos} + (dcl_functions, st1, st2) #! 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_gen_cons_without_instances gc_type gs_predefs - = build_main_instance_ ins_type module_index gc_ident fun_index gcf_kind gcf_generic gc_type_cons gc_pos gc_type has_generic_info - dcl_functions modules st + #! generic_info_index = index_gen_cons_with_info_type gc_type gs_predefs + = build_main_instance_ ins_type module_index gc_ident fun_index gcf_kind gcf_generic gc_type_cons gc_pos generic_info_index gcf_generic_info + dcl_functions st1 st2 build_main_instance module_index {gc_gcf=GCFS gcfs,gc_type,gc_type_cons,gc_pos} - (dcl_functions, modules, st) + (dcl_functions, st1, st2) #! 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_gen_cons_without_instances gc_type gs_predefs - = build_main_instances gcfs ins_type module_index gc_type_cons gc_pos has_generic_info dcl_functions modules st + #! generic_info_index = index_gen_cons_with_info_type gc_type gs_predefs + = build_main_instances gcfs ins_type module_index gc_type_cons gc_pos generic_info_index dcl_functions st1 st2 where - build_main_instances [!{gcf_body = GCB_FunIndex fun_index,gcf_generic,gcf_kind,gcf_gident}:gcfs!] ins_type module_index gc_type_cons gc_pos has_generic_info - dcl_functions modules st - # (dcl_functions, modules, st) - = build_main_instance_ ins_type module_index gcf_gident fun_index gcf_kind gcf_generic gc_type_cons gc_pos gc_type has_generic_info - dcl_functions modules st - = build_main_instances gcfs ins_type module_index gc_type_cons gc_pos has_generic_info dcl_functions modules st - build_main_instances [!!] ins_type module_index gc_type_cons gc_pos has_generic_info dcl_functions modules st - = (dcl_functions, modules, st) - - build_main_instance_ :: InstanceType Int Ident Int TypeKind GlobalIndex TypeCons Position Type Bool - !*{#FunType} !*Modules !(FunsAndGroups, !(!Index, ![ClassInstance]), !*{#FunDef}, !*TypeDefInfos, !*Heaps, !*ErrorAdmin) - -> (!*{#FunType}, !*Modules, !(FunsAndGroups, !(!Index, ![ClassInstance]), !*{#FunDef}, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)) - build_main_instance_ ins_type module_index gc_ident fun_index gcf_kind gcf_generic gc_type_cons gc_pos gc_type has_generic_info - dcl_functions modules st=:(fun_info, ins_info, fun_defs, td_infos, heaps, error) - #! (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] - - #! (fun_type, heaps, error) - = determine_type_of_member_instance member_def ins_type heaps error + build_main_instances [!{gcf_body = GCB_FunIndex fun_index,gcf_generic,gcf_kind,gcf_gident,gcf_generic_info}:gcfs!] ins_type module_index gc_type_cons gc_pos generic_info_index + dcl_functions st1 st2 + # (dcl_functions, st1, st2) + = build_main_instance_ ins_type module_index gcf_gident fun_index gcf_kind gcf_generic gc_type_cons gc_pos generic_info_index gcf_generic_info + dcl_functions st1 st2 + = build_main_instances gcfs ins_type module_index gc_type_cons gc_pos generic_info_index dcl_functions st1 st2 + build_main_instances [!!] ins_type module_index gc_type_cons gc_pos generic_info_index dcl_functions st1 st2 + = (dcl_functions, st1, st2) + + build_main_instance_ :: InstanceType Int Ident Int TypeKind GlobalIndex TypeCons Position Int Int + !*{#FunType} !(!Index, ![ClassInstance]) !*SpecializeState + -> (!*{#FunType},!(!Index, ![ClassInstance]),!*SpecializeState) + build_main_instance_ ins_type module_index gc_ident fun_index gcf_kind gcf_generic gc_type_cons gc_pos generic_info_index generic_info + dcl_functions ins_info st=:{ss_modules=modules,ss_heaps=heaps,ss_error=error} + # (gen_info_ptr, modules) = modules![gcf_generic.gi_module].com_generic_defs.[gcf_generic.gi_index].gen_info_ptr + ({gen_classes,gen_rep_conses}, hp_generic_heap) = readPtr gen_info_ptr heaps.hp_generic_heap + heaps & hp_generic_heap=hp_generic_heap + (Yes class_info) = lookupGenericClassInfo gcf_kind gen_classes #! fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons - | not has_generic_info + | generic_info_index<0 + #! (member_def, modules) = modules![class_info.gci_module].com_member_defs.[class_info.gci_member] + #! (fun_type, heaps, error) + = determine_type_of_member_instance member_def ins_type heaps error #! (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 gc_type_cons gc_pos gc_ident gcf_generic fun_type has_generic_info - fun_info fun_defs td_infos modules heaps error - + # st & ss_modules=modules, ss_heaps=heaps, ss_error=error + #! st = update_icl_function fun_index fun_ident gc_pos gc_type_cons gc_ident gcf_generic + fun_type generic_info_index -1 AllGenericInstanceDependencies st # 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 gcf_kind class_instance_member ins_type ins_info - = (dcl_functions, modules, (fun_info, ins_info, fun_defs, td_infos, heaps, error)) - + = (dcl_functions, ins_info, st) + + # {grc_optional_fun_type,grc_generic_instance_deps} = gen_rep_conses.[generic_info_index] + # (fun_type,modules,heaps,error) + = case grc_optional_fun_type of + Yes fun_type + -> (fun_type,modules,heaps,error) + No + #! (member_def, modules) = modules![class_info.gci_module].com_member_defs.[class_info.gci_member] + # (fun_type,heaps,error) = determine_type_of_member_instance member_def ins_type heaps error + -> (fun_type,modules,heaps,error) # fun_type_with_generic_info - = add_generic_info_to_type fun_type (index_gen_cons_with_info_type gc_type gs_predefs) gs_predefs - + = if (generic_info<>0) + (add_generic_info_to_type fun_type generic_info_index generic_info gs_predefs) + fun_type #! (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 fun_index fun_ident gc_type_cons gc_pos gc_ident gcf_generic 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)) - - instance_vars_from_type_cons (TypeConsVar tv) - = [tv] - instance_vars_from_type_cons _ - = [] + # st & ss_modules=modules,ss_heaps=heaps,ss_error=error + #! st = update_icl_function fun_index fun_ident gc_pos gc_type_cons gc_ident gcf_generic + fun_type_with_generic_info generic_info_index generic_info grc_generic_instance_deps st + = (dcl_functions, ins_info, st) build_shorthand_instances_in_modules :: !Index !*{#CommonDefs} !*{#DclModule} (FunsAndGroups, (!Index, ![ClassInstance]), !*Heaps, !*ErrorAdmin) @@ -1829,9 +1939,9 @@ 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_gcf=GCF _ {gcf_kind=KindConst}} st + build_shorthand_instances module_index {gc_gcf=GCF gc_ident {gcf_kind=KindConst}} st = 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 + build_shorthand_instances module_index {gc_gcf=GCF gc_ident {gcf_kind=KindArrow kinds,gcf_generic,gcf_body},gc_type,gc_type_cons,gc_pos} st = build_shorthand_instance_for_kinds gc_ident kinds gcf_generic gcf_body gc_type gc_type_cons gc_pos module_index st build_shorthand_instances module_index {gc_gcf=GCFS gcfs,gc_type,gc_type_cons,gc_pos} st = build_shorthand_instances_for_generic_superclasses gcfs module_index gc_type gc_type_cons gc_pos st @@ -1852,37 +1962,44 @@ where = case gcf_body of GCB_FunIndex fun_index -> fun_index - = foldSt (build_shorthand_instance fun_index) [1 .. length kinds] st + = foldSt (build_shorthand_instance gc_ident kinds gcf_generic fun_index gc_type gc_type_cons gc_pos module_index) [1 .. length kinds] st where - build_shorthand_instance fun_index num_args - (modules, (fun_info, ins_info, heaps, error)) + build_shorthand_instance gc_ident kinds gcf_generic fun_index gc_type gc_type_cons gc_pos module_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 gcf_generic this_kind (modules, heaps) #! (arg_class_infos, (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] + # (deps, modules) = modules![gcf_generic.gi_module].com_generic_defs.[gcf_generic.gi_index].gen_deps + # (dep_class_infoss, (modules, heaps)) + = mapSt (\{gd_index} -> mapSt (get_class_for_kind gd_index) consumed_kinds) deps (modules, heaps) + # class_idents = [(gcf_generic, gc_ident):[(gd_index, ident) \\ {gd_index, gd_ident=Ident ident} <- deps]] + # arg_and_dep_class_infoss = map (zip2 class_idents) (transpose [arg_class_infos:dep_class_infoss]) + #! (ins_type, heaps) - = build_instance_type gc_type arg_class_infos heaps + = build_instance_type gc_type num_args (map removeDupByIndex arg_and_dep_class_infoss) heaps + + #! (member_def, modules) = modules![class_info.gci_module].com_member_defs.[class_info.gci_member] #! (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 - - #! 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 gcf_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 fun_index fun_ident gc_pos fun_type (flatten arg_and_dep_class_infoss) 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 - #! 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} - #! arity = length class_infos + where + removeDupByIndex [] = [] + removeDupByIndex [x=:((indexx, _), _):xs] = [x:removeDupByIndex (filter (\((indexy, _), _) -> indexx <> indexy) xs)] + + build_instance_type type arity arg_and_dep_class_infoss heaps=:{hp_type_heaps=th=:{th_vars},hp_var_heap} #! type_var_names = [makeIdent ("a" +++ toString i) \\ i <- [1 .. arity]] #! (type_vars, th_vars) = mapSt freshTypeVar type_var_names th_vars #! type_var_types = [TV tv \\ tv <- type_vars] @@ -1890,8 +2007,10 @@ where #! type = fill_type_args type new_type_args + # num_contexts = length (hd arg_and_dep_class_infoss) + # context_type_vars = flatten (map (repeatn num_contexts) type_vars) #! (contexts, hp_var_heap) - = zipWithSt build_context class_infos type_vars hp_var_heap + = zipWithSt build_context (flatten arg_and_dep_class_infoss) context_type_vars hp_var_heap #! ins_type = { it_vars = type_vars @@ -1914,13 +2033,13 @@ where fill_type_args type args = abort ("fill_type_args\n"---> ("fill_type_args", type, args)) - build_context {gci_class, gci_module, gci_kind} tv hp_var_heap + build_context ((_, ident), {gci_class, gci_module, gci_kind}) tv hp_var_heap # (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - # type_context = + # type_context = { tc_class = TCClass { glob_module=gci_module // the same as icl module , glob_object = - { ds_ident = genericIdentToClassIdent gc_ident.id_name gci_kind + { ds_ident = genericIdentToClassIdent ident.id_name gci_kind , ds_index = gci_class , ds_arity = 1 } @@ -1930,9 +2049,9 @@ where } = (type_context, hp_var_heap) - build_shorthand_instance_member :: Int TypeKind GlobalIndex Bool Int Ident Position SymbolType [GenericClassInfo] !FunsAndGroups !*Heaps + build_shorthand_instance_member :: Int TypeKind Int Ident Position SymbolType [((GlobalIndex, Ident), GenericClassInfo)] !FunsAndGroups !*Heaps -> (!DefinedSymbol,!FunsAndGroups,!*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 + build_shorthand_instance_member module_index this_kind fun_index fun_ident gc_pos st arg_and_dep_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 @@ -1940,7 +2059,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 gcf_generic gc_ident) class_infos heaps + # (gen_exprs, heaps) = mapSt build_generic_app arg_and_dep_class_infos heaps #! arg_exprs = gen_exprs ++ arg_var_exprs # (body_expr, heaps) @@ -1953,10 +2072,9 @@ where = (fun_ds, fun_info, heaps) where - build_generic_app {gi_module, gi_index} gc_ident {gci_kind} heaps - = buildGenericApp gi_module gi_index gc_ident gci_kind [] heaps + build_generic_app (({gi_module, gi_index}, ident), {gci_kind}) heaps + = buildGenericApp gi_module gi_index ident gci_kind [] heaps - 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 #! ins = @@ -2001,44 +2119,97 @@ where = (dcl_functions, heaps) = (dcl_functions, heaps) - update_icl_function :: !Index !Ident !TypeCons !Position !Ident !GlobalIndex !SymbolType !Bool - !FunsAndGroups !*{#FunDef} !*TypeDefInfos !*{#CommonDefs} !*Heaps !*ErrorAdmin - -> (!FunsAndGroups,!*{#FunDef},!*TypeDefInfos,!*{#CommonDefs},!*Heaps,!*ErrorAdmin) - update_icl_function fun_index fun_ident gc_type_cons gc_pos gc_ident gcf_generic 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 + update_icl_function :: !Index !Ident !Position !TypeCons !Ident !GlobalIndex !SymbolType !Int !Int !GenericInstanceDependencies + !*SpecializeState -> *SpecializeState + update_icl_function fun_index fun_ident gc_pos gc_type_cons gc_ident gcf_generic symbol_type generic_info_index generic_info generic_instance_deps + st + #! (symbol_type, heaps) = fresh_symbol_type symbol_type st.ss_heaps + # st & ss_heaps = heaps + #! (fun=:{fun_body, fun_arity}, st) = st!ss_funs.[fun_index] + = case fun_body of TransformedBody {tb_args,tb_rhs} // user defined case - | has_generic_info - | fun_arity<>st.st_arity - # error = reportError gc_ident.id_name 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} - -> (funs_and_groups, fun_defs, td_infos, modules, heaps, error) - # fun_body = TransformedBody {tb_args = tl tb_args, tb_rhs = tb_rhs} - | fun_arity-1<>st.st_arity - # error = reportError gc_ident.id_name gc_pos ("incorrect arity " +++ toString (fun_arity-1) - +++ ", expected " +++ toString st.st_arity) error - -> (funs_and_groups, fun_defs, td_infos, modules, heaps, error) - #! fun = {fun & fun_ident = fun_ident, fun_body = fun_body, fun_type = Yes st} - #! fun_defs = {fun_defs & [fun_index] = fun} - -> (funs_and_groups, fun_defs, td_infos, modules, heaps, error) + | generic_info_index>=0 + # n_unused_dep_args + = case generic_instance_deps of + GenericInstanceDependencies n_deps deps + -> n_deps - add_n_bits deps 0 + _ + -> 0 + | generic_info==0 + // remove generic info argument + # tb_args = tl tb_args + fun_arity = fun_arity-1 + | fun_arity<>symbol_type.st_arity + n_unused_dep_args + # error = reportError gc_ident.id_name gc_pos + ("incorrect arity "+++toString fun_arity+++", expected "+++toString (symbol_type.st_arity+n_unused_dep_args)) st.ss_error + -> {st & ss_error=error} + # (tb_args,fun_arity) + = case generic_instance_deps of + GenericInstanceDependencies n_deps deps + # tb_args = remove_unused_dep_args tb_args 0 n_deps deps + # fun_arity = fun_arity-n_unused_dep_args + -> (tb_args,fun_arity) + _ + -> (tb_args,fun_arity) + # fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs} + # fun = {fun & fun_ident = fun_ident, fun_type = Yes symbol_type, fun_body = fun_body, fun_arity = fun_arity} + -> {st & ss_funs.[fun_index] = fun} + | generic_info<0 + // keep generic info argument + | fun_arity<>symbol_type.st_arity + n_unused_dep_args + # error = reportError gc_ident.id_name gc_pos + ("incorrect arity "+++toString (fun_arity-1)+++", expected "+++toString (symbol_type.st_arity+n_unused_dep_args-1)) st.ss_error + -> {st & ss_error=error} + # (fun_body,fun_arity) + = case generic_instance_deps of + GenericInstanceDependencies n_deps deps + # [generic_info_arg:args] = tb_args + # tb_args = [generic_info_arg : remove_unused_dep_args args 0 n_deps deps] + # fun_arity = fun_arity-n_unused_dep_args + -> (TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs},fun_arity) + _ + -> (fun_body,fun_arity) + # fun = {fun & fun_ident = fun_ident, fun_type = Yes symbol_type, fun_body = fun_body, fun_arity = fun_arity} + -> {st & ss_funs.[fun_index] = fun} + // generic info record already replaced by fields + # n_generic_info_field = add_n_bits generic_info 0 + | fun_arity<>symbol_type.st_arity + n_unused_dep_args + # error = reportError gc_ident.id_name gc_pos + ("incorrect arity "+++toString (fun_arity-n_generic_info_field)+++", expected "+++toString (symbol_type.st_arity+n_unused_dep_args-n_generic_info_field)) st.ss_error + -> {st & ss_error=error} + # (fun_body,fun_arity) + = case generic_instance_deps of + GenericInstanceDependencies n_deps deps + # (generic_info_args,args) = splitAt n_generic_info_field tb_args + # tb_args = generic_info_args ++ remove_unused_dep_args args 0 n_deps deps + # fun_arity = fun_arity-n_unused_dep_args + -> (TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs},fun_arity) + _ + -> (fun_body,fun_arity) + # fun = {fun & fun_ident = fun_ident, fun_type = Yes symbol_type, fun_body = fun_body, fun_arity = fun_arity} + -> {st & ss_funs.[fun_index] = fun} + // not a special generic instance, remove generic info argument + # tb_args = tl tb_args + fun_arity = fun_arity-1 + # fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs} + | fun_arity<>symbol_type.st_arity + # error = reportError gc_ident.id_name gc_pos + ("incorrect arity "+++toString fun_arity+++", expected "+++toString symbol_type.st_arity) st.ss_error + -> {st & ss_error=error} + # fun = {fun & fun_ident = fun_ident, fun_body = fun_body, fun_type = Yes symbol_type, fun_arity=fun_arity} + -> {st & ss_funs.[fun_index] = fun} GeneratedBody // derived case - #! (TransformedBody {tb_args, tb_rhs}, funs_and_groups, td_infos, modules, heaps, error) - = buildGenericCaseBody gs_main_module gc_pos gc_type_cons gc_ident gcf_generic has_generic_info st gs_predefs funs_and_groups td_infos modules heaps error - # {fg_group_index,fg_groups} = funs_and_groups - #! fun = makeFunction fun_ident fg_group_index tb_args tb_rhs (Yes st) gs_main_module gc_pos - #! fun_defs = {fun_defs & [fun_index] = fun} + #! (TransformedBody {tb_args, tb_rhs}, st) + = buildGenericCaseBody gs_main_module gc_pos gc_type_cons gc_ident generic_info_index gcf_generic gs_predefs st + # funs_and_groups=:{fg_group_index,fg_groups} = st.ss_funs_and_groups + #! fun = makeFunction fun_ident fg_group_index tb_args tb_rhs (Yes symbol_type) gs_main_module gc_pos # 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) + funs_and_groups & fg_group_index=fg_group_index+1,fg_groups=[group:fg_groups] + -> {st & ss_funs.[fun_index] = fun, ss_funs_and_groups = funs_and_groups} build_class_instance :: Int Ident Position TypeKind ClassInstanceMember InstanceType !(!Int,![ClassInstance]) -> (!Int,![ClassInstance]) - 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} + 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 #! ins = { ins_class_index = {gi_module=gs_main_module, gi_index=class_index} , ins_class_ident = {ci_ident=Ident class_ident, ci_arity=1} @@ -2051,33 +2222,156 @@ where } = (ins_index+1, [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 - = (fresh_st, {heaps & hp_type_heaps = hp_type_heaps}) +add_n_bits :: !Int !Int -> Int +add_n_bits n c + | n>1 + = add_n_bits (n>>1) (c+(n bitand 1)) + = c+n + +remove_unused_dep_args :: ![FreeVar] !Int !Int !Int -> [FreeVar] +remove_unused_dep_args args=:[arg:r_args] arg_n n_deps deps + | arg_n>=n_deps + = args + | deps bitand (1<0 + = [arg : remove_unused_dep_args r_args (arg_n+1) n_deps deps] + = remove_unused_dep_args r_args (arg_n+1) n_deps deps +remove_unused_dep_args [] arg_n n_deps deps + = [] + +determine_type_of_member_instance_from_symbol_type :: !SymbolType !InstanceType !*TypeHeaps !*VarHeap !*ErrorAdmin + -> (!SymbolType, !*TypeHeaps, !*VarHeap, !*ErrorAdmin) +determine_type_of_member_instance_from_symbol_type me_type=:{st_context=[{tc_types = [TV class_var]}:_]} ins_type hp_type_heaps hp_var_heap error + #! (symbol_type, _, hp_type_heaps, _, error) + = determineTypeOfMemberInstance me_type [class_var] ins_type SP_None hp_type_heaps No error + #! (st_context, hp_var_heap) = initializeContextVariables symbol_type.st_context hp_var_heap + #! hp_type_heaps = clearSymbolType me_type hp_type_heaps + #! symbol_type = {symbol_type & st_context = st_context} + = (symbol_type, hp_type_heaps, hp_var_heap, error) // add an argument for generic info at the beginning -add_generic_info_to_type :: !SymbolType !Int !{#PredefinedSymbol} -> SymbolType -add_generic_info_to_type st=:{st_arity, st_args, st_args_strictness} generic_info_index predefs - # st_args = add_generic_info_types generic_info_index st_args predefs - = {st & st_args = st_args, st_arity = st_arity + 1, st_args_strictness = insert_n_lazy_values_at_beginning 1 st_args_strictness} +add_generic_info_to_type :: !SymbolType !Int !Int !{#PredefinedSymbol} -> SymbolType +add_generic_info_to_type st=:{st_arity, st_args, st_args_strictness} generic_info_index generic_info predefs + # (st_args,n_new_args) = add_generic_info_types generic_info_index generic_info st_args predefs + = {st & st_args = st_args, st_arity = st_arity + n_new_args, st_args_strictness = insert_n_lazy_values_at_beginning n_new_args st_args_strictness} where - add_generic_info_types 0 args predefs - # {pds_module, pds_def} = predefs.[PD_TGenericTypeDefDescriptor] - #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericTypeDefDescriptor] 0 - = [makeAType (TA type_symb []) TA_Multi : args] - add_generic_info_types 1 args predefs - # {pds_module, pds_def} = predefs.[PD_TGenericConsDescriptor] - #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericConsDescriptor] 0 - = [makeAType (TA type_symb []) TA_Multi : args] - add_generic_info_types 2 args predefs - # {pds_module, pds_def} = predefs.[PD_TGenericRecordDescriptor] - #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericRecordDescriptor] 0 - = [makeAType (TA type_symb []) TA_Multi : args] - add_generic_info_types 3 args predefs - # {pds_module, pds_def} = predefs.[PD_TGenericFieldDescriptor] - #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericFieldDescriptor] 0 - = [makeAType (TA type_symb []) TA_Multi : args] + add_generic_info_types 0 generic_info args predefs + | generic_info== -1 + # {pds_module, pds_def} = predefs.[PD_TGenericTypeDefDescriptor] + #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericTypeDefDescriptor] 0 + = ([makeAType (TA type_symb []) TA_Multi : args], 1) + = add_OBJECT_field_args generic_info args predefs + add_generic_info_types 1 generic_info args predefs + | generic_info== -1 + # {pds_module, pds_def} = predefs.[PD_TGenericConsDescriptor] + #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericConsDescriptor] 0 + = ([makeAType (TA type_symb []) TA_Multi : args], 1) + = add_CONS_field_args generic_info args predefs + add_generic_info_types 2 generic_info args predefs + | generic_info== -1 + # {pds_module, pds_def} = predefs.[PD_TGenericRecordDescriptor] + #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericRecordDescriptor] 0 + = ([makeAType (TA type_symb []) TA_Multi : args], 1) + = add_RECORD_field_args generic_info args predefs + add_generic_info_types 3 generic_info args predefs + | generic_info== -1 + # {pds_module, pds_def} = predefs.[PD_TGenericFieldDescriptor] + #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericFieldDescriptor] 0 + = ([makeAType (TA type_symb []) TA_Multi : args], 1) + = add_FIELD_field_args generic_info args predefs + + add_OBJECT_field_args generic_info args predefs + | generic_info bitand 1<>0 // gtd_name + # (args,n_args) = add_OBJECT_field_args (generic_info bitxor 1) args predefs + = add_String_arg args n_args + | generic_info bitand 2<>0 // gtd_arity + # (args,n_args) = add_OBJECT_field_args (generic_info bitxor 2) args predefs + = add_Int_arg args n_args + | generic_info bitand 4<>0 // gtd_num_conses + # (args,n_args) = add_OBJECT_field_args (generic_info bitxor 4) args predefs + = add_Int_arg args n_args + | generic_info bitand 8<>0 // gtd_conses + # (args,n_args) = add_RECORD_field_args (generic_info bitxor 8) args predefs + # {pds_module, pds_def} = predefs.[PD_TGenericConsDescriptor] + #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericConsDescriptor] 0 + # type_GenericConsDescriptor = {at_type= TA type_symb [], at_attribute = TA_Multi} + # {pds_module,pds_def} = predefs.[PD_ListType] + #! string_type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_ListType] 1 + = ([{at_type = TA string_type_symb [type_GenericConsDescriptor], at_attribute = TA_Multi} : args],n_args+1) + = (args,0) + + add_CONS_field_args generic_info args predefs + | generic_info bitand 1<>0 // gcd_name + # (args,n_args) = add_CONS_field_args (generic_info bitxor 1) args predefs + = add_String_arg args n_args + | generic_info bitand 2<>0 // gcd_arity + # (args,n_args) = add_CONS_field_args (generic_info bitxor 2) args predefs + = add_Int_arg args n_args + | generic_info bitand 4<>0 // gcd_prio + # (args,n_args) = add_CONS_field_args (generic_info bitxor 4) args predefs + # {pds_module, pds_def} = predefs.[PD_TGenConsPrio] + #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenConsPrio] 0 + = ([{at_type = TA type_symb [], at_attribute = TA_Multi} : args],n_args+1) + | generic_info bitand 8<>0 // gcd_type_def + # (args,n_args) = add_CONS_field_args (generic_info bitxor 8) args predefs + # {pds_module, pds_def} = predefs.[PD_TGenericTypeDefDescriptor] + #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericTypeDefDescriptor] 0 + = ([{at_type = TA type_symb [], at_attribute = TA_Multi} : args],n_args+1) + | generic_info bitand 16<>0 // gcd_type + # (args,n_args) = add_CONS_field_args (generic_info bitxor 16) args predefs + # {pds_module, pds_def} = predefs.[PD_TGenType] + #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenType] 0 + = ([{at_type = TA type_symb [], at_attribute = TA_Multi} : args],n_args+1) + | generic_info bitand 32<>0 // gcd_index + # (args,n_args) = add_CONS_field_args (generic_info bitxor 32) args predefs + = add_Int_arg args n_args + = (args,0) + + add_RECORD_field_args generic_info args predefs + | generic_info bitand 1<>0 // grd_name + # (args,n_args) = add_RECORD_field_args (generic_info bitxor 1) args predefs + = add_String_arg args n_args + | generic_info bitand 2<>0 // grd_arity + # (args,n_args) = add_RECORD_field_args (generic_info bitxor 2) args predefs + = add_Int_arg args n_args + | generic_info bitand 4<>0 // grd_type_arity + # (args,n_args) = add_RECORD_field_args (generic_info bitxor 4) args predefs + = add_Int_arg args n_args + | generic_info bitand 8<>0 // grd_type + # (args,n_args) = add_RECORD_field_args (generic_info bitxor 8) args predefs + # {pds_module, pds_def} = predefs.[PD_TGenType] + #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenType] 0 + = ([{at_type = TA type_symb [], at_attribute = TA_Multi} : args],n_args+1) + | generic_info bitand 16<>0 // grd_fields + # (args,n_args) = add_RECORD_field_args (generic_info bitxor 16) args predefs + # {pds_module,pds_def} = predefs.[PD_StringType] + #! string_type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_StringType] 0 + # string_type = {at_type = TA string_type_symb [], at_attribute = TA_Multi} + # {pds_module,pds_def} = predefs.[PD_ListType] + #! string_type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_ListType] 1 + = ([{at_type = TA string_type_symb [string_type], at_attribute = TA_Multi} : args],n_args+1) + = (args,0) + + add_FIELD_field_args generic_info args predefs + | generic_info bitand 1<>0 // gfd_name + # (args,n_args) = add_FIELD_field_args (generic_info bitxor 1) args predefs + = add_String_arg args n_args + | generic_info bitand 2<>0 // gfd_index + # (args,n_args) = add_FIELD_field_args (generic_info bitxor 2) args predefs + = add_Int_arg args n_args + | generic_info bitand 4<>0 // gfd_cons + # (args,n_args) = add_FIELD_field_args (generic_info bitxor 4) args predefs + # {pds_module, pds_def} = predefs.[PD_TGenericRecordDescriptor] + #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericRecordDescriptor] 0 + = ([{at_type = TA type_symb [], at_attribute = TA_Multi} : args],n_args+1) + = (args,0) + + add_String_arg args n_args + # {pds_module,pds_def} = predefs.[PD_StringType] + #! string_type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_StringType] 0 + = ([{at_type = TA string_type_symb [], at_attribute = TA_Multi} : args],n_args+1) + + add_Int_arg args n_args + = ([{at_type = TB BT_Int, at_attribute = TA_Multi} : args],n_args+1) index_gen_cons_with_info_type :: !Type !{#PredefinedSymbol} -> Int index_gen_cons_with_info_type (TA {type_index={glob_module,glob_object}} []) predefs @@ -2090,6 +2384,12 @@ index_gen_cons_with_info_type (TA {type_index={glob_module,glob_object}} []) pre = 2 | glob_object==predefs.[PD_TypeFIELD].pds_def = 3 + | glob_object==predefs.[PD_TypePAIR].pds_def + = 4 + | glob_object==predefs.[PD_TypeEITHER].pds_def + = 5 + | glob_object==predefs.[PD_TypeUNIT].pds_def + = 6 = -1 = -1 index_gen_cons_with_info_type _ predefs @@ -2102,47 +2402,50 @@ is_gen_cons_without_instances (TA {type_index={glob_module,glob_object}} []) pre || glob_object==predefs.[PD_TypeCONS].pds_def || glob_object==predefs.[PD_TypeRECORD].pds_def || glob_object==predefs.[PD_TypeFIELD].pds_def + || glob_object==predefs.[PD_TypePAIR].pds_def + || glob_object==predefs.[PD_TypeEITHER].pds_def + || glob_object==predefs.[PD_TypeUNIT].pds_def = False is_gen_cons_without_instances _ predefs = False buildGenericCaseBody :: !Index // current icl module - !Position !TypeCons !Ident !GlobalIndex - !Bool - !SymbolType // type of the instance function + !Position !TypeCons !Ident !Int !GlobalIndex !PredefinedSymbols - !FunsAndGroups !*TypeDefInfos !*{#CommonDefs} !*Heaps !*ErrorAdmin + !*SpecializeState -> (!FunctionBody, - !FunsAndGroups, !*TypeDefInfos,!*{#CommonDefs},!*Heaps,!*ErrorAdmin) -buildGenericCaseBody main_module_index gc_pos (TypeConsSymb {type_ident,type_index}) gc_ident gcf_generic has_generic_info st predefs - funs_and_groups td_infos modules heaps error + !*SpecializeState) +buildGenericCaseBody main_module_index gc_pos (TypeConsSymb {type_ident,type_index}) gc_ident generic_info_index gcf_generic predefs + st=:{ss_modules=modules,ss_td_infos=td_infos,ss_heaps=heaps} #! (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 + #! (td_info=:{tdi_gen_rep}, td_infos) = td_infos![type_index.glob_module, type_index.glob_object] + # (gen_type_rep=:{gtr_type}) = case tdi_gen_rep of Yes x -> x No -> abort "sanity check: no generic representation\n" #! (type_def=:{td_args, td_arity}, modules) = modules![type_index.glob_module].com_type_defs.[type_index.glob_object] - #! (generated_arg_exprs, original_arg_exprs, arg_vars, heaps) - = build_arg_vars gen_def td_args heaps + #! (generated_arg_exprss, original_arg_exprs, arg_vars, heaps) + = build_arg_vars gen_def gcf_generic td_args heaps # (arg_vars,heaps) - = case has_generic_info of - True - # (generic_info_var, heaps) = build_generic_info_arg heaps - #! arg_vars = [generic_info_var:arg_vars] - -> (arg_vars,heaps) - False - -> (arg_vars,heaps) - - #! (specialized_expr, 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 - + = if (generic_info_index>=0) + (let + (generic_info_var, heaps_) = build_generic_info_arg heaps + arg_vars = [generic_info_var:arg_vars] + in (arg_vars,heaps_)) + (arg_vars,heaps) + + # st & ss_modules=modules,ss_td_infos=td_infos,ss_heaps=heaps + #! (specialized_expr, st) + = build_specialized_expr gc_pos gc_ident gcf_generic gen_def.gen_deps gtr_type td_args generated_arg_exprss gen_def.gen_info_ptr st + + # {ss_modules=modules,ss_td_infos=td_infos,ss_funs_and_groups=funs_and_groups,ss_heaps=heaps,ss_error=error} = st #! (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 + # st & ss_modules=modules,ss_td_infos=td_infos,ss_funs_and_groups=funs_and_groups,ss_heaps=heaps,ss_error=error - = (TransformedBody {tb_args=arg_vars, tb_rhs=body_expr}, funs_and_groups, td_infos, modules, heaps, error) + = (TransformedBody {tb_args=arg_vars, tb_rhs=body_expr}, st) where build_generic_info_arg heaps=:{hp_var_heap} // generic arg is never referenced in the generated body @@ -2150,36 +2453,47 @@ where #! fv = {fv_count = 0, fv_ident = makeIdent "geninfo", fv_info_ptr = fv_info_ptr, fv_def_level = NotALevel} = (fv, {heaps & hp_var_heap = hp_var_heap}) - build_arg_vars {gen_ident, gen_vars, gen_type} td_args heaps - #! (generated_arg_exprs, generated_arg_vars, heaps) - = buildVarExprs - [ gen_ident.id_name +++ atv_variable.tv_ident.id_name \\ {atv_variable} <- td_args] + build_arg_vars {gen_ident, gen_vars, gen_type, gen_deps} gcf_generic td_args heaps + # dep_names = [(gen_ident, gen_vars, gcf_generic) : [(ident, gd_vars, gd_index) \\ {gd_ident=Ident ident, gd_vars, gd_index} <- gen_deps]] + #! (generated_arg_exprss, generated_arg_vars, heaps) + = mapY2St buildVarExprs + [[mkDepName dep_name atv_variable \\ dep_name <- dep_names] \\ {atv_variable} <- td_args] heaps #! (original_arg_exprs, original_arg_vars, heaps) = buildVarExprs [ "x" +++ toString n \\ n <- [1 .. gen_type.st_arity]] heaps - = (generated_arg_exprs, original_arg_exprs, generated_arg_vars ++ original_arg_vars, heaps) + = (generated_arg_exprss, original_arg_exprs, flatten generated_arg_vars ++ original_arg_vars, heaps) + where + mkDepName (ident, gvars, index) atv + # gvarsName = foldl (\vs v -> vs +++ "_" +++ v.tv_ident.id_name) "" gvars + # indexName = "_" +++ toString index.gi_module +++ "-" +++ toString index.gi_index + = ident.id_name +++ gvarsName +++ indexName +++ "_" +++ atv.tv_ident.id_name // generic function specialized to the generic representation of the type - build_specialized_expr gc_pos gc_ident gcf_generic gtr_type td_args generated_arg_exprs gen_info_ptr funs_and_groups td_infos heaps error - #! spec_env = [(atv_variable, TVI_Expr False expr) \\ {atv_variable} <- td_args & expr <- generated_arg_exprs] + build_specialized_expr gc_pos gc_ident gcf_generic gen_deps gtr_type td_args generated_arg_exprss gen_info_ptr st + // TODO: TvN: bimap_spec_env is hacked to fit the original description of a spec_env, taking the hd of the generated_arg_exprss, change it? + #! bimap_spec_env = [(atv_variable, TVI_Expr False (hd exprs)) \\ {atv_variable} <- td_args & exprs <- generated_arg_exprss] + // TODO: TvN: very quick and dirty implementation, must include generic dependency variables as well to look up right argument with + // multiple dependencies on the same generic function but with different generic dependency variables + // See functions: specialize_type_var and checkgenerics.check_dependency + #! spec_env = [(atv_variable, TVI_Exprs (zip2 [gcf_generic:[gd_index \\ {gd_index} <- gen_deps]] exprs)) \\ {atv_variable} <- td_args & exprs <- generated_arg_exprss] # generic_bimap = predefs.[PD_GenericBimap] | gcf_generic.gi_module==generic_bimap.pds_module && gcf_generic.gi_index==generic_bimap.pds_def // JvG: can probably make special version of simplify_bimap_GenTypeStruct that doesn't simplify if any var occurs, because all vars are passed - # (gtr_type, heaps) = simplify_bimap_GenTypeStruct [atv_variable \\ {atv_variable} <- td_args] gtr_type heaps + # (gtr_type, heaps) = simplify_bimap_GenTypeStruct [atv_variable \\ {atv_variable} <- td_args] gtr_type st.ss_heaps # (expr,funs_and_groups,heaps,error) - = specialize_generic_bimap gcf_generic gtr_type spec_env gc_ident gc_pos main_module_index predefs funs_and_groups heaps error - = (expr,funs_and_groups,td_infos,heaps,error) + = specialize_generic_bimap gcf_generic gtr_type bimap_spec_env gc_ident gc_pos main_module_index predefs st.ss_funs_and_groups heaps st.ss_error + # st & ss_funs_and_groups=funs_and_groups,ss_heaps=heaps,ss_error=error + = (expr,st) - # ({gen_rep_conses},generic_heap) = readPtr gen_info_ptr heaps.hp_generic_heap - heaps = {heaps & hp_generic_heap=generic_heap} + # heaps = st.ss_heaps + ({gen_rep_conses},generic_heap) = readPtr gen_info_ptr heaps.hp_generic_heap + st & ss_heaps= {heaps & hp_generic_heap=generic_heap} - # (expr,td_infos,heaps,error) - = specializeGeneric gcf_generic gtr_type spec_env gc_ident gc_pos gen_rep_conses main_module_index td_infos heaps error - = (expr,funs_and_groups,td_infos,heaps,error) + = specializeGeneric gcf_generic gtr_type spec_env gc_ident gc_pos gen_deps gen_rep_conses gen_info_ptr main_module_index predefs st // adaptor that converts a function for the generic representation into a // function for the type itself @@ -2241,9 +2555,9 @@ 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_pos _ gc_ident gcf_generic 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) +buildGenericCaseBody main_module_index gc_pos gc_type_cons gc_ident generic_info_index gcf_generic predefs st + # error = reportError gc_ident.id_name gc_pos "cannot specialize to this type" st.ss_error + = (TransformedBody {tb_args=[], tb_rhs=EE}, {st & ss_error=error}) // convert generic type contexts into normal type contexts @@ -2283,12 +2597,12 @@ where # funs = {funs & [fun_index] = fun} = convert_functions (inc fun_index) funs st where - convert_function :: !FunDef !(!*Modules, !*Heaps, !*ErrorAdmin) + convert_function :: !FunDef !(!*Modules, !*Heaps, !*ErrorAdmin) -> (!FunDef,!(!*Modules, !*Heaps, !*ErrorAdmin)) - convert_function fun=:{fun_type=Yes symbol_type=:{st_context}, fun_ident, fun_pos} st - # (has_converted, st_context, st) = convert_contexts fun_ident fun_pos st_context st - | has_converted - # fun = {fun & fun_type = Yes {symbol_type & st_context = st_context}} + convert_function fun=:{fun_type=Yes symbol_type, fun_ident, fun_pos} st + # (has_converted_context, symbol_type, st) = convert_contexts_in_symbol_type fun_ident fun_pos symbol_type st + | has_converted_context + # fun = {fun & fun_type = Yes symbol_type} = (fun, st) = (fun, st) convert_function fun st @@ -2300,10 +2614,10 @@ where # (modules, dcl_modules, st) = convert_module module_index modules dcl_modules st = convert_modules (inc module_index) modules dcl_modules st - convert_module :: !Index !*Modules !*DclModules (!*Heaps, !*ErrorAdmin) - -> (!*Modules,!*DclModules,(!*Heaps, !*ErrorAdmin)) + convert_module :: !Index !*Modules !*DclModules (!*Heaps,!*ErrorAdmin) + -> (!*Modules,!*DclModules,(!*Heaps,!*ErrorAdmin)) convert_module module_index modules dcl_modules st - | inNumberSet module_index gs_used_modules + | inNumberSet module_index gs_used_modules #! (common_defs, modules) = modules ! [module_index] #! (dcl_module=:{dcl_functions, dcl_common}, dcl_modules) = dcl_modules ! [module_index] @@ -2317,18 +2631,21 @@ where | otherwise = (modules, dcl_modules, st) - convert_common_defs common_defs=:{com_class_defs, com_member_defs, com_instance_defs} modules (heaps, error) + convert_common_defs common_defs=:{com_class_defs,com_member_defs,com_instance_defs,com_cons_defs} modules (heaps, error) # (com_class_defs, st) = updateArraySt convert_class {x\\x<-:com_class_defs} (modules, heaps, error) # (com_member_defs, st) = updateArraySt convert_member {x\\x<-:com_member_defs} st - # (com_instance_defs, (modules, heaps, error)) + # (com_instance_defs, st) = updateArraySt convert_instance {x\\x<-:com_instance_defs} st - + # (com_cons_defs, (modules, heaps, error)) + = updateArraySt convert_constructor {x\\x<-:com_cons_defs} st + # common_defs = { common_defs & com_class_defs = com_class_defs , com_member_defs = com_member_defs , com_instance_defs = com_instance_defs + , com_cons_defs = com_cons_defs } = (common_defs, modules, (heaps, error)) where @@ -2338,10 +2655,11 @@ where # class_def={class_def & class_context = class_context} = (class_def, st) = (class_def, st) - convert_member member_def=:{me_ident, me_pos, me_type=me_type=:{st_context}} st - # (ok, st_context, st) = convert_contexts me_ident me_pos st_context st + + convert_member member_def=:{me_ident, me_pos, me_type} st + # (ok, me_type, st) = convert_contexts_in_symbol_type me_ident me_pos me_type st | ok - # member_def={member_def & me_type = {me_type & st_context = st_context}} + # member_def={member_def & me_type = me_type} = (member_def, st) = (member_def, st) @@ -2349,21 +2667,52 @@ where # (ok, it_context, st) = convert_contexts ins_ident ins_pos it_context st | ok # ins={ins & ins_type = {ins_type & it_context = it_context}} - = (ins, st) - = (ins, st) - + = (ins, st) + = (ins, st) + + convert_constructor cons=:{cons_ident,cons_pos,cons_type} st + # (has_converted_context, cons_type, st) = convert_contexts_in_symbol_type cons_ident cons_pos cons_type st + | has_converted_context + = ({cons & cons_type=cons_type}, st) + = (cons, st) + convert_dcl_functions dcl_functions modules (heaps, error) # (dcl_functions, (modules, heaps, error)) = updateArraySt convert_dcl_function dcl_functions (modules, heaps, error) = (dcl_functions, modules, (heaps, error)) where - convert_dcl_function fun=:{ft_type=ft_type=:{st_context}, ft_ident, ft_pos} st - # (ok, st_context, st) = convert_contexts ft_ident ft_pos st_context st + convert_dcl_function fun=:{ft_type, ft_ident, ft_pos} st + # (ok, ft_type, st) = convert_contexts_in_symbol_type ft_ident ft_pos ft_type st | ok - # fun={fun & ft_type = {ft_type & st_context = st_context}} + # fun={fun & ft_type = ft_type} = (fun, st) = (fun, st) - + + convert_contexts_in_symbol_type :: Ident Position !SymbolType !(!*{#CommonDefs},!*Heaps,!*ErrorAdmin) + -> (!Bool,!SymbolType,!(!*{#CommonDefs},!*Heaps,!*ErrorAdmin)) + convert_contexts_in_symbol_type fun_ident fun_pos symbol_type=:{st_context,st_args} st + # (has_converted_context, st_context, st) = convert_contexts fun_ident fun_pos st_context st + (has_converted_arg, st_args, st) = convert_contexts_in_args fun_ident fun_pos st_args st + | has_converted_context || has_converted_arg + = (True,{symbol_type & st_context=st_context, st_args=st_args}, st) + = (False,symbol_type, st) + + convert_contexts_in_args :: Ident Position ![AType] !(!*{#CommonDefs},!*Heaps,!*ErrorAdmin) + -> (!Bool,![AType],!(!*{#CommonDefs},!*Heaps,!*ErrorAdmin)) + convert_contexts_in_args fun_ident fun_pos arg_args=:[arg=:{at_type=TFAC tvs t contexts}:args] st + # (has_converted_context,contexts,st) = convert_contexts fun_ident fun_pos contexts st + # (has_converted_arg,args,st) = convert_contexts_in_args fun_ident fun_pos args st + | has_converted_context || has_converted_arg + = (True,[{arg & at_type=TFAC tvs t contexts}:args],st) + = (False,arg_args,st) + convert_contexts_in_args fun_ident fun_pos arg_args=:[arg:args] st + # (has_converted_arg,args,st) = convert_contexts_in_args fun_ident fun_pos args st + | has_converted_arg + = (True,[arg:args],st) + = (False,arg_args,st) + convert_contexts_in_args fun_ident fun_pos [] st + = (False,[],st) + convert_contexts fun_name fun_pos [] st = (False, [], st) convert_contexts fun_name fun_pos all_tcs=:[tc:tcs] st @@ -2375,7 +2724,7 @@ 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) + convert_context fun_name fun_pos tc=:{tc_class=TCGeneric gtc=:{gtc_generic, gtc_kind}} (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 @@ -2408,105 +2757,472 @@ specializeGeneric :: ![(TypeVar, TypeVarInfo)] // specialization environment !Ident // generic/generic case !Position // of generic case - !{#GenericRepresentationConstructor} + ![GenericDependency] + !{!GenericRepresentationConstructor} + !GenericInfoPtr !Index // main_module index - !*TypeDefInfos !*Heaps !*ErrorAdmin + !PredefinedSymbols + !*SpecializeState -> (!Expression, - !*TypeDefInfos,!*Heaps,!*ErrorAdmin) -specializeGeneric gen_index type spec_env gen_ident gen_pos gen_rep_conses main_module_index td_infos heaps error - #! heaps = set_tvs spec_env heaps - #! (expr, (td_infos, heaps, error)) - = specialize type (td_infos, heaps, error) - #! heaps = clear_tvs spec_env heaps - = (expr, td_infos, heaps, error) + !*SpecializeState) +specializeGeneric gen_index type spec_env gen_ident gen_pos gen_deps gen_rep_conses gen_info_ptr main_module_index predefs st + #! st & ss_heaps = set_tvs spec_env st.ss_heaps + #! (expr, st) + = specialize type gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr st + #! st & ss_heaps = clear_tvs spec_env st.ss_heaps + = (expr, st) where - specialize (GTSAppCons kind arg_types) st - #! (arg_exprs, st) = mapSt specialize arg_types st + specialize (GTSAppCons kind arg_types) gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr st + #! (arg_exprs, st) = specialize_with_deps gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr arg_types st = build_generic_app kind arg_exprs gen_index gen_ident st - specialize (GTSAppVar tv arg_types) st - #! (arg_exprs, st) = mapSt specialize arg_types st - #! (expr, st) = specialize_type_var tv st + specialize (GTSAppVar tv arg_types) gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr st + #! (arg_exprs, st) = specialize_with_deps gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr arg_types st + #! (expr, st) = specialize_type_var tv gen_index st = (expr @ arg_exprs, st) - specialize (GTSVar tv) st - = specialize_type_var tv st - specialize (GTSArrow x y) st - #! (x, st) = specialize x st - #! (y, st) = specialize y st - = build_generic_app (KindArrow [KindConst, KindConst]) [x,y] gen_index gen_ident st - specialize (GTSPair x y) st - #! (x, st) = specialize x st - #! (y, st) = specialize y st - = build_generic_app (KindArrow [KindConst, KindConst]) [x,y] gen_index gen_ident st - specialize (GTSEither x y) st - #! (x, st) = specialize x st - #! (y, st) = specialize y st - = build_generic_app (KindArrow [KindConst, KindConst]) [x,y] gen_index gen_ident st - specialize (GTSCons cons_info_ds arg_type) st - # (arg_expr, (td_infos, heaps, error)) = specialize arg_type st - #! (generic_info_expr, heaps) = buildFunApp main_module_index cons_info_ds [] heaps - # gen_CONS_index = gen_rep_conses.[1] - | gen_CONS_index.gcf_module>=0 - #! (expr, heaps) - = buildFunApp2 gen_CONS_index.gcf_module gen_CONS_index.gcf_index gen_CONS_index.gcf_ident [generic_info_expr, arg_expr] heaps - = (expr, (td_infos, heaps, error)) - // no instance for CONS, report error here ? - #! (expr, heaps) - = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident (KindArrow [KindConst]) [arg_expr] heaps - = (expr, (td_infos, heaps, error)) - specialize (GTSRecord record_info_ds arg_type) st - # (arg_expr, (td_infos, heaps, error)) = specialize arg_type st - #! (generic_info_expr, heaps) = buildFunApp main_module_index record_info_ds [] heaps - # gen_RECORD_index = gen_rep_conses.[2] - | gen_RECORD_index.gcf_module>=0 - #! (expr, heaps) - = buildFunApp2 gen_RECORD_index.gcf_module gen_RECORD_index.gcf_index gen_RECORD_index.gcf_ident [generic_info_expr, arg_expr] heaps - = (expr, (td_infos, heaps, error)) - // no instance for RECORD, report error here ? - #! (expr, heaps) - = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident (KindArrow [KindConst]) [arg_expr] heaps - = (expr, (td_infos, heaps, error)) - specialize (GTSField field_info_ds arg_type) st - # (arg_expr, (td_infos, heaps, error)) = specialize arg_type st - #! (generic_info_expr, heaps) = buildFunApp main_module_index field_info_ds [] heaps - # gen_FIELD_index = gen_rep_conses.[3] - | gen_FIELD_index.gcf_module>=0 - #! (expr, heaps) - = buildFunApp2 gen_FIELD_index.gcf_module gen_FIELD_index.gcf_index gen_FIELD_index.gcf_ident [generic_info_expr, arg_expr] heaps - = (expr, (td_infos, heaps, error)) - // no instance for FIELD, report error here ? - #! (expr, heaps) - = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident (KindArrow [KindConst]) [arg_expr] heaps - = (expr, (td_infos, heaps, error)) - specialize (GTSObject type_info_ds arg_type) st - # (arg_expr, (td_infos, heaps, error)) = specialize arg_type st - #! (generic_info_expr, heaps) = buildFunApp main_module_index type_info_ds [] heaps - # gen_OBJECT_index = gen_rep_conses.[0] - | gen_OBJECT_index.gcf_module>=0 - #! (expr, heaps) - = buildFunApp2 gen_OBJECT_index.gcf_module gen_OBJECT_index.gcf_index gen_OBJECT_index.gcf_ident [generic_info_expr, arg_expr] heaps - = (expr, (td_infos, heaps, error)) - // no instance for OBJECT, report error here ? - #! (expr, heaps) - = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident (KindArrow [KindConst]) [arg_expr] heaps - = (expr, (td_infos, heaps, error)) - specialize type (td_infos, heaps, error) - #! error = reportError gen_ident.id_name gen_pos "cannot specialize " error - = (EE, (td_infos, heaps, error)) + specialize (GTSVar tv) gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr st + = specialize_type_var tv gen_index st + specialize (GTSArrow x y) gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr st + # (arg_exprs, st) = specialize_with_deps gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr [x, y] st + = build_generic_app (KindArrow [KindConst, KindConst]) arg_exprs gen_index gen_ident st + specialize (GTSPair x y) gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr st + # {grc_ident,grc_generic_instance_deps,grc_index,grc_module,grc_local_fun_index} = gen_rep_conses.[4] + | grc_module<0 + #! error = reportError gen_ident.id_name gen_pos "cannot specialize because there is no instance of PAIR" st.ss_error + = (EE, {st & ss_error=error}) + # (fun_module_index,fun_index,gen_rep_conses,st) + = get_function_or_copied_macro_index grc_index grc_module main_module_index grc_local_fun_index gen_info_ptr 4 gen_rep_conses st + # (arg_exprs, st) + = specialize_with_partial_or_all_deps gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr [x,y] grc_generic_instance_deps st + #! (expr, heaps) + = buildFunApp2 fun_module_index fun_index grc_ident arg_exprs st.ss_heaps + = (expr, {st & ss_heaps=heaps}) + specialize (GTSEither x y) gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr st + # {grc_ident,grc_generic_instance_deps,grc_index,grc_module,grc_local_fun_index} = gen_rep_conses.[5] + | grc_module<0 + #! error = reportError gen_ident.id_name gen_pos "cannot specialize because there is no instance of EITHER" st.ss_error + = (EE, {st & ss_error=error}) + # (fun_module_index,fun_index,gen_rep_conses,st) + = get_function_or_copied_macro_index grc_index grc_module main_module_index grc_local_fun_index gen_info_ptr 5 gen_rep_conses st + # (arg_exprs, st) + = specialize_with_partial_or_all_deps gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr [x,y] grc_generic_instance_deps st + #! (expr, heaps) + = buildFunApp2 fun_module_index fun_index grc_ident arg_exprs st.ss_heaps + = (expr, {st & ss_heaps=heaps}) + specialize (GTSCons cons_info_ds cons_index type_def_info gen_type_ds arg_type) gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr st + # {grc_ident,grc_generic_info,grc_generic_instance_deps,grc_index,grc_module,grc_local_fun_index} = gen_rep_conses.[1] + | grc_module<0 + #! error = reportError gen_ident.id_name gen_pos "cannot specialize because there is no instance of CONS" st.ss_error + = (EE, {st & ss_error=error}) + # (fun_module_index,fun_index,gen_rep_conses,st) + = get_function_or_copied_macro_index grc_index grc_module main_module_index grc_local_fun_index gen_info_ptr 1 gen_rep_conses st + # (arg_exprs, st) + = specialize_with_partial_or_all_deps gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr [arg_type] grc_generic_instance_deps st + # (arg_exprs,st) + = case grc_generic_info of + 0 + -> (arg_exprs,st) + -1 + #! (generic_info_expr, heaps) = buildFunApp main_module_index cons_info_ds [] st.ss_heaps + -> ([generic_info_expr:arg_exprs],{st & ss_heaps=heaps}) + _ + # (cons_def, modules) = (st.ss_modules)![cons_index.gi_module].com_cons_defs.[cons_index.gi_index] + # (arg_exprs,heaps) = add_CONS_info_args grc_generic_info cons_def type_def_info gen_type_ds arg_exprs main_module_index predefs st.ss_heaps + -> (arg_exprs,{st & ss_modules=modules,ss_heaps=heaps}) + #! (expr, heaps) + = buildFunApp2 fun_module_index fun_index grc_ident arg_exprs st.ss_heaps + = (expr, {st & ss_heaps=heaps}) + specialize (GTSRecord record_info_ds type_index gen_type_ds field_list_ds arg_type) gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr st + # {grc_ident,grc_generic_info,grc_generic_instance_deps,grc_index,grc_module,grc_local_fun_index} = gen_rep_conses.[2] + | grc_module<0 + #! error = reportError gen_ident.id_name gen_pos "cannot specialize because there is no instance of RECORD" st.ss_error + = (EE, {st & ss_error=error}) + # (fun_module_index,fun_index,gen_rep_conses,st) + = get_function_or_copied_macro_index grc_index grc_module main_module_index grc_local_fun_index gen_info_ptr 2 gen_rep_conses st + # (arg_exprs, st) + = specialize_with_partial_or_all_deps gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr [arg_type] grc_generic_instance_deps st + # (arg_exprs,st) + = case grc_generic_info of + 0 + -> (arg_exprs,st) + -1 + #! (generic_info_expr, heaps) = buildFunApp main_module_index record_info_ds [] st.ss_heaps + -> ([generic_info_expr:arg_exprs],{st & ss_heaps=heaps}) + _ + # (type_def, modules) = (st.ss_modules)![type_index.gi_module].com_type_defs.[type_index.gi_index] + # (arg_exprs,modules,heaps) = add_RECORD_info_args grc_generic_info type_def gen_type_ds field_list_ds type_index.gi_module arg_exprs main_module_index modules st.ss_heaps + -> (arg_exprs,{st & ss_modules=modules,ss_heaps=heaps}) + #! (expr, heaps) + = buildFunApp2 fun_module_index fun_index grc_ident arg_exprs st.ss_heaps + = (expr, {st & ss_heaps=heaps}) + specialize (GTSField field_info_ds field_index record_info_ds arg_type) gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr st + # {grc_ident,grc_generic_info,grc_generic_instance_deps,grc_index,grc_module,grc_local_fun_index} = gen_rep_conses.[3] + | grc_module<0 + #! error = reportError gen_ident.id_name gen_pos "cannot specialize because there is no instance of FIELD" st.ss_error + = (EE, {st & ss_error=error}) + # (fun_module_index,fun_index,gen_rep_conses,st) + = get_function_or_copied_macro_index grc_index grc_module main_module_index grc_local_fun_index gen_info_ptr 3 gen_rep_conses st + # (arg_exprs, st) + = specialize_with_partial_or_all_deps gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr [arg_type] grc_generic_instance_deps st + # (arg_exprs,st) + = case grc_generic_info of + 0 + -> (arg_exprs,st) + -1 + #! (generic_info_expr, heaps) = buildFunApp main_module_index field_info_ds [] st.ss_heaps + -> ([generic_info_expr:arg_exprs],{st & ss_heaps=heaps}) + _ + # (field_def, modules) = (st.ss_modules)![field_index.gi_module].com_selector_defs.[field_index.gi_index] + # (arg_exprs,heaps) = add_FIELD_info_args grc_generic_info field_def record_info_ds arg_exprs main_module_index st.ss_heaps + -> (arg_exprs,{st & ss_modules=modules,ss_heaps=heaps}) + #! (expr, heaps) + = buildFunApp2 fun_module_index fun_index grc_ident arg_exprs st.ss_heaps + = (expr, {st & ss_heaps=heaps}) + specialize (GTSObject type_info_ds type_index cons_desc_list_ds arg_type) gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr st + # {grc_ident,grc_generic_info,grc_generic_instance_deps,grc_index,grc_module,grc_local_fun_index} = gen_rep_conses.[0] + | grc_module<0 + #! error = reportError gen_ident.id_name gen_pos "cannot specialize because there is no instance of OBJECT" st.ss_error + = (EE, {st & ss_error=error}) + # (fun_module_index,fun_index,gen_rep_conses,st) + = get_function_or_copied_macro_index grc_index grc_module main_module_index grc_local_fun_index gen_info_ptr 0 gen_rep_conses st + # (arg_exprs, st) + = specialize_with_partial_or_all_deps gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr [arg_type] grc_generic_instance_deps st + # (arg_exprs,st) + = case grc_generic_info of + 0 + -> (arg_exprs,st) + -1 + #! (generic_info_expr, heaps) = buildFunApp main_module_index type_info_ds [] st.ss_heaps + -> ([generic_info_expr:arg_exprs],{st & ss_heaps=heaps}) + _ + # (type_def, modules) = (st.ss_modules)![type_index.gi_module].com_type_defs.[type_index.gi_index] + (arg_exprs,heaps) = add_OBJECT_info_args grc_generic_info type_def cons_desc_list_ds arg_exprs main_module_index st.ss_heaps + -> (arg_exprs,{st & ss_modules=modules,ss_heaps=heaps}) + #! (expr, heaps) + = buildFunApp2 fun_module_index fun_index grc_ident arg_exprs st.ss_heaps + = (expr, {st & ss_heaps=heaps}) + specialize GTSUnit gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr st + # {grc_ident,grc_generic_instance_deps,grc_index,grc_module,grc_local_fun_index} = gen_rep_conses.[6] + | grc_module<0 + #! error = reportError gen_ident.id_name gen_pos "cannot specialize because there is no instance of UNIT" st.ss_error + = (EE, {st & ss_error=error}) + # (fun_module_index,fun_index,gen_rep_conses,st) + = get_function_or_copied_macro_index grc_index grc_module main_module_index grc_local_fun_index gen_info_ptr 6 gen_rep_conses st + # (arg_exprs, st) + = specialize_with_partial_or_all_deps gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr [] grc_generic_instance_deps st + #! (expr, heaps) + = buildFunApp2 fun_module_index fun_index grc_ident arg_exprs st.ss_heaps + = (expr, {st & ss_heaps=heaps}) + specialize type gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr st + #! error = reportError gen_ident.id_name gen_pos "cannot specialize " st.ss_error + = (EE, {st & ss_error=error}) - specialize_type_var tv=:{tv_info_ptr} (td_infos, heaps=:{hp_type_heaps=th=:{th_vars}}, error) + specialize_type_var {tv_info_ptr} gen_index st=:{ss_heaps=heaps=:{hp_type_heaps=th=:{th_vars}}} # (expr, th_vars) = readPtr tv_info_ptr th_vars - # heaps = {heaps & hp_type_heaps = {th & th_vars = th_vars}} + # heaps & hp_type_heaps = {th & th_vars = th_vars} = case expr of - TVI_Expr is_bimap_id expr - -> (expr, (td_infos, heaps, error)) + // TODO: TvN: Now we use the gen_index to look up the right argument expression, but this fails when you have a duplicate dependency on + // the same generic function with different generic variables. The generic variables must be included in the spec_env as well, but this + // requires including forwarding pointers to obtain substitutions of dependency variables. For example: + // + // generic f a b | g a, g b :: a -> b + // generic g c :: c -> c + // See functions: build_specialized_expr and checkgenerics.check_dependency + TVI_Exprs exprs + # (argExpr, error) = lookupArgExpr gen_index exprs st.ss_error + -> (argExpr, {st & ss_heaps=heaps,ss_error=error}) TVI_Iso iso_ds to_ds from_ds # (expr,heaps) = buildFunApp main_module_index iso_ds [] heaps - -> (expr, (td_infos, heaps, error)) + -> (expr, {st & ss_heaps=heaps}) + where + lookupArgExpr x [(k, v):kvs] error + | k == x + = (v, error) + = lookupArgExpr x kvs error + lookupArgExpr _ [] error + = (undef, reportError gen_ident.id_name gen_pos "missing dependencies of its dependencies in the type signature" error) + + specialize_with_deps gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr xs st + # (info_deps, st) = collect_dependency_infos gen_deps st + # info_self = (gen_index, gen_ident, gen_deps, gen_rep_conses, gen_info_ptr) + # arg_and_deps = make_arg_and_deps xs info_self info_deps + = specialize_arg_and_deps arg_and_deps st + + specialize_with_partial_or_all_deps gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr xs (GenericInstanceDependencies _ deps) st + # (info_deps, st) = collect_dependency_infos gen_deps st + # info_self = (gen_index, gen_ident, gen_deps, gen_rep_conses, gen_info_ptr) + # arg_and_deps = make_arg_and_deps xs info_self info_deps + # arg_and_deps = [arg_and_dep \\ arg_and_dep<-arg_and_deps & dep_n<-[0..] | deps bitand (1<0] + = specialize_arg_and_deps arg_and_deps st + specialize_with_partial_or_all_deps gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr xs _ st + = specialize_with_deps gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr xs st + + make_arg_and_deps xs info_self info_deps + # info_self_deps = [info_self : info_deps] + = [(arg,info_self_dep) \\ arg <- xs, info_self_dep <- info_self_deps] + + specialize_arg_and_deps arg_and_deps st + = mapSt specialize_arg_or_dep arg_and_deps st + where + specialize_arg_or_dep (arg, (index, ident, deps, gen_rep_conses, gen_info_ptr)) st + = specialize arg index ident deps gen_rep_conses gen_info_ptr st + + collect_dependency_infos gen_deps st + = mapSt collect_dependency_info gen_deps st + where + collect_dependency_info gen_dep st=:{ss_modules,ss_heaps} + # ({gen_ident, gen_deps, gen_info_ptr}, modules) = lookupDependencyDef gen_dep ss_modules + # ({gen_rep_conses}, generic_heap) = readPtr gen_info_ptr ss_heaps.hp_generic_heap + # ss_heaps & hp_generic_heap = generic_heap + = ((gen_dep.gd_index, gen_ident, gen_deps, gen_rep_conses, gen_info_ptr), {st & ss_modules=modules, ss_heaps=ss_heaps}) - build_generic_app kind arg_exprs gen_index gen_ident (td_infos, heaps, error) + build_generic_app kind arg_exprs gen_index gen_ident st=:{ss_heaps} #! (expr, heaps) - = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident kind arg_exprs heaps - = (expr, (td_infos, heaps, error)) + = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident kind arg_exprs ss_heaps + = (expr, {st & ss_heaps=heaps}) + + get_function_or_copied_macro_index :: !GenericCaseBody !Int !Int !Int !GenericInfoPtr !Int !{!GenericRepresentationConstructor} !*SpecializeState -> (!Int,!Int,!{!GenericRepresentationConstructor},!*SpecializeState) + get_function_or_copied_macro_index (GCB_FunIndex fun_index) module_index main_module_index local_fun_index gen_info_ptr gen_cons_index gen_rep_conses st + = (module_index,fun_index,gen_rep_conses,st) + get_function_or_copied_macro_index (GCB_FunAndMacroIndex _ macro_index) module_index main_module_index local_fun_index gen_info_ptr gen_cons_index gen_rep_conses st + | local_fun_index>=0 + = (main_module_index,local_fun_index,gen_rep_conses,st) + # heaps = st.ss_heaps + (gen_info=:{gen_rep_conses}, generic_heap) = readPtr gen_info_ptr heaps.hp_generic_heap + {grc_local_fun_index,grc_optional_fun_type,grc_generic_info,grc_generic_instance_deps} = gen_rep_conses.[gen_cons_index] + st & ss_heaps = {heaps & hp_generic_heap = generic_heap} + | grc_local_fun_index>=0 + = (main_module_index,grc_local_fun_index,gen_rep_conses,st) + # (fun_index,st) + = copy_generic_case_macro module_index macro_index grc_optional_fun_type gen_cons_index grc_generic_info grc_generic_instance_deps main_module_index st + gen_rep_conses = {gen_rep_cons\\gen_rep_cons<-:gen_rep_conses} + gen_rep_conses & [gen_cons_index].grc_local_fun_index = fun_index + heaps = st.ss_heaps + generic_heap = writePtr gen_info_ptr {gen_info & gen_rep_conses=gen_rep_conses} heaps.hp_generic_heap + st & ss_heaps = {heaps & hp_generic_heap = generic_heap} + = (main_module_index,fun_index,gen_rep_conses,st) + + copy_generic_case_macro :: !Int !Int !(Optional SymbolType) !Int !Int !GenericInstanceDependencies !Int !*SpecializeState -> (!Int,!*SpecializeState) + copy_generic_case_macro macro_module_index macro_index optional_fun_type gen_cons_index generic_info generic_instance_deps main_module_index st + # {ss_heaps=heaps,ss_funs_and_groups=funs_and_groups,ss_error=error,ss_funs=fun_defs,ss_dcl_macros=dcl_macros,ss_symbol_table=symbol_table} = st + {fg_fun_index = fun_index, fg_funs=funs, fg_groups=groups, fg_group_index=group_index} = funs_and_groups + + fun_defs = case funs of + [] -> fun_defs + _ -> arrayPlusRevList fun_defs funs + funs = [] + + {hp_var_heap=var_heap,hp_expression_heap=expression_heap} = heaps + | size fun_defs<>fun_index + = abort "copy_generic_case_macro: incorrect function index" + + # (reversed_groups,unexpanded_dcl_macros,fun_defs,dcl_macros,var_heap,expression_heap,symbol_table,error) + = partitionateAndLiftMacro macro_module_index macro_index main_module_index predefs group_index + fun_defs dcl_macros var_heap expression_heap symbol_table error + + (fun_index,fun_defs) = usize fun_defs + + (macro,dcl_macros) = dcl_macros![macro_module_index,macro_index] + + macro + = case generic_instance_deps of + GenericInstanceDependencies n_deps deps + # m = (1<m + # {fun_body=TransformedBody {tb_args,tb_rhs}} = macro + # n_generic_info_args + = if (generic_info==0) 0 (if (generic_info<0) 1 (add_n_bits generic_info 0)) + tb_args = remove_unused_dep_args_after_generic_info_args tb_args n_generic_info_args n_deps deps + -> {macro & fun_body = TransformedBody {tb_args=tb_args,tb_rhs=tb_rhs}} + where + remove_unused_dep_args_after_generic_info_args args 0 n_deps deps + = remove_unused_dep_args args 0 n_deps deps + remove_unused_dep_args_after_generic_info_args [arg:args] n_generic_info_args n_deps deps + = [arg : remove_unused_dep_args_after_generic_info_args args (n_generic_info_args-1) n_deps deps] + _ + -> macro + + (fun_def,local_fun_defs,next_fun_index,fun_defs,dcl_macros,var_heap,expression_heap) + = copy_macro_and_local_functions macro fun_index fun_defs dcl_macros var_heap expression_heap + + dcl_macros = restore_unexpanded_dcl_macros unexpanded_dcl_macros dcl_macros + + heaps & hp_var_heap=var_heap,hp_expression_heap=expression_heap + + (fun_def,heaps) + = case optional_fun_type of + Yes fun_type + # (fun_type, heaps) = fresh_symbol_type fun_type heaps + fun_type_with_generic_info + = if (generic_info<>0) + (add_generic_info_to_type fun_type gen_cons_index generic_info predefs) + fun_type + fun_def & fun_type = Yes fun_type_with_generic_info + -> (fun_def,heaps) + No + -> (fun_def,heaps) + + funs = [fun_def:funs] + (funs,groups,group_index) = add_local_macro_functions local_fun_defs (fun_index+1) funs groups group_index + + groups = [{group_members = [fun_index]}:groups] + group_index = group_index+1 + + funs_and_groups & fg_fun_index=next_fun_index, fg_group_index=group_index, fg_funs=funs, fg_groups=groups + st & ss_funs_and_groups=funs_and_groups,ss_dcl_macros=dcl_macros,ss_heaps=heaps,ss_error=error,ss_funs=fun_defs,ss_symbol_table=symbol_table + = (fun_index,st) + +add_local_macro_functions [] fun_index funs groups group_index + = (funs,groups,group_index) +add_local_macro_functions copied_local_functions fun_index funs groups group_index + # local_functions_sorted_by_group = sortBy less_than_group_number copied_local_functions + # (groups,group_index,functions_with_numbers) = add_groups local_functions_sorted_by_group groups group_index [] + # sorted_functions_with_numbers = sortBy (\(function_n1,_) (function_n2,_) -> function_n1 (!SymbolType, !*Heaps) +fresh_symbol_type st heaps=:{hp_type_heaps} + # (fresh_st, hp_type_heaps) = freshSymbolType st hp_type_heaps + = (fresh_st, {heaps & hp_type_heaps = hp_type_heaps}) + +add_OBJECT_info_args :: Int CheckedTypeDef DefinedSymbol [Expression] Int *Heaps -> (![Expression],*Heaps) +add_OBJECT_info_args generic_info type_def cons_desc_list_ds arg_exprs main_module_index heaps + | generic_info==0 + = (arg_exprs,heaps) + | generic_info bitand 1<>0 // gtd_name + # generic_info = generic_info bitxor 1 + #! gtd_name_expr = makeStringExpr type_def.td_ident.id_name + # (arg_exprs,heaps) = add_OBJECT_info_args generic_info type_def cons_desc_list_ds arg_exprs main_module_index heaps + = ([gtd_name_expr : arg_exprs],heaps) + | generic_info bitand 2<>0 // gtd_arity + # generic_info = generic_info bitxor 2 + #! gtd_arity_expr = makeIntExpr type_def.td_arity + # (arg_exprs,heaps) = add_OBJECT_info_args generic_info type_def cons_desc_list_ds arg_exprs main_module_index heaps + = ([gtd_arity_expr : arg_exprs],heaps) + | generic_info bitand 4<>0 // gtd_num_conses + # generic_info = generic_info bitxor 4 + #! gtd_num_conses_expr = makeIntExpr (case type_def.td_rhs of AlgType alts -> length alts; _ -> 0) + # (arg_exprs,heaps) = add_OBJECT_info_args generic_info type_def cons_desc_list_ds arg_exprs main_module_index heaps + = ([gtd_num_conses_expr : arg_exprs],heaps) + | generic_info bitand 8<>0 // gtd_conses + # generic_info = generic_info bitxor 8 + # (gtd_conses_expr, heaps) = buildFunApp main_module_index cons_desc_list_ds [] heaps + # (arg_exprs,heaps) = add_OBJECT_info_args generic_info type_def cons_desc_list_ds arg_exprs main_module_index heaps + = ([gtd_conses_expr : arg_exprs],heaps) + +add_CONS_info_args :: Int ConsDef DefinedSymbol DefinedSymbol [Expression] Int {#PredefinedSymbol} *Heaps -> (![Expression],!*Heaps) +add_CONS_info_args generic_info cons_def type_def_info gen_type_ds arg_exprs main_module_index predefs heaps + | generic_info==0 + = (arg_exprs,heaps) + | generic_info bitand 1<>0 // gcd_name + # generic_info = generic_info bitxor 1 + #! gcd_name_expr = makeStringExpr cons_def.cons_ident.id_name + # (arg_exprs,heaps) = add_CONS_info_args generic_info cons_def type_def_info gen_type_ds arg_exprs main_module_index predefs heaps + = ([gcd_name_expr : arg_exprs],heaps) + | generic_info bitand 2<>0 // gcd_arity + # generic_info = generic_info bitxor 2 + #! gcd_arity_expr = makeIntExpr cons_def.cons_type.st_arity + # (arg_exprs,heaps) = add_CONS_info_args generic_info cons_def type_def_info gen_type_ds arg_exprs main_module_index predefs heaps + = ([gcd_arity_expr : arg_exprs],heaps) + | generic_info bitand 4<>0 // gcd_prio + # generic_info = generic_info bitxor 4 + # (gcd_prio_expr, heaps) = make_prio_expr cons_def.cons_priority predefs heaps + # (arg_exprs,heaps) = add_CONS_info_args generic_info cons_def type_def_info gen_type_ds arg_exprs main_module_index predefs heaps + = ([gcd_prio_expr : arg_exprs],heaps) + | generic_info bitand 8<>0 // gcd_type_def + # generic_info = generic_info bitxor 8 + # (gcd_type_def_expr, heaps) = buildFunApp main_module_index type_def_info [] heaps + # (arg_exprs,heaps) = add_CONS_info_args generic_info cons_def type_def_info gen_type_ds arg_exprs main_module_index predefs heaps + = ([gcd_type_def_expr : arg_exprs],heaps) + | generic_info bitand 16<>0 // gcd_type + # generic_info = generic_info bitxor 16 + # (gcd_type_expr, heaps) = buildFunApp main_module_index gen_type_ds [] heaps + # (arg_exprs,heaps) = add_CONS_info_args generic_info cons_def type_def_info gen_type_ds arg_exprs main_module_index predefs heaps + = ([gcd_type_expr : arg_exprs],heaps) + | generic_info bitand 32<>0 // gcd_index + # generic_info = generic_info bitxor 32 + #! gcd_index_expr = makeIntExpr cons_def.cons_number + # (arg_exprs,heaps) = add_CONS_info_args generic_info cons_def type_def_info gen_type_ds arg_exprs main_module_index predefs heaps + = ([gcd_index_expr : arg_exprs],heaps) + +add_RECORD_info_args :: Int CheckedTypeDef DefinedSymbol DefinedSymbol Int [Expression] Int *{#CommonDefs} *Heaps -> (![Expression],!*{#CommonDefs},!*Heaps) +add_RECORD_info_args generic_info type_def gen_type_ds field_list_ds type_module arg_exprs main_module_index modules heaps + | generic_info==0 + = (arg_exprs,modules,heaps) + | generic_info bitand 1<>0 // grd_name + # generic_info = generic_info bitxor 1 + #! grd_name_expr = makeStringExpr type_def.td_ident.id_name + # (arg_exprs,modules,heaps) = add_RECORD_info_args generic_info type_def gen_type_ds field_list_ds type_module arg_exprs main_module_index modules heaps + = ([grd_name_expr : arg_exprs],modules,heaps) + | generic_info bitand 2<>0 // grd_arity + # generic_info = generic_info bitxor 2 + # (RecordType {rt_constructor}) = type_def.td_rhs + # ({cons_type}, modules) = modules![type_module].com_cons_defs.[rt_constructor.ds_index] + #! grd_arity_expr = makeIntExpr cons_type.st_arity + # (arg_exprs,modules,heaps) = add_RECORD_info_args generic_info type_def gen_type_ds field_list_ds type_module arg_exprs main_module_index modules heaps + = ([grd_arity_expr : arg_exprs],modules,heaps) + | generic_info bitand 4<>0 // grd_type_arity + # generic_info = generic_info bitxor 4 + #! grd_type_arity_expr = makeIntExpr type_def.td_arity + # (arg_exprs,modules,heaps) = add_RECORD_info_args generic_info type_def gen_type_ds field_list_ds type_module arg_exprs main_module_index modules heaps + = ([grd_type_arity_expr : arg_exprs],modules,heaps) + | generic_info bitand 8<>0 // grd_type + # generic_info = generic_info bitxor 8 + # (gen_type_expr, heaps) = buildFunApp main_module_index gen_type_ds [] heaps + # (arg_exprs,modules,heaps) = add_RECORD_info_args generic_info type_def gen_type_ds field_list_ds type_module arg_exprs main_module_index modules heaps + = ([gen_type_expr : arg_exprs],modules,heaps) + | generic_info bitand 16<>0 // grd_fields + # generic_info = generic_info bitxor 16 + # (gen_type_expr, heaps) = buildFunApp main_module_index field_list_ds [] heaps + # (arg_exprs,modules,heaps) = add_RECORD_info_args generic_info type_def gen_type_ds field_list_ds type_module arg_exprs main_module_index modules heaps + = ([gen_type_expr : arg_exprs],modules,heaps) + +add_FIELD_info_args :: Int SelectorDef DefinedSymbol [Expression] Int *Heaps -> (![Expression],!*Heaps) +add_FIELD_info_args generic_info field_def record_info_ds arg_exprs main_module_index heaps + | generic_info==0 + = (arg_exprs,heaps) + | generic_info bitand 1<>0 // gfd_name + # generic_info = generic_info bitxor 1 + #! gcd_name_expr = makeStringExpr field_def.sd_ident.id_name + # (arg_exprs,heaps) = add_FIELD_info_args generic_info field_def record_info_ds arg_exprs main_module_index heaps + = ([gcd_name_expr : arg_exprs],heaps) + | generic_info bitand 2<>0 // gfd_index + # generic_info = generic_info bitxor 2 + #! gcd_arity_expr = makeIntExpr field_def.sd_field_nr + # (arg_exprs,heaps) = add_FIELD_info_args generic_info field_def record_info_ds arg_exprs main_module_index heaps + = ([gcd_arity_expr : arg_exprs],heaps) + | generic_info bitand 4<>0 // gfd_cons + # generic_info = generic_info bitxor 4 + # (record_info_expr, heaps) = buildFunApp main_module_index record_info_ds [] heaps + # (arg_exprs,heaps) = add_FIELD_info_args generic_info field_def record_info_ds arg_exprs main_module_index heaps + = ([record_info_expr : arg_exprs],heaps) specialize_generic_bimap :: !GlobalIndex // generic index @@ -2572,22 +3288,22 @@ where (expr, funs_and_groups, heaps) = bimap_EITHER_expression [x,y] main_module_index predefs funs_and_groups heaps = (expr, (funs_and_groups, heaps, error)) - specialize (GTSCons cons_info_ds arg_type) st + specialize (GTSCons cons_info_ds cons_index type_info gen_type_ds arg_type) st # (arg_expr, (funs_and_groups, heaps, error)) = specialize arg_type st (expr, funs_and_groups, heaps) = bimap_CONS_expression [arg_expr] main_module_index predefs funs_and_groups heaps = (expr, (funs_and_groups, heaps, error)) - specialize (GTSRecord cons_info_ds arg_type) st + specialize (GTSRecord cons_info_ds type_index gen_type_ds field_list_ds arg_type) st # (arg_expr, (funs_and_groups, heaps, error)) = specialize arg_type st (expr, funs_and_groups, heaps) = bimap_RECORD_expression [arg_expr] main_module_index predefs funs_and_groups heaps = (expr, (funs_and_groups, heaps, error)) - specialize (GTSField field_info_ds arg_type) st + specialize (GTSField field_info_ds field_index record_info_ds arg_type) st # (arg_expr, (funs_and_groups, heaps, error)) = specialize arg_type st (expr, funs_and_groups, heaps) = bimap_FIELD_expression [arg_expr] main_module_index predefs funs_and_groups heaps = (expr, (funs_and_groups, heaps, error)) - specialize (GTSObject type_info_ds arg_type) st + specialize (GTSObject type_info_ds type_index cons_desc_list_ds arg_type) st # (arg_expr, (funs_and_groups, heaps, error)) = specialize arg_type st (expr, funs_and_groups, heaps) = bimap_OBJECT_expression [arg_expr] main_module_index predefs funs_and_groups heaps @@ -2596,6 +3312,10 @@ where # (expr, funs_and_groups, heaps) = bimap_id_expression main_module_index predefs funs_and_groups heaps = (expr ,(funs_and_groups, heaps, error)) + specialize GTSUnit (funs_and_groups, heaps, error) + # (expr, funs_and_groups, heaps) + = bimap_id_expression main_module_index predefs funs_and_groups heaps + = (expr, (funs_and_groups, heaps, error)) specialize type (funs_and_groups, heaps, error) #! error = reportError gen_ident.id_name gen_pos "cannot specialize " error = (EE, (funs_and_groups, heaps, error)) @@ -2893,11 +3613,27 @@ where bimap_to_simple_type :: !GlobalIndex !TypeKind ![GenTypeStruct] !Expression !*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin) -> *(!Expression,!*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin)) bimap_to_simple_type global_type_def_index=:{gi_module} (KindArrow kinds) arg_types arg (funs_and_groups,modules,heaps,error) +/* # (alts,constructors_arg_types,modules,heaps) = determine_constructors_arg_types global_type_def_index arg_types modules heaps # (alg_patterns,funs_and_groups,modules,heaps,error) = build_to_alg_patterns alts constructors_arg_types gi_module funs_and_groups modules heaps error = build_bimap_case global_type_def_index arg alg_patterns funs_and_groups modules heaps error +*/ + # (alts,constructors_arg_types,modules,heaps) + = determine_constructors_arg_types global_type_def_index arg_types modules heaps + # (alg_patterns,funs_and_groups,modules,heaps,error) + = build_to_alg_patterns alts constructors_arg_types gi_module funs_and_groups modules heaps error + + # (arg_expr, arg_var, heaps) = buildVarExpr "x" heaps + + # (case_expr,(funs_and_groups,modules,heaps,error)) + = build_bimap_case global_type_def_index arg_expr alg_patterns funs_and_groups modules heaps error + + # (def_sym, funs_and_groups) + = buildFunAndGroup (makeIdent "bimapToGeneric") [arg_var] case_expr No main_module_index NoPos funs_and_groups + # (app_expr, heaps) = buildFunApp main_module_index def_sym [arg] heaps + = (app_expr,(funs_and_groups,modules,heaps,error)) where build_to_alg_patterns [cons_ds=:{ds_ident,ds_index,ds_arity}:alts] [constructor_arg_types:constructors_arg_types] type_module_n funs_and_groups modules heaps error # arg_names = ["x" +++ toString k \\ k <- [1..ds_arity]] @@ -2928,11 +3664,27 @@ where bimap_from_simple_type :: !GlobalIndex !TypeKind ![GenTypeStruct] !Expression !*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin) -> *(!Expression,!*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin)) bimap_from_simple_type global_type_def_index=:{gi_module} (KindArrow kinds) arg_types arg (funs_and_groups,modules,heaps,error) +/* # (alts,constructors_arg_types,modules,heaps) = determine_constructors_arg_types global_type_def_index arg_types modules heaps # (alg_patterns,funs_and_groups,modules,heaps,error) = build_from_alg_patterns alts constructors_arg_types gi_module funs_and_groups modules heaps error = build_bimap_case global_type_def_index arg alg_patterns funs_and_groups modules heaps error +*/ + # (alts,constructors_arg_types,modules,heaps) + = determine_constructors_arg_types global_type_def_index arg_types modules heaps + # (alg_patterns,funs_and_groups,modules,heaps,error) + = build_from_alg_patterns alts constructors_arg_types gi_module funs_and_groups modules heaps error + + # (arg_expr, arg_var, heaps) = buildVarExpr "x" heaps + + # (case_expr,(funs_and_groups,modules,heaps,error)) + = build_bimap_case global_type_def_index arg_expr alg_patterns funs_and_groups modules heaps error + + # (def_sym, funs_and_groups) + = buildFunAndGroup (makeIdent "bimapFromGeneric") [arg_var] case_expr No main_module_index NoPos funs_and_groups + # (app_expr, heaps) = buildFunApp main_module_index def_sym [arg] heaps + = (app_expr,(funs_and_groups,modules,heaps,error)) where build_from_alg_patterns [cons_ds=:{ds_ident,ds_index,ds_arity}:alts] [constructor_arg_types:constructors_arg_types] type_module_n funs_and_groups modules heaps error # arg_names = ["x" +++ toString k \\ k <- [1..ds_arity]] @@ -3460,60 +4212,54 @@ bimap_from_arrow_arg_id_expression arg_exprs main_module_index predefs funs_and_ // kind indexing: // t_{*} a1 ... an = t a1 ... an // t_{k->l} a1 ... an = forall b1...bn.(t_k b1 ... bn) -> (t_l (a1 b1) ... (an bn)) -buildKindIndexedType :: +buildKindIndexedType :: !SymbolType // symbol type to kind-index ![TypeVar] // generic type variables + ![GenericDependency] // generic dependencies !TypeKind // kind index !Ident // name for debugging !Position // position for debugging - !*TypeHeaps // type heaps - !*ErrorAdmin - -> ( !SymbolType // instantiated type - , ![ATypeVar] // fresh generic type variables - , !*TypeHeaps // type heaps - , !*ErrorAdmin - ) -buildKindIndexedType st gtvs kind ident pos th error - #! th = clearSymbolType st th - #! (fresh_st, fresh_gtvs, th) = fresh_generic_type st gtvs th - - #! (gatvs, th) = collectAttrsOfTypeVarsInSymbolType fresh_gtvs fresh_st th - - #! (kind_indexed_st, _, th, error) = build_symbol_type fresh_st gatvs kind 1 th error + !*TypeHeaps !*Modules !*ErrorAdmin + -> (!SymbolType, // instantiated type + ![ATypeVar], // fresh generic type variables + !*TypeHeaps,!*Modules,!*ErrorAdmin) +buildKindIndexedType st gtvs deps kind ident pos th modules error + #! (fresh_st, gatvs, th) = fresh_generic_type st gtvs th + + #! (kind_indexed_st, _, (th, modules, error)) = build_symbol_type fresh_st gatvs deps kind ident pos 1 (th, modules, error) #! th = clearSymbolType kind_indexed_st th #! th = clearSymbolType st th // paranoja - = (kind_indexed_st, gatvs, th, error) + = (kind_indexed_st, gatvs, th, modules, error) where - fresh_generic_type st gtvs th - # (fresh_st, th) = freshSymbolType st th - # fresh_gtvs = take (length gtvs) fresh_st.st_vars - = (fresh_st, fresh_gtvs, th) - build_symbol_type :: !SymbolType // generic type, ![ATypeVar] // attributed generic variables + ![GenericDependency] // generic dependencies !TypeKind // kind to specialize to + !Ident + !Position !Int // current order (in the sense of the order of the kind) - !*TypeHeaps !*ErrorAdmin + (!*TypeHeaps, !*Modules, !*ErrorAdmin) -> ( !SymbolType // new generic type , ![ATypeVar] // fresh copies of generic variables created for the // generic arguments - , !*TypeHeaps, !*ErrorAdmin) - build_symbol_type st gatvs KindConst order th error - = (st, [], th, error) - build_symbol_type st gatvs (KindArrow kinds) order th error + , (!*TypeHeaps, !*Modules, !*ErrorAdmin)) + build_symbol_type st _ _ KindConst _ _ _ (th, modules, error) + = (st, [], (th, modules, error)) + build_symbol_type st gatvs deps (KindArrow kinds) ident pos order (th, modules, error) | order > 2 - # error = reportError ident.id_name pos "kinds of order higher then 2 are not supported" error - = (st, [], th, error) + # error = reportError ident.id_name pos "kinds of order higher than 2 are not supported" error + = (st, [], (th, modules, error)) - # (arg_sts, arg_gatvss, th, error) - = build_args st gatvs order kinds th error + # (arg_stss, arg_gatvss, (_, th, modules, error)) + = mapY2St (build_arg st gatvs deps ident pos order) kinds (0, th, modules, error) + # arg_sts = flatten arg_stss # (body_st, th) = build_body st gatvs (transpose arg_gatvss) th - # num_added_args = length kinds + # num_added_args = length kinds * (length deps + 1) # new_st = { st_vars = removeDup ( foldr (++) body_st.st_vars [st_vars \\ {st_vars}<-arg_sts]) @@ -3528,107 +4274,239 @@ where foldr (++) body_st.st_attr_env [st_attr_env \\ {st_attr_env} <- arg_sts]) , st_args_strictness = insert_n_lazy_values_at_beginning num_added_args body_st.st_args_strictness } - - = (new_st, flatten arg_gatvss, th, error) - //---> ("build_symbol_type returns", arg_gatvss, st) - - build_args st gatvs order kinds th error - # (arg_sts_and_gatvss, (_,th,error)) - = mapSt (build_arg st gatvs order) kinds (1,th,error) - # (arg_sts, arg_gatvss) = unzip arg_sts_and_gatvss - = (arg_sts, arg_gatvss, th, error) + = (new_st, flatten arg_gatvss, (th, modules, error)) build_arg :: !SymbolType // current part of the generic type ![ATypeVar] // generic type variables with their attrs + ![GenericDependency] // generic dependencies + !Ident + !Position !Int // order !TypeKind // kind corrseponding to the arg ( !Int // the argument number - , !*TypeHeaps - , !*ErrorAdmin - ) - -> ( (!SymbolType, [ATypeVar]) // fresh symbol type and generic variables - , ( !Int // incremented argument number - , !*TypeHeaps - , !*ErrorAdmin - ) - ) - build_arg st gatvs order kind (arg_num, th, error) + , !*TypeHeaps, !*Modules, !*ErrorAdmin) + -> ( ![SymbolType], [ATypeVar] // fresh symbol type and generic variables + ,( !Int // incremented argument number + ,!*TypeHeaps, !*Modules, !*ErrorAdmin)) + build_arg st gatvs deps ident pos order kind (arg_num, th, modules, error) #! th = clearSymbolType st th - #! (fresh_gatvs, th) = mapSt subst_gatv gatvs th + # postfix = toString arg_num + #! (fresh_gatvs, th) = mapSt (create_fresh_gatv postfix) gatvs th + #! (th, error) = fold2St (make_subst_gatv pos_and_ident) gatvs fresh_gatvs (th, error) #! (new_st, th) = applySubstInSymbolType st th - - #! (new_st, forall_atvs, th, error) - = build_symbol_type new_st fresh_gatvs kind (inc order) th error + #! (new_st, forall_atvs, (th, modules, error)) + = build_symbol_type new_st fresh_gatvs deps kind ident pos (inc order) (th, modules, error) #! (curry_st, th) - = curryGenericArgType1 new_st ("cur" +++ toString order +++ postfix) th - + = curryGenericArgType1 new_st ("cur" +++ toString order +++ postfix) th #! curry_st = adjust_forall curry_st forall_atvs - - = ((curry_st, fresh_gatvs), (inc arg_num, th, error)) + + # (curry_dep_sts, arg_num_th_modules_error) = mapSt (build_dependency_arg fresh_gatvs order kind) deps (arg_num+1, th, modules, error) + = ([curry_st:curry_dep_sts], fresh_gatvs, arg_num_th_modules_error) where - postfix = toString arg_num - - subst_gatv atv=:{atv_attribute, atv_variable} th=:{th_attrs, th_vars} - # (tv, th_vars) = subst_gtv atv_variable th_vars - # (attr, th_attrs) = subst_attr atv_attribute th_attrs - = ( {atv & atv_variable = tv, atv_attribute = attr} - , {th & th_vars = th_vars, th_attrs = th_attrs} - ) - - // generic type var is replaced with a fresh one - subst_gtv {tv_info_ptr, tv_ident} th_vars - # (tv, th_vars) = freshTypeVar (postfixIdent tv_ident.id_name postfix) th_vars - = (tv, writePtr tv_info_ptr (TVI_Type (TV tv)) th_vars) - - subst_attr (TA_Var {av_ident, av_info_ptr}) th_attrs - # (av, th_attrs) = freshAttrVar (postfixIdent av_ident.id_name postfix) th_attrs - = (TA_Var av, writePtr av_info_ptr (AVI_Attr (TA_Var av)) th_attrs) - - subst_attr TA_Multi th = (TA_Multi, th) - subst_attr TA_Unique th = (TA_Unique, th) - - adjust_forall curry_st [] = curry_st - adjust_forall curry_st=:{st_result} forall_atvs - #! st_result = {st_result & at_type = TFA forall_atvs st_result.at_type} - = { curry_st - & st_result = st_result - , st_attr_vars - = curry_st.st_attr_vars -- [av \\ {atv_attribute=TA_Var av} <- forall_atvs] - , st_vars - = curry_st.st_vars -- [atv_variable \\ {atv_variable} <- forall_atvs] - } + pos_and_ident = (pos,ident) + + build_dependency_arg fresh_gatvs order kind {gd_index, gd_nums} (arg_num, th, modules, error) + # ({gen_type, gen_vars, gen_deps, gen_ident, gen_pos}, modules) + = modules![gd_index.gi_module].com_generic_defs.[gd_index.gi_index] + # (fresh_dep_st, fresh_dep_gatvs, th) = fresh_generic_type gen_type gen_vars th + # to_gatvs = map (\num -> fresh_gatvs !! num) gd_nums + # (th, error) = fold2St (make_subst_gatv pos_and_ident) fresh_dep_gatvs to_gatvs (th, error) + # (new_dep_st, th) = applySubstInSymbolType fresh_dep_st th + # (new_dep_st, forall_dep_atvs, (th, modules, error)) + = build_symbol_type new_dep_st to_gatvs gen_deps kind gen_ident gen_pos (inc order) (th, modules, error) + # (curry_dep_st, th) = curryGenericArgType1 new_dep_st ("cur" +++ toString order +++ toString arg_num) th + # curry_dep_st = adjust_forall curry_dep_st forall_dep_atvs + = (curry_dep_st, (arg_num+1, th, modules, error)) + +buildKindIndexedTypeWithPartialDependencies :: + !SymbolType // symbol type to kind-index + ![TypeVar] // generic type variables + ![GenericDependency] // generic dependencies + !TypeKind // kind index + !Int + !Ident // name for debugging + !Position // position for debugging + !*TypeHeaps !*Modules !*ErrorAdmin + -> (!SymbolType, // instantiated type + ![ATypeVar], // fresh generic type variables + !*TypeHeaps,!*Modules,!*ErrorAdmin) +// only for kinds of order<=1 +buildKindIndexedTypeWithPartialDependencies st gtvs deps kind used_deps ident pos th modules error + #! (fresh_st, gatvs, th) = fresh_generic_type st gtvs th + + #! (kind_indexed_st, (th, modules, error)) = build_symbol_type fresh_st gatvs deps kind ident pos (th, modules, error) + + #! th = clearSymbolType kind_indexed_st th + #! th = clearSymbolType st th // paranoja + = (kind_indexed_st, gatvs, th, modules, error) +where + build_symbol_type :: + !SymbolType // generic type, + ![ATypeVar] // attributed generic variables + ![GenericDependency] // generic dependencies + !TypeKind // kind to specialize to + !Ident + !Position + (!*TypeHeaps, !*Modules, !*ErrorAdmin) + -> ( !SymbolType // new generic type + , (!*TypeHeaps, !*Modules, !*ErrorAdmin)) + build_symbol_type st _ _ KindConst _ _ (th, modules, error) + = (st, (th, modules, error)) + build_symbol_type st gatvs deps (KindArrow kinds) ident pos (th, modules, error) + # (arg_stss, arg_gatvss, (_, th, modules, error)) + = mapY2St (build_arg st gatvs deps ident pos) kinds (0, th, modules, error) + # arg_sts = flatten arg_stss + + # (body_st, th) + = build_body st gatvs (transpose arg_gatvss) th - build_body :: - !SymbolType - ![ATypeVar] - ![[ATypeVar]] - !*TypeHeaps - -> (!SymbolType, !*TypeHeaps) - build_body st gatvs arg_gatvss th - # th = clearSymbolType st th - # th = fold2St subst_gatv gatvs arg_gatvss th - # (st, th) = applySubstInSymbolType st th - //# st = add_propagating_inequalities st gatvs arg_gatvss - = (st, th) + # num_added_args = length arg_sts + # new_st = + { st_vars = removeDup ( + foldr (++) body_st.st_vars [st_vars \\ {st_vars}<-arg_sts]) + , st_attr_vars = removeDup ( + foldr (++) body_st.st_attr_vars [st_attr_vars \\ {st_attr_vars}<-arg_sts]) + , st_args = [st_result \\ {st_result}<-arg_sts] ++ body_st.st_args + , st_result = body_st.st_result + , st_arity = body_st.st_arity + num_added_args + , st_context = removeDup( + foldr (++) body_st.st_context [st_context \\ {st_context} <- arg_sts]) + , st_attr_env = removeDup( + foldr (++) body_st.st_attr_env [st_attr_env \\ {st_attr_env} <- arg_sts]) + , st_args_strictness = insert_n_lazy_values_at_beginning num_added_args body_st.st_args_strictness + } + = (new_st, (th, modules, error)) + + build_arg :: + !SymbolType // current part of the generic type + ![ATypeVar] // generic type variables with their attrs + ![GenericDependency] // generic dependencies + !Ident + !Position + !TypeKind // kind corrseponding to the arg + ( !Int // the argument number + , !*TypeHeaps, !*Modules, !*ErrorAdmin) + -> ( ![SymbolType], [ATypeVar] // fresh symbol type and generic variables + ,( !Int // incremented argument number + ,!*TypeHeaps, !*Modules, !*ErrorAdmin)) + build_arg st gatvs deps ident pos KindConst (arg_num, th, modules, error) + # postfix = toString arg_num + | used_deps bitand (1<0 + #! th = clearSymbolType st th + #! (fresh_gatvs, th) = mapSt (create_fresh_gatv postfix) gatvs th + #! (th, error) = fold2St (make_subst_gatv pos_and_ident) gatvs fresh_gatvs (th, error) + #! (new_st, th) = applySubstInSymbolType st th + #! (curry_st, th) + = curryGenericArgType1 new_st ("cur1" +++ postfix) th + # (curry_dep_sts, arg_num_th_modules_error) = build_dependency_args fresh_gatvs deps (arg_num+1, th, modules, error) + = ([curry_st:curry_dep_sts], fresh_gatvs, arg_num_th_modules_error) + + #! (fresh_gatvs, th) = mapSt (create_fresh_gatv postfix) gatvs th + #! (th, error) = fold2St (make_subst_gatv pos_and_ident) gatvs fresh_gatvs (th, error) + # (curry_dep_sts, arg_num_th_modules_error) = build_dependency_args fresh_gatvs deps (arg_num+1, th, modules, error) + = (curry_dep_sts, fresh_gatvs, arg_num_th_modules_error) where - subst_gatv gatv=:{atv_variable} arg_gatvs th=:{th_vars} - #! type_args = [ makeAType (TV atv_variable) atv_attribute - \\ {atv_variable, atv_attribute} <- arg_gatvs] - #! type = (CV atv_variable) :@: type_args - #! th_vars = writePtr atv_variable.tv_info_ptr (TVI_Type type) th_vars - = {th & th_vars = th_vars} - - add_propagating_inequalities st gatvs arg_gatvss - # inequalities = zipWith make_inequalities gatvs arg_gatvss - = {st & st_attr_env = st.st_attr_env ++ flatten inequalities} - where - make_inequalities gatv arg_gatvs - = filterOptionals (map (make_inequality gatv) arg_gatvs) - make_inequality {atv_attribute=TA_Var x} {atv_attribute=TA_Var y} - = Yes {ai_offered = x, ai_demanded = y} // offered <= demanded = outer<=inner = x<=y - make_inequality _ _ - = No + pos_and_ident = (pos,ident) + + build_dependency_args fresh_gatvs [{gd_index, gd_nums}:deps] (arg_num, th, modules, error) + | used_deps bitand (1<0 + # ({gen_type, gen_vars, gen_deps, gen_ident, gen_pos}, modules) + = modules![gd_index.gi_module].com_generic_defs.[gd_index.gi_index] + # (fresh_dep_st, fresh_dep_gatvs, th) = fresh_generic_type gen_type gen_vars th + # to_gatvs = map (\num -> fresh_gatvs !! num) gd_nums + # (th, error) = fold2St (make_subst_gatv pos_and_ident) fresh_dep_gatvs to_gatvs (th, error) + # (new_dep_st, th) = applySubstInSymbolType fresh_dep_st th + # (curry_dep_st, th) = curryGenericArgType1 new_dep_st ("cur1" +++ toString arg_num) th + # (dep_args,(arg_num, th, modules, error)) = build_dependency_args fresh_gatvs deps (arg_num+1, th, modules, error) + = ([curry_dep_st:dep_args], (arg_num, th, modules, error)) + = build_dependency_args fresh_gatvs deps (arg_num+1, th, modules, error) + build_dependency_args fresh_gatvs [] (arg_num, th, modules, error) + = ([],(arg_num, th, modules, error)) + +fresh_generic_type :: SymbolType [b] *TypeHeaps -> (!SymbolType,![ATypeVar],!*TypeHeaps) +fresh_generic_type st gtvs th + # th = clearSymbolType st th + # (fresh_st, th) = freshSymbolType st th + # fresh_gtvs = take (length gtvs) fresh_st.st_vars + # (gatvs, th) = collectAttrsOfTypeVarsInSymbolType fresh_gtvs fresh_st th + = (fresh_st, gatvs, th) + +create_fresh_gatv :: {#Char} ATypeVar *TypeHeaps -> (!ATypeVar, !*TypeHeaps) +create_fresh_gatv postfix atv=:{atv_attribute, atv_variable} th=:{th_attrs, th_vars} + # (fresh_atv_variable, th_vars) = freshTypeVar (postfixIdent atv_variable.tv_ident.id_name postfix) th_vars + # (fresh_atv_attribute, th_attrs) + = case atv_attribute of + TA_Var {av_ident} + # (av, th_attrs) = freshAttrVar (postfixIdent av_ident.id_name postfix) th_attrs + -> (TA_Var av, th_attrs) + TA_Multi + -> (TA_Multi, th_attrs) + TA_Unique + -> (TA_Unique, th_attrs) + # new_atv = {atv_variable = fresh_atv_variable, atv_attribute = fresh_atv_attribute} + # th = {th & th_vars = th_vars, th_attrs = th_attrs} + = (new_atv, th) + +make_subst_gatv :: (Position,Ident) ATypeVar ATypeVar (*TypeHeaps, *ErrorAdmin) -> (!*TypeHeaps, !*ErrorAdmin) +make_subst_gatv pos_and_ident atv=:{atv_attribute, atv_variable} gatv=:{atv_attribute=new_atv_attribute, atv_variable=new_atv_variable} (th=:{th_attrs, th_vars}, error) + # th_vars = make_subst_gtv atv_variable new_atv_variable th_vars + # (th_attrs, error) = make_subst_attr atv_attribute new_atv_attribute th_attrs error + # th & th_vars = th_vars, th_attrs = th_attrs + = (th, error) +where + make_subst_gtv :: TypeVar TypeVar *TypeVarHeap -> *TypeVarHeap + make_subst_gtv {tv_info_ptr} new_atv_variable th_vars + = writePtr tv_info_ptr (TVI_Type (TV new_atv_variable)) th_vars + + make_subst_attr :: TypeAttribute TypeAttribute *AttrVarHeap *ErrorAdmin -> (!*AttrVarHeap,!*ErrorAdmin) + make_subst_attr (TA_Var {av_ident, av_info_ptr}) new_atv_attribute=:(TA_Var _) th_attrs error + = (writePtr av_info_ptr (AVI_Attr new_atv_attribute) th_attrs, error) + make_subst_attr TA_Multi TA_Multi th_attrs error + = (th_attrs, error) + make_subst_attr TA_Unique TA_Unique th_attrs error + = (th_attrs, error) + make_subst_attr _ _ th_attrs error + # (pos,ident) = pos_and_ident + = (th_attrs, reportError ident.id_name pos ("inconsistency with attributes of a generic dependency") error) + +adjust_forall curry_st [] = curry_st +adjust_forall curry_st=:{st_result} forall_atvs + #! st_result = {st_result & at_type = TFA forall_atvs st_result.at_type} + = { curry_st + & st_result = st_result + , st_attr_vars + = curry_st.st_attr_vars -- [av \\ {atv_attribute=TA_Var av} <- forall_atvs] + , st_vars + = curry_st.st_vars -- [atv_variable \\ {atv_variable} <- forall_atvs] + } + +build_body :: !SymbolType ![ATypeVar] ![[ATypeVar]] !*TypeHeaps -> (!SymbolType, !*TypeHeaps) +build_body st gatvs arg_gatvss th + # th = clearSymbolType st th + # th = fold2St subst_gatv gatvs arg_gatvss th + # (st, th) = applySubstInSymbolType st th + //# st = add_propagating_inequalities st gatvs arg_gatvss + = (st, th) +where + subst_gatv gatv=:{atv_variable} arg_gatvs th=:{th_vars} + #! type_args = [ makeAType (TV atv_variable) atv_attribute + \\ {atv_variable, atv_attribute} <- arg_gatvs] + #! type = (CV atv_variable) :@: type_args + #! th_vars = writePtr atv_variable.tv_info_ptr (TVI_Type type) th_vars + = {th & th_vars = th_vars} + /* + add_propagating_inequalities st gatvs arg_gatvss + # inequalities = zipWith make_inequalities gatvs arg_gatvss + = {st & st_attr_env = st.st_attr_env ++ flatten inequalities} + where + make_inequalities gatv arg_gatvs + = filterOptionals (map (make_inequality gatv) arg_gatvs) + make_inequality {atv_attribute=TA_Var x} {atv_attribute=TA_Var y} + = Yes {ai_offered = x, ai_demanded = y} // offered <= demanded = outer<=inner = x<=y + make_inequality _ _ + = No + */ reportError name pos msg error=:{ea_file} # ea_file = ea_file <<< "Error " <<< (stringPosition name pos) <<< ":" <<< msg <<< '\n' @@ -4104,9 +4982,12 @@ collectAttrsOfTypeVars :: ![TypeVar] type !*TypeHeaps -> (![ATypeVar], !*TypeHea collectAttrsOfTypeVars tvs type th #! (th=:{th_vars}) = clearType type th - # th_vars = foldSt (\{tv_info_ptr} h->writePtr tv_info_ptr TVI_Used h) tvs th_vars + # th_vars = foldSt (\{tv_info_ptr} h->writePtr tv_info_ptr TVI_Empty h) tvs th_vars - #! (atvs, th_vars) = foldType on_type on_atype type ([], th_vars) + # th_vars = foldType on_type on_atype type th_vars + + # (attrs, th_vars) = mapSt read_attr tvs th_vars + # atvs = [makeATypeVar tv attr \\ tv <- tvs & attr <- attrs] # th_vars = foldSt (\{tv_info_ptr} h->writePtr tv_info_ptr TVI_Empty h) tvs th_vars @@ -4121,14 +5002,17 @@ where //??? TFA -- seems that it is not needed on_atype _ st = st - on_type_var tv=:{tv_info_ptr} attr (atvs, th_vars) + on_type_var tv=:{tv_info_ptr} attr th_vars #! (tvi, th_vars) = readPtr tv_info_ptr th_vars = case tvi of - TVI_Used - # th_vars = writePtr tv_info_ptr TVI_Empty th_vars - -> ([makeATypeVar tv attr : atvs], th_vars) - TVI_Empty - -> (atvs, th_vars) + TVI_Empty + -> writePtr tv_info_ptr (TVI_Attr attr) th_vars + TVI_Attr _ + -> th_vars + + read_attr {tv_info_ptr} th_vars + # (TVI_Attr attr, th_vars) = readPtr tv_info_ptr th_vars + = (attr, th_vars) collectAttrsOfTypeVarsInSymbolType tvs {st_args, st_result} th = collectAttrsOfTypeVars tvs [st_result:st_args] th @@ -4302,7 +5186,7 @@ makeFunction ident group_index arg_vars body_expr opt_sym_type main_dcl_module_n , fun_pos = fun_pos , fun_kind = FK_Function cNameNotLocationDependent , fun_lifted = 0 - , fun_info = + , fun_info = { fi_calls = collectCalls main_dcl_module_n body_expr , fi_group_index = group_index , fi_def_level = NotALevel diff --git a/frontend/genericsupport.dcl b/frontend/genericsupport.dcl index 56a51c0..e1ec5ad 100644 --- a/frontend/genericsupport.dcl +++ b/frontend/genericsupport.dcl @@ -1,6 +1,6 @@ definition module genericsupport -import syntax, checksupport +import syntax lookupGenericClassInfo :: !TypeKind @@ -51,3 +51,15 @@ genericIdentToClassIdent :: !String !TypeKind -> Ident genericIdentToMemberIdent :: !String !TypeKind -> Ident genericIdentToFunIdent :: !String !TypeCons -> Ident kind_to_short_string :: !TypeKind -> {#Char} + +field_n_of_GenericTypeDefDescriptor :: !String -> Int +field_n_of_GenericConsDescriptor :: !String -> Int +field_n_of_GenericFieldDescriptor :: !String -> Int +field_n_of_GenericRecordDescriptor :: !String -> Int + +field_0_name_of_generic_info :: !Int -> String +field_1_name_of_generic_info :: !Int -> String +field_2_name_of_generic_info :: !Int -> String +field_3_name_of_generic_info :: !Int -> String +field_4_name_of_generic_info :: !Int -> String +field_5_name_of_generic_info :: !Int -> String diff --git a/frontend/genericsupport.icl b/frontend/genericsupport.icl index 993149d..6ac079b 100644 --- a/frontend/genericsupport.icl +++ b/frontend/genericsupport.icl @@ -1,6 +1,6 @@ implementation module genericsupport -import syntax, checksupport +import syntax getGenericClassInfo :: !(Global Index) @@ -87,7 +87,7 @@ genericIdentToClassIdent id_name kind kind_to_short_string :: !TypeKind -> {#Char} kind_to_short_string KindConst = "s" -kind_to_short_string (KindArrow kinds) = kinds_to_str kinds +++ "s" +kind_to_short_string (KindArrow kinds) = kinds_to_str kinds +++ "s" where kinds_to_str [] = "" kinds_to_str [KindConst:ks] = "s" +++ kinds_to_str ks @@ -105,4 +105,63 @@ where type_cons_to_str (TypeConsBasic bt) = toString bt type_cons_to_str TypeConsArrow = "ARROW" type_cons_to_str (TypeConsVar tv) = tv.tv_ident.id_name - \ No newline at end of file + +field_n_of_GenericTypeDefDescriptor :: !String -> Int +field_n_of_GenericTypeDefDescriptor "gtd_name" = 0 +field_n_of_GenericTypeDefDescriptor "gtd_arity" = 1 +field_n_of_GenericTypeDefDescriptor "gtd_num_conses" = 2 +field_n_of_GenericTypeDefDescriptor "gtd_conses" = 3 +field_n_of_GenericTypeDefDescriptor _ = -1 + +field_n_of_GenericConsDescriptor :: !String -> Int +field_n_of_GenericConsDescriptor "gcd_name" = 0 +field_n_of_GenericConsDescriptor "gcd_arity" = 1 +field_n_of_GenericConsDescriptor "gcd_prio" = 2 +field_n_of_GenericConsDescriptor "gcd_type_def" = 3 +field_n_of_GenericConsDescriptor "gcd_type" = 4 +field_n_of_GenericConsDescriptor "gcd_index" = 5 +field_n_of_GenericConsDescriptor _ = -1 + +field_n_of_GenericFieldDescriptor :: !String -> Int +field_n_of_GenericFieldDescriptor "gfd_name" = 0 +field_n_of_GenericFieldDescriptor "gfd_index" = 1 +field_n_of_GenericFieldDescriptor "gfd_cons" = 2 +field_n_of_GenericFieldDescriptor _ = -1 + +field_n_of_GenericRecordDescriptor :: !String -> Int +field_n_of_GenericRecordDescriptor "grd_name" = 0 +field_n_of_GenericRecordDescriptor "grd_arity" = 1 +field_n_of_GenericRecordDescriptor "grd_type_arity" = 2 +field_n_of_GenericRecordDescriptor "grd_type" = 3 +field_n_of_GenericRecordDescriptor "grd_fields" = 4 +field_n_of_GenericRecordDescriptor _ = -1 + +field_0_name_of_generic_info :: !Int -> String +field_0_name_of_generic_info 0 = "gtd_name" +field_0_name_of_generic_info 1 = "gcd_name" +field_0_name_of_generic_info 2 = "grd_name" +field_0_name_of_generic_info 3 = "gfd_name" + +field_1_name_of_generic_info :: !Int -> String +field_1_name_of_generic_info 0 = "gtd_arity" +field_1_name_of_generic_info 1 = "gcd_arity" +field_1_name_of_generic_info 2 = "grd_arity" +field_1_name_of_generic_info 3 = "gfd_index" + +field_2_name_of_generic_info :: !Int -> String +field_2_name_of_generic_info 0 = "gtd_num_conses" +field_2_name_of_generic_info 1 = "gcd_prio" +field_2_name_of_generic_info 2 = "grd_type_arity" +field_2_name_of_generic_info 3 = "gfd_cons" + +field_3_name_of_generic_info :: !Int -> String +field_3_name_of_generic_info 0 = "gtd_conses" +field_3_name_of_generic_info 1 = "gcd_type_def" +field_3_name_of_generic_info 2 = "grd_type" + +field_4_name_of_generic_info :: !Int -> String +field_4_name_of_generic_info 1 = "gcd_type" +field_4_name_of_generic_info 2 = "grd_fields" + +field_5_name_of_generic_info :: !Int -> String +field_5_name_of_generic_info 1 = "gcd_index" diff --git a/frontend/overloading.icl b/frontend/overloading.icl index f216b8f..a4e42e8 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -986,11 +986,16 @@ convertOverloadedCall defs contexts {symb_ident,symb_kind = SK_OverloadedFunctio = ({heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_ptr, inst_expr)}, ptrs, error) where adjust_member_application defs contexts {me_ident,me_offset,me_class} (CA_Instance red_contexts) class_exprs heaps_and_ptrs - # ({glob_module,glob_object}, red_contexts_appls) = find_instance_of_member me_class me_offset red_contexts - (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts red_contexts_appls heaps_and_ptrs - class_exprs = exprs ++ class_exprs - = (EI_Instance { glob_module = glob_module, glob_object = { ds_ident = me_ident, ds_arity = length class_exprs, ds_index = glob_object }} class_exprs, - heaps_and_ptrs) + # (glob_module,cim_index,cim_ident,red_contexts_appls) = find_instance_of_member me_class me_offset red_contexts + #! (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts red_contexts_appls heaps_and_ptrs + class_exprs = exprs ++ class_exprs + n_class_exprs = length class_exprs + | cim_index>=0 + = (EI_Instance {glob_module=glob_module, glob_object={ds_ident=me_ident, ds_arity=n_class_exprs, ds_index=cim_index}} class_exprs, + heaps_and_ptrs) + # index = -1 - cim_index + = (EI_Instance {glob_module=glob_module, glob_object={ds_ident=cim_ident, ds_arity=n_class_exprs, ds_index=index}} class_exprs, + heaps_and_ptrs) adjust_member_application defs contexts {me_ident,me_offset,me_class={glob_module,glob_object}} (CA_Context tc) class_exprs (heaps=:{hp_type_heaps}, ptrs) # (class_context, address, hp_type_heaps) = determineContextAddress contexts defs tc hp_type_heaps # {class_dictionary={ds_index,ds_ident}} = defs.[glob_module].com_class_defs.[glob_object] @@ -1003,13 +1008,13 @@ where adjust_member_application defs contexts _ (CA_LocalTypeCode new_var_ptr) _ heaps_and_ptrs = (EI_TypeCode (TCE_Var new_var_ptr), heaps_and_ptrs) - find_instance_of_member :: (Global Int) Int ReducedContexts -> ((Global Int),[ClassApplication]) + find_instance_of_member :: (Global Int) Int ReducedContexts -> (!Index,!Index,!Ident,[ClassApplication]) find_instance_of_member me_class me_offset { rcs_class_context = {rc_class_index, rc_inst_module, rc_inst_members, rc_red_contexts}, rcs_constraints_contexts} - | rc_class_index.gi_module == me_class.glob_module && rc_class_index.gi_index == me_class.glob_object - # {cim_index,cim_arity} = rc_inst_members.[me_offset] + | rc_class_index.gi_module == me_class.glob_module && rc_class_index.gi_index == me_class.glob_object + # {cim_index,cim_arity,cim_ident} = 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) + = (cim_arity, cim_index, cim_ident, rc_red_contexts) + = (rc_inst_module, cim_index, cim_ident, 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 ] diff --git a/frontend/parse.icl b/frontend/parse.icl index f028ea0..c9471ed 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -1,7 +1,7 @@ implementation module parse import StdEnv -import scanner, syntax, hashtable, utilities, predef, containers +import scanner, syntax, hashtable, utilities, predef, containers, genericsupport ParseOnly :== False @@ -567,61 +567,70 @@ where wantGenericFunctionDefinition name pos pState //# (type, pState) = wantType pState # (ok, {at_type=type}, pState) = trySimpleType TA_None pState - # (ident, pState) = stringToIdent name (IC_GenericCase type) pState - # (type_CONS_ident, pState) = stringToIdent "CONS" IC_Type pState - # (type_RECORD_ident, pState) = stringToIdent "RECORD" IC_Type pState - # (type_FIELD_ident, pState)= stringToIdent "FIELD" IC_Type pState - # (type_OBJECT_ident, pState)= stringToIdent "OBJECT" IC_Type pState - # (generic_ident, pState) = stringToIdent name IC_Generic pState - - # (type_cons, pState) = get_type_cons type pState + # (ident, pState) = stringToIdent name (IC_GenericCase type) pState + # (generic_ident, pState) = stringToIdent name IC_Generic pState + # (type_cons, generic_fun_ident, pState) = get_type_cons type pState with get_type_cons (TA type_symb []) pState - = (TypeConsSymb type_symb, pState) + = make_generic_fun_ident (TypeConsSymb type_symb) pState get_type_cons (TA type_symb _) pState # pState = parseError "generic type, no constructor arguments allowed" No " |}" pState - = (abort "no TypeCons", pState) - get_type_cons (TB tb) pState - = (TypeConsBasic tb, pState) + = (abort_no_TypeCons, abort_no_TypeCons, pState) + get_type_cons (TB tb) pState + = make_generic_fun_ident (TypeConsBasic tb) pState get_type_cons TArrow pState - = (TypeConsArrow, pState) + = make_generic_fun_ident TypeConsArrow pState get_type_cons (TV tv) pState - = (TypeConsVar tv, pState) + = make_generic_fun_ident (TypeConsVar tv) pState get_type_cons _ pState # pState = parseError "generic type" No " |}" pState - = (abort "no TypeCons", pState) - + = (abort_no_TypeCons, abort_no_TypeCons, pState) + + make_generic_fun_ident type_cons pState + # generic_fun_ident = genericIdentToFunIdent name type_cons + (generic_fun_ident,pState) = stringToIdent generic_fun_ident.id_name IC_Expression pState + = (type_cons, generic_fun_ident, pState) + # (token, pState) = nextToken GenericContext pState - # (geninfo_arg, pState) = case token of + # (geninfo_arg, gcf_generic_info, pState) = case token of GenericOfToken # (ok, geninfo_arg, pState) = trySimplePattern pState # pState = wantToken FunctionContext "type argument" GenericCloseToken pState | ok -> case type_cons of - (TypeConsSymb {type_ident}) - | type_ident == type_CONS_ident - -> (geninfo_arg, pState) - | type_ident == type_RECORD_ident - -> (geninfo_arg, pState) - | type_ident == type_FIELD_ident - -> (geninfo_arg, pState) - | type_ident == type_OBJECT_ident - -> (geninfo_arg, pState) + TypeConsSymb {type_ident=type_ident=:{id_name}} + | id_name=="OBJECT" + # (generic_constructor_type_ident, pState) = stringToIdent id_name IC_Type pState + | type_ident==generic_constructor_type_ident + -> (geninfo_arg, generic_info_of_OBJECT_geninfo_arg geninfo_arg, pState) + -> (geninfo_arg, 0, pState) + | id_name=="CONS" + # (generic_constructor_type_ident, pState) = stringToIdent id_name IC_Type pState + | type_ident==generic_constructor_type_ident + -> (geninfo_arg, generic_info_of_CONS_geninfo_arg geninfo_arg, pState) + -> (geninfo_arg, 0, pState) + | id_name=="RECORD" + # (generic_constructor_type_ident, pState) = stringToIdent id_name IC_Type pState + | type_ident==generic_constructor_type_ident + -> (geninfo_arg, generic_info_of_RECORD_geninfo_arg geninfo_arg, pState) + -> (geninfo_arg, 0, pState) + | id_name=="FIELD" + # (generic_constructor_type_ident, pState) = stringToIdent id_name IC_Type pState + | type_ident==generic_constructor_type_ident + -> (geninfo_arg, generic_info_of_FIELD_geninfo_arg geninfo_arg, pState) + -> (geninfo_arg, 0, pState) _ - | otherwise - -> (geninfo_arg, pState) + -> (geninfo_arg, 0, pState) | otherwise # pState = parseError "generic case" No "simple lhs expression" pState - -> (PE_Empty, pState) - + -> (PE_Empty, 0, pState) + GenericCloseToken - # (geninfo_ident, pState) = stringToIdent "geninfo" IC_Expression pState - -> (PE_Ident geninfo_ident, pState) + -> (PE_WildCard, 0, pState) _ # pState = parseError "generic type" (Yes token) "of or |}" pState - # (geninfo_ident, pState) = stringToIdent "geninfo" IC_Expression pState - -> (PE_Ident geninfo_ident, pState) - + -> (PE_WildCard, 0, pState) + //# pState = wantToken FunctionContext "type argument" GenericCloseToken pState # (args, pState) = parseList trySimplePattern pState # args = [geninfo_arg : args] @@ -643,10 +652,14 @@ where gcf_gident = generic_ident, gcf_generic = {gi_module=NoIndex,gi_index=NoIndex}, gcf_arity = length args, + gcf_generic_info = gcf_generic_info, gcf_body = GCB_ParsedBody args rhs, - gcf_kind = KindError } + gcf_kind = KindError, + gcf_generic_instance_deps = AllGenericInstanceDependencies } } - = (True, PD_GenericCase generic_case, pState) + = (True, PD_GenericCase generic_case generic_fun_ident, pState) + + abort_no_TypeCons => abort "no TypeCons" wantForeignExportDefinition pState # (token, pState) = nextToken GeneralContext pState @@ -684,6 +697,74 @@ where foreign_export_error s pState = (True,PD_Erroneous,tokenBack (parseError "foreign export" No s pState)) +generic_info_of_RECORD_geninfo_arg (PE_Record PE_Empty NoRecordName field_assignments) + = mark_GenericRecordDescriptor_fields field_assignments 0 + where + mark_GenericRecordDescriptor_fields :: [FieldAssignment] !Int -> Int + mark_GenericRecordDescriptor_fields [{bind_dst=FieldName {id_name}}:field_assignments] generic_info + # field_number=field_n_of_GenericRecordDescriptor id_name + | field_number>=0 && generic_info bitand (1< Int + mark_GenericTypeDefDescriptor_fields [{bind_dst=FieldName {id_name}}:field_assignments] generic_info + # field_number=field_n_of_GenericTypeDefDescriptor id_name + | field_number>=0 && generic_info bitand (1< Int + mark_GenericConsDescriptor_fields [{bind_dst=FieldName {id_name}}:field_assignments] generic_info + # field_number=field_n_of_GenericConsDescriptor id_name + | field_number>=0 && generic_info bitand (1< Int + mark_GenericFieldDescriptor_fields [{bind_dst=FieldName {id_name}}:field_assignments] generic_info + # field_number=field_n_of_GenericFieldDescriptor id_name + | field_number>=0 && generic_info bitand (1< (![ParsedDefinition], !ParseState) want_instance_type_definitions instance_type pState = parseList want_instance_type_definition pState @@ -1669,7 +1750,7 @@ wantGenericDefinition parseContext pos pState # (ident, pState) = stringToIdent name IC_Generic/*IC_Class*/ pState # (member_ident, pState) = stringToIdent name IC_Expression pState # (arg_vars, pState) = wantList "generic variable(s)" try_variable pState - + # (gen_deps, pState) = optionalDependencies pState # pState = wantToken TypeContext "generic definition" DoubleColonToken pState # (type, pState) = wantSymbolType pState # pState = wantEndOfDefinition "generic definition" pState @@ -1678,6 +1759,7 @@ wantGenericDefinition parseContext pos pState , gen_member_ident = member_ident , gen_type = type , gen_vars = arg_vars + , gen_deps = gen_deps , gen_pos = pos , gen_info_ptr = nilPtr } @@ -1693,6 +1775,32 @@ wantGenericDefinition parseContext pos pState # (token, pState) = nextToken TypeContext pState = tryTypeVarT token pState + optionalDependencies :: !ParseState -> (![GenericDependency], !ParseState) + optionalDependencies pState + # (token, pState) = nextToken TypeContext pState + = case token of + BarToken -> wantSepList "generic dependencies" CommaToken TypeContext wantDependency pState + _ -> ([], tokenBack pState) + + wantDependency :: !ParseState -> (Bool, GenericDependency, ParseState) + wantDependency pState + # (ident, pState) = wantIdentOrQualifiedIdent pState + # (vars, pState) = wantList "generic dependency variable(s)" try_variable pState + = (True, {gd_ident = ident, gd_index = NoGlobalIndex, gd_vars = vars, gd_nums = repeatn (length vars) (-1)}, pState) + + wantIdentOrQualifiedIdent pState + # (token, pState) = nextToken TypeContext pState + = case token of + IdentToken name + # (ident, pState) = stringToIdent name IC_Generic pState + = (Ident ident, pState) + QualifiedIdentToken mod_name name + # (mod_ident, pState) = stringToQualifiedModuleIdent mod_name name IC_Generic pState + = (QualifiedIdent mod_ident name, pState) + _ + # (ident, pState) = stringToIdent "" IC_Generic pState + = (Ident ident, parseError "generic dependency" (Yes token) "" pState) + wantDeriveDefinition :: !ParseContext !Position !*ParseState -> (!ParsedDefinition, !*ParseState) wantDeriveDefinition parseContext pos pState | pState.ps_flags bitand PS_SupportGenericsMask==0 @@ -1733,12 +1841,50 @@ where # (generic_ident, pState) = stringToIdent name IC_Generic pState # (type_cons, pState) = get_type_cons type pState # (token, pState) = nextToken GenericContext pState + # (gcf_generic_info, generic_instance_deps, token, pState) + = case token of + // make sure no look ahead occurred in a non GenericContext (defines an offside) + GenericOfToken + -> case type_cons of + TypeConsSymb {type_ident={id_name}} + | id_name=="OBJECT" || id_name=="CONS" || id_name=="RECORD" || id_name=="FIELD" + # (next_token, pState) = nextToken FunctionContext pState + -> case next_token of + IdentToken name + | isLowerCaseName name + # (token, pState) = nextToken GenericContext pState + # (generic_instance_deps, token, pState) = parse_optional_generic_instance_deps token pState + -> (-1, generic_instance_deps, token, pState) + CurlyOpenToken + # (token, pState) = nextToken FunctionContext pState + -> case token of + CurlyCloseToken + # (token, pState) = nextToken GenericContext pState + # (generic_instance_deps, token, pState) = parse_optional_generic_instance_deps token pState + -> (0, generic_instance_deps, token, pState) + _ + # (generic_info,pState) = parse_info_fields id_name token pState + (token, pState) = nextToken GenericContext pState + # (generic_instance_deps, token, pState) = parse_optional_generic_instance_deps token pState + -> (generic_info,generic_instance_deps, token,pState) + _ + # pState = parseError "derive definition" (Yes next_token) "{ or lower case ident" pState + -> (0, AllGenericInstanceDependencies, token, pState) + _ + -> (0, AllGenericInstanceDependencies, token, pState) + GenericWithToken + # (generic_instance_deps, token, pState) = parse_generic_instance_deps 0 0 pState + -> (0, generic_instance_deps, token, pState) + _ + -> (0, AllGenericInstanceDependencies, token, pState) + # derive_def = { gc_pos = pos , gc_type = type , gc_type_cons = type_cons , 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} + gcf_generic_info = gcf_generic_info, gcf_body = GCB_None, gcf_kind = KindError, + gcf_generic_instance_deps = generic_instance_deps} } = (derive_def, token, pState) @@ -1757,7 +1903,8 @@ where # (type, pState) = wantType pState # (ident, pState) = stringToIdent class_ident.id_name (IC_GenericDeriveClass type) pState # (type_cons, pState) = get_type_cons type pState - # derive_def = { gc_pos = pos, gc_type = type, gc_type_cons = type_cons, gc_gcf = GCFC ident class_ident} + # derive_def = { gc_pos = pos, gc_type = type, gc_type_cons = type_cons, + gc_gcf = GCFC ident class_ident} = (derive_def, pState) get_type_cons :: Type !*ParseState -> (TypeCons, !*ParseState) @@ -1774,6 +1921,115 @@ where # pState = parseError "generic type" No " type constructor" pState = (abort "no TypeCons", pState) + parse_info_fields "OBJECT" token pState + = parse_OBJECT_info_fields token 0 pState + parse_info_fields "CONS" token pState + = parse_CONS_info_fields token 0 pState + parse_info_fields "RECORD" token pState + = parse_RECORD_info_fields token 0 pState + parse_info_fields "FIELD" token pState + = parse_FIELD_info_fields token 0 pState + + parse_OBJECT_info_fields token=:(IdentToken name) generic_info pState + # field_number=field_n_of_GenericTypeDefDescriptor name + | field_number<0 + = (generic_info, parseError "GenericTypeDefDescriptor" (Yes token) "field of GenericTypeDefDescriptor" pState) + # field_mask = 1<0) + (parseErrorSimple "GenericTypeDefDescriptor" "field already defined" pState) + pState + generic_info = generic_info bitor field_mask + (token, pState) = nextToken FunctionContext pState + = case token of + CommaToken + # (token,pState) = nextToken FunctionContext pState + -> parse_OBJECT_info_fields token generic_info pState + CurlyCloseToken + -> (generic_info,pState) + _ + -> (generic_info, parseError "GenericTypeDefDescriptor record" (Yes token) ", or }" pState) + parse_OBJECT_info_fields token generic_info pState + = (generic_info, parseError "GenericTypeDefDescriptor record" (Yes token) "field name" pState) + + parse_CONS_info_fields token=:(IdentToken name) generic_info pState + # field_number=field_n_of_GenericConsDescriptor name + | field_number<0 + = (generic_info, parseError "GenericConsDescriptor" (Yes token) "field of GenericConsDescriptor" pState) + # field_mask = 1<0) + (parseErrorSimple "GenericConsDescriptor" "field already defined" pState) + pState + generic_info = generic_info bitor field_mask + (token, pState) = nextToken FunctionContext pState + = case token of + CommaToken + # (token,pState) = nextToken FunctionContext pState + -> parse_CONS_info_fields token generic_info pState + CurlyCloseToken + -> (generic_info,pState) + _ + -> (generic_info, parseError "GenericConsDescriptor record" (Yes token) ", or }" pState) + parse_CONS_info_fields token generic_info pState + = (generic_info, parseError "GenericConsDescriptor record" (Yes token) "field name" pState) + + parse_RECORD_info_fields token=:(IdentToken name) generic_info pState + # field_number=field_n_of_GenericRecordDescriptor name + | field_number<0 + = (generic_info, parseError "GenericRecordDescriptor" (Yes token) "field of GenericRecordDescriptor" pState) + # field_mask = 1<0) + (parseErrorSimple "GenericRecordDescriptor" "field already defined" pState) + pState + generic_info = generic_info bitor field_mask + (token, pState) = nextToken FunctionContext pState + = case token of + CommaToken + # (token,pState) = nextToken FunctionContext pState + -> parse_RECORD_info_fields token generic_info pState + CurlyCloseToken + -> (generic_info,pState) + _ + -> (generic_info, parseError "GenericRecordDescriptor record" (Yes token) ", or }" pState) + parse_RECORD_info_fields token generic_info pState + = (generic_info, parseError "GenericRecordDescriptor record" (Yes token) "field name" pState) + + parse_FIELD_info_fields token=:(IdentToken name) generic_info pState + # field_number=field_n_of_GenericFieldDescriptor name + | field_number<0 + = (generic_info, parseError "GenericFieldDescriptor" (Yes token) "field of GenericFieldDescriptor" pState) + # field_mask = 1<0) + (parseErrorSimple "GenericFieldDescriptor" "field already defined" pState) + pState + generic_info = generic_info bitor field_mask + (token, pState) = nextToken FunctionContext pState + = case token of + CommaToken + # (token,pState) = nextToken FunctionContext pState + -> parse_FIELD_info_fields token generic_info pState + CurlyCloseToken + -> (generic_info,pState) + _ + -> (generic_info, parseError "GenericFieldDescriptor record" (Yes token) ", or }" pState) + parse_FIELD_info_fields token generic_info pState + = (generic_info, parseError "GenericFieldDescriptor record" (Yes token) "field name" pState) + + parse_optional_generic_instance_deps GenericWithToken pState + = parse_generic_instance_deps 0 0 pState + parse_optional_generic_instance_deps token pState + = (AllGenericInstanceDependencies, token, pState) + + parse_generic_instance_deps n_deps deps pState + # (token, pState) = nextToken GenericContext pState + = case token of + WildCardToken + -> parse_generic_instance_deps (n_deps+1) deps pState + IdentToken name + | isLowerCaseName name + -> parse_generic_instance_deps (n_deps+1) (deps bitor (1< (GenericInstanceDependencies n_deps deps, token, pState) + /* Type definitions */ diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 6af58be..fc63ca7 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -1054,13 +1054,14 @@ where scan_dcl_module dcl_module mod=:{mod_defs = pdefs} parsed_modules searchPaths modtimefunction files ca # (_, defs, imports, imported_objects,foreign_exports,ca) = reorganiseDefinitionsAndAddTypes dcl_module support_dynamics False pdefs ca - (def_macros, ca) = collectFunctions defs.def_macros False {ca & ca_fun_count=0,ca_rev_fun_defs=[]} - (range, ca) = addFunctionsRange def_macros ca + n_macros = length defs.def_macros + (def_macros, ca) = collectFunctions defs.def_macros False {ca & ca_fun_count=n_macros,ca_rev_fun_defs=[]} + range = {ir_from=0,ir_to=n_macros} (rev_fun_defs,ca) = ca!ca_rev_fun_defs - ca = {ca & ca_rev_fun_defs=[]} + def_macros = def_macros++reverse rev_fun_defs (pea_ok,ca) = ca!ca_error.pea_ok - mod = { mod & mod_imports = imports, mod_imported_objects = imported_objects, mod_defs = { defs & def_macros=reverse rev_fun_defs,def_macro_indices = range }} ca = {ca & ca_rev_fun_defs=[]} + mod = { mod & mod_imports = imports, mod_imported_objects = imported_objects, mod_defs = { defs & def_macros=def_macros,def_macro_indices = range }} (import_ok, parsed_modules,files, ca) = scanModules imports [mod : parsed_modules] cached_modules searchPaths support_generics support_dynamics modtimefunction files ca = (pea_ok && import_ok, parsed_modules,files, ca) @@ -1083,7 +1084,7 @@ scanModule mod=:{mod_ident,mod_type,mod_defs = pdefs} cached_modules support_gen (import_dcls_ok, parsed_modules, files, ca) = scanModules imports parsed_modules cached_modules searchPaths support_generics support_dynamics modtimefunction files ca - (pea_dcl_ok,optional_dcl_mod,ca) = collect_main_dcl_module optional_parsed_dcl_mod dcl_module_n ca + (pea_dcl_ok,optional_dcl_mod,ca) = collect_main_dcl_module optional_parsed_dcl_mod dcl_module_n ca modules = case (reverse parsed_modules) of [{mod_type=MK_NoMainDcl}:modules] @@ -1153,12 +1154,14 @@ where = (import_ok, Yes mod, NoIndex,parsed_modules, cached_modules,files, ca) collect_main_dcl_module (Yes mod=:{mod_defs=defs}) dcl_module_n ca - # (macro_defs, ca) = collectFunctions defs.def_macros False {ca & ca_fun_count=0,ca_rev_fun_defs=[]} - (range, ca) = addFunctionsRange macro_defs ca + # n_macros = length defs.def_macros + (def_macros, ca) = collectFunctions defs.def_macros False {ca & ca_fun_count=n_macros,ca_rev_fun_defs=[]} + range = {ir_from=0,ir_to=n_macros} (rev_fun_defs,ca) = ca!ca_rev_fun_defs + def_macros = def_macros++reverse rev_fun_defs ca = {ca & ca_rev_fun_defs=[]} (pea_ok,ca) = ca!ca_error.pea_ok - mod = { mod & mod_defs = { defs & def_macros=reverse rev_fun_defs,def_macro_indices = range }} + mod = { mod & mod_defs = { defs & def_macros=def_macros,def_macro_indices = range }} = (pea_ok,Yes mod,ca) collect_main_dcl_module No dcl_module_n ca | dcl_module_n==NoIndex @@ -1194,21 +1197,164 @@ 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 :: ![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 +collectGenericBodies :: ![ParsedDefinition] !Ident !Int !TypeCons !*CollectAdmin -> (![ParsedBody], !Int, ![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 + #! (bodies, generic_info, rest_defs, ca) = collectGenericBodies defs gc_ident1 gcf_arity1 gc_type_cons1 ca + # (GCF _ {gcf_body=GCB_ParsedBody args rhs,gcf_arity,gcf_generic_info}) = gc.gc_gcf + # generic_info = generic_info bitor gcf_generic_info #! 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) + = ([body : bodies], generic_info, 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], generic_info, rest_defs, ca) + = ([], 0, all_defs, ca) collectGenericBodies defs gc_ident1 gcf_arity1 gc_type_cons1 ca - = ([], defs, ca) + = ([], 0, defs, ca) + +replace_generic_info_record_by_arguments :: !Int ![ParsedBody] !Int !TypeCons !*CollectAdmin -> (![ParsedBody],!Int,!GenericInstanceDependencies,!*CollectAdmin) +replace_generic_info_record_by_arguments generic_info bodies arity (TypeConsSymb {type_ident={id_name}}) ca + # arity = add_n_bits generic_info (arity-1) + # (bodies,n_deps,deps,ca) = replace_generic_info_record_by_arguments_in_bodies bodies generic_info -1 0 ca + | n_deps>=0 + # deps = deps bitand ((1< 0 + "CONS" -> 1 + "RECORD" -> 2 + "FIELD" -> 3 + + replace_generic_info_record_by_arguments_in_bodies [body:bodies] generic_info n_deps deps ca + # (body,n_deps,deps,ca) = replace_generic_info_record_by_arguments_in_body body generic_info n_deps deps ca + # (bodies,n_deps,deps,ca) = replace_generic_info_record_by_arguments_in_bodies bodies generic_info n_deps deps ca + = ([body : bodies],n_deps,deps,ca) + replace_generic_info_record_by_arguments_in_bodies [] generic_info n_deps deps ca + = ([],n_deps,deps,ca) + + replace_generic_info_record_by_arguments_in_body body=:{pb_args=[PE_Record PE_Empty NoRecordName field_assignments:args]} generic_info n_deps deps ca + # (n_deps,deps) = mark_deps_in_args args 0 n_deps deps + # (args,ca) = add_fields generic_info field_assignments args ca + = ({body & pb_args = args},n_deps,deps,ca) + replace_generic_info_record_by_arguments_in_body body=:{pb_args=[PE_WildCard:args]} generic_info n_deps deps ca + # (n_deps,deps) = mark_deps_in_args args 0 n_deps deps + # args = add_wild_cards generic_info args + = ({body & pb_args = args},n_deps,deps,ca) + + add_fields :: !Int [FieldAssignment] [ParsedExpr] *CollectAdmin -> (![ParsedExpr],!*CollectAdmin) + add_fields generic_info field_assignments args ca + | generic_info==0 + = (args,ca) + | generic_info bitand 1<>0 + = add_field (field_0_name_of_generic_info generic_cons_index) (generic_info bitxor 1) field_assignments args ca + | generic_info bitand 2<>0 + = add_field (field_1_name_of_generic_info generic_cons_index) (generic_info bitxor 2) field_assignments args ca + | generic_info bitand 4<>0 + = add_field (field_2_name_of_generic_info generic_cons_index) (generic_info bitxor 4) field_assignments args ca + | generic_info bitand 8<>0 + = add_field (field_3_name_of_generic_info generic_cons_index) (generic_info bitxor 8) field_assignments args ca + | generic_info bitand 16<>0 + = add_field (field_4_name_of_generic_info generic_cons_index) (generic_info bitxor 16) field_assignments args ca + | generic_info bitand 32<>0 + = add_field (field_5_name_of_generic_info generic_cons_index) (generic_info bitxor 32) field_assignments args ca + + add_field :: !{#Char} !Int [FieldAssignment] [ParsedExpr] *CollectAdmin -> (![ParsedExpr],!*CollectAdmin) + add_field field_name generic_info field_assignments args ca + # (arg,ca) = field_or_wild_card field_name field_assignments ca + # (args,ca) = add_fields generic_info field_assignments args ca + = ([arg : args],ca) + + add_wild_cards 0 args + = args + add_wild_cards generic_info args + | generic_info bitand 1<>0 + = [PE_WildCard : add_wild_cards (generic_info>>1) args] + = add_wild_cards (generic_info>>1) args + + field_or_wild_card field_name [{bind_dst=FieldName {id_name},bind_src}:field_assignments] ca + | id_name==field_name + = case bind_src of + PE_Empty + # ({boxed_ident=ident}, ca_hash_table) = putIdentInHashTable id_name IC_Expression ca.ca_hash_table + -> (PE_Ident ident, {ca & ca_hash_table = ca_hash_table}) + _ + -> (bind_src,ca) + = field_or_wild_card field_name field_assignments ca + field_or_wild_card field_name field_assignments ca + = (PE_WildCard,ca) + + add_n_bits n c + | n>1 + = add_n_bits (n>>1) (c+(n bitand 1)) + = c+n + +determine_generic_instance_deps :: ![ParsedBody] !Int !TypeCons !*CollectAdmin -> (![ParsedBody],!Int,!GenericInstanceDependencies,!*CollectAdmin) +determine_generic_instance_deps bodies arity type_cons ca + = case type_cons of + TypeConsSymb {type_ident={id_name}} + | id_name=="OBJECT" || id_name=="CONS" || id_name=="RECORD" || id_name=="FIELD" || id_name=="PAIR" || id_name=="EITHER" || id_name=="UNIT" + # (n_deps,deps) = determine_generic_instance_deps_in_bodies bodies -1 0 + | n_deps>=0 + # deps = deps bitand ((1< (bodies,arity,GenericInstanceUsedArgs n_deps deps,ca) + -> (bodies,arity,GenericInstanceUsedArgs 0 0,ca) + _ + -> (bodies,arity,AllGenericInstanceDependencies,ca) + where + determine_generic_instance_deps_in_bodies [body:bodies] n_deps deps + # (n_deps,deps) = determine_generic_instance_deps_in_body body n_deps deps + = determine_generic_instance_deps_in_bodies bodies n_deps deps + determine_generic_instance_deps_in_bodies [] n_deps deps + = (n_deps,deps) + + determine_generic_instance_deps_in_body {pb_args=[_:args]} n_deps deps + = mark_deps_in_args args 0 n_deps deps + determine_generic_instance_deps_in_body body n_deps deps + = (n_deps,deps) + +remove_generic_info_and_determine_generic_instance_deps :: ![ParsedBody] !Int !TypeCons !*CollectAdmin -> (![ParsedBody],!Int,!GenericInstanceDependencies,!*CollectAdmin) +remove_generic_info_and_determine_generic_instance_deps bodies arity type_cons ca + = case type_cons of + TypeConsSymb {type_ident={id_name}} + | id_name=="OBJECT" || id_name=="CONS" || id_name=="RECORD" || id_name=="FIELD" || id_name=="PAIR" || id_name=="EITHER" || id_name=="UNIT" + # (bodies,n_deps,deps) = remove_generic_info_and_determine_generic_instance_deps_in_bodies bodies -1 0 + | n_deps>=0 + # deps = deps bitand ((1< (bodies,arity-1,GenericInstanceUsedArgs n_deps deps,ca) + -> (bodies,arity-1,GenericInstanceUsedArgs 0 0,ca) + _ + -> (bodies,arity-1,AllGenericInstanceDependencies,ca) + where + remove_generic_info_and_determine_generic_instance_deps_in_bodies [body:bodies] n_deps deps + # (body,n_deps,deps) = remove_generic_info_and_determine_generic_instance_deps_in_body body n_deps deps + # (bodies,n_deps,deps) = remove_generic_info_and_determine_generic_instance_deps_in_bodies bodies n_deps deps + = ([body:bodies],n_deps,deps) + remove_generic_info_and_determine_generic_instance_deps_in_bodies [] n_deps deps + = ([],n_deps,deps) + + remove_generic_info_and_determine_generic_instance_deps_in_body body=:{pb_args=[_:args]} n_deps deps + # (n_deps,deps) = mark_deps_in_args args 0 n_deps deps + = ({body & pb_args=args},n_deps,deps) + remove_generic_info_and_determine_generic_instance_deps_in_body body n_deps deps + = (body,n_deps,deps) + +mark_deps_in_args :: [ParsedExpr] Int Int Int -> (!Int,!Int) +mark_deps_in_args [PE_WildCard:args] arg_n n_deps deps + = mark_deps_in_args args (arg_n+1) n_deps deps +mark_deps_in_args [_:args] arg_n n_deps deps + # deps = deps bitor (1<=0 + | arg_n StrictnessList strictness_from_fields fields @@ -1230,20 +1376,23 @@ where cons_count :: !Int, sel_count :: !Int, mem_count :: !Int, - type_count :: !Int + type_count :: !Int, + macro_count :: !Int } reorganiseDefinitions :: Bool [ParsedDefinition] !DefCounts *CollectAdmin -> (![FunDef],!CollectedDefinitions (ScannedInstanceAndMembersR FunDef), ![ParsedImport], ![ImportedObject],![ParsedForeignExport],!*CollectAdmin) -reorganiseDefinitions icl_module [PD_Function pos name is_infix args rhs fun_kind : defs] def_counts ca +reorganiseDefinitions icl_module [PD_Function pos name is_infix args rhs fun_kind : defs] def_counts=:{macro_count} ca # prio = if is_infix (Prio NoAssoc 9) NoPrio fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca - (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca fun = MakeNewImpOrDefFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies] fun_kind prio No pos | fun_kind == FK_Macro + # def_counts & macro_count=macro_count+1 + (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca = (fun_defs, { c_defs & def_macros = [ fun : c_defs.def_macros ]}, imports, imported_objects,foreign_exports, ca) + # (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca = ([ fun : fun_defs ], c_defs, imports, imported_objects,foreign_exports, ca) -reorganiseDefinitions icl_module [PD_TypeSpec fun_pos fun_name prio No specials : defs] def_counts ca +reorganiseDefinitions icl_module [PD_TypeSpec fun_pos fun_name prio No specials : defs] def_counts=:{macro_count} ca = case defs of [PD_Function pos name is_infix args rhs fun_kind : defs] | fun_name <> name @@ -1253,10 +1402,12 @@ reorganiseDefinitions icl_module [PD_TypeSpec fun_pos fun_name prio No specials // | belongsToTypeSpec fun_name prio name is_infix # fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca - (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca fun = MakeNewImpOrDefFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies ] fun_kind prio No fun_pos | fun_kind == FK_Macro + # def_counts & macro_count=macro_count+1 + (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca -> (fun_defs, { c_defs & def_macros = [ fun : c_defs.def_macros]}, imports, imported_objects,foreign_exports, ca) + # (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca -> ([ fun : fun_defs ], c_defs, imports, imported_objects,foreign_exports, ca) // -> reorganiseDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos "function body expected (1)" ca) _ @@ -1343,12 +1494,12 @@ reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = MoreConses type_ex type_def & td_rhs = UncheckedAlgConses type_ext_ident cons_symbs c_defs & def_types = [type_def : c_defs.def_types], def_constructors = mapAppend ParsedConstructorToConsDef cons_defs c_defs.def_constructors = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) -reorganiseDefinitions icl_module [PD_Class class_def=:{class_ident,class_arity,class_args} members : defs] def_counts=:{mem_count} ca +reorganiseDefinitions icl_module [PD_Class class_def=:{class_ident,class_arity,class_args} members : defs] def_counts=:{mem_count,macro_count} ca # type_context = { tc_class = TCClass {glob_module = NoIndex, glob_object = {ds_ident = class_ident, ds_arity = class_arity, ds_index = NoIndex }}, tc_types = [ TV tv \\ tv <- class_args ], tc_var = nilPtr} (mem_defs, mem_macros, ca) = check_symbols_of_class_members members type_context ca (mem_symbs, mem_defs, class_size) = reorganise_member_defs mem_defs mem_count - def_counts & mem_count=mem_count + class_size + def_counts & mem_count=mem_count + class_size, macro_count=macro_count + length mem_macros (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca class_def = { class_def & class_members = { member \\ member <- mem_symbs }} c_defs = { c_defs & def_classes = [class_def : c_defs.def_classes], def_macros = mem_macros ++ c_defs.def_macros, @@ -1450,19 +1601,40 @@ 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=:{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 - # 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_GenericCase gc=:{gc_type_cons} generic_fun_ident : defs] def_counts=:{macro_count} ca + # (GCF gc_ident gcf=:{gcf_body=GCB_ParsedBody args rhs,gcf_arity,gcf_generic_info}) = gc.gc_gcf + #! (bodies, generic_info, defs, ca) = collectGenericBodies defs gc_ident gcf_arity gc_type_cons ca + # generic_info = generic_info bitor gcf_generic_info + #! body = { pb_args = args, pb_rhs = rhs, pb_position = gc.gc_pos } + # bodies = [body : bodies] + # fun_name = genericIdentToFunIdent gc_ident.id_name /*gcf.gcf_ident.id_name*/ gc.gc_type_cons + | icl_module + # (bodies,gcf_arity,generic_instance_deps,ca) + = if (generic_info > 0) + (replace_generic_info_record_by_arguments generic_info bodies gcf_arity gc_type_cons ca) + (determine_generic_instance_deps bodies gcf_arity gc_type_cons ca) + #! (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) + = reorganiseDefinitions icl_module defs def_counts ca + #! 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, gcf_generic_info=generic_info, gcf_generic_instance_deps=generic_instance_deps + #! inst = {gc & gc_gcf = GCF gc_ident gcf} + #! c_defs & def_generic_cases = [inst : c_defs.def_generic_cases] + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) + + # (bodies,gcf_arity,generic_instance_deps,ca) + = if (generic_info > 0) + (replace_generic_info_record_by_arguments generic_info bodies gcf_arity gc_type_cons ca) + (if (generic_info < 0) + (determine_generic_instance_deps bodies gcf_arity gc_type_cons ca) + (remove_generic_info_and_determine_generic_instance_deps bodies gcf_arity gc_type_cons ca)) + # def_counts & macro_count=macro_count+1 + #! (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) + = reorganiseDefinitions icl_module defs def_counts ca + #! macro = MakeNewImpOrDefFunction generic_fun_ident gcf_arity bodies (FK_Function False) NoPrio No gc.gc_pos + # gcf & gcf_body=GCB_MacroIndex macro_count, gcf_arity=gcf_arity, gcf_generic_info=generic_info, gcf_generic_instance_deps=generic_instance_deps + #! inst = {gc & gc_gcf = GCF gc_ident gcf} + #! c_defs & def_generic_cases = [inst : c_defs.def_generic_cases], def_macros = [macro : c_defs.def_macros] + = (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) reorganiseDefinitions icl_module [PD_Derive derive_defs : defs] def_counts=:{type_count} ca # def_counts & type_count=type_count+1 #! (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca @@ -1520,7 +1692,7 @@ qualified_ident_to_import_declaration IC_Selector ident = abort "qualified_ident_to_import_declaration IC_Selector not yet implemented" reorganiseDefinitionsAndAddTypes mod_ident support_dynamics icl_module defs ca - # def_counts = {cons_count=0, sel_count=0, mem_count=0, type_count=0} + # def_counts = {cons_count=0, sel_count=0, mem_count=0, type_count=0, macro_count=0} | support_dynamics # clean_types_module_ident = predefined_idents.[PD_StdDynamic] diff --git a/frontend/scanner.dcl b/frontend/scanner.dcl index 3667d05..69a5936 100644 --- a/frontend/scanner.dcl +++ b/frontend/scanner.dcl @@ -110,6 +110,7 @@ instance <<< FilePosition | GenericOpenToken // {| | GenericCloseToken // |} | GenericOfToken // of + | GenericWithToken // with | ExistsToken // E. | ForAllToken // A. diff --git a/frontend/scanner.icl b/frontend/scanner.icl index 584ef28..0d33341 100644 --- a/frontend/scanner.icl +++ b/frontend/scanner.icl @@ -198,6 +198,7 @@ ScanOptionNoNewOffsideForSeqLetBit:==4; | GenericOpenToken // {| | GenericCloseToken // |} | GenericOfToken // of + | GenericWithToken // with | ExistsToken // E. | ForAllToken // A. @@ -895,7 +896,8 @@ CheckCodeContext s input CheckGenericContext :: !String !Input -> (!Token, !Input) CheckGenericContext s input = case s of - "of" -> (GenericOfToken , input) + "of" -> (GenericOfToken, input) + "with" -> (GenericWithToken, input) s -> CheckEveryContext s input GetPrio :: !Input -> (!Optional String, !Int, !Input) diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index c0d9c41..563003e 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -267,7 +267,7 @@ cIsNotAFunction :== False | PD_ImportedObjects [ImportedObject] | PD_ForeignExport !Ident !{#Char} !Int !Bool /* if stdcall */ | PD_Generic GenericDef - | PD_GenericCase GenericCaseDef + | PD_GenericCase GenericCaseDef Ident | PD_Derive [GenericCaseDef] | PD_Erroneous @@ -400,9 +400,19 @@ cNameLocationDependent :== True , gen_pos :: !Position , gen_type :: !SymbolType // Generic type (st_vars include generic type vars) , gen_vars :: ![TypeVar] // Generic type variables + , gen_deps :: ![GenericDependency] // Generic function dependencies , gen_info_ptr :: !GenericInfoPtr } +:: GenericDependency = + { gd_ident :: !IdentOrQualifiedIdent + , gd_index :: !GlobalIndex + , gd_vars :: ![TypeVar] + , gd_nums :: ![Int] // Mapping from dependency variable to generic type variable + } + +instance == GenericDependency + :: GenericClassInfo = { gci_kind :: !TypeKind // the kind , gci_module :: !Index // filled with main_module_index @@ -414,14 +424,18 @@ cNameLocationDependent :== True :: GenericInfo = { gen_classes :: !GenericClassInfos , gen_var_kinds :: ![TypeKind] // kinds of all st_vars of the gen_type - , gen_rep_conses :: !{#GenericRepresentationConstructor} - // OBJECT, CONS, RECORD, FIELD + , gen_rep_conses :: !{!GenericRepresentationConstructor} + // OBJECT, CONS, RECORD, FIELD, PAIR, EITHER, UNIT } :: GenericRepresentationConstructor = - { gcf_module :: !Int - , gcf_index :: !Int - , gcf_ident :: !Ident + { grc_module :: !Int + , grc_index :: !GenericCaseBody // GCB_FunIndex, GCB_FunAndMacroIndex or GCB_None + , grc_local_fun_index :: !Int + , grc_ident :: !Ident + , grc_generic_info :: !Int + , grc_generic_instance_deps :: !GenericInstanceDependencies + , grc_optional_fun_type :: !Optional SymbolType } :: GenericInfoPtr :== Ptr GenericInfo @@ -446,18 +460,27 @@ cNameLocationDependent :== True | GCFC !Ident !Ident // IC_GenericDeriveClass IC_Class :: GCF = { - gcf_gident :: !Ident, // name in IC_GenricCase namespace + gcf_gident :: !Ident, // name in IC_Generic namespace gcf_generic :: !GlobalIndex, // index of the generic gcf_arity :: !Int, // arity of the function + gcf_generic_info :: !Int, // 0 = no, -1 = all, generic info for CONS, OBJECT, RECORD or FIELD gcf_body :: !GenericCaseBody, // the body function or NoIndex - gcf_kind :: !TypeKind // kind of the instance type + gcf_kind :: !TypeKind, // kind of the instance type + gcf_generic_instance_deps :: !GenericInstanceDependencies } :: GenericCaseBody = GCB_None // to be generated - | GCB_FunIndex !Index - | GCB_FunDef !FunDef - | GCB_ParsedBody ![ParsedExpr] !Rhs + | GCB_FunIndex !Index + | GCB_FunAndMacroIndex !Index !Index + | GCB_MacroIndex !Index + | GCB_FunDef !FunDef + | GCB_ParsedBody ![ParsedExpr] !Rhs + +:: GenericInstanceDependencies + = AllGenericInstanceDependencies + | GenericInstanceDependencies !Int /*n_deps*/ !Int /*deps*/ + | GenericInstanceUsedArgs !Int /*n_deps*/ !Int /*deps*/ :: InstanceType = { it_vars :: [TypeVar] @@ -587,17 +610,19 @@ NoGlobalIndex :== {gi_module=NoIndex,gi_index=NoIndex} = GTSAppCons TypeKind [GenTypeStruct] | GTSAppVar TypeVar [GenTypeStruct] | GTSVar TypeVar - | GTSCons DefinedSymbol GenTypeStruct - | GTSRecord DefinedSymbol GenTypeStruct - | GTSField DefinedSymbol GenTypeStruct - | GTSObject DefinedSymbol GenTypeStruct - | GTSPair !GenTypeStruct !GenTypeStruct // for optimizing bimaps - | GTSEither !GenTypeStruct !GenTypeStruct // for optimizing bimaps - | GTSArrow GenTypeStruct GenTypeStruct // for optimizing bimaps - | GTSE - | GTSAppConsBimapKindConst // for optimizing bimaps - | GTSAppBimap TypeKind [GenTypeStruct] // for optimizing bimaps - | GTSAppConsSimpleType !GlobalIndex !TypeKind ![GenTypeStruct] // for optimizing bimaps + | GTSCons !DefinedSymbol !GlobalIndex !DefinedSymbol !DefinedSymbol !GenTypeStruct + | GTSRecord !DefinedSymbol !GlobalIndex !DefinedSymbol !DefinedSymbol !GenTypeStruct + | GTSField !DefinedSymbol !GlobalIndex !DefinedSymbol !GenTypeStruct + | GTSObject !DefinedSymbol !GlobalIndex !DefinedSymbol !GenTypeStruct + | GTSE + // the following constructors are used for optimizing bimaps + | GTSPair !GenTypeStruct !GenTypeStruct + | GTSEither !GenTypeStruct !GenTypeStruct + | GTSUnit + | GTSArrow GenTypeStruct GenTypeStruct + | GTSAppConsBimapKindConst + | GTSAppBimap TypeKind [GenTypeStruct] + | GTSAppConsSimpleType !GlobalIndex !TypeKind ![GenTypeStruct] :: GenericTypeRep = { gtr_type :: GenTypeStruct // generic structure type @@ -1098,9 +1123,11 @@ cNotVarNumber :== -1 | TVI_ConsInstance !DefinedSymbol //AA: generic cons instance function | TVI_Normalized !Int /* MV - position of type variable in its definition */ | TVI_Expr !Bool !Expression /* AA: Expression corresponding to the type var during generic specialization */ + | TVI_Exprs ![(GlobalIndex, Expression)] /* List of expressions corresponding to the type var during generic specialization */ | TVI_Iso !DefinedSymbol !DefinedSymbol !DefinedSymbol | TVI_GenTypeVarNumber !Int | TVI_CPSTypeVar !CheatCompiler /* MdM: a pointer to a variable in CleanProverSystem is stored here, using a cast */ + | TVI_Attr !TypeAttribute :: TypeVarInfoPtr :== Ptr TypeVarInfo :: TypeVarHeap :== Heap TypeVarInfo diff --git a/frontend/syntax.icl b/frontend/syntax.icl index d6f1d50..16ff61b 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -1,7 +1,7 @@ implementation module syntax import StdEnv, compare_constructor -import scanner, general, Heap, typeproperties, utilities +import scanner, general, Heap, typeproperties, utilities, compare_types import IndexType from containers import ::NumberSet from convertcases import :: LetVarInfo, :: LetExpressionInfo, :: RefCountsInCase, :: SplitsInCase @@ -9,6 +9,11 @@ from convertcases import :: LetVarInfo, :: LetExpressionInfo, :: RefCountsInCase instance toString Ident where toString {id_name} = id_name +instance == GenericDependency + where + (==) gen_dep1 gen_dep2 + = gen_dep1.gd_index == gen_dep2.gd_index && gen_dep1.gd_vars == gen_dep2.gd_vars + instance toString Import where toString {import_module} = toString import_module @@ -753,7 +758,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_gcf=GCF 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 @@ -938,6 +943,7 @@ where = file <<< "STE_DclFunction" (<<<) file STE_Generic = file <<< "STE_Generic" (<<<) file STE_GenericCase = file <<< "STE_GenericCase" + (<<<) file STE_GenericDeriveClass = file <<< "STE_GenericDeriveClass" (<<<) file (STE_Module _) = file <<< "STE_Module" diff --git a/frontend/transform.dcl b/frontend/transform.dcl index 4a5e120..7850fe1 100644 --- a/frontend/transform.dcl +++ b/frontend/transform.dcl @@ -11,7 +11,14 @@ partitionateIclMacros :: !IndexRange !Index !PredefSymbolsForTransform !*{#FunDe -> (!*{#FunDef},!*{#*{#FunDef}},!*VarHeap,!*ExpressionHeap,!*SymbolTable,!*ErrorAdmin ) partitionateAndLiftFunctions :: ![IndexRange] !Index !PredefSymbolsForTransform !*{#FunDef} !*{#*{#FunDef}} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin - -> (!*{!Group}, !*{#FunDef},!*{#*{#FunDef}},!*VarHeap,!*ExpressionHeap,!*SymbolTable,!*ErrorAdmin ) + -> (!*{!Group}, !*{#FunDef},!*{#*{#FunDef}},!*VarHeap,!*ExpressionHeap,!*SymbolTable,!*ErrorAdmin) + +:: UnexpandedDclMacros:==[(Int,Int,FunDef)] + +partitionateAndLiftMacro :: !Int !Int !Index !PredefinedSymbols !Int !*{#FunDef} !*{#*{#FunDef}} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin + -> (![[Int]],!UnexpandedDclMacros,!*{#FunDef},!*{#*{#FunDef}},!*VarHeap,!*ExpressionHeap,!*SymbolTable,!*ErrorAdmin) + +restore_unexpanded_dcl_macros :: !UnexpandedDclMacros !*{#*{#FunDef}} -> *{#*{#FunDef}} :: CopiedLocalFunctions @@ -32,3 +39,8 @@ determineVariablesAndRefCounts :: ![FreeVar] !Expression !*CollectState -> (!Exp class unfold a :: !a !*UnfoldState -> (!a, !*UnfoldState) instance unfold Expression, CasePatterns + +:: CopiedLocalFunction = { old_function_n :: !FunctionOrMacroIndex, new_function_n :: !Int } + +copy_macro_and_local_functions :: !FunDef !Int !*{#FunDef} !*{#*{#FunDef}} !*VarHeap !*ExpressionHeap + -> (!FunDef,![(CopiedLocalFunction,FunDef)],!Int,!*{#FunDef},!*{#*{#FunDef}},!*VarHeap,!*ExpressionHeap) diff --git a/frontend/transform.icl b/frontend/transform.icl index 5dc725e..36b7bb5 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -354,10 +354,7 @@ readVarInfo var_info_ptr us VI_Extended _ original -> (original, us) _ -> (var_info, us) -:: CopiedLocalFunction = { - old_function_n :: !FunctionOrMacroIndex, - new_function_n :: !Int - } +:: CopiedLocalFunction = { old_function_n :: !FunctionOrMacroIndex, new_function_n :: !Int } :: CopiedLocalFunctions = { copied_local_functions :: [CopiedLocalFunction], @@ -704,14 +701,19 @@ examineFunctionCall {id_info} fc=:(MacroCall macro_module_index fc_index _) (cal es_new_fun_def_numbers :: ![Int] } -copy_macro_and_local_functions :: FunDef (Optional CopiedLocalFunctions) *ExpandState -> (!FunDef,![(CopiedLocalFunction,FunDef)],!Optional CopiedLocalFunctions,!*ExpandState); -copy_macro_and_local_functions macro=:{fun_kind} local_macro_functions es - # (macro,local_macro_functions,es) = copy_macro_or_local_macro_function macro local_macro_functions es - # (new_functions,local_macro_functions,es) = copy_local_functions_of_macro local_macro_functions [] es - = (macro,new_functions,local_macro_functions,es) - -copy_local_functions_of_macro :: (Optional CopiedLocalFunctions) [CopiedLocalFunction] *ExpandState -> (![(CopiedLocalFunction,FunDef)],!Optional CopiedLocalFunctions,!*ExpandState); -copy_local_functions_of_macro local_macro_functions local_functions_to_be_copied es +copy_macro_and_local_functions :: !FunDef !Int !*{#FunDef} !*{#*{#FunDef}} !*VarHeap !*ExpressionHeap + -> (!FunDef,![(CopiedLocalFunction,FunDef)],!Int,!*{#FunDef},!*{#*{#FunDef}},!*VarHeap,!*ExpressionHeap) +copy_macro_and_local_functions macro new_function_index fun_defs macro_defs var_heap expr_heap + # local_macro_functions = Yes {copied_local_functions=[],used_copied_local_functions=[],new_copied_local_functions=[],next_local_function_n=new_function_index+1} + (macro,local_macro_functions,var_heap,expr_heap) + = copy_macro_or_local_macro_function macro local_macro_functions var_heap expr_heap + (new_functions,Yes {next_local_function_n},fun_defs,macro_defs,var_heap,expr_heap) + = copy_local_functions_of_macro local_macro_functions [] fun_defs macro_defs var_heap expr_heap + = (macro,new_functions,next_local_function_n,fun_defs,macro_defs,var_heap,expr_heap) + +copy_local_functions_of_macro :: (Optional CopiedLocalFunctions) [CopiedLocalFunction] !*{#FunDef} !*{#*{#FunDef}} !*VarHeap !*ExpressionHeap + -> (![(CopiedLocalFunction,FunDef)],!Optional CopiedLocalFunctions,!*{#FunDef},!*{#*{#FunDef}},!*VarHeap,!*ExpressionHeap) +copy_local_functions_of_macro local_macro_functions local_functions_to_be_copied fun_defs macro_defs var_heap expr_heap # (local_functions_to_be_copied,local_macro_functions) = add_new_local_functions_to_be_copied local_functions_to_be_copied local_macro_functions with add_new_local_functions_to_be_copied local_functions_to_be_copied local_macro_functions=:(Yes copied_local_macro_functions=:{new_copied_local_functions=[]}) @@ -722,25 +724,26 @@ copy_local_functions_of_macro local_macro_functions local_functions_to_be_copied = (local_functions_to_be_copied++new_copied_local_functions,local_macro_functions) = case local_functions_to_be_copied of [] - -> ([],local_macro_functions,es) + -> ([],local_macro_functions,fun_defs,macro_defs,var_heap,expr_heap) [(old_and_new_function_n=:{old_function_n,new_function_n}):local_functions_to_be_copied] - # (function,es) + # (function,fun_defs,macro_defs) = case old_function_n of FunctionOrIclMacroIndex old_function_index - # (function,es)=es!es_fun_defs.[old_function_index] + # (function,fun_defs)=fun_defs![old_function_index] #! function_group_index=function.fun_info.fi_group_index - # es = {es & es_fun_defs.[old_function_index].fun_info.fi_group_index= if (function_group_index>NoIndex) (-2-function_group_index) function_group_index} + # fun_defs & [old_function_index].fun_info.fi_group_index= if (function_group_index>NoIndex) (-2-function_group_index) function_group_index # function = {function & fun_info.fi_group_index=if (function_group_index (function,es) + -> (function,fun_defs,macro_defs) DclMacroIndex old_function_module_index old_function_index - # (function,es)=es!es_macro_defs.[old_function_module_index,old_function_index] + # (function,macro_defs)=macro_defs![old_function_module_index,old_function_index] #! function_group_index=function.fun_info.fi_group_index - # es = {es & es_macro_defs.[old_function_module_index].[old_function_index].fun_info.fi_group_index= if (function_group_index>NoIndex) (-2-function_group_index) function_group_index} + # macro_defs & [old_function_module_index].[old_function_index].fun_info.fi_group_index= if (function_group_index>NoIndex) (-2-function_group_index) function_group_index # function = {function & fun_info.fi_group_index=if (function_group_index (function,es) - # (function,local_macro_functions,es) = copy_macro_or_local_macro_function function local_macro_functions es - # (new_functions,local_macro_functions,es) = copy_local_functions_of_macro local_macro_functions local_functions_to_be_copied es - -> ([(old_and_new_function_n,function):new_functions],local_macro_functions,es) + -> (function,fun_defs,macro_defs) + # (function,local_macro_functions,var_heap,expr_heap) = copy_macro_or_local_macro_function function local_macro_functions var_heap expr_heap + # (new_functions,local_macro_functions,fun_defs,macro_defs,var_heap,expr_heap) + = copy_local_functions_of_macro local_macro_functions local_functions_to_be_copied fun_defs macro_defs var_heap expr_heap + -> ([(old_and_new_function_n,function):new_functions],local_macro_functions,fun_defs,macro_defs,var_heap,expr_heap) update_calls calls No = calls @@ -785,9 +788,9 @@ where add_new_calls [] calls = calls -copy_macro_or_local_macro_function :: !FunDef !(Optional CopiedLocalFunctions) !*ExpandState -> (!FunDef,!Optional CopiedLocalFunctions,!.ExpandState); -copy_macro_or_local_macro_function macro=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_kind,fun_info={fi_local_vars,fi_calls}} local_macro_functions es=:{es_var_heap,es_expression_heap} - # (tb_args,es_var_heap) = create_new_arguments tb_args es_var_heap +copy_macro_or_local_macro_function :: !FunDef !(Optional CopiedLocalFunctions) !*VarHeap !*ExpressionHeap -> (!FunDef,!Optional CopiedLocalFunctions,!*VarHeap,!*ExpressionHeap); +copy_macro_or_local_macro_function macro=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_kind,fun_info={fi_local_vars,fi_calls}} local_macro_functions var_heap expr_heap + # (tb_args,var_heap) = create_new_arguments tb_args var_heap with create_new_arguments [var=:{fv_ident,fv_info_ptr} : vars] var_heap # (new_vars,var_heap) = create_new_arguments vars var_heap @@ -796,7 +799,7 @@ copy_macro_or_local_macro_function macro=:{fun_body = TransformedBody {tb_args,t = ([new_var : new_vars], writePtr fv_info_ptr (VI_Variable fv_ident new_info) var_heap) create_new_arguments [] var_heap = ([],var_heap) - # us = { us_symbol_heap = es_expression_heap, us_var_heap = es_var_heap, us_local_macro_functions = local_macro_functions } + # us = { us_symbol_heap = expr_heap, us_var_heap = var_heap, us_local_macro_functions = local_macro_functions } # (result_expr,{us_local_macro_functions,us_symbol_heap,us_var_heap}) = unfold tb_rhs us # (fi_local_vars,us_var_heap) = update_local_vars fi_local_vars us_var_heap with @@ -812,7 +815,7 @@ copy_macro_or_local_macro_function macro=:{fun_body = TransformedBody {tb_args,t = ([],var_heap) # fi_calls = update_calls fi_calls us_local_macro_functions = ({macro & fun_body = TransformedBody {tb_args=tb_args,tb_rhs=result_expr},fun_info.fi_local_vars=fi_local_vars,fun_info.fi_calls=fi_calls},us_local_macro_functions, - {es & es_var_heap=us_var_heap, es_expression_heap=us_symbol_heap}) + us_var_heap, us_symbol_heap) unfoldMacro :: !FunDef ![Expression] !*ExpandInfo -> (!Expression, !*ExpandInfo) unfoldMacro {fun_body =fun_body=: TransformedBody {tb_args,tb_rhs}, fun_info = {fi_calls},fun_kind,fun_ident} args (calls, es=:{es_var_heap,es_expression_heap,es_fun_defs}) @@ -823,8 +826,9 @@ unfoldMacro {fun_body =fun_body=: TransformedBody {tb_args,tb_rhs}, fun_info = { # (result_expr,{us_local_macro_functions,us_symbol_heap,us_var_heap}) = unfold tb_rhs us # es = {es & es_var_heap = us_var_heap, es_expression_heap = us_symbol_heap} # fi_calls = update_calls fi_calls us_local_macro_functions - # (new_functions,us_local_macro_functions,es) = copy_local_functions_of_macro us_local_macro_functions [] es - # {es_expression_heap,es_symbol_table,es_fun_defs,es_new_fun_def_numbers} = es + # {es_fun_defs,es_macro_defs,es_var_heap,es_expression_heap,es_symbol_table,es_new_fun_def_numbers} = es + (new_functions,us_local_macro_functions,es_fun_defs,es_macro_defs,es_var_heap,es_expression_heap) + = copy_local_functions_of_macro us_local_macro_functions [] es_fun_defs es_macro_defs es_var_heap es_expression_heap # (es_fun_defs,es_new_fun_def_numbers) = case new_functions of [] -> (es_fun_defs,es_new_fun_def_numbers) @@ -841,10 +845,12 @@ unfoldMacro {fun_body =fun_body=: TransformedBody {tb_args,tb_rhs}, fun_info = { -> (new_fun_defs, [size_fun_defs:es_new_fun_def_numbers]) # (calls, fun_defs, es_symbol_table) = updateFunctionCalls fi_calls calls es_fun_defs es_symbol_table | isEmpty let_binds - = (result_expr, (calls, { es & es_symbol_table = es_symbol_table, es_fun_defs=fun_defs,es_new_fun_def_numbers=es_new_fun_def_numbers })) + # es & es_macro_defs=es_macro_defs, es_var_heap=es_var_heap, es_symbol_table = es_symbol_table, es_expression_heap=es_expression_heap, es_fun_defs=fun_defs, es_new_fun_def_numbers=es_new_fun_def_numbers + = (result_expr, (calls, es)) # (new_info_ptr, es_expression_heap) = newPtr EI_Empty es_expression_heap + # es & es_macro_defs=es_macro_defs, es_var_heap=es_var_heap, es_symbol_table = es_symbol_table, es_expression_heap=es_expression_heap, es_fun_defs=fun_defs, es_new_fun_def_numbers=es_new_fun_def_numbers # result_expr=Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = result_expr, let_info_ptr = new_info_ptr, let_expr_position = NoPos } - = (result_expr, (calls, { es & es_symbol_table = es_symbol_table, es_expression_heap=es_expression_heap, es_fun_defs=fun_defs,es_new_fun_def_numbers=es_new_fun_def_numbers })) + = (result_expr, (calls, es)) where bind_expressions [var : vars] [expr : exprs] binds var_heap # (binds, var_heap) = bind_expressions vars exprs binds var_heap @@ -865,6 +871,8 @@ where new_var = { fv_ident = fv_ident, fv_def_level = NotALevel, fv_info_ptr = new_info, fv_count = 0 } = ([{ lb_src = expr, lb_dst = new_var, lb_position = NoPos} : binds], writePtr fv_info_ptr (VI_Variable fv_ident new_info) var_heap) +:: UnexpandedDclMacros:==[(Int,Int,FunDef)] + :: PartitioningState = { ps_symbol_table :: !.SymbolTable , ps_var_heap :: !.VarHeap @@ -876,12 +884,13 @@ where , ps_next_group :: !Int , ps_groups :: ![[FunctionOrMacroIndex]] , ps_deps :: ![FunctionOrMacroIndex] - , ps_unexpanded_dcl_macros :: ![(Int,Int,FunDef)] + , ps_unexpanded_dcl_macros :: !UnexpandedDclMacros } :: PartitioningInfo = ! { pi_predef_symbols_for_transform :: !PredefSymbolsForTransform, - pi_main_dcl_module_n :: !Int + pi_main_dcl_module_n :: !Int, + pi_reset_body_of_rhs_macros :: !Bool } NotChecked :== -1 @@ -914,7 +923,7 @@ expand_simple_macro mod_index macro=:{fun_body = CheckedBody body, fun_info, fun es_fun_defs=ps_fun_defs, es_macro_defs=ps_macro_defs, es_new_fun_def_numbers=[] } # (tb_args, tb_rhs, local_vars, fi_calls, fi_dynamics,{es_symbol_table, es_var_heap, es_expression_heap, es_error,es_fun_defs,es_macro_defs}) - = expandMacrosInBody [] body fun_info.fi_dynamics predef_symbols_for_transform es + = expandMacrosInBody [] body fun_info.fi_dynamics predef_symbols_for_transform False es # macro = { macro & fun_body = TransformedBody { tb_args = tb_args, tb_rhs = tb_rhs}, fun_info = { fun_info & fi_calls = fi_calls, fi_local_vars = local_vars, fi_dynamics=fi_dynamics }} = ( macro, { ps & ps_symbol_table = es_symbol_table, ps_symbol_heap = es_expression_heap, ps_var_heap = es_var_heap, ps_fun_defs = es_fun_defs,ps_macro_defs=es_macro_defs,ps_error = es_error }) @@ -924,7 +933,7 @@ expand_dcl_macro_if_simple mod_index macro_index macro=:{fun_body = CheckedBody | macros_are_simple fun_info.fi_calls mod_index ps_fun_defs ps_macro_defs && has_no_curried_macro body.cb_rhs ps_fun_defs ps_macro_defs # (macro,ps) = expand_simple_macro mod_index macro predef_symbols_for_transform ps = { ps & ps_macro_defs.[mod_index,macro_index] = macro } - = { ps & ps_deps = [DclMacroIndex mod_index macro_index:ps.ps_deps], ps_macro_defs.[mod_index,macro_index] = { macro & fun_body = RhsMacroBody body }} + = { ps & ps_deps = [DclMacroIndex mod_index macro_index:ps.ps_deps], ps_macro_defs.[mod_index,macro_index] = { macro & fun_body = RhsMacroBody body }} expand_icl_macro_if_simple mod_index macro_index macro=:{fun_body = CheckedBody body, fun_info} predef_symbols_for_transform ps=:{ps_symbol_table,ps_symbol_heap,ps_var_heap,ps_fun_defs,ps_macro_defs,ps_error} @@ -1176,17 +1185,36 @@ partitionateAndLiftFunctions ranges main_dcl_module_n predef_symbols_for_transfo = foldSt (partitionate_functions main_dcl_module_n max_fun_nr) ranges partitioning_info # (reversed_ps_groups,fun_defs) = remove_macros_from_groups_and_reverse ps_groups ps_fun_defs [] # groups = { {group_members = group} \\ group <- reversed_ps_groups } - # ps_macro_defs = restore_unexpanded_dcl_macros ps_unexpanded_dcl_macros ps_macro_defs - = (groups, fun_defs, ps_macro_defs, ps_var_heap, ps_symbol_heap, ps_symbol_table, ps_error) + # macro_defs = restore_unexpanded_dcl_macros ps_unexpanded_dcl_macros ps_macro_defs + = (groups, fun_defs, macro_defs, ps_var_heap, ps_symbol_heap, ps_symbol_table, ps_error) where partitionate_functions mod_index max_fun_nr {ir_from,ir_to} ps = iFoldSt (partitionate_global_function mod_index max_fun_nr) ir_from ir_to ps partitionate_global_function mod_index max_fun_nr fun_index ps - # pi = {pi_predef_symbols_for_transform=predef_symbols_for_transform,pi_main_dcl_module_n=main_dcl_module_n} + # pi = {pi_predef_symbols_for_transform=predef_symbols_for_transform,pi_main_dcl_module_n=main_dcl_module_n,pi_reset_body_of_rhs_macros=False} # (_,ps) = partitionate_function mod_index max_fun_nr fun_index pi ps = ps +get_predef_symbols_for_transform :: !PredefinedSymbols -> PredefSymbolsForTransform +get_predef_symbols_for_transform predef_symbols + = ({predef_alias_dummy=predef_symbols.[PD_DummyForStrictAliasFun],predef_and=predef_symbols.[PD_AndOp],predef_or=predef_symbols.[PD_OrOp]}) + +partitionateAndLiftMacro :: !Int !Int !Index !PredefinedSymbols !Int !*{#FunDef} !*{#*{#FunDef}} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin + -> (![[Int]],!UnexpandedDclMacros,!*{#FunDef},!*{#*{#FunDef}},!*VarHeap,!*ExpressionHeap,!*SymbolTable,!*ErrorAdmin) +partitionateAndLiftMacro macro_module_index macro_index main_dcl_module_n predef_symbols next_group_n fun_defs macro_defs var_heap symbol_heap symbol_table error + # predef_symbols_for_transform = get_predef_symbols_for_transform predef_symbols + #! max_fun_nr = cMAXINT + # partitioning_state = {ps_var_heap = var_heap, ps_symbol_heap = symbol_heap, ps_symbol_table = symbol_table, ps_fun_defs=fun_defs, ps_macro_defs=macro_defs, + ps_error = error, ps_deps = [], ps_next_num = 0, ps_next_group = next_group_n, ps_groups = [], + ps_unexpanded_dcl_macros=[] } + pi = {pi_predef_symbols_for_transform=predef_symbols_for_transform,pi_main_dcl_module_n=main_dcl_module_n,pi_reset_body_of_rhs_macros=True} + (_, {ps_groups, ps_symbol_table, ps_var_heap, ps_symbol_heap, ps_fun_defs, ps_macro_defs, ps_error,ps_unexpanded_dcl_macros}) + = partitionate_macro main_dcl_module_n max_fun_nr macro_module_index macro_index pi partitioning_state + # (reversed_ps_groups,fun_defs) = remove_macros_from_groups_and_reverse ps_groups ps_fun_defs [] + = (reversed_ps_groups, ps_unexpanded_dcl_macros, fun_defs, ps_macro_defs, ps_var_heap, ps_symbol_heap, ps_symbol_table, ps_error) + +restore_unexpanded_dcl_macros :: !UnexpandedDclMacros !*{#*{#FunDef}} -> *{#*{#FunDef}} restore_unexpanded_dcl_macros [(macro_module_index,macro_index,macro_def):unexpanded_dcl_macros] macro_defs # macro_defs & [macro_module_index,macro_index] = macro_def = restore_unexpanded_dcl_macros unexpanded_dcl_macros macro_defs @@ -1320,7 +1348,7 @@ where identPos = newPosition fun_ident fun_pos # es={ es & es_error = setErrorAdmin identPos es.es_error } # (tb_args, tb_rhs, fi_local_vars, fi_calls,fi_dynamics, es) - = expandMacrosInBody fun_info.fi_calls body fun_info.fi_dynamics pi.pi_predef_symbols_for_transform es + = expandMacrosInBody fun_info.fi_calls body fun_info.fi_dynamics pi.pi_predef_symbols_for_transform pi.pi_reset_body_of_rhs_macros es fun_def = { fun_def & fun_body = TransformedBody { tb_args = tb_args, tb_rhs = tb_rhs}, fun_info = { fun_info & fi_calls = fi_calls, fi_local_vars = fi_local_vars,fi_dynamics=fi_dynamics }} = {es & es_fun_defs.[fun_index] = fun_def } @@ -1330,7 +1358,7 @@ where identPos = newPosition fun_ident fun_pos # es={ es & es_error = setErrorAdmin identPos es.es_error } # (tb_args, tb_rhs, fi_local_vars, fi_calls,fi_dynamics, es) - = expandMacrosInBody fun_info.fi_calls body fun_info.fi_dynamics pi.pi_predef_symbols_for_transform es + = expandMacrosInBody fun_info.fi_calls body fun_info.fi_dynamics pi.pi_predef_symbols_for_transform pi.pi_reset_body_of_rhs_macros es fun_def = { old_fun_def & fun_body = TransformedBody { tb_args = tb_args, tb_rhs = tb_rhs}, fun_info = { fun_info & fi_calls = fi_calls, fi_local_vars = fi_local_vars,fi_dynamics=fi_dynamics }} = {es & es_macro_defs.[macro_module_index,fun_index] = fun_def } @@ -1402,16 +1430,22 @@ where _ -> (fun_defs, symbol_table) -expandMacrosInBody :: [.FunCall] CheckedBody ![ExprInfoPtr] PredefSymbolsForTransform *ExpandState -> ([FreeVar],Expression,[FreeVar],[FunCall],![ExprInfoPtr],.ExpandState); -expandMacrosInBody fi_calls {cb_args,cb_rhs} fi_dynamics predef_symbols_for_transform es=:{es_symbol_table,es_expression_heap,es_fun_defs,es_macro_defs} +expandMacrosInBody :: ![.FunCall] !CheckedBody ![ExprInfoPtr] !PredefSymbolsForTransform !Bool !*ExpandState + -> (![FreeVar],!Expression,![FreeVar],![FunCall],![ExprInfoPtr],!*ExpandState) +expandMacrosInBody fi_calls {cb_args,cb_rhs} fi_dynamics predef_symbols_for_transform reset_body_of_rhs_macros + es=:{es_symbol_table,es_expression_heap,es_fun_defs,es_macro_defs} # (prev_calls, fun_defs, macro_defs,es_symbol_table) = addFunctionCallsToSymbolTable fi_calls es_fun_defs es_macro_defs es_symbol_table ([rhs:rhss], (all_calls, es) ) = mapSt expandCheckedAlternative cb_rhs (prev_calls, { es & es_fun_defs=fun_defs, es_macro_defs=macro_defs,es_symbol_table = es_symbol_table, es_expression_heap=es_expression_heap }) (fun_defs, symbol_table) = removeFunctionCallsFromSymbolTable all_calls es.es_fun_defs es.es_symbol_table + var_heap = es.es_var_heap + var_heap = if reset_body_of_rhs_macros + (reset_free_var_heap_pointers cb_rhs (reset_free_var_heap_pointers cb_args var_heap)) + var_heap ((merged_rhs, _), es_var_heap, es_expression_heap, es_error) - = mergeCases rhs rhss es.es_var_heap es.es_expression_heap es.es_error + = mergeCases rhs rhss var_heap es.es_expression_heap es.es_error (new_rhs, new_args, local_vars, fi_dynamics, {cos_error, cos_var_heap, cos_expression_heap}) = determineVariablesAndRefCounts cb_args merged_rhs { cos_error = es_error, cos_var_heap = es_var_heap, cos_expression_heap = es_expression_heap, @@ -1447,11 +1481,12 @@ where # macro = {macro & fun_info.fi_group_index=if (macro_group_index next_local_function_n-1 # es = add_new_fun_defs [({old_function_n=DclMacroIndex glob_module glob_object,new_function_n=new_function_index},macro):new_functions] new_function_index last_function_index es # (calls, es_symbol_table) = examineFunctionCall macro.fun_ident (FunCall new_function_index NotALevel) (calls, es.es_symbol_table) # app = App { app & app_symb = { symb & symb_kind = SK_LocalMacroFunction new_function_index }, app_args = app_args } @@ -1482,11 +1517,12 @@ where # macro = {macro & fun_info.fi_group_index=if (macro_group_index next_local_function_n-1 # es = add_new_fun_defs [({old_function_n=FunctionOrIclMacroIndex glob_object,new_function_n=new_function_index},macro):new_functions] new_function_index last_function_index es # (calls, es_symbol_table) = examineFunctionCall macro.fun_ident (FunCall new_function_index NotALevel) (calls, es.es_symbol_table) # app = App { app & app_symb = { symb & symb_kind = SK_LocalMacroFunction new_function_index }, app_args = app_args } @@ -1779,7 +1815,7 @@ where # ((expr, exprs), free_vars, dynamics, cos) = collectVariables (expr, exprs) free_vars dynamics cos = (expr @ exprs, free_vars, dynamics, cos) collectVariables (Let lad=:{let_strict_binds, let_lazy_binds, let_expr, let_info_ptr}) free_vars dynamics cos=:{cos_var_heap} - # (let_info,cos_expression_heap) = readPtr let_info_ptr cos.cos_expression_heap + # (let_info,cos_expression_heap) = readPtr let_info_ptr cos.cos_expression_heap let_types = case let_info of EI_LetType let_types -> let_types _ -> repeat undef @@ -2294,3 +2330,103 @@ instance <<< VarInfo where (<<<) file (VI_Expression expr) = file <<< expr (<<<) file vi = file <<< "VI??" + +class reset_free_var_heap_pointers a :: !a !*VarHeap -> *VarHeap + +instance reset_free_var_heap_pointers Expression +where + reset_free_var_heap_pointers (App {app_args}) var_heap + = reset_free_var_heap_pointers app_args var_heap + reset_free_var_heap_pointers (expr @ exprs) var_heap + = reset_free_var_heap_pointers expr (reset_free_var_heap_pointers exprs var_heap) + reset_free_var_heap_pointers (Let {let_strict_binds,let_lazy_binds,let_expr}) var_heap + = reset_free_var_heap_pointers let_expr (reset_bound_vars let_lazy_binds (reset_bound_vars let_strict_binds var_heap)) + reset_free_var_heap_pointers (Case {case_expr,case_guards,case_default}) var_heap + = reset_free_var_heap_pointers case_default (reset_free_var_heap_pointers case_guards (reset_free_var_heap_pointers case_expr var_heap)) + reset_free_var_heap_pointers (Selection selector_kind expr selectors) var_heap + = reset_free_var_heap_pointers expr (reset_free_var_heap_pointers selectors var_heap) + reset_free_var_heap_pointers (Update expr1 selectors expr2) var_heap + = reset_free_var_heap_pointers expr1 (reset_free_var_heap_pointers expr2 (reset_free_var_heap_pointers selectors var_heap)) + reset_free_var_heap_pointers (RecordUpdate cons_symbol expression bind_expressions) var_heap + = reset_free_var_heap_pointers expression (reset_var_heap_pointers_of_bind_srcs bind_expressions var_heap) + reset_free_var_heap_pointers (TupleSelect symbol argn_nr expr) var_heap + = reset_free_var_heap_pointers expr var_heap + reset_free_var_heap_pointers (MatchExpr cons_ident expr) var_heap + = reset_free_var_heap_pointers expr var_heap + reset_free_var_heap_pointers (DynamicExpr {dyn_expr}) var_heap + = reset_free_var_heap_pointers dyn_expr var_heap + reset_free_var_heap_pointers (TypeSignature type_function expr) var_heap + = reset_free_var_heap_pointers expr var_heap + reset_free_var_heap_pointers expr var_heap + = var_heap + +instance reset_free_var_heap_pointers Selection +where + reset_free_var_heap_pointers (ArraySelection array_select expr_ptr index_expr) var_heap + = reset_free_var_heap_pointers index_expr var_heap + reset_free_var_heap_pointers (DictionarySelection var selectors expr_ptr index_expr) var_heap + = reset_free_var_heap_pointers index_expr (reset_free_var_heap_pointers selectors var_heap) + reset_free_var_heap_pointers record_selection var_heap + = var_heap + +instance reset_free_var_heap_pointers FreeVar +where + reset_free_var_heap_pointers {fv_info_ptr} var_heap + = writePtr fv_info_ptr VI_Empty var_heap + +reset_var_heap_pointers_of_bind_srcs [{bind_src}:binds] var_heap + = reset_var_heap_pointers_of_bind_srcs binds (reset_free_var_heap_pointers bind_src var_heap) +reset_var_heap_pointers_of_bind_srcs [] var_heap + = var_heap + +reset_bound_vars [{lb_dst={fv_info_ptr},lb_src} : binds] var_heap + = reset_bound_vars binds (reset_free_var_heap_pointers lb_src (writePtr fv_info_ptr VI_Empty var_heap)) +reset_bound_vars [] var_heap + = var_heap + +instance reset_free_var_heap_pointers CasePatterns +where + reset_free_var_heap_pointers (AlgebraicPatterns type patterns) var_heap + = reset_free_var_heap_pointers patterns var_heap + reset_free_var_heap_pointers (BasicPatterns type patterns) var_heap + = reset_free_var_heap_pointers patterns var_heap + reset_free_var_heap_pointers (OverloadedListPatterns type decons_expr patterns) var_heap + = reset_free_var_heap_pointers patterns (reset_free_var_heap_pointers decons_expr var_heap) + reset_free_var_heap_pointers (NewTypePatterns type patterns) var_heap + = reset_free_var_heap_pointers patterns var_heap + reset_free_var_heap_pointers (DynamicPatterns patterns) var_heap + = reset_free_var_heap_pointers patterns var_heap + +instance reset_free_var_heap_pointers AlgebraicPattern +where + reset_free_var_heap_pointers {ap_vars,ap_expr} var_heap + = reset_free_var_heap_pointers ap_expr (reset_free_var_heap_pointers ap_vars var_heap) + +instance reset_free_var_heap_pointers BasicPattern +where + reset_free_var_heap_pointers {bp_expr} var_heap + = reset_free_var_heap_pointers bp_expr var_heap + +instance reset_free_var_heap_pointers DynamicPattern +where + reset_free_var_heap_pointers {dp_var,dp_rhs} var_heap + = reset_free_var_heap_pointers dp_rhs (reset_free_var_heap_pointers dp_var var_heap) + +instance reset_free_var_heap_pointers [a] | reset_free_var_heap_pointers a +where + reset_free_var_heap_pointers [x : xs] s + = reset_free_var_heap_pointers xs (reset_free_var_heap_pointers x s) + reset_free_var_heap_pointers [] s + = s + +instance reset_free_var_heap_pointers (Optional a) | reset_free_var_heap_pointers a +where + reset_free_var_heap_pointers (Yes x) var_heap + = reset_free_var_heap_pointers x var_heap + reset_free_var_heap_pointers no var_heap + = var_heap + +instance reset_free_var_heap_pointers CheckedAlternative +where + reset_free_var_heap_pointers {ca_rhs} var_heap + = reset_free_var_heap_pointers ca_rhs var_heap -- cgit v1.2.3