diff options
| -rw-r--r-- | frontend/check.icl | 74 | ||||
| -rw-r--r-- | frontend/checkgenerics.icl | 95 | ||||
| -rw-r--r-- | frontend/comparedefimp.icl | 77 | ||||
| -rw-r--r-- | frontend/explicitimports.icl | 8 | ||||
| -rw-r--r-- | frontend/frontend.icl | 42 | ||||
| -rw-r--r-- | frontend/generics1.dcl | 5 | ||||
| -rw-r--r-- | frontend/generics1.icl | 2104 | ||||
| -rw-r--r-- | frontend/genericsupport.dcl | 14 | ||||
| -rw-r--r-- | frontend/genericsupport.icl | 65 | ||||
| -rw-r--r-- | frontend/overloading.icl | 25 | ||||
| -rw-r--r-- | frontend/parse.icl | 338 | ||||
| -rw-r--r-- | frontend/postparse.icl | 252 | ||||
| -rw-r--r-- | frontend/scanner.dcl | 1 | ||||
| -rw-r--r-- | frontend/scanner.icl | 4 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 71 | ||||
| -rw-r--r-- | frontend/syntax.icl | 10 | ||||
| -rw-r--r-- | frontend/transform.dcl | 14 | ||||
| -rw-r--r-- | frontend/transform.icl | 242 |
18 files changed, 2601 insertions, 840 deletions
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<<dcl_n_deps)-1) + | icl_deps==dcl_deps + # generic_instance_deps = GenericInstanceDependencies dcl_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_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<<n_generic_function_arguments)-1) + -> (GenericInstanceDependencies n_generic_function_arguments deps,gs_error) + # deps = deps bitor ((-1)<<n_deps) + # deps = deps bitand ((1<<n_generic_function_arguments)-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<<n_generic_function_arguments)-1) + -> (GenericInstanceDependencies n_generic_function_arguments deps,gs_error) + # deps = deps bitor ((-1)<<n_deps) + # deps = deps bitand ((1<<n_generic_function_arguments)-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 "<no generic class>", 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 "<no generic class>", 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<<arg_n)<>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<<dep_n)<>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<<n_deps)-1 + | deps bitand m<>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<function_n2) functions_with_numbers + # funs = add_functions sorted_functions_with_numbers fun_index funs + = (funs,groups,group_index) +where + less_than_group_number (_,{fun_info={fi_group_index=group_n1}}) (_,{fun_info={fi_group_index=group_n2}}) + = group_n1 < group_n2 + + add_functions [(function_n,fun_def):sorted_functions_with_numbers] fun_index funs + | function_n==fun_index + = add_functions sorted_functions_with_numbers (fun_index+1) [fun_def:funs] + add_functions [] fun_index funs + = funs + + add_groups [] groups group_index functions_with_numbers + = (groups,group_index,functions_with_numbers) + add_groups [({new_function_n},function=:{fun_info={fi_group_index}}):local_functions_sorted_by_group] groups group_index functions_with_numbers + # functions_with_numbers = [(new_function_n,{function & fun_info.fi_group_index=group_index}):functions_with_numbers] + # (group,local_functions_sorted_by_group,functions_with_numbers) + = add_functions_to_group local_functions_sorted_by_group [new_function_n] fi_group_index functions_with_numbers + # groups = [{group_members = group}:groups] + # group_index = group_index+1 + = add_groups local_functions_sorted_by_group groups group_index functions_with_numbers + + add_functions_to_group local_functions_sorted_by_group=:[({new_function_n},function=:{fun_info={fi_group_index}}):remaining_funs] group group_n functions_with_numbers + | fi_group_index==group_n + # functions_with_numbers = [(new_function_n,{function & fun_info.fi_group_index=group_index}):functions_with_numbers] + = add_functions_to_group remaining_funs [new_function_n:group] group_n functions_with_numbers + = (group,local_functions_sorted_by_group,functions_with_numbers) + add_functions_to_group [] group group_n functions_with_numbers + = (group,[],functions_with_numbers) + +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_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<<arg_num)<>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<<arg_num)<>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<<field_number)==0 + # generic_info = generic_info bitor (1<<field_number) + = mark_GenericRecordDescriptor_fields field_assignments generic_info + = -1 + mark_GenericRecordDescriptor_fields [_:_] generic_info + = -1 + mark_GenericRecordDescriptor_fields [] generic_info + = generic_info +generic_info_of_RECORD_geninfo_arg _ + = -1 + +generic_info_of_OBJECT_geninfo_arg (PE_Record PE_Empty NoRecordName field_assignments) + = mark_GenericTypeDefDescriptor_fields field_assignments 0 + where + mark_GenericTypeDefDescriptor_fields :: [FieldAssignment] !Int -> 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<<field_number)==0 + # generic_info = generic_info bitor (1<<field_number) + = mark_GenericTypeDefDescriptor_fields field_assignments generic_info + = -1 + mark_GenericTypeDefDescriptor_fields [_:_] generic_info + = -1 + mark_GenericTypeDefDescriptor_fields [] generic_info + = generic_info +generic_info_of_OBJECT_geninfo_arg _ + = -1 + +generic_info_of_CONS_geninfo_arg (PE_Record PE_Empty NoRecordName field_assignments) + = mark_GenericConsDescriptor_fields field_assignments 0 + where + mark_GenericConsDescriptor_fields :: [FieldAssignment] !Int -> 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<<field_number)==0 + # generic_info = generic_info bitor (1<<field_number) + = mark_GenericConsDescriptor_fields field_assignments generic_info + = -1 + mark_GenericConsDescriptor_fields [_:_] generic_info + = -1 + mark_GenericConsDescriptor_fields [] generic_info + = generic_info +generic_info_of_CONS_geninfo_arg _ + = -1 + +generic_info_of_FIELD_geninfo_arg (PE_Record PE_Empty NoRecordName field_assignments) + = mark_GenericFieldDescriptor_fields field_assignments 0 + where + mark_GenericFieldDescriptor_fields :: [FieldAssignment] !Int -> 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<<field_number)==0 + # generic_info = generic_info bitor (1<<field_number) + = mark_GenericFieldDescriptor_fields field_assignments generic_info + = -1 + mark_GenericFieldDescriptor_fields [_:_] generic_info + = -1 + mark_GenericFieldDescriptor_fields [] generic_info + = generic_info +generic_info_of_FIELD_geninfo_arg _ + = -1 + want_instance_type_definitions :: ![Type] !ParseState -> (![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) "<identifier>" 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<<field_number + pState = if (generic_info bitand field_mask<>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<<field_number + pState = if (generic_info bitand field_mask<>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<<field_number + pState = if (generic_info bitand field_mask<>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<<field_number + pState = if (generic_info bitand field_mask<>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<<n_deps)) pState + _ + -> (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<<n_deps)-1) + = (bodies,arity,GenericInstanceUsedArgs n_deps deps,ca) + = (bodies,arity,GenericInstanceUsedArgs 0 0,ca) + where + generic_cons_index + = case id_name of + "OBJECT" -> 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<<n_deps)-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<<n_deps)-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<<arg_n) + = mark_deps_in_args args (arg_n+1) n_deps deps +mark_deps_in_args [] arg_n n_deps deps + | n_deps>=0 + | arg_n<n_deps + = (arg_n,deps) + = (n_deps,deps) + = (arg_n,deps) strictness_from_fields :: ![ParsedSelector] -> 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<NoIndex) (-2-function_group_index) 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<NoIndex) (-2-function_group_index) 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<NoIndex) (-2-macro_group_index) macro_group_index} #! new_function_index = size es.es_fun_defs - # copied_local_functions = Yes { copied_local_functions=[],used_copied_local_functions=[],new_copied_local_functions=[],next_local_function_n=new_function_index+1} + # {es_fun_defs,es_macro_defs,es_var_heap,es_expression_heap} = es + (macro,new_functions,next_local_function_n,es_fun_defs,es_macro_defs,es_var_heap,es_expression_heap) + = copy_macro_and_local_functions macro new_function_index es_fun_defs es_macro_defs es_var_heap es_expression_heap + es & es_fun_defs=es_fun_defs, es_macro_defs=es_macro_defs, es_var_heap=es_var_heap, es_expression_heap=es_expression_heap + last_function_index = next_local_function_n-1 - # (macro,new_functions,local_macro_functions,es) = copy_macro_and_local_functions macro copied_local_functions es -// # new_function_index=trace ("new_function_index: "+++toString new_function_index+++"\n") new_function_index; - # last_function_index = case local_macro_functions of (Yes {next_local_function_n}) -> 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<NoIndex) (-2-macro_group_index) macro_group_index} #! new_function_index = size es.es_fun_defs - # copied_local_functions = Yes { copied_local_functions=[],used_copied_local_functions=[],new_copied_local_functions=[],next_local_function_n=new_function_index+1} + # {es_fun_defs,es_macro_defs,es_var_heap,es_expression_heap} = es + (macro,new_functions,next_local_function_n,es_fun_defs,es_macro_defs,es_var_heap,es_expression_heap) + = copy_macro_and_local_functions macro new_function_index es_fun_defs es_macro_defs es_var_heap es_expression_heap + es & es_fun_defs=es_fun_defs, es_macro_defs=es_macro_defs, es_var_heap=es_var_heap, es_expression_heap=es_expression_heap + last_function_index = next_local_function_n-1 - # (macro,new_functions,local_macro_functions,es) = copy_macro_and_local_functions macro copied_local_functions es -// # new_function_index=trace ("new_function_index: "+++toString new_function_index+++"\n") new_function_index; - # last_function_index = case local_macro_functions of (Yes {next_local_function_n}) -> 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 |