diff options
| -rw-r--r-- | frontend/check.dcl | 2 | ||||
| -rw-r--r-- | frontend/check.icl | 40 | ||||
| -rw-r--r-- | frontend/checksupport.dcl | 2 | ||||
| -rw-r--r-- | frontend/checksupport.icl | 2 | ||||
| -rw-r--r-- | frontend/checktypes.dcl | 2 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 99 | ||||
| -rw-r--r-- | frontend/convertDynamics.dcl | 2 | ||||
| -rw-r--r-- | frontend/convertDynamics.icl | 20 | ||||
| -rw-r--r-- | frontend/frontend.icl | 4 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 2 | ||||
| -rw-r--r-- | frontend/syntax.icl | 2 | ||||
| -rw-r--r-- | frontend/type_io.dcl | 2 | ||||
| -rw-r--r-- | frontend/type_io.icl | 124 |
13 files changed, 243 insertions, 60 deletions
diff --git a/frontend/check.dcl b/frontend/check.dcl index 583ebe6..c28d7c7 100644 --- a/frontend/check.dcl +++ b/frontend/check.dcl @@ -5,7 +5,7 @@ import syntax, transform, checksupport, typesupport, predef cPredefinedModuleIndex :== 1 checkModule :: !ScannedModule !IndexRange ![FunDef] !Int !Int !(Optional ScannedModule) ![ScannedModule] !{#DclModule} !{#FunDef} !*PredefinedSymbols !*SymbolTable !*File !*Heaps - -> (!Bool, *IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !.{#FunDef},!Int, !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File) + -> (!Bool, *IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !.{#FunDef},!Int, !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File /* TD */, [String]) checkFunctions :: !Index !Level !Index !Index !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef}, !*ExpressionInfo, !*Heaps, !*CheckState) diff --git a/frontend/check.icl b/frontend/check.icl index a06ac90..db553dc 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -580,7 +580,7 @@ checkCommonDefinitions :: !Bool !Index !*CommonDefs !*{# DclModule} !*TypeHeaps checkCommonDefinitions is_dcl module_index common modules type_heaps var_heap cs #! is_main_dcl_mod = is_dcl && module_index == cs.cs_x.x_main_dcl_module_n # (com_type_defs, com_cons_defs, com_selector_defs, modules, var_heap, type_heaps, cs) - = checkTypeDefs is_main_dcl_mod common.com_type_defs module_index + = checkTypeDefs /* TD */ is_dcl is_main_dcl_mod common.com_type_defs module_index common.com_cons_defs common.com_selector_defs modules var_heap type_heaps cs (com_class_defs, com_member_defs, com_type_defs, modules, type_heaps, cs) = checkTypeClasses 0 module_index common.com_class_defs common.com_member_defs com_type_defs modules type_heaps cs @@ -893,6 +893,18 @@ where (<=<) infixl (<=<) state fun :== fun state +// TD ... +retrieve_directly_imported_dcl_modules dependencies_of_icl_mod dcl_modules + # (directly_imported_dcl_modules,dcl_modules) + = mapSt retrieve_directly_import_dcl_module dependencies_of_icl_mod dcl_modules + = (directly_imported_dcl_modules,dependencies_of_icl_mod,dcl_modules) +where + retrieve_directly_import_dcl_module index dcl_modules=:{[index] = dcl_module} + # directly_imported_dcl_module + = dcl_module.dcl_name.id_name + = (directly_imported_dcl_module,dcl_modules) +// ... TD + checkDclModules imports_of_icl_mod dcl_modules icl_functions heaps cs=:{cs_symbol_table} #! nr_of_dcl_modules = size dcl_modules @@ -904,13 +916,17 @@ checkDclModules imports_of_icl_mod dcl_modules icl_functions heaps cs=:{cs_symbo = nr_of_dcl_modules (dependencies_of_icl_mod, (_, cs_symbol_table)) = mapFilterYesSt get_opt_dependency imports_of_icl_mod (bitvect, cs_symbol_table) +// TD ... + (directly_imported_dcl_modules,dependencies_of_icl_mod,dcl_modules) + = retrieve_directly_imported_dcl_modules dependencies_of_icl_mod dcl_modules +// ... TD 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:", maxList (map length components)) +// | False--->("biggest component:", m axList (map length components)) // = undef # (nr_of_components, component_numbers) = getComponentNumbers components module_dag.dag_nr_of_nodes @@ -934,7 +950,7 @@ checkDclModules imports_of_icl_mod dcl_modules icl_functions heaps cs=:{cs_symbo \\ 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 } // --->("expl_imp_symbols_in_components", expl_imp_symbols_in_components) + = { cs & cs_symbol_table = cs_symbol_table /* TD ... */ ,cs_x = { cs.cs_x & directly_imported_dcl_modules = directly_imported_dcl_modules} /* ... TD */ } // --->("expl_imp_symbols_in_components", expl_imp_symbols_in_components) nr_of_icl_component = component_numbers.[index_of_icl_module] (_, expl_imp_infos, dcl_modules, icl_functions, heaps, cs) @@ -1228,8 +1244,8 @@ checkDclModuleWithinComponent dcl_imported_module_numbers component_nr is_on_cyc { cs & cs_symbol_table = cs_symbol_table } -checkModule :: !ScannedModule !IndexRange ![FunDef] !Int !Int !(Optional ScannedModule) ![ScannedModule] !{#DclModule} !{#FunDef} !*PredefinedSymbols !*SymbolTable !*File !*Heaps - -> (!Bool, *IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !.{#FunDef}, !Int,!*Heaps, !*PredefinedSymbols, !*SymbolTable, *File) +checkModule :: !ScannedModule !IndexRange ![FunDef] !Int !Int !(Optional ScannedModule) ![ScannedModule] !{#DclModule} !{#FunDef} !*PredefinedSymbols !*SymbolTable !*File !*Heaps + -> (!Bool, *IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !.{#FunDef},!Int, !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File /* TD */, [String]) checkModule m icl_global_function_range fun_defs n_functions_and_macros_in_dcl_modules dcl_module_n_in_cache optional_dcl_mod scanned_modules dcl_modules functions_and_macros predef_symbols symbol_table err_file heaps // | False--->("checkModule", m.mod_name) // = undef @@ -1241,6 +1257,8 @@ checkModule m icl_global_function_range fun_defs n_functions_and_macros_in_dcl_m # (mod_name,mod_imported_objects,mod_imports,mod_type,icl_global_function_range,nr_of_functions,first_inst_index,local_defs,icl_functions,init_dcl_modules,main_dcl_module_n,cdefs,sizes,cs) = check_module1 m icl_global_function_range fun_defs optional_dcl_mod optional_pre_def_mod scanned_modules dcl_modules functions_and_macros dcl_module_n_in_cache predef_symbols symbol_table err_file # icl_instance_range = {ir_from = first_inst_index, ir_to = nr_of_functions} + + // llslsls CheckState = check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_function_range icl_instance_range nr_of_functions n_functions_and_macros_in_dcl_modules optional_pre_def_mod local_defs icl_functions init_dcl_modules cdefs sizes heaps cs check_module1 {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs} icl_global_function_range fun_defs optional_dcl_mod optional_pre_def_mod scanned_modules dcl_modules functions_and_macros dcl_module_n_in_cache predef_symbols symbol_table err_file @@ -1261,7 +1279,7 @@ check_module1 {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cde (icl_functions, (sizes, local_defs)) = collectMacros cdefs.def_macros icl_functions sizes_and_local_defs main_dcl_module_n = if (dcl_module_n_in_cache<>NoIndex) dcl_module_n_in_cache (size dcl_modules) - cs = { cs_symbol_table = symbol_table, cs_predef_symbols = predef_symbols, cs_error = error, cs_x= {x_needed_modules=0,x_main_dcl_module_n=main_dcl_module_n}} + cs = { cs_symbol_table = symbol_table, cs_predef_symbols = predef_symbols, cs_error = error, cs_x= {x_needed_modules=0,x_main_dcl_module_n=main_dcl_module_n /* TD */, x_is_dcl_module = False, x_type_var_position = 0, directly_imported_dcl_modules = []}} (scanned_modules, icl_functions, cs) = add_dcl_module_predef_module_and_modules_to_symbol_table optional_dcl_mod optional_pre_def_mod scanned_modules (size dcl_modules) icl_functions cs @@ -1395,7 +1413,7 @@ check_module2 :: Ident [.ImportedObject] .[Import ImportDeclaration] .ModuleKind (Optional (Module a)) [Declaration] *{#FunDef} *{#DclModule} (CollectedDefinitions ClassInstance IndexRange) *{#.Int} *Heaps *CheckState -> (!Bool,.IclModule,!.{#DclModule},.{!Group},!Optional {#Int},!.{#FunDef},!Int,!.Heaps,!.{#PredefinedSymbol}, - !.Heap SymbolTableEntry,!.File); + !.Heap SymbolTableEntry,!.File,[String]); check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_function_range icl_instance_range nr_of_functions n_functions_and_macros_in_dcl_modules optional_pre_def_mod local_defs icl_functions init_dcl_modules cdefs sizes heaps cs # (main_dcl_module_n,cs)=cs!cs_x.x_main_dcl_module_n (icl_sizes_without_added_dcl_defs, sizes) = memcpy sizes @@ -1416,7 +1434,7 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func = checkDclModules mod_imports dcl_modules icl_functions heaps cs | not cs.cs_error.ea_ok - = (False, abort "evaluated error 1 (check.icl)", {}, {}, No, {}, cs.cs_x.x_main_dcl_module_n,heaps, cs.cs_predef_symbols, cs.cs_symbol_table, cs.cs_error.ea_file) + = (False, abort "evaluated error 1 (check.icl)", {}, {}, No, {}, cs.cs_x.x_main_dcl_module_n,heaps, cs.cs_predef_symbols, cs.cs_symbol_table, cs.cs_error.ea_file /* TD */, []) # (imported_module_numbers, dcl_modules) = foldSt compute_used_module_nrs expl_imp_indices @@ -1496,7 +1514,7 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func cs = check_start_rule mod_type mod_name icl_global_function_range cs cs = check_needed_modules_are_imported mod_name ".icl" cs - (icl_functions, e_info, heaps, {cs_symbol_table, cs_predef_symbols, cs_error,cs_x}) + (icl_functions, e_info, heaps, {cs_symbol_table, cs_predef_symbols, cs_error,cs_x }) = checkInstanceBodies icl_instance_range icl_functions e_info heaps cs cs_symbol_table = removeDeclarationsFromSymbolTable local_defs cGlobalScope cs_symbol_table @@ -1541,7 +1559,7 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func = compareDefImp icl_sizes_without_added_dcl_defs untransformed_fun_bodies main_dcl_module_n unexpanded_icl_type_defs main_dcl_module icl_mod heaps cs_error - = (cs_error.ea_ok, icl_mod, dcl_modules, groups, dcl_icl_conversions, cached_functions_and_macros, cs_x.x_main_dcl_module_n, heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file) + = (cs_error.ea_ok, icl_mod, dcl_modules, groups, dcl_icl_conversions, cached_functions_and_macros, cs_x.x_main_dcl_module_n, heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file /* TD */, cs_x.directly_imported_dcl_modules) # icl_common = { icl_common & com_type_defs = e_info.ef_type_defs, com_selector_defs = e_info.ef_selector_defs, com_class_defs = e_info.ef_class_defs, com_cons_defs = e_info.ef_cons_defs, com_member_defs = e_info.ef_member_defs } icl_mod = { icl_name = mod_name, icl_functions = icl_functions, icl_common = icl_common, @@ -1549,7 +1567,7 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func icl_specials = {ir_from = nr_of_functions, ir_to = nr_of_functions}, icl_imported_objects = mod_imported_objects, icl_used_module_numbers = imported_module_numbers, icl_import = icl_imported } - = (False, icl_mod, dcl_modules, {}, No, {}, cs_x.x_main_dcl_module_n,heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file) + = (False, icl_mod, dcl_modules, {}, No, {}, cs_x.x_main_dcl_module_n,heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file /* TD */, cs_x.directly_imported_dcl_modules) where check_start_rule mod_kind mod_name {ir_from, ir_to} cs=:{cs_predef_symbols,cs_symbol_table,cs_x} # (pre_symb, cs_predef_symbols) = cs_predef_symbols![PD_Start] diff --git a/frontend/checksupport.dcl b/frontend/checksupport.dcl index 695bd4a..0e7c42a 100644 --- a/frontend/checksupport.dcl +++ b/frontend/checksupport.dcl @@ -28,7 +28,7 @@ cNeedStdDynamics:== 4 :: CheckState = { cs_symbol_table :: !.SymbolTable, cs_predef_symbols :: !.PredefinedSymbols, cs_error :: !.ErrorAdmin,cs_x :: !CheckStateX } -:: CheckStateX = {x_needed_modules :: !BITVECT,x_main_dcl_module_n :: !Int } +:: CheckStateX = {x_needed_modules :: !BITVECT,x_main_dcl_module_n :: !Int /* TD */, x_is_dcl_module :: !Bool, x_type_var_position :: !Int, directly_imported_dcl_modules :: [String] } // SymbolTable :== {# SymbolTableEntry} diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl index 13b3ef0..d2b1e99 100644 --- a/frontend/checksupport.icl +++ b/frontend/checksupport.icl @@ -33,7 +33,7 @@ cNeedStdDynamics:== 4 :: CheckState = { cs_symbol_table :: !.SymbolTable, cs_predef_symbols :: !.PredefinedSymbols, cs_error :: !.ErrorAdmin, cs_x :: !CheckStateX } -:: CheckStateX = {x_needed_modules :: !BITVECT,x_main_dcl_module_n :: !Int } +:: CheckStateX = {x_needed_modules :: !BITVECT,x_main_dcl_module_n :: !Int /* TD */, x_is_dcl_module :: !Bool, x_type_var_position :: !Int, directly_imported_dcl_modules :: [String] } :: ConversionTable :== {# .{# Int }} diff --git a/frontend/checktypes.dcl b/frontend/checktypes.dcl index c8d8f13..6c4c192 100644 --- a/frontend/checktypes.dcl +++ b/frontend/checktypes.dcl @@ -2,7 +2,7 @@ definition module checktypes import checksupport, typesupport -checkTypeDefs :: !Bool !*{# CheckedTypeDef} !Index !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*VarHeap !*TypeHeaps !*CheckState +checkTypeDefs :: /* TD */ !Bool !Bool !*{# CheckedTypeDef} !Index !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*VarHeap !*TypeHeaps !*CheckState -> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState) checkSymbolType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index 09f4dcc..15c827d 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -59,20 +59,19 @@ where = True try_to_combine_attributes _ _ = False - + instance bindTypes TypeVar where - bindTypes cti tv=:{tv_name=var_id=:{id_info}} (ts, ti, cs=:{cs_symbol_table}) + bindTypes cti tv=:{tv_name=var_id=:{id_info}} (ts, ti, cs=:{cs_symbol_table /* TD ... */, cs_x={x_type_var_position,x_is_dcl_module} /* ... TD */ }) # (var_def, cs_symbol_table) = readPtr id_info cs_symbol_table cs = { cs & cs_symbol_table = cs_symbol_table } = case var_def.ste_kind of - STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count} + STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count /* TD */, stv_position} # cs = { cs & cs_symbol_table = cs.cs_symbol_table <:= (id_info, { var_def & ste_kind = STE_BoundTypeVariable { bv & stv_count = inc stv_count }})} - -> ({ tv & tv_info_ptr = stv_info_ptr }, stv_attribute, (ts, ti, cs)) + -> ({ tv & tv_info_ptr = stv_info_ptr /* TD ... */, tv_name = if x_is_dcl_module tv.tv_name { tv.tv_name & id_name = toString stv_position } /* ... TD */ }, stv_attribute, (ts, ti, cs)) _ -> (tv, TA_Multi, (ts, ti, { cs & cs_error = checkError var_id "undefined" cs.cs_error })) - instance bindTypes [a] | bindTypes a where bindTypes cti [] ts_ti_cs @@ -162,17 +161,18 @@ where # (types, local_vars_list, attr_env, ts_ti_cs) = bind_types_of_cons types cti free_vars attr_env ts_ti_cs (type, type_attr, (ts, ti, cs)) = bindTypes cti type ts_ti_cs - (local_vars, cs_symbol_table) = foldSt retrieve_local_vars free_vars ([], cs.cs_symbol_table) + (local_vars, cs_symbol_table /* TD ... */, _ /* ... TD */ ) = foldSt retrieve_local_vars free_vars ([], cs.cs_symbol_table /* TD ...*/, cs.cs_x /* ... TD */ ) (attr_env, cs_error) = addToAttributeEnviron type_attr cti.cti_lhs_attribute attr_env cs.cs_error = ([type : types], [local_vars : local_vars_list], attr_env, (ts, ti , { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })) where - retrieve_local_vars tv=:{tv_name={id_info}} (local_vars, symbol_table) - # (ste=:{ste_kind = STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count}}, symbol_table) = readPtr id_info symbol_table + retrieve_local_vars tv=:{tv_name={id_info}} (local_vars, symbol_table /* TD ... */, cs_x=:{x_is_dcl_module} /* ... TD */ ) + # (ste=:{ste_kind = STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count /* TD ... */,stv_position /* ... TD */ }}, symbol_table) = readPtr id_info symbol_table | stv_count == 0 - = (local_vars, symbol_table) - = ([{ atv_variable = { tv & tv_info_ptr = stv_info_ptr }, atv_attribute = stv_attribute, atv_annotation = AN_None } : local_vars], - symbol_table <:= (id_info, { ste & ste_kind = STE_BoundTypeVariable { bv & stv_count = 0}})) - + = (local_vars, symbol_table /* TD ... */, cs_x /* ... TD */) + + = ([{ atv_variable = { tv & tv_info_ptr = stv_info_ptr /* TD ... */, tv_name = if x_is_dcl_module tv.tv_name { tv.tv_name & id_name = toString stv_position } /* ... TD */ }, atv_attribute = stv_attribute, atv_annotation = AN_None } : local_vars], + symbol_table <:= (id_info, { ste & ste_kind = STE_BoundTypeVariable { bv & stv_count = 0}})/* TD ... */, cs_x /* ... TD */) + // checkRhsOfTypeDef :: !CheckedTypeDef ![AttributeVar] !CurrentTypeInfo !(!*TypeSymbols, !*TypeInfo, !*CheckState) -> (!TypeRhs, !(!*TypeSymbols, !*TypeInfo, !*CheckState)) @@ -227,10 +227,20 @@ isATopConsVar cv :== cv < 0 encodeTopConsVar cv :== dec (~cv) decodeTopConsVar cv :== ~(inc cv) -checkTypeDef :: !Index !Index !*TypeSymbols !*TypeInfo !*CheckState -> (!*TypeSymbols, !*TypeInfo, !*CheckState); -checkTypeDef type_index module_index ts=:{ts_type_defs} ti=:{ti_type_heaps} cs=:{cs_error} +checkTypeDef :: /* TD */ !Bool !Index !Index !*TypeSymbols !*TypeInfo !*CheckState -> (!*TypeSymbols, !*TypeInfo, !*CheckState); +checkTypeDef /* TD */ is_dcl_module type_index module_index ts=:{ts_type_defs} ti=:{ti_type_heaps} cs=:{cs_error} # (type_def, ts_type_defs) = ts_type_defs![type_index] # {td_name,td_pos,td_args,td_attribute} = type_def + + // TD ... + // in case of an icl-module, the arguments i.e. the type variables of type constructors are normalized which makes + // comparison by the static linker easier. + # (cs=:{cs_error}) + = { cs & cs_x = { cs.cs_x & x_is_dcl_module = is_dcl_module, x_type_var_position = 0 } } +// | FB (not is_dcl_module) ("checkTypeDef: " +++ td_name.id_name) True + # + // ... TD + position = newPosition td_name td_pos cs_error = pushErrorAdmin position cs_error (td_attribute, attr_vars, th_attrs) = determine_root_attribute td_attribute td_name.id_name ti_type_heaps.th_attrs @@ -242,7 +252,10 @@ checkTypeDef type_index module_index ts=:{ts_type_defs} ti=:{ti_type_heaps} cs=: ({ ts & ts_type_defs = ts_type_defs },{ ti & ti_type_heaps = ti_type_heaps}, cs) = ({ ts & ts_type_defs = { ts.ts_type_defs & [type_index] = { type_def & td_rhs = td_rhs }}}, ti, { cs & cs_error = popErrorAdmin cs.cs_error, - cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cOuterMostLevel type_vars cs.cs_symbol_table }) + cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cOuterMostLevel type_vars cs.cs_symbol_table + // TD ... + , cs_x = { cs.cs_x & x_is_dcl_module = False} }) + // ... TD where determine_root_attribute TA_None name attr_var_heap # (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap @@ -406,9 +419,9 @@ where kind_list_to_string [k:ks] = " -> " +++ toString k +++ kind_list_to_string ks */ -checkTypeDefs :: !Bool !*{# CheckedTypeDef} !Index !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*VarHeap !*TypeHeaps !*CheckState +checkTypeDefs :: /* TD */ !Bool !Bool !*{# CheckedTypeDef} !Index !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*VarHeap !*TypeHeaps !*CheckState -> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState) -checkTypeDefs is_main_dcl type_defs module_index cons_defs selector_defs modules var_heap type_heaps cs +checkTypeDefs /* TD */ is_dcl_module is_main_dcl type_defs module_index cons_defs selector_defs modules var_heap type_heaps cs #! nr_of_types = size type_defs # ts = { ts_type_defs = type_defs, ts_cons_defs = cons_defs, ts_selector_defs = selector_defs, ts_modules = modules } ti = { ti_type_heaps = type_heaps, ti_var_heap = var_heap } @@ -417,7 +430,7 @@ where check_type_defs is_main_dcl type_index nr_of_types module_index ts ti=:{ti_type_heaps,ti_var_heap} cs | type_index == nr_of_types = (ts.ts_type_defs, ts.ts_cons_defs, ts.ts_selector_defs, ts.ts_modules, ti_var_heap, ti_type_heaps, cs) - # (ts, ti, cs) = checkTypeDef type_index module_index ts ti cs + # (ts, ti, cs) = checkTypeDef /* TD */ is_dcl_module type_index module_index ts ti cs = check_type_defs is_main_dcl (inc type_index) nr_of_types module_index ts ti cs expand_syn_types module_index type_index nr_of_types expst @@ -983,26 +996,54 @@ cOuterMostLevel :== 0 addTypeVariablesToSymbolTable :: ![ATypeVar] ![AttributeVar] !*TypeHeaps !*CheckState -> (![ATypeVar], !(![AttributeVar], !*TypeHeaps, !*CheckState)) -addTypeVariablesToSymbolTable type_vars attr_vars heaps cs - = mapSt (add_type_variable_to_symbol_table) type_vars (attr_vars, heaps, cs) +addTypeVariablesToSymbolTable type_vars attr_vars heaps cs /* TD */ =:{cs_x={x_type_var_position,x_is_dcl_module}} +// TD ... + | x_type_var_position <> 0 = abort "addTypeVariablesToSymbolTable: x_type_var_position must be zero-initialized" + + # ((a_type_vars,t=:(attribute_vars, type_heaps, check_state))) + = mapSt (add_type_variable_to_symbol_table) type_vars (attr_vars, heaps, cs) + | x_is_dcl_module + = (a_type_vars,t) + + // in case of an icl-module, the type variables of the type definition need to be normalized by storing its + // argument number for later use. To avoid incomprehensible error messages the constructor's type variables + // are changed below. + # (a_type_vars,check_state) + = mapSt change_type_variables_into_their_type_constructor_position a_type_vars check_state + = (a_type_vars,(attribute_vars, type_heaps, check_state)) +// ... TD where +// TD ... + change_type_variables_into_their_type_constructor_position :: !ATypeVar !*CheckState -> (!ATypeVar, !*CheckState) + change_type_variables_into_their_type_constructor_position atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} cs=:{cs_symbol_table} + # tv_info = tv_name.id_info + (entry, cs_symbol_table) = readPtr tv_info cs_symbol_table + # stv_position + = case entry.ste_kind of + STE_BoundTypeVariable {stv_position} + -> stv_position + # atv + = { atv & atv_variable.tv_name.id_name = toString stv_position } + = (atv,{cs & cs_symbol_table = cs_symbol_table}) +// ... TD + add_type_variable_to_symbol_table :: !ATypeVar !(![AttributeVar], !*TypeHeaps, !*CheckState) -> (!ATypeVar, !(![AttributeVar], !*TypeHeaps, !*CheckState)) add_type_variable_to_symbol_table atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} - (attr_vars, heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error }) + (attr_vars, heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error /* TD ... */, cs_x={x_type_var_position} /* ... TD */}) # tv_info = tv_name.id_info - (entry, cs_symbol_table) = readPtr tv_info cs_symbol_table + (entry, cs_symbol_table) = readPtr tv_info cs_symbol_table | entry.ste_def_level < cOuterMostLevel # (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars atv_variable = { atv_variable & tv_info_ptr = tv_info_ptr } (atv_attribute, attr_vars, th_attrs, cs_error) = check_attribute atv_attribute tv_name.id_name attr_vars th_attrs cs_error cs_symbol_table = cs_symbol_table <:= (tv_info, {ste_index = NoIndex, ste_kind = STE_BoundTypeVariable {stv_attribute = atv_attribute, - stv_info_ptr = tv_info_ptr, stv_count = 0 }, ste_def_level = cOuterMostLevel, ste_previous = entry }) + stv_info_ptr = tv_info_ptr, stv_count = 0 /* TD */, stv_position = x_type_var_position}, ste_def_level = cOuterMostLevel, ste_previous = entry }) heaps = { heaps & th_vars = th_vars, th_attrs = th_attrs } = ({atv & atv_variable = atv_variable, atv_attribute = atv_attribute}, - (attr_vars, heaps, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })) + (attr_vars, heaps, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error /* TD ... */, cs_x = {cs.cs_x & x_type_var_position = inc x_type_var_position} /* ... TD */})) = (atv, (attr_vars, { heaps & th_vars = th_vars }, - { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name " type variable already defined" cs_error})) + { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name " type variable already defined" cs_error /* TD ... */, cs_x = {cs.cs_x & x_type_var_position = inc x_type_var_position} /* ... TD */})) check_attribute :: !TypeAttribute !String ![AttributeVar] !*AttrVarHeap !*ErrorAdmin -> (!TypeAttribute, ![AttributeVar], !*AttrVarHeap, !*ErrorAdmin) @@ -1028,7 +1069,7 @@ where add_type_variable_to_symbol_table :: !TypeAttribute !ATypeVar !(!*TypeHeaps, !*CheckState) -> (!ATypeVar, !(!*TypeHeaps, !*CheckState)) add_type_variable_to_symbol_table root_attr atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} - (heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error }) + (heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error /* TD ... */, cs_x={x_type_var_position} /* ... TD */}) # tv_info = tv_name.id_info (entry, cs_symbol_table) = readPtr tv_info cs_symbol_table | entry.ste_def_level < cOuterMostLevel @@ -1036,12 +1077,12 @@ where atv_variable = { atv_variable & tv_info_ptr = tv_info_ptr } (atv_attribute, cs_error) = check_attribute atv_attribute root_attr tv_name.id_name cs_error cs_symbol_table = cs_symbol_table <:= (tv_info, {ste_index = NoIndex, ste_kind = STE_BoundTypeVariable {stv_attribute = atv_attribute, - stv_info_ptr = tv_info_ptr, stv_count = 0 }, ste_def_level = cOuterMostLevel, ste_previous = entry }) + stv_info_ptr = tv_info_ptr, stv_count = 0 /* TD */, stv_position = x_type_var_position }, ste_def_level = cOuterMostLevel, ste_previous = entry }) heaps = { heaps & th_vars = th_vars } = ({atv & atv_variable = atv_variable, atv_attribute = atv_attribute}, - (heaps, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })) + (heaps, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error /* TD ... */, cs_x = {cs.cs_x & x_type_var_position = inc x_type_var_position} /* ... TD */ })) = (atv, ({ heaps & th_vars = th_vars }, - { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name " type variable already defined" cs_error})) + { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name " type variable already defined" cs_error /* TD ... */, cs_x = {cs.cs_x & x_type_var_position = inc x_type_var_position} /* ... TD */})) check_attribute :: !TypeAttribute !TypeAttribute !String !*ErrorAdmin -> (!TypeAttribute, !*ErrorAdmin) diff --git a/frontend/convertDynamics.dcl b/frontend/convertDynamics.dcl index dba1bc4..adabe15 100644 --- a/frontend/convertDynamics.dcl +++ b/frontend/convertDynamics.dcl @@ -3,7 +3,7 @@ definition module convertDynamics import syntax, transform, convertcases -convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap !*File {# DclModule} !IclModule +convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap !*File {# DclModule} !IclModule /* TD */ [String] -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, !*File) /* diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index db94e19..5f54bbb 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -47,23 +47,27 @@ pl [x:xs] = x +++ " , " +++ (pl xs) F :: !a .b -> .b F a b = b -write_tcl_file :: !Int {#DclModule} CommonDefs !*File -> (.Bool,.File) -write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file +write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File) +write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file directly_imported_dcl_modules #! tcl_file = write_type_info common_defs tcl_file - = (True,tcl_file) + #! tcl_file + = write_type_info directly_imported_dcl_modules tcl_file + #! tcl_file + = fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file + = (True,tcl_file) +//---> ("dcl",size main_dcl_module.dcl_common.com_type_defs, "icl", size common_defs.com_type_defs); -convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap /* TD */!*File {# DclModule} !IclModule +convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap /* TD */!*File {# DclModule} !IclModule /* TD */ [String] -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, /* TD */ !*File) -convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap /* TD */ tcl_file dcl_mods icl_mod +convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap /* TD */ tcl_file dcl_mods icl_mod /* TD */ directly_imported_dcl_modules // TD ... -/* # (ok,tcl_file) - = write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file + = write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file /* TD */ directly_imported_dcl_modules | not ok = abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file" -*/ // ... TD + # ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamics] #! (dynamic_temp_symb_ident,ci_sel_value_field,ci_sel_type_field,predefined_symbols) = case (pds_module == (-1) || pds_def == (-1)) of diff --git a/frontend/frontend.icl b/frontend/frontend.icl index c4584c3..4a825cf 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -89,7 +89,7 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac | not ok = (No,{},0,0,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) # symbol_table = hash_table.hte_symbol_heap - (ok, icl_mod, dcl_mods, components, optional_dcl_icl_conversions,cached_functions_and_macros,main_dcl_module_n,heaps, predef_symbols, symbol_table, error) + (ok, icl_mod, dcl_mods, components, optional_dcl_icl_conversions,cached_functions_and_macros,main_dcl_module_n,heaps, predef_symbols, symbol_table, error /* TD */, directly_imported_dcl_modules) = checkModule mod global_fun_range mod_functions n_functions_and_macros_in_dcl_modules dcl_module_n_in_cache optional_dcl_mod modules dcl_modules functions_and_macros predef_symbols (symbol_table -*-> "Checking") error heaps hash_table = { hash_table & hte_symbol_heap = symbol_table} @@ -137,7 +137,7 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac # (components, fun_defs, predef_symbols, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap, tcl_file) = convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs main_dcl_module_n (components -*-> "convertDynamics") fun_defs predef_symbols - heaps.hp_var_heap heaps.hp_type_heaps heaps.hp_expression_heap tcl_file dcl_mods icl_mod + heaps.hp_var_heap heaps.hp_type_heaps heaps.hp_expression_heap tcl_file dcl_mods icl_mod /* TD */ directly_imported_dcl_modules // # (components, fun_defs, error) = showComponents3 components 0 False fun_defs error // (components, fun_defs, error) = showComponents components 0 True fun_defs error diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 2457c8d..845043e 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -33,7 +33,7 @@ instance toString Ident , ste_previous :: SymbolTableEntry } -:: STE_BoundTypeVariable = { stv_count :: !Int, stv_attribute :: !TypeAttribute, stv_info_ptr :: !TypeVarInfoPtr} +:: STE_BoundTypeVariable = { stv_count :: !Int, stv_attribute :: !TypeAttribute, stv_info_ptr :: !TypeVarInfoPtr /* TD */, stv_position :: Int } :: STE_Kind = STE_FunctionOrMacro ![Index] | STE_Type diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 13ec1b1..d5201ae 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -34,7 +34,7 @@ where toString {import_module} = toString import_module , ste_previous :: SymbolTableEntry } -:: STE_BoundTypeVariable = { stv_count :: !Int, stv_attribute :: !TypeAttribute, stv_info_ptr :: !TypeVarInfoPtr} +:: STE_BoundTypeVariable = { stv_count :: !Int, stv_attribute :: !TypeAttribute, stv_info_ptr :: !TypeVarInfoPtr /* TD */, stv_position :: Int } :: STE_Kind = STE_FunctionOrMacro ![Index] | STE_Type diff --git a/frontend/type_io.dcl b/frontend/type_io.dcl index 4f208f6..0ec2bda 100644 --- a/frontend/type_io.dcl +++ b/frontend/type_io.dcl @@ -8,7 +8,7 @@ class WriteTypeInfo a where write_type_info :: a !*File -> !*File -instance WriteTypeInfo CommonDefs +instance WriteTypeInfo CommonDefs, Char, [a] | WriteTypeInfo a //1.3 instance WriteTypeInfo {#b} | select_u, size_u, WriteTypeInfo b diff --git a/frontend/type_io.icl b/frontend/type_io.icl index e4dbe75..f37a4a2 100644 --- a/frontend/type_io.icl +++ b/frontend/type_io.icl @@ -13,6 +13,120 @@ F a b :== b; // - abstract data type, what should be written? // +// Records: +// - ordered fields +// +// Constructors: +// - unordered + + +/* +:: TypeRhs = AlgType ![DefinedSymbol] + | SynType !AType + | RecordType !RecordType + | AbstractType !BITVECT + | UnknownType + + + { ds_ident :: !Ident + , ds_arity :: !Int + , ds_index :: !Index + } + + +:: RecordType = + { rt_constructor :: !DefinedSymbol + , rt_fields :: !{# FieldSymbol} + } + +:: FieldSymbol = + { fs_name :: !Ident + , fs_var :: !Ident + , fs_index :: !Index + } + +:: ConsDef = + { cons_symb :: !Ident + , cons_type :: !SymbolType + , cons_arg_vars :: ![[ATypeVar]] + , cons_priority :: !Priority + , cons_index :: !Index + , cons_type_index :: !Index + , cons_exi_vars :: ![ATypeVar] +// , cons_exi_attrs :: ![AttributeVar] + , cons_type_ptr :: !VarInfoPtr + , cons_pos :: !Position + } + +:: TypeDef type_rhs = + { td_name :: !Ident + , td_index :: !Int + , td_arity :: !Int + , td_args :: ![ATypeVar] + , td_attrs :: ![AttributeVar] + , td_context :: ![TypeContext] + , td_rhs :: !type_rhs + , td_attribute :: !TypeAttribute + , td_pos :: !Position + } + +*/ +class NormaliseTypeDef a +where + normalise_type_def :: a -> a + +import RWSDebug + +instance NormaliseTypeDef TypeRhs +where + normalise_type_def (AlgType defined_symbols) + // algebraic data types are further normalized by an alphabetical sort on the + // constructor names. + = AlgType (sortBy (\{ds_ident={id_name=id_name1}} {ds_ident={id_name=id_name2}} -> id_name1 < id_name2) defined_symbols) + normalise_type_def i + = i + +instance NormaliseTypeDef TypeDef rhs | NormaliseTypeDef rhs +where + normalise_type_def type_def=:{td_args,td_arity} + = type_def + + + + + +/* + +:: TypeVar = + { tv_name :: !Ident + , tv_info_ptr :: !TypeVarInfoPtr + } + +:: ATypeVar = + { atv_attribute :: !TypeAttribute + , atv_annotation :: !Annotation + , atv_variable :: !TypeVar + } + +:: TypeDef type_rhs = + { td_name :: !Ident + , td_index :: !Int + , td_arity :: !Int + , td_args :: ![ATypeVar] // example Tree a b = ... field is [a,b] + , td_attrs :: ![AttributeVar] + , td_context :: ![TypeContext] + , td_rhs :: !type_rhs + , td_attribute :: !TypeAttribute + , td_pos :: !Position + } +*/ +// CommonDefs +// TypeDef +loop [] + = "" +loop [{ds_ident={id_name}}:xs] + = id_name +++ ", " +++ (loop xs) + class WriteTypeInfo a where write_type_info :: a !*File -> !*File @@ -86,7 +200,10 @@ where instance WriteTypeInfo TypeDef TypeRhs where - write_type_info {td_name,td_arity,td_args,td_rhs} tcl_file + write_type_info /*{td_name,td_arity,td_args,td_rhs}*/ type_def tcl_file + # {td_name,td_arity,td_args,td_rhs} + = normalise_type_def type_def + | F ("TypeDef '" +++ td_name.id_name +++ "'") True #! tcl_file = write_type_info td_name tcl_file @@ -117,7 +234,10 @@ where instance WriteTypeInfo TypeVar where write_type_info {tv_name} tcl_file + // writing tv_name as number suffices + | F ("TypeVar: " +++ tv_name.id_name) True = write_type_info tv_name tcl_file + AlgTypeCode =: (toChar 5) SynTypeCode =: (toChar 6) @@ -638,7 +758,7 @@ where instance DefaultElem Int where default_elem - = abort "instance DefaultElem Int" + = 0 //abort "instance DefaultElem Int" instance DefaultElem DefinedSymbol where |