diff options
| -rw-r--r-- | frontend/check.icl | 21 | ||||
| -rw-r--r-- | frontend/checkKindCorrectness.dcl | 4 | ||||
| -rw-r--r-- | frontend/checkKindCorrectness.icl | 261 | ||||
| -rw-r--r-- | frontend/checksupport.dcl | 1 | ||||
| -rw-r--r-- | frontend/checksupport.icl | 1 | ||||
| -rw-r--r-- | frontend/frontend.icl | 25 | ||||
| -rw-r--r-- | frontend/generics.icl | 6 | ||||
| -rw-r--r-- | frontend/parse.icl | 9 | ||||
| -rw-r--r-- | frontend/predef.icl | 3 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 1 | ||||
| -rw-r--r-- | frontend/syntax.icl | 1 |
11 files changed, 220 insertions, 113 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 016a00b..ce0e296 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -365,7 +365,7 @@ where //| 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 } + # cs = { cs & cs_error = checkError gen_name "generic instance must have one member" cs.cs_error } = (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs) # member_name = ins_members.[0].ds_ident | member_name <> gen_member_name @@ -385,6 +385,7 @@ where = (instance_types, member_defs, type_defs, modules, var_heap, type_heaps, cs) # ins_member = ins_members.[mem_offset] class_member = class_members.[mem_offset] + cs = setErrorAdmin (newPosition class_name ins_pos) cs | ins_member.ds_ident <> class_member.ds_ident = check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members class_name ins_pos ins_type instance_types member_defs type_defs modules var_heap type_heaps @@ -394,10 +395,8 @@ where instance_types member_defs type_defs modules var_heap type_heaps { cs & cs_error = checkError class_member.ds_ident "used with wrong arity" cs.cs_error} # ({me_symb, me_type,me_class_vars,me_pos}, member_defs, modules) = getMemberDef member_mod_index class_member.ds_index module_index member_defs modules - cs_error = pushErrorAdmin (newPosition class_name ins_pos) cs.cs_error (instance_type, _, type_heaps, Yes (modules, type_defs), Yes cs_error) - = determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None type_heaps (Yes (modules, type_defs, x_main_dcl_module_n)) (Yes cs_error) - cs_error = popErrorAdmin cs_error + = determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None type_heaps (Yes (modules, type_defs, x_main_dcl_module_n)) (Yes cs.cs_error) (st_context, var_heap) = initializeContextVariables instance_type.st_context var_heap = check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members class_name ins_pos ins_type [ (ins_member.ds_index, { instance_type & st_context = st_context }) : instance_types ] member_defs type_defs modules var_heap type_heaps { cs & cs_error = cs_error } @@ -1332,8 +1331,7 @@ checkDclModules imports_of_icl_mod dcl_modules icl_functions heaps cs=:{cs_symbo = { ini_symbol_nr = nr_of_expl_imp_symbols, ini_imp_decl = imp_decl } -> ([ident:expl_imp_symbols_accu], nr_of_expl_imp_symbols+1, [ini:expl_imp_indices_accu], cs_symbol_table) - -//import StdDebug + checkDclComponent :: !{![Int]} !{![Int]} ![[(Index, Position, [ImportNrAndIdents])]] ![Int] !(!Int, !*ExplImpInfos, !*{# DclModule}, !*{# FunDef}, !*Heaps,!*CheckState) @@ -1523,7 +1521,8 @@ checkDclModuleWithinComponent dcl_imported_module_numbers component_nr is_on_cyc checkModule :: !ScannedModule !IndexRange ![FunDef] !Int !Int !(Optional ScannedModule) ![ScannedModule] !{#DclModule} !{#FunDef} !*PredefinedSymbols !*SymbolTable !*File !*Heaps -> (!Bool, *IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !.{#FunDef},!Int, !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File, [String]) -checkModule m icl_global_function_range fun_defs n_functions_and_macros_in_dcl_modules dcl_module_n_in_cache optional_dcl_mod scanned_modules dcl_modules functions_and_macros predef_symbols symbol_table err_file heaps +checkModule m icl_global_function_range fun_defs n_functions_and_macros_in_dcl_modules dcl_module_n_in_cache + optional_dcl_mod scanned_modules dcl_modules functions_and_macros predef_symbols symbol_table err_file heaps // | False--->("checkModule", m.mod_name) // = undef # (optional_pre_def_mod,predef_symbols) @@ -1562,7 +1561,10 @@ check_module1 {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cde init_new_dcl_modules = gimme_a_strict_array_type { initialDclModule scanned_module module_n \\ scanned_module <- scanned_modules & module_n<-[size dcl_modules..]} - init_dcl_modules = {if (i<size dcl_modules) dcl_modules.[i] init_new_dcl_modules.[i-size dcl_modules] \\ i<-[0..size dcl_modules+size init_new_dcl_modules-1]} + init_dcl_modules = { if (i<size dcl_modules) + { dcl_modules.[i] & dcl_is_cashed = True } + init_new_dcl_modules.[i-size dcl_modules] + \\ i<-[0..size dcl_modules+size init_new_dcl_modules-1]} = (mod_name,mod_imported_objects,mod_imports,mod_type,icl_global_function_range,nr_of_functions,first_inst_index,local_defs,icl_functions,init_dcl_modules,main_dcl_module_n,cdefs,sizes,cs) where @@ -2162,7 +2164,8 @@ initialDclModule ({mod_name, mod_defs=mod_defs=:{def_funtypes,def_macros}, mod_t , dcl_is_system = case mod_type of MK_System -> True _ -> False - , dcl_imported_module_numbers = EndNumbers + , dcl_imported_module_numbers = EndNumbers + , dcl_is_cashed = False } addImportedSymbolsToSymbolTable importing_mod opt_macro_range modules_in_component_set imports_ikh diff --git a/frontend/checkKindCorrectness.dcl b/frontend/checkKindCorrectness.dcl index 94bd8d1..26ebb28 100644 --- a/frontend/checkKindCorrectness.dcl +++ b/frontend/checkKindCorrectness.dcl @@ -2,5 +2,5 @@ definition module checkKindCorrectness import syntax, checksupport, containers -checkKindCorrectness :: !NumberSet !Index IndexRange !{#CommonDefs} !{#DclModule} !u:{# FunDef} !*TypeVarHeap !*TypeDefInfos !*ErrorAdmin - -> (!u:{# FunDef}, !*TypeVarHeap, !*TypeDefInfos, !*ErrorAdmin) +checkKindCorrectness :: !Index IndexRange !u:{# FunDef} !{#CommonDefs} !*{#DclModule} !*TypeVarHeap !*TypeDefInfos !*ErrorAdmin + -> (!u:{# FunDef}, !*{#DclModule}, !*TypeVarHeap, !*TypeDefInfos, !*ErrorAdmin) diff --git a/frontend/checkKindCorrectness.icl b/frontend/checkKindCorrectness.icl index d0dd2e1..f48cfcb 100644 --- a/frontend/checkKindCorrectness.icl +++ b/frontend/checkKindCorrectness.icl @@ -5,55 +5,83 @@ import syntax, containers, checksupport, utilities // import RWSDebug -checkKindCorrectness :: !NumberSet !Index IndexRange !{#CommonDefs} !{#DclModule} !u:{# FunDef} !*TypeVarHeap !*TypeDefInfos !*ErrorAdmin - -> (!u:{# FunDef}, !*TypeVarHeap, !*TypeDefInfos, !*ErrorAdmin) -checkKindCorrectness icl_used_module_numbers main_dcl_module_n icl_instances common_defs dcl_mods - fun_defs th_vars td_infos error_admin - #! n_fun_defs = size fun_defs - # (th_vars, td_infos, error_admin) +checkKindCorrectness :: !Index IndexRange !u:{# FunDef} !{#CommonDefs} !*{#DclModule} !*TypeVarHeap !*TypeDefInfos !*ErrorAdmin + -> (!u:{# FunDef}, !*{#DclModule}, !*TypeVarHeap, !*TypeDefInfos, !*ErrorAdmin) +checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs + dcl_mods th_vars td_infos error_admin + #! n_fun_defs + = size fun_defs + size_dcl_mods + = size dcl_mods + # (bv_cashed_modules, dcl_mods) + = iFoldSt mark_cashed_module + 0 size_dcl_mods (bitvectCreate size_dcl_mods, dcl_mods) + (dcl_mods, th_vars, td_infos, error_admin) = iFoldSt (\mod_index state - -> if (inNumberSet mod_index icl_used_module_numbers) - (check_kind_correctness_of_classes common_defs common_defs.[mod_index] state) - state) - 0 (size dcl_mods) (th_vars, td_infos, error_admin) - th_vars = th_vars - (th_vars, td_infos, error_admin) + -> if (bitvectSelect mod_index bv_cashed_modules) + state + (check_kind_correctness_of_classes mod_index state)) + 0 size_dcl_mods (dcl_mods, th_vars, td_infos, error_admin) + icl_common_defs + = common_defs.[main_dcl_module_n] + (_, th_vars, td_infos, error_admin) + = foldrArraySt (check_kind_correctness_of_class icl_common_defs.com_member_defs) + icl_common_defs.com_class_defs + ([], th_vars, td_infos, error_admin) + bv_uninitialized_mods + = {el\\el<-:bv_cashed_modules} + (bv_uninitialized_mods, th_vars, td_infos, error_admin) = iFoldSt (\mod_index state - -> if (inNumberSet mod_index icl_used_module_numbers) + -> if (bitvectSelect mod_index bv_cashed_modules) + state (check_kind_correctness_of_instances_and_class_and_member_contexts - common_defs common_defs.[mod_index] state) - state) - 0 (size dcl_mods) (th_vars, td_infos, error_admin) + common_defs common_defs.[mod_index] state)) + 0 size_dcl_mods (bv_uninitialized_mods, th_vars, td_infos, error_admin) // check_kind_correctness_of_icl_function: don't check the types that were generated for instances - th_vars = th_vars state - = iFoldSt check_kind_correctness_of_icl_function 0 icl_instances.ir_from - (fun_defs, th_vars, td_infos, error_admin) - (fun_defs, th_vars, td_infos, error_admin) - = iFoldSt check_kind_correctness_of_icl_function icl_instances.ir_to n_fun_defs state - th_vars = th_vars - (th_vars, td_infos, error_admin) + = iFoldSt (check_kind_correctness_of_icl_function common_defs) 0 icl_instances.ir_from + (fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin) + (fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin) + = iFoldSt (check_kind_correctness_of_icl_function common_defs) icl_instances.ir_to n_fun_defs state + (dcl_mods, bv_uninitialized_mods, th_vars, td_infos, error_admin) = iFoldSt (\mod_index state - -> if (inNumberSet mod_index icl_used_module_numbers && mod_index<>main_dcl_module_n) - (check_kind_correctness_of_dcl_functions common_defs dcl_mods.[mod_index] - state) - state) - 0 (size dcl_mods) - (th_vars, td_infos, error_admin) - th_vars = th_vars - = (fun_defs, th_vars, td_infos, error_admin) + -> if (bitvectSelect mod_index bv_cashed_modules || mod_index==main_dcl_module_n) + state + (check_kind_correctness_of_dcl_functions common_defs mod_index state)) + 0 size_dcl_mods + (dcl_mods, bv_uninitialized_mods, th_vars, td_infos, error_admin) + = (fun_defs, dcl_mods, th_vars, td_infos, error_admin) where - check_kind_correctness_of_classes common_defs {com_class_defs, com_member_defs} state - = foldlArraySt (check_kind_correctness_of_class common_defs com_member_defs) com_class_defs state - check_kind_correctness_of_class common_defs com_member_defs {class_name, class_args, class_members} - (th_vars, td_infos, error_admin) + mark_cashed_module mod_index (bitvect, dcl_mods) + | dcl_mods.[mod_index].dcl_is_cashed + = (bitvectSet mod_index bitvect, dcl_mods) + = (bitvect, dcl_mods) + + check_kind_correctness_of_classes mod_index (dcl_mods, th_vars, td_infos, error_admin) + # (dcl_mod, dcl_mods) + = dcl_mods![mod_index] + {com_class_defs, com_member_defs} + = dcl_mod.dcl_common + (class_defs_with_cacheable_kind_info, th_vars, td_infos, error_admin) + = foldrArraySt (check_kind_correctness_of_class com_member_defs) com_class_defs + ([], th_vars, td_infos, error_admin) + dcl_mods + = { dcl_mods & [mod_index].dcl_common.com_class_defs + = { el \\ el <- class_defs_with_cacheable_kind_info }} + = (dcl_mods, th_vars, td_infos, error_admin) + check_kind_correctness_of_class com_member_defs class_def=:{class_name, class_args, class_members} + (class_defs_accu, th_vars, td_infos, error_admin) # th_vars = foldSt init_type_var class_args th_vars - = foldlArraySt (\{ds_index} state - -> check_kind_correctness_of_member_without_context common_defs class_args - com_member_defs.[ds_index] state) - class_members (th_vars, td_infos, error_admin) - check_kind_correctness_of_member_without_context common_defs class_args + (th_vars, td_infos, error_admin) + = foldlArraySt (\{ds_index} state + -> check_kind_correctness_of_member_without_context class_args + com_member_defs.[ds_index] state) + class_members (th_vars, td_infos, error_admin) + (derived_kinds, th_vars) + = mapFilterYesSt get_opt_kind class_args th_vars + = ([{ class_def & class_arg_kinds = derived_kinds }:class_defs_accu], th_vars, td_infos, error_admin) + check_kind_correctness_of_member_without_context class_args {me_symb, me_pos, me_class_vars, me_type=me_type=:{st_vars, st_args, st_result}} (th_vars, td_infos, error_admin) # error_admin @@ -83,72 +111,115 @@ checkKindCorrectness icl_used_module_numbers main_dcl_module_n icl_instances com com_class_defs state = state check_kind_correctness_of_instance common_defs {ins_is_generic, ins_class, ins_ident, ins_pos, ins_type} - (th_vars, td_infos, error_admin) + (bv_uninitialized_mods, th_vars, td_infos, error_admin) | ins_is_generic - // kind correctness of user suppliedg eneric instances + // kind correctness of user supplied generic 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 + = (bv_uninitialized_mods, th_vars, td_infos, error_admin) + # (expected_kinds, bv_uninitialized_mods, th_vars) + = get_expected_kinds ins_class common_defs bv_uninitialized_mods th_vars + error_admin + = setErrorAdmin (newPosition ins_ident ins_pos) error_admin + th_vars + = foldSt init_type_var ins_type.it_vars th_vars + (th_vars, td_infos, error_admin) + = 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 + (bv_uninitialized_mods, th_vars, td_infos, error_admin) + = state + + get_expected_kinds class_index=:{glob_module, glob_object} common_defs bv_uninitialized_mods th_vars + | bitvectSelect glob_module bv_uninitialized_mods + /* the desired class is defined in a module which is a cached one + => check_kind_correctness_of_classes has not been called for all the classes + within that module + => the kind information for the class args is not in the heap + => put it in the heap now + */ + # th_vars + = foldlArraySt write_kind_info common_defs.[glob_module].com_class_defs th_vars + = get_expected_kinds class_index common_defs (bitvectReset glob_module bv_uninitialized_mods) + th_vars + # {class_args, class_arg_kinds} + = common_defs.[glob_module].com_class_defs.[glob_object.ds_index] + (expected_kinds, th_vars) + = mapSt get_tvi class_args th_vars + = (expected_kinds, bv_uninitialized_mods, th_vars) + + write_kind_info {class_name, class_args, class_arg_kinds} th_vars + = write_ki class_args class_arg_kinds th_vars + + write_ki [{tv_info_ptr}:class_args] [class_arg_kind:class_arg_kinds] th_vars + = write_ki class_args class_arg_kinds (writePtr tv_info_ptr (TVI_Kind class_arg_kind) th_vars) + write_ki [{tv_info_ptr}:class_args] [] th_vars + = write_ki class_args [] (writePtr tv_info_ptr TVI_Empty th_vars) + write_ki [] [] th_vars + = th_vars + 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 possibly_check_kind_correctness_of_type (TVI_Kind expected_kind) arg_nr type state = check_kind_correctness_of_type expected_kind arg_nr type state check_kind_correctness_of_class_context_and_member_contexts common_defs com_member_defs - {class_name, class_pos, class_context, class_members} (th_vars, td_infos, error_admin) + {class_name, class_pos, class_context, class_members, class_args} + (bv_uninitialized_mods, th_vars, td_infos, error_admin) # error_admin = setErrorAdmin (newPosition class_name class_pos) error_admin state = foldSt (check_kind_correctness_of_context common_defs) class_context - (th_vars, td_infos, error_admin) + (bv_uninitialized_mods, th_vars, td_infos, error_admin) state = foldlArraySt (check_kind_correctness_of_member_context common_defs com_member_defs) class_members state = state check_kind_correctness_of_member_context common_defs com_member_defs {ds_index} - (th_vars, td_infos, error_admin) + (bv_uninitialized_mods, th_vars, td_infos, error_admin) # {me_symb, me_pos, me_type} = com_member_defs.[ds_index] error_admin = setErrorAdmin (newPosition me_symb me_pos) error_admin = foldSt (check_kind_correctness_of_context common_defs) me_type.st_context - (th_vars, td_infos, error_admin) + (bv_uninitialized_mods, th_vars, td_infos, error_admin) get_tvi {tv_info_ptr} th_vars = readPtr tv_info_ptr th_vars - check_kind_correctness_of_icl_function fun_n (fun_defs, th_vars, td_infos, error_admin) + get_opt_kind {tv_info_ptr} th_vars + # (tvi, th_vars) + = readPtr tv_info_ptr th_vars + #! opt_kind + = case tvi of + TVI_Kind kind -> Yes kind + _ -> No + = (opt_kind, th_vars) + check_kind_correctness_of_icl_function common_defs fun_n + (fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin) # (fun_def, fun_defs) = fun_defs![fun_n] = case fun_def.fun_type of No - -> (fun_defs, th_vars, td_infos, error_admin) + -> (fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin) Yes st - # (th_vars, td_infos, error_admin) + # (bv_uninitialized_mods, th_vars, td_infos, error_admin) = check_kind_correctness_of_symbol_type common_defs fun_def.fun_symb fun_def.fun_pos - st (th_vars, td_infos, error_admin) - -> (fun_defs, th_vars, td_infos, error_admin) - check_kind_correctness_of_dcl_functions common_defs {dcl_functions, dcl_instances, dcl_macros} state - = iFoldSt (\i state - -> if (in_index_range i dcl_instances || in_index_range i dcl_macros) // yawn - state - (let ({ft_symb, ft_pos, ft_type}) = dcl_functions.[i] - in check_kind_correctness_of_symbol_type common_defs ft_symb ft_pos ft_type - state)) - 0 (size dcl_functions) state - check_kind_correctness_of_symbol_type common_defs fun_symb fun_pos - st=:{st_vars, st_args, st_result, st_context} (th_vars, td_infos, error_admin) + st (bv_uninitialized_mods, th_vars, td_infos, error_admin) + -> (fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin) + check_kind_correctness_of_dcl_functions common_defs mod_index + (dcl_mods, bv_uninitialized_mods, th_vars, td_infos, error_admin) + # ({dcl_functions, dcl_instances, dcl_macros}, dcl_mods) + = dcl_mods![mod_index] + (bv_uninitialized_mods, th_vars, td_infos, error_admin) + = iFoldSt (\i state + -> if (in_index_range i dcl_instances || in_index_range i dcl_macros) // yawn + state + (let ({ft_symb, ft_pos, ft_type}) = dcl_functions.[i] + in check_kind_correctness_of_symbol_type common_defs ft_symb ft_pos ft_type + state)) + 0 (size dcl_functions) (bv_uninitialized_mods, th_vars, td_infos, error_admin) + = (dcl_mods, bv_uninitialized_mods, th_vars, td_infos, error_admin) + check_kind_correctness_of_symbol_type common_defs fun_symb fun_pos + st=:{st_vars, st_args, st_result, st_context} + (bv_uninitialized_mods, th_vars, td_infos, error_admin) # error_admin = setErrorAdmin (newPosition fun_symb fun_pos) error_admin th_vars @@ -156,9 +227,10 @@ checkKindCorrectness icl_used_module_numbers main_dcl_module_n icl_instances com (th_vars, td_infos, error_admin) = unsafeFold2St (check_kind_correctness_of_atype KindConst) [0..] [st_result:st_args] (th_vars, td_infos, error_admin) - (th_vars, td_infos, error_admin) - = foldSt (check_kind_correctness_of_context common_defs) st_context (th_vars, td_infos, error_admin) - = (th_vars, td_infos, error_admin) + (bv_uninitialized_mods, th_vars, td_infos, error_admin) + = foldSt (check_kind_correctness_of_context common_defs) st_context + (bv_uninitialized_mods, th_vars, td_infos, error_admin) + = (bv_uninitialized_mods, th_vars, td_infos, error_admin) check_kind_correctness_of_atype expected_kind arg_nr {at_type} state = check_kind_correctness_of_type expected_kind arg_nr at_type state check_kind_correctness_of_type expected_kind arg_nr (TA {type_name,type_index} args) @@ -208,22 +280,21 @@ checkKindCorrectness icl_used_module_numbers main_dcl_module_n icl_instances com = check_equality_of_kinds arg_nr expected_kind KindConst error_admin = (th_vars, td_infos, error_admin) - check_kind_correctness_of_context common_defs {tc_class, tc_types} (th_vars, td_infos, error_admin) - # {class_args} - = common_defs.[tc_class.glob_module].com_class_defs.[tc_class.glob_object.ds_index] - (expected_kinds, th_vars) - = mapSt get_tvi class_args th_vars - state + check_kind_correctness_of_context common_defs {tc_class, tc_types} + (bv_uninitialized_mods, th_vars, td_infos, error_admin) + # (expected_kinds, bv_uninitialized_mods, th_vars) + = get_expected_kinds tc_class common_defs bv_uninitialized_mods th_vars + (th_vars, td_infos, error_admin) = unsafeFold3St possibly_check_kind_correctness_of_type expected_kinds (descending (-1)) tc_types (th_vars, td_infos, error_admin) - = state + = (bv_uninitialized_mods, th_vars, td_infos, error_admin) where descending i = [i:descending (i-1)] init_type_var {tv_info_ptr} th_vars = writePtr tv_info_ptr TVI_Empty th_vars - unify_var_kinds expected_kind {tv_name, tv_info_ptr} th_vars error_admin + unify_var_kinds expected_kind tv=:{tv_name, tv_info_ptr} th_vars error_admin # (tvi, th_vars) = readPtr tv_info_ptr th_vars = case tvi of @@ -237,7 +308,7 @@ checkKindCorrectness icl_used_module_numbers main_dcl_module_n icl_instances com check_equality_of_kinds arg_nr expected_kind kind error_admin | expected_kind==kind = error_admin - = checkError "inconsistent kind in " (arg_nr_to_string arg_nr) error_admin + = checkError "inconsistent kind in" (arg_nr_to_string arg_nr) error_admin arg_nr_to_string 0 = "result type" arg_nr_to_string i @@ -245,5 +316,17 @@ checkKindCorrectness icl_used_module_numbers main_dcl_module_n icl_instances com = "type of argument nr "+++toString i = "type context nr "+++toString (~i) + get_common_defs dcl_mods + #! size = size dcl_mods + # ({dcl_common=arbitrary_value_for_initializing}, dcl_mods) = dcl_mods![0] + = loop 0 (createArray size arbitrary_value_for_initializing) dcl_mods + where + loop :: !Int !*{#CommonDefs} !u:{#DclModule} -> (!*{#CommonDefs}, !u:{#DclModule}) + loop i common_defs dcl_mods + | i==size dcl_mods + = (common_defs, dcl_mods) + # ({dcl_common}, dcl_mods) = dcl_mods![i] + = loop (i+1) { common_defs & [i] = dcl_common } dcl_mods in_index_range test ir :== test>=ir.ir_from && test < ir.ir_to + diff --git a/frontend/checksupport.dcl b/frontend/checksupport.dcl index 7d3734f..322819c 100644 --- a/frontend/checksupport.dcl +++ b/frontend/checksupport.dcl @@ -107,6 +107,7 @@ cConversionTableSize :== 9 // AA , dcl_conversions :: !Optional ConversionTable , dcl_is_system :: !Bool , dcl_imported_module_numbers :: !NumberSet + , dcl_is_cashed :: !Bool } class Erroradmin state diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl index fd82387..0222299 100644 --- a/frontend/checksupport.icl +++ b/frontend/checksupport.icl @@ -120,6 +120,7 @@ where , dcl_conversions :: !Optional ConversionTable , dcl_is_system :: !Bool , dcl_imported_module_numbers :: !NumberSet + , dcl_is_cashed :: !Bool } class Erroradmin state // PK... diff --git a/frontend/frontend.icl b/frontend/frontend.icl index 6486fdb..d05c6b0 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -123,16 +123,16 @@ 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 } - # (saved_main_dcl_common, ti_common_defs) = replace ti_common_defs main_dcl_module_n icl_common - + # (ti_common_defs, dcl_mods) = get_common_defs dcl_mods + ti_common_defs = { 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 - ti_common_defs dcl_mods fun_defs type_heaps.th_vars td_infos error_admin + (fun_defs, dcl_mods, th_vars, td_infos, error_admin) + = checkKindCorrectness main_dcl_module_n icl_instances + fun_defs ti_common_defs dcl_mods type_heaps.th_vars td_infos error_admin type_heaps = { type_heaps & th_vars = th_vars } # heaps = { heaps & hp_type_heaps = type_heaps } + # 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 #! (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 @@ -249,6 +249,17 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac = fill_empty_positions (inc next_index) table_size (inc next_new_index) { icl_conversions & [next_index] = next_new_index } = fill_empty_positions (inc next_index) table_size next_new_index icl_conversions = icl_conversions + get_common_defs dcl_mods + #! size = size dcl_mods + # ({dcl_common=arbitrary_value_for_initializing}, dcl_mods) = dcl_mods![0] + = loop 0 (createArray size arbitrary_value_for_initializing) dcl_mods + where + loop :: !Int !*{#CommonDefs} !u:{#DclModule} -> (!*{#CommonDefs}, !u:{#DclModule}) + loop i common_defs dcl_mods + | i==size dcl_mods + = (common_defs, dcl_mods) + # ({dcl_common}, dcl_mods) = dcl_mods![i] + = loop (i+1) { common_defs & [i] = dcl_common } dcl_mods newSymbolTable :: !Int -> *{# SymbolTableEntry} newSymbolTable size diff --git a/frontend/generics.icl b/frontend/generics.icl index 155dccc..7874c64 100644 --- a/frontend/generics.icl +++ b/frontend/generics.icl @@ -1680,7 +1680,8 @@ buildClassDef class_pos = gen_pos, class_members = createArray 1 class_member, class_cons_vars = case kind of KindConst -> 0; _ -> 1, - class_dictionary = class_dictionary + class_dictionary = class_dictionary, + class_arg_kinds = [kind] } #! com_class_defs = append_array com_class_defs class_def @@ -1772,7 +1773,8 @@ where class_pos = gen_pos, class_members = createArray 1 class_member, class_cons_vars = case kind of KindConst -> 0; _ -> 1, - class_dictionary = class_dictionary + class_dictionary = class_dictionary, + class_arg_kinds = [kind] } = class_def diff --git a/frontend/parse.icl b/frontend/parse.icl index f1e6f88..26e3cc8 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -1020,7 +1020,8 @@ wantClassDefinition context pos pState (members, pState) = wantDefinitions (SetLocalContext context) pState class_def = { class_name = class_id, class_arity = class_arity, class_args = class_args, class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars, - class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }} + class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }, + class_arg_kinds = []} pState = wantEndGroup "class" pState = (PD_Class class_def members, pState) | isEmpty contexts @@ -1030,7 +1031,8 @@ wantClassDefinition context pos pState (class_id, pState) = stringToIdent class_or_member_name IC_Class pState class_def = { class_name = class_id, class_arity = class_arity, class_args = class_args, class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars, - class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }} + class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }, + class_arg_kinds = []} pState = wantEndOfDefinition "class definition" pState = (PD_Class class_def [], pState) = (PD_Erroneous, parseError "Class Definition" (Yes token) "<class definition>" pState) @@ -1077,7 +1079,8 @@ wantClassDefinition context pos pState member = PD_TypeSpec pos member_id prio (Yes tspec) SP_None class_def = { class_name = class_id, class_arity = class_arity, class_args = class_args, class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars, - class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }} + class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }, + class_arg_kinds = []} pState = wantEndOfDefinition "overloaded function" pState = (PD_Class class_def [member], pState) diff --git a/frontend/predef.icl b/frontend/predef.icl index f9759ca..c618442 100644 --- a/frontend/predef.icl +++ b/frontend/predef.icl @@ -371,7 +371,8 @@ where class_def = { class_name = tc_class_name.pds_ident, class_arity = 1, class_args = [class_var], class_context = [], class_members = {{ds_ident = tc_member_name.pds_ident, ds_index = cTCMemberSymbIndex, ds_arity = 0 }}, class_cons_vars = 0, - class_dictionary = { ds_ident = { tc_class_name.pds_ident & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }, class_pos = NoPos } + class_dictionary = { ds_ident = { tc_class_name.pds_ident & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }, class_pos = NoPos, + class_arg_kinds = [] } = (class_def, member_def, pre_def_symbols) diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 9bbdb19..a02ef8c 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -242,6 +242,7 @@ cNameLocationDependent :== True , class_dictionary :: !DefinedSymbol , class_pos :: !Position , class_cons_vars :: !BITVECT + , class_arg_kinds :: ![TypeKind] // filled in in checkKindCorrectness phase } :: MemberDef = diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 9bb74d3..15bfdd4 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -236,6 +236,7 @@ cNameLocationDependent :== True , class_dictionary :: !DefinedSymbol , class_pos :: !Position , class_cons_vars :: !BITVECT + , class_arg_kinds :: ![TypeKind] // filled in in checkKindCorrectness phase } :: MemberDef = |