diff options
| -rw-r--r-- | frontend/check.icl | 39 | ||||
| -rw-r--r-- | frontend/checksupport.dcl | 2 | ||||
| -rw-r--r-- | frontend/checksupport.icl | 12 | ||||
| -rw-r--r-- | frontend/comparedefimp.icl | 3 | ||||
| -rw-r--r-- | frontend/generics.icl | 3 | ||||
| -rw-r--r-- | frontend/parse.icl | 2 | ||||
| -rw-r--r-- | frontend/postparse.icl | 2 | ||||
| -rw-r--r-- | frontend/trans.icl | 152 | ||||
| -rw-r--r-- | main/compile.icl | 4 |
9 files changed, 137 insertions, 82 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index f9789e7..a7b5538 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -785,7 +785,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 /* TD */ is_dcl is_main_dcl_mod common.com_type_defs module_index + = checkTypeDefs 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 @@ -1129,17 +1129,6 @@ 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 @@ -1152,10 +1141,9 @@ 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 + (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 @@ -1186,15 +1174,15 @@ 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 /* 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) + = { cs & cs_symbol_table = cs_symbol_table } nr_of_icl_component = component_numbers.[index_of_icl_module] (_, expl_imp_infos, dcl_modules, icl_functions, heaps, cs) = unsafeFold2St (checkDclComponent components_array super_components) (reverse expl_imp_indices) (reverse components) (nr_of_components-1, expl_imp_infos, dcl_modules, icl_functions, heaps, cs) // # cs = cs--->"------------------------------------" - = (nr_of_icl_component, hd expl_imp_indices!!nr_of_icl_component, expl_imp_infos, - dcl_modules, icl_functions, heaps, cs) + = (nr_of_icl_component, hd expl_imp_indices!!nr_of_icl_component, directly_imported_dcl_modules, + expl_imp_infos, dcl_modules, icl_functions, heaps, cs) where add_dependencies mod_index (bitvect, dependencies, dcl_modules, cs_symbol_table) // all i: not bitvect.[i] @@ -1481,7 +1469,7 @@ checkDclModuleWithinComponent dcl_imported_module_numbers component_nr is_on_cyc checkModule :: !ScannedModule !IndexRange ![FunDef] !Int !Int !(Optional ScannedModule) ![ScannedModule] !{#DclModule} !{#FunDef} !*PredefinedSymbols !*SymbolTable !*File !*Heaps - -> (!Bool, *IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !.{#FunDef},!Int, !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File /* TD */, [String]) + -> (!Bool, *IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !.{#FunDef},!Int, !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File, [String]) checkModule m icl_global_function_range fun_defs n_functions_and_macros_in_dcl_modules dcl_module_n_in_cache optional_dcl_mod scanned_modules dcl_modules functions_and_macros predef_symbols symbol_table err_file heaps // | False--->("checkModule", m.mod_name) // = undef @@ -1515,7 +1503,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 /* TD */, x_is_dcl_module = False, x_type_var_position = 0, directly_imported_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, x_is_dcl_module = False, x_type_var_position = 0}} (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 @@ -1668,11 +1656,12 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func (dcl_to_icl_function_conversions,dcl_modules) = remove_function_conversion_table main_dcl_module_n dcl_modules - (nr_of_icl_component, expl_imp_indices, expl_imp_info, dcl_modules, icl_functions, heaps, cs) + (nr_of_icl_component, expl_imp_indices, directly_imported_dcl_modules, + expl_imp_info, dcl_modules, icl_functions, heaps, cs) = 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 /* TD */, []) + = (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, []) # (imported_module_numbers_of_main_dcl_mod, dcl_modules) = dcl_modules![main_dcl_module_n].dcl_imported_module_numbers (imported_module_numbers, dcl_modules) @@ -1802,7 +1791,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 /* TD */, cs_x.directly_imported_dcl_modules) + = (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, 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, com_generic_defs = e_info.ef_generic_defs/*AA*/ } @@ -1811,7 +1800,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 /* TD */, cs_x.directly_imported_dcl_modules) + = (False, icl_mod, dcl_modules, {}, No, {}, 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_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 d269981..2a998ad 100644 --- a/frontend/checksupport.dcl +++ b/frontend/checksupport.dcl @@ -29,7 +29,7 @@ cNeedStdGeneric :== 8 // AA :: 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 /* TD */, x_is_dcl_module :: !Bool, x_type_var_position :: !Int, directly_imported_dcl_modules :: [String] } +:: CheckStateX = {x_needed_modules :: !BITVECT,x_main_dcl_module_n :: !Int /* TD */, x_is_dcl_module :: !Bool, x_type_var_position :: !Int } // SymbolTable :== {# SymbolTableEntry} diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl index 401a6c0..1a90e9f 100644 --- a/frontend/checksupport.icl +++ b/frontend/checksupport.icl @@ -34,7 +34,7 @@ cNeedStdGeneric :== 8 // AA :: 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 /* TD */, x_is_dcl_module :: !Bool, x_type_var_position :: !Int, directly_imported_dcl_modules :: [String] } +:: CheckStateX = {x_needed_modules :: !BITVECT,x_main_dcl_module_n :: !Int /* TD */, x_is_dcl_module :: !Bool, x_type_var_position :: !Int } :: ConversionTable :== {# .{# Int }} @@ -159,20 +159,20 @@ newPosition id NoPos checkError :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b // PK checkError id mess error=:{ea_file,ea_loc=[]} - = { error & ea_file = ea_file <<< "Check Error " <<< "\"" <<< id <<< "\" " <<< mess <<< '\n', ea_ok = False } + = { error & ea_file = ea_file <<< "Error " <<< "\"" <<< id <<< "\" " <<< mess <<< '\n', ea_ok = False } checkError id mess error=:{ea_file,ea_loc} - = { error & ea_file = ea_file <<< "Check Error " <<< hd ea_loc <<< ":\"" <<< id <<< "\" " <<< mess <<< '\n', ea_ok = False } + = { error & ea_file = ea_file <<< "Error " <<< hd ea_loc <<< ":\"" <<< id <<< "\" " <<< mess <<< '\n', ea_ok = False } checkWarning :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b // PK checkWarning id mess error=:{ea_file,ea_loc=[]} - = { error & ea_file = ea_file <<< "Check Warning " <<< "\"" <<< id <<< "\" " <<< mess <<< '\n' } + = { error & ea_file = ea_file <<< "Warning " <<< "\"" <<< id <<< "\" " <<< mess <<< '\n' } checkWarning id mess error=:{ea_file,ea_loc} - = { error & ea_file = ea_file <<< "Check Warning " <<< hd ea_loc <<< ":\"" <<< id <<< "\" " <<< mess <<< '\n' } + = { error & ea_file = ea_file <<< "Warning " <<< hd ea_loc <<< ":\"" <<< id <<< "\" " <<< mess <<< '\n' } checkErrorWithIdentPos :: !IdentPos !a !*ErrorAdmin -> .ErrorAdmin | <<< a; checkErrorWithIdentPos ident_pos mess error=:{ea_file} - = { error & ea_file = ea_file <<< "Check Error " <<< ident_pos <<< ":" <<< mess <<< '\n', ea_ok = False } + = { error & ea_file = ea_file <<< "Error " <<< ident_pos <<< ":" <<< mess <<< '\n', ea_ok = False } class envLookUp a :: !a !(Env Ident .b) -> (!Bool,.b) diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index fc02ce0..449f6cd 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -814,11 +814,13 @@ e_corresponds_app_symb dcl_app_symb=:{symb_name, symb_kind=SK_Function dcl_glob_ #! main_dcl_module_n = ec_state.ec_main_dcl_module_n | dcl_glob_index.glob_module==main_dcl_module_n && icl_glob_index.glob_module==main_dcl_module_n # dcl_glob_object = dcl_glob_index.glob_object +/* is_indeed_a_macro = ec_state.ec_dcl_macro_range.ir_from <= dcl_glob_object && dcl_glob_object < ec_state.ec_dcl_macro_range.ir_to | is_indeed_a_macro = continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_glob_object icl_app_symb icl_glob_index.glob_object ec_state +*/ | ec_state.ec_function_conversions.[dcl_glob_object]<>icl_glob_index.glob_object = give_error symb_name ec_state = ec_state @@ -926,3 +928,4 @@ do_nothing ec_state give_error s ec_state = { ec_state & ec_error_admin = checkError s error_message ec_state.ec_error_admin } + diff --git a/frontend/generics.icl b/frontend/generics.icl index cfbc41d..6be0cae 100644 --- a/frontend/generics.icl +++ b/frontend/generics.icl @@ -145,8 +145,7 @@ convertGenerics x_needed_modules = 0, x_main_dcl_module_n = main_dcl_module_n, x_is_dcl_module = False, - x_type_var_position = 0, - directly_imported_dcl_modules = [] + x_type_var_position = 0 } } diff --git a/frontend/parse.icl b/frontend/parse.icl index 557f6d7..0acf7ef 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -300,7 +300,7 @@ where // otherwise // ~ succ # ({fp_line}, scanState) = getPosition scanState mod = { mod_name = file_id, mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_defs = [] } - = (False, mod, hash_table, error <<< '[' <<< file_name <<< ',' <<< fp_line <<< "]: incorrect module header", + = (False, mod, hash_table, error <<< "Error [" <<< file_name <<< ',' <<< fp_line <<< "]: incorrect module header", pre_def_symbols, closeScanner scanState files) try_module_header :: !Bool !ScanState -> (!Bool,!ModuleKind,!String,!ScanState) diff --git a/frontend/postparse.icl b/frontend/postparse.icl index def5cd8..19cf641 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -87,7 +87,7 @@ instance toParsedExpr Int where postParseError :: Position {#Char} *CollectAdmin -> *CollectAdmin postParseError pos msg ps=:{ca_error={pea_file}} # (filename, line, funname) = get_file_and_line_nr pos - pea_file = pea_file <<< "Post Parse Error [" <<< filename <<< "," <<< line + pea_file = pea_file <<< "Error [" <<< filename <<< "," <<< line pea_file = case funname of Yes name -> pea_file <<< "," <<< name No -> pea_file diff --git a/frontend/trans.icl b/frontend/trans.icl index 74a2cfc..be07c6d 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -187,6 +187,7 @@ writeVarInfo var_info_ptr new_var_info var_heap VI_Extended extensions _ -> writePtr var_info_ptr (VI_Extended extensions new_var_info) var_heap _ -> writePtr var_info_ptr new_var_info var_heap + class consumerRequirements a :: !a !{# CommonDefs} !AnalyseInfo -> (!ConsClass, !UnsafePatternBool, !AnalyseInfo) :: UnsafePatternBool :== Bool @@ -1448,8 +1449,8 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi = transform tb_rhs ro ti new_fd = { new_fd_expanding & fun_body = TransformedBody {tb_args = new_fun_args, tb_rhs = new_fun_rhs} } -// | (False--->("generated function", new_fd, '\n', new_fd.fun_type, new_cons_args)) -// = undef +// | (False--->("generated function", new_fd.fun_symb, '\n', new_fd.fun_type, new_cons_args)) +//` = undef = (ti_next_fun_nr, fun_arity, { ti & ti_fun_heap = ti.ti_fun_heap <:= (fun_def_ptr, FI_Function { new_gen_fd & gf_fun_def = new_fd })}) where is_dictionary {at_type=TA {type_index} _} es_td_infos @@ -1512,7 +1513,7 @@ where , ti_functions = ro.ro_imported_funs , ti_main_dcl_module_n = ro.ro_main_dcl_module_n } - (succ, subst, type_heaps) + # (succ, subst, type_heaps) /* = case isEmptyType int_class_type || isEmptyType (hd arg_type).at_type of True @@ -1580,7 +1581,7 @@ where (succ, subst, type_heaps) = unify application_type (hd arg_type) type_input subst type_heaps | not succ - = abort "sanity check nr 94 in module trans failed" + = abort ("sanity check nr 94 in module trans failed"--->(application_type, (hd arg_type))) # (attr_inequalities, type_heaps) = accAttrVarHeap (mapSt substitute_attr_inequality st_attr_env) type_heaps new_uniqueness_requirement @@ -1884,24 +1885,28 @@ where = abort ("trans.icl: max_group_index_of_producer" ---> prod) ro_main_dcl_module_n = ro.ro_main_dcl_module_n - max_group_index_of_member fun_defs fun_heap cons_args current_max (App {app_symb = {symb_name, symb_kind = SK_Function { glob_object = fun_index, glob_module = mod_index}}}) + max_group_index_of_member fun_defs fun_heap cons_args current_max + (App {app_symb = {symb_name, symb_kind = SK_Function { glob_object = fun_index, glob_module = mod_index}}}) | mod_index == ro_main_dcl_module_n | fun_index < size cons_args # {fun_info = {fi_group_index}} = fun_defs.[fun_index] = max fi_group_index current_max = current_max = current_max - max_group_index_of_member fun_defs fun_heap cons_args current_max (App {app_symb = {symb_name, symb_kind = SK_LocalMacroFunction fun_index}}) + max_group_index_of_member fun_defs fun_heap cons_args current_max + (App {app_symb = {symb_name, symb_kind = SK_LocalMacroFunction fun_index}}) | fun_index < size cons_args # {fun_info = {fi_group_index}} = fun_defs.[fun_index] = max fi_group_index current_max = current_max - max_group_index_of_member fun_defs fun_heap cons_args current_max (App {app_symb = {symb_kind = SK_GeneratedFunction fun_ptr _ }}) + max_group_index_of_member fun_defs fun_heap cons_args current_max + (App {app_symb = {symb_kind = SK_GeneratedFunction fun_ptr _ }}) # (FI_Function {gf_fun_def={fun_info = {fi_group_index}}}) = sreadPtr fun_ptr fun_heap = max fi_group_index current_max - max_group_index_of_member fun_defs fun_heap cons_args current_max (App {app_symb = {symb_kind = SK_Constructor _}, app_args}) + max_group_index_of_member fun_defs fun_heap cons_args current_max + (App {app_symb = {symb_kind = SK_Constructor _}, app_args}) = max_group_index_of_members app_args current_max fun_defs fun_heap cons_args - + max_group_index_of_members members current_max fun_defs fun_heap cons_args = foldl (max_group_index_of_member fun_defs fun_heap cons_args) current_max members @@ -2005,15 +2010,15 @@ transformFunctionApplication fun_def instances cc=:{cc_size, cc_args, cc_linear_ | cc_size > 0 # (producers, new_args, ti) = determineProducers fun_def.fun_info.fi_is_macro_fun cc_linear_bits cc_args app_args 0 (createArray cc_size PR_Empty) ro ti -// | False--->("determineProducers",(cc_linear_bits,cc_args,app_args),("results in",II_Node producers nilPtr II_Empty II_Empty)) -// = undef | containsProducer cc_size producers +// | False--->("determineProducers",(cc_linear_bits,cc_args,app_symb.symb_name, app_args),("\nresults in",II_Node producers nilPtr II_Empty II_Empty)) +// = undef # (is_new, fun_def_ptr, instances, ti_fun_heap) = tryToFindInstance producers instances ti.ti_fun_heap | is_new # (fun_index, fun_arity, ti) = generateFunction fun_def cc producers fun_def_ptr ro (update_instance_info app_symb.symb_kind instances { ti & ti_fun_heap = ti_fun_heap, ti_trace = False }) app_symb = { app_symb & symb_kind = SK_GeneratedFunction fun_def_ptr fun_index, symb_arity = length new_args} - (app_symb, app_args, extra_args) = complete_application app_symb fun_arity new_args extra_args + # (app_symb, app_args, extra_args) = complete_application app_symb fun_arity new_args extra_args = transformApplication { app & app_symb = app_symb, app_args = app_args } extra_args ro ti # (FI_Function {gf_fun_index, gf_fun_def}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap app_symb = { app_symb & symb_kind = SK_GeneratedFunction fun_def_ptr gf_fun_index, symb_arity = length new_args} @@ -2129,14 +2134,12 @@ determineProducer _ _ app=:{app_symb = {symb_arity}, app_args} _ new_args prod_i | symb_arity<>length app_args = abort "sanity check 98765 failed in module trans" determineProducer _ _ app=:{app_symb = symb=:{symb_kind = SK_Constructor _}, app_args} (EI_DictionaryType type) new_args prod_index producers _ ti - # (app_args, (new_vars_and_types, ti_var_heap)) = renewVariables app_args ([], ti.ti_var_heap) - (new_args, ti_var_heap) = mapAppendSt retrieve_old_var new_vars_and_types new_args ti_var_heap - = ({ producers & [prod_index] = PR_Class { app & app_args = app_args } new_vars_and_types type}, new_args, { ti & ti_var_heap = ti_var_heap }) - where - retrieve_old_var ({var_info_ptr}, _) var_heap - # (var_info, var_heap) = readVarInfo var_info_ptr var_heap - (VI_Forward var) = var_info - = (Var var, writeVarInfo var_info_ptr VI_Empty (writeVarInfo var.var_info_ptr VI_Empty var_heap)) + # (app_args, (new_vars_and_types, free_vars, ti_var_heap)) + = renewVariables app_args ti.ti_var_heap + = ( { producers & [prod_index] = PR_Class { app & app_args = app_args } new_vars_and_types type} + , mapAppend Var free_vars new_args + , { ti & ti_var_heap = ti_var_heap } + ) determineProducer is_applied_to_macro_fun linear_bit app=:{app_symb = symb=:{ symb_kind = SK_GeneratedFunction fun_ptr fun_index, symb_arity}, app_args} _ new_args prod_index producers ro ti # (FI_Function {gf_fun_def={fun_body, fun_arity, fun_type=Yes symbol_type}}, ti_fun_heap) = readPtr fun_ptr ti.ti_fun_heap @@ -2212,34 +2215,58 @@ where is_a_producer PR_Empty = False is_a_producer _ = True -class renewVariables a :: !a !(![(BoundVar, Type)], !*VarHeap) -> (!a, !(![(BoundVar, Type)], !*VarHeap)) - -instance renewVariables Expression -where - renewVariables (Var var=:{var_info_ptr}) (new_vars, var_heap) +:: *RenewState :== (![(BoundVar, Type)], ![BoundVar], !*VarHeap) + +renewVariables :: ![Expression] !*VarHeap + -> (![Expression], !RenewState) +renewVariables exprs var_heap + # (exprs, (new_vars, free_vars, var_heap)) + = mapSt (mapExprSt map_expr preprocess_free_var postprocess_free_var) + exprs ([], [], var_heap) + var_heap + = foldSt (\{var_info_ptr} var_heap -> writeVarInfo var_info_ptr VI_Empty var_heap) + free_vars var_heap + = (exprs, (new_vars, free_vars, var_heap)) + where + map_expr :: !Expression !RenewState -> (!Expression, !RenewState) + map_expr (Var var=:{var_info_ptr, var_name}) (new_vars_accu, free_vars_accu, var_heap) # (var_info, var_heap) = readPtr var_info_ptr var_heap = case var_info of VI_Extended _ (VI_Forward new_var) - -> (Var { var & var_info_ptr = new_var.var_info_ptr }, (new_vars, var_heap)) + -> ( Var new_var + , (new_vars_accu, free_vars_accu, var_heap)) VI_Extended evi=:(EVI_VarType var_type) _ - # (new_info_ptr, var_heap) - = newPtr (VI_Extended (EVI_VarType var_type) (VI_Forward var)) var_heap - new_var - = { var & var_info_ptr = new_info_ptr } - var_heap - = writePtr var_info_ptr (VI_Extended evi (VI_Forward new_var)) var_heap - -> (Var new_var, ([(new_var, var_type.at_type) : new_vars], var_heap)) - renewVariables (App app=:{app_args}) state - # (app_args, state) = renewVariables app_args state - = (App { app & app_args = app_args }, state) - renewVariables (Selection x1 expr x2) state - # (expr, state) = renewVariables expr state - = (Selection x1 expr x2, state) - -instance renewVariables [a] | renewVariables a -where - renewVariables l state = mapSt renewVariables l state + # (new_var, var_heap) + = allocate_and_bind_new_var var_name var_info_ptr evi var_heap + -> ( Var new_var + , ( [(new_var, var_type.at_type) : new_vars_accu] + , [var:free_vars_accu] + , var_heap + ) + ) + map_expr x st = (x, st) + + preprocess_free_var :: !FreeVar !RenewState -> (!FreeVar, !RenewState) + preprocess_free_var fv=:{fv_name, fv_info_ptr} (new_vars_accu, free_vars_accu, var_heap) + # (VI_Extended evi _, var_heap) + = readPtr fv_info_ptr var_heap + (new_var, var_heap) + = allocate_and_bind_new_var fv_name fv_info_ptr evi var_heap + = ( { fv & fv_info_ptr = new_var.var_info_ptr} + , (new_vars_accu, free_vars_accu, var_heap)) + allocate_and_bind_new_var var_name var_info_ptr evi var_heap + # (new_info_ptr, var_heap) + = newPtr (VI_Extended evi VI_Empty) var_heap + new_var + = { var_name = var_name, var_info_ptr = new_info_ptr, var_expr_ptr = nilPtr } + var_heap + = writeVarInfo var_info_ptr (VI_Forward new_var) var_heap + = (new_var, var_heap) + postprocess_free_var :: !FreeVar !RenewState -> RenewState + postprocess_free_var {fv_info_ptr} (a, b, var_heap) + = (a, b, writeVarInfo fv_info_ptr VI_Empty var_heap) + :: ImportedConstructors :== [Global Index] @@ -2278,7 +2305,8 @@ transformGroups cleanup_info main_dcl_module_n groups fun_defs cons_args common_ transform_function common_defs imported_funs fun ti=:{ti_fun_defs, ti_var_heap} # (fun_def, ti_fun_defs) = ti_fun_defs![fun] - (Yes {st_args}) = fun_def.fun_type +// | False--->("TRANSFORMING", fun_def.fun_symb, '\n') = undef + # (Yes {st_args}) = fun_def.fun_type {fun_body = TransformedBody tb} = fun_def ti_var_heap = fold2St (\{fv_info_ptr} a_type ti_var_heap -> setExtendedVarInfo fv_info_ptr (EVI_VarType a_type) ti_var_heap) @@ -2708,3 +2736,39 @@ isYes (Yes _) = True isYes _ = False empty_atype = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TE } + +mapExprSt map_expr map_free_var postprocess_free_var expr st :== map_expr_st expr st + where + map_expr_st expr=:(Var bound_var) st + = map_expr expr st + map_expr_st (App app=:{app_args}) st + # (app_args, st) = mapSt map_expr_st app_args st + = map_expr (App { app & app_args = app_args }) st + map_expr_st (Let lad=:{let_lazy_binds, let_strict_binds, let_expr}) st + # (lazy_free_vars, st) + = mapSt (\{lb_dst} st -> map_free_var lb_dst st) let_lazy_binds st + (strict_free_vars, st) + = mapSt (\{lb_dst} st -> map_free_var lb_dst st) let_strict_binds st + (lazy_rhss, st) + = mapSt (\{lb_src} st -> map_expr_st lb_src st) let_lazy_binds st + (strict_rhss, st) + = mapSt (\{lb_src} st -> map_expr_st lb_src st) let_strict_binds st + (let_expr, st) + = map_expr let_expr st + st = foldSt (\{lb_dst} st -> postprocess_free_var lb_dst st) let_lazy_binds st + st = foldSt (\{lb_dst} st -> postprocess_free_var lb_dst st) let_strict_binds st + = ( Let { lad & let_lazy_binds = combine lazy_free_vars lazy_rhss let_lazy_binds, + let_strict_binds = combine strict_free_vars strict_rhss let_strict_binds, + let_expr = let_expr + } + , st + ) + map_expr_st (Selection a expr b) st + # (expr, st) = map_expr expr st + = (Selection a expr b, st) + +combine :: [FreeVar] [Expression] [LetBind] -> [LetBind] +combine free_vars rhss original_binds + = [{ original_bind & lb_dst = lb_dst, lb_src = lb_src} + \\ lb_dst <- free_vars & lb_src <- rhss & original_bind <- original_binds] + diff --git a/main/compile.icl b/main/compile.icl index ccc25fa..cdfa82c 100644 --- a/main/compile.icl +++ b/main/compile.icl @@ -174,8 +174,8 @@ compileModule options commandLineArgs {dcl_modules,functions_and_macros,predef_s // (moduleIdent, hash_table) = putIdentInHashTable options.moduleName IC_Module hash_table # ({boxed_ident=moduleIdent}, hash_table) = putIdentInHashTable options.moduleName IC_Module hash_table # list_inferred_types = if (isMember "-lt" commandLineArgs) (Yes (not (isMember "-lattr" commandLineArgs))) No - # (optionalSyntaxTree,cached_functions_and_macros,n_functions_and_macros_in_dcl_modules,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out,tcl_file,heaps) - = frontEndInterface FrontEndPhaseAll moduleIdent options.searchPaths dcl_modules functions_and_macros list_inferred_types predef_symbols hash_table files error io out tcl_file heaps + # (optionalSyntaxTree,cached_functions_and_macros,n_functions_and_macros_in_dcl_modules,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out,Yes tcl_file,heaps) + = frontEndInterface FrontEndPhaseAll moduleIdent options.searchPaths dcl_modules functions_and_macros list_inferred_types predef_symbols hash_table files error io out (Yes tcl_file) heaps # unique_copy_of_predef_symbols={predef_symbol\\predef_symbol<-:predef_symbols} # (closed, files) |