diff options
| -rw-r--r-- | frontend/check.icl | 149 | ||||
| -rw-r--r-- | frontend/checkKindCorrectness.icl | 35 | ||||
| -rw-r--r-- | frontend/frontend.icl | 53 | ||||
| -rw-r--r-- | frontend/generics.dcl | 4 | ||||
| -rw-r--r-- | frontend/generics.icl | 342 |
5 files changed, 414 insertions, 169 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index d482f23..016a00b 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -285,7 +285,8 @@ where ) check_generic_instance :: GenericDef !Index !Index !Index !ClassInstance !u:InstanceSymbols !*TypeHeaps !*CheckState -> (!ClassInstance, !u:InstanceSymbols, !*TypeHeaps, !*CheckState) check_generic_instance - class_def module_index generic_index generic_module_index + {gen_member_name} + module_index generic_index generic_module_index ins=:{ ins_members, ins_class={glob_object = class_name =: {ds_ident = {id_name,id_info},ds_arity, ds_index} }, @@ -293,7 +294,9 @@ where ins_specials, ins_pos, ins_ident, - ins_is_generic} + ins_is_generic, + ins_generate + } is=:{is_class_defs,is_modules} type_heaps cs=:{cs_symbol_table, cs_error} @@ -304,16 +307,20 @@ where = checkInstanceType module_index ins_class ins_type ins_specials is.is_type_defs is.is_class_defs is.is_modules type_heaps cs # is = { is & is_type_defs = is_type_defs, is_class_defs = is_class_defs, is_modules = is_modules } - # ins = { ins & - ins_is_generic = True, - ins_generic = {glob_module = module_index, glob_object = generic_index}, - ins_class = ins_class, - ins_type = ins_type, - ins_specials = ins_specials + # ins = + { ins + & ins_is_generic = True + , ins_generic = {glob_module = generic_module_index, glob_object = generic_index} + , ins_class = ins_class + , ins_type = ins_type + , ins_specials = ins_specials + , ins_members = if ins_generate + {{ds_arity = 0, ds_index = NoIndex, ds_ident = gen_member_name}} + ins_members } = (ins, is, type_heaps, cs) // otherwise - # cs_error = checkError id_name "arity of generic instance must be 1" cs_error + # cs_error = checkError id_name "arity of a generic instance must be 1" cs_error # cs = {cs & cs_error = cs_error} = (ins, is, type_heaps, cs) @@ -355,8 +362,8 @@ where check_generic_instance {ins_class, ins_members, ins_generate} mod_index instance_types class_defs member_defs generic_defs type_defs modules var_heap type_heaps cs # ({gen_name, gen_member_name}, generic_defs, modules) = getGenericDef ins_class mod_index generic_defs modules - | ins_generate - = (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs) + //| ins_generate + // = (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs) | size ins_members <> 1 # cs = { cs & cs_error = checkError gen_name "generic instance must have one memeber" cs.cs_error } = (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs) @@ -576,43 +583,90 @@ getTypeDef x_main_dcl_module_n {glob_module,glob_object} type_defs modules = modules![glob_module].dcl_common.com_type_defs.[glob_object] = (type_def, type_defs, modules) -determineTypesOfInstances :: !Index !Index !*{#ClassInstance} !*{# ClassDef} !*{# MemberDef} +determineTypesOfInstances :: !Index !Index !*{#ClassInstance} !*{# ClassDef} !*{# MemberDef} !*{#GenericDef} !*{#DclModule} !*TypeHeaps !*VarHeap !*CheckState - -> (![FunType], !Index, ![ClassInstance], !*{#ClassInstance}, !*{# ClassDef}, !*{# MemberDef}, !*{#DclModule}, !*TypeHeaps, !*VarHeap, !*CheckState) -determineTypesOfInstances first_memb_inst_index mod_index com_instance_defs com_class_defs com_member_defs + -> (![FunType], !Index, ![ClassInstance], !*{#ClassInstance}, !*{# ClassDef}, !*{# MemberDef}, !*{#GenericDef}, !*{#DclModule}, !*TypeHeaps, !*VarHeap, !*CheckState) +determineTypesOfInstances first_memb_inst_index mod_index com_instance_defs com_class_defs com_member_defs com_generic_defs modules type_heaps var_heap cs=:{cs_error, cs_x={x_main_dcl_module_n}} | cs_error.ea_ok #! nr_of_class_instances = size com_instance_defs - # (memb_inst_defs, next_mem_inst_index, all_class_specials, com_class_defs, com_member_defs, modules, com_instance_defs, type_heaps, var_heap, cs_error) - = determine_types_of_instances x_main_dcl_module_n 0 nr_of_class_instances first_memb_inst_index mod_index [] com_class_defs com_member_defs + # (memb_inst_defs, next_mem_inst_index, all_class_specials, com_class_defs, com_member_defs, com_generic_defs, modules, com_instance_defs, type_heaps, var_heap, cs_error) + = determine_types_of_instances x_main_dcl_module_n 0 nr_of_class_instances first_memb_inst_index mod_index [] com_class_defs com_member_defs com_generic_defs modules com_instance_defs type_heaps var_heap cs_error = (memb_inst_defs, next_mem_inst_index, all_class_specials, com_instance_defs, com_class_defs, - com_member_defs, modules, type_heaps, var_heap, { cs & cs_error = cs_error }) - = ([], first_memb_inst_index, [], com_instance_defs, com_class_defs, com_member_defs, modules, type_heaps, var_heap, cs) + com_member_defs, com_generic_defs, modules, type_heaps, var_heap, { cs & cs_error = cs_error }) + = ([], first_memb_inst_index, [], com_instance_defs, com_class_defs, com_member_defs, com_generic_defs, modules, type_heaps, var_heap, cs) where - determine_types_of_instances :: !Index !Index !Index !Index !Index ![ClassInstance] !v:{#ClassDef} !w:{#MemberDef} + determine_types_of_instances :: !Index !Index !Index !Index !Index ![ClassInstance] !v:{#ClassDef} !w:{#MemberDef} !y:{#GenericDef} !x:{#DclModule} !*{#ClassInstance} !*TypeHeaps !*VarHeap !*ErrorAdmin - -> (![FunType], !Index, ![ClassInstance], !v:{#ClassDef}, !w:{#MemberDef}, !x:{#DclModule}, !*{#ClassInstance}, !*TypeHeaps, !*VarHeap, !*ErrorAdmin) + -> (![FunType], !Index, ![ClassInstance], !v:{#ClassDef}, !w:{#MemberDef}, !y:{#GenericDef}, !x:{#DclModule}, !*{#ClassInstance}, !*TypeHeaps, !*VarHeap, !*ErrorAdmin) determine_types_of_instances x_main_dcl_module_n inst_index next_class_inst_index next_mem_inst_index mod_index all_class_specials - class_defs member_defs modules instance_defs type_heaps var_heap error + class_defs member_defs generic_defs modules instance_defs type_heaps var_heap error | inst_index < size instance_defs # (instance_def, instance_defs) = instance_defs![inst_index] - # {ins_class,ins_pos,ins_type,ins_specials} = instance_def - ({class_name, class_members}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules - class_size = size class_members - (ins_members, memb_inst_defs1, member_defs, modules, type_heaps, var_heap, error) - = determine_instance_symbols_and_types x_main_dcl_module_n next_mem_inst_index 0 mod_index ins_class.glob_module class_size class_members - ins_type ins_specials class_name ins_pos member_defs modules type_heaps var_heap error - instance_def = { instance_def & ins_members = { member \\ member <- ins_members }} - (ins_specials, next_class_inst_index, all_class_specials, type_heaps, error) - = check_instance_specials mod_index instance_def inst_index ins_specials next_class_inst_index all_class_specials type_heaps error - (memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, error) - = determine_types_of_instances x_main_dcl_module_n (inc inst_index) next_class_inst_index (next_mem_inst_index + class_size) mod_index all_class_specials - class_defs member_defs modules { instance_defs & [inst_index] = { instance_def & ins_specials = ins_specials }} type_heaps var_heap error - - = (memb_inst_defs1 ++ memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, error) - = ([], next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, error) + # {ins_class,ins_pos,ins_type,ins_specials, ins_is_generic} = instance_def + | ins_is_generic + # ({gen_member_name}, generic_defs, modules) = getGenericDef ins_class mod_index generic_defs modules + # ins_member = {ds_ident=gen_member_name, ds_arity= -1, ds_index = next_mem_inst_index} + # instance_def = { instance_def & ins_members = {ins_member}} + # class_size = 1 + # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap + # empty_st = + { st_vars = [] + , st_args = [] + , st_arity = -1 + , st_result = {at_type=TE, at_attribute=TA_None, at_annotation=AN_None} + , st_context = [] + , st_attr_vars = [] + , st_attr_env = [] + } + # memb_inst_def = MakeNewFunctionType gen_member_name 0 NoPrio empty_st ins_pos SP_None new_info_ptr + # memb_inst_defs1 = [memb_inst_def] + # (memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, generic_defs, modules, instance_defs, type_heaps, var_heap, error) + = determine_types_of_instances + x_main_dcl_module_n + (inc inst_index) + next_class_inst_index + (next_mem_inst_index + class_size) + mod_index + all_class_specials + class_defs + member_defs + generic_defs + modules + { instance_defs & [inst_index] = { instance_def & ins_specials = ins_specials }} + type_heaps + var_heap + error + = ( memb_inst_defs1 ++ memb_inst_defs2 + , next_mem_inst_index + , all_class_specials + , class_defs + , member_defs + , generic_defs + , modules + , instance_defs + , type_heaps + , var_heap + , error + ) + //---> ("determine_types_of_instances: generic ", gen_name, mod_index, inst_index, x_main_dcl_module_n) +// = abort "exporting generics is not yet supported\n" + # ({class_name, class_members}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules + class_size = size class_members + (ins_members, memb_inst_defs1, member_defs, modules, type_heaps, var_heap, error) + = determine_instance_symbols_and_types x_main_dcl_module_n next_mem_inst_index 0 mod_index ins_class.glob_module class_size class_members + ins_type ins_specials class_name ins_pos member_defs modules type_heaps var_heap error + instance_def = { instance_def & ins_members = { member \\ member <- ins_members }} + (ins_specials, next_class_inst_index, all_class_specials, type_heaps, error) + = check_instance_specials mod_index instance_def inst_index ins_specials next_class_inst_index all_class_specials type_heaps error + (memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, generic_defs, modules, instance_defs, type_heaps, var_heap, error) + = determine_types_of_instances x_main_dcl_module_n (inc inst_index) next_class_inst_index (next_mem_inst_index + class_size) mod_index all_class_specials + class_defs member_defs generic_defs modules { instance_defs & [inst_index] = { instance_def & ins_specials = ins_specials }} type_heaps var_heap error + + = (memb_inst_defs1 ++ memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, generic_defs, modules, instance_defs, type_heaps, var_heap, error) + = ([], next_mem_inst_index, all_class_specials, class_defs, member_defs, generic_defs, modules, instance_defs, type_heaps, var_heap, error) determine_instance_symbols_and_types :: !Index !Index !Index !Index !Index !Int !{#DefinedSymbol} !InstanceType !Specials Ident !Position !w:{#MemberDef} !u:{#DclModule} !*TypeHeaps !*VarHeap !*ErrorAdmin @@ -945,7 +999,6 @@ renumber_icl_definitions_as_dcl_definitions _ icl_decl_symbols modules cdefs icl = (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cClassDefs,decl_index]},cdefs) renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Generic, decl_index}) cdefs = (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cGenericDefs,decl_index]},cdefs) - ---> ("renumber_icl_decl_symbol: " +++ icl_decl_symbol.decl_ident.id_name) renumber_icl_decl_symbol icl_decl_symbol cdefs = (icl_decl_symbol,cdefs) # cdefs=reorder_common_definitions cdefs @@ -2409,11 +2462,12 @@ doSomeThingsThatHaveToBeDoneAfterTheWholeComponentHasBeenChecked mod_index nr_of_dcl_functions = size dcl_functions (memb_inst_defs, nr_of_dcl_functions_and_instances2, rev_spec_class_inst, - com_instance_defs, com_class_defs, com_member_defs, dcl_modules, hp_type_heaps, hp_var_heap, cs) + com_instance_defs, com_class_defs, com_member_defs, com_generic_defs, dcl_modules, hp_type_heaps, hp_var_heap, cs) = determineTypesOfInstances nr_of_dcl_functions mod_index (fst (memcpy dcl_common.com_instance_defs)) (fst (memcpy dcl_common.com_class_defs)) (fst (memcpy dcl_common.com_member_defs)) + (fst (memcpy dcl_common.com_generic_defs)) dcl_modules hp_type_heaps hp_var_heap { cs & cs_error = cs_error } heaps = { heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap } @@ -2438,12 +2492,14 @@ doSomeThingsThatHaveToBeDoneAfterTheWholeComponentHasBeenChecked mod_index -> adjust_instance_types_of_array_functions_in_std_array_dcl mod_index com_member_defs com_instance_defs dcl_functions cs dcl_mod - = { dcl_mod & + = { dcl_mod & dcl_functions = dcl_functions, dcl_specials = { ir_from = nr_of_dcl_functions_and_instances, ir_to = nr_of_dcl_funs_insts_and_specs }, - dcl_common = { dcl_common & com_instance_defs = com_instance_defs, - com_class_defs = com_class_defs, com_member_defs = com_member_defs }} + dcl_common = + { dcl_common & com_instance_defs = com_instance_defs, + com_class_defs = com_class_defs, com_member_defs = com_member_defs, + com_generic_defs = com_generic_defs }} dcl_modules = { dcl_modules & [mod_index] = dcl_mod } = (dcl_modules, heaps, cs) @@ -2677,10 +2733,15 @@ where = foldlArraySt (count_members_of_instance mod_index) com_instance_defs (0, com_class_defs, modules) = sum - count_members_of_instance mod_index {ins_class} (sum, com_class_defs, modules) - # ({class_members}, com_class_defs, modules) + count_members_of_instance mod_index {ins_class,ins_is_generic} (sum, com_class_defs, modules) +//AA.. + | ins_is_generic + = (1 + sum, com_class_defs, modules) + | otherwise +//..AA + # ({class_members}, com_class_defs, modules) = getClassDef ins_class mod_index com_class_defs modules - = (size class_members + sum, com_class_defs, modules) + = (size class_members + sum, com_class_defs, modules) // MV... adjust_predef_symbol predef_index mod_index symb_kind cs=:{cs_predef_symbols,cs_symbol_table,cs_error} diff --git a/frontend/checkKindCorrectness.icl b/frontend/checkKindCorrectness.icl index 49d285e..d0dd2e1 100644 --- a/frontend/checkKindCorrectness.icl +++ b/frontend/checkKindCorrectness.icl @@ -82,22 +82,27 @@ checkKindCorrectness icl_used_module_numbers main_dcl_module_n icl_instances com (check_kind_correctness_of_class_context_and_member_contexts common_defs com_member_defs) com_class_defs state = state - check_kind_correctness_of_instance common_defs {ins_class, ins_ident, ins_pos, ins_type} + check_kind_correctness_of_instance common_defs {ins_is_generic, ins_class, ins_ident, ins_pos, ins_type} (th_vars, td_infos, error_admin) - # {class_args} - = common_defs.[ins_class.glob_module].com_class_defs.[ins_class.glob_object.ds_index] - (expected_kinds, th_vars) - = mapSt get_tvi class_args th_vars - error_admin - = setErrorAdmin (newPosition ins_ident ins_pos) error_admin - th_vars - = foldSt init_type_var ins_type.it_vars th_vars - state - = unsafeFold3St possibly_check_kind_correctness_of_type expected_kinds [1..] - ins_type.it_types (th_vars, td_infos, error_admin) - state - = foldSt (check_kind_correctness_of_context common_defs) ins_type.it_context state - = state + | ins_is_generic + // kind correctness of user suppliedg eneric instances + // is checked during generic phase + = (th_vars, td_infos, error_admin) + | otherwise + # {class_args} + = common_defs.[ins_class.glob_module].com_class_defs.[ins_class.glob_object.ds_index] + (expected_kinds, th_vars) + = mapSt get_tvi class_args th_vars + error_admin + = setErrorAdmin (newPosition ins_ident ins_pos) error_admin + th_vars + = foldSt init_type_var ins_type.it_vars th_vars + state + = unsafeFold3St possibly_check_kind_correctness_of_type expected_kinds [1..] + ins_type.it_types (th_vars, td_infos, error_admin) + state + = foldSt (check_kind_correctness_of_context common_defs) ins_type.it_context state + = state possibly_check_kind_correctness_of_type TVI_Empty _ _ state // This can happen for stooopid classes like StdClass::Ord, where the member type is ignored at all = state diff --git a/frontend/frontend.icl b/frontend/frontend.icl index 44d4397..6486fdb 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -123,7 +123,10 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac // AA.. # error_admin = {ea_file = error, ea_loc = [], ea_ok = True } - # ti_common_defs = {{dcl_common \\ {dcl_common} <-: dcl_mods } & [main_dcl_module_n] = icl_common } + + # ti_common_defs = {dcl_common \\ {dcl_common} <-: dcl_mods } + # (saved_main_dcl_common, ti_common_defs) = replace ti_common_defs main_dcl_module_n icl_common + # (td_infos, type_heaps, error_admin) = analTypeDefs ti_common_defs icl_used_module_numbers type_heaps error_admin (fun_defs, th_vars, td_infos, error_admin) = checkKindCorrectness icl_used_module_numbers main_dcl_module_n icl_instances @@ -131,16 +134,19 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac type_heaps = { type_heaps & th_vars = th_vars } # heaps = { heaps & hp_type_heaps = type_heaps } - #! (components, ti_common_defs, fun_defs, generic_range, td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin) = + #! (components, ti_common_defs, fun_defs, generic_range, td_infos, heaps, hash_table, predef_symbols, dcl_mods, optional_dcl_icl_conversions, error_admin) = case SupportGenerics of True -> convertGenerics components main_dcl_module_n ti_common_defs fun_defs td_infos - heaps hash_table predef_symbols dcl_mods error_admin - False -> (components, ti_common_defs, fun_defs, {ir_to=0,ir_from=0}, td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin) - - - # icl_common = ti_common_defs.[main_dcl_module_n] - + heaps hash_table predef_symbols dcl_mods optional_dcl_icl_conversions error_admin + False -> (components, ti_common_defs, fun_defs, {ir_to=0,ir_from=0}, td_infos, heaps, hash_table, predef_symbols, dcl_mods, optional_dcl_icl_conversions, 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} + # dcl_mods = { {dcl_mod & dcl_common = common} \\ dcl_mod <-: dcl_mods & common <-: ti_common_defs } + # error = error_admin.ea_file #! ok = error_admin.ea_ok | not ok @@ -155,7 +161,7 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac # (fun_def_size, fun_defs) = usize fun_defs - # (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions") [ global_fun_range, icl_instances, icl_specials, generic_range] + # (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions") [ global_fun_range, icl_instances, icl_specials, generic_range] // (components, fun_defs, error) = showTypes components 0 fun_defs error // (components, fun_defs, error) = showComponents components 0 True fun_defs error @@ -202,6 +208,7 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac = convertImportedTypeSpecifications main_dcl_module_n dcl_mods imported_funs common_defs used_conses used_funs (dcl_types -*-> "Convert types") type_heaps var_heap # heaps = {hp_var_heap = var_heap, hp_expression_heap=expression_heap, hp_type_heaps=type_heaps} // (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 #! fe ={ fe_icl = @@ -233,7 +240,7 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac | dcl_index < dcl_table_size # icl_index = dcl_icl_conversions.[dcl_index] = update_conversion_array (inc dcl_index) dcl_table_size dcl_icl_conversions - { icl_conversions & [icl_index] = dcl_index } + { icl_conversions & [icl_index] = dcl_index } = icl_conversions fill_empty_positions next_index table_size next_new_index icl_conversions @@ -318,3 +325,29 @@ where # properties = { form_properties = cAttributed bitor cAnnotated, form_attr_position = No } (Yes ftype) = fun_def.fun_type = show_types funs fun_defs (file <<< fun_def.fun_symb <<< " :: " <:: (properties, ftype, No) <<< '\n' ) + +showDclModules :: !u:{#DclModule} !*File -> (!u:{#DclModule}, !*File) +showDclModules dcl_mods file + = show_dcl_mods 0 dcl_mods file +where + show_dcl_mods mod_index dcl_mods file + # (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] + # file = show_dcl_mod dcl_mod file + = (dcl_mods, file) + + show_dcl_mod {dcl_name, dcl_functions} file + # file = file <<< dcl_name <<< ":\n" + # file = show_dcl_functions 0 dcl_functions file + = file <<< "\n" + show_dcl_functions fun_index dcl_functions file + | fun_index == size dcl_functions + = file + | otherwise + # file = show_dcl_function dcl_functions.[fun_index] file + = show_dcl_functions (inc fun_index) dcl_functions file + show_dcl_function {ft_symb, ft_type} file + = file <<< ft_symb <<< " :: " <<< ft_type <<< "\n"
\ No newline at end of file diff --git a/frontend/generics.dcl b/frontend/generics.dcl index 8ee5187..47702e7 100644 --- a/frontend/generics.dcl +++ b/frontend/generics.dcl @@ -3,8 +3,8 @@ definition module generics import checksupport from transform import Group -convertGenerics :: !{!Group} !Int !{#CommonDefs} !*{# FunDef} !*TypeDefInfos !*Heaps !*HashTable !*PredefinedSymbols !u:{# DclModule} !*ErrorAdmin - -> (!{!Group}, !{#CommonDefs}, !*{# FunDef}, !IndexRange, !*TypeDefInfos, !*Heaps, !*HashTable, !*PredefinedSymbols, !u:{# DclModule}, !*ErrorAdmin) +convertGenerics :: !{!Group} !Int !{#CommonDefs} !*{# FunDef} !*TypeDefInfos !*Heaps !*HashTable !*PredefinedSymbols !u:{# DclModule} !(Optional {#Index}) !*ErrorAdmin + -> (!{!Group}, !{#CommonDefs}, !*{# FunDef}, !IndexRange, !*TypeDefInfos, !*Heaps, !*HashTable, !*PredefinedSymbols, !u:{# DclModule}, !(Optional {#Index}), !*ErrorAdmin) getGenericMember :: !(Global Index) !TypeKind !{#CommonDefs} -> (Bool, Global Index)
\ No newline at end of file diff --git a/frontend/generics.icl b/frontend/generics.icl index 5160b84..155dccc 100644 --- a/frontend/generics.icl +++ b/frontend/generics.icl @@ -11,29 +11,31 @@ import analtypes // whether to generate CONS // (needed for function that use CONS, like toString) -supportCons :== True +supportCons :== False // whether to bind _cons_info to actual constructor info // (needed for functions that create CONS, like fromString) supportConsInfo :== False && supportCons // whether generate missing alternatives -supportPartialInstances :== True - -:: *GenericState = { - gs_modules :: !*{#CommonDefs}, - gs_fun_defs :: !*{# FunDef}, - gs_groups :: !{!Group}, - gs_td_infos :: !*TypeDefInfos, - gs_gtd_infos :: !*GenericTypeDefInfos, - gs_heaps :: !*Heaps, - gs_main_dcl_module_n :: !Index, - gs_first_fun :: !Index, - gs_last_fun :: !Index, - gs_first_group :: !Index, - gs_last_group :: !Index, - gs_predefs :: !PredefinedSymbols, - gs_error :: !*ErrorAdmin +supportPartialInstances :== False + +:: *GenericState = + { gs_modules :: !*{#CommonDefs} + , gs_fun_defs :: !*{# FunDef} + , gs_groups :: !{!Group} + , gs_td_infos :: !*TypeDefInfos + , gs_gtd_infos :: !*GenericTypeDefInfos + , gs_heaps :: !*Heaps + , gs_main_dcl_module_n :: !Index + , gs_first_fun :: !Index + , gs_last_fun :: !Index + , gs_first_group :: !Index + , gs_last_group :: !Index + , gs_predefs :: !PredefinedSymbols + , gs_dcl_modules :: !*{#DclModule} + , gs_opt_dcl_icl_conversions :: !*(Optional !*{#Index}) + , gs_error :: !*ErrorAdmin } :: GenericTypeDefInfo @@ -71,13 +73,15 @@ EmptyGenericType :== instance toBool GenericTypeDefInfo where toBool GTDI_Empty = False - toBool (GTDI_Generic _) = True + toBool (GTDI_Generic _) = True -convertGenerics :: !{!Group} !Int !{#CommonDefs} !*{# FunDef} !*TypeDefInfos !*Heaps !*HashTable !*PredefinedSymbols !u:{# DclModule} !*ErrorAdmin - -> (!{!Group}, !{#CommonDefs}, !*{# FunDef}, !IndexRange, !*TypeDefInfos, !*Heaps, !*HashTable, !*PredefinedSymbols, !u:{# DclModule}, !*ErrorAdmin) +convertGenerics :: !{!Group} !Int !{#CommonDefs} !*{# FunDef} !*TypeDefInfos !*Heaps !*HashTable !*PredefinedSymbols !u:{# DclModule} !(Optional {#Index}) !*ErrorAdmin + -> (!{!Group}, !{#CommonDefs}, !*{# FunDef}, !IndexRange, !*TypeDefInfos, !*Heaps, !*HashTable, !*PredefinedSymbols, !u:{# DclModule}, !(Optional {#Index}), !*ErrorAdmin) convertGenerics groups main_dcl_module_n modules fun_defs td_infos heaps - hash_table predefs dcl_modules error + hash_table predefs dcl_modules + opt_dcl_icl_conversions + error #! (fun_defs_size, fun_defs) = usize fun_defs #! groups_size = size groups @@ -85,6 +89,7 @@ convertGenerics #! (predef_size, predefs) = usize predefs #! (gs_predefs, predefs) = arrayCopyBegin predefs predef_size + // determine sized of type def_infos: // ??? How to map 2-d unique array not so ugly ??? #! (td_infos_sizes, td_infos) = get_sizes 0 td_infos with @@ -97,83 +102,93 @@ convertGenerics = ([row_size : row_sizes], td_infos) #! gtd_infos = { createArray s GTDI_Empty \\ s <- td_infos_sizes } - #! gs = {gs_modules = {m \\m <-: modules}, // unique copy - gs_groups = groups, gs_fun_defs = fun_defs, - gs_td_infos = td_infos, - gs_gtd_infos = gtd_infos, - gs_heaps = heaps, - gs_main_dcl_module_n = main_dcl_module_n, - gs_first_fun = fun_defs_size, gs_last_fun = fun_defs_size, - gs_first_group = groups_size, gs_last_group = groups_size, - gs_predefs = gs_predefs, - gs_error = error} + #! gs = + { gs_modules = {m \\m <-: modules} // unique copy + , gs_groups = groups + , gs_fun_defs = fun_defs + , gs_td_infos = td_infos + , gs_gtd_infos = gtd_infos + , gs_heaps = heaps + , gs_main_dcl_module_n = main_dcl_module_n + , gs_first_fun = fun_defs_size + , gs_last_fun = fun_defs_size + , gs_first_group = groups_size + , gs_last_group = groups_size + , gs_predefs = gs_predefs + , gs_dcl_modules = { x \\ x <-: dcl_modules } // unique copy + , gs_opt_dcl_icl_conversions = + case opt_dcl_icl_conversions of + No -> No + Yes xs -> Yes {x \\ x <-: xs} // unique copy + , gs_error = error + } #! gs = collectInstanceKinds gs //---> "*** collect kinds used in generic instances and update generics with them" #! (ok,gs) = gs!gs_error.ea_ok | not ok - = return gs predefs hash_table dcl_modules + = return gs predefs hash_table #! gs = buildClasses gs //---> "*** build generic classes for all used kinds" #! (ok,gs) = gs!gs_error.ea_ok | not ok - = return gs predefs hash_table dcl_modules + = return gs predefs hash_table #! (generic_types, gs) = collectGenericTypes gs //---> "*** collect types of generics (needed for generic representation)" #! (ok,gs) = gs!gs_error.ea_ok | not ok - = return gs predefs hash_table dcl_modules + = return gs predefs hash_table #! (instance_types, gs) = convertInstances gs //---> "*** bind generic instances to classes and collect instance types" #! (ok,gs) = gs!gs_error.ea_ok | not ok - = return gs predefs hash_table dcl_modules + = return gs predefs hash_table #! (cons_funs, cons_groups, gs) = buildConsInstances gs | not ok //---> "*** bind function for CONS" - = return gs predefs hash_table dcl_modules + = return gs predefs hash_table #! (td_indexes, gs) = collectGenericTypeDefs generic_types instance_types gs //---> "*** collect type definitions for which a generic representation must be created" #! (ok,gs) = gs!gs_error.ea_ok | not ok - = return gs predefs hash_table dcl_modules + = return gs predefs hash_table #! (iso_funs, iso_groups, gs) = buildIsoFunctions td_indexes gs //---> "*** build isomorphisms for type definitions" #! (ok,gs) = gs!gs_error.ea_ok | not ok - = return gs predefs hash_table dcl_modules + = return gs predefs hash_table #! (isomap_type_funs, isomap_type_groups, gs) = buildIsomapsForTypeDefs td_indexes gs //---> "*** build maps for type definitions" #! (ok,gs) = gs!gs_error.ea_ok | not ok - = return gs predefs hash_table dcl_modules + = return gs predefs hash_table #! (isomap_gen_funs, isomap_gen_groups, gs) = buildIsomapsForGenerics gs //---> "*** build maps for generic function types" #! (ok,gs) = gs!gs_error.ea_ok | not ok - = return gs predefs hash_table dcl_modules + = return gs predefs hash_table #! (instance_funs, instance_groups, gs) = buildInstances gs //---> "*** build instances" #! (ok,gs) = gs!gs_error.ea_ok | not ok - = return gs predefs hash_table dcl_modules + = return gs predefs hash_table #! (star_funs, star_groups, gs) = buildKindConstInstances gs //---> "*** build shortcut instances for kind *" #! (ok,gs) = gs!gs_error.ea_ok | not ok - = return gs predefs hash_table dcl_modules + = return gs predefs hash_table // the order in the lists below is important! // Indexes are allocated in that order. @@ -184,36 +199,37 @@ convertGenerics //---> "*** add geenrated functions" #! (ok,gs) = gs!gs_error.ea_ok | not ok - = return gs predefs hash_table dcl_modules + = return gs predefs hash_table #! gs = determineMemberTypes 0 0 gs //---> "*** determine types of member instances" #! (ok,gs) = gs!gs_error.ea_ok | not ok - = return gs predefs hash_table dcl_modules + = return gs predefs hash_table //| True // = abort "-----------------\n" - #! {gs_modules, gs_groups, gs_fun_defs, gs_td_infos, - gs_heaps, - gs_error} = gs + # { gs_modules, gs_groups, gs_fun_defs, gs_td_infos, gs_heaps, gs_dcl_modules, + gs_opt_dcl_icl_conversions, + gs_error} + = gs #! {hte_symbol_heap} = hash_table - #! cs = { - cs_symbol_table = hte_symbol_heap, - cs_predef_symbols = predefs, - cs_error = gs_error, - cs_x= { - x_needed_modules = 0, - x_main_dcl_module_n = main_dcl_module_n, - x_is_dcl_module = False, - x_type_var_position = 0 + #! cs = + { cs_symbol_table = hte_symbol_heap + , cs_predef_symbols = predefs + , cs_error = gs_error + , cs_x = + { x_needed_modules = 0 + , x_main_dcl_module_n = main_dcl_module_n + , x_is_dcl_module = False + , x_type_var_position = 0 } } - #! (dcl_modules, gs_modules, gs_heaps, cs) = - create_class_dictionaries 0 dcl_modules gs_modules gs_heaps cs + #! (gs_dcl_modules, gs_modules, gs_heaps, cs) = + create_class_dictionaries 0 gs_dcl_modules gs_modules gs_heaps cs // create_class_dictionaries1 main_dcl_module_n dcl_modules gs_modules gs_heaps cs //---> "*** create class dictionaries" @@ -223,11 +239,14 @@ convertGenerics #! index_range = {ir_from = gs.gs_first_fun, ir_to = gs.gs_last_fun} = ( gs_groups, gs_modules, gs_fun_defs, index_range, gs_td_infos, gs_heaps, hash_table, - cs_predef_symbols, dcl_modules, cs_error) + cs_predef_symbols, gs_dcl_modules, gs_opt_dcl_icl_conversions, cs_error) where - return {gs_modules, gs_groups, gs_fun_defs, gs_td_infos, gs_gtd_infos, gs_heaps, gs_main_dcl_module_n, gs_error} predefs hash_table dcl_modules + return { gs_modules, gs_groups, gs_fun_defs, gs_td_infos, gs_gtd_infos, + gs_heaps, gs_main_dcl_module_n, gs_dcl_modules, gs_opt_dcl_icl_conversions, gs_error} + predefs hash_table = ( gs_groups, gs_modules, gs_fun_defs, {ir_from=0,ir_to=0}, - gs_td_infos, gs_heaps, hash_table, predefs, dcl_modules, gs_error) + gs_td_infos, gs_heaps, hash_table, predefs, gs_dcl_modules, + gs_opt_dcl_icl_conversions, gs_error) create_class_dictionaries module_index dcl_modules modules heaps cs #! size_of_modules = size modules @@ -321,7 +340,7 @@ where #! instance_def = { instance_def & ins_class = {glob_module=ins_class.glob_module, glob_object=class_ds} - , ins_ident = makeIdent (ins_ident.id_name +++ ":" +++ (toString kind)) + , ins_ident = makeIdent ins_ident.id_name } #! (is_partial, gs_fun_defs) = check_if_partial instance_def gs_predefs gs_fun_defs @@ -333,7 +352,8 @@ where , gs_modules = gs_modules , gs_fun_defs = gs_fun_defs , gs_heaps = gs_heaps - , gs_error = gs_error } + , gs_error = gs_error + } = ([], instance_defs, gs) #! gs_heaps = check_cons_instance generic_def instance_def it_type gs_predefs gs_heaps @@ -455,10 +475,10 @@ where = (True, gs_modules, gs_error) # (class_def=:{class_members}, gs_modules) = - getClassDef glob_module glob_object.ds_index gs_modules + getClassDef glob_module glob_object.ds_index gs_modules # (member_def, gs_modules) = getMemberDef glob_module class_def.class_members.[0].ds_index gs_modules - | member_def.me_type.st_arity <> instance_def.ins_members.[0].ds_arity + | member_def.me_type.st_arity <> instance_def.ins_members.[0].ds_arity && instance_def.ins_members.[0].ds_arity <> (-1) # gs_error = checkErrorWithIdentPos (newPosition ins_ident ins_pos) "generic instance function has incorrect arity" gs_error = (False, gs_modules, gs_error) = (True, gs_modules, gs_error) @@ -475,7 +495,7 @@ where # (generic_defs, gs_modules) = gs_modules ! [module_index].com_generic_defs #! size_generic_defs = size generic_defs | generic_index == size_generic_defs - = collect_in_modules (inc module_index) 0 gs_modules + = collect_in_modules (inc module_index) 0 gs_modules # {gen_type={gt_type={st_args, st_result}}} = generic_defs . [generic_index] # (types, gs_modules) = collect_in_modules module_index (inc generic_index) gs_modules = ([at_type \\ {at_type} <- [st_result:st_args]] ++ types, gs_modules) @@ -1167,9 +1187,69 @@ where = ([], [], instance_defs, gs) | instance_def.ins_generate - #! (fun_def, fun_def_sym, gs) = build_instance_fun instance_def gs + #! (fun_def, fun_def_sym, gs) = build_instance_fun instance_def gs #! instance_def = { instance_def & ins_members = {fun_def_sym} } #! instance_defs = {instance_defs & [instance_index] = instance_def} + + # (dcl_fun_index, gs) = get_dcl_member_index instance_index gs + with + get_dcl_member_index icl_instance_index gs=:{gs_dcl_modules, gs_main_dcl_module_n} + # ({dcl_conversions, dcl_common}, gs_dcl_modules) = gs_dcl_modules![gs_main_dcl_module_n] + # gs = {gs & gs_dcl_modules = gs_dcl_modules} + # dcl_index = case dcl_conversions of + No -> NoIndex + Yes conversion_table + # instance_table = conversion_table.[cInstanceDefs] + # dcl_instance_index = find_dcl_instance_index icl_instance_index 0 instance_table + | dcl_instance_index == NoIndex + -> NoIndex + | otherwise + # dcl_instance = dcl_common.com_instance_defs.[dcl_instance_index] + # dcl_index = dcl_instance.ins_members.[0].ds_index + -> dcl_index + = (dcl_index, gs) + where + find_dcl_instance_index icl_instance_index index instance_table + | index == size instance_table + = NoIndex + | instance_table.[index] == icl_instance_index + = index + | otherwise + = find_dcl_instance_index icl_instance_index (inc index) instance_table + + # gs = case dcl_fun_index of + NoIndex -> gs + _ + # gs = update_dcl_icl_conversions dcl_fun_index fun_def_sym.ds_index gs + # gs = update_dcl_fun_conversions module_index dcl_fun_index fun_def_sym.ds_index gs + -> gs + with + update_dcl_icl_conversions dcl_index icl_index gs=:{gs_opt_dcl_icl_conversions=No} + = gs + update_dcl_icl_conversions dcl_index icl_index gs=:{gs_opt_dcl_icl_conversions=Yes cs} + #! (table_size, cs) = usize cs + | dcl_index < table_size + = {gs & gs_opt_dcl_icl_conversions=Yes {cs & [dcl_index] = icl_index}} + //---> ("update dcl-to-icl conversion table", dcl_index, icl_index) + = {gs & gs_opt_dcl_icl_conversions=Yes cs} + //---> ("update dcl-to-icl conversion table: index does not fit", dcl_index, icl_index) + + update_dcl_fun_conversions module_index dcl_index icl_index gs=:{gs_dcl_modules} + # (dcl_module=:{dcl_conversions}, gs_dcl_modules) = gs_dcl_modules ! [module_index] + # dcl_conversions = case dcl_conversions of + No -> No + Yes table + # fun_table = table.[cFunctionDefs] + # (size_fun_table, fun_table) = usize fun_table + | dcl_index < size_fun_table + # fun_table = {x \\ x <-: fun_table} + # fun_table = {fun_table & [dcl_index] = icl_index} + -> Yes {{x\\x<-:table} & [cFunctionDefs] = fun_table} + | otherwise + -> Yes table + # dcl_module = { dcl_module & dcl_conversions = dcl_conversions} + = {gs & gs_dcl_modules = {gs_dcl_modules & [module_index] = dcl_module }} + = ([fun_def], [{group_members = [fun_def.fun_index]}], instance_defs, gs) | supportPartialInstances && instance_def.ins_partial @@ -1250,11 +1330,10 @@ where = (instance_def, new_ins_fun_def, {gs & gs_fun_defs = gs_fun_defs, gs_heaps = gs_heaps}) build_instance_fun instance_def gs=:{gs_modules} - # {ins_class, ins_generic} = instance_def + # {ins_class, ins_generic} = instance_def # (class_def, gs_modules) = getClassDef ins_class.glob_module ins_class.glob_object.ds_index gs_modules # (member_def, gs_modules) = getMemberDef ins_class.glob_module class_def.class_members.[0].ds_index gs_modules # (generic_def, gs_modules) = getGenericDef ins_generic.glob_module ins_generic.glob_object gs_modules - # (fun_index, group_index, gs) = newFunAndGroupIndex {gs & gs_modules=gs_modules} # fun_def_sym = { ds_ident = instance_def.ins_ident, @@ -1278,7 +1357,7 @@ buildKindConstInstances gs where build_modules :: !Index !*GenericState -> (![FunDef], ![Group], !*GenericState) - build_modules module_index gs=:{gs_modules} + build_modules module_index gs=:{gs_modules, gs_main_dcl_module_n} #! num_modules = size gs_modules | module_index == num_modules @@ -1289,9 +1368,15 @@ where # {gs_modules} = gs // add instances +/* # (common_defs=:{com_instance_defs}, gs_modules) = gs_modules ! [module_index] # com_instance_defs = arrayPlusList com_instance_defs instance_defs # gs_modules = { gs_modules & [module_index] = {common_defs & com_instance_defs = com_instance_defs}} +*/ + # (common_defs=:{com_instance_defs}, gs_modules) = gs_modules ! [gs_main_dcl_module_n] + # com_instance_defs = arrayPlusList com_instance_defs instance_defs + # gs_modules = { gs_modules & [gs_main_dcl_module_n] = {common_defs & com_instance_defs = com_instance_defs}} + = (new_funs ++ funs, new_groups ++ groups, {gs & gs_modules = gs_modules}) build_instances :: !Index !Index !*GenericState @@ -1313,7 +1398,7 @@ where # { ins_ident, ins_type, ins_pos, ins_generate, ins_is_generic, ins_generic} = instance_def - | not (/*ins_generate &&*/ ins_is_generic) + | not (ins_is_generic) = ([], [], [], {gs & gs_td_infos = gs_td_infos, gs_modules = gs_modules, gs_heaps = gs_heaps}) # it_type = hd ins_type.it_types @@ -1410,7 +1495,7 @@ where determineMemberTypes :: !Index !Index !*GenericState -> !*GenericState determineMemberTypes module_index ins_index - gs=:{gs_modules, gs_fun_defs, gs_heaps=gs_heaps=:{hp_var_heap, hp_type_heaps}} + gs=:{gs_modules, gs_fun_defs, gs_heaps=gs_heaps=:{hp_var_heap, hp_type_heaps}, gs_dcl_modules, gs_main_dcl_module_n} # (num_modules, gs_modules) = usize gs_modules | module_index == num_modules = {gs & gs_modules = gs_modules} @@ -1421,34 +1506,95 @@ determineMemberTypes module_index ins_index | not instance_def.ins_is_generic = determineMemberTypes module_index (inc ins_index) {gs & gs_modules = gs_modules} - # {ins_class, ins_type, ins_members} = instance_def - # (class_def, gs_modules) = getClassDef ins_class.glob_module ins_class.glob_object.ds_index gs_modules - # (member_def, gs_modules) = getMemberDef ins_class.glob_module class_def.class_members.[0].ds_index gs_modules - # {me_type, me_class_vars} = member_def - + # gs = determine_member_type module_index ins_index instance_def {gs & gs_modules = gs_modules} + = determineMemberTypes module_index (inc ins_index) gs +where + determine_member_type + module_index + ins_index + {ins_ident, ins_class, ins_type, ins_members} + gs=:{ gs_modules, + gs_fun_defs, + gs_heaps=gs_heaps=:{hp_var_heap, hp_type_heaps}, + gs_dcl_modules, + gs_main_dcl_module_n, + gs_opt_dcl_icl_conversions} + # (class_def, gs_modules) = getClassDef ins_class.glob_module ins_class.glob_object.ds_index gs_modules + # (member_def, gs_modules) = getMemberDef ins_class.glob_module class_def.class_members.[0].ds_index gs_modules + # {me_type, me_class_vars} = member_def + + // determine type of the instance function + # (symbol_type, _, hp_type_heaps, _, _) = + determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None hp_type_heaps No No + # (st_context, hp_var_heap) = initializeContextVariables symbol_type.st_context hp_var_heap + # symbol_type = {symbol_type & st_context = st_context} + + // determine the instance function index (in icl or dcl) + # fun_index = ins_members.[0].ds_index + | fun_index == NoIndex + = abort "no generic instance function\n" - // determine type of the member instance - # (symbol_type, _, hp_type_heaps, _, _) = - determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None hp_type_heaps No No - # (st_context, hp_var_heap) = initializeContextVariables symbol_type.st_context hp_var_heap - # symbol_type = {symbol_type & st_context = st_context} - - // update the instance function - # fun_index = ins_members.[0].ds_index - # (fun_def, gs_fun_defs) = gs_fun_defs![fun_index] - # fun_def = {fun_def & fun_type = (Yes symbol_type)} - - # gs_fun_defs = {gs_fun_defs & [fun_index] = fun_def} - - # gs = { gs & - gs_modules = gs_modules, - gs_fun_defs = gs_fun_defs, - gs_heaps = {gs_heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap} - } - - = determineMemberTypes module_index (inc ins_index) gs + // update the instance function + | module_index == gs_main_dcl_module_n // icl module + # (fun_def, gs_fun_defs) = gs_fun_defs![fun_index] + # fun_def = { fun_def & fun_type = Yes symbol_type } + # gs_fun_defs = {gs_fun_defs & [fun_index] = fun_def} + + // update corresponding DCL function type, which is empty at the moment + # ({dcl_conversions}, gs_dcl_modules) = gs_dcl_modules ! [gs_main_dcl_module_n] + # (dcl_fun_index, gs_opt_dcl_icl_conversions) + = find_dcl_fun_index fun_index gs_opt_dcl_icl_conversions// XXX + with + find_dcl_fun_index icl_fun_index No + = (NoIndex /*abort "no dcl_icl conversions table\n"*/, No) + find_dcl_fun_index icl_fun_index (Yes table) + #! table1 = {x\\x<-:table} + = find_index 0 icl_fun_index table + find_index i index table + # (size_table, table) = usize table + | i == size_table + = (NoIndex /*abort ("not found dcl function index " +++ toString index)*/, Yes table) + # (x, table) = table ! [i] + | x == index + = (i /*abort ("found dcl function index " +++ toString index +++ " " +++ toString i)*/, Yes table) + = find_index (inc i) index table + + + # gs_dcl_modules = case dcl_fun_index of + NoIndex -> gs_dcl_modules + _ -> update_dcl_fun_type gs_main_dcl_module_n dcl_fun_index symbol_type gs_dcl_modules + + = { gs + & gs_modules = gs_modules + , gs_fun_defs = gs_fun_defs + , gs_dcl_modules = gs_dcl_modules + , gs_opt_dcl_icl_conversions = gs_opt_dcl_icl_conversions + , gs_heaps = {gs_heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap} + } + | otherwise // dcl module + //---> ("update dcl instance function", ins_ident, module_index, ins_index, symbol_type) + # gs_dcl_modules = update_dcl_fun_type module_index fun_index symbol_type gs_dcl_modules + = { gs + & gs_modules = gs_modules + , gs_dcl_modules = gs_dcl_modules + , gs_heaps = {gs_heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap} + } + + update_dcl_fun_type module_index fun_index symbol_type dcl_modules + # (dcl_module=:{dcl_functions}, dcl_modules) = dcl_modules ! [module_index] + # (dcl_fun, dcl_functions) = dcl_functions ! [fun_index] + # dcl_fun = + { dcl_fun + & ft_arity = symbol_type.st_arity + , ft_type = symbol_type + } + # dcl_functions = {{x \\ x <-: dcl_functions} & [fun_index] = dcl_fun} + # dcl_module={dcl_module & dcl_functions = dcl_functions} + = {dcl_modules & [module_index] = dcl_module} + + kindOfTypeDef :: Index Index !*TypeDefInfos -> (!TypeKind, !*TypeDefInfos) kindOfTypeDef module_index td_index td_infos # ({tdi_kinds}, td_infos) = td_infos![module_index, td_index] @@ -3154,7 +3300,7 @@ copyExpr expr heaps=:{hp_var_heap, hp_expression_heap} = (expr, {heaps & hp_var_heap = us_var_heap, hp_expression_heap = us_symbol_heap}) //---> ("copy Expr") -//mapExprSt :: (Expression .st->(Expression, .st)) Expression .st -> (Expression, .st) +mapExprSt :: !(Expression -> w:st -> u:(Expression, w:st)) !Expression w:st -> v:(Expression, w:st), [v<=w,u<=v] mapExprSt f (App app=:{app_args}) st # (app_args, st) = mapSt (mapExprSt f) app_args st = f (App { app & app_args = app_args }) st |