Commit c458938f authored by Martin Wierich's avatar Martin Wierich
Browse files

*** empty log message ***

parent f1a2cbc1
......@@ -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]
......
......@@ -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}
......
......@@ -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)
......
......@@ -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 }
......@@ -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
}
}
......
......@@ -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)
......
......@@ -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
......
......@@ -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]
......@@ -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)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment