diff options
| -rw-r--r-- | frontend/checkFunctionBodies.icl | 11 | ||||
| -rw-r--r-- | frontend/compilerSwitches.dcl | 4 | ||||
| -rw-r--r-- | frontend/generics1.icl | 355 | ||||
| -rw-r--r-- | frontend/parse.icl | 4 |
4 files changed, 169 insertions, 205 deletions
diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl index fe3a440..8ca5e2f 100644 --- a/frontend/checkFunctionBodies.icl +++ b/frontend/checkFunctionBodies.icl @@ -1165,10 +1165,13 @@ checkExpression free_vars (PE_Generic id=:{id_name,id_info} kind) e_input e_stat = (EE, free_vars, e_state, e_info, { cs & cs_error = checkError id "not a generic" cs_error }) check_it free_vars mod_index gen_index id kind e_input e_state=:{es_expr_heap} e_info cs - # (generic_info_expr, es_expr_heap, cs) = build_generic_info es_expr_heap cs - #! (app_args, es_expr_heap, cs) = SwitchGenericInfo - ([generic_info_expr], es_expr_heap, cs) - ([], es_expr_heap, cs) + #! (app_args, es_expr_heap, cs) + = case kind of + KindArrow [KindConst] + # (generic_info_expr, es_expr_heap, cs) = build_generic_info es_expr_heap cs + -> ([generic_info_expr], es_expr_heap, cs) + _ + -> ([], es_expr_heap, cs) #! symb_kind = SK_Generic { glob_object = gen_index, glob_module = mod_index} kind #! symbol = { symb_ident = id, symb_kind = symb_kind } #! (new_info_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap diff --git a/frontend/compilerSwitches.dcl b/frontend/compilerSwitches.dcl index 417d562..89403fe 100644 --- a/frontend/compilerSwitches.dcl +++ b/frontend/compilerSwitches.dcl @@ -1,5 +1 @@ definition module compilerSwitches - -SwitchPreprocessor preprocessor no_preprocessor :== preprocessor - -SwitchGenericInfo on off :== on diff --git a/frontend/generics1.icl b/frontend/generics1.icl index fb1a6ad..9fc9bed 100644 --- a/frontend/generics1.icl +++ b/frontend/generics1.icl @@ -9,11 +9,8 @@ import check from checktypes import createClassDictionaries from transform import ::Group import genericsupport -import compilerSwitches -//************************************************************************************** // Data types -//************************************************************************************** :: FunDefs :== {#FunDef} :: Modules :== {#CommonDefs} @@ -69,10 +66,7 @@ import compilerSwitches , gs_used_modules :: !NumberSet } - -//************************************************************************************** // Exported functions -//************************************************************************************** convertGenerics :: !Int // index of the main dcl module @@ -160,10 +154,8 @@ where = ([iso_range,instance_range], gs) -//**************************************************************************************** // clear stuff that might have been left over // from compilation of other icl modules -//**************************************************************************************** clearTypeDefInfos td_infos = clear_modules 0 td_infos @@ -194,15 +186,13 @@ where #! modules = {modules & [n].com_generic_defs = com_generic_defs} = clear_module (inc n) modules heaps - clear_generic_def generic_def=:{gen_ident,gen_info_ptr} heaps=:{hp_generic_heap} + 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_info & gen_classes = createArray 32 [] } #! hp_generic_heap = writePtr gen_info_ptr gen_info hp_generic_heap = (generic_def, {heaps & hp_generic_heap = hp_generic_heap}) -//**************************************************************************************** // generic type representation -//**************************************************************************************** // generic representation is built for each type argument of // generic cases of the current module @@ -233,7 +223,7 @@ buildGenericRepresentations gs=:{gs_main_module, gs_modules, gs_funs, gs_groups} } 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 on_gencase com_gencase_defs (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 # {gs_funs, gs_groups} = gs @@ -243,9 +233,8 @@ buildGenericRepresentations gs=:{gs_main_module, gs_modules, gs_funs, gs_groups} #! range = {ir_from = size_funs, ir_to = fg_fun_index} = (range, fg_bimap_functions, {gs & gs_funs = gs_funs, gs_groups = gs_groups}) -where - - on_gencase index +where + build_generic_representation index case_def=:{gc_type_cons=TypeConsSymb {type_index={glob_module,glob_object}, type_ident}, gc_ident, gc_body=GCB_FunIndex fun_index, gc_pos} (funs_and_groups, gs=:{gs_modules, gs_td_infos, gs_funs}) @@ -259,7 +248,6 @@ where TransformedBody _ // does not need a generic representation -> (funs_and_groups, gs) - GeneratedBody // needs a generic representation -> case type_def.td_rhs of @@ -271,20 +259,18 @@ where -> (funs_and_groups, {gs & gs_error = gs_error}) _ -> case td_info.tdi_gen_rep of - Yes _ - -> (funs_and_groups, gs) - //---> ("generic representation is already built", type_ident) - No + Yes _ + -> (funs_and_groups, gs) // generic representation is already built + No #! (gen_type_rep, funs_and_groups, gs) = buildGenericTypeRep type_def_gi funs_and_groups gs #! td_info = {td_info & tdi_gen_rep = Yes gen_type_rep} # {gs_td_infos} = gs #! gs_td_infos = {gs_td_infos & [glob_module, glob_object] = td_info} - # gs = {gs & gs_td_infos = gs_td_infos } - -> (funs_and_groups, gs) - - on_gencase _ _ st = st + # gs = {gs & gs_td_infos = gs_td_infos} + -> (funs_and_groups, gs) + build_generic_representation _ _ st = st :: ConsInfo = {ci_cons_info :: DefinedSymbol, ci_field_infos :: [DefinedSymbol]} @@ -329,9 +315,7 @@ buildGenericTypeRep type_index funs_and_groups } = ({gtr_type=atype,gtr_iso=iso_fun_ds}, funs_and_groups, gs) -//======================================================================================== // the structure type -//======================================================================================== convertATypeToGenTypeStruct :: !Ident !Position !PredefinedSymbols !AType (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin) -> (GenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)) @@ -535,8 +519,7 @@ where build_type {td_rhs=AlgType alts, td_ident, td_pos} type_info cons_infos st # (cons_args, st) = zipWithSt (build_alt td_ident td_pos) alts cons_infos st # type = build_sum_type cons_args - # type = SwitchGenericInfo (GTSObject type_info type) type - = (type, st) + = (GTSObject type_info type, st) build_type {td_rhs=RecordType {rt_constructor}, td_ident, td_pos} type_info [{ci_cons_info, ci_field_infos}] @@ -544,11 +527,10 @@ where # ({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 = SwitchGenericInfo [GTSField fi arg \\ arg <- args & fi <- ci_field_infos] args + # args = [GTSField fi arg \\ arg <- args & fi <- ci_field_infos] # prod_type = build_prod_type args - # type = SwitchGenericInfo (GTSCons ci_cons_info prod_type) prod_type - # type = SwitchGenericInfo (GTSObject type_info type) type - = (type, st) + # type = GTSCons ci_cons_info prod_type + = (GTSObject type_info type, st) # error = reportError td_ident 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_info cons_infos (modules, td_infos, heaps, error) @@ -562,9 +544,8 @@ where # ({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 - # type = SwitchGenericInfo (GTSCons ci_cons_info prod_type) prod_type - = (type, st) + # prod_type = build_prod_type args + = (GTSCons ci_cons_info prod_type, st) # error = reportError td_ident td_pos "cannot build a generic representation of an existential type" error = (GTSE, (modules, td_infos, heaps, error)) @@ -617,10 +598,7 @@ buildPredefTypeApp predef_index args predefs # type_symb = MakeTypeSymbIdent global_index pds_ident (length args) = makeAType (TA type_symb args) TA_Multi - -//======================================================================================== // build type infos -//======================================================================================== buildTypeDefInfo :: !Index // type def module !CheckedTypeDef // the type definition @@ -645,12 +623,7 @@ buildTypeDefInfo td_module td=:{td_rhs = AbstractType _, td_ident, td_pos} main_ = buildTypeDefInfo2 td_module td [] [] main_module_index predefs funs_and_groups modules heaps error buildTypeDefInfo2 td_module td alts fields main_module_index predefs funs_and_groups modules heaps error - = SwitchGenericInfo - (buildTypeDefInfo1 td_module td alts fields main_module_index predefs funs_and_groups modules heaps error) - (dummy, funs_and_groups, modules, heaps, error) -where - dummy_ds = {ds_index = -1, ds_arity = 0, ds_ident = makeIdent "<dummy_generic_info>"} - dummy = (dummy_ds, repeatn (length alts) dummy_ds) + = buildTypeDefInfo1 td_module td alts fields main_module_index predefs funs_and_groups modules heaps error buildTypeDefInfo1 td_module {td_ident, td_pos, td_arity} alts fields main_module_index predefs funs_and_groups=:{fg_fun_index=fun_index,fg_group_index=group_index,fg_funs=funs,fg_groups=groups} modules heaps error @@ -703,7 +676,6 @@ buildTypeDefInfo1 td_module {td_ident, td_pos, td_arity} alts fields main_module = (type_info_ds, cons_infos, funs_and_groups, modules, heaps, error) where - build_type_def_dsc group_index cons_info_dss {ds_index, ds_ident} heaps # td_name_expr = makeStringExpr td_ident.id_name # td_arity_expr = makeIntExpr td_arity @@ -891,11 +863,7 @@ where # (def_sym, funs_and_groups) = buildFunAndGroup ident [] body_expr No main_module_index td_pos funs_and_groups = (def_sym, (funs_and_groups, heaps)) - - -//======================================================================================== // conversions functions -//======================================================================================== // buildConversionIso buildConversionIso :: @@ -996,16 +964,16 @@ where #! names = ["x" +++ toString (i+1) +++ toString k \\ k <- [1..ds_arity]] #! (var_exprs, vars, heaps) = buildVarExprs names heaps - #! (arg_exprs, heaps) = build_fields (SwitchGenericInfo True False && is_record) var_exprs heaps + #! (arg_exprs, heaps) = build_fields is_record var_exprs heaps with build_fields False var_exprs heaps = (var_exprs, heaps) build_fields True var_exprs heaps = mapSdSt build_field var_exprs predefs heaps #! (expr, heaps) = build_prod arg_exprs predefs heaps - #! (expr, heaps) = SwitchGenericInfo (build_cons expr predefs heaps) (expr, heaps) + #! (expr, heaps) = build_cons expr predefs heaps #! (expr, heaps) = build_sum i n expr predefs heaps - #! (expr, heaps) = SwitchGenericInfo (build_object expr predefs heaps) (expr, heaps) + #! (expr, heaps) = build_object expr predefs heaps #! alg_pattern = { ap_symbol = {glob_module = type_def_mod, glob_object = cons_def_sym}, @@ -1076,15 +1044,11 @@ where ) build_expr_for_type_rhs type_def_mod (AlgType def_symbols) heaps error #! (expr, var, heaps, error) = build_sum False type_def_mod def_symbols heaps error - #! (expr, var, heaps) = SwitchGenericInfo - (build_case_object var expr predefs heaps) - (expr, var, heaps) + #! (expr, var, heaps) = build_case_object var expr predefs heaps = (expr, var, heaps, error) build_expr_for_type_rhs type_def_mod (RecordType {rt_constructor}) heaps error # (expr, var, heaps, error) = build_sum True type_def_mod [rt_constructor] heaps error - #! (expr, var, heaps) = SwitchGenericInfo - (build_case_object var expr predefs heaps) - (expr, var, heaps) + #! (expr, var, heaps) = build_case_object var expr predefs heaps = (expr, var, heaps, error) build_expr_for_type_rhs type_def_mod (AbstractType _) heaps error @@ -1110,9 +1074,7 @@ where build_sum is_record type_def_mod [def_symbol] heaps error #! (cons_app_expr, cons_arg_vars, heaps) = build_cons_app type_def_mod def_symbol heaps #! (prod_expr, var, heaps) = build_prod is_record cons_app_expr cons_arg_vars heaps - #! (alt_expr, var, heaps) = SwitchGenericInfo - (build_case_cons var prod_expr predefs heaps) - (prod_expr, var, heaps) + #! (alt_expr, var, heaps) = build_case_cons var prod_expr predefs heaps = (alt_expr, var, heaps, error) build_sum is_record type_def_mod def_symbols heaps error #! (left_def_syms, right_def_syms) = splitAt ((length def_symbols) /2) def_symbols @@ -1137,12 +1099,9 @@ where build_prod is_record expr [] heaps = build_case_unit expr heaps build_prod is_record expr [cons_arg_var] heaps - - #! (arg_expr, var, heaps) = SwitchGenericInfo - (if is_record (build_case_field cons_arg_var expr predefs heaps) (expr, cons_arg_var, heaps)) - (expr, cons_arg_var, heaps) - - = (arg_expr, var, heaps) + | is_record + = build_case_field cons_arg_var expr predefs heaps + = (expr, cons_arg_var, heaps) build_prod is_record expr cons_arg_vars heaps #! (left_vars, right_vars) = splitAt ((length cons_arg_vars) /2) cons_arg_vars #! (expr, right_var, heaps) = build_prod is_record expr right_vars heaps @@ -1255,10 +1214,7 @@ where #! (common_defs=:{com_gencase_defs}, gs_modules) = gs_modules![module_index] #! (com_gencase_defs, st, gs=:{gs_modules}) = build_module module_index com_gencase_defs st {gs & gs_modules=gs_modules} - #! gs_modules = - { gs_modules - & [module_index] = {common_defs & com_gencase_defs = com_gencase_defs } - } + #! gs_modules = {gs_modules & [module_index] = {common_defs & com_gencase_defs = com_gencase_defs}} = build_modules (inc module_index) st {gs & gs_modules = gs_modules} build_module module_index com_gencase_defs st gs=:{gs_used_modules} @@ -1275,12 +1231,12 @@ where #! com_gencase_defs = {com_gencase_defs & [index] = gencase} = build_module1 module_index (inc index) com_gencase_defs st gs - on_gencase :: !Index !Index + on_gencase :: !Index !Index !GenericCaseDef (![ClassDef], ![MemberDef], !Index, Index) !*GenericState -> (!GenericCaseDef,(![ClassDef], ![MemberDef], !Index, Index), !*GenericState) - on_gencase module_index index + on_gencase module_index index gencase=:{gc_ident,gc_generic, gc_type_cons} st gs=:{gs_modules, gs_td_infos} - #! (gen_def, gs_modules) = gs_modules ! [gc_generic.gi_module].com_generic_defs.[gc_generic.gi_index] + #! (gen_def, gs_modules) = gs_modules![gc_generic.gi_module].com_generic_defs.[gc_generic.gi_index] #! (kind, gs_td_infos) = get_kind_of_type_cons gc_type_cons gs_td_infos // To generate all partially applied shorthand instances we need @@ -1316,9 +1272,9 @@ where -> ((![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} + #! gs = {gs & gs_genh = gs_genh} = case opt_class_info of - No + No #! (class_def, member_def, gs=:{gs_genh}) = buildClassAndMember gs_main_module class_index member_index kind gen_def gs #! class_info = @@ -1366,9 +1322,8 @@ where #! gs_genh = writePtr gen_info_ptr {gen_info&gen_classes=gen_classes} gs_genh = gs_genh - build_class_dictionaries :: !CommonDefs !*GenericState -> (!CommonDefs, !*GenericState) - build_class_dictionaries - common_defs + build_class_dictionaries :: !CommonDefs !*GenericState -> (!CommonDefs, !*GenericState) + build_class_dictionaries common_defs gs=:{gs_varh, gs_tvarh, gs_main_module, gs_symtab, gs_dcl_modules} #! class_defs = { x \\ x <-: common_defs.com_class_defs } // make unique copy # type_defs = { x \\ x <-: common_defs.com_type_defs } // make unique copy @@ -1411,7 +1366,12 @@ buildMemberType gen_def=:{gen_ident,gen_pos,gen_type,gen_vars} kind class_var gs #! (member_st, th, gs_error) = replace_generic_vars_with_class_var kind_indexed_st gatvs kind th gs_error - #! (member_st, th) = SwitchGenericInfo (add_generic_info member_st th) (member_st, th) + #! (member_st, th) + = case kind of + KindArrow [KindConst] + -> add_generic_info member_st th + _ + -> (member_st, th) #! th = assertSymbolType member_st th // just paranoied about cleared variables #! th = assertSymbolType gen_type th @@ -1419,7 +1379,6 @@ buildMemberType gen_def=:{gen_ident,gen_pos,gen_type,gen_vars} kind class_var gs # {th_vars, th_attrs} = th #! gs = {gs & gs_avarh = th_attrs, gs_tvarh = th_vars, gs_error = gs_error } = (member_st, gs) - //---> ("buildMemberType returns", gen_ident, kind, member_st) where add_bimap_contexts {gen_type=gen_type=:{st_vars, st_context}, gen_vars, gen_info_ptr} @@ -1494,28 +1453,26 @@ where // add an argument for generic info at the beginning add_generic_info st=:{st_arity, st_args, st_args_strictness} th=:{th_vars} - #! {pds_module, pds_def} = gs_predefs . [PD_GenericInfo] - #! pds_ident = predefined_idents . [PD_GenericInfo] - #! type_symb = MakeTypeSymbIdent { glob_module = pds_module, glob_object = pds_def } pds_ident 0 - #! st = { st & st_args = [ makeAType (TA type_symb []) TA_Multi : st_args] - , st_arity = st_arity + 1 - , st_args_strictness = insert_n_lazy_values_at_beginning 1 st_args_strictness + #! {pds_module, pds_def} = gs_predefs.[PD_GenericInfo] + #! pds_ident = predefined_idents.[PD_GenericInfo] + #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} pds_ident 0 + #! st = {st & st_args = [makeAType (TA type_symb []) TA_Multi : st_args] + , st_arity = st_arity + 1 + , st_args_strictness = insert_n_lazy_values_at_beginning 1 st_args_strictness } - = (st, {th & th_vars = th_vars }) - + = (st, {th & th_vars = th_vars}) -buildClassAndMember - module_index class_index member_index kind - gen_def=:{gen_ident, gen_pos} +buildClassAndMember :: Int Int Int TypeKind GenericDef *GenericState -> (ClassDef,MemberDef,*GenericState) +buildClassAndMember + module_index class_index member_index kind + gen_def=:{gen_ident, gen_pos} gs=:{gs_tvarh} # (class_var, gs_tvarh) = freshTypeVar (makeIdent "class_var") gs_tvarh #! (member_def, gs) = build_class_member class_var {gs & gs_tvarh = gs_tvarh} #! class_def = build_class class_var member_def = (class_def, member_def, gs) - //---> ("buildClassAndMember", gen_def.gen_ident, kind) where - class_ident = genericIdentToClassIdent gen_def.gen_ident.id_name kind member_ident = genericIdentToMemberIdent gen_def.gen_ident.id_name kind class_ds = {ds_index = class_index, ds_ident = class_ident, ds_arity = 1} @@ -1526,7 +1483,7 @@ where #! 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_types = [TV class_var] , tc_var = tc_var_ptr } #! (member_type, gs) @@ -1542,8 +1499,8 @@ where me_pos = gen_pos, me_priority = NoPrio } - //---> ("member_type", member_type) = (member_def, gs) + build_class class_var member_def=:{me_type} #! class_member = { ds_ident = member_ident @@ -1564,10 +1521,8 @@ where class_members = createArray 1 class_member, class_cons_vars = 0, // dotted class variables class_dictionary = class_dictionary - } - + } = class_def - //**************************************************************************************** // Convert generic cases @@ -1652,9 +1607,8 @@ where (!*{#FunType},!*Modules, (FunsAndGroups, (!Index, ![ClassInstance]), !*{#FunDef}, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)) -> (!*{#FunType},!*Modules, (FunsAndGroups, (!Index, ![ClassInstance]), !*{#FunDef}, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)) convert_gencase module_index gc_index gencase=:{gc_ident, gc_type} st - #! st = build_main_instance module_index gc_index gencase st - #! st = build_shorthand_instances module_index gc_index gencase st - = st + #! st = build_main_instance module_index gc_index gencase st + = build_shorthand_instances module_index gc_index gencase st build_main_instance module_index gc_index gencase=:{gc_ident, gc_kind, gc_generic, gc_pos, gc_type, gc_type_cons, gc_body = GCB_FunIndex fun_index} @@ -1667,7 +1621,7 @@ where #! ({class_members}, modules) = modules![class_info.gci_module].com_class_defs.[class_info.gci_class] #! (member_def, modules) = modules![class_info.gci_module].com_member_defs.[class_members.[0].ds_index] - #! ins_type = + #! ins_type = { it_vars = case gc_type_cons of TypeConsVar tv -> [tv] _ -> [] @@ -1683,9 +1637,7 @@ where = update_dcl_function fun_index gencase fun_type dcl_functions heaps #! (fun_info, fun_defs, td_infos, modules, heaps, error) - = update_icl_function_if_needed - module_index - fun_index gencase fun_type + = update_icl_function_if_needed module_index fun_index gencase fun_type fun_info fun_defs td_infos modules heaps error #! ins_info = build_exported_class_instance class_info.gci_class gencase module_index ins_type ins_info @@ -1780,7 +1732,8 @@ where = (type_context, hp_var_heap) build_shorthand_instance_member module_index this_kind gencase=:{gc_generic, gc_ident, gc_kind, gc_pos} st class_infos fun_info heaps - #! arg_var_names = ["x" +++ toString i \\ i <- [1..st.st_arity-SwitchGenericInfo 1 0]] + # function_has_generic_info_arg = case this_kind of KindArrow [KindConst] -> True ; _ -> False + #! arg_var_names = ["x" +++ toString i \\ i <- [1..st.st_arity-(if function_has_generic_info_arg 1 0)]] #! (arg_var_exprs, arg_vars, heaps) = buildVarExprs arg_var_names heaps #! (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty heaps.hp_expression_heap @@ -1791,29 +1744,37 @@ where #! arg_exprs = gen_exprs ++ arg_var_exprs - # (generic_info_expr, generic_info_var , heaps) = buildVarExpr "geninfo" heaps - # arg_exprs = SwitchGenericInfo [generic_info_expr: arg_exprs] arg_exprs - # arg_vars = SwitchGenericInfo [generic_info_var: arg_vars] arg_vars - - # (body_expr, heaps) - = buildGenericApp gc_generic.gi_module gc_generic.gi_index - gc_ident gc_kind arg_exprs heaps + # (arg_vars,heaps) + = case function_has_generic_info_arg of + True + #! (fv_info_ptr, hp_var_heap) = newPtr VI_Empty heaps.hp_var_heap + #! fv = {fv_count = 0, fv_ident = makeIdent "geninfo", fv_info_ptr = fv_info_ptr, fv_def_level = NotALevel} + -> ([fv : arg_vars], {heaps & hp_var_heap = hp_var_heap}) + False + -> (arg_vars, heaps) + + # (body_expr, heaps) + = case gc_kind of + KindArrow [KindConst] + # (generic_info_expr, heaps) = buildPredefConsApp PD_NoGenericInfo [] gs_predefs heaps + -> buildGenericApp gc_generic.gi_module gc_generic.gi_index gc_ident gc_kind [generic_info_expr:arg_exprs] heaps + _ + -> buildGenericApp gc_generic.gi_module gc_generic.gi_index gc_ident gc_kind arg_exprs heaps #! (st, heaps) = fresh_symbol_type st heaps #! (fun_ds, fun_info) = buildFunAndGroup fun_name arg_vars body_expr (Yes st) gs_main_module gc_pos fun_info - - = (fun_ds, fun_info, heaps) - //---> ("shorthand instance body", body_expr) + + = (fun_ds, fun_info, heaps) where - build_generic_app {gi_module, gi_index} gc_ident {gci_kind} heaps - # (generic_info_expr, heaps) = build_generic_info_expr heaps - = buildGenericApp gi_module gi_index gc_ident gci_kind (SwitchGenericInfo [generic_info_expr] []) heaps - build_generic_info_expr heaps - = buildPredefConsApp PD_NoGenericInfo [] gs_predefs heaps + build_generic_app {gi_module, gi_index} gc_ident {gci_kind=gci_kind=:KindArrow [KindConst]} heaps + # (generic_info_expr, heaps) = buildPredefConsApp PD_NoGenericInfo [] gs_predefs heaps + = buildGenericApp gi_module gi_index gc_ident gci_kind [generic_info_expr] heaps + build_generic_app {gi_module, gi_index} gc_ident {gci_kind} heaps + = buildGenericApp gi_module gi_index gc_ident gci_kind [] heaps - build_class_instance this_kind class_index gencase {ds_ident,ds_arity,ds_index} ins_type (ins_index, instances) + build_class_instance this_kind class_index gencase {ds_ident,ds_arity,ds_index} ins_type (ins_index, instances) # {gc_pos, gc_ident, gc_kind} = gencase #! class_ident = genericIdentToClassIdent gc_ident.id_name this_kind #! class_ds = {ds_index = class_index, ds_arity=1, ds_ident=class_ident} @@ -1837,7 +1798,6 @@ where # (Yes class_info) = lookupGenericClassInfo kind gen_classes = (class_info, (modules, heaps)) - determine_type_of_member_instance :: !MemberDef !InstanceType !*Heaps !*ErrorAdmin -> (!SymbolType, !*Heaps, !*ErrorAdmin) determine_type_of_member_instance {me_type, me_class_vars} ins_type heaps=:{hp_type_heaps, hp_var_heap} error @@ -1848,22 +1808,18 @@ where #! symbol_type = {symbol_type & st_context = st_context} #! heaps = {heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap} = (symbol_type, heaps, error) - //---> ("determine_type_of_member_instance", ins_type, symbol_type) - update_dcl_function :: !Index !GenericCaseDef !SymbolType !*{#FunType} !*Heaps - -> (!*{#FunType}, !*Heaps) + update_dcl_function :: !Index !GenericCaseDef !SymbolType !*{#FunType} !*Heaps -> (!*{#FunType}, !*Heaps) update_dcl_function fun_index {gc_ident, gc_type_cons} symbol_type dcl_functions heaps | fun_index < size dcl_functions #! (symbol_type, heaps) = fresh_symbol_type symbol_type heaps - #! (fun, dcl_functions) = dcl_functions ! [fun_index] + #! (fun, dcl_functions) = dcl_functions![fun_index] #! fun = { fun & ft_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons , ft_type = symbol_type - , ft_arity = symbol_type.st_arity } - #! dcl_functions = { dcl_functions & [fun_index] = fun} + , ft_arity = symbol_type.st_arity} + #! dcl_functions = {dcl_functions & [fun_index] = fun} = (dcl_functions, heaps) - //---> ("update dcl function", fun.ft_ident, fun_index, symbol_type) = (dcl_functions, heaps) - //---> ("update dcl function: not in the dcl module", fun_index) update_icl_function_if_needed module_index fun_index gencase fun_type funs_and_groups fun_defs td_infos modules heaps error | module_index == gs_main_module // current module @@ -1876,19 +1832,30 @@ where !Index !GenericCaseDef !SymbolType !FunsAndGroups !*{#FunDef} !*TypeDefInfos !*{#CommonDefs} !*Heaps !*ErrorAdmin -> (!FunsAndGroups,!*{#FunDef},!*TypeDefInfos,!*{#CommonDefs},!*Heaps,!*ErrorAdmin) - update_icl_function fun_index gencase=:{gc_ident, gc_type_cons, gc_pos} st funs_and_groups fun_defs td_infos modules heaps error + update_icl_function fun_index gencase=:{gc_ident,gc_type_cons,gc_kind,gc_pos} st 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] + #! (fun=:{fun_body, fun_arity}, fun_defs) = fun_defs![fun_index] #! fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons = case fun_body of - TransformedBody tb // user defined case - | fun_arity <> st.st_arity - # error = reportError gc_ident gc_pos ("incorrect arity " +++ toString (SwitchGenericInfo (fun_arity-1) fun_arity) - +++ ", expected " +++ toString (SwitchGenericInfo (st.st_arity-1) st.st_arity)) 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) + TransformedBody {tb_args,tb_rhs} // user defined case + -> case gc_kind of + KindArrow [KindConst] + | fun_arity<>st.st_arity + # error = reportError gc_ident gc_pos ("incorrect arity " +++ toString (fun_arity-1) + +++ ", expected " +++ toString (st.st_arity-1)) error + -> (funs_and_groups, fun_defs, td_infos, modules, heaps, error) + #! fun = {fun & fun_ident = fun_ident, fun_type = Yes st} + #! fun_defs = {fun_defs & [fun_index] = fun} + -> (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 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) GeneratedBody // derived case #! (TransformedBody {tb_args, tb_rhs}, funs_and_groups, td_infos, modules, heaps, error) = buildGenericCaseBody gs_main_module gencase st gs_predefs funs_and_groups td_infos modules heaps error @@ -1926,7 +1893,7 @@ buildGenericCaseBody :: !FunsAndGroups !*TypeDefInfos !*{#CommonDefs} !*Heaps !*ErrorAdmin -> (!FunctionBody, !FunsAndGroups, !*TypeDefInfos,!*{#CommonDefs},!*Heaps,!*ErrorAdmin) -buildGenericCaseBody main_module_index gc=:{gc_ident, gc_pos, gc_generic, gc_type_cons=TypeConsSymb {type_ident,type_index}} st predefs +buildGenericCaseBody main_module_index gc=:{gc_type_cons=TypeConsSymb {type_ident,type_index},gc_ident,gc_kind,gc_generic} st predefs funs_and_groups td_infos modules heaps error #! (gen_def, modules) = modules![gc_generic.gi_module].com_generic_defs.[gc_generic.gi_index] #! (td_info=:{tdi_gen_rep}, td_infos) = td_infos![type_index.glob_module,type_index.glob_object] @@ -1934,18 +1901,18 @@ buildGenericCaseBody main_module_index gc=:{gc_ident, gc_pos, gc_generic, gc_typ 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] - - #! num_generic_info_args = SwitchGenericInfo 1 0 - | td_arity <> st.st_arity - gen_def.gen_type.st_arity - num_generic_info_args - = abort "sanity check: td_arity <> added arity of the symbol type\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 - # (generic_info_var, heaps) = build_generic_info_arg heaps - #! arg_vars = SwitchGenericInfo [generic_info_var:arg_vars] arg_vars + # (arg_vars,heaps) + = case gc_kind of + KindArrow [KindConst] + # (generic_info_var, heaps) = build_generic_info_arg heaps + #! arg_vars = [generic_info_var:arg_vars] + -> (arg_vars,heaps) + _ + -> (arg_vars,heaps) #! (adaptor_expr, funs_and_groups, modules, td_infos, heaps, error) = build_adaptor_expr gc gen_def gen_type_rep funs_and_groups modules td_infos heaps error @@ -1958,7 +1925,6 @@ buildGenericCaseBody main_module_index gc=:{gc_ident, gc_pos, gc_generic, gc_typ = (TransformedBody {tb_args=arg_vars, tb_rhs=body_expr}, funs_and_groups, td_infos, modules, heaps, error) where - build_generic_info_arg heaps=:{hp_var_heap} // generic arg is never referenced in the generated body #! (fv_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap @@ -2028,10 +1994,14 @@ where # (expr, funs_and_groups, heaps) = bimap_id_expression main_module_index predefs funs_and_groups heaps = ((non_gen_var, expr), funs_and_groups, heaps) - build_bimap_expr non_gen_var kind funs_and_groups heaps + build_bimap_expr non_gen_var kind=:(KindArrow [KindConst]) funs_and_groups heaps # (generic_info_expr, heaps) = build_generic_info_expr heaps - #! (expr, heaps) - = buildGenericApp bimap_module bimap_index bimap_ident kind (SwitchGenericInfo [generic_info_expr] []) heaps + #! (expr, heaps) + = buildGenericApp bimap_module bimap_index bimap_ident kind [generic_info_expr] heaps + = ((non_gen_var, expr), funs_and_groups, heaps) + build_bimap_expr non_gen_var kind funs_and_groups heaps + #! (expr, heaps) + = buildGenericApp bimap_module bimap_index bimap_ident kind [] heaps = ((non_gen_var, expr), funs_and_groups, heaps) build_generic_info_expr heaps @@ -2153,13 +2123,11 @@ where # (com_instance_defs, (modules, heaps, error)) = updateArraySt convert_instance {x\\x<-:com_instance_defs} st - # common_defs = - { common_defs + # common_defs = { common_defs & com_class_defs = com_class_defs , com_member_defs = com_member_defs , com_instance_defs = com_instance_defs } - = (common_defs, modules, (heaps, error)) where convert_class class_def=:{class_ident, class_pos, class_context} st @@ -2202,7 +2170,7 @@ where | ok1 || ok2 = (True, [tc:tcs], st) = (False, all_tcs, st) - + 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) @@ -2272,35 +2240,32 @@ where 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 predefs st + = build_generic_app_no_info (KindArrow [KindConst, KindConst]) [x,y] gen_index gen_ident predefs 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 predefs st + = build_generic_app_no_info (KindArrow [KindConst, KindConst]) [x,y] gen_index gen_ident predefs 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 predefs st + = build_generic_app_no_info (KindArrow [KindConst, KindConst]) [x,y] gen_index gen_ident predefs 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 - #! (expr, heaps) = buildGenericApp - gen_index.gi_module gen_index.gi_index gen_ident - (KindArrow [KindConst]) [generic_info_expr, arg_expr] heaps + #! (generic_info_expr, heaps) = buildFunApp main_module_index cons_info_ds [] heaps + #! (expr, heaps) + = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident (KindArrow [KindConst]) [generic_info_expr, 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 - #! (expr, heaps) = buildGenericApp - gen_index.gi_module gen_index.gi_index gen_ident - (KindArrow [KindConst]) [generic_info_expr, arg_expr] heaps + #! (expr, heaps) + = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident (KindArrow [KindConst]) [generic_info_expr, 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 - #! (expr, heaps) = buildGenericApp - gen_index.gi_module gen_index.gi_index gen_ident - (KindArrow [KindConst]) [generic_info_expr, arg_expr] heaps + #! (expr, heaps) + = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident (KindArrow [KindConst]) [generic_info_expr, arg_expr] heaps = (expr, (td_infos, heaps, error)) specialize type (td_infos, heaps, error) #! error = reportError gen_ident gen_pos "cannot specialize " error @@ -2310,9 +2275,16 @@ where #! (TVI_Expr expr, th_vars) = readPtr tv_info_ptr th_vars = (expr, (td_infos, {heaps & hp_type_heaps = {th & th_vars = th_vars}}, error)) - build_generic_app kind arg_exprs gen_index gen_ident predefs (td_infos, heaps, error) + build_generic_app kind=:(KindArrow [KindConst]) arg_exprs gen_index gen_ident predefs (td_infos, heaps, error) # (generic_info_expr, heaps) = buildPredefConsApp PD_NoGenericInfo [] predefs heaps - # arg_exprs = SwitchGenericInfo [generic_info_expr:arg_exprs] arg_exprs + # arg_exprs = [generic_info_expr:arg_exprs] + #! (expr, heaps) + = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident kind arg_exprs heaps + = (expr, (td_infos, heaps, error)) + build_generic_app kind arg_exprs gen_index gen_ident predefs (td_infos, heaps, error) + = build_generic_app_no_info kind arg_exprs gen_index gen_ident predefs (td_infos, heaps, error) + + build_generic_app_no_info kind arg_exprs gen_index gen_ident predefs (td_infos, heaps, error) #! (expr, heaps) = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident kind arg_exprs heaps = (expr, (td_infos, heaps, error)) @@ -2408,9 +2380,13 @@ where #! (TVI_Expr expr, th_vars) = readPtr tv_info_ptr th_vars = (expr, (funs_and_groups, {heaps & hp_type_heaps = {th & th_vars = th_vars}}, error)) - build_generic_app kind arg_exprs gen_index gen_ident predefs (funs_and_groups, heaps, error) + build_generic_app kind=:(KindArrow [KindConst]) arg_exprs gen_index gen_ident predefs (funs_and_groups, heaps, error) # (generic_info_expr, heaps) = buildPredefConsApp PD_NoGenericInfo [] predefs heaps - # arg_exprs = SwitchGenericInfo [generic_info_expr:arg_exprs] arg_exprs + # arg_exprs = [generic_info_expr:arg_exprs] + #! (expr, heaps) + = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident kind arg_exprs heaps + = (expr, (funs_and_groups, heaps, error)) + build_generic_app kind arg_exprs gen_index gen_ident predefs (funs_and_groups, heaps, error) #! (expr, heaps) = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident kind arg_exprs heaps = (expr, (funs_and_groups, heaps, error)) @@ -2582,12 +2558,12 @@ where #! (TVI_Expr expr, th_vars) = readPtr tv_info_ptr th_vars = (expr, (funs_and_groups, {heaps & hp_type_heaps = {th & th_vars = th_vars}}, error)) - build_generic_app kind arg_exprs gen_index gen_ident predefs heaps + build_generic_app kind=:(KindArrow [KindConst]) arg_exprs gen_index gen_ident predefs heaps # (generic_info_expr, heaps) = buildPredefConsApp PD_NoGenericInfo [] predefs heaps - # arg_exprs = SwitchGenericInfo [generic_info_expr:arg_exprs] arg_exprs - #! (expr, heaps) - = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident kind arg_exprs heaps - = (expr, heaps) + # arg_exprs = [generic_info_expr:arg_exprs] + = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident kind arg_exprs heaps + build_generic_app kind arg_exprs gen_index gen_ident predefs heaps + = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident kind arg_exprs heaps is_bimap_id_expression (App {app_symb={symb_kind=SK_Function fun_glob},app_args=[]}) main_module_index {fg_bimap_functions={bimap_id_function={fii_index}}} = fii_index>=0 && fun_glob.glob_module==main_module_index && fun_glob.glob_object==fii_index @@ -3151,7 +3127,7 @@ where = Yes {ai_offered = x, ai_demanded = y} // offered <= demanded = outer<=inner = x<=y make_inequality _ _ = No - + reportError name pos msg error=:{ea_file} //= checkErrorWithIdentPos (newPosition name pos) msg error # ea_file = ea_file <<< "Error " <<< (newPosition name pos) <<< ":" <<< msg <<< '\n' @@ -3250,9 +3226,7 @@ instance mapTypeSt Type where #! (type2, st) = map_type type1 st #! (type3, st) = on_type_after type2 st = (type3, st) - //---> ("mapTypeSt Type", type, type1, type2, type3) where - map_type (TA type_symb_ident args) st #! (args, st) = mapTypeSt on_type_before on_atype_before on_type_after on_atype_after args st = (TA type_symb_ident args, st) @@ -3289,10 +3263,6 @@ instance mapTypeSt TypeContext where #! (tc_types, st) = mapTypeSt on_type_before on_atype_before on_type_after on_atype_after tc_types st = ({tc&tc_types=tc_types}, st) - -//----------------------------------------------------------------------- -//----------------------------------------------------------------------- - // allocate fresh type variable freshTypeVar :: !Ident !*TypeVarHeap -> (!TypeVar, !*TypeVarHeap) freshTypeVar name th_vars @@ -3305,7 +3275,6 @@ freshAttrVar name th_attrs # (info_ptr, th_attrs) = newPtr AVI_Empty th_attrs = ({av_ident = name, av_info_ptr = info_ptr}, th_attrs) - // take a fresh copy of a SymbolType freshSymbolType :: !SymbolType // symbol type to take fresh @@ -3315,7 +3284,6 @@ freshSymbolType :: ) freshSymbolType st th=:{th_vars, th_attrs} #! (fresh_st_vars, th_vars) = mapSt subst_type_var st.st_vars th_vars - //---> ("freshSymbolType called for", st) #! (fresh_st_attr_vars, th_attrs) = mapSt subst_attr_var st.st_attr_vars th_attrs #! th = {th & th_vars = th_vars, th_attrs = th_attrs} @@ -3341,12 +3309,12 @@ freshSymbolType st th=:{th_vars, th_attrs} #! th = assertSymbolType st th = (fresh_st, th) - //---> ("freshSymbolType returns", fresh_st) where subst_type_var :: !TypeVar !*TypeVarHeap -> (!TypeVar, !*TypeVarHeap) subst_type_var tv=:{tv_info_ptr} th_vars # (new_ptr, th_vars) = newPtr TVI_Empty th_vars = ({tv & tv_info_ptr=new_ptr}, writePtr tv_info_ptr (TVI_TypeVar new_ptr) th_vars) + subst_attr_var :: !AttributeVar !*AttrVarHeap -> (!AttributeVar, !*AttrVarHeap) subst_attr_var av=:{av_info_ptr} th_attrs # (new_ptr, th_attrs) = newPtr AVI_Empty th_attrs @@ -3389,11 +3357,10 @@ where = (TA_Multi, th_attrs) on_type type th = (type, th) - + on_atype atype=:{at_attribute=TA_Var av} th #! (fresh_av, th) = on_attr_var av th = ({atype & at_attribute=TA_Var fresh_av}, th) - //---> ("on_atype av", av, fresh_av) on_atype atype th = (atype, th) diff --git a/frontend/parse.icl b/frontend/parse.icl index 6982f47..3ecb030 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -627,9 +627,7 @@ where //# pState = wantToken FunctionContext "type argument" GenericCloseToken pState # (args, pState) = parseList trySimpleLhsExpression pState - - //# (geninfo_ident, pState) = stringToIdent "geninfo" IC_Expression pState - # args = SwitchGenericInfo [geninfo_arg : args] args + # args = [geninfo_arg : args] // must be EqualToken or HashToken or ??? //# pState = wantToken FunctionContext "generic definition" EqualToken pState |