diff options
| -rw-r--r-- | frontend/check.icl | 152 | ||||
| -rw-r--r-- | frontend/checkFunctionBodies.icl | 452 | ||||
| -rw-r--r-- | frontend/checksupport.dcl | 1 | ||||
| -rw-r--r-- | frontend/checksupport.icl | 4 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 157 | ||||
| -rw-r--r-- | frontend/explicitimports.dcl | 35 | ||||
| -rw-r--r-- | frontend/explicitimports.icl | 319 | ||||
| -rw-r--r-- | frontend/frontend.icl | 8 | ||||
| -rw-r--r-- | frontend/parse.icl | 419 | ||||
| -rw-r--r-- | frontend/postparse.icl | 8 | ||||
| -rw-r--r-- | frontend/scanner.dcl | 1 | ||||
| -rw-r--r-- | frontend/scanner.icl | 84 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 47 | ||||
| -rw-r--r-- | frontend/syntax.icl | 5 | ||||
| -rw-r--r-- | frontend/type.dcl | 6 | ||||
| -rw-r--r-- | frontend/type.icl | 58 |
16 files changed, 1260 insertions, 496 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 782e14b..89bdcef 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -1109,6 +1109,8 @@ where = remove_calls_from_symbol_table fun_index fun_level fun_calls fun_defs macro_defs symbol_table = remove_calls_from_symbol_table fun_index fun_level fun_calls fun_defs macro_defs symbol_table remove_calls_from_symbol_table fun_index fun_level [MacroCall module_index fc_index fc_level : fun_calls] fun_defs macro_defs symbol_table + | fc_level == -1 + = remove_calls_from_symbol_table fun_index fun_level fun_calls fun_defs macro_defs symbol_table | fc_level <= fun_level # (id_info, macro_defs) = macro_defs![module_index,fc_index].fun_ident.id_info # (entry, symbol_table) = readPtr id_info symbol_table @@ -1780,39 +1782,32 @@ replace_icl_macros_by_dcl_macros _ {ir_from=first_icl_macro_index,ir_to=end_icl_ (<=<) infixl (<=<) state fun :== fun state +checkDclModules :: [.(Import .ImportDeclaration)] *{#.DclModule} *{#.FunDef} *{#*{#.FunDef}} *Heaps *CheckState + -> (Int,[ExplicitImport],.[{#Char}],{!{!.ExplImpInfo}}, .{# DclModule},.{# FunDef}, {#.{# FunDef}},.Heaps,.CheckState) checkDclModules imports_of_icl_mod dcl_modules icl_functions macro_defs heaps cs=:{cs_symbol_table} - #! nr_of_dcl_modules - = size dcl_modules + #! nr_of_dcl_modules = size dcl_modules # (bitvect, dependencies, dcl_modules, cs_symbol_table) = iFoldSt add_dependencies 0 nr_of_dcl_modules (bitvectCreate (nr_of_dcl_modules+1), gimme_a_strict_array_type (createArray (nr_of_dcl_modules+1) []), dcl_modules, cs_symbol_table) - index_of_icl_module - = nr_of_dcl_modules + index_of_icl_module = nr_of_dcl_modules (dependencies_of_icl_mod, (_, cs_symbol_table)) = mapFilterYesSt get_opt_dependency imports_of_icl_mod (bitvect, cs_symbol_table) (directly_imported_dcl_modules,dcl_modules) = mapSt (\mod_index dcl_modules -> dcl_modules![mod_index].dcl_name.id_name) dependencies_of_icl_mod dcl_modules - dependencies - = { dependencies & [index_of_icl_module] = dependencies_of_icl_mod } - module_dag - = { dag_nr_of_nodes = nr_of_dcl_modules+1, dag_get_children = select dependencies } - components - = partitionateDAG module_dag [cs.cs_x.x_main_dcl_module_n,index_of_icl_module] + dependencies = { dependencies & [index_of_icl_module] = dependencies_of_icl_mod } + module_dag = { dag_nr_of_nodes = nr_of_dcl_modules+1, dag_get_children = select dependencies } + components = partitionateDAG module_dag [cs.cs_x.x_main_dcl_module_n,index_of_icl_module] // | False--->("biggest component:", m axList (map length components)) // = undef # (nr_of_components, component_numbers) = getComponentNumbers components module_dag.dag_nr_of_nodes - reversed_dag1 - = reverseDAG module_dag - reversed_dag - = { module_dag & dag_get_children = select reversed_dag1 } - components_importing_module_a - = groupify reversed_dag component_numbers nr_of_components + reversed_dag1 = reverseDAG module_dag + reversed_dag = { module_dag & dag_get_children = select reversed_dag1 } + components_importing_module_a = groupify reversed_dag component_numbers nr_of_components // module i is imported by components with _component_ numbers components_importing_module_a.[i] - components_array - = gimme_a_strict_array_type { component \\ component <- components } + components_array = gimme_a_strict_array_type { component \\ component <- components } (expl_imp_symbols_in_components, expl_imp_indices, (dcl_modules, cs_symbol_table)) = mapY2St (get_expl_imp_symbols_of_component imports_of_icl_mod) components (dcl_modules, cs_symbol_table) @@ -1823,8 +1818,7 @@ checkDclModules imports_of_icl_mod dcl_modules icl_functions macro_defs heaps cs \\ expl_imp_symbols_in_component<-expl_imp_symbols_in_components } // eii_declaring_modules will be updated later cs = { cs & cs_symbol_table = cs_symbol_table } - nr_of_icl_component - = component_numbers.[index_of_icl_module] + nr_of_icl_component = component_numbers.[index_of_icl_module] (_, expl_imp_infos, dcl_modules, icl_functions, macro_defs, heaps, cs) = unsafeFold2St (checkDclComponent components_array components_importing_module_a) (reverse expl_imp_indices) (reverse components) (nr_of_components-1, expl_imp_infos, dcl_modules, icl_functions, macro_defs, heaps, cs) @@ -1859,15 +1853,13 @@ checkDclModules imports_of_icl_mod dcl_modules icl_functions macro_defs heaps cs set_to_false :: (Import x) !(!*LargeBitvect, !u:SymbolTable) -> (!.LargeBitvect, !u:SymbolTable) set_to_false {import_module} (bitvect, cs_symbol_table) - #! ste_index - = (sreadPtr import_module.id_info cs_symbol_table).ste_index + #! ste_index = (sreadPtr import_module.id_info cs_symbol_table).ste_index = (bitvectReset ste_index bitvect, cs_symbol_table) get_expl_imp_symbols_of_component imports_of_icl_mod component (dcl_modules, cs_symbol_table) # (expl_imp_symbols, _, expl_imp_indices, dcl_modules, cs_symbol_table) = foldSt (get_expl_imp_symbols_of_module imports_of_icl_mod) component ([], 0, [], dcl_modules, cs_symbol_table) - cs_symbol_table - = foldSt restoreHeap expl_imp_symbols cs_symbol_table + cs_symbol_table = foldSt restoreHeap expl_imp_symbols cs_symbol_table = (reverse expl_imp_symbols, reverse expl_imp_indices, (dcl_modules, cs_symbol_table)) get_expl_imp_symbols_of_module imports_of_icl_mod mod_index (expl_imp_symbols_accu, nr_of_expl_imp_symbols, expl_imp_indices_accu, dcl_modules, cs_symbol_table) @@ -1889,11 +1881,13 @@ checkDclModules imports_of_icl_mod dcl_modules icl_functions macro_defs heaps cs get_mod_imports _ imports_of_icl_mod dcl_modules cs_symbol_table = (imports_of_icl_mod, dcl_modules, cs_symbol_table) - get_expl_imp_symbols {import_module, import_symbols, import_file_position} (expl_imp_symbols_accu, nr_of_expl_imp_symbols, expl_imp_indices_accu, cs_symbol_table) + get_expl_imp_symbols {import_module,import_symbols,import_file_position,import_qualified} (expl_imp_symbols_accu, nr_of_expl_imp_symbols, expl_imp_indices_accu, cs_symbol_table) # (expl_imp_symbols_accu, nr_of_expl_imp_symbols, expl_imp_indices, cs_symbol_table) = foldSt get_expl_imp_symbol import_symbols (expl_imp_symbols_accu, nr_of_expl_imp_symbols, [], cs_symbol_table) ({ste_index}, cs_symbol_table) = readPtr import_module.id_info cs_symbol_table - = (expl_imp_symbols_accu, nr_of_expl_imp_symbols, [(ste_index, import_file_position, expl_imp_indices):expl_imp_indices_accu], cs_symbol_table) + explicit_import = {ei_module_n=ste_index, ei_position=import_file_position, + ei_symbols=expl_imp_indices, ei_qualified=import_qualified} + = (expl_imp_symbols_accu, nr_of_expl_imp_symbols, [explicit_import:expl_imp_indices_accu], cs_symbol_table) get_expl_imp_symbol imp_decl state = get_symbol imp_decl (get_ident imp_decl) state @@ -1905,6 +1899,7 @@ checkDclModules imports_of_icl_mod dcl_modules icl_functions macro_defs heaps cs get_ident (ID_Record {ii_ident} _) = ii_ident get_ident (ID_Instance class_ident instance_ident _) = instance_ident + get_symbol :: ImportDeclaration !Ident !*([Ident],Int,[ImportNrAndIdents],*(Heap SymbolTableEntry)) -> ([Ident],Int,[ImportNrAndIdents],.(Heap SymbolTableEntry)) get_symbol imp_decl ident=:{id_info} (expl_imp_symbols_accu, nr_of_expl_imp_symbols, expl_imp_indices_accu, cs_symbol_table) # (ste, cs_symbol_table) = readPtr id_info cs_symbol_table = case ste.ste_kind of @@ -1916,7 +1911,7 @@ checkDclModules imports_of_icl_mod dcl_modules icl_functions macro_defs heaps cs ini = { 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) -checkDclComponent :: !{![Int]} !{![Int]} ![[(Index, Position, [ImportNrAndIdents])]] ![Int] +checkDclComponent :: !{![Int]} !{![Int]} ![[ExplicitImport]] ![Int] !(!Int, !*ExplImpInfos, !*{# DclModule},!*{# FunDef},!*{#*{#FunDef}},!*Heaps,!*CheckState) -> (!Int, !*ExplImpInfos, !.{# DclModule},!.{# FunDef},!*{#*{#FunDef}},!.Heaps,!.CheckState) checkDclComponent components_array components_importing_module_a expl_imp_indices mod_indices @@ -1926,10 +1921,9 @@ checkDclComponent components_array components_importing_module_a expl_imp_indice // | False--->("checkDclComponent", mod_indices, size dcl_modules) = undef # ({dcl_name=dcl_name_of_first_mod_in_component}, dcl_modules) = dcl_modules![hd mod_indices] - ({ste_kind}, cs_symbol_table) + # ({ste_kind}, cs_symbol_table) = readPtr dcl_name_of_first_mod_in_component.id_info cs.cs_symbol_table - cs - = { cs & cs_symbol_table = cs_symbol_table } + cs = { cs & cs_symbol_table = cs_symbol_table } = case ste_kind of STE_ClosedModule // this component has been already checked during the previous icl module's compilation @@ -1942,8 +1936,7 @@ checkDclComponent components_array components_importing_module_a expl_imp_indice = case mod_indices of [_] -> False _ -> True - cs_error - = fold2St check_whether_module_imports_itself expl_imp_indices mod_indices cs.cs_error + cs_error = fold2St check_whether_module_imports_itself expl_imp_indices mod_indices cs.cs_error cs = { cs & cs_error = cs_error } | not cs.cs_error.ea_ok -> (component_nr-1, expl_imp_infos, dcl_modules, icl_functions, macro_defs, heaps, cs) @@ -1953,16 +1946,14 @@ checkDclComponent components_array components_importing_module_a expl_imp_indice -> collect_expl_imp_info component_nr mod_indices (expl_imp_infos, dcl_modules, cs) False -> (expl_imp_infos, dcl_modules, cs) - #! nr_of_modules - = size dcl_modules + #! nr_of_modules = size dcl_modules # modules_in_component_set = foldSt bitvectSet mod_indices (bitvectCreate nr_of_modules) (dcl_imported_module_numbers, dcl_modules) = foldSt (\imports_per_module state -> foldSt compute_used_module_nrs imports_per_module state) expl_imp_indices (foldSt addNr mod_indices EndNumbers, dcl_modules) - expl_imp_indices_ikh - = fold2St (ikhInsert` False) mod_indices expl_imp_indices ikhEmpty + expl_imp_indices_ikh = fold2St (ikhInsert` False) mod_indices expl_imp_indices ikhEmpty (expl_imp_info, expl_imp_infos) = replace expl_imp_infos component_nr cDummyArray (imports, (dcl_modules, _, expl_imp_info, cs)) @@ -2002,9 +1993,9 @@ checkDclComponent components_array components_importing_module_a expl_imp_indice check_whether_module_imports_itself expl_imp_indices_for_module mod_index cs_error = foldSt (check_that mod_index) expl_imp_indices_for_module cs_error where - check_that mod_index (imported_mod_index, position, _) cs_error + check_that mod_index {ei_module_n=imported_mod_index, ei_position} cs_error | mod_index==imported_mod_index - = checkErrorWithIdentPos (newPosition import_ident position) + = checkErrorWithIdentPos (newPosition import_ident ei_position) "a dcl module cannot import from itself" cs_error = cs_error @@ -2029,17 +2020,16 @@ checkDclComponent components_array components_importing_module_a expl_imp_indice # ({dcls_local_for_import, dcls_import}, dcl_modules) = dcl_modules![mod_index].dcl_declared = updateExplImpInfoForCachedModule components_importing_module_a.[mod_index] mod_index dcls_import dcls_local_for_import expl_imp_infos dcl_modules cs_symbol_table - check_expl_imp_completeness_of_dcl_mod_within_non_trivial_component mod_index {si_explicit} (dcl_modules, icl_functions,macro_defs,hp_expression_heap, cs) + check_expl_imp_completeness_of_dcl_mod_within_non_trivial_component mod_index {si_explicit,si_qualified_explicit} (dcl_modules, icl_functions,macro_defs,hp_expression_heap, cs) # ({dcl_declared}, dcl_modules) = dcl_modules![mod_index] ({dcls_local_for_import, dcls_import}) = dcl_declared cs = addDeclarationsOfDclModToSymbolTable mod_index dcls_local_for_import dcls_import cs (dcl_modules, icl_functions,macro_defs,hp_expression_heap, cs=:{cs_symbol_table}) - = checkExplicitImportCompleteness si_explicit dcl_modules icl_functions macro_defs hp_expression_heap cs - cs_symbol_table - = removeImportsAndLocalsOfModuleFromSymbolTable dcl_declared cs.cs_symbol_table + = checkExplicitImportCompleteness si_explicit si_qualified_explicit dcl_modules icl_functions macro_defs hp_expression_heap cs + cs_symbol_table = removeImportsAndLocalsOfModuleFromSymbolTable dcl_declared cs.cs_symbol_table = (dcl_modules, icl_functions,macro_defs,hp_expression_heap, { cs & cs_symbol_table = cs_symbol_table }) - -compute_used_module_nrs (mod_index, _, _) (mod_nr_accu, dcl_modules) + +compute_used_module_nrs {ei_module_n=mod_index} (mod_nr_accu, dcl_modules) | inNumberSet mod_index mod_nr_accu = (mod_nr_accu, dcl_modules) # ({dcl_imported_module_numbers}, dcl_modules) @@ -2047,6 +2037,7 @@ compute_used_module_nrs (mod_index, _, _) (mod_nr_accu, dcl_modules) = (addNr mod_index (numberSetUnion dcl_imported_module_numbers mod_nr_accu), dcl_modules) +createCommonDefinitionsWithinComponent :: Bool Int *(!*{#.DclModule},*CheckState) -> (*CommonDefs,(*{#DclModule},*CheckState)) createCommonDefinitionsWithinComponent is_on_cycle mod_index (dcl_modules, cs=:{cs_symbol_table}) # (dcl_mod=:{dcl_name}, dcl_modules) = dcl_modules![mod_index] (mod_entry, cs_symbol_table) = readPtr dcl_name.id_info cs_symbol_table @@ -2080,6 +2071,9 @@ createCommonDefinitionsWithinComponent is_on_cycle mod_index (dcl_modules, cs=:{ = ({com_type_defs=type_defs1,com_cons_defs=cons_defs1,com_selector_defs=selector_defs1,com_class_defs=class_defs1,com_member_defs=member_defs1,com_instance_defs=instance_defs1,com_generic_defs=generic_defs1,com_gencase_defs=gencase_defs1}, {com_type_defs=type_defs2,com_cons_defs=cons_defs2,com_selector_defs=selector_defs2,com_class_defs=class_defs2,com_member_defs=member_defs2,com_instance_defs=instance_defs2,com_generic_defs=generic_defs2,com_gencase_defs=gencase_defs2}) +checkDclModuleWithinComponent :: .NumberSet Int Bool {#.Int} {![.Int]} (IntKeyHashtable SolvedImports) Int *CommonDefs + *(*{!*{!*ExplImpInfo}},*{#.DclModule},*{#.FunDef},*{#*{#.FunDef}},*Heaps,*CheckState) + -> ((Int,Int,[FunType]),({!{!.ExplImpInfo}},.{# DclModule},.{# FunDef}, {#.{# FunDef}},.Heaps,.CheckState)) checkDclModuleWithinComponent dcl_imported_module_numbers component_nr is_on_cycle modules_in_component_set components_importing_module_a imports_ikh mod_index dcl_common (expl_imp_infos, dcl_modules, icl_functions, macro_defs, heaps, cs=:{cs_symbol_table}) @@ -2087,7 +2081,7 @@ checkDclModuleWithinComponent dcl_imported_module_numbers component_nr is_on_cyc (mod_entry, cs_symbol_table) = readPtr dcl_name.id_info cs_symbol_table ({ ste_kind = STE_Module mod, ste_index }) = mod_entry cs = { cs & cs_symbol_table = writePtr dcl_name.id_info { mod_entry & ste_kind = STE_ClosedModule } cs_symbol_table} - # {mod_ident,mod_defs={def_macro_indices,def_funtypes}} = mod + {mod_ident,mod_defs={def_macro_indices,def_funtypes}} = mod = checkDclModule2 dcl_imported_module_numbers components_importing_module_a.[mod_index] imports_ikh component_nr is_on_cycle modules_in_component_set mod_ident dcl_common def_macro_indices def_funtypes ste_index expl_imp_infos dcl_modules icl_functions macro_defs heaps cs @@ -2569,8 +2563,12 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m (dcls_import_list, dcl_modules, cs) = addImportedSymbolsToSymbolTable nr_of_modules (Yes dcl_macros) modules_in_component_set imports_ikh dcl_modules cs + qualified_explicit_imports = (ikhSearch` nr_of_modules imports_ikh).si_qualified_explicit (dcl_modules, icl_functions,macro_defs,hp_expression_heap, cs) - = checkExplicitImportCompleteness imports.si_explicit dcl_modules icl_functions macro_defs heaps.hp_expression_heap cs + = checkExplicitImportCompleteness imports.si_explicit qualified_explicit_imports dcl_modules icl_functions macro_defs heaps.hp_expression_heap cs + (modified_ste_kinds,symbol_table,dcl_modules) + = store_qualified_explicit_imports_in_symbol_table qualified_explicit_imports [] cs.cs_symbol_table dcl_modules + cs = {cs & cs_symbol_table=symbol_table} heaps = { heaps & hp_expression_heap=hp_expression_heap } @@ -2611,11 +2609,10 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m = foldSt checkSpecifiedInstanceType instance_types (icl_functions, heaps.hp_type_heaps, cs_error) heaps = { heaps & hp_type_heaps = hp_type_heaps } - - cs_symbol_table = removeDeclarationsFromSymbolTable local_defs cGlobalScope cs_symbol_table - cs_symbol_table - = foldlArraySt removeImportedSymbolsFromSymbolTable icl_imported cs_symbol_table + cs_symbol_table = restore_module_ste_kinds_in_symbol_table modified_ste_kinds cs_symbol_table + cs_symbol_table = removeDeclarationsFromSymbolTable local_defs cGlobalScope cs_symbol_table + cs_symbol_table = foldlArraySt removeImportedSymbolsFromSymbolTable icl_imported cs_symbol_table dcl_modules = e_info.ef_modules @@ -2644,9 +2641,10 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m ifi_gencase_indices = icl_generic_ranges, ifi_type_function_indices = icl_type_fun_ranges } icl_mod = { icl_name = mod_ident, icl_functions = icl_functions, icl_function_indices = icl_function_indices, - icl_common = icl_common, icl_import = icl_imported, icl_imported_objects = mod_imported_objects, - icl_foreign_exports = foreign_exports, icl_used_module_numbers = imported_module_numbers, - icl_copied_from_dcl = copied_dcl_defs, icl_modification_time = mod_modification_time } + icl_common = icl_common, icl_import = icl_imported, icl_qualified_imports = qualified_explicit_imports, + icl_imported_objects = mod_imported_objects, icl_foreign_exports = foreign_exports, + icl_used_module_numbers = imported_module_numbers, icl_copied_from_dcl = copied_dcl_defs, + icl_modification_time = mod_modification_time } heaps = { heaps & hp_var_heap = var_heap, hp_expression_heap = expr_heap, hp_type_heaps = {hp_type_heaps & th_vars = th_vars}} (main_dcl_module, dcl_modules) = dcl_modules![main_dcl_module_n] @@ -2674,9 +2672,10 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m ifi_gencase_indices = icl_generic_ranges, ifi_type_function_indices = icl_type_fun_ranges } icl_mod = { icl_name = mod_ident, icl_functions = icl_functions, icl_function_indices = icl_function_indices, - icl_common = icl_common, icl_import = icl_imported, icl_imported_objects = mod_imported_objects, - icl_foreign_exports = foreign_exports, icl_used_module_numbers = imported_module_numbers, - icl_copied_from_dcl = copied_dcl_defs, icl_modification_time = mod_modification_time } + icl_common = icl_common, icl_import = icl_imported, icl_qualified_imports = qualified_explicit_imports, + icl_imported_objects = mod_imported_objects, icl_foreign_exports = foreign_exports, + icl_used_module_numbers = imported_module_numbers, icl_copied_from_dcl = copied_dcl_defs, + icl_modification_time = mod_modification_time } = (False, icl_mod, dcl_modules, {}, {}, cs_x.x_main_dcl_module_n,heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file, directly_imported_dcl_modules) where check_start_rule mod_kind mod_ident icl_global_functions_ranges cs=:{cs_symbol_table,cs_x} @@ -2705,7 +2704,7 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table # cs = { cs & cs_symbol_table = cs_symbol_table <:= (id_info, { entry & ste_kind = STE_ClosedModule })} {ste_kind = STE_Module mod, ste_index} = entry - solved_imports = { si_explicit = [], si_implicit = [] } + solved_imports = { si_explicit=[], si_qualified_explicit=[], si_implicit=[] } imports_ikh = ikhInsert` False cPredefinedModuleIndex solved_imports ikhEmpty (deferred_stuff, (_, modules, macro_and_fun_defs, macro_defs, heaps, cs)) = checkDclModule EndNumbers [] imports_ikh cUndef False cDummyArray mod ste_index cDummyArray modules macro_and_fun_defs macro_defs heaps cs @@ -2916,7 +2915,7 @@ check_needed_modules_are_imported mod_ident extension cs=:{cs_x={x_needed_module = cs where check_it pd mod_ident explanation extension cs=:{cs_symbol_table} - # pds_ident = predefined_idents.[pd] + # pds_ident = predefined_idents.[pd] # ({ste_kind}, cs_symbol_table) = readPtr pds_ident.id_info cs_symbol_table cs = { cs & cs_symbol_table = cs_symbol_table } = case ste_kind of @@ -3007,9 +3006,10 @@ initialDclModule ({mod_ident, mod_modification_time, mod_defs=mod_defs=:{def_fun , dcl_imported_module_numbers = EndNumbers } +addImportedSymbolsToSymbolTable :: Int (Optional IndexRange) {#Int} (IntKeyHashtable SolvedImports) !*{#DclModule} *CheckState + -> ([Declaration],*{#DclModule},*CheckState) addImportedSymbolsToSymbolTable importing_mod opt_macro_range modules_in_component_set imports_ikh dcl_modules cs - #! nr_of_dcl_modules - = size dcl_modules + #! nr_of_dcl_modules = size dcl_modules # {si_explicit, si_implicit} = ikhSearch` importing_mod imports_ikh (decls_accu, visited_modules, dcl_modules, cs) = foldSt (add_impl_imported_symbols_with_new_error_pos opt_macro_range importing_mod @@ -3029,8 +3029,7 @@ addImportedSymbolsToSymbolTable importing_mod opt_macro_range modules_in_compone (decls_accu, visited_modules, dcl_modules, cs) | bitvectSelect mod_index visited_modules = (decls_accu, visited_modules, dcl_modules, cs) - # visited_modules - = bitvectSet mod_index visited_modules + # visited_modules = bitvectSet mod_index visited_modules ({ dcls_import, dcls_local_for_import }, dcl_modules) = dcl_modules![mod_index].dcl_declared (decls_accu, cs) @@ -3043,8 +3042,7 @@ addImportedSymbolsToSymbolTable importing_mod opt_macro_range modules_in_compone = foldlArraySt (add_declaration opt_macro_range importing_mod) dcls_import (decls_accu, cs) = (decls_accu, visited_modules, dcl_modules, cs) - # {si_explicit, si_implicit} - = ikhSearch` mod_index imports_ikh + # {si_explicit, si_implicit} = ikhSearch` mod_index imports_ikh (decls_accu, cs) = foldSt (\(decls, _) state -> foldSt (\decl state -> add_declaration opt_macro_range importing_mod decl state) @@ -3238,10 +3236,10 @@ ste_kind_to_string ste_kind = case ste_kind of update_expl_imp_for_marked_symbols mod_index decls (dcl_modules, expl_imp_infos, cs_symbol_table) = foldlArraySt (update_expl_imp_for_marked_symbol mod_index) decls (dcl_modules, expl_imp_infos, cs_symbol_table) - -update_expl_imp_for_marked_symbol mod_index decl=:(Declaration {decl_ident}) (dcl_modules, expl_imp_infos, cs_symbol_table) - # (ste, cs_symbol_table) = readPtr decl_ident.id_info cs_symbol_table - = updateExplImpForMarkedSymbol mod_index decl ste dcl_modules expl_imp_infos cs_symbol_table +where + update_expl_imp_for_marked_symbol mod_index decl=:(Declaration {decl_ident}) (dcl_modules, expl_imp_infos, cs_symbol_table) + # (ste, cs_symbol_table) = readPtr decl_ident.id_info cs_symbol_table + = updateExplImpForMarkedSymbol mod_index decl ste dcl_modules expl_imp_infos cs_symbol_table update_expl_imp_for_marked_local_symbol mod_index decl=:(Declaration {decl_ident}) (dcl_modules, expl_imp_infos, cs_symbol_table) # (ste, cs_symbol_table) = readPtr decl_ident.id_info cs_symbol_table @@ -3413,6 +3411,12 @@ checkDclModule2 dcl_imported_module_numbers components_importing_module imports_ cs = addGlobalDefinitionsToSymbolTable dcl_defined cs (dcls_import_list, modules, cs) = addImportedSymbolsToSymbolTable mod_index No modules_in_component_set imports_ikh modules cs + + qualified_explicit_imports = (ikhSearch` mod_index imports_ikh).si_qualified_explicit + (modified_ste_kinds,symbol_table,modules) + = store_qualified_explicit_imports_in_symbol_table qualified_explicit_imports [] cs.cs_symbol_table modules + cs = {cs & cs_symbol_table=symbol_table} + dcls_import = { el \\ el<-dcls_import_list } cs = { cs & cs_x.x_needed_modules = 0 } nr_of_dcl_functions = size dcl_mod.dcl_functions @@ -3420,7 +3424,8 @@ checkDclModule2 dcl_imported_module_numbers components_importing_module imports_ = checkCommonDefinitions No mod_index dcl_common modules heaps cs # dcl_mod = {dcl_mod & dcl_dictionary_info=dictionary_info} | not cs.cs_error.ea_ok - # cs_symbol_table = removeDeclarationsFromSymbolTable dcl_defined cModuleScope cs.cs_symbol_table + # cs_symbol_table = restore_module_ste_kinds_in_symbol_table modified_ste_kinds cs.cs_symbol_table + # cs_symbol_table = removeDeclarationsFromSymbolTable dcl_defined cModuleScope cs_symbol_table # cs_symbol_table = foldlArraySt removeImportedSymbolsFromSymbolTable dcls_import cs_symbol_table = ((0, 0, []), (expl_imp_info, modules, icl_functions, macro_defs, heaps, {cs & cs_symbol_table = cs_symbol_table})) @@ -3450,9 +3455,9 @@ checkDclModule2 dcl_imported_module_numbers components_importing_module imports_ (modules, icl_functions, macro_defs, hp_expression_heap, cs) = case is_on_cycle of - False - # decls_explicit = (ikhSearch` mod_index imports_ikh).si_explicit - -> checkExplicitImportCompleteness decls_explicit modules icl_functions macro_defs hp_expression_heap cs + False + # {si_explicit,si_qualified_explicit} = ikhSearch` mod_index imports_ikh + -> checkExplicitImportCompleteness si_explicit si_qualified_explicit modules icl_functions macro_defs hp_expression_heap cs True -> (modules, icl_functions, macro_defs, hp_expression_heap, cs) @@ -3464,7 +3469,8 @@ checkDclModule2 dcl_imported_module_numbers components_importing_module imports_ } (modules, expl_imp_info, cs_symbol_table) = updateExplImpInfo components_importing_module mod_index dcls_import dcl_mod.dcl_declared.dcls_local_for_import modules expl_imp_info cs.cs_symbol_table - + + cs_symbol_table = restore_module_ste_kinds_in_symbol_table modified_ste_kinds cs_symbol_table cs_symbol_table = removeDeclarationsFromSymbolTable dcl_defined cModuleScope cs_symbol_table cs_symbol_table = foldlArraySt removeImportedSymbolsFromSymbolTable dcls_import cs_symbol_table diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl index 288e0f1..6ec2135 100644 --- a/frontend/checkFunctionBodies.icl +++ b/frontend/checkFunctionBodies.icl @@ -132,8 +132,7 @@ checkFunctionBodies (ParsedBody [{pb_args,pb_rhs={rhs_alts,rhs_locals}, pb_posit e_state=:{es_var_heap, es_fun_defs} e_info cs # (aux_patterns, (var_env, array_patterns), {ps_var_heap,ps_fun_defs}, e_info, cs) = check_patterns pb_args {pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False} ([], []) - {ps_var_heap = es_var_heap, ps_fun_defs = es_fun_defs} e_info cs - + {ps_var_heap = es_var_heap, ps_fun_defs = es_fun_defs} e_info cs (rhs_expr, free_vars, e_state, e_info, cs) = checkRhs [] rhs_alts rhs_locals e_input { e_state & es_var_heap = ps_var_heap, es_fun_defs = ps_fun_defs } e_info cs (expr_with_array_selections, free_vars, e_state=:{es_var_heap,es_dynamics=dynamics_in_rhs}, e_info, cs) @@ -501,6 +500,9 @@ where PE_Ident id # (expr, free_vars, e_state, e_info, cs) = checkIdentExpression cIsInExpressionList free_vars id e_input e_state e_info cs -> ([expr : exprs], free_vars, e_state, e_info, cs) + PE_QualifiedIdent module_id ident_name + # (expr, free_vars, e_state, e_info, cs) = checkQualifiedIdentExpression free_vars module_id ident_name cIsInExpressionList e_input e_state e_info cs + -> ([expr : exprs], free_vars, e_state, e_info, cs) _ # (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs -> ([expr : exprs], free_vars, e_state, e_info, cs) @@ -513,7 +515,7 @@ where build_expression [Constant symb _ (Prio _ _) _ , _: _] e_state cs_error = (EE, e_state, checkError symb.symb_ident first_argument_of_infix_operator_missing cs_error) build_expression [Constant symb arity _ is_fun] e_state cs_error - = buildApplication symb arity 0 is_fun [] e_state cs_error + = buildApplicationWithoutArguments symb is_fun e_state cs_error build_expression [expr] e_state cs_error = (expr, e_state, cs_error) build_expression [expr : exprs] e_state cs_error @@ -530,12 +532,12 @@ where -> (left_expr, e_state, cs_error) where split_at_operator left [Constant symb arity NoPrio is_fun : exprs] e_state cs_error - # (appl_exp, e_state, cs_error) = buildApplication symb arity 0 is_fun [] e_state cs_error + # (appl_exp, e_state, cs_error) = buildApplicationWithoutArguments symb is_fun e_state cs_error = split_at_operator [appl_exp : left] exprs e_state cs_error split_at_operator left [Constant symb arity (Prio _ _) is_fun] e_state cs_error = (No, left, e_state, checkError symb.symb_ident "second argument of infix operator missing" cs_error) split_at_operator left [Constant symb arity prio is_fun] e_state cs_error - # (appl_exp, e_state, cs_error) = buildApplication symb arity 0 is_fun [] e_state cs_error + # (appl_exp, e_state, cs_error) = buildApplicationWithoutArguments symb is_fun e_state cs_error = (No, [appl_exp : left], e_state, cs_error) split_at_operator left [expr=:(Constant symb arity prio is_fun) : exprs] e_state cs_error = (Yes (symb, arity, prio, is_fun, exprs), left, e_state, cs_error) @@ -547,8 +549,7 @@ where combine_expressions [first_expr] args arity e_state cs_error = case first_expr of Constant symb form_arity _ is_fun - # (app_exp, e_state, cs_error) = buildApplication symb form_arity arity is_fun args e_state cs_error - -> (app_exp, e_state, cs_error) + -> buildApplication symb form_arity arity is_fun args e_state cs_error _ | arity == 0 -> (first_expr, e_state, cs_error) @@ -1118,8 +1119,9 @@ where checkExpression free_vars (PE_Ident id) e_input e_state e_info cs = checkIdentExpression cIsNotInExpressionList free_vars id e_input e_state e_info cs +checkExpression free_vars (PE_QualifiedIdent module_id ident_name) e_input e_state e_info cs + = checkQualifiedIdentExpression free_vars module_id ident_name cIsNotInExpressionList e_input e_state e_info cs checkExpression free_vars (PE_Generic id=:{id_name,id_info} kind) e_input e_state e_info cs=:{cs_symbol_table} - //= checkIdentExpression cIsNotInExpressionList free_vars id e_input e_state e_info cs # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table = check_generic_expr free_vars entry id kind e_input e_state e_info {cs & cs_symbol_table = cs_symbol_table} where @@ -1197,17 +1199,16 @@ checkExpression free_vars (PE_Generic id=:{id_name,id_info} kind) e_input e_stat = (generic_defs, {e_state & es_generic_heap = es_generic_heap}) checkExpression free_vars expr e_input e_state e_info cs - = abort "checkExpression (checkFunctionBodies.icl, line 868)" // <<- expr + = abort "checkExpression (checkFunctionBodies.icl)" // <<- expr checkIdentExpression :: !Bool ![FreeVar] !Ident !ExpressionInput !*ExpressionState !u:ExpressionInfo !*CheckState - -> (!Expression, ![FreeVar], !*ExpressionState, !u:ExpressionInfo, !*CheckState) + -> (!Expression, ![FreeVar], !*ExpressionState,!u:ExpressionInfo,!*CheckState) checkIdentExpression is_expr_list free_vars id=:{id_info} e_input e_state e_info cs=:{cs_symbol_table} # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table = check_id_expression entry is_expr_list free_vars id e_input e_state e_info { cs & cs_symbol_table = cs_symbol_table } where check_id_expression :: !SymbolTableEntry !Bool ![FreeVar] !Ident !ExpressionInput !*ExpressionState !u:ExpressionInfo !*CheckState - -> (!Expression, ![FreeVar], !*ExpressionState, !u:ExpressionInfo, !*CheckState) - + -> (!Expression, ![FreeVar], !*ExpressionState,!u:ExpressionInfo,!*CheckState) check_id_expression {ste_kind = STE_Empty} is_expr_list free_vars id e_input e_state e_info cs=:{cs_error,cs_predef_symbols,cs_x} # local_predefined_idents = predefined_idents # from_ident = local_predefined_idents.[PD_From] @@ -1262,8 +1263,12 @@ where symbol = { symb_ident = id, symb_kind = symb_kind } | is_expr_list = (Constant symbol arity priority is_a_function, free_vars, e_state, e_info, cs) - # (app_expr, e_state, cs_error) = buildApplication symbol arity 0 is_a_function [] e_state cs.cs_error - = (app_expr, free_vars, e_state, e_info, { cs & cs_error = cs_error }) + | is_a_function + # (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap + # app_expr = App { app_symb = symbol , app_args = [], app_info_ptr = new_info_ptr } + = (app_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs) + # app_expr = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr } + = (app_expr, free_vars, e_state, e_info, cs) determine_info_of_symbol :: !SymbolTableEntry !SymbolPtr !ExpressionInput !*ExpressionState !u:ExpressionInfo !*CheckState -> (!SymbKind, !Int, !Priority, !Bool, !*ExpressionState, !u:ExpressionInfo,!*CheckState) @@ -1315,9 +1320,6 @@ where = (kind, arity, priority, is_fun, e_state, { e_info & ef_modules = ef_modules }, cs) where ste_kind_to_symbol_kind :: !STE_Kind !Index !Index !DclModule -> (!SymbKind, !Int, !Priority, !Bool); - ste_kind_to_symbol_kind STE_DclFunction def_index mod_index {dcl_functions} - # {ft_type={st_arity},ft_priority} = dcl_functions.[def_index] - = (SK_Function { glob_object = def_index, glob_module = mod_index }, st_arity, ft_priority, cIsAFunction) ste_kind_to_symbol_kind STE_Member def_index mod_index {dcl_common={com_member_defs}} # {me_type={st_arity},me_priority} = com_member_defs.[def_index] = (SK_OverloadedFunction { glob_object = def_index, glob_module = mod_index }, st_arity, me_priority, cIsAFunction) @@ -1342,18 +1344,6 @@ where # e_state = { e_state & es_calls = [DclFunCall ei_mod_index ste_index : es_calls ]} = (kind, st_arity, ft_priority, cIsAFunction, e_state, e_info, cs) - is_called_before caller_index [] - = False - is_called_before caller_index [called_index : calls] - = caller_index == called_index || is_called_before caller_index calls - - dcl_fun_is_called_before ste_index mod_index [] - = False - dcl_fun_is_called_before ste_index mod_index [DclFunCall dcl_fun_mod_index dcl_fun_index:calls] - = (ste_index==dcl_fun_index && mod_index==dcl_fun_mod_index) || dcl_fun_is_called_before ste_index mod_index calls - dcl_fun_is_called_before ste_index mod_index [_:calls] - = dcl_fun_is_called_before ste_index mod_index calls - convert_DefOrImpFunKind_to_icl_SymbKind FK_Macro index fi_properties = SK_IclMacro index.glob_object; convert_DefOrImpFunKind_to_icl_SymbKind _ index fi_properties @@ -1361,12 +1351,106 @@ where = SK_LocalMacroFunction index.glob_object = SK_Function index - convert_DefOrImpFunKind_to_dcl_SymbKind FK_Macro index fi_properties - = SK_DclMacro index; - convert_DefOrImpFunKind_to_dcl_SymbKind _ index fi_properties - | fi_properties bitand FI_IsMacroFun <> 0 - = SK_LocalDclMacroFunction index - = SK_Function index +checkQualifiedIdentExpression free_vars module_id ident_name is_expr_list e_input=:{ei_fun_index,ei_mod_index} e_state e_info cs + # (found,{decl_kind,decl_ident,decl_index},cs) = search_qualified_ident module_id ident_name ExpressionNameSpaceN cs + | not found + = (EE, free_vars, e_state, e_info, cs) + = case decl_kind of + STE_Imported STE_DclFunction mod_index + # ({ft_type={st_arity},ft_priority}, e_info) = e_info!ef_modules.[mod_index].dcl_functions.[decl_index] + # kind = SK_Function { glob_object = decl_index, glob_module = mod_index } + # symbol = { symb_ident = decl_ident, symb_kind = kind } + # (app_expr, e_state) = build_application_or_constant_for_function symbol st_arity ft_priority e_state + | not e_info.ef_is_macro_fun || dcl_fun_is_called_before decl_index mod_index e_state.es_calls + -> (app_expr, free_vars, e_state, e_info, cs) + # e_state = { e_state & es_calls = [DclFunCall mod_index decl_index : e_state.es_calls ]} + -> (app_expr, free_vars, e_state, e_info, cs) + STE_Imported STE_Constructor mod_index + # ({cons_type={st_arity},cons_priority}, e_info) = e_info!ef_modules.[mod_index].dcl_common.com_cons_defs.[decl_index] + # kind = SK_Constructor { glob_object = decl_index, glob_module = mod_index } + # symbol = { symb_ident = decl_ident, symb_kind = kind } + # app_expr = build_application_or_constant_for_constructor symbol st_arity cons_priority + -> (app_expr, free_vars, e_state, e_info, cs) + STE_Imported STE_Member mod_index + # ({me_type={st_arity},me_priority}, e_info) = e_info!ef_modules.[mod_index].dcl_common.com_member_defs.[decl_index] + # kind = SK_OverloadedFunction { glob_object = decl_index, glob_module = mod_index } + # symbol = { symb_ident = decl_ident, symb_kind = kind } + # (app_expr, e_state) = build_application_or_constant_for_function symbol st_arity me_priority e_state + -> (app_expr, free_vars, e_state, e_info, cs) + STE_Imported (STE_DclMacroOrLocalMacroFunction _) mod_index + # (macro_def,e_info) = e_info!ef_macro_defs.[mod_index,decl_index] + # {fun_ident,fun_arity,fun_kind,fun_priority,fun_info={fi_properties}}=macro_def + # index = { glob_object = decl_index, glob_module = mod_index } + # symbol_kind = convert_DefOrImpFunKind_to_dcl_SymbKind fun_kind index fi_properties + # (e_state,cs) = add_call e_state decl_ident.id_info cs + with + add_call e_state=:{es_calls} symbol_table_ptr cs + # (entry=:{ste_kind,ste_index,ste_def_level},cs_symbol_table) = readPtr symbol_table_ptr cs.cs_symbol_table + # cs = {cs & cs_symbol_table=cs_symbol_table} + = case ste_kind of + /* also imported unqualified */ + STE_Imported (STE_DclMacroOrLocalMacroFunction calls) ste_mod_index + | ste_index==decl_index && ste_mod_index==mod_index + | is_called_before ei_fun_index calls + -> (e_state,cs) + # entry = {entry & ste_kind = STE_DclMacroOrLocalMacroFunction [ ei_fun_index : calls ]} + # cs = {cs & cs_symbol_table = writePtr symbol_table_ptr entry cs_symbol_table} + -> ({e_state & es_calls = [MacroCall ste_mod_index ste_index ste_def_level : es_calls ]},cs) + /* also imported unqualified */ + STE_DclMacroOrLocalMacroFunction calls + | ste_index==decl_index && mod_index==ei_mod_index + | is_called_before ei_fun_index calls + -> (e_state,cs) + # entry = {entry & ste_kind = STE_DclMacroOrLocalMacroFunction [ ei_fun_index : calls ]} + # cs = {cs & cs_symbol_table = writePtr symbol_table_ptr entry cs_symbol_table} + -> ({e_state & es_calls = [MacroCall ei_mod_index ste_index ste_def_level : es_calls ]},cs) + _ + | macro_is_called_before decl_index mod_index es_calls + -> (e_state,cs) + -> ({ e_state & es_calls = [MacroCall mod_index decl_index (-1) : es_calls ]},cs) + + macro_is_called_before decl_index mod_index [] + = False + macro_is_called_before decl_index mod_index [MacroCall macro_mod_index macro_index level:calls] + = (decl_index==macro_index && mod_index==macro_mod_index && level==(-1)) || macro_is_called_before decl_index mod_index calls + macro_is_called_before decl_index mod_index [_:calls] + = macro_is_called_before decl_index mod_index calls + # symbol = { symb_ident = decl_ident, symb_kind = symbol_kind } + # (app_expr, e_state) = build_application_or_constant_for_function symbol fun_arity fun_priority e_state + -> (app_expr, free_vars, e_state, e_info, cs) + _ + -> (EE, free_vars, e_state, e_info, { cs & cs_error = checkError (module_id.id_name+++"@"+++ident_name) "not imported" cs.cs_error }) + where + build_application_or_constant_for_function symbol arity priority e_state + | is_expr_list + = (Constant symbol arity priority cIsAFunction, e_state) + # (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap + # app = { app_symb = symbol , app_args = [], app_info_ptr = new_info_ptr } + = (App app, { e_state & es_expr_heap = es_expr_heap }) + + build_application_or_constant_for_constructor symbol arity priority + | is_expr_list + = Constant symbol arity priority cIsNotAFunction + = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr } + +convert_DefOrImpFunKind_to_dcl_SymbKind FK_Macro index fi_properties + = SK_DclMacro index; +convert_DefOrImpFunKind_to_dcl_SymbKind _ index fi_properties + | fi_properties bitand FI_IsMacroFun <> 0 + = SK_LocalDclMacroFunction index + = SK_Function index + +is_called_before caller_index [] + = False +is_called_before caller_index [called_index : calls] + = caller_index == called_index || is_called_before caller_index calls + +dcl_fun_is_called_before ste_index mod_index [] + = False +dcl_fun_is_called_before ste_index mod_index [DclFunCall dcl_fun_mod_index dcl_fun_index:calls] + = (ste_index==dcl_fun_index && mod_index==dcl_fun_mod_index) || dcl_fun_is_called_before ste_index mod_index calls +dcl_fun_is_called_before ste_index mod_index [_:calls] + = dcl_fun_is_called_before ste_index mod_index calls checkPattern :: !ParsedExpr !(Optional (Bind Ident VarInfoPtr)) !PatternInput !(![Ident], ![ArrayPattern]) !*PatternState !*ExpressionInfo !*CheckState -> (!AuxiliaryPattern, !(![Ident], ![ArrayPattern]), !*PatternState, !*ExpressionInfo, !*CheckState) @@ -1374,6 +1458,8 @@ checkPattern (PE_List [exp]) opt_var p_input accus ps e_info cs=:{cs_symbol_tabl = case exp of PE_Ident ident -> checkIdentPattern cIsNotInExpressionList ident opt_var p_input accus ps e_info cs + PE_QualifiedIdent module_id ident_name + -> checkQualifiedIdentPattern cIsNotInExpressionList module_id ident_name opt_var p_input accus ps e_info cs _ -> checkPattern exp opt_var p_input accus ps e_info cs @@ -1397,13 +1483,15 @@ checkPattern (PE_List [exp1, exp2 : exps]) opt_var p_input accus ps e_info cs (right_pat, accus, ps, e_info, cs) = check_pattern right p_input accus ps e_info cs -> check_infix_pattern [] left_arg kind constant prio [right_pat] rest opt_var p_input accus ps e_info cs - -> (AP_Empty ds_ident, accus, ps, e_info, + -> (AP_Empty ds_ident.id_name, accus, ps, e_info, { cs & cs_error = checkError ds_ident "arguments of constructor are missing" cs.cs_error }) _ -> check_patterns [mid_pat : left] right rest opt_var p_input accus ps e_info cs check_pattern (PE_Ident id) p_input accus ps e_info cs = checkIdentPattern cIsInExpressionList id No p_input accus ps e_info cs + check_pattern (PE_QualifiedIdent module_id ident_name) p_input accus ps e_info cs + = checkQualifiedIdentPattern cIsInExpressionList module_id ident_name No p_input accus ps e_info cs check_pattern expr p_input accus ps e_info cs = checkPattern expr No p_input accus ps e_info cs @@ -1442,8 +1530,8 @@ checkPattern (PE_List [exp1, exp2 : exps]) opt_var p_input accus ps e_info cs -> check_infix_pattern [(kind1, cons1, prio1, left) : left_args] middle_pat kind2 cons2 prio2 [arg_pat] rest No p_input accus ps e_info cs No - -> (AP_Empty ds_ident, accus, ps, e_info, { cs & cs_error = checkError ds_ident "conflicting priorities" cs.cs_error }) - -> (AP_Empty ds_ident, accus, ps, e_info, { cs & cs_error = checkError ds_ident "arguments of constructor are missing" cs.cs_error }) + -> (AP_Empty ds_ident.id_name, accus, ps, e_info, { cs & cs_error = checkError ds_ident "conflicting priorities" cs.cs_error }) + -> (AP_Empty ds_ident.id_name, accus, ps, e_info, { cs & cs_error = checkError ds_ident "arguments of constructor are missing" cs.cs_error }) _ -> check_infix_pattern left_args left kind1 cons1 prio1 [inf_cons_pat : middle] [arg : rest] opt_var p_input accus ps e_info cs @@ -1477,7 +1565,7 @@ checkPattern (PE_List [exp1, exp2 : exps]) opt_var p_input accus ps e_info cs _ -> False) # (pattern, ps, e_info, cs) = buildPattern mod_index kind constant args opt_var ps e_info cs -> (pattern, ps, e_info, cs) - -> (AP_Empty ds_ident, ps, e_info, { cs & cs_error = checkError ds_ident "used with wrong arity" cs.cs_error}) + -> (AP_Empty ds_ident.id_name, ps, e_info, { cs & cs_error = checkError ds_ident "used with wrong arity" cs.cs_error}) _ | nr_of_args == 0 -> (first_expr, ps, e_info, cs) @@ -1513,7 +1601,10 @@ checkPattern (PE_Record record opt_type fields) opt_var p_input=:{pi_mod_index, (patterns, ps_var_heap) = bind_opt_record_variable opt_var pi_is_node_pattern patterns new_fields ps.ps_var_heap -> (AP_Algebraic record_symbol type_index patterns opt_var, (var_env, array_patterns), { ps & ps_var_heap = ps_var_heap }, e_info, cs) No - -> (AP_Empty (hd fields).bind_dst, accus, ps, e_info, cs) + # id_name = case (hd fields).bind_dst of + FieldName {id_name} -> id_name + QualifiedFieldName module_id field_name -> module_id.id_name+++"@"+++field_name + -> (AP_Empty id_name, accus, ps, e_info, cs) where check_field_pattern p_input=:{pi_def_level} {bind_src = PE_Empty, bind_dst = {glob_object={fs_var}}} @@ -1559,6 +1650,8 @@ checkPattern (PE_Bound bind) opt_var p_input accus ps e_info cs checkPattern (PE_Ident id) opt_var p_input accus ps e_info cs = checkIdentPattern cIsNotInExpressionList id opt_var p_input accus ps e_info cs +checkPattern (PE_QualifiedIdent module_id ident_name) opt_var p_input accus ps e_info cs + = checkQualifiedIdentPattern cIsNotInExpressionList module_id ident_name opt_var p_input accus ps e_info cs checkPattern PE_WildCard opt_var p_input accus ps e_info cs = (AP_WildCard No, accus, ps, e_info, cs) @@ -1613,13 +1706,27 @@ checkMacroPatternConstructor macro=:{fun_ident,fun_arity,fun_kind,fun_priority} # (pattern, ps, ef_modules, ef_cons_defs, cs_error) = unfoldPatternMacro macro mod_index [] opt_var ps e_info.ef_modules e_info.ef_cons_defs cs_error = (pattern, ps, { e_info & ef_modules = ef_modules, ef_cons_defs = ef_cons_defs }, { cs & cs_error = cs_error }) - = (AP_Empty ident, ps, e_info, { cs & cs_error = checkError ident "not defined" cs_error }) - = (AP_Empty ident, ps, e_info, { cs & cs_error = checkError fun_ident "not allowed in a pattern" cs_error }) + = (AP_Empty ident.id_name, ps, e_info, { cs & cs_error = checkError ident "not defined" cs_error }) + = (AP_Empty ident.id_name, ps, e_info, { cs & cs_error = checkError fun_ident "not allowed in a pattern" cs_error }) + +checkQualifiedMacroPatternConstructor macro=:{fun_ident,fun_arity,fun_kind,fun_priority} macro_mod_index mod_index is_dcl_macro is_expr_list ste_index module_name ident_name opt_var ps e_info cs=:{cs_error} + | case fun_kind of FK_Macro->True; _ -> False + | is_expr_list + # macro_symbol = { glob_object = MakeDefinedSymbol fun_ident ste_index fun_arity, glob_module = macro_mod_index } + = (AP_Constant (APK_Macro is_dcl_macro) macro_symbol fun_priority, ps, e_info, cs) + | fun_arity == 0 + # (pattern, ps, ef_modules, ef_cons_defs, cs_error) + = unfoldPatternMacro macro mod_index [] opt_var ps e_info.ef_modules e_info.ef_cons_defs cs_error + = (pattern, ps, { e_info & ef_modules = ef_modules, ef_cons_defs = ef_cons_defs }, { cs & cs_error = cs_error }) + # name=module_name+++"@"+++ident_name + = (AP_Empty name, ps, e_info, { cs & cs_error = checkError name "not defined" cs_error }) + # name=module_name+++"@"+++ident_name + = (AP_Empty name, ps, e_info, { cs & cs_error = checkError name "not allowed in a pattern" cs_error }) checkPatternConstructor :: !Index !Bool !SymbolTableEntry !Ident !(Optional (Bind Ident VarInfoPtr)) !*PatternState !*ExpressionInfo !*CheckState -> (!AuxiliaryPattern, !*PatternState, !*ExpressionInfo, !*CheckState); checkPatternConstructor _ _ {ste_kind = STE_Empty} ident _ ps e_info cs=:{cs_error} - = (AP_Empty ident, ps, e_info, { cs & cs_error = checkError ident "not defined" cs_error }) + = (AP_Empty ident.id_name, ps, e_info, { cs & cs_error = checkError ident "not defined" cs_error }) checkPatternConstructor mod_index is_expr_list {ste_kind = STE_FunctionOrMacro _,ste_index} ident opt_var ps e_info cs=:{cs_x} # (macro,ps) = ps!ps_fun_defs.[ste_index] = checkMacroPatternConstructor macro cs_x.x_main_dcl_module_n mod_index False is_expr_list ste_index ident opt_var ps e_info cs @@ -1651,6 +1758,42 @@ where determine_pattern_symbol mod_index id_index id_kind id_name cons_defs modules error = (id_index, NoIndex, 0, NoPrio, NoIndex, cons_defs, modules, checkError id_name "constructor expected" error) +checkQualifiedPatternConstructor :: !STE_Kind !Index !Ident !{#Char} !{#Char} !Index !Bool !(Optional (Bind Ident VarInfoPtr)) !*PatternState !*ExpressionInfo !*CheckState + -> (!AuxiliaryPattern, !*PatternState, !*ExpressionInfo, !*CheckState); +checkQualifiedPatternConstructor STE_Empty _ decl_ident module_name ident_name _ _ _ ps e_info cs=:{cs_error} + # name=module_name+++"@"+++ident_name + = (AP_Empty name, ps, e_info, { cs & cs_error = checkError name "not defined" cs_error }) +checkQualifiedPatternConstructor (STE_FunctionOrMacro _) ste_index decl_ident module_name ident_name mod_index is_expr_list opt_var ps e_info cs=:{cs_x} + # (macro,ps) = ps!ps_fun_defs.[ste_index] + = checkQualifiedMacroPatternConstructor macro cs_x.x_main_dcl_module_n mod_index False is_expr_list ste_index module_name ident_name opt_var ps e_info cs +checkQualifiedPatternConstructor (STE_DclMacroOrLocalMacroFunction _) ste_index decl_ident module_name ident_name mod_index is_expr_list opt_var ps e_info cs=:{cs_x} + # (macro,e_info) = e_info!ef_macro_defs.[mod_index,ste_index] + = checkQualifiedMacroPatternConstructor macro mod_index mod_index True is_expr_list ste_index module_name ident_name opt_var ps e_info cs +checkQualifiedPatternConstructor (STE_Imported (STE_DclMacroOrLocalMacroFunction _) macro_module_index) ste_index decl_ident module_name ident_name mod_index is_expr_list opt_var ps e_info cs + # (macro,e_info) = e_info!ef_macro_defs.[macro_module_index,ste_index] + = checkQualifiedMacroPatternConstructor macro macro_module_index mod_index True is_expr_list ste_index module_name ident_name opt_var ps e_info cs +checkQualifiedPatternConstructor ste_kind ste_index decl_ident module_name ident_name mod_index is_expr_list opt_var ps + e_info=:{ef_cons_defs,ef_modules} cs=:{cs_error} + # (cons_index, cons_module, cons_arity, cons_priority, cons_type_index, ef_cons_defs, ef_modules, cs_error) + = determine_pattern_symbol mod_index ste_index ste_kind module_name ident_name ef_cons_defs ef_modules cs_error + e_info = { e_info & ef_cons_defs = ef_cons_defs, ef_modules = ef_modules } + cons_symbol = { glob_object = MakeDefinedSymbol decl_ident cons_index cons_arity, glob_module = cons_module } + | is_expr_list + = (AP_Constant (APK_Constructor cons_type_index) cons_symbol cons_priority, ps, e_info, { cs & cs_error = cs_error }) + | cons_arity == 0 + = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = cs_error }) + = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = checkError ident_name "constructor arguments are missing" cs_error }) +where + determine_pattern_symbol mod_index id_index STE_Constructor module_name ident_name cons_defs modules error + # ({cons_type={st_arity},cons_priority, cons_type_index}, cons_defs) = cons_defs![id_index] + = (id_index, mod_index, st_arity, cons_priority, cons_type_index, cons_defs, modules, error) + determine_pattern_symbol mod_index id_index (STE_Imported STE_Constructor import_mod_index) module_name ident_name cons_defs modules error + # ({dcl_common},modules) = modules![import_mod_index] + {cons_type={st_arity},cons_priority, cons_type_index} = dcl_common.com_cons_defs.[id_index] + = (id_index, import_mod_index, st_arity, cons_priority, cons_type_index, cons_defs, modules, error) + determine_pattern_symbol mod_index id_index id_kind module_name ident_name cons_defs modules error + = (id_index, NoIndex, 0, NoPrio, NoIndex, cons_defs, modules, checkError (module_name+++"@"+++ident_name) "constructor expected" error) + checkBoundPattern {bind_src,bind_dst} opt_var p_input (var_env, array_patterns) ps e_info cs=:{cs_symbol_table} | isLowerCaseName bind_dst.id_name # (entry, cs_symbol_table) = readPtr bind_dst.id_info cs_symbol_table @@ -1685,6 +1828,17 @@ checkIdentPattern is_expr_list id=:{id_name,id_info} opt_var {pi_def_level, pi_m # (pattern, ps, e_info, cs) = checkPatternConstructor pi_mod_index is_expr_list entry id opt_var ps e_info { cs & cs_symbol_table = cs_symbol_table } = (pattern, accus, ps, e_info, cs) +checkQualifiedIdentPattern is_expr_list module_id ident_name opt_var {pi_mod_index} accus ps e_info cs + # (found,{decl_kind,decl_ident,decl_index},cs) = search_qualified_ident module_id ident_name ExpressionNameSpaceN cs + | not found + = (AP_Empty (module_id.id_name+++"@"+++ident_name), accus, ps, e_info, cs) + = case decl_kind of + STE_Imported _ _ + # (pattern, ps, e_info, cs) = checkQualifiedPatternConstructor decl_kind decl_index decl_ident module_id.id_name ident_name pi_mod_index is_expr_list opt_var ps e_info cs + -> (pattern, accus, ps, e_info, cs) + _ + -> (AP_Empty (module_id.id_name+++"@"+++ident_name), accus, ps, e_info, { cs & cs_error = checkError (module_id.id_name+++"@"+++ident_name) "not imported" cs.cs_error }) + convertSubPatterns :: [AuxiliaryPattern] Expression Position *(Heap VarInfo) *(Heap ExprInfo) u:[Ptr ExprInfo] *CheckState -> *(!.[FreeVar],!Expression,!Position,!*Heap VarInfo,!*Heap ExprInfo,!u:[Ptr ExprInfo],!*CheckState); convertSubPatterns [] result_expr pattern_position var_store expr_heap opt_dynamics cs = ([], result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) @@ -1954,7 +2108,7 @@ unfoldPatternMacro macro=:{fun_body=TransformedBody {tb_args,tb_rhs}} mod_index ums = { ums_var_heap = fold2St bind_var tb_args macro_args ps_var_heap, ums_modules = modules, ums_cons_defs = cons_defs, ums_error = error } (pattern, {ums_var_heap,ums_modules,ums_cons_defs,ums_error}) = unfold_pattern_macro mod_index macro.fun_ident opt_var extra_args tb_rhs ums = (pattern, { ps & ps_var_heap = ums_var_heap}, ums_modules, ums_cons_defs, ums_error) - = (AP_Empty macro.fun_ident, { ps & ps_var_heap = ps_var_heap}, modules, cons_defs, checkError macro.fun_ident "sharing not allowed" error) + = (AP_Empty macro.fun_ident.id_name, { ps & ps_var_heap = ps_var_heap}, modules, cons_defs, checkError macro.fun_ident "sharing not allowed" error) where no_sharing [{fv_count} : args] = fv_count <= 1 && no_sharing args @@ -1966,7 +2120,7 @@ where unfold_pattern_macro mod_index macro_ident _ extra_args (Var {var_ident,var_info_ptr}) ums=:{ums_var_heap, ums_error} | not (isEmpty extra_args) - = (AP_Empty macro_ident, { ums & ums_error = checkError macro_ident "too many arguments for pattern macro" ums_error }) + = (AP_Empty macro_ident.id_name, { ums & ums_error = checkError macro_ident "too many arguments for pattern macro" ums_error }) # (VI_Pattern pattern, ums_var_heap) = readPtr var_info_ptr ums_var_heap = (pattern, { ums & ums_var_heap = ums_var_heap}) unfold_pattern_macro mod_index macro_ident opt_var extra_args (App {app_symb={symb_kind=SK_Constructor {glob_module,glob_object},symb_ident},app_args}) @@ -1976,8 +2130,8 @@ where # (patterns, ums) = mapSt (unfold_pattern_macro mod_index macro_ident No []) app_args { ums & ums_cons_defs = ums_cons_defs, ums_modules = ums_modules } cons_symbol = { glob_object = MakeDefinedSymbol symb_ident cons_index cons_def.cons_type.st_arity, glob_module = glob_module } = (AP_Algebraic cons_symbol cons_def.cons_type_index (patterns++extra_args) opt_var, ums) - = (AP_Empty cons_def.cons_ident, { ums & ums_cons_defs = ums_cons_defs, ums_modules = ums_modules, - ums_error = checkError cons_def.cons_ident "wrong number of arguments" ums_error }) + = (AP_Empty cons_def.cons_ident.id_name, { ums & ums_cons_defs = ums_cons_defs, ums_modules = ums_modules, + ums_error = checkError cons_def.cons_ident "incorrect number of arguments" ums_error }) where get_cons_def mod_index cons_mod cons_index cons_defs modules | mod_index == cons_mod @@ -1988,12 +2142,12 @@ where = (cons_def, cons_index, cons_defs, modules) unfold_pattern_macro mod_index macro_ident opt_var extra_args (BasicExpr bv) ums=:{ums_error} | not (isEmpty extra_args) - = (AP_Empty macro_ident, { ums & ums_error = checkError macro_ident "too many arguments for pattern macro" ums_error }) + = (AP_Empty macro_ident.id_name, { ums & ums_error = checkError macro_ident "too many arguments for pattern macro" ums_error }) = (AP_Basic bv opt_var, ums) unfold_pattern_macro mod_index macro_ident opt_var _ expr ums=:{ums_error} - = (AP_Empty macro_ident, { ums & ums_error = checkError macro_ident "illegal rhs for a pattern macro" ums_error }) + = (AP_Empty macro_ident.id_name, { ums & ums_error = checkError macro_ident "illegal rhs for a pattern macro" ums_error }) unfoldPatternMacro macro mod_index all_macro_args opt_var ps=:{ps_var_heap} modules cons_defs error - = (AP_Empty macro.fun_ident, { ps & ps_var_heap = ps_var_heap}, modules, cons_defs, checkError macro.fun_ident "illegal macro in pattern" error) + = (AP_Empty macro.fun_ident.id_name, { ps & ps_var_heap = ps_var_heap}, modules, cons_defs, checkError macro.fun_ident "illegal macro in pattern" error) checkSelectors end_with_update free_vars [ selector : selectors ] e_input e_state e_info cs | isEmpty selectors @@ -2002,56 +2156,43 @@ checkSelectors end_with_update free_vars [ selector : selectors ] e_input e_stat # (selector, free_vars, e_state, e_info, cs) = check_selector cEndWithSelection free_vars selector e_input e_state e_info cs (selectors, free_vars, e_state, e_info, cs) = checkSelectors end_with_update free_vars selectors e_input e_state e_info cs = ([ selector : selectors ], free_vars, e_state, e_info, cs) -where +where check_selector _ free_vars (PS_Record selector=:{id_info,id_name} opt_type) e_input=:{ei_mod_index} e_state e_info=:{ef_selector_defs, ef_modules} cs=:{cs_symbol_table} # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table - # selectors = retrieveSelectorIndexes ei_mod_index entry + # selectors = retrieveSelectorIndexes ei_mod_index entry (field_module, field_index, field_nr, ef_selector_defs, ef_modules, cs) - = get_field_nr ei_mod_index selector opt_type selectors ef_selector_defs ef_modules { cs & cs_symbol_table = cs_symbol_table } + = get_field_nr ei_mod_index opt_type selectors id_name ef_selector_defs ef_modules { cs & cs_symbol_table = cs_symbol_table } = (RecordSelection { glob_object = MakeDefinedSymbol selector field_index 1, glob_module = field_module } field_nr, free_vars, e_state, {e_info & ef_selector_defs = ef_selector_defs, ef_modules = ef_modules }, cs) - where - get_field_nr :: !Index !Ident !(Optional Ident) ![Global Index] !u:{#SelectorDef} !v:{# DclModule} !*CheckState - -> (!Index, !Index, !Index, u:{#SelectorDef}, v:{#DclModule}, !*CheckState) - get_field_nr mod_index sel_id _ [] selector_defs modules cs=:{cs_error} - = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_error = checkError id_name "selector not defined" cs_error }) - get_field_nr mod_index sel_id (Yes type_id=:{id_info}) selectors selector_defs modules cs=:{cs_symbol_table,cs_error} - # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table - # (type_index, type_module) = retrieveGlobalDefinition entry STE_Type mod_index - | type_index <> NotFound - # (selector_index, selector_offset, selector_defs, modules) - = determine_selector mod_index type_module type_index selectors selector_defs modules - | selector_offset <> NoIndex - = (type_module, selector_index, selector_offset, selector_defs, modules, { cs & cs_symbol_table = cs_symbol_table }) - = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_symbol_table = cs_symbol_table, - cs_error = checkError id_name "selector not defined" cs_error }) - = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_symbol_table = cs_symbol_table, - cs_error = checkError type_id "type not defined" cs_error }) - get_field_nr mod_index sel_id No [{glob_object,glob_module}] selector_defs modules cs - | mod_index == glob_module - # (selector_offset,selector_defs) = selector_defs![glob_object].sd_field_nr - = (glob_module, glob_object, selector_offset, selector_defs, modules, cs) - # (selector_offset,modules) = modules![glob_module].dcl_common.com_selector_defs.[glob_object].sd_field_nr - = (glob_module, glob_object, selector_offset, selector_defs, modules, cs) - get_field_nr mod_index sel_id No _ selector_defs modules cs=:{cs_error} - = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_error = checkError sel_id "ambiguous selector specified" cs_error }) - - determine_selector :: !Index !Index !Index ![Global Index] !u:{# SelectorDef} !v:{# DclModule} -> (!Int, !Int, !u:{# SelectorDef}, !v:{# DclModule}) - determine_selector mod_index type_mod_index type_index [] selector_defs modules - = (NoIndex, NoIndex, selector_defs, modules) - determine_selector mod_index type_mod_index type_index [{glob_module, glob_object} : selectors] selector_defs modules - | type_mod_index == glob_module - | type_mod_index == mod_index - # (selector_def,selector_defs) = selector_defs![glob_object] - | selector_def.sd_type_index == type_index - = (glob_object, selector_def.sd_field_nr, selector_defs, modules) - = determine_selector mod_index type_mod_index type_index selectors selector_defs modules - # (selector_def, modules) = modules![glob_module].dcl_common.com_selector_defs.[glob_object] - | selector_def.sd_type_index == type_index - = (glob_object, selector_def.sd_field_nr, selector_defs, modules) - = determine_selector mod_index type_mod_index type_index selectors selector_defs modules - = determine_selector mod_index type_mod_index type_index selectors selector_defs modules + + check_selector _ free_vars (PS_QualifiedRecord module_id field_name opt_type) e_input=:{ei_mod_index} e_state + e_info cs=:{cs_symbol_table} + # (entry, symbol_table) = readPtr module_id.id_info cs_symbol_table + # cs = {cs & cs_symbol_table=symbol_table} + = case entry.ste_kind of + STE_ModuleQualifiedImports sorted_qualified_imports + # selectors = retrieve_qualified_selector_indices field_name sorted_qualified_imports + # {ef_selector_defs, ef_modules}=e_info + (field_module, field_index, field_nr, ef_selector_defs, ef_modules, cs) + = get_field_nr ei_mod_index opt_type selectors field_name ef_selector_defs ef_modules cs + selector = {id_name=field_name,id_info=nilPtr} + -> (RecordSelection { glob_object = MakeDefinedSymbol selector field_index 1, glob_module = field_module } field_nr, free_vars, e_state, + {e_info & ef_selector_defs = ef_selector_defs, ef_modules = ef_modules }, cs) + STE_ClosedModule + -> not_imported_error cs + STE_Module _ + -> not_imported_error cs + _ + # selector = {id_name=field_name,id_info=nilPtr} + -> (RecordSelection {glob_object = MakeDefinedSymbol selector NoIndex 1,glob_module = NoIndex} + NoIndex, free_vars, e_state, e_info, + {cs & cs_error = checkError module_id "not defined" cs.cs_error }) + where + not_imported_error cs + # selector = {id_name=field_name,id_info=nilPtr} + = (RecordSelection {glob_object = MakeDefinedSymbol selector NoIndex 1,glob_module = NoIndex} NoIndex, + free_vars, e_state, e_info, {cs & cs_error = checkError (module_id.id_name+++"@"+++field_name) "not imported" cs.cs_error }) check_selector end_with_update free_vars (PS_Array index_expr) e_input e_state e_info cs | end_with_update @@ -2060,16 +2201,68 @@ where # (glob_select_symb, cs) = getPredefinedGlobalSymbol PD_ArraySelectFun PD_StdArray STE_Member 2 cs = checkArraySelection glob_select_symb free_vars index_expr e_input e_state e_info cs - +get_field_nr :: !Index !OptionalRecordName ![Global Index] !{#Char} !u:{#SelectorDef} !v:{# DclModule} !*CheckState + -> (!Index, !Index, !Index, u:{#SelectorDef}, v:{#DclModule}, !*CheckState) +get_field_nr mod_index _ [] id_name selector_defs modules cs=:{cs_error} + = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_error = checkError id_name "selector not defined" cs_error }) +get_field_nr mod_index (RecordNameIdent type_id=:{id_info}) selectors id_name selector_defs modules cs=:{cs_symbol_table,cs_error} + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + # (type_index, type_module) = retrieveGlobalDefinition entry STE_Type mod_index + | type_index <> NotFound + # (selector_index, selector_offset, selector_defs, modules) + = determine_selector mod_index type_module type_index selectors selector_defs modules + | selector_offset <> NoIndex + = (type_module, selector_index, selector_offset, selector_defs, modules, { cs & cs_symbol_table = cs_symbol_table }) + = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_symbol_table = cs_symbol_table, + cs_error = checkError id_name "selector not defined" cs_error }) + = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_symbol_table = cs_symbol_table, + cs_error = checkError type_id "type not defined" cs_error }) +get_field_nr mod_index (RecordNameQualifiedIdent module_id record_name) selectors id_name selector_defs modules cs + # (found,{decl_kind,decl_ident,decl_index},cs) = search_qualified_ident module_id record_name TypeNameSpaceN cs + | not found + = (NoIndex, NoIndex, NoIndex, selector_defs, modules, cs) + = case decl_kind of + STE_Imported STE_Type type_mod_index + # (selector_index, selector_offset, selector_defs, modules) + = determine_selector mod_index type_mod_index decl_index selectors selector_defs modules + | selector_offset <> NoIndex + -> (type_mod_index, selector_index, selector_offset, selector_defs, modules, cs) + -> (NoIndex, NoIndex, NoIndex, selector_defs, modules, + {cs & cs_error = checkError id_name "selector not defined" cs.cs_error }) + _ + -> (NoIndex, NoIndex, NoIndex, selector_defs, modules, + {cs & cs_error = checkError (module_id.id_name+++"@"+++record_name) "type not defined" cs.cs_error} ) +get_field_nr mod_index NoRecordName [{glob_object,glob_module}] id_name selector_defs modules cs + | mod_index == glob_module + # (selector_offset,selector_defs) = selector_defs![glob_object].sd_field_nr + = (glob_module, glob_object, selector_offset, selector_defs, modules, cs) + # (selector_offset,modules) = modules![glob_module].dcl_common.com_selector_defs.[glob_object].sd_field_nr + = (glob_module, glob_object, selector_offset, selector_defs, modules, cs) +get_field_nr mod_index NoRecordName _ id_name selector_defs modules cs=:{cs_error} + = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_error = checkError id_name "ambiguous selector specified" cs_error }) + +determine_selector :: !Index !Index !Index ![Global Index] !u:{# SelectorDef} !v:{# DclModule} -> (!Int, !Int, !u:{# SelectorDef}, !v:{# DclModule}) +determine_selector mod_index type_mod_index type_index [] selector_defs modules + = (NoIndex, NoIndex, selector_defs, modules) +determine_selector mod_index type_mod_index type_index [{glob_module, glob_object} : selectors] selector_defs modules + | type_mod_index == glob_module + | type_mod_index == mod_index + # (selector_def,selector_defs) = selector_defs![glob_object] + | selector_def.sd_type_index == type_index + = (glob_object, selector_def.sd_field_nr, selector_defs, modules) + = determine_selector mod_index type_mod_index type_index selectors selector_defs modules + # (selector_def, modules) = modules![glob_module].dcl_common.com_selector_defs.[glob_object] + | selector_def.sd_type_index == type_index + = (glob_object, selector_def.sd_field_nr, selector_defs, modules) + = determine_selector mod_index type_mod_index type_index selectors selector_defs modules + = determine_selector mod_index type_mod_index type_index selectors selector_defs modules checkArraySelection glob_select_symb free_vars index_expr e_input e_state e_info cs # (index_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars index_expr e_input e_state e_info cs (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap = (ArraySelection glob_select_symb new_info_ptr index_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs) - - -checkFields :: !Index ![FieldAssignment] !(Optional Ident) !u:ExpressionInfo !*CheckState +checkFields :: !Index ![FieldAssignment] !OptionalRecordName !u:ExpressionInfo !*CheckState -> (!Optional ((Global DefinedSymbol), Index, [Bind ParsedExpr (Global FieldSymbol)]), !u:ExpressionInfo, !*CheckState) checkFields mod_index field_ass opt_type e_info=:{ef_selector_defs,ef_type_defs,ef_modules} cs # (ok, field_ass, cs) = check_fields field_ass cs @@ -2082,19 +2275,38 @@ checkFields mod_index field_ass opt_type e_info=:{ef_selector_defs,ef_type_defs, # (field_exprs, cs_error) = check_and_rearrange_fields type_mod_index 0 rt_fields field_ass cs.cs_error -> (Yes ({ glob_object = rt_constructor, glob_module = type_mod_index }, td_index, field_exprs), e_info, { cs & cs_error = cs_error }) Yes _ - # (Yes type_ident) = opt_type + # (RecordNameIdent type_ident) = opt_type -> (No, e_info, { cs & cs_error = checkError type_ident "not a record constructor" cs.cs_error }) No -> (No, e_info, cs) = (No, e_info, cs) where - check_fields [ bind=:{bind_dst} : field_ass ] cs=:{cs_symbol_table,cs_error} - # (entry, cs_symbol_table) = readPtr bind_dst.id_info cs_symbol_table + check_fields [ bind=:{bind_dst=bind_dst=:FieldName field_ident} : field_ass ] cs=:{cs_symbol_table,cs_error} + # (entry, cs_symbol_table) = readPtr field_ident.id_info cs_symbol_table # fields = retrieveSelectorIndexes mod_index entry | isEmpty fields - = (False, [], { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError bind_dst "not defined as a record field" cs_error }) + = (False, [], { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError field_ident "not defined as a record field" cs_error }) # (ok, field_ass, cs) = check_fields field_ass { cs & cs_symbol_table = cs_symbol_table } = (ok, [{bind & bind_dst = (bind_dst, fields)} : field_ass], cs) + check_fields [ bind=:{bind_dst=bind_dst=:QualifiedFieldName module_id field_name} : field_ass ] cs=:{cs_symbol_table} + # (entry, symbol_table) = readPtr module_id.id_info cs_symbol_table + # cs = {cs & cs_symbol_table=symbol_table} + = case entry.ste_kind of + STE_ModuleQualifiedImports sorted_qualified_imports + # fields = retrieve_qualified_selector_indices field_name sorted_qualified_imports + | isEmpty fields + -> not_imported_error cs + # (ok, field_ass, cs) = check_fields field_ass cs + -> (ok, [{bind & bind_dst = (bind_dst, fields)} : field_ass], cs) + STE_ClosedModule + -> not_imported_error cs + STE_Module _ + -> not_imported_error cs + _ + -> (False, [], { cs & cs_error = checkError module_id "not defined" cs.cs_error }) + where + not_imported_error cs + = (False, [], { cs & cs_error = checkError (module_id.id_name+++"@"+++field_name) "not defined as a record field" cs.cs_error }) check_fields [] cs = (True, [], cs) @@ -2105,7 +2317,7 @@ where try_to_get_unique_field [ _ : fields ] = try_to_get_unique_field fields - determine_record_type mod_index (Yes type_id=:{id_info}) _ selector_defs type_defs modules cs=:{cs_symbol_table, cs_error} + determine_record_type mod_index (RecordNameIdent type_id=:{id_info}) _ selector_defs type_defs modules cs=:{cs_symbol_table, cs_error} # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table # (type_index, type_mod_index) = retrieveGlobalDefinition entry STE_Type mod_index | type_index <> NotFound @@ -2115,7 +2327,22 @@ where # (type_def, modules) = modules![type_mod_index].dcl_common.com_type_defs.[type_index] = (Yes (type_def, type_mod_index), selector_defs, type_defs, modules, { cs & cs_symbol_table = cs_symbol_table }) = (No, selector_defs, type_defs, modules, { cs & cs_error = checkError type_id "not defined" cs_error, cs_symbol_table = cs_symbol_table}) - determine_record_type mod_index No fields selector_defs type_defs modules cs=:{cs_error} + + determine_record_type mod_index (RecordNameQualifiedIdent module_id record_name) _ selector_defs type_defs modules cs + # (found,{decl_kind,decl_ident,decl_index},cs) = search_qualified_ident module_id record_name TypeNameSpaceN cs + | not found + = (No, selector_defs, type_defs, modules, cs) + = case decl_kind of + STE_Imported STE_Type type_mod_index + | type_mod_index==mod_index + # (type_def, type_defs) = type_defs![decl_index] + -> (Yes (type_def, type_mod_index), selector_defs, type_defs, modules, cs) + # (type_def, modules) = modules![type_mod_index].dcl_common.com_type_defs.[decl_index] + -> (Yes (type_def, type_mod_index), selector_defs, type_defs, modules, cs) + _ + -> (No, selector_defs, type_defs, modules, { cs & cs_error = checkError (module_id.id_name+++"@"+++record_name) "not imported" cs.cs_error }) + + determine_record_type mod_index NoRecordName fields selector_defs type_defs modules cs=:{cs_error} # succ = try_to_get_unique_field fields = case succ of Yes {glob_module, glob_object} @@ -2130,7 +2357,7 @@ where No -> (No, selector_defs, type_defs, modules, { cs & cs_error = checkError "could not determine the type of this record" "" cs.cs_error }) - check_and_rearrange_fields :: !Int !Int !{#FieldSymbol} ![Bind ParsedExpr (Ident,[Global .Int])] !*ErrorAdmin -> (![Bind ParsedExpr .(Global FieldSymbol)],!.ErrorAdmin); + check_and_rearrange_fields :: !Int !Int !{#FieldSymbol} ![Bind ParsedExpr (FieldNameOrQualifiedFieldName,[Global .Int])] !*ErrorAdmin -> (![Bind ParsedExpr .(Global FieldSymbol)],!.ErrorAdmin); check_and_rearrange_fields mod_index field_index fields field_ass cs_error | field_index < size fields # (field_expr, field_ass) = look_up_field mod_index fields.[field_index] field_ass @@ -2302,6 +2529,15 @@ buildApplication symbol form_arity act_arity is_fun args e_state=:{es_expr_heap} = (app, e_state, checkError symbol.symb_ident "used with too many arguments" error) = (app, e_state, error) +buildApplicationWithoutArguments :: !SymbIdent !Bool !*ExpressionState !*ErrorAdmin -> (!Expression,!*ExpressionState,!*ErrorAdmin) +buildApplicationWithoutArguments symbol is_fun e_state error + | is_fun + # (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap + # app = App { app_symb = symbol , app_args = [], app_info_ptr = new_info_ptr } + = (app, { e_state & es_expr_heap = es_expr_heap }, error) + # app = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr } + = (app, e_state, error) + buildPattern mod_index (APK_Constructor type_index) cons_ident args opt_var ps e_info cs = (AP_Algebraic cons_ident type_index args opt_var, ps, e_info, cs) buildPattern mod_index (APK_Macro is_dcl_macro) {glob_module,glob_object} args opt_var ps e_info=:{ef_modules,ef_macro_defs,ef_cons_defs} cs=:{cs_error} @@ -2393,7 +2629,7 @@ allocate_free_var ident var_heap newVarId name = { id_name = name, id_info = nilPtr } - +retrieveSelectorIndexes :: Int !SymbolTableEntry -> [(Global Int)] retrieveSelectorIndexes mod_index {ste_kind = STE_Selector selector_list, ste_index, ste_previous } = map (adjust_mod_index mod_index) selector_list where @@ -2404,6 +2640,10 @@ where retrieveSelectorIndexes mod_index off_kind = [] +retrieve_qualified_selector_indices field_name sorted_qualified_imports + = [{glob_module=type_mod_index,glob_object=decl_index} \\ + {decl_kind=STE_Imported (STE_Field selector) type_mod_index,decl_index} + <- search_qualified_imports field_name sorted_qualified_imports FieldNameSpaceN] instance <<< FieldSymbol diff --git a/frontend/checksupport.dcl b/frontend/checksupport.dcl index 25af501..9af55a6 100644 --- a/frontend/checksupport.dcl +++ b/frontend/checksupport.dcl @@ -103,6 +103,7 @@ cConversionTableSize :== 10 , icl_function_indices :: !IclFunctionIndices , icl_common :: !.CommonDefs , icl_import :: !{!Declaration} + , icl_qualified_imports :: ![([Declaration], ModuleN, Position)] , icl_imported_objects :: ![ImportedObject] , icl_foreign_exports :: ![ForeignExport] , icl_used_module_numbers :: !NumberSet diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl index 2864644..edb5dd2 100644 --- a/frontend/checksupport.icl +++ b/frontend/checksupport.icl @@ -362,8 +362,8 @@ where # ({ste_kind,ste_previous}, symbol_table) = readPtr id_info symbol_table = case ste_kind of - STE_Field field_id - # symbol_table = removeFieldFromSelectorDefinition field_id NoIndex decl_index symbol_table + STE_Field selector_id + # symbol_table = removeFieldFromSelectorDefinition selector_id NoIndex decl_index symbol_table | ste_previous.ste_def_level == scope -> symbol_table <:= (id_info, ste_previous.ste_previous) -> symbol_table <:= (id_info, ste_previous) diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index 9b30ab8..98bd02e 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -4,6 +4,7 @@ import StdEnv import syntax, checksupport, check, typesupport, utilities, compilerSwitches // , RWSDebug import genericsupport +from explicitimports import search_qualified_ident,::NameSpaceN,TypeNameSpaceN,ClassNameSpaceN :: TypeSymbols = { ts_type_defs :: !.{# CheckedTypeDef} @@ -100,16 +101,35 @@ where retrieveTypeDefinition :: SymbolPtr !Index !*SymbolTable ![SymbolPtr] -> ((!Index, !Index), !*SymbolTable, ![SymbolPtr]) retrieveTypeDefinition type_ptr mod_index symbol_table used_types - # (entry, symbol_table) = readPtr type_ptr symbol_table - = case entry of - ({ste_kind = this_kind =: STE_Imported STE_Type decl_index, ste_def_level, ste_index}) - -> ((ste_index, decl_index), symbol_table <:= (type_ptr, { entry & ste_kind = STE_UsedType decl_index this_kind }), [type_ptr : used_types]) - ({ste_kind = this_kind =: STE_Type, ste_def_level, ste_index}) + # (entry=:{ste_kind,ste_def_level,ste_index}, symbol_table) = readPtr type_ptr symbol_table + = case ste_kind of + this_kind=:(STE_Imported STE_Type ste_mod_index) + -> ((ste_index, ste_mod_index), symbol_table <:= (type_ptr, { entry & ste_kind = STE_UsedType ste_mod_index this_kind }), [type_ptr : used_types]) + this_kind=:STE_Type | ste_def_level == cGlobalScope -> ((ste_index, mod_index), symbol_table <:= (type_ptr, { entry & ste_kind = STE_UsedType mod_index this_kind }), [type_ptr : used_types]) -> ((NotFound, mod_index), symbol_table, used_types) - ({ste_kind = STE_UsedType mod_index _, ste_def_level, ste_index}) + STE_UsedType mod_index _ -> ((ste_index, mod_index), symbol_table, used_types) + this_kind=:(STE_UsedQualifiedType uqt_mod_index uqt_index orig_kind) + | uqt_mod_index==mod_index && uqt_index==ste_index + -> ((ste_index, mod_index),symbol_table, used_types) + -> retrieve_type_definition orig_kind + with + retrieve_type_definition (STE_UsedQualifiedType uqt_mod_index uqt_index orig_kind) + | uqt_mod_index==mod_index && uqt_index==ste_index + = ((ste_index, mod_index),symbol_table, used_types) + = retrieve_type_definition orig_kind + retrieve_type_definition (STE_Imported STE_Type ste_mod_index) + = ((ste_index, ste_mod_index), symbol_table <:= (type_ptr, { entry & ste_kind = STE_UsedType ste_mod_index this_kind }), used_types) + retrieve_type_definition STE_Type + | ste_def_level == cGlobalScope + = ((ste_index, mod_index), symbol_table <:= (type_ptr, { entry & ste_kind = STE_UsedType mod_index this_kind }), used_types) + = ((NotFound, mod_index), symbol_table, used_types) + retrieve_type_definition (STE_UsedType mod_index _) + = ((ste_index, mod_index), symbol_table, used_types) + retrieve_type_definition _ + = ((NotFound, mod_index), symbol_table, used_types) _ -> ((NotFound, mod_index), symbol_table, used_types) @@ -157,25 +177,70 @@ where # (arg_type, _, ts_ti_cs) = bindTypes cti arg_type ts_ti_cs (res_type, _, ts_ti_cs) = bindTypes cti res_type ts_ti_cs = (arg_type --> res_type, TA_Multi, ts_ti_cs) -//AA.. bindTypes cti (TArrow1 type) ts_ti_cs # (type, _, ts_ti_cs) = bindTypes cti type ts_ti_cs = (TArrow1 type, TA_Multi, ts_ti_cs) -//..AA bindTypes cti (CV tv :@: types) ts_ti_cs # (tv, type_attr, ts_ti_cs) = bindTypes cti tv ts_ti_cs (types, _, ts_ti_cs) = bindTypes cti types ts_ti_cs = (CV tv :@: types, type_attr, ts_ti_cs) -// Sjaak 16-08-01 bindTypes cti (TFA vars type) (ts, ti=:{ti_type_heaps}, cs) # (type_vars, (_, ti_type_heaps, cs)) = addTypeVariablesToSymbolTable cRankTwoScope vars [] ti_type_heaps cs (type, _, (ts, ti, cs)) = bindTypes cti type (ts, {ti & ti_type_heaps = ti_type_heaps}, cs) cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cRankTwoScope type_vars cs.cs_symbol_table = (TFA type_vars type, TA_Multi, (ts, ti, { cs & cs_symbol_table = cs_symbol_table })) -// ... Sjaak + bindTypes cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} type=:(TQualifiedIdent module_id type_name types) + (ts=:{ts_type_defs,ts_modules}, ti, cs) + # (found,{decl_kind,decl_ident=type_ident,decl_index=type_index},cs) = search_qualified_ident module_id type_name TypeNameSpaceN cs + | not found + = (TE, TA_Multi, (ts, ti, cs)) + = case decl_kind of + STE_Imported STE_Type type_module + # ({td_arity,td_attribute,td_rhs},type_index,ts_type_defs,ts_modules) = getTypeDef type_index type_module cti_module_index ts_type_defs ts_modules + ts = { ts & ts_type_defs = ts_type_defs, ts_modules = ts_modules } + (cs_symbol_table, ti_used_types) = add_qualified_type_to_used_types type_ident.id_info type_module type_index cs.cs_symbol_table ti.ti_used_types + cs = {cs & cs_symbol_table = cs_symbol_table} + ti = { ti & ti_used_types = ti_used_types } + # type_cons = MakeNewTypeSymbIdent type_ident (length types) + | checkArityOfType type_cons.type_arity td_arity td_rhs + # (types, _, ts_ti_cs) = bindTypes cti types (ts, ti, cs) + | type_module == cti_module_index && cti_type_index == type_index + -> (TA { type_cons & type_index = { glob_object = type_index, glob_module = type_module}} types, cti_lhs_attribute, ts_ti_cs) + -> (TA { type_cons & type_index = { glob_object = type_index, glob_module = type_module}} types, + determine_type_attribute td_attribute, ts_ti_cs) + -> (TE, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_ident "used with wrong arity" cs.cs_error })) + _ + -> (TE, TA_Multi, (ts, ti, { cs & cs_error = checkError (module_id.id_name+++"@"+++type_name) "not imported" cs.cs_error})) + where + add_qualified_type_to_used_types symbol_table_ptr type_module type_index symbol_table used_types + # (entry=:{ste_kind,ste_index}, symbol_table) = readPtr symbol_table_ptr symbol_table + = case ste_kind of + STE_UsedQualifiedType mod_index decl_index next_kind + | (mod_index==type_module && decl_index==type_index) || qualified_type_occurs next_kind ste_index type_module type_index + -> (symbol_table, used_types) + # entry = {entry & ste_kind = STE_UsedQualifiedType type_module type_index ste_kind } + -> (writePtr symbol_table_ptr entry symbol_table, used_types) + STE_UsedType ste_module next_kind + | (ste_module==type_module && ste_index==type_index) || qualified_type_occurs next_kind ste_index type_module type_index + -> (symbol_table, used_types) + # entry = {entry & ste_kind = STE_UsedQualifiedType type_module type_index ste_kind } + -> (writePtr symbol_table_ptr entry symbol_table, used_types) + _ + # entry = {entry & ste_kind = STE_UsedQualifiedType type_module type_index ste_kind } + -> (writePtr symbol_table_ptr entry symbol_table, [symbol_table_ptr:used_types]) + + qualified_type_occurs (STE_UsedQualifiedType mod_index decl_index next_kind) ste_index type_module type_index + | mod_index==type_module && decl_index==type_index + = True + = qualified_type_occurs next_kind ste_index type_module type_index + qualified_type_occurs (STE_UsedType ste_module next_kind) ste_index type_module type_index + | ste_module==type_module && ste_index==type_index + = True + = qualified_type_occurs next_kind ste_index type_module type_index + qualified_type_occurs _ _ _ _ + = False bindTypes cti type ts_ti_cs = (type, TA_Multi, ts_ti_cs) - addToAttributeEnviron :: !TypeAttribute !TypeAttribute ![AttrInequality] !*ErrorAdmin -> (![AttrInequality],!*ErrorAdmin) addToAttributeEnviron TA_Multi _ attr_env error @@ -349,11 +414,21 @@ where retrieve_used_types symb_ptrs symbol_table = foldSt retrieve_used_type symb_ptrs ([], symbol_table) - where + where retrieve_used_type symb_ptr (used_types, symbol_table) - # (ste=:{ste_kind=STE_UsedType decl_index orig_kind,ste_index}, symbol_table) = readPtr symb_ptr symbol_table - = ([{gi_module = decl_index, gi_index = ste_index} : used_types], symbol_table <:= (symb_ptr, { ste & ste_kind = orig_kind })) - + # (ste=:{ste_kind,ste_index}, symbol_table) = readPtr symb_ptr symbol_table + # (orig_kind,used_types) = retrieve_used_types_of_ident ste_kind ste_index used_types + = (used_types, symbol_table <:= (symb_ptr, { ste & ste_kind = orig_kind })) + + retrieve_used_types_of_ident (STE_UsedType mod_index orig_kind) ste_index used_types + # used_types = [{gi_module = mod_index, gi_index = ste_index} : used_types] + = retrieve_used_types_of_ident orig_kind ste_index used_types + retrieve_used_types_of_ident (STE_UsedQualifiedType mod_index decl_index orig_kind) ste_index used_types + # used_types = [{gi_module = mod_index, gi_index = decl_index} : used_types] + = retrieve_used_types_of_ident orig_kind ste_index used_types + retrieve_used_types_of_ident orig_kind ste_index used_types + = (orig_kind,used_types) + CS_Checked :== 1 CS_Checking :== 0 @@ -607,7 +682,6 @@ checkOpenAType mod_index scope dem_attr_kind type=:{ at_type=TA type_cons=:{type ots = { ots & ots_type_defs = ots_type_defs, ots_modules = ots_modules } | x_check_dynamic_types && checkAbstractType type_module td_rhs = (type, (ots, oti, {cs & cs_error = checkError type_ident "(abstract type) not permitted in a dynamic type" cs.cs_error})) - | checkArityOfType type_cons.type_arity td_arity td_rhs # type_cons = { type_cons & type_index = { glob_object = type_index, glob_module = type_module }} (types, (ots, oti, cs)) = check_args_of_type_cons mod_index scope dem_attr_kind types td_args (ots, oti, cs) @@ -674,6 +748,27 @@ where remove_universal_var {atv_variable = {tv_ident}} cs_symbol_table = removeDefinitionFromSymbolTable cRankTwoScope tv_ident cs_symbol_table +checkOpenAType mod_index scope dem_attr_kind type=:{ at_type=TQualifiedIdent module_id type_name types, at_attribute} + (ots=:{ots_type_defs,ots_modules}, oti, cs=:{cs_symbol_table,cs_x={x_check_dynamic_types}}) + # (found,{decl_kind,decl_ident=type_ident,decl_index=type_index},cs) = search_qualified_ident module_id type_name TypeNameSpaceN cs + | not found + = (type, (ots, oti, cs)) + = case decl_kind of + STE_Imported STE_Type type_module + # id_name = type_name + # type_cons = MakeNewTypeSymbIdent type_ident (length types) + # ({td_arity,td_args,td_attribute,td_rhs},type_index,ots_type_defs,ots_modules) = getTypeDef type_index type_module mod_index ots_type_defs ots_modules + ots = { ots & ots_type_defs = ots_type_defs, ots_modules = ots_modules } + | x_check_dynamic_types && checkAbstractType type_module td_rhs + -> (type, (ots, oti, {cs & cs_error = checkError type_ident "(abstract type) not permitted in a dynamic type" cs.cs_error})) + | checkArityOfType type_cons.type_arity td_arity td_rhs + # type_cons = { type_cons & type_index = { glob_object = type_index, glob_module = type_module }} + (types, (ots, oti, cs)) = check_args_of_type_cons mod_index scope dem_attr_kind types td_args (ots, oti, cs) + (new_attr, oti, cs) = newAttribute (new_demanded_attribute dem_attr_kind td_attribute) id_name at_attribute oti cs + -> ({ type & at_type = TA type_cons types, at_attribute = new_attr } , (ots, oti, cs)) + -> (type, (ots, oti, {cs & cs_error = checkError type_ident "used with wrong arity" cs.cs_error})) + _ + -> (type, (ots, oti, {cs & cs_error = checkError (module_id.id_name+++"@"+++type_name) "not imported" cs.cs_error})) checkOpenAType mod_index scope dem_attr type=:{at_attribute} (ots, oti, cs) # (new_attr, oti, cs) = newAttribute dem_attr "." at_attribute oti cs = ({ type & at_attribute = new_attr}, (ots, oti, cs)) @@ -866,15 +961,14 @@ where checkTypeContext :: !Index !TypeContext !(!v:{# ClassDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState) -> (!TypeContext,!(!v:{# ClassDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)) checkTypeContext mod_index tc=:{tc_class, tc_types} (class_defs, ots, oti, cs) - # (tc_class, (class_defs, ots, cs=:{cs_error})) = check_context_class tc_class (class_defs, ots, cs) + # (tc_class, (class_defs, ots, cs=:{cs_error})) = check_context_class tc_class tc_types (class_defs, ots, cs) | cs_error.ea_ok # (tc_types, (ots, oti, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs) # cs = check_context_types tc_class tc_types cs = ({tc & tc_class = tc_class, tc_types = tc_types}, (class_defs, ots, oti, cs)) = ({tc & tc_types = []}, (class_defs, ots, oti, cs)) where - - check_context_class (TCClass cl) (class_defs, ots, cs) + check_context_class (TCClass cl) tc_types (class_defs, ots, cs) # (entry, cs_symbol_table) = readPtr cl.glob_object.ds_ident.id_info cs.cs_symbol_table # cs = { cs & cs_symbol_table = cs_symbol_table } # (class_index, class_module) = retrieveGlobalDefinition entry STE_Class mod_index @@ -882,17 +976,32 @@ where # (class_def, class_index, class_defs, ots_modules) = getClassDef class_index class_module mod_index class_defs ots.ots_modules # ots = { ots & ots_modules = ots_modules } | class_def.class_arity == cl.glob_object.ds_arity - # checked_class = - { cl + # checked_class = + { cl & glob_module = class_module , glob_object = {cl.glob_object & ds_index = class_index} - } + } = (TCClass checked_class, (class_defs, ots, cs)) # cs_error = checkError cl.glob_object.ds_ident "class used with wrong arity" cs.cs_error = (TCClass cl, (class_defs, ots, {cs & cs_error = cs_error})) # cs_error = checkError cl.glob_object.ds_ident "class undefined" cs.cs_error - = (TCClass cl, (class_defs, ots, {cs & cs_error = cs_error})) - check_context_class (TCGeneric gtc=:{gtc_generic, gtc_kind}) (class_defs, ots, cs) + = (TCClass cl, (class_defs, ots, {cs & cs_error = cs_error})) + check_context_class tc_class=:(TCQualifiedIdent module_id class_name) tc_types (class_defs, ots, cs) + # (found,{decl_kind,decl_ident=type_ident,decl_index=class_index},cs) = search_qualified_ident module_id class_name ClassNameSpaceN cs + | not found + = (tc_class, (class_defs, ots, cs)) + = case decl_kind of + STE_Imported STE_Class class_module + # ({class_ident,class_arity}, class_index, class_defs, ots_modules) = getClassDef class_index class_module mod_index class_defs ots.ots_modules + # ots = { ots & ots_modules = ots_modules } + | class_arity == length tc_types + # checked_class = { glob_object = MakeDefinedSymbol class_ident class_index class_arity, glob_module = class_module } + -> (TCClass checked_class, (class_defs, ots, cs)) + # cs_error = checkError (module_id.id_name+++"@"+++class_name) "class used with wrong arity" cs.cs_error + -> (tc_class, (class_defs, ots, {cs & cs_error = cs_error})) + _ + -> (tc_class, (class_defs, ots, {cs & cs_error = checkError (module_id.id_name+++"@"+++class_name) "class undefined" cs.cs_error})) + check_context_class (TCGeneric gtc=:{gtc_generic, gtc_kind}) tc_types (class_defs, ots, cs) # gen_ident = gtc_generic.glob_object.ds_ident # (entry, cs_symbol_table) = readPtr gen_ident.id_info cs.cs_symbol_table # cs = { cs & cs_symbol_table = cs_symbol_table } diff --git a/frontend/explicitimports.dcl b/frontend/explicitimports.dcl index 4d4483c..5eec130 100644 --- a/frontend/explicitimports.dcl +++ b/frontend/explicitimports.dcl @@ -7,11 +7,18 @@ import syntax, checksupport , ini_imp_decl :: !ImportDeclaration } -:: SolvedImports = - { si_explicit :: ![([Declaration], Position)] - , si_implicit :: ![(Index, Position)] // module indices +:: ExplicitImport = ! { + ei_module_n :: !Int, + ei_position :: !Position, + ei_symbols :: ![ImportNrAndIdents], + ei_qualified:: !Bool } +:: SolvedImports = + { si_explicit :: ![([Declaration], Position)] + , si_qualified_explicit :: ![([Declaration], ModuleN, Position)] + , si_implicit :: ![(ModuleN, Position)] + } markExplImpSymbols :: !Int !*(!*{!*{!u:ExplImpInfo}}, !*SymbolTable) -> (!.[Ident],!(!{!{!u:ExplImpInfo}},!.SymbolTable)) @@ -19,10 +26,26 @@ markExplImpSymbols :: !Int !*(!*{!*{!u:ExplImpInfo}}, !*SymbolTable) updateExplImpForMarkedSymbol :: !Index !Declaration !SymbolTableEntry !u:{#DclModule} !{!{!*ExplImpInfo}} !*SymbolTable -> (!u:{#DclModule}, !{!{!.ExplImpInfo}}, !.SymbolTable) -solveExplicitImports :: !(IntKeyHashtable [(Int,Position,[ImportNrAndIdents])]) !{#Int} !Index +solveExplicitImports :: !(IntKeyHashtable [ExplicitImport]) !{#Int} !Index !*(!v:{#DclModule},!*{#Int},!{!*ExplImpInfo},!*CheckState) -> (!.SolvedImports,! (!v:{#DclModule},!.{#Int},!{!.ExplImpInfo},!.CheckState)) -checkExplicitImportCompleteness :: ![([Declaration], Position)] !*{#DclModule} !*{#FunDef} !*{#*{#FunDef}} !*ExpressionHeap !*CheckState - -> (!.{#DclModule},!.{#FunDef},!*{#*{#FunDef}},!.ExpressionHeap,!.CheckState) +checkExplicitImportCompleteness :: ![([Declaration], Position)] ![([Declaration], Int, Position)] + !*{#DclModule} !*{#FunDef} !*{#*{#FunDef}} !*ExpressionHeap !*CheckState + -> (!.{#DclModule},!.{#FunDef},!*{#*{#FunDef}},!.ExpressionHeap,!.CheckState) + +store_qualified_explicit_imports_in_symbol_table :: ![([Declaration],Int,Position)] ![(SymbolPtr,STE_Kind)] !*SymbolTable *{#DclModule} -> (![(SymbolPtr,STE_Kind)],!*SymbolTable,!*{#DclModule}) + +:: NameSpaceN:==Int + +ExpressionNameSpaceN:==0 +TypeNameSpaceN:==1 +ClassNameSpaceN:==2 +FieldNameSpaceN:==3 +OtherNameSpaceN:==4 + +search_qualified_ident :: !Ident {#Char} !NameSpaceN !*CheckState -> (!Bool,!DeclarationRecord,!*CheckState) +search_qualified_import :: !String !SortedQualifiedImports !NameSpaceN -> (!Bool,!DeclarationRecord) +search_qualified_imports :: !String !SortedQualifiedImports !NameSpaceN -> [DeclarationRecord] +restore_module_ste_kinds_in_symbol_table :: ![(SymbolPtr,STE_Kind)] !*SymbolTable -> *SymbolTable diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl index 0d753bb..8670490 100644 --- a/frontend/explicitimports.icl +++ b/frontend/explicitimports.icl @@ -15,8 +15,9 @@ implies a b :== not a || b } :: SolvedImports = - { si_explicit :: ![([Declaration], Position)] - , si_implicit :: ![(Index, Position)] // module indices + { si_explicit :: ![([Declaration], Position)] + , si_qualified_explicit :: ![([Declaration], ModuleN, Position)] + , si_implicit :: ![(ModuleN, Position)] } markExplImpSymbols :: !Int !*(!*{!*{!u:ExplImpInfo}}, !*SymbolTable) -> (!.[Ident],!(!{!{!u:ExplImpInfo}},!.SymbolTable)) @@ -103,37 +104,61 @@ imp_decl_to_string (ID_OldSyntax idents) = "ID_OldSyntax "+++idents_to_string id */ getBelongingSymbolsFromID :: !ImportDeclaration -> Optional [ImportedIdent] -getBelongingSymbolsFromID (ID_Class _ x) = x +getBelongingSymbolsFromID (ID_Class _ x) = x getBelongingSymbolsFromID (ID_Type _ x) = x -getBelongingSymbolsFromID (ID_Record _ x) = x +getBelongingSymbolsFromID (ID_Record _ x) = x getBelongingSymbolsFromID _ = No -solveExplicitImports :: !(IntKeyHashtable [(Int,Position,[ImportNrAndIdents])]) !{#Int} !Index +solveExplicitImports :: !(IntKeyHashtable [ExplicitImport]) !{#Int} !Index !*(!v:{#DclModule},!*{#Int},!{!*ExplImpInfo},!*CheckState) -> (!.SolvedImports,! (!v:{#DclModule},!.{#Int},!{!.ExplImpInfo},!.CheckState)) solveExplicitImports expl_imp_indices_ikh modules_in_component_set importing_mod (dcl_modules, visited_modules, expl_imp_info, cs) # import_indices = ikhSearch` importing_mod expl_imp_indices_ikh - expl_imp_indices = [ imports \\ imports=:(_, _, [_:_]) <- import_indices ] - impl_imports = [ (mod_index, position) \\ imports=:(mod_index, position, []) <- import_indices ] + expl_imp_indices = [ imports \\ imports=:{ei_symbols=[_:_],ei_qualified=False} <- import_indices ] + qualified_expl_imp_indices = [ imports \\ imports=:{ei_symbols=[_:_],ei_qualified=True} <- import_indices ] + impl_imports = [ (ei_module_n,ei_position) \\ imports=:{ei_module_n,ei_position,ei_symbols=[]} <- import_indices ] + state = (dcl_modules, visited_modules, expl_imp_info, cs) + path = [importing_mod] (expl_imports, state) - = mapSt (solve_expl_imp_from_module expl_imp_indices_ikh modules_in_component_set importing_mod) - expl_imp_indices (dcl_modules, visited_modules, expl_imp_info, cs) - = ({ si_explicit = expl_imports, si_implicit = impl_imports }, state) + = mapSt (solve_expl_imp_from_module expl_imp_indices_ikh modules_in_component_set path) + expl_imp_indices state + path = [] + (qualified_expl_imports, state) + = mapSt (solve_qualified_expl_imp_from_module expl_imp_indices_ikh modules_in_component_set path) + qualified_expl_imp_indices state + = ({ si_explicit=expl_imports, si_qualified_explicit=qualified_expl_imports, si_implicit=impl_imports }, state) where - solve_expl_imp_from_module expl_imp_indices_ikh modules_in_component_set importing_mod - (imported_mod, position, imported_symbols) (dcl_modules, visited_modules, expl_imp_info, cs) + solve_expl_imp_from_module expl_imp_indices_ikh modules_in_component_set path + {ei_module_n=imported_mod, ei_position=position, ei_symbols=imported_symbols} (dcl_modules, visited_modules, expl_imp_info, cs) # (not_exported_symbols,decl_accu, unsolved_belonging, visited_modules, expl_imp_info) - = foldSt (search_expl_imp_symbol expl_imp_indices_ikh modules_in_component_set importing_mod imported_mod) - imported_symbols + = search_expl_imp_symbols imported_symbols expl_imp_indices_ikh modules_in_component_set path imported_mod ([],[], [], visited_modules, expl_imp_info) (expl_imp_info,cs_error) = report_not_exported_symbol_errors not_exported_symbols position expl_imp_info cs.cs_error (decl_accu, dcl_modules, visited_modules, expl_imp_info, cs) - = foldSt (solve_belonging position expl_imp_indices_ikh modules_in_component_set importing_mod) - unsolved_belonging + = solve_belongings unsolved_belonging position expl_imp_indices_ikh modules_in_component_set path (decl_accu, dcl_modules, visited_modules, expl_imp_info, { cs & cs_error = cs_error }) = ((decl_accu, position), (dcl_modules, visited_modules, expl_imp_info, cs)) - solve_belonging position expl_imp_indices_ikh modules_in_component_set importing_mod + solve_qualified_expl_imp_from_module expl_imp_indices_ikh modules_in_component_set path + {ei_module_n=imported_mod, ei_position=position, ei_symbols=imported_symbols} (dcl_modules, visited_modules, expl_imp_info, cs) + # (not_exported_symbols,decl_accu, unsolved_belonging, visited_modules, expl_imp_info) + = search_expl_imp_symbols imported_symbols expl_imp_indices_ikh modules_in_component_set path imported_mod + ([],[], [], visited_modules, expl_imp_info) + (expl_imp_info,cs_error) = report_not_exported_symbol_errors not_exported_symbols position expl_imp_info cs.cs_error + (decl_accu, dcl_modules, visited_modules, expl_imp_info, cs) + = solve_belongings unsolved_belonging position expl_imp_indices_ikh modules_in_component_set path + (decl_accu, dcl_modules, visited_modules, expl_imp_info, { cs & cs_error = cs_error }) + = ((decl_accu, imported_mod, position), (dcl_modules, visited_modules, expl_imp_info, cs)) + + search_expl_imp_symbols imported_symbols expl_imp_indices_ikh modules_in_component_set path imported_mod state + = foldSt (search_expl_imp_symbol expl_imp_indices_ikh modules_in_component_set path imported_mod) + imported_symbols state + + solve_belongings unsolved_belonging position expl_imp_indices_ikh modules_in_component_set path state + = foldSt (solve_belonging position expl_imp_indices_ikh modules_in_component_set path) + unsolved_belonging state + + solve_belonging position expl_imp_indices_ikh modules_in_component_set path (decl, {ini_symbol_nr, ini_imp_decl}, imported_mod) (decls_accu, dcl_modules, visited_modules, expl_imp_info, cs=:{cs_error, cs_symbol_table}) # (Yes belongs) @@ -152,26 +177,24 @@ solveExplicitImports expl_imp_indices_ikh modules_in_component_set importing_mod // an import like ::A(C1, C2) or ::A{f1} or class c{m1} # (nr_of_belongs, cs_symbol_table) = foldSt numerate_belongs all_belongs (0, cs_symbol_table) - belongs_bitvect - = bitvectCreate nr_of_belongs + belongs_bitvect = bitvectCreate nr_of_belongs (belongs_set, (cs_error, cs_symbol_table)) = mapFilterYesSt (get_opt_nr_and_ident position eii_ident) belongs (cs_error, cs_symbol_table) - cs_symbol_table - = foldSt restoreHeap all_belongs cs_symbol_table + cs_symbol_table = foldSt restoreHeap all_belongs cs_symbol_table -> (True, belongs_set, cs_error, cs_symbol_table) (decls_accu, dcl_modules, eii_declaring_modules, visited_modules, cs_error) - = foldSt + = foldSt (search_belonging need_all position eii_ident decl expl_imp_indices_ikh modules_in_component_set - imported_mod ini_symbol_nr importing_mod) + imported_mod ini_symbol_nr path) belongs_set (decls_accu, dcl_modules, eii_declaring_modules, visited_modules, cs_error) expl_imp_info = { expl_imp_info & [ini_symbol_nr] = ExplImpInfo eii_ident eii_declaring_modules } = (decls_accu, dcl_modules, visited_modules, expl_imp_info, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }) - - search_belonging need_all position eii_ident decl expl_imp_indices_ikh modules_in_component_set imported_mod ini_symbol_nr importing_mod + + search_belonging need_all position eii_ident decl expl_imp_indices_ikh modules_in_component_set imported_mod ini_symbol_nr path (belong_nr, belong_ident) (decls_accu, dcl_modules, eii_declaring_modules, visited_modules, cs_error) # (found, path, eii_declaring_modules, visited_modules) = depth_first_search expl_imp_indices_ikh modules_in_component_set - imported_mod ini_symbol_nr belong_nr belong_ident [importing_mod] + imported_mod ini_symbol_nr belong_nr belong_ident path eii_declaring_modules (bitvectResetAll visited_modules) = case found of Yes _ @@ -252,16 +275,16 @@ solveExplicitImports expl_imp_indices_ikh modules_in_component_set importing_mod cs_error = checkError ii_ident ("does not belong to "+++eii_ident.id_name) cs_error -> (No, (popErrorAdmin cs_error, cs_symbol_table)) - search_expl_imp_symbol :: (IntKeyHashtable [(Int,a,[ImportNrAndIdents])]) {#Int} Int Int ImportNrAndIdents - *([ImportNrAndIdents],[Declaration],[(Declaration,ImportNrAndIdents,Int)],*{#Int},*{!*ExplImpInfo}) + search_expl_imp_symbol :: (IntKeyHashtable [ExplicitImport]) {#Int} [Int] Int ImportNrAndIdents + *([ImportNrAndIdents],[Declaration],[(Declaration,ImportNrAndIdents,Int)],*{#Int},*{!*ExplImpInfo}) -> ([ImportNrAndIdents],[Declaration],[(Declaration,ImportNrAndIdents,Int)],*{#Int},*{!*ExplImpInfo}) - search_expl_imp_symbol expl_imp_indices_ikh modules_in_component_set importing_mod imported_mod + search_expl_imp_symbol expl_imp_indices_ikh modules_in_component_set path imported_mod ini=:{ini_symbol_nr} (not_exported_symbols,decls_accu, belonging_accu, visited_modules, expl_imp_info) # (ExplImpInfo eii_ident eii_declaring_modules, expl_imp_info) = replace expl_imp_info ini_symbol_nr TemporarilyFetchedAway (opt_decl, path, eii_declaring_modules, visited_modules) = depth_first_search expl_imp_indices_ikh modules_in_component_set imported_mod - ini_symbol_nr cUndef stupid_ident [importing_mod] + ini_symbol_nr cUndef stupid_ident path eii_declaring_modules (bitvectResetAll visited_modules) = case opt_decl of Yes di=:{di_decl} @@ -317,7 +340,7 @@ solveExplicitImports expl_imp_indices_ikh modules_in_component_set importing_mod [imported_mod:path] eii_declaring_modules (bitvectSet imported_mod visited_modules) - try_children [(imp_imp_mod, _, imp_imp_symbols):imports] expl_imp_indices_ikh + try_children [{ei_module_n=imp_imp_mod,ei_symbols=imp_imp_symbols}:imports] expl_imp_indices_ikh modules_in_component_set imported_symbol belong_nr belong_ident path eii_declaring_modules visited_modules | bitvectSelect imp_imp_mod visited_modules // | False--->"visited" = undef @@ -421,27 +444,31 @@ get_eei_ident (eii=:ExplImpInfo eii_ident _) = (eii_ident, eii) :: CheckCompletenessInputBox = { box_cci :: !CheckCompletenessInput } -checkExplicitImportCompleteness :: ![([Declaration], Position)] !*{#DclModule} !*{#FunDef} !*{#*{#FunDef}} !*ExpressionHeap !*CheckState - -> (!.{#DclModule},!.{#FunDef},!*{#*{#FunDef}},!.ExpressionHeap,!.CheckState) -checkExplicitImportCompleteness dcls_explicit dcl_modules icl_functions macro_defs expr_heap cs=:{cs_symbol_table, cs_error} +checkExplicitImportCompleteness :: ![([Declaration], Position)] ![([Declaration], Int, Position)] + !*{#DclModule} !*{#FunDef} !*{#*{#FunDef}} !*ExpressionHeap !*CheckState + -> (!.{#DclModule},!.{#FunDef},!*{#*{#FunDef}},!.ExpressionHeap,!.CheckState) +checkExplicitImportCompleteness dcls_explicit explicit_qualified_imports dcl_modules icl_functions macro_defs expr_heap cs=:{cs_symbol_table, cs_error} #! nr_icl_functions = size icl_functions #! n_dcl_modules = size dcl_modules - # box_ccs = { ccs_dcl_modules = dcl_modules, ccs_icl_functions = icl_functions, ccs_macro_defs=macro_defs, + + # (modified_symbol_ptrs,cs_symbol_table) = store_qualified_explicitly_imported_symbols_in_symbol_table explicit_qualified_imports [] cs_symbol_table + + box_ccs = { ccs_dcl_modules = dcl_modules, ccs_icl_functions = icl_functions, ccs_macro_defs=macro_defs, ccs_set_of_visited_icl_funs = createArray nr_icl_functions False, ccs_set_of_visited_macros = { {} \\ module_n<-[0..n_dcl_modules-1]}, ccs_expr_heap = expr_heap, ccs_symbol_table = cs_symbol_table, - ccs_error = cs_error, ccs_heap_changes_accu = [] } - main_dcl_module_n - = cs.cs_x.x_main_dcl_module_n -// ccs = foldSt (checkCompleteness main_dcl_module_n) dcls_explicit { box_ccs = box_ccs } - ccs = foldSt (\(dcls, position) ccs + ccs_error = cs_error, ccs_heap_changes_accu = modified_symbol_ptrs } + main_dcl_module_n = cs.cs_x.x_main_dcl_module_n + + ccs = foldSt (\(dcls, position) ccs -> foldSt (checkCompleteness main_dcl_module_n position) dcls ccs) dcls_explicit { box_ccs = box_ccs } - { ccs_dcl_modules, ccs_icl_functions,ccs_macro_defs,ccs_expr_heap, ccs_symbol_table, ccs_error, ccs_heap_changes_accu } = ccs.box_ccs + { ccs_dcl_modules, ccs_icl_functions,ccs_macro_defs,ccs_expr_heap, ccs_symbol_table, ccs_error, ccs_heap_changes_accu } = ccs.box_ccs // repair heap contents - ccs_symbol_table = foldSt replace_ste_with_previous ccs_heap_changes_accu ccs_symbol_table - cs = { cs & cs_symbol_table = ccs_symbol_table, cs_error = ccs_error } + ccs_symbol_table = restore_symbol_table_after_checking_completeness modified_symbol_ptrs ccs_symbol_table + + cs = { cs & cs_symbol_table = ccs_symbol_table, cs_error = ccs_error } = (ccs_dcl_modules, ccs_icl_functions,ccs_macro_defs, ccs_expr_heap, cs) where checkCompleteness :: !Int !Position !Declaration !*CheckCompletenessStateBox -> *CheckCompletenessStateBox @@ -480,12 +507,7 @@ checkExplicitImportCompleteness dcls_explicit dcl_modules icl_functions macro_de ccs = { ccs & box_ccs.ccs_set_of_visited_icl_funs.[decl_index] = True } cci = { box_cci = { cci_import_position = import_position, cci_main_dcl_module_n=main_dcl_module_n }} = check_completeness fun_body cci ccs - - replace_ste_with_previous :: !SymbolPtr !*SymbolTable -> .SymbolTable - replace_ste_with_previous changed_ste_ptr symbol_table - #! ({ste_previous}, symbol_table) = readPtr changed_ste_ptr symbol_table - = writePtr changed_ste_ptr ste_previous symbol_table - + instance toString STE_Kind where toString (STE_FunctionOrMacro _) = "function/macro" toString (STE_DclMacroOrLocalMacroFunction _) = "macro" @@ -503,28 +525,36 @@ check_whether_ident_is_imported :: !Ident !Int !Int !STE_Kind !CheckCompleteness check_whether_ident_is_imported ident module_n symbol_index wanted_ste_kind cci ccs=:{box_ccs=box_ccs=:{ccs_symbol_table}} #! (ste=:{ste_kind,ste_index}, ccs_symbol_table) = readPtr ident.id_info ccs_symbol_table ccs = { ccs & box_ccs = {box_ccs & ccs_symbol_table = ccs_symbol_table } } - | ste_index==symbol_index && is_imported_or_not_and_already_reported ste_kind wanted_ste_kind module_n + | is_imported ste_kind wanted_ste_kind symbol_index module_n ste_index = ccs - #! (ccs=:{box_ccs=box_ccs=:{ccs_symbol_table, ccs_error, ccs_heap_changes_accu}}) = ccs - {box_cci={cci_import_position}} = cci - ccs_error = checkErrorWithIdentPos (newPosition { id_name="import", id_info=nilPtr } cci_import_position) - (" "+++toString wanted_ste_kind+++" "+++toString ident.id_name+++" not imported") ccs_error - // pretend that the unimported symbol was imported to prevent doubling error mesages - ccs_symbol_table = writePtr ident.id_info { ste & ste_kind = STE_ExplImpSymbolNotImported module_n, ste_previous = ste } ccs_symbol_table - = { ccs & box_ccs = { box_ccs & ccs_error = ccs_error, ccs_symbol_table = ccs_symbol_table, - ccs_heap_changes_accu = [ident.id_info:ccs_heap_changes_accu] }} + #! (ccs=:{box_ccs=box_ccs=:{ccs_symbol_table, ccs_error, ccs_heap_changes_accu}}) = ccs + # {box_cci={cci_import_position}} = cci + ccs_error = checkErrorWithIdentPos (newPosition { id_name="import", id_info=nilPtr } cci_import_position) + (" "+++toString wanted_ste_kind+++" "+++toString ident.id_name+++" not imported") ccs_error + // pretend that the unimported symbol was imported to prevent doubling error mesages + ccs_symbol_table = writePtr ident.id_info { ste & ste_kind = STE_ExplImpSymbolNotImported module_n ste_kind } ccs_symbol_table + ccs_heap_changes_accu = case ste_kind of + STE_ExplImpSymbolNotImported _ _ + -> ccs_heap_changes_accu + STE_ImportedQualified _ _ + -> ccs_heap_changes_accu + _ + -> [ident.id_info:ccs_heap_changes_accu] + = { ccs & box_ccs = { box_ccs & ccs_error = ccs_error, ccs_symbol_table = ccs_symbol_table, ccs_heap_changes_accu = ccs_heap_changes_accu }} where - is_imported_or_not_and_already_reported :: !STE_Kind !STE_Kind !Int -> Bool - is_imported_or_not_and_already_reported (STE_Imported ste_kind ste_module_n) wanted_ste_kind module_n - = ste_kind==wanted_ste_kind && ste_module_n==module_n - is_imported_or_not_and_already_reported ste_kind wanted_ste_kind module_n - | ste_kind==wanted_ste_kind - = cci.box_cci.cci_main_dcl_module_n==module_n - = case ste_kind of - STE_ExplImpSymbolNotImported ste_module_n - -> ste_module_n==module_n - _ - -> False + is_imported :: !STE_Kind !STE_Kind !Int !Int !Int -> Bool + is_imported (STE_Imported ste_kind ste_module_n) wanted_ste_kind symbol_index module_n ste_index + = ste_module_n==module_n && ste_index==symbol_index && ste_kind==wanted_ste_kind + is_imported (STE_ImportedQualified (Declaration {decl_index,decl_kind=STE_Imported decl_kind decl_module_n}) ste_kind) wanted_ste_kind symbol_index module_n ste_index + | decl_module_n==module_n && decl_index==symbol_index && decl_kind==wanted_ste_kind + = True + = is_imported ste_kind wanted_ste_kind symbol_index module_n ste_index + is_imported (STE_ExplImpSymbolNotImported ste_module_n ste_kind) wanted_ste_kind symbol_index module_n ste_index + | module_n==ste_module_n + = True + = is_imported ste_kind wanted_ste_kind symbol_index module_n ste_index + is_imported ste_kind wanted_ste_kind symbol_index module_n ste_index + = cci.box_cci.cci_main_dcl_module_n==module_n && ste_index==symbol_index && ste_kind==wanted_ste_kind class check_completeness x :: !x !CheckCompletenessInputBox !*CheckCompletenessStateBox -> *CheckCompletenessStateBox @@ -855,3 +885,154 @@ stupid_ident =: { id_name = "stupid", id_info = nilPtr } // XXX from m import :: T(..) works also if T is a record type + +store_qualified_explicitly_imported_symbols_in_symbol_table :: ![([Declaration],Int,Position)] ![SymbolPtr] !*SymbolTable -> (![SymbolPtr],!*SymbolTable) +store_qualified_explicitly_imported_symbols_in_symbol_table [(declarations,module_n,position):qualified_explicit_imports] modified_symbol_ptrs symbol_table + # (modified_symbol_ptrs,symbol_table) = foldSt store_qualified_explicitly_imported_symbol declarations (modified_symbol_ptrs,symbol_table) + = store_qualified_explicitly_imported_symbols_in_symbol_table qualified_explicit_imports modified_symbol_ptrs symbol_table + where + store_qualified_explicitly_imported_symbol declaration=:(Declaration {decl_ident={id_info},decl_kind=STE_Imported _ module_n}) (modified_symbol_ptrs,symbol_table) + # (symbol_ste=:{ste_kind},symbol_table) = readPtr id_info symbol_table + # ste_kind = STE_ImportedQualified declaration ste_kind + # symbol_table = writePtr id_info {symbol_ste & ste_kind=ste_kind} symbol_table + = case ste_kind of + STE_ImportedQualified _ _ + -> ([id_info:modified_symbol_ptrs],symbol_table) + _ + -> (modified_symbol_ptrs,symbol_table) +store_qualified_explicitly_imported_symbols_in_symbol_table [] modified_symbol_ptrs symbol_table + = (modified_symbol_ptrs,symbol_table) + +restore_symbol_table_after_checking_completeness :: ![SymbolPtr] !*SymbolTable -> *SymbolTable +restore_symbol_table_after_checking_completeness modified_symbol_ptrs symbol_table + = foldSt restore_symbol modified_symbol_ptrs symbol_table + where + restore_symbol symbol_ptr symbol_table + # (symbol_ste=:{ste_kind},symbol_table) = readPtr symbol_ptr symbol_table + # ste_kind = restore_ste_kind ste_kind + with + restore_ste_kind (STE_ImportedQualified declaration ste_kind) + = restore_ste_kind ste_kind + restore_ste_kind (STE_ExplImpSymbolNotImported _ ste_kind) + = restore_ste_kind ste_kind + restore_ste_kind ste_kind + = ste_kind + = writePtr symbol_ptr {symbol_ste & ste_kind=ste_kind} symbol_table + +store_qualified_explicit_imports_in_symbol_table :: ![([Declaration],Int,Position)] ![(SymbolPtr,STE_Kind)] !*SymbolTable *{#DclModule} -> (![(SymbolPtr,STE_Kind)],!*SymbolTable,!*{#DclModule}) +store_qualified_explicit_imports_in_symbol_table [(declarations,module_n,position):qualified_explicit_imports] modified_ste_kinds symbol_table modules + # (module_symbol_ptr,modules) = modules![module_n].dcl_name.id_info + (module_ste=:{ste_kind},symbol_table) = readPtr module_symbol_ptr symbol_table + (modified_ste_kinds,sorted_qualified_imports) + = case ste_kind of + STE_ModuleQualifiedImports sorted_qualified_imports + -> (modified_ste_kinds,sorted_qualified_imports) + STE_ClosedModule + -> ([(module_symbol_ptr,ste_kind):modified_ste_kinds],EmptySortedQualifiedImports) + STE_Module _ + -> ([(module_symbol_ptr,ste_kind):modified_ste_kinds],EmptySortedQualifiedImports) + sorted_qualified_imports = foldSt add_qualified_import declarations sorted_qualified_imports + module_ste = {module_ste & ste_kind=STE_ModuleQualifiedImports sorted_qualified_imports} + symbol_table = writePtr module_symbol_ptr module_ste symbol_table + = store_qualified_explicit_imports_in_symbol_table qualified_explicit_imports modified_ste_kinds symbol_table modules +store_qualified_explicit_imports_in_symbol_table [] modified_ste_kinds symbol_table modules + = (modified_ste_kinds,symbol_table,modules) + +add_qualified_import :: !Declaration !u:SortedQualifiedImports -> u:SortedQualifiedImports +add_qualified_import new_declaration EmptySortedQualifiedImports + = SortedQualifiedImports new_declaration EmptySortedQualifiedImports EmptySortedQualifiedImports +add_qualified_import new_declaration=:(Declaration {decl_ident=new_ident,decl_kind=new_ste_kind}) (SortedQualifiedImports declaration=:(Declaration {decl_ident,decl_kind}) sqi_left sqi_right) + | new_ident.id_name<decl_ident.id_name + = SortedQualifiedImports declaration (add_qualified_import new_declaration sqi_left) sqi_right + | new_ident.id_name==decl_ident.id_name && less_imported_ste_kind new_ste_kind decl_kind + = SortedQualifiedImports declaration (add_qualified_import new_declaration sqi_left) sqi_right + = SortedQualifiedImports declaration sqi_left (add_qualified_import new_declaration sqi_right) + +less_imported_ste_kind (STE_Imported ste_kind1 _) (STE_Imported ste_kind2 _) + = ste_kind_to_name_space_n ste_kind1 < ste_kind_to_name_space_n ste_kind2 +less_imported_ste_kind _ _ + = False + +imported_ste_kind_to_name_space_n (STE_Imported ste_kind1 _) + = ste_kind_to_name_space_n ste_kind1 +imported_ste_kind_to_name_space_n _ + = 3 + +:: NameSpaceN:==Int + +ExpressionNameSpaceN:==0 +TypeNameSpaceN:==1 +ClassNameSpaceN:==2 +FieldNameSpaceN:==3 +OtherNameSpaceN:==4 + +ste_kind_to_name_space_n STE_DclFunction = ExpressionNameSpaceN +ste_kind_to_name_space_n STE_Constructor = ExpressionNameSpaceN +ste_kind_to_name_space_n STE_Member = ExpressionNameSpaceN +ste_kind_to_name_space_n (STE_DclMacroOrLocalMacroFunction _) = ExpressionNameSpaceN +ste_kind_to_name_space_n STE_Type = TypeNameSpaceN +ste_kind_to_name_space_n STE_Class = ClassNameSpaceN +ste_kind_to_name_space_n (STE_Field _) = FieldNameSpaceN +ste_kind_to_name_space_n _ = OtherNameSpaceN + +search_qualified_ident :: !Ident {#Char} !NameSpaceN !*CheckState -> (!Bool,!DeclarationRecord,!*CheckState) +search_qualified_ident module_id=:{id_info} ident_name name_space_n cs + # ({ste_kind}, cs_symbol_table) = readPtr id_info cs.cs_symbol_table + # cs = {cs & cs_symbol_table=cs_symbol_table} + = case ste_kind of + STE_ModuleQualifiedImports sorted_qualified_imports + # (found,declaration) = search_qualified_import ident_name sorted_qualified_imports name_space_n + | found + -> (True,declaration,cs) + -> not_imported_error cs + STE_ClosedModule + -> not_imported_error cs + STE_Module _ + -> not_imported_error cs + _ + -> (False,{decl_ident={id_name="",id_info=nilPtr},decl_pos=NoPos,decl_kind=STE_Empty,decl_index=NoIndex}, + {cs & cs_error=checkError module_id "undefined" cs.cs_error}) + where + not_imported_error cs + = (False,{decl_ident={id_name="",id_info=nilPtr},decl_pos=NoPos,decl_kind=STE_Empty,decl_index=NoIndex}, + {cs & cs_error=checkError (module_id.id_name+++"@"+++ident_name) "not imported" cs.cs_error}) + +search_qualified_import :: !String !SortedQualifiedImports !NameSpaceN -> (!Bool,!DeclarationRecord) +search_qualified_import name EmptySortedQualifiedImports name_space_n + = (False,{decl_ident = {id_name="",id_info=nilPtr},decl_pos=NoPos,decl_kind=STE_Empty,decl_index=0}) +search_qualified_import name (SortedQualifiedImports (Declaration declaration=:{decl_ident={id_name},decl_kind}) sqi_left sqi_right) name_space_n + | name==id_name + # decl_name_space_n = imported_ste_kind_to_name_space_n decl_kind + | name_space_n == decl_name_space_n + = (True,declaration) + | name_space_n < decl_name_space_n + = search_qualified_import name sqi_left name_space_n + = search_qualified_import name sqi_right name_space_n + | name<id_name + = search_qualified_import name sqi_left name_space_n + = search_qualified_import name sqi_right name_space_n + +search_qualified_imports :: !String !SortedQualifiedImports !NameSpaceN -> [DeclarationRecord] +search_qualified_imports name EmptySortedQualifiedImports name_space_n + = [] +search_qualified_imports name (SortedQualifiedImports (Declaration declaration=:{decl_ident={id_name},decl_kind}) sqi_left sqi_right) name_space_n + | name==id_name + # decl_name_space_n = imported_ste_kind_to_name_space_n decl_kind + | name_space_n == decl_name_space_n + # declarations_left =search_qualified_imports name sqi_left name_space_n + # declarations_right=search_qualified_imports name sqi_right name_space_n + = declarations_left++[declaration:declarations_right] + | name_space_n < decl_name_space_n + = search_qualified_imports name sqi_left name_space_n + = search_qualified_imports name sqi_right name_space_n + | name<id_name + = search_qualified_imports name sqi_left name_space_n + = search_qualified_imports name sqi_right name_space_n + +restore_module_ste_kinds_in_symbol_table :: ![(SymbolPtr,STE_Kind)] !*SymbolTable -> *SymbolTable +restore_module_ste_kinds_in_symbol_table [(ptr,ste_kind):ptrs_and_ste_kinds] symbol_table + # (ste,symbol_table) = readPtr ptr symbol_table + # symbol_table = writePtr ptr {ste & ste_kind=ste_kind} symbol_table + = restore_module_ste_kinds_in_symbol_table ptrs_and_ste_kinds symbol_table +restore_module_ste_kinds_in_symbol_table [] symbol_table + = symbol_table diff --git a/frontend/frontend.icl b/frontend/frontend.icl index 6b48483..8e8dd78 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -65,7 +65,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m select_and_remove_icl_functions_from_record :: !*IclModule -> (!.{#FunDef},!.IclModule) select_and_remove_icl_functions_from_record icl_mod=:{icl_functions} = (icl_functions,{icl_mod & icl_functions={}}) - # { icl_common,icl_function_indices,icl_name,icl_import,icl_imported_objects, + # { icl_common,icl_function_indices,icl_name,icl_import,icl_qualified_imports,icl_imported_objects, icl_foreign_exports,icl_used_module_numbers,icl_copied_from_dcl } = icl_mod /* (_,f,files) = fopen "components" FWriteText files @@ -167,7 +167,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m = (No,{},{},main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) # (ok, fun_defs, array_instances, common_defs, imported_funs, type_def_infos, heaps, predef_symbols, error,out) - = typeProgram (components -*-> "Typing") main_dcl_module_n fun_defs icl_function_indices.ifi_specials_indices list_inferred_types icl_common [a\\a<-:icl_import] dcl_mods icl_used_module_numbers td_infos heaps predef_symbols error out dcl_mods + = typeProgram (components -*-> "Typing") main_dcl_module_n fun_defs icl_function_indices.ifi_specials_indices list_inferred_types icl_common icl_import icl_qualified_imports dcl_mods icl_used_module_numbers td_infos heaps predef_symbols error out | not ok = (No,{},{},main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) @@ -289,8 +289,8 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m # heaps = {hp_var_heap = var_heap, hp_expression_heap=expression_heap, hp_type_heaps=type_heaps,hp_generic_heap=heaps.hp_generic_heap} # fe ={ fe_icl = {icl_functions=fun_defs, icl_function_indices=icl_function_indices, icl_common=icl_common, - icl_import=icl_import, icl_imported_objects=icl_imported_objects, icl_foreign_exports=icl_foreign_exports, - icl_name=icl_name,icl_used_module_numbers=icl_used_module_numbers, + icl_import=icl_import, icl_qualified_imports=icl_qualified_imports, icl_imported_objects=icl_imported_objects, + icl_foreign_exports=icl_foreign_exports,icl_name=icl_name,icl_used_module_numbers=icl_used_module_numbers, icl_copied_from_dcl=icl_copied_from_dcl,icl_modification_time=icl_mod.icl_modification_time } , fe_dcls = dcl_mods , fe_components = components diff --git a/frontend/parse.icl b/frontend/parse.icl index aa3afb0..21fd4c7 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -1081,7 +1081,9 @@ wantImports pState # (names, pState) = wantModuleIdents FunctionContext IC_Module pState (file_name, line_nr, pState) = getFileAndLineNr pState pState = wantEndOfDefinition "imports" pState - = (map (\name -> { import_module = name, import_symbols = [], import_file_position = LinePos file_name line_nr}) names, pState) + position = LinePos file_name line_nr + = ([ { import_module = name, import_symbols = [], import_file_position = position, import_qualified = False } + \\ name<-names], pState) wantFromImports :: !ParseState -> (!ParsedImport, !ParseState) wantFromImports pState @@ -1089,9 +1091,28 @@ wantFromImports pState (mod_ident, pState) = stringToIdent mod_name IC_Module pState pState = wantToken GeneralContext "from imports" ImportToken pState (file_name, line_nr, pState) = getFileAndLineNr pState - (import_symbols, pState) = wantSequence CommaToken GeneralContext pState + (token, pState) = nextToken GeneralContext pState + | case token of IdentToken "qualified" -> True ; _ -> False + # (import_symbols, pState) = wantImportDeclarations pState + pState = wantEndOfDefinition "from imports" pState + = ( { import_module = mod_ident, import_symbols = import_symbols, + import_file_position = LinePos file_name line_nr, import_qualified = True }, pState) + # (import_symbols, pState) = wantImportDeclarationsT token pState pState = wantEndOfDefinition "from imports" pState - = ( { import_module = mod_ident, import_symbols = import_symbols, import_file_position = LinePos file_name line_nr }, pState) + = ( { import_module = mod_ident, import_symbols = import_symbols, + import_file_position = LinePos file_name line_nr, import_qualified = False }, pState) +where + wantImportDeclarations pState + # (token, pState) = nextToken GeneralContext pState + = wantImportDeclarationsT token pState + + wantImportDeclarationsT token pState + # (first, pState) = wantImportDeclarationT token pState + (token, pState) = nextToken GeneralContext pState + | token == CommaToken + # (rest, pState) = wantImportDeclarations pState + = ([first : rest], pState) + = ([first], tokenBack pState) instance want ImportedObject where want pState @@ -1117,74 +1138,77 @@ instance want ImportDeclaration where want pState # (token, pState) = nextToken GeneralContext pState - = case token of - DoubleColonToken - # (name, pState) = wantConstructorName "import type" pState - (type_id, pState) = stringToIdent name IC_Type pState - (ii_extended, token, pState) = optional_extension_with_next_token pState - | token == OpenToken - # (conses, pState) = want_names (wantConstructorName "import type (..)") IC_Expression CloseToken pState - -> (ID_Type { ii_ident = type_id, ii_extended = ii_extended } (Yes conses), pState) - | token == CurlyOpenToken - # (fields, pState) = want_names (wantLowerCaseName "import record fields") (IC_Field type_id) CurlyCloseToken pState - -> (ID_Record { ii_ident = type_id, ii_extended = ii_extended } (Yes fields), pState) - -> (ID_Type { ii_ident = type_id, ii_extended = ii_extended } No, tokenBack pState) - ClassToken - # (name, pState) = want pState - (class_id, pState) = stringToIdent name IC_Class pState - (ii_extended, token, pState) = optional_extension_with_next_token pState - | token == OpenToken - # (members, pState) = want_names want IC_Expression CloseToken pState - -> (ID_Class { ii_ident = class_id, ii_extended = ii_extended } (Yes members), pState) - -> (ID_Class { ii_ident = class_id, ii_extended = ii_extended } No, tokenBack pState) - InstanceToken - # (class_name, pState) = want pState -// (ii_extended, pState) = optional_extension pState // MW: removed but still not ok - ii_extended = False - (types, pState) = wantList "instance types" tryBrackType pState - (class_id, pState) = stringToIdent class_name IC_Class pState - (inst_id, pState) = stringToIdent class_name (IC_Instance types) pState - (context, pState) = optionalContext pState - -> (ID_Instance { ii_ident = class_id, ii_extended = ii_extended } inst_id (types,context), pState) - IdentToken fun_name - # (fun_id, pState) = stringToIdent fun_name IC_Expression pState - (ii_extended, pState) = optional_extension pState - -> (ID_Function { ii_ident = fun_id, ii_extended = ii_extended }, pState) - token - # (fun_id, pState) = stringToIdent "dummy" IC_Expression pState - -> ( ID_Function { ii_ident = fun_id, ii_extended = False } - , parseError "from import" (Yes token) "imported item" pState - ) - where - want_names want_fun ident_kind close_token pState - # (token, pState) = nextToken FunctionContext pState - | token == DotDotToken - = ([], wantToken FunctionContext "import declaration" close_token pState) - = want_list_of_names want_fun ident_kind close_token (tokenBack pState) - - want_list_of_names want_fun ident_kind close_token pState - # (name, pState) = want_fun pState - (name_id, pState) = stringToIdent name ident_kind pState - (ii_extended, token, pState) = optional_extension_with_next_token pState - | token == CommaToken - # (names, pState) = want_list_of_names want_fun ident_kind close_token pState - = ([{ ii_ident = name_id, ii_extended = ii_extended } : names], pState) - | token == close_token - = ([{ ii_ident = name_id, ii_extended = ii_extended }], pState) - = ([{ ii_ident = name_id, ii_extended = ii_extended }], parseError "ImportDeclaration" (Yes token) ")" pState) - - optional_extension pState - # (token, pState) = nextToken FunctionContext pState - | token == DotDotToken - = (True, pState) - = (False, tokenBack pState) - - optional_extension_with_next_token pState + = wantImportDeclarationT token pState + +wantImportDeclarationT token pState + = case token of + DoubleColonToken + # (name, pState) = wantConstructorName "import type" pState + (type_id, pState) = stringToIdent name IC_Type pState + (ii_extended, token, pState) = optional_extension_with_next_token pState + | token == OpenToken + # (conses, pState) = want_names (wantConstructorName "import type (..)") IC_Expression CloseToken pState + -> (ID_Type { ii_ident = type_id, ii_extended = ii_extended } (Yes conses), pState) + | token == CurlyOpenToken + # (fields, pState) = want_names (wantLowerCaseName "import record fields") (IC_Field type_id) CurlyCloseToken pState + -> (ID_Record { ii_ident = type_id, ii_extended = ii_extended } (Yes fields), pState) + -> (ID_Type { ii_ident = type_id, ii_extended = ii_extended } No, tokenBack pState) + ClassToken + # (name, pState) = want pState + (class_id, pState) = stringToIdent name IC_Class pState + (ii_extended, token, pState) = optional_extension_with_next_token pState + | token == OpenToken + # (members, pState) = want_names want IC_Expression CloseToken pState + -> (ID_Class { ii_ident = class_id, ii_extended = ii_extended } (Yes members), pState) + -> (ID_Class { ii_ident = class_id, ii_extended = ii_extended } No, tokenBack pState) + InstanceToken + # (class_name, pState) = want pState +// (ii_extended, pState) = optional_extension pState // MW: removed but still not ok + ii_extended = False + (types, pState) = wantList "instance types" tryBrackType pState + (class_id, pState) = stringToIdent class_name IC_Class pState + (inst_id, pState) = stringToIdent class_name (IC_Instance types) pState + (context, pState) = optionalContext pState + -> (ID_Instance { ii_ident = class_id, ii_extended = ii_extended } inst_id (types,context), pState) + IdentToken fun_name + # (fun_id, pState) = stringToIdent fun_name IC_Expression pState + (ii_extended, pState) = optional_extension pState + -> (ID_Function { ii_ident = fun_id, ii_extended = ii_extended }, pState) + token + # (fun_id, pState) = stringToIdent "dummy" IC_Expression pState + -> ( ID_Function { ii_ident = fun_id, ii_extended = False } + , parseError "from import" (Yes token) "imported item" pState + ) +where + want_names want_fun ident_kind close_token pState + # (token, pState) = nextToken FunctionContext pState + | token == DotDotToken + = ([], wantToken FunctionContext "import declaration" close_token pState) + = want_list_of_names want_fun ident_kind close_token (tokenBack pState) + + want_list_of_names want_fun ident_kind close_token pState + # (name, pState) = want_fun pState + (name_id, pState) = stringToIdent name ident_kind pState + (ii_extended, token, pState) = optional_extension_with_next_token pState + | token == CommaToken + # (names, pState) = want_list_of_names want_fun ident_kind close_token pState + = ([{ ii_ident = name_id, ii_extended = ii_extended } : names], pState) + | token == close_token + = ([{ ii_ident = name_id, ii_extended = ii_extended }], pState) + = ([{ ii_ident = name_id, ii_extended = ii_extended }], parseError "ImportDeclaration" (Yes token) ")" pState) + + optional_extension pState + # (token, pState) = nextToken FunctionContext pState + | token == DotDotToken + = (True, pState) + = (False, tokenBack pState) + + optional_extension_with_next_token pState + # (token, pState) = nextToken FunctionContext pState + | token == DotDotToken # (token, pState) = nextToken FunctionContext pState - | token == DotDotToken - # (token, pState) = nextToken FunctionContext pState - = (True, token, pState) - = (False, token, pState) + = (True, token, pState) + = (False, token, pState) /* Classes and instances @@ -1430,19 +1454,23 @@ where -> (True, TCGeneric gen_type_context, pState) _ # pState = tokenBack pState - # (ident, pState) = stringToIdent name IC_Class pState + # (ident, pState) = stringToIdent name IC_Class pState # class_global_ds = { glob_object = MakeDefinedSymbol ident NoIndex (-1), glob_module = NoIndex } -> (True, TCClass class_global_ds, pState) - _ + QualifiedIdentToken module_name ident_name + # (module_ident, pState) = stringToIdent module_name IC_Module pState + -> (True, TCQualifiedIdent module_ident ident_name, pState) + _ -> (False, abort "no tc_class", tokenBack pState) build_context types length_types (TCClass class_global_ds=:{glob_object}) pState # tc_class = TCClass {class_global_ds & glob_object = {glob_object & ds_arity = length_types}} = ({ tc_class = tc_class, tc_var = nilPtr, tc_types = types}, pState) + build_context types length_types tc_class=:(TCQualifiedIdent module_name ident_name) pState + = ({ tc_class = tc_class, tc_var = nilPtr, tc_types = types}, pState) build_context types 1 (TCGeneric gtc=:{gtc_generic=gtc_generic=:{glob_object}}) pState # gtc = { gtc & gtc_generic = {gtc_generic & glob_object = {glob_object & ds_arity = 1}}} = ({ tc_class = TCGeneric gtc, tc_var = nilPtr, tc_types = types }, pState) - build_context types length_types tc_class=:(TCGeneric _) pState # pState = parseErrorSimple "type context" "generic class can have only one class argument" pState = (abort "No TypeContext", pState) @@ -1571,6 +1599,7 @@ where , gc_kind = KindError } = (derive_def, pState) + get_type_cons :: Type !*ParseState -> (TypeCons, !*ParseState) get_type_cons (TA type_symb []) pState = (TypeConsSymb type_symb, pState) @@ -1979,6 +2008,13 @@ where (context, pState) = optionalContext (tokenBack pState) (attr_env, pState) = optionalCoercions pState = (makeSymbolType [] type context attr_env, pState) + want_rest_of_symbol_type token [{sp_type=type=:{at_type = TQualifiedIdent module_ident type_name [] },sp_annotation} : types] pState + # pState = warnIfStrictAnnot sp_annotation pState + # (atypes,pState) = atypes_from_sptypes_and_warn_if_strict types pState + # type = { type & at_type = TQualifiedIdent module_ident type_name atypes } + (context, pState) = optionalContext (tokenBack pState) + (attr_env, pState) = optionalCoercions pState + = (makeSymbolType [] type context attr_env, pState) want_rest_of_symbol_type token types pState = (makeSymbolType [] (MakeAttributedType TE) [] [], parseError "symbol type" (Yes token) "->" pState) -->> types @@ -2230,14 +2266,14 @@ where = (TA { sym & type_arity = length types } types, pState) convert_list_of_types (TV tv) types pState = (CV tv :@: types, pState) -//AA.. convert_list_of_types TArrow [type1, type2] pState = (type1 --> type2, pState) convert_list_of_types TArrow [type1] pState = (TArrow1 type1, pState) convert_list_of_types (TArrow1 type1) [type2] pState = (type1 --> type2, pState) -//..AA + convert_list_of_types (TQualifiedIdent module_ident type_name []) types pState + = (TQualifiedIdent module_ident type_name types, pState) convert_list_of_types _ types pState = (TE, parseError "Type" No "ordinary type variable" pState) // ... Sjaak @@ -2400,6 +2436,11 @@ trySimpleTypeT CurlyOpenToken attr pState trySimpleTypeT StringTypeToken attr pState # type = makeStringType = (True, {at_attribute = attr, at_type = type}, pState) +trySimpleTypeT (QualifiedIdentToken module_name ident_name) attr pState + | not (isLowerCaseName ident_name) + # (module_id, pState) = stringToIdent module_name IC_Module pState + # type = TQualifiedIdent module_id ident_name [] + = (True, {at_attribute = attr, at_type = type}, pState) trySimpleTypeT token attr pState # (bt, pState) = try token pState = case bt of @@ -2644,13 +2685,13 @@ where wantSelectors :: Token *ParseState -> *(![ParsedSelection], !*ParseState) wantSelectors token pState - # (selector, pState) = want_selector token pState - (token, pState) = nextToken FunctionContext pState - | token == DotToken - # (token, pState) = nextToken FunctionContext pState - (selectors, pState) = wantSelectors token pState - = (selector ++ selectors, pState) - = (selector, tokenBack pState) + # (selector, pState) = want_selector token pState + (token, pState) = nextToken FunctionContext pState + | token == DotToken + # (token, pState) = nextToken FunctionContext pState + (selectors, pState) = wantSelectors token pState + = (selector ++ selectors, pState) + = (selector, tokenBack pState) where want_selector :: !Token !*ParseState -> *(![ParsedSelection], !*ParseState) want_selector SquareOpenToken pState @@ -2666,18 +2707,37 @@ where # (selectors, pState) = want_array_selectors pState = ([selector : selectors], pState) = ([selector], tokenBack pState) - want_selector (IdentToken name) pState | isUpperCaseName name - # (field_name, pState) = want (wantToken FunctionContext "array selector" DotToken pState) - (field_id, pState) = stringToIdent field_name IC_Selector pState - (type_id, pState) = stringToIdent name IC_Type pState - = ([PS_Record field_id (Yes type_id)], pState) - # (field_id, pState) = stringToIdent name IC_Selector pState - = ([PS_Record field_id No], pState) + # pState = wantToken FunctionContext "record selector" DotToken pState + (type_id, pState) = stringToIdent name IC_Type pState + = want_field_after_record_type (RecordNameIdent type_id) pState + # (selector_id, pState) = stringToIdent name IC_Selector pState + = ([PS_Record selector_id NoRecordName], pState) + want_selector (QualifiedIdentToken module_name ident_name) pState + | isUpperCaseName ident_name + # pState = wantToken FunctionContext "record selector" DotToken pState + (module_id, pState) = stringToIdent module_name IC_Module pState + = want_field_after_record_type (RecordNameQualifiedIdent module_id ident_name) pState + # (module_id, pState) = stringToIdent module_name IC_Module pState + = ([PS_QualifiedRecord module_id ident_name NoRecordName], pState) want_selector token pState = ([PS_Erroneous], parseError "simple RHS expression" (Yes token) "<selector>" pState) + want_field_after_record_type record_name pState + # (token, pState) = nextToken GeneralContext pState + = case token of + IdentToken field_name + | isLowerCaseName field_name + # (selector_id, pState) = stringToIdent field_name IC_Selector pState + -> ([PS_Record selector_id record_name], pState) + QualifiedIdentToken module_name field_name + | isLowerCaseName field_name + # (module_id, pState) = stringToIdent module_name IC_Module pState + -> ([PS_QualifiedRecord module_id field_name record_name], pState) + _ + -> ([PS_Erroneous], parseError "record field" (Yes token) "lower case ident" pState) + trySimpleExpression :: !Bool !ParseState -> (!Bool, !ParsedExpr, !ParseState) trySimpleExpression is_pattern pState | is_pattern @@ -2777,6 +2837,10 @@ trySimpleExpressionT (CharToken char) is_pattern pState = (True, PE_Basic (BVC char), pState) trySimpleExpressionT (RealToken real) is_pattern pState = (True, PE_Basic (BVR real), pState) +trySimpleExpressionT (QualifiedIdentToken module_name ident_name) is_pattern pState + | not is_pattern || not (isLowerCaseName ident_name) + # (module_id, pState) = stringToIdent module_name IC_Module pState + = (True, PE_QualifiedIdent module_id ident_name, pState) trySimpleExpressionT token is_pattern pState | is_pattern | token == WildCardToken @@ -3280,19 +3344,17 @@ wantRecordOrArrayExp is_pattern pState = (PE_ArrayDenot [], pState) # (opt_type, pState) = try_type_specification token pState = case opt_type of - Yes _ - -> want_record opt_type pState - _ + NoRecordName # (succ, field, pState) = try_field_assignment token pState | succ # (token, pState) = nextToken FunctionContext pState | token == CommaToken # (token, pState) = nextToken FunctionContext pState (fields, pState) = want_field_assignments cIsNotAPattern token pState - -> (PE_Record PE_Empty No [ field : fields ], wantToken FunctionContext "record or array" CurlyCloseToken pState) + -> (PE_Record PE_Empty NoRecordName [ field : fields ], wantToken FunctionContext "record or array" CurlyCloseToken pState) | token == CurlyCloseToken - -> (PE_Record PE_Empty No [ field ], pState) - -> (PE_Record PE_Empty No [ field ], parseError "record or array" (Yes token) "}" pState) + -> (PE_Record PE_Empty NoRecordName [ field ], pState) + -> (PE_Record PE_Empty NoRecordName [ field ], parseError "record or array" (Yes token) "}" pState) # (expr, pState) = wantRhsExpressionT token pState (token, pState) = nextToken FunctionContext pState | token == AndToken @@ -3302,6 +3364,8 @@ wantRecordOrArrayExp is_pattern pState -> wantArrayComprehension expr pState # (elems, pState) = want_array_elems token pState -> (PE_ArrayDenot [expr : elems], pState) + opt_type + -> want_record opt_type pState where want_array_elems CurlyCloseToken pState = ([], pState) @@ -3319,23 +3383,38 @@ where (type_id, pState) = stringToIdent name IC_Type pState (token, pState) = nextToken FunctionContext pState (fields, pState) = want_field_assignments cIsAPattern token pState - = (PE_Record PE_Empty (Yes type_id) fields, wantToken FunctionContext "record pattern" CurlyCloseToken pState) + = (PE_Record PE_Empty (RecordNameIdent type_id) fields, wantToken FunctionContext "record pattern" CurlyCloseToken pState) + want_record_pattern (QualifiedIdentToken module_name record_name) pState + | isUpperCaseName record_name + # pState = wantToken FunctionContext "record pattern" BarToken pState + (module_id, pState) = stringToIdent module_name IC_Module pState + (token, pState) = nextToken FunctionContext pState + (fields, pState) = want_field_assignments cIsAPattern token pState + = (PE_Record PE_Empty (RecordNameQualifiedIdent module_id record_name) fields, wantToken FunctionContext "record pattern" CurlyCloseToken pState) want_record_pattern token pState # (fields, pState) = want_field_assignments cIsAPattern token pState - = (PE_Record PE_Empty No fields, wantToken FunctionContext "record pattern" CurlyCloseToken pState) + = (PE_Record PE_Empty NoRecordName fields, wantToken FunctionContext "record pattern" CurlyCloseToken pState) try_type_specification (IdentToken type_name) pState | isUpperCaseName type_name || isFunnyIdName type_name # (token, pState) = nextToken FunctionContext pState | token == BarToken # (type_id, pState) = stringToIdent type_name IC_Type pState - = (Yes type_id, pState) - = (No, tokenBack pState) - = (No, pState) + = (RecordNameIdent type_id, pState) + = (NoRecordName, tokenBack pState) + = (NoRecordName, pState) + try_type_specification (QualifiedIdentToken module_name record_name) pState + | isUpperCaseName record_name || isFunnyIdName record_name + # (token, pState) = nextToken FunctionContext pState + | token == BarToken + # (module_ident, pState) = stringToIdent module_name IC_Module pState + = (RecordNameQualifiedIdent module_ident record_name, pState) + = (NoRecordName, tokenBack pState) + = (NoRecordName, pState) try_type_specification _ pState - = (No, pState) + = (NoRecordName, pState) - want_updates :: !(Optional Ident) Token ParseState -> ([NestedUpdate], ParseState) + want_updates :: !OptionalRecordName Token ParseState -> ([NestedUpdate], ParseState) want_updates type token pState # (updates, pState) = parse_updates token pState @@ -3362,7 +3441,7 @@ where = ({nu_selectors = selectors, nu_update_expr = expr}, pState) = ({nu_selectors = selectors, nu_update_expr = PE_Empty}, parseError "field assignment" (Yes token) "=" pState) - transform_record_or_array_update :: !(Optional Ident) ParsedExpr [NestedUpdate] !Int ParseState -> (ParsedExpr, ParseState) + transform_record_or_array_update :: !OptionalRecordName ParsedExpr [NestedUpdate] !Int ParseState -> (ParsedExpr, ParseState) transform_record_or_array_update type expr updates level pState | is_record_update sortedUpdates = transform_record_update type expr groupedUpdates level pState @@ -3380,8 +3459,16 @@ where smaller_selector :: ParsedSelection ParsedSelection -> Bool smaller_selector (PS_Record ident1 _) (PS_Record ident2 _) = ident1.id_name < ident2.id_name + smaller_selector (PS_Record ident1 _) (PS_QualifiedRecord _ field_name2 _) + = ident1.id_name < field_name2 smaller_selector (PS_Record _ _) _ = True + smaller_selector (PS_QualifiedRecord _ field_name1 _) (PS_QualifiedRecord _ field_name2 _) + = field_name1 < field_name2 + smaller_selector (PS_QualifiedRecord _ field_name1 _) (PS_Record ident2 _) + = field_name1 < ident2.id_name + smaller_selector (PS_QualifiedRecord _ _ _) _ + = True smaller_selector _ _ = False @@ -3396,6 +3483,8 @@ where equal_selectors :: [ParsedSelection] [ParsedSelection] -> Bool equal_selectors [PS_Record ident1 _ ,_ : _] [PS_Record ident2 _ ,_: _] = ident1.id_name == ident2.id_name + equal_selectors [PS_QualifiedRecord _ field_name1 _ ,_ : _] [PS_QualifiedRecord _ field_name2 _ ,_: _] + = field_name1 == field_name2 equal_selectors _ _ = False @@ -3406,10 +3495,12 @@ where is_record_select (PS_Record _ _) = True + is_record_select (PS_QualifiedRecord _ _ _) + = True is_record_select _ = False - transform_record_update :: (Optional Ident) ParsedExpr ![[NestedUpdate]] !Int ParseState -> (ParsedExpr, ParseState) + transform_record_update :: OptionalRecordName ParsedExpr ![[NestedUpdate]] !Int ParseState -> (ParsedExpr, ParseState) transform_record_update record_type expr groupedUpdates level pState = (updateExpr, pState2) where @@ -3422,47 +3513,54 @@ where // for example: f.g1 = e1, f.g2 = e2 -> f = {id.f & g1 = e1, g2 = e2}, // (id is ident to shared expression that's being updated) - transform_update :: !Int [NestedUpdate] (Optional Ident,Optional Ident,ParseState) -> (FieldAssignment, !(!Optional Ident,!Optional Ident,ParseState)) + transform_update :: !Int [NestedUpdate] (Optional Ident,OptionalRecordName,ParseState) -> (FieldAssignment, !(!Optional Ident,OptionalRecordName,ParseState)) transform_update _ [{nu_selectors=[PS_Record fieldIdent field_record_type], nu_update_expr}] (shareIdent,record_type,pState) # (record_type,pState) = check_field_and_record_types field_record_type record_type pState; - = ({bind_dst = fieldIdent, bind_src = nu_update_expr},(shareIdent,record_type,pState)) + = ({bind_dst = FieldName fieldIdent, bind_src = nu_update_expr},(shareIdent,record_type,pState)) + transform_update _ [{nu_selectors=[PS_QualifiedRecord module_id field_name field_record_type], nu_update_expr}] (shareIdent,record_type,pState) + # (record_type,pState) = check_field_and_record_types field_record_type record_type pState; + = ({bind_dst = QualifiedFieldName module_id field_name, bind_src = nu_update_expr},(shareIdent,record_type,pState)) transform_update level updates=:[{nu_selectors=[PS_Record fieldIdent field_record_type : _]} : _] (optionalIdent,record_type,pState) # (record_type,pState) = check_field_and_record_types field_record_type record_type pState; - # (shareIdent, pState) - = make_ident optionalIdent level pState - select - = PE_Selection ParsedNormalSelector (PE_Ident shareIdent) [PS_Record fieldIdent final_record_type] + (shareIdent, pState) = make_ident optionalIdent level pState + select = PE_Selection ParsedNormalSelector (PE_Ident shareIdent) [PS_Record fieldIdent final_record_type] (update_expr, pState) - = transform_record_or_array_update No select (map sub_update updates) (level+1) pState - = ({bind_dst = fieldIdent, bind_src = update_expr}, (Yes shareIdent,record_type,pState)) - where - make_ident :: (Optional Ident) !Int ParseState -> (Ident, ParseState) - make_ident (Yes ident) _ pState - = (ident, pState) - make_ident No level pState - = internalIdent ("s" +++ toString level +++ ";") pState - - sub_update :: NestedUpdate -> NestedUpdate - sub_update update=:{nu_selectors} - = {update & nu_selectors = tl nu_selectors} + = transform_record_or_array_update NoRecordName select (map sub_update updates) (level+1) pState + = ({bind_dst = FieldName fieldIdent, bind_src = update_expr}, (Yes shareIdent,record_type,pState)) + transform_update level updates=:[{nu_selectors=[PS_QualifiedRecord module_id field_name field_record_type : _]} : _] (optionalIdent,record_type,pState) + # (record_type,pState) = check_field_and_record_types field_record_type record_type pState; + (shareIdent, pState) = make_ident optionalIdent level pState + select = PE_Selection ParsedNormalSelector (PE_Ident shareIdent) [PS_QualifiedRecord module_id field_name final_record_type] + (update_expr, pState) + = transform_record_or_array_update NoRecordName select (map sub_update updates) (level+1) pState + = ({bind_dst = QualifiedFieldName module_id field_name, bind_src = update_expr}, (Yes shareIdent,record_type,pState)) transform_update _ _ (_, record_type,pState) - # pState - = parseError "record or array" No "field assignments mixed with array assignments not" pState - = ({bind_dst = errorIdent, bind_src = PE_Empty}, (No,record_type,pState)) + # pState = parseError "record or array" No "field assignments mixed with array assignments not" pState + = ({bind_dst = FieldName errorIdent, bind_src = PE_Empty}, (No,record_type,pState)) + + make_ident :: (Optional Ident) !Int ParseState -> (Ident, ParseState) + make_ident (Yes ident) _ pState + = (ident, pState) + make_ident No level pState + = internalIdent ("s" +++ toString level +++ ";") pState - build_update :: !(Optional Ident) !(Optional Ident) !ParsedExpr ![FieldAssignment] -> ParsedExpr + sub_update :: NestedUpdate -> NestedUpdate + sub_update update=:{nu_selectors} + = {update & nu_selectors = tl nu_selectors} + + build_update :: !OptionalRecordName !(Optional Ident) !ParsedExpr ![FieldAssignment] -> ParsedExpr build_update record_type No expr assignments = PE_Record expr record_type assignments build_update record_type (Yes ident) expr assignments = PE_Let False (LocalParsedDefs [buildNodeDef (PE_Ident ident) expr]) (PE_Record (PE_Ident ident) record_type assignments) - check_field_and_record_types :: (Optional Ident) (Optional Ident) ParseState -> (!Optional Ident,!ParseState); - check_field_and_record_types No record_type pState + check_field_and_record_types :: OptionalRecordName OptionalRecordName ParseState -> (!OptionalRecordName,!ParseState); + check_field_and_record_types NoRecordName record_type pState = (record_type,pState); - check_field_and_record_types field_record_type=:(Yes _) No pState + check_field_and_record_types field_record_type=:(RecordNameIdent _) NoRecordName pState = (field_record_type,pState); - check_field_and_record_types (Yes field_record_type_name) record_type=:(Yes record_type_name) pState + check_field_and_record_types (RecordNameIdent field_record_type_name) record_type=:(RecordNameIdent record_type_name) pState | field_record_type_name==record_type_name = (record_type,pState); # error_message = "record type in update: "+++field_record_type_name.id_name+++" where "+++record_type_name.id_name+++" was" @@ -3505,45 +3603,62 @@ where (PE_Tuple [PE_Ident element_id, PE_Ident array_id]) (PE_Selection (ParsedUniqueSelector True) expr (reverse [PS_Array (PE_Ident index_id) : initial_selectors])) (updated_element, pState) - = transform_record_update No + = transform_record_update NoRecordName (PE_Ident element_id) [[{nu_selectors=(reverse record_selectors), nu_update_expr=update_expr}]] (level+1) pState = (PE_Let False (LocalParsedDefs [index_def, select_def]) (PE_Update (PE_Ident array_id) (reverse [PS_Array (PE_Ident index_id) : initial_selectors]) updated_element), pState) - want_field_assignments is_pattern token=:(IdentToken ident) pState - | isLowerCaseName ident - # (field, pState) = want_field_expression is_pattern ident pState - (token, pState) = nextToken FunctionContext pState - | token == CommaToken - # (token, pState) = nextToken FunctionContext pState - (fields, pState) = want_field_assignments is_pattern token pState - = ([ field : fields ], pState) - = ([ field ], tokenBack pState) - where - want_field_expression is_pattern field_name pState + want_field_assignments is_pattern token=:(IdentToken field_name) pState + | isLowerCaseName field_name # (field_id, pState) = stringToIdent field_name IC_Selector pState - (token, pState) = nextToken FunctionContext pState - | token == EqualToken - # (field_expr, pState) = wantExpression is_pattern pState - = ({ bind_src = field_expr, bind_dst = field_id}, pState) - = ({ bind_src = PE_Empty, bind_dst = field_id}, tokenBack pState) + = want_more_field_assignments (FieldName field_id) is_pattern pState + want_field_assignments is_pattern token=:(QualifiedIdentToken module_name field_name) pState + | isLowerCaseName field_name + # (module_id, pState) = stringToIdent module_name IC_Module pState + = want_more_field_assignments (QualifiedFieldName module_id field_name) is_pattern pState want_field_assignments is_pattern token pState = ([], parseError "record or array field assignments" (Yes token) "field name" pState) + want_more_field_assignments field_name_or_qualified_field_name is_pattern pState + # (field_expr, pState) = want_field_expression is_pattern pState + field = { bind_src = field_expr, bind_dst = field_name_or_qualified_field_name} + # (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (token, pState) = nextToken FunctionContext pState + (fields, pState) = want_field_assignments is_pattern token pState + = ([ field : fields ], pState) + = ([ field ], tokenBack pState) + try_field_assignment (IdentToken field_name) pState | isLowerCaseName field_name # (token, pState) = nextToken FunctionContext pState | token == EqualToken # (field_expr, pState) = wantExpression cIsNotAPattern pState (field_id, pState) = stringToIdent field_name IC_Selector pState - = (True, { bind_src = field_expr, bind_dst = field_id}, pState) + = (True, { bind_src = field_expr, bind_dst = FieldName field_id}, pState) + = (False, abort "no field", tokenBack pState) + = (False, abort "no field", pState) + try_field_assignment (QualifiedIdentToken module_name field_name) pState + | isLowerCaseName field_name + # (token, pState) = nextToken FunctionContext pState + | token == EqualToken + # (field_expr, pState) = wantExpression cIsNotAPattern pState + (module_id, pState) = stringToIdent module_name IC_Module pState + = (True, { bind_src = field_expr, bind_dst = QualifiedFieldName module_id field_name}, pState) = (False, abort "no field", tokenBack pState) = (False, abort "no field", pState) try_field_assignment _ pState = (False, abort "no field", pState) - + + want_field_expression is_pattern pState + # (token, pState) = nextToken FunctionContext pState + | token == EqualToken + = wantExpression is_pattern pState + = (PE_Empty, tokenBack pState) + + want_record :: !OptionalRecordName !ParseState -> (!ParsedExpr,!ParseState) want_record type pState # (token1, pState) = nextToken FunctionContext pState (token2, pState) = nextToken FunctionContext pState @@ -3552,14 +3667,14 @@ where = (PE_Record PE_Empty type fields, wantToken FunctionContext "record" CurlyCloseToken pState) = want_record_update type token1 (tokenBack pState) where - want_record_update :: !(Optional Ident) !Token !ParseState -> (!ParsedExpr, !ParseState) + want_record_update :: !OptionalRecordName !Token !ParseState -> (!ParsedExpr, !ParseState) want_record_update type token pState # (expr, pState) = wantRhsExpressionT token pState pState = wantToken FunctionContext "record update" AndToken pState (token, pState) = nextToken FunctionContext pState = want_update type expr token pState - want_update :: !(Optional Ident) !ParsedExpr !Token !ParseState -> (!ParsedExpr, !ParseState) + want_update :: !OptionalRecordName !ParsedExpr !Token !ParseState -> (!ParsedExpr, !ParseState) want_update type expr token pState # (position, pState) = getPosition pState (updates, pState) = want_updates type token pState @@ -3590,7 +3705,7 @@ where = PE_UpdateComprehension expr update_expr ident_expr qualifiers want_record_or_array_update token expr pState - = want_update No expr token pState + = want_update NoRecordName expr token pState want_array_assignments is_pattern pState # (assign, pState) = want_array_assignment is_pattern pState diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 55c9ee8..6a04239 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -349,6 +349,11 @@ where collectFunctions e icl_module ca = (e, ca) +instance collectFunctions FieldNameOrQualifiedFieldName +where + collectFunctions e icl_module ca + = (e, ca) + instance collectFunctions (ParsedInstance a) | collectFunctions a where collectFunctions inst=:{pi_members} icl_module ca # (pi_members, ca) = collectFunctions pi_members icl_module ca @@ -997,7 +1002,7 @@ transformArrayDenot exprs scanModules :: [ParsedImport] [ScannedModule] [Ident] SearchPaths Bool Bool (ModTimeFunction *Files) *Files *CollectAdmin -> (Bool, [ScannedModule],*Files, *CollectAdmin) scanModules [] parsed_modules cached_modules searchPaths support_generics support_dynamics modtimefunction files ca = (True, parsed_modules,files, ca) -scanModules [{import_module,import_symbols,import_file_position} : mods] parsed_modules cached_modules searchPaths support_generics support_dynamics modtimefunction files ca +scanModules [{import_module,import_file_position} : mods] parsed_modules cached_modules searchPaths support_generics support_dynamics modtimefunction files ca | in_cache import_module cached_modules = scanModules mods parsed_modules cached_modules searchPaths support_generics support_dynamics modtimefunction files ca # (found_module,mod_type) = try_to_find import_module parsed_modules @@ -1454,6 +1459,7 @@ reorganiseDefinitionsAndAddTypes mod_ident support_dynamics icl_module defs ca { import_module = clean_types_module_ident , import_symbols = [] , import_file_position = NoPos + , import_qualified = False } # imports = if (mod_ident == clean_types_module_ident) [] [clean_types_module] = reorganiseDefinitions icl_module [PD_Import imports : defs] 0 0 0 0 ca diff --git a/frontend/scanner.dcl b/frontend/scanner.dcl index 1fafeb9..1a5b8da 100644 --- a/frontend/scanner.dcl +++ b/frontend/scanner.dcl @@ -23,6 +23,7 @@ instance <<< FilePosition :: Token = IdentToken !.String // an identifier | UnderscoreIdentToken !.String// an identifier that starts with a '_' + | QualifiedIdentToken !String !.String // a qualified identifier | IntToken !.String // an integer | RealToken !.String // a real | StringToken !.String // a string diff --git a/frontend/scanner.icl b/frontend/scanner.icl index af74a80..8cada50 100644 --- a/frontend/scanner.icl +++ b/frontend/scanner.icl @@ -110,6 +110,7 @@ ScanOptionNoNewOffsideForSeqLetBit:==4; :: Token = IdentToken ! .String // an identifier | UnderscoreIdentToken !.String// an identifier that starts with a '_' + | QualifiedIdentToken !String !.String // a qualified identifier | IntToken !.String // an integer | RealToken !.String // a real | StringToken !.String // a string @@ -773,32 +774,75 @@ new_exp_char c = isSpace c ScanIdentFast :: !Int !Input !ScanContext -> (!Token, !Input) ScanIdentFast n input=:{inp_stream=OldLine i line stream,inp_pos} co - # end_i = ScanIdentCharsInString i line co + # (end_i,qualified) = ScanIdentCharsInString i line co with - ScanIdentCharsInString :: !Int !{#Char} !ScanContext -> Int + ScanIdentCharsInString :: !Int !{#Char} !ScanContext -> (!Int,!Bool) ScanIdentCharsInString i line co - | i<size line && IsIdentChar line.[i] co - = ScanIdentCharsInString (i+1) line co - = i - # pos = {inp_pos & fp_col = inp_pos.fp_col + (end_i-i)} - # input = {input & inp_stream=OldLine end_i line stream,inp_pos=pos} - = CheckReserved co (line % (i-n,end_i-1)) input + | i<size line + | IsIdentChar line.[i] co + = ScanIdentCharsInString (i+1) line co + = (i,line.[i]=='@') + = (i,False) + | not qualified + # pos = {inp_pos & fp_col = inp_pos.fp_col + (end_i-i)} + # input = {input & inp_stream=OldLine end_i line stream,inp_pos=pos} + = CheckReservedIdent co (line % (i-n,end_i-1)) input + # i2=end_i+1 + | i2==size line + # pos = {inp_pos & fp_col = inp_pos.fp_col + (end_i-i)} + # input = {input & inp_stream=OldLine end_i line stream,inp_pos=pos} + = CheckReservedIdent co (line % (i-n,end_i-1)) input + # c=line.[i2] + | IsIdentChar c co + # module_name = line % (i-n,end_i-1) + # end_i = ScanIdentCharsInString (i2+1) line co + with + ScanIdentCharsInString :: !Int !{#Char} !ScanContext -> Int + ScanIdentCharsInString i line co + | i<size line && IsIdentChar line.[i] co + = ScanIdentCharsInString (i+1) line co + = i + # ident_name = line % (i2,end_i-1) + # pos = {inp_pos & fp_col = inp_pos.fp_col + (end_i-i)} + # input = {input & inp_stream=OldLine end_i line stream,inp_pos=pos} + = (QualifiedIdentToken module_name ident_name,input) + | isSpecialChar c + # module_name = line % (i-n,end_i-1) + # end_i = ScanSpecialCharsInString (i2+1) line + with + ScanSpecialCharsInString :: !Int !{#Char} -> Int + ScanSpecialCharsInString i line + | i<size line && isSpecialChar line.[i] + = ScanSpecialCharsInString (i+1) line + = i + # ident_name = line % (i2,end_i-1) + # pos = {inp_pos & fp_col = inp_pos.fp_col + (end_i-i)} + # input = {input & inp_stream=OldLine end_i line stream,inp_pos=pos} + = (QualifiedIdentToken module_name ident_name,input) + # pos = {inp_pos & fp_col = inp_pos.fp_col + (end_i-i)} + # input = {input & inp_stream=OldLine end_i line stream,inp_pos=pos} + = CheckReservedIdent co (line % (i-n,end_i-1)) input ScanOperator :: !Int !Input ![Char] !ScanContext -> (!Token, !Input) ScanOperator n input token co # (eof, c, input) = ReadNormalChar input - | eof = CheckReserved co (revCharListToString n token) input + | eof = CheckReservedOperator (revCharListToString n token) input | isSpecialChar c = ScanOperator (n + 1) input [c:token] co - = CheckReserved co (revCharListToString n token) (charBack input) + = CheckReservedOperator (revCharListToString n token) (charBack input) + +CheckReservedIdent :: !ScanContext !String !Input -> (!Token, !Input) +CheckReservedIdent GeneralContext s i = CheckGeneralContext s i +CheckReservedIdent TypeContext s i = CheckTypeContext s i +CheckReservedIdent FunctionContext s i = CheckFunctContext s i +CheckReservedIdent CodeContext s i = CheckCodeContext s i +CheckReservedIdent GenericContext s i = CheckGenericContext s i -CheckReserved :: !ScanContext !String !Input -> (!Token, !Input) -CheckReserved GeneralContext s i = CheckGeneralContext s i -CheckReserved TypeContext s i = CheckTypeContext s i -CheckReserved FunctionContext s i = CheckFunctContext s i -CheckReserved CodeContext s i = CheckCodeContext s i -CheckReserved GenericContext s i = CheckGenericContext s i +CheckReservedOperator :: !String !Input -> (!Token, !Input) +CheckReservedOperator "!" input = (ExclamationToken, input) +CheckReservedOperator "*/" input = (ErrorToken "Unexpected end of comment, */", input) +CheckReservedOperator s input = (IdentToken s, input) -CheckGeneralContext :: !String !Input -> (!Token, !Input) +CheckGeneralContext :: !String !Input -> (!Token, !Input) CheckGeneralContext s input = case s of "module" -> (ModuleToken , input) @@ -819,8 +863,6 @@ CheckEveryContext s input "generic" -> (GenericToken , input) "derive" -> (DeriveToken , input) "otherwise" -> (OtherwiseToken , input) - "!" -> (ExclamationToken , input) - "*/" -> (ErrorToken "Unexpected end of comment, */", input) "infixr" # (error, n, input) = GetPrio input -> case error of Yes err -> (ErrorToken err , input) //-->> ("Error token generated: "+err) @@ -1424,6 +1466,8 @@ where toString EndOfFileToken = "end of file" toString (ErrorToken id) = "Scanner error: " + id + toString (QualifiedIdentToken module_name ident_name) = module_name+++"@"+++ident_name + toString GenericToken = "generic" toString DeriveToken = "derive" toString GenericOpenToken = "{|" @@ -1451,6 +1495,8 @@ where equal_args_of_tokens (LetToken l1) (LetToken l2) = l1 == l2 equal_args_of_tokens (SeqLetToken l1) (SeqLetToken l2) = l1 == l2 equal_args_of_tokens (ErrorToken id1) (ErrorToken id2) = id1 == id2 + equal_args_of_tokens (QualifiedIdentToken module_name1 ident_name1) (QualifiedIdentToken module_name2 ident_name2) + = ident_name1==ident_name2 && module_name1==module_name2 equal_args_of_tokens _ _ = True /* Sjaak ... */ diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 96226f1..0761941 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -48,10 +48,11 @@ instance == FunctionOrMacroIndex | STE_TypeVariable !TypeVarInfoPtr | STE_TypeAttribute !AttrVarInfoPtr | STE_BoundTypeVariable !STE_BoundTypeVariable - | STE_Imported !STE_Kind !Index + | STE_Imported !STE_Kind !ModuleN | STE_DclFunction | STE_Module !(Module (CollectedDefinitions ClassInstance IndexRange)) | STE_ClosedModule + | STE_ModuleQualifiedImports !SortedQualifiedImports | STE_Empty /* for creating class dictionaries */ | STE_DictType !CheckedTypeDef @@ -64,14 +65,19 @@ instance == FunctionOrMacroIndex the "actual" dcl module. */ | STE_BelongingSymbol !Int - | STE_ExplImpSymbolNotImported !ModuleN - - | STE_UsedType !Index !STE_Kind - /* used during binding of types to mark types that have been applied. The first */ + | STE_ExplImpSymbolNotImported !ModuleN !STE_Kind + | STE_ImportedQualified !Declaration !STE_Kind + + | STE_UsedType !ModuleN !STE_Kind + /* used during binding of types to mark types that have been applied. */ + | STE_UsedQualifiedType !ModuleN !Index !STE_Kind | STE_BelongingSymbolExported | STE_BelongingSymbolForExportedSymbol -:: ModuleN:==Int +:: ModuleN:==Int; + +:: SortedQualifiedImports = SortedQualifiedImports !Declaration !SortedQualifiedImports !SortedQualifiedImports + | EmptySortedQualifiedImports :: Declaration = Declaration !DeclarationRecord @@ -383,6 +389,7 @@ cNameLocationDependent :== True { import_module :: !Ident , import_symbols :: ![from_symbol] , import_file_position:: !Position // for error messages + , import_qualified :: !Bool } instance toString (Import from_symbol), AttributeVar, TypeAttribute, Annotation @@ -600,7 +607,7 @@ pIsSafe :== True | AP_Dynamic !AuxiliaryPattern !DynamicType !OptionalVariable | AP_Constant !AP_Kind !(Global DefinedSymbol) !Priority | AP_WildCard !OptionalVariable - | AP_Empty !Ident + | AP_Empty !{#Char} :: AP_Kind = APK_Constructor !Index | APK_Macro !Bool // is_dcl_macro @@ -874,6 +881,7 @@ cNonRecursiveAppl :== False //AA: class in a type context is either normal class or a generic class :: TCClass = TCClass !(Global DefinedSymbol) // Normal class | TCGeneric !GenericTypeContext // Generic class + | TCQualifiedIdent !Ident !String :: GenericTypeContext = { gtc_generic :: !(Global DefinedSymbol) @@ -912,6 +920,8 @@ cNonRecursiveAppl :== False | TLifted !TypeVar /* Auxiliary, used during type checking of lifted arguments */ + | TQualifiedIdent !Ident !String ![AType] + | TE :: ConsVariable = CV !TypeVar @@ -1102,8 +1112,8 @@ instance toString KindInfo | PE_Basic !BasicValue | PE_Bound !BoundExpr | PE_Lambda !Ident ![ParsedExpr] !ParsedExpr !Position - | PE_Tuple ![ParsedExpr] - | PE_Record !ParsedExpr !(Optional Ident) ![FieldAssignment] + | PE_Tuple ![ParsedExpr] + | PE_Record !ParsedExpr !OptionalRecordName ![FieldAssignment] | PE_ArrayPattern ![ElemAssignment] | PE_UpdateComprehension !ParsedExpr !ParsedExpr !ParsedExpr ![Qualifier] | PE_ArrayDenot ![ParsedExpr] @@ -1118,6 +1128,8 @@ instance toString KindInfo | PE_WildCard | PE_Field !ParsedExpr !(Global FieldSymbol) /* Auxiliary, used during checking */ + | PE_QualifiedIdent !Ident !String + | PE_ABC_Code ![String] !Bool | PE_Any_Code !(CodeBinding Ident) !(CodeBinding Ident) ![String] @@ -1128,10 +1140,18 @@ instance toString KindInfo | PE_Empty -:: ParsedSelection = PS_Record !Ident !(Optional Ident) +:: ParsedSelection = PS_Record !Ident !OptionalRecordName + | PS_QualifiedRecord !ModuleIdent !String !OptionalRecordName | PS_Array !ParsedExpr | PS_Erroneous +:: OptionalRecordName + = NoRecordName + | RecordNameIdent !Ident + | RecordNameQualifiedIdent !ModuleIdent !String + +:: ModuleIdent:==Ident + :: GeneratorKind = IsListGenerator | IsOverloadedListGenerator | IsArrayGenerator :: LineAndColumn = {lc_line :: !Int, lc_column :: !Int} @@ -1158,8 +1178,10 @@ instance toString KindInfo :: BoundExpr :== Bind ParsedExpr Ident -:: FieldAssignment :== Bind ParsedExpr Ident +:: FieldAssignment :== Bind ParsedExpr FieldNameOrQualifiedFieldName +:: FieldNameOrQualifiedFieldName = FieldName !Ident | QualifiedFieldName !Ident !String + :: ElemAssignment :== Bind ParsedExpr [ParsedExpr] @@ -1359,7 +1381,8 @@ cNotALineNumber :== -1 instance == ModuleKind, Ident instance <<< (Module a) | <<< a, ParsedDefinition, InstanceType, AttributeVar, TypeVar, SymbolType, Expression, Type, Ident, (Global object) | <<< object, - Position, CaseAlt, AType, FunDef, ParsedExpr, TypeAttribute, (Bind a b) | <<< a & <<< b, ParsedConstructor, (TypeDef a) | <<< a, TypeVarInfo, AttrVarInfo, + Position, CaseAlt, AType, FunDef, ParsedExpr, TypeAttribute, (Bind a b) | <<< a & <<< b, + FieldNameOrQualifiedFieldName, ParsedConstructor, (TypeDef a) | <<< a, TypeVarInfo, AttrVarInfo, BasicValue, ATypeVar, TypeRhs, (Import from_symbol) | <<< from_symbol, ImportDeclaration, ImportedIdent, CasePatterns, (Optional a) | <<< a, ConsVariable, BasicType, Annotation, SelectorKind, Selection, SelectorDef, ConsDef, LocalDefs, FreeVar, ClassInstance, SignClassification, TypeCodeExpression, CoercionPosition, AttrInequality, LetBind, Declaration, STE_Kind, BoundVar, diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 5f503b4..f5894bb 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -517,6 +517,11 @@ where (<<<) file (PS_Array index_expr) = file <<< '[' <<< index_expr <<< ']' (<<<) file PS_Erroneous = file <<< "Erroneous selector" // PK +instance <<< FieldNameOrQualifiedFieldName +where + (<<<) file (FieldName ident) = file <<< ident + (<<<) file (QualifiedFieldName module_ident field_name) = file <<< module_ident <<< '@' <<< field_name + instance <<< CaseAlt where (<<<) file {calt_pattern,calt_rhs} = file <<< calt_pattern <<< " -> " <<< calt_rhs diff --git a/frontend/type.dcl b/frontend/type.dcl index 57428ea..f7d998b 100644 --- a/frontend/type.dcl +++ b/frontend/type.dcl @@ -3,9 +3,9 @@ definition module type import StdArray import syntax, check -typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !NumberSet !*TypeDefInfos !*Heaps !*PredefinedSymbols !*File !*File !{# DclModule} - -> (!Bool, !*{# FunDef}, !ArrayAndListInstances, !{# CommonDefs}, !{# {# FunType} }, !*TypeDefInfos, !*Heaps, !*PredefinedSymbols, !*File, !*File) - +typeProgram :: !{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs !{!Declaration} ![([Declaration], Int, Position)] !{# DclModule} !NumberSet + !*TypeDefInfos !*Heaps !*PredefinedSymbols !*File !*File + -> (!Bool, !*{# FunDef}, !ArrayAndListInstances, !{# CommonDefs}, !{# {# FunType} }, !*TypeDefInfos,!*Heaps,!*PredefinedSymbols,!*File,!*File) addPropagationAttributesToAType :: {#CommonDefs} !AType !*PropState -> *(!AType,Int,!*PropState); diff --git a/frontend/type.icl b/frontend/type.icl index ab5dadc..a6ce95c 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -2222,20 +2222,22 @@ ste_kind_to_string s -> "STE_???" */ -typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !NumberSet !*TypeDefInfos !*Heaps !*PredefinedSymbols !*File !*File !{# DclModule} - -> (!Bool, !*{# FunDef}, !ArrayAndListInstances, !{# CommonDefs}, !{# {# FunType} }, !*TypeDefInfos, !*Heaps, !*PredefinedSymbols, !*File, !*File) -typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_defs imports modules used_module_numbers td_infos heaps=:{hp_var_heap, hp_expression_heap, hp_type_heaps,hp_generic_heap} predef_symbols file out dcl_modules +typeProgram :: !{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs !{!Declaration} ![([Declaration], Int, Position)] !{# DclModule} !NumberSet + !*TypeDefInfos !*Heaps !*PredefinedSymbols !*File !*File + -> (!Bool, !*{# FunDef}, !ArrayAndListInstances, !{# CommonDefs}, !{# {# FunType} }, !*TypeDefInfos,!*Heaps,!*PredefinedSymbols,!*File,!*File) +typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_defs imports icl_qualified_imports dcl_modules used_module_numbers + td_infos heaps=:{hp_var_heap, hp_expression_heap, hp_type_heaps,hp_generic_heap} predef_symbols file out #! fun_env_size = size fun_defs # ts_error = {ea_file = file, ea_loc = [], ea_ok = True } - ti_common_defs = {{dcl_common \\ {dcl_common} <-: modules } & [main_dcl_module_n] = icl_defs } - ti_functions = {dcl_functions \\ {dcl_functions} <-: modules } + ti_common_defs = {{dcl_common \\ {dcl_common} <-: dcl_modules } & [main_dcl_module_n] = icl_defs } + ti_functions = {dcl_functions \\ {dcl_functions} <-: dcl_modules } + + class_instances = { { IT_Empty \\ i <- [0 .. dec (size com_class_defs)] } \\ {com_class_defs} <-: ti_common_defs } + state = collect_imported_instances imports ti_common_defs {} ts_error class_instances hp_type_heaps.th_vars td_infos + state = collect_qualified_imported_instances icl_qualified_imports ti_common_defs state -// type_def_sizes = [ size com_type_defs \\ {com_type_defs} <-: ti_common_defs ] - class_def_sizes = [ size com_class_defs \\ {com_class_defs} <-: ti_common_defs ] - class_instances = { { IT_Empty \\ i <- [0 .. dec size] } \\ size <- class_def_sizes } - state = collect_imported_instances imports ti_common_defs {} ts_error class_instances hp_type_heaps.th_vars td_infos (_, ts_error, class_instances, th_vars, td_infos) = collect_and_check_instances (size icl_defs.com_instance_defs) ti_common_defs state ts = { ts_fun_env = InitFunEnv fun_env_size, ts_var_heap = hp_var_heap, ts_expr_heap = hp_expression_heap, ts_generic_heap = hp_generic_heap, ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [], @@ -2262,7 +2264,11 @@ typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_de // ---> ("typeProgram", array_inst_types) where collect_imported_instances imports common_defs dummy error class_instances type_var_heap td_infos - = foldSt (collect_imported_instance common_defs) imports (dummy, error, class_instances, type_var_heap, td_infos) + = foldlArraySt (collect_imported_instance common_defs) imports (dummy, error, class_instances, type_var_heap, td_infos) + + collect_qualified_imported_instances icl_qualified_imports common_defs state + = foldSt (\ (declarations,_,_) state -> foldSt (collect_imported_instance common_defs) declarations state) + icl_qualified_imports state collect_imported_instance common_defs (Declaration {decl_kind = STE_Imported STE_Instance mod_index, decl_index }) state = update_instances_of_class common_defs mod_index decl_index state @@ -2282,6 +2288,22 @@ where (error, type_var_heap, td_infos) = check_types_of_instances ins_pos common_defs glob_module ds_index it_types (error, type_var_heap, td_infos) = (dummy, error, class_instances, type_var_heap, td_infos) + where + insert :: ![Type] !Index !Index !{# CommonDefs } !*ErrorAdmin !*InstanceTree -> (!*ErrorAdmin, !*InstanceTree) + insert ins_types new_ins_index new_ins_module modules error IT_Empty + = (error, IT_Node {glob_object = new_ins_index,glob_module = new_ins_module} IT_Empty IT_Empty) + insert ins_types new_ins_index new_ins_module modules error (IT_Node ins=:{glob_object,glob_module} it_less it_greater) + #! {ins_type={it_types}} = modules.[glob_module].com_instance_defs.[glob_object] + # cmp = ins_types =< it_types + | cmp == Smaller + # (error, it_less) = insert ins_types new_ins_index new_ins_module modules error it_less + = (error, IT_Node ins it_less it_greater) + | cmp == Greater + # (error, it_greater) = insert ins_types new_ins_index new_ins_module modules error it_greater + = (error, IT_Node ins it_less it_greater) + | ins.glob_object==new_ins_index && ins.glob_module==new_ins_module + = (error, IT_Node ins it_less it_greater) + = (checkError ins_types " instance is overlapping" error, IT_Node ins it_less it_greater) check_types_of_instances ins_pos common_defs class_module class_index types state # {class_arity,class_cons_vars} = common_defs.[class_module].com_class_defs.[class_index] @@ -2335,20 +2357,6 @@ where | neg_signs bitand 1 == 0 = check_sign type (neg_signs >> 1) (dec arg_nr) error = checkError type " all arguments of an instance type should have a non-negative sign" error - - insert :: ![Type] !Index !Index !{# CommonDefs } !*ErrorAdmin !*InstanceTree -> (!*ErrorAdmin, !*InstanceTree) - insert ins_types new_ins_index new_ins_module modules error IT_Empty - = (error, IT_Node {glob_object = new_ins_index,glob_module = new_ins_module} IT_Empty IT_Empty) - insert ins_types new_ins_index new_ins_module modules error (IT_Node ins=:{glob_object,glob_module} it_less it_greater) - #! {ins_type={it_types}} = modules.[glob_module].com_instance_defs.[glob_object] - # cmp = ins_types =< it_types - | cmp == Smaller - # (error, it_less) = insert ins_types new_ins_index new_ins_module modules error it_less - = (error, IT_Node ins it_less it_greater) - | cmp == Greater - # (error, it_greater) = insert ins_types new_ins_index new_ins_module modules error it_greater - = (error, IT_Node ins it_less it_greater) - = (checkError ins_types " instance is overlapping" error, IT_Node ins it_less it_greater) type_instances list_inferred_types ir_from ir_to class_instances ti funs_and_state | ir_from == ir_to @@ -2403,7 +2411,7 @@ where { os_type_heaps, os_var_heap, os_symbol_heap, os_generic_heap, os_predef_symbols, os_special_instances, os_error }) = tryToSolveOverloading over_info main_dcl_module_n ti_common_defs class_instances coercion_env { os_type_heaps = ts_type_heaps, os_var_heap = ts_var_heap, os_symbol_heap = ts_expr_heap, os_generic_heap = ts.ts_generic_heap, - os_predef_symbols = predef_symbols, os_error = ts_error, os_special_instances = special_instances } modules + os_predef_symbols = predef_symbols, os_error = ts_error, os_special_instances = special_instances } dcl_modules //ts = {ts & ts_generic_heap = os_generic_heap} | not os_error.ea_ok = (True, os_predef_symbols, os_special_instances, out, create_erroneous_function_types comp { ts & ts_type_heaps = os_type_heaps, |