diff options
| -rw-r--r-- | frontend/check.icl | 63 | ||||
| -rw-r--r-- | frontend/comparedefimp.icl | 11 | ||||
| -rw-r--r-- | frontend/convertcases.icl | 7 | ||||
| -rw-r--r-- | frontend/frontend.icl | 14 | ||||
| -rw-r--r-- | frontend/overloading.icl | 10 | ||||
| -rw-r--r-- | frontend/postparse.icl | 322 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 9 | ||||
| -rw-r--r-- | frontend/syntax.icl | 35 | ||||
| -rw-r--r-- | frontend/trans.icl | 39 | ||||
| -rw-r--r-- | frontend/transform.dcl | 15 | ||||
| -rw-r--r-- | frontend/transform.icl | 438 | ||||
| -rw-r--r-- | frontend/type.icl | 16 |
12 files changed, 549 insertions, 430 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 1353c39..3ceeeeb 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -669,6 +669,7 @@ where = (AP_Algebraic cons_symbol cons_def.cons_type_index patterns opt_var, ums) = (AP_Empty cons_def.cons_symb, { ums & ums_cons_defs = ums_cons_defs, ums_modules = ums_modules, ums_error = checkError cons_def.cons_symb " missing argument(s)" ums_error }) + get_cons_def mod_index cons_mod cons_index cons_defs modules | mod_index == cons_mod # (cons_def, cons_defs) = cons_defs![cons_index] @@ -676,7 +677,6 @@ where # ({dcl_common,dcl_conversions}, modules) = modules![cons_mod] cons_def = dcl_common.com_cons_defs.[cons_index] = (cons_def, convertIndex cons_index (toInt STE_Constructor) dcl_conversions, cons_defs, modules) - get_cons_def mod_index cons_mod cons_index cons_defs modules # ({dcl_common,dcl_conversions}, modules) = modules![cons_mod] cons_def = dcl_common.com_cons_defs.[cons_index] @@ -703,7 +703,7 @@ checkPatternConstructor _ _ {ste_kind = STE_Empty} ident _ ps e_info cs=:{cs_er checkPatternConstructor mod_index is_expr_list {ste_kind = STE_FunctionOrMacro _,ste_index} ident opt_var ps=:{ps_fun_defs} e_info cs=:{cs_error,cs_x} # ({fun_symb,fun_arity,fun_kind,fun_priority},ps_fun_defs) = ps_fun_defs![ste_index] ps = { ps & ps_fun_defs = ps_fun_defs } - | fun_kind == FK_Macro + | case fun_kind of FK_DefMacro->True ; FK_ImpMacro->True; _ -> False | is_expr_list # macro_symbol = { glob_object = MakeDefinedSymbol fun_symb ste_index fun_arity, glob_module = cs_x.x_main_dcl_module_n } = (AP_Constant APK_Macro macro_symbol fun_priority, ps, e_info, cs) @@ -1112,15 +1112,21 @@ where # ({fun_symb,fun_arity,fun_kind,fun_priority}, es_fun_defs) = es_fun_defs![ste_index] # index = { glob_object = ste_index, glob_module = cs_x.x_main_dcl_module_n } | is_called_before ei_fun_index calls - | fun_kind == FK_Macro + | case fun_kind of FK_DefMacro->True ; FK_ImpMacro->True; _ -> False = (SK_Macro index, fun_arity, fun_priority, cIsAFunction, { e_state & es_fun_defs = es_fun_defs }, e_info, cs) -// = (SK_Function index, fun_arity, fun_priority, cIsAFunction, { e_state & es_fun_defs = es_fun_defs }, e_info, cs) # symbol_kind = if ef_is_macro_fun (SK_LocalMacroFunction ste_index) (SK_Function index) = (symbol_kind, fun_arity, fun_priority, cIsAFunction, { e_state & es_fun_defs = es_fun_defs }, e_info, cs) # cs = { cs & cs_symbol_table = cs_symbol_table <:= (symb_info, { entry & ste_kind = STE_FunctionOrMacro [ ei_fun_index : calls ]})} e_state = { e_state & es_fun_defs = es_fun_defs, es_calls = [{ fc_index = ste_index, fc_level = ste_def_level} : es_calls ]} -// = (if (fun_kind == FK_Macro) (SK_Macro index) (SK_Function index), fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) - # symbol_kind = if (fun_kind == FK_Macro) (SK_Macro index) (if ef_is_macro_fun (SK_LocalMacroFunction ste_index) (SK_Function index)) + # symbol_kind = case fun_kind of + FK_DefMacro + -> SK_Macro index; + FK_ImpMacro + -> SK_Macro index; + _ + | ef_is_macro_fun + -> SK_LocalMacroFunction ste_index + -> SK_Function index = (symbol_kind, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) where is_called_before caller_index [] @@ -2426,7 +2432,11 @@ where get_calls (STE_FunctionOrMacro [x:xs]) = (x,xs) get_calls ste_kind = abort "get_calls (check.icl)" // <<- ste_kind - push_error_admin_beautifully {id_name} fun_pos (FK_Function fun_name_is_location_dependent) cs_error + push_error_admin_beautifully {id_name} fun_pos (FK_ImpFunction fun_name_is_location_dependent) cs_error + | fun_name_is_location_dependent && size id_name>0 + # beautiful_name = if (id_name.[0]==backslash) "lambda" "comprehension" + = pushErrorAdmin (newPosition { id_name=beautiful_name, id_info=nilPtr } fun_pos) cs_error + push_error_admin_beautifully {id_name} fun_pos (FK_DefFunction fun_name_is_location_dependent) cs_error | fun_name_is_location_dependent && size id_name>0 # beautiful_name = if (id_name.[0]==backslash) "lambda" "comprehension" = pushErrorAdmin (newPosition { id_name=beautiful_name, id_info=nilPtr } fun_pos) cs_error @@ -2800,7 +2810,7 @@ checkModule m icl_global_function_range fun_defs n_functions_and_macros_in_dcl_m // # (ea_ok, icl_mod, dcl_modules, groups, dcl_icl_conversions, heaps, cs_predef_symbols, cs_symbol_table, ea_file) = 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 // = (ea_ok, icl_mod, dcl_modules, groups, dcl_icl_conversions, cached_functions_and_macros, heaps, cs_predef_symbols, cs_symbol_table, ea_file) - + 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 # error = {ea_file = err_file, ea_loc = [], ea_ok = True } @@ -2858,7 +2868,6 @@ check_module1 {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cde # (mod_entry, symbol_table) = readPtr mod_symb.pds_ident.id_info symbol_table = case mod_entry.ste_kind of STE_Module _ -// -> ({ pre_def_symbols & [predef_index] = { mod_symb & pds_module = cIclModIndex, pds_def = mod_entry.ste_index }}, symbol_table) -> ({ pre_def_symbols & [predef_index] = { mod_symb & pds_module = cs_x.x_main_dcl_module_n, pds_def = mod_entry.ste_index }}, symbol_table) _ -> (pre_def_symbols, symbol_table) @@ -2939,6 +2948,29 @@ replace_icl_macros_by_dcl_macros _ {ir_from=first_icl_macro_index,ir_to=end_icl_ = [] = (decls,dcl_modules,cs) +remove_function_conversion_table main_dcl_module_n dcl_modules + # (dcl_mod,dcl_modules) = dcl_modules![main_dcl_module_n] + = case dcl_mod.dcl_conversions of + No + -> ({},dcl_modules) + (Yes conversion_table) + #! size_function_conversions = size conversion_table.[cFunctionDefs] + # conversion_table = {e \\ e <-:conversion_table} + # (function_conversions,conversion_table) = replace conversion_table cFunctionDefs {n \\ n<-[0..size_function_conversions-1]} + # dcl_modules = {dcl_modules & [main_dcl_module_n].dcl_conversions=Yes conversion_table} + -> (function_conversions,dcl_modules) + +add_function_conversion_table dcl_to_icl_function_conversions main_dcl_module_n dcl_modules + # (dcl_mod,dcl_modules) = dcl_modules![main_dcl_module_n] + = case dcl_mod.dcl_conversions of + No + -> dcl_modules + (Yes conversion_table) + # conversion_table = {e \\ e <-:conversion_table} + # conversion_table = {conversion_table & [cFunctionDefs]=dcl_to_icl_function_conversions} + # dcl_modules = {dcl_modules & [main_dcl_module_n].dcl_conversions=Yes conversion_table} + -> dcl_modules + check_module2 :: Ident [.ImportedObject] .[Import ImportDeclaration] .ModuleKind !.IndexRange !.IndexRange !Int !Int (Optional (Module a)) [.Declaration] *{#FunDef} *{#DclModule} (CollectedDefinitions ClassInstance IndexRange) *{#.Int} *Heaps *CheckState @@ -2957,13 +2989,17 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func (dcl_modules, icl_functions, heaps, cs) = check_predefined_module optional_pre_def_mod dcl_modules icl_functions heaps cs + # (main_dcl_module_n,cs)=cs!cs_x.x_main_dcl_module_n + (dcl_to_icl_function_conversions,dcl_modules) = remove_function_conversion_table main_dcl_module_n dcl_modules + iinfo = { ii_modules = dcl_modules, ii_funs_and_macros = icl_functions, ii_next_num = 0, ii_deps = [] } (iinfo, heaps, cs) = check_dcl_module iinfo heaps cs (_, imported_module_numbers,{ii_modules,ii_funs_and_macros = icl_functions}, heaps, cs) = checkImports mod_imports EndModuleNumbers iinfo heaps cs - + + ii_modules = add_function_conversion_table dcl_to_icl_function_conversions main_dcl_module_n ii_modules + cs = { cs & cs_x.x_needed_modules = 0 } - # (main_dcl_module_n,cs)=cs!cs_x.x_main_dcl_module_n # imported_module_numbers = add_module_n main_dcl_module_n (add_module_n 1 imported_module_numbers) // ii_modules = print_imported_modules 0 ii_modules (used_module_numbers,ii_modules) = compute_used_module_numbers imported_module_numbers imported_module_numbers ii_modules @@ -3143,7 +3179,7 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func = ([new_fun_def : new_fun_defs], funs_index_heaps) = ([], (icl_functions, next_fun_index, heaps)) - build_function new_fun_index fun_def=:{fun_symb, fun_arity, fun_index, fun_body = CheckedBody {cb_args}, fun_info} fun_type + build_function new_fun_index fun_def=:{fun_symb, fun_index, fun_arity, fun_body = CheckedBody {cb_args}, fun_info} fun_type (var_heap, type_var_heap, expr_heap) # (tb_args, var_heap) = mapSt new_free_var cb_args var_heap (app_args, expr_heap) = mapSt new_bound_var tb_args expr_heap @@ -3152,7 +3188,7 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func symb_kind = SK_Function { glob_module = main_dcl_module_n, glob_object = fun_index }}, app_args = app_args, app_info_ptr = app_info_ptr } - = ({ fun_def & fun_index = new_fun_index, fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, fun_type = Yes fun_type, + = ({ fun_def & fun_index=new_fun_index, fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, fun_type = Yes fun_type, fun_info = { EmptyFunInfo & fi_calls = [ { fc_index = fun_index, fc_level = cGlobalScope }] }}, (var_heap, type_var_heap, expr_heap)) @@ -3445,7 +3481,6 @@ checkDclModule is_on_cycle {mod_name,mod_imports,mod_defs} mod_index modules icl cs = { cs & cs_x.x_needed_modules = 0 } nr_of_dcl_functions = size dcl_mod.dcl_functions - dcls_explicit = flatten [[dcls_explicit\\dcls_explicit<-:dcls_explicit] \\ (_,{dcls_explicit})<-imports] #! main_dcl_module_n = cs.cs_x.x_main_dcl_module_n diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index ec3957d..cc3cee5 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -19,8 +19,7 @@ implementation module comparedefimp (see type HeapWithNumber). The same happens with attribute variables and variables in macros/functions. */ -import syntax, checksupport, compare_constructor, utilities, StdCompare -import RWSDebug +import syntax, checksupport, compare_constructor, utilities, StdCompare //, RWSDebug :: TypesCorrespondState = { tc_type_vars @@ -623,9 +622,9 @@ instance t_corresponds TypeRhs where = return True // sanity check ... t_corresponds UnknownType _ - = undef <<- "t_corresponds (TypeRhs): dclDef == UnknownType" + = undef // <<- "t_corresponds (TypeRhs): dclDef == UnknownType" t_corresponds _ UnknownType - = undef <<- "t_corresponds (TypeRhs): iclDef == UnknownType" + = undef // <<- "t_corresponds (TypeRhs): iclDef == UnknownType" // ... sanity check t_corresponds _ _ = return False @@ -990,7 +989,9 @@ continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_index icl_app_sy && (implies (not dcl_name_is_loc_dependent) (dcl_function.fun_symb.id_name==icl_function.fun_symb.id_name)) // functions that originate from e.g. lambda expressions can correspond although their names differ where - name_is_location_dependent (FK_Function name_is_loc_dependent) + name_is_location_dependent (FK_ImpFunction name_is_loc_dependent) + = name_is_loc_dependent + name_is_location_dependent (FK_DefFunction name_is_loc_dependent) = name_is_loc_dependent name_is_location_dependent _ = False diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index 88a142c..11b09e0 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -1,7 +1,6 @@ implementation module convertcases -import syntax, transform, checksupport, StdCompare, check, utilities, trans, general, RWSDebug - +import syntax, transform, checksupport, StdCompare, check, utilities, trans, general // , RWSDebug :: *ConversionInfo = { ci_new_functions :: ![FunctionInfoPtr] @@ -306,7 +305,7 @@ newFunction opt_id fun_bodies local_vars arg_types result_type group_index (ci_n , fun_type = Yes fun_type , fun_pos = NoPos , fun_index = NoIndex - , fun_kind = FK_Function cNameNotLocationDependent + , fun_kind = FK_ImpFunction cNameNotLocationDependent , fun_lifted = 0 , fun_info = { EmptyFunInfo & fi_group_index = group_index, fi_local_vars = local_vars } } @@ -792,7 +791,7 @@ where { cp_info & cp_free_vars = [ (var_info_ptr, type) : cp_info.cp_free_vars ], cp_var_heap = cp_var_heap <:= (var_info_ptr, VI_FreeVar var_name new_info_ptr 1 type) }) _ - -> abort "copy [BoundVar] (convertcases, 612)" <<- (var_info ---> (var_name, ptrToInt var_info_ptr)) + -> abort "copy [BoundVar] (convertcases)" // <<- (var_info ---> (var_name, ptrToInt var_info_ptr)) instance copy Expression where diff --git a/frontend/frontend.icl b/frontend/frontend.icl index 13af162..00bce5a 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -73,7 +73,7 @@ frontSyntaxTree predef_symbols hash_table files error io out icl_mod dcl_mods fu frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !{#DclModule} !{#FunDef} !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File !*Heaps -> ( !Optional *FrontEndSyntaxTree,!.{# FunDef },!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File,!*Heaps) frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_macros list_inferred_types predef_symbols hash_table files error io out heaps # (ok, mod, hash_table, error, predef_symbols, files) - = wantModule cWantIclFile mod_ident NoPos (hash_table -*-> ("Parsing:", mod_ident)) error search_paths predef_symbols files + = wantModule cWantIclFile mod_ident NoPos (hash_table /* ---> ("Parsing:", mod_ident)*/) error search_paths predef_symbols files | not ok = (No,{},0,0,predef_symbols, hash_table, files, error, io, out,heaps) # cached_module_idents = [dcl_mod.dcl_name \\ dcl_mod<-:dcl_modules] @@ -100,13 +100,17 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac // # {icl_functions,icl_instances,icl_specials,icl_common,icl_import} = icl_mod # {icl_instances,icl_specials,icl_common,icl_import,icl_name,icl_imported_objects,icl_used_module_numbers} = icl_mod - -// (components, icl_functions, error) = showComponents components 0 True icl_functions error - +/* + (_,f,files) = fopen "components" FWriteText files + (components, icl_functions, f) = showComponents components 0 True icl_functions f + (ok,files) = fclose f files + | ok<>ok + = abort ""; +*/ // dcl_mods = {{dcl_mod & dcl_declared={dcls_import=[],dcls_local=[],dcls_explicit=[]}}\\ dcl_mod<-:dcl_mods} // # dcl_mods = {{dcl_mod & dcl_declared={dcls_import={},dcls_local=[],dcls_local_for_import={},dcls_explicit={}}}\\ dcl_mod<-:dcl_mods} - var_heap = heaps.hp_var_heap + # var_heap = heaps.hp_var_heap type_heaps = heaps.hp_type_heaps fun_defs = icl_functions array_instances = {ir_from=0, ir_to=0} diff --git a/frontend/overloading.icl b/frontend/overloading.icl index 57b6d1f..83baedb 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -2,8 +2,7 @@ implementation module overloading import StdEnv -import syntax, check, type, typesupport, utilities, unitype, predef, checktypes, RWSDebug, convertDynamics - +import syntax, check, type, typesupport, utilities, unitype, predef, checktypes, convertDynamics // ,RWSDebug :: InstanceTree = IT_Node !(Global Index) !InstanceTree !InstanceTree | IT_Empty @@ -695,7 +694,7 @@ expressionToTypeCodeExpression (ClassVariable var_info_ptr) = TCE_TypeTerm var /* expressionToTypeCodeExpression (Var {var_info_ptr}) = TCE_Var var_info_ptr */ -expressionToTypeCodeExpression expr = abort ("expressionToTypeCodeExpression (overloading.icl)" <<- expr) +expressionToTypeCodeExpression expr = abort "expressionToTypeCodeExpression (overloading.icl)" // <<- expr) generateClassSelection address last_selectors = mapAppend (\(off_set,selector) -> RecordSelection selector off_set) address last_selectors @@ -1170,11 +1169,10 @@ where get_recursive_fun_index :: !Index !SymbKind Int !{# FunDef} -> Index get_recursive_fun_index group_index (SK_Function {glob_module,glob_object}) main_dcl_module_n fun_defs -// | glob_module == cIclModIndex | glob_module == main_dcl_module_n - # {fun_info, fun_index} = fun_defs.[glob_object] + # {fun_info,fun_index} = fun_defs.[glob_object] | fun_info.fi_group_index == group_index - = fun_index + = fun_index = NoIndex = NoIndex get_recursive_fun_index group_index _ main_dcl_module_n fun_defs diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 9110509..16ef220 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -100,8 +100,6 @@ where get_file_and_line_nr (LinePos filename linenr) = (filename, linenr, No) -class collectFunctions a :: a !*CollectAdmin -> (a, !*CollectAdmin) - addFunctionsRange :: [FunDef] *CollectAdmin -> (IndexRange, *CollectAdmin) addFunctionsRange fun_defs ca # (frm, ca) @@ -118,197 +116,248 @@ addFunctionsRange fun_defs ca , ca_rev_fun_defs = [fun_def : ca.ca_rev_fun_defs] } +class collectFunctions a :: a Bool !*CollectAdmin -> (a, !*CollectAdmin) + instance collectFunctions ParsedExpr where - collectFunctions (PE_List exprs) ca - # (exprs, ca) = collectFunctions exprs ca + collectFunctions (PE_List exprs) icl_module ca + # (exprs, ca) = collectFunctions exprs icl_module ca = (PE_List exprs, ca) - collectFunctions (PE_Bound bound_expr) ca - # (bound_expr, ca) = collectFunctions bound_expr ca + collectFunctions (PE_Bound bound_expr) icl_module ca + # (bound_expr, ca) = collectFunctions bound_expr icl_module ca = (PE_Bound bound_expr, ca) - collectFunctions (PE_Lambda lam_ident args res pos) ca - # ((args,res), ca) = collectFunctions (args,res) ca - # (range, ca) = addFunctionsRange [transformLambda lam_ident args res pos] ca + collectFunctions (PE_Lambda lam_ident args res pos) icl_module ca + # ((args,res), ca) = collectFunctions (args,res) icl_module ca + # (range, ca) = addFunctionsRange [transformLambda lam_ident args res pos icl_module] ca = (PE_Let cIsStrict (CollectedLocalDefs { loc_functions = range, loc_nodes = [] }) (PE_Ident lam_ident), ca) - collectFunctions (PE_Record rec_expr type_name fields) ca - # ((rec_expr,fields), ca) = collectFunctions (rec_expr,fields) ca + collectFunctions (PE_Record rec_expr type_name fields) icl_module ca + # ((rec_expr,fields), ca) = collectFunctions (rec_expr,fields) icl_module ca = (PE_Record rec_expr type_name fields, ca) - collectFunctions (PE_Tuple exprs) ca - # (exprs, ca) = collectFunctions exprs ca + collectFunctions (PE_Tuple exprs) icl_module ca + # (exprs, ca) = collectFunctions exprs icl_module ca = (PE_Tuple exprs, ca) - collectFunctions (PE_Selection is_unique expr selectors) ca - # ((expr, selectors), ca) = collectFunctions (expr, selectors) ca + collectFunctions (PE_Selection is_unique expr selectors) icl_module ca + # ((expr, selectors), ca) = collectFunctions (expr, selectors) icl_module ca = (PE_Selection is_unique expr selectors, ca) - collectFunctions (PE_Update expr1 updates expr2) ca - # ((expr1, (updates, expr2)), ca) = collectFunctions (expr1, (updates, expr2)) ca + collectFunctions (PE_Update expr1 updates expr2) icl_module ca + # ((expr1, (updates, expr2)), ca) = collectFunctions (expr1, (updates, expr2)) icl_module ca = (PE_Update expr1 updates expr2, ca) - collectFunctions (PE_Case case_ident pattern_expr case_alts) ca - # ((pattern_expr,case_alts), ca) = collectFunctions (pattern_expr,case_alts) ca + collectFunctions (PE_Case case_ident pattern_expr case_alts) icl_module ca + # ((pattern_expr,case_alts), ca) = collectFunctions (pattern_expr,case_alts) icl_module ca = (PE_Case case_ident pattern_expr case_alts, ca) - collectFunctions (PE_If if_ident c t e) ca + collectFunctions (PE_If if_ident c t e) icl_module ca # true_pattern = PE_Basic (BVB True) false_pattern = PE_WildCard // PE_Basic (BVB False) = collectFunctions (PE_Case if_ident c [ {calt_pattern = true_pattern , calt_rhs = exprToRhs t} , {calt_pattern = false_pattern, calt_rhs = exprToRhs e} - ]) ca - collectFunctions (PE_Let strict locals in_expr) ca - # ((node_defs,in_expr), ca) = collectFunctions (locals,in_expr) ca + ]) icl_module ca + collectFunctions (PE_Let strict locals in_expr) icl_module ca + # ((node_defs,in_expr), ca) = collectFunctions (locals,in_expr) icl_module ca = (PE_Let strict node_defs in_expr, ca) - collectFunctions (PE_Compr gen_kind expr qualifiers) ca + collectFunctions (PE_Compr gen_kind expr qualifiers) icl_module ca # (compr, ca) = transformComprehension gen_kind expr qualifiers ca - = collectFunctions compr ca - collectFunctions (PE_UpdateComprehension expr updateExpr identExpr qualifiers) ca + = collectFunctions compr icl_module ca + collectFunctions (PE_UpdateComprehension expr updateExpr identExpr qualifiers) icl_module ca # (compr, ca) = transformUpdateComprehension expr updateExpr identExpr qualifiers ca - = collectFunctions compr ca - collectFunctions (PE_Sequ sequence) ca=:{ca_predefs} - = collectFunctions (transformSequence sequence ca_predefs) ca - collectFunctions (PE_ArrayDenot exprs) ca=:{ca_predefs} - = collectFunctions (transformArrayDenot exprs ca_predefs) ca - collectFunctions (PE_Dynamic exprs opt_dyn_type) ca - # (exprs, ca) = collectFunctions exprs ca + = collectFunctions compr icl_module ca + collectFunctions (PE_Sequ sequence) icl_module ca=:{ca_predefs} + = collectFunctions (transformSequence sequence ca_predefs) icl_module ca + collectFunctions (PE_ArrayDenot exprs) icl_module ca=:{ca_predefs} + = collectFunctions (transformArrayDenot exprs ca_predefs) icl_module ca + collectFunctions (PE_Dynamic exprs opt_dyn_type) icl_module ca + # (exprs, ca) = collectFunctions exprs icl_module ca = (PE_Dynamic exprs opt_dyn_type, ca) - collectFunctions expr ca + collectFunctions expr icl_module ca = (expr, ca) instance collectFunctions [a] | collectFunctions a where - collectFunctions l ca - = mapSt collectFunctions l ca + collectFunctions l icl_module ca +// = mapSt collectFunctions l icl_module ca + = map_st l ca + where + map_st [x : xs] s + # (x, s) = collectFunctions x icl_module s + (xs, s) = map_st xs s + #! s = s + = ([x : xs], s) + map_st [] s + = ([], s) instance collectFunctions (a,b) | collectFunctions a & collectFunctions b where - collectFunctions (x,y) ca - # (x, ca) = collectFunctions x ca - (y, ca) = collectFunctions y ca + collectFunctions (x,y) icl_module ca + # (x, ca) = collectFunctions x icl_module ca + (y, ca) = collectFunctions y icl_module ca = ((x,y), ca) instance collectFunctions Qualifier where - collectFunctions qual=:{qual_generators, qual_filter} ca - # ((qual_generators, qual_filter), ca) = collectFunctions (qual_generators, qual_filter) ca + collectFunctions qual=:{qual_generators, qual_filter} icl_module ca + # ((qual_generators, qual_filter), ca) = collectFunctions (qual_generators, qual_filter) icl_module ca = ({ qual & qual_generators = qual_generators, qual_filter = qual_filter }, ca) instance collectFunctions Generator where - collectFunctions gen=:{gen_pattern,gen_expr} ca - # ((gen_pattern,gen_expr), ca) = collectFunctions (gen_pattern,gen_expr) ca + collectFunctions gen=:{gen_pattern,gen_expr} icl_module ca + # ((gen_pattern,gen_expr), ca) = collectFunctions (gen_pattern,gen_expr) icl_module ca = ({gen & gen_pattern = gen_pattern, gen_expr = gen_expr}, ca) instance collectFunctions (Optional a) | collectFunctions a where - collectFunctions (Yes expr) ca - # (expr, ca) = collectFunctions expr ca + collectFunctions (Yes expr) icl_module ca + # (expr, ca) = collectFunctions expr icl_module ca = (Yes expr, ca) - collectFunctions No ca + collectFunctions No icl_module ca = (No, ca) instance collectFunctions ParsedSelection where - collectFunctions (PS_Array index_expr) ca - # (index_expr, ca) = collectFunctions index_expr ca + collectFunctions (PS_Array index_expr) icl_module ca + # (index_expr, ca) = collectFunctions index_expr icl_module ca = (PS_Array index_expr, ca) - collectFunctions expr ca + collectFunctions expr icl_module ca = (expr, ca) instance collectFunctions CaseAlt where - collectFunctions calt=:{calt_pattern,calt_rhs} ca - # ((calt_pattern,calt_rhs), ca) = collectFunctions (calt_pattern,calt_rhs) ca + collectFunctions calt=:{calt_pattern,calt_rhs} icl_module ca + # ((calt_pattern,calt_rhs), ca) = collectFunctions (calt_pattern,calt_rhs) icl_module ca = ({calt & calt_pattern = calt_pattern, calt_rhs = calt_rhs}, ca) instance collectFunctions (Bind a b) | collectFunctions a & collectFunctions b where - collectFunctions bind=:{bind_src,bind_dst} ca - # ((bind_src,bind_dst), ca) = collectFunctions (bind_src,bind_dst) ca + collectFunctions bind=:{bind_src,bind_dst} icl_module ca + # ((bind_src,bind_dst), ca) = collectFunctions (bind_src,bind_dst) icl_module ca = ({bind & bind_src = bind_src, bind_dst = bind_dst }, ca) instance collectFunctions OptGuardedAlts where - collectFunctions (GuardedAlts guarded_exprs (Yes def_expr)) ca - # ((guarded_exprs, def_expr), ca) = collectFunctions (guarded_exprs, def_expr) ca + collectFunctions (GuardedAlts guarded_exprs (Yes def_expr)) icl_module ca + # ((guarded_exprs, def_expr), ca) = collectFunctions (guarded_exprs, def_expr) icl_module ca = (GuardedAlts guarded_exprs (Yes def_expr), ca) - collectFunctions (GuardedAlts guarded_exprs No) ca - # (guarded_exprs, ca) = collectFunctions guarded_exprs ca + collectFunctions (GuardedAlts guarded_exprs No) icl_module ca + # (guarded_exprs, ca) = collectFunctions guarded_exprs icl_module ca = (GuardedAlts guarded_exprs No, ca) - collectFunctions (UnGuardedExpr unguarded_expr) ca - # (unguarded_expr, ca) = collectFunctions unguarded_expr ca + collectFunctions (UnGuardedExpr unguarded_expr) icl_module ca + # (unguarded_expr, ca) = collectFunctions unguarded_expr icl_module ca = (UnGuardedExpr unguarded_expr, ca) instance collectFunctions GuardedExpr where - collectFunctions alt=:{alt_nodes,alt_guard,alt_expr} ca + collectFunctions alt=:{alt_nodes,alt_guard,alt_expr} icl_module ca # ((alt_nodes, (alt_guard, alt_expr)), ca) = - collectFunctions (alt_nodes, (alt_guard, alt_expr)) ca + collectFunctions (alt_nodes, (alt_guard, alt_expr)) icl_module ca = ({alt & alt_nodes = alt_nodes, alt_guard = alt_guard, alt_expr = alt_expr}, ca) instance collectFunctions ExprWithLocalDefs where - collectFunctions expr=:{ewl_nodes, ewl_expr,ewl_locals} ca - # ((ewl_nodes, (ewl_expr, ewl_locals)), ca) = collectFunctions (ewl_nodes, (ewl_expr, ewl_locals)) ca + collectFunctions expr=:{ewl_nodes, ewl_expr,ewl_locals} icl_module ca + # ((ewl_nodes, (ewl_expr, ewl_locals)), ca) = collectFunctions (ewl_nodes, (ewl_expr, ewl_locals)) icl_module ca = ({expr & ewl_nodes = ewl_nodes, ewl_expr = ewl_expr, ewl_locals = ewl_locals}, ca) instance collectFunctions NodeDefWithLocals where - collectFunctions node_def=:{ndwl_def, ndwl_locals} ca - # (( ndwl_def, ndwl_locals), ca) = collectFunctions (ndwl_def, ndwl_locals) ca + collectFunctions node_def=:{ndwl_def, ndwl_locals} icl_module ca + # (( ndwl_def, ndwl_locals), ca) = collectFunctions (ndwl_def, ndwl_locals) icl_module ca = ({node_def & ndwl_def = ndwl_def, ndwl_locals = ndwl_locals}, ca) instance collectFunctions Rhs where - collectFunctions {rhs_alts, rhs_locals} ca - # ((rhs_alts, rhs_locals), ca) = collectFunctions (rhs_alts, rhs_locals) ca + collectFunctions {rhs_alts, rhs_locals} icl_module ca + # ((rhs_alts, rhs_locals), ca) = collectFunctions (rhs_alts, rhs_locals) icl_module ca = ({rhs_alts = rhs_alts, rhs_locals = rhs_locals}, ca) instance collectFunctions LocalDefs where - collectFunctions (LocalParsedDefs locals) ca + collectFunctions (LocalParsedDefs locals) icl_module ca # (fun_defs, node_defs, ca) = reorganiseLocalDefinitions locals ca (node_defs, ca) = collect_functions_in_node_defs node_defs ca - (fun_defs, ca) = collectFunctions fun_defs ca + (fun_defs, ca) = collectFunctions fun_defs icl_module ca (range, ca) = addFunctionsRange fun_defs ca = (CollectedLocalDefs { loc_functions = range, loc_nodes = node_defs }, ca) where + reorganiseLocalDefinitions :: [ParsedDefinition] *CollectAdmin -> ([FunDef],[(Optional SymbolType,NodeDef ParsedExpr)],*CollectAdmin) + reorganiseLocalDefinitions [PD_NodeDef pos pattern {rhs_alts,rhs_locals} : defs] ca + # (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca + = (fun_defs, [(No, { nd_dst = pattern, nd_alts = rhs_alts, nd_locals = rhs_locals, nd_position = pos }) : node_defs], ca) + reorganiseLocalDefinitions [PD_Function pos name is_infix args rhs fun_kind : defs] ca + # prio = if is_infix (Prio NoAssoc 9) NoPrio + fun_arity = length args + (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca + (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca + fun = MakeNewImpOrDefFunction icl_module name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies ] fun_kind prio No pos + = ([ fun : fun_defs ], node_defs, ca) + reorganiseLocalDefinitions [PD_TypeSpec pos1 name1 prio type specials : defs] ca + = case defs of + [PD_Function pos name is_infix args rhs fun_kind : _] + | belongsToTypeSpec name1 prio name is_infix + # fun_arity = determineArity args type + # (bodies, fun_kind, defs, ca) = collectFunctionBodies name1 fun_arity prio fun_kind defs ca + (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca + fun = MakeNewImpOrDefFunction icl_module name fun_arity bodies fun_kind prio type pos + -> ([fun : fun_defs], node_defs, ca) + -> reorganiseLocalDefinitions defs (postParseError pos "function body expected" ca) + [PD_NodeDef pos pattern=:(PE_Ident id) {rhs_alts,rhs_locals} : defs] + | belongsToTypeSpec name1 prio id False + # (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca + -> (fun_defs, [(type, { nd_dst = pattern, nd_alts = rhs_alts, nd_locals = rhs_locals, nd_position = pos }) : node_defs], ca) + -> reorganiseLocalDefinitions defs (postParseError pos "function body expected" ca) + _ + -> reorganiseLocalDefinitions defs (postParseError pos1 "function body expected" ca) + reorganiseLocalDefinitions [] ca + = ([], [], ca) + collect_functions_in_node_defs :: [(Optional SymbolType,NodeDef ParsedExpr)] *CollectAdmin -> ([(Optional SymbolType,NodeDef ParsedExpr)],*CollectAdmin) collect_functions_in_node_defs [ (node_def_type, bind) : node_defs ] ca - # (bind, ca) = collectFunctions bind ca + # (bind, ca) = collectFunctions bind icl_module ca (node_defs, ca) = collect_functions_in_node_defs node_defs ca = ([(node_def_type, bind):node_defs], ca) collect_functions_in_node_defs [] ca = ([], ca) // RWS ... +++ remove recollection - collectFunctions locals ca + collectFunctions locals icl_module ca = (locals, ca) // ... RWS instance collectFunctions (NodeDef a) | collectFunctions a where - collectFunctions node_def=:{nd_dst,nd_alts,nd_locals} ca - # ((nd_dst,(nd_alts,nd_locals)), ca) = collectFunctions (nd_dst,(nd_alts,nd_locals)) ca + collectFunctions node_def=:{nd_dst,nd_alts,nd_locals} icl_module ca + # ((nd_dst,(nd_alts,nd_locals)), ca) = collectFunctions (nd_dst,(nd_alts,nd_locals)) icl_module ca = ({ node_def & nd_dst = nd_dst, nd_alts = nd_alts, nd_locals = nd_locals }, ca) instance collectFunctions Ident where - collectFunctions e ca + 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 + = ({inst & pi_members = pi_members }, ca) + +instance collectFunctions FunDef where + collectFunctions fun_def=:{fun_body = ParsedBody bodies} icl_module ca + # (bodies, ca) = collectFunctions bodies icl_module ca + = ({fun_def & fun_body = ParsedBody bodies}, ca) + +instance collectFunctions ParsedBody where + collectFunctions pb=:{pb_rhs} icl_module ca + # (pb_rhs, ca) = collectFunctions pb_rhs icl_module ca + = ({ pb & pb_rhs = pb_rhs }, ca) + NoCollectedLocalDefs :== CollectedLocalDefs { loc_functions = { ir_from = 0, ir_to = 0 }, loc_nodes = [] } -// MW was:transformLambda :: Ident [ParsedExpr] ParsedExpr -> FunDef -transformLambda :: Ident [ParsedExpr] ParsedExpr Position -> FunDef -// MW was:transformLambda lam_ident args result -transformLambda lam_ident args result pos - # lam_rhs = { rhs_alts = UnGuardedExpr { ewl_nodes = [], ewl_expr = result, ewl_locals = NoCollectedLocalDefs, - ewl_position = NoPos }, - rhs_locals = NoCollectedLocalDefs } -// MW4 was: lam_body = [{pb_args = args, pb_rhs = lam_rhs }] +transformLambda :: Ident [ParsedExpr] ParsedExpr Position Bool -> FunDef +transformLambda lam_ident args result pos icl_module + # lam_rhs = { rhs_alts = UnGuardedExpr { ewl_nodes = [], ewl_expr = result, ewl_locals = NoCollectedLocalDefs, ewl_position = NoPos }, + rhs_locals = NoCollectedLocalDefs } lam_body = [{pb_args = args, pb_rhs = lam_rhs, pb_position = pos }] -// MW was: fun_def = MakeNewFunction lam_ident (length args) lam_body (FK_Function cNameLocationDependent) NoPrio No NoPos - fun_def = MakeNewFunction lam_ident (length args) lam_body (FK_Function cNameLocationDependent) NoPrio No pos - = fun_def + = MakeNewImpOrDefFunction icl_module lam_ident (length args) lam_body (FK_Function cNameLocationDependent) NoPrio No pos makeNilExpression :: *CollectAdmin -> (ParsedExpr,*CollectAdmin) makeNilExpression ca=:{ca_predefs} @@ -427,7 +476,6 @@ transformQualifier {qual_generators, qual_filter, qual_position, qual_filename} // =array&callArray are misnomers (can also be records) transformUpdateQualifier :: ParsedExpr ParsedExpr Qualifier *CollectAdmin -> (TransformedQualifier, *CollectAdmin) -//MW3 was:transformUpdateQualifier array callArray {qual_generators, qual_filter, qual_position} ca transformUpdateQualifier array callArray {qual_generators, qual_filter, qual_position, qual_filename} ca # (transformedGenerators, ca) = mapSt transformGenerator qual_generators ca @@ -473,7 +521,6 @@ transformComprehension gen_kind expr qualifiers ca (create_array, ca) = get_predef_id PD__CreateArrayFun ca (length, ca) -//MW3 was: = computeLength qualifiers qual_position ca = computeLength qualifiers qual_position hd_qualifier.qual_filename ca new_array = PE_List [PE_Ident create_array, length] @@ -483,8 +530,6 @@ transformComprehension gen_kind expr qualifiers ca = [{hd_qualifier & qual_generators = [index_generator : hd_qualifier.qual_generators] } : tl_qualifiers] = transformUpdateComprehension new_array update (PE_Ident c_a) qualifiers ca -//MW3 was:computeLength :: [Qualifier] LineAndColumn *CollectAdmin -> (ParsedExpr, *CollectAdmin) -//MW3 was:computeLength qualifiers qual_position ca computeLength :: [Qualifier] LineAndColumn FileName *CollectAdmin -> (ParsedExpr, *CollectAdmin) computeLength qualifiers qual_position qual_filename ca # (fun_ident, ca) @@ -500,12 +545,6 @@ computeLength qualifiers qual_position qual_filename ca (inc, ca) = get_predef_id PD_IncFun ca new_fun_pos = LinePos qual_filename qual_position.lc_line // MW3++ -/* MW3 was - parsedFunction1 - = MakeNewParsedDef fun_ident [cons, PE_Ident i_ident] (exprToRhs (PE_List [PE_Ident fun_ident, PE_Ident tail_ident, PE_List [PE_Ident inc, PE_Ident i_ident]])) - parsedFunction2 - = MakeNewParsedDef fun_ident [PE_WildCard, PE_Ident i_ident] (exprToRhs (PE_Ident i_ident)) -*/ parsedFunction1 = MakeNewParsedDef fun_ident [cons, PE_Ident i_ident] (exprToRhs (PE_List [PE_Ident fun_ident, PE_Ident tail_ident, PE_List [PE_Ident inc, PE_Ident i_ident]])) @@ -708,7 +747,7 @@ where # (_, defs, imports, imported_objects, ca) = reorganiseDefinitions False pdefs 0 0 0 ca (macro_defs, ca) - = collectFunctions defs.def_macros ca + = collectFunctions defs.def_macros False ca (range, ca) = addFunctionsRange macro_defs ca (pea_ok,ca) @@ -748,11 +787,11 @@ scanModule mod=:{mod_name,mod_type,mod_defs = pdefs} cached_modules first_new_fu ca = {ca & ca_hash_table=set_hte_mark 1 ca.ca_hash_table} - (fun_defs, ca) = collectFunctions fun_defs ca + (fun_defs, ca) = collectFunctions fun_defs True ca (fun_range, ca) = addFunctionsRange fun_defs ca - (macro_defs, ca) = collectFunctions defs.def_macros ca + (macro_defs, ca) = collectFunctions defs.def_macros True ca (macro_range, ca) = addFunctionsRange macro_defs ca - (def_instances, ca) = collectFunctions defs.def_instances ca + (def_instances, ca) = collectFunctions defs.def_instances True ca ca = {ca & ca_hash_table=set_hte_mark 0 ca.ca_hash_table} @@ -796,7 +835,7 @@ where = (import_ok, Yes mod, NoIndex,parsed_modules, cached_modules,files, ca) collect_main_dcl_module (Yes mod=:{mod_defs=defs}) dcl_module_n ca - # (macro_defs, ca) = collectFunctions defs.def_macros ca + # (macro_defs, ca) = collectFunctions defs.def_macros False ca (range, ca) = addFunctionsRange macro_defs ca (pea_ok,ca) = ca!ca_error.pea_ok mod = { mod & mod_defs = { defs & def_macros = range }} @@ -806,25 +845,21 @@ where = (True,Yes (MakeEmptyModule mod_name),ca) = (True,No,ca) -instance collectFunctions (ParsedInstance a) | collectFunctions a where - collectFunctions inst=:{pi_members} ca - # (pi_members, ca) = collectFunctions pi_members ca - = ({inst & pi_members = pi_members }, ca) - -instance collectFunctions FunDef where - collectFunctions fun_def=:{fun_body = ParsedBody bodies} ca - # (bodies, ca) = collectFunctions bodies ca - = ({fun_def & fun_body = ParsedBody bodies}, ca) - -instance collectFunctions ParsedBody where - collectFunctions pb=:{pb_rhs} ca - # (pb_rhs, ca) = collectFunctions pb_rhs ca - = ({ pb & pb_rhs = pb_rhs }, ca) - -MakeNewFunction name arity body kind prio opt_type pos - :== { fun_symb = name, fun_arity = arity, fun_priority = prio, fun_type = opt_type, fun_kind = kind, +MakeNewImpOrDefFunction icl_module name arity body kind prio opt_type pos + :== { fun_symb = name, fun_arity = arity, fun_priority = prio, fun_type = opt_type, fun_kind = fun_kind_to_def_or_imp_fun_kind icl_module kind, fun_body = ParsedBody body, fun_pos = pos, fun_lifted = 0, fun_index = NoIndex, fun_info = EmptyFunInfo } +fun_kind_to_def_or_imp_fun_kind icl_module (FK_Function b) + | icl_module + = FK_ImpFunction b + = FK_DefFunction b +fun_kind_to_def_or_imp_fun_kind icl_module FK_Macro + | icl_module + = FK_ImpMacro + = FK_DefMacro +fun_kind_to_def_or_imp_fun_kind icl_module FK_Caf = FK_ImpCaf +fun_kind_to_def_or_imp_fun_kind icl_module FK_Unknown = FK_DefOrImpUnknown + /* MW3 was // +++ position MakeNewParsedDef ident args rhs @@ -862,15 +897,13 @@ collectFunctionBodies fun_name fun_arity fun_prio fun_kind all_defs=:[PD_Functio collectFunctionBodies fun_name fun_arity fun_prio fun_kind defs ca = ([], fun_kind, defs, ca) -//reorganiseDefinitions :: Bool [ParsedDefinition] Index Index Index *CollectAdmin -> ([FunDef],CollectedDefinitions (ParsedInstance FunDef) [FunDef], [ParsedImport], [ImportedObject], *CollectAdmin) reorganiseDefinitions :: Bool [ParsedDefinition] Index Index Index *CollectAdmin -> (![FunDef],!CollectedDefinitions (ParsedInstance FunDef) [FunDef], ![ParsedImport], ![ImportedObject], !*CollectAdmin) reorganiseDefinitions icl_module [PD_Function pos name is_infix args rhs fun_kind : defs] cons_count sel_count mem_count ca # prio = if is_infix (Prio NoAssoc 9) NoPrio fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca -// MW4 was: fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies] fun_kind prio No pos - fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies] fun_kind prio No pos + fun = MakeNewImpOrDefFunction icl_module name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies] fun_kind prio No pos | fun_kind == FK_Macro = (fun_defs, { c_defs & def_macros = [ fun : c_defs.def_macros ]}, imports, imported_objects, ca) = ([ fun : fun_defs ], c_defs, imports, imported_objects, ca) @@ -885,8 +918,7 @@ reorganiseDefinitions icl_module [PD_TypeSpec fun_pos fun_name prio No specials # fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca -// MW4 was: fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos - fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies ] fun_kind prio No pos + fun = MakeNewImpOrDefFunction icl_module name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies ] fun_kind prio No pos | fun_kind == FK_Macro -> (fun_defs, { c_defs & def_macros = [ fun : c_defs.def_macros]}, imports, imported_objects, ca) -> ([ fun : fun_defs ], c_defs, imports, imported_objects, ca) @@ -902,7 +934,7 @@ reorganiseDefinitions icl_module [PD_TypeSpec pos name prio (Yes fun_type=:{st_a | icl_module = (fun_defs, c_defs, imports, imported_objects, postParseError pos "function body expected" ca) = (fun_defs, c_defs, imports, imported_objects, ca) - # fun = MakeNewFunction name fun_type.st_arity bodies fun_kind prio (Yes fun_type) pos + # fun = MakeNewImpOrDefFunction icl_module name fun_type.st_arity bodies fun_kind prio (Yes fun_type) pos | icl_module = ([fun : fun_defs], c_defs, imports, imported_objects, ca) = ([fun : fun_defs], c_defs, imports, imported_objects, postParseError pos "function body not allowed in definition module" ca) @@ -969,7 +1001,7 @@ where me_offset = NoIndex, me_class_vars = [], me_class = { glob_module = NoIndex, glob_object = NoIndex}, me_type_ptr = nilPtr } ( mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca = ([mem_def : mem_defs], mem_macros, ca) - # macro = MakeNewFunction name st_arity bodies FK_Macro prio opt_type pos + # macro = MakeNewImpOrDefFunction icl_module name st_arity bodies FK_Macro prio opt_type pos (mem_defs, mem_macros,ca) = check_symbols_of_class_members defs type_context ca = (mem_defs, [macro : mem_macros], ca) check_symbols_of_class_members [PD_TypeSpec fun_pos fun_name prio No specials : defs] type_context ca @@ -979,7 +1011,7 @@ where # fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca (mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca - macro = MakeNewFunction name fun_arity bodies FK_Macro prio No pos + macro = MakeNewImpOrDefFunction icl_module name fun_arity bodies FK_Macro prio No pos -> (mem_defs, [macro : mem_macros], ca) -> check_symbols_of_class_members defs type_context (postParseError fun_pos "macro body expected" ca) _ @@ -989,8 +1021,7 @@ where fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca (mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca -// MW4 was: macro = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies] FK_Macro prio No fun_pos - macro = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = fun_pos } : bodies] FK_Macro prio No fun_pos + macro = MakeNewImpOrDefFunction icl_module name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = fun_pos } : bodies] FK_Macro prio No fun_pos = (mem_defs, [macro : mem_macros], ca) check_symbols_of_class_members [def : _] type_context ca = abort "postparse.check_symbols_of_class_members: unknown def" // <<- def @@ -1024,8 +1055,7 @@ where prio = if is_infix (Prio NoAssoc 9) NoPrio (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca (fun_defs, ca) = collect_member_instances defs ca -// MW4 was: fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos - fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies ] fun_kind prio No pos + fun = MakeNewImpOrDefFunction icl_module name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies ] fun_kind prio No pos = ([ fun : fun_defs ], ca) collect_member_instances [PD_TypeSpec fun_pos fun_name prio type specials : defs] ca = case defs of @@ -1034,7 +1064,7 @@ where # fun_arity = determineArity args type (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca (fun_defs, ca) = collect_member_instances defs ca - fun = MakeNewFunction name fun_arity bodies fun_kind prio type pos + fun = MakeNewImpOrDefFunction icl_module name fun_arity bodies fun_kind prio type pos -> ([ fun : fun_defs ], ca) _ -> collect_member_instances defs (postParseError fun_pos "function body expected" ca) @@ -1055,38 +1085,6 @@ reorganiseDefinitions icl_module [] _ _ _ ca = ([], { def_types = [], def_constructors = [], def_selectors = [], def_macros = [], def_classes = [], def_members = [], def_instances = [], def_funtypes = [] }, [], [], ca) -reorganiseLocalDefinitions :: [ParsedDefinition] *CollectAdmin -> ([FunDef],[(Optional SymbolType,NodeDef ParsedExpr)],*CollectAdmin) -reorganiseLocalDefinitions [PD_NodeDef pos pattern {rhs_alts,rhs_locals} : defs] ca - # (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca - = (fun_defs, [(No, { nd_dst = pattern, nd_alts = rhs_alts, nd_locals = rhs_locals, nd_position = pos }) : node_defs], ca) -reorganiseLocalDefinitions [PD_Function pos name is_infix args rhs fun_kind : defs] ca - # prio = if is_infix (Prio NoAssoc 9) NoPrio - fun_arity = length args - (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca - (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca -// MW4 was: fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos - fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies ] fun_kind prio No pos - = ([ fun : fun_defs ], node_defs, ca) -reorganiseLocalDefinitions [PD_TypeSpec pos1 name1 prio type specials : defs] ca - = case defs of - [PD_Function pos name is_infix args rhs fun_kind : _] - | belongsToTypeSpec name1 prio name is_infix - # fun_arity = determineArity args type - # (bodies, fun_kind, defs, ca) = collectFunctionBodies name1 fun_arity prio fun_kind defs ca - (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca - fun = MakeNewFunction name fun_arity bodies fun_kind prio type pos - -> ([fun : fun_defs], node_defs, ca) - -> reorganiseLocalDefinitions defs (postParseError pos "function body expected" ca) - [PD_NodeDef pos pattern=:(PE_Ident id) {rhs_alts,rhs_locals} : defs] - | belongsToTypeSpec name1 prio id False - # (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca - -> (fun_defs, [(type, { nd_dst = pattern, nd_alts = rhs_alts, nd_locals = rhs_locals, nd_position = pos }) : node_defs], ca) - -> reorganiseLocalDefinitions defs (postParseError pos "function body expected" ca) - _ - -> reorganiseLocalDefinitions defs (postParseError pos1 "function body expected" ca) -reorganiseLocalDefinitions [] ca - = ([], [], ca) - belongsToTypeSpec name prio new_name is_infix :== name == new_name && sameFixity prio is_infix diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 57465ba..3cbb47a 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -135,7 +135,10 @@ cIsNotAFunction :== False | PD_ImportedObjects [ImportedObject] | PD_Erroneous -:: FunKind = FK_Function !Bool | FK_Macro | FK_Caf | FK_Unknown +:: FunKind = FK_Function !Bool | FK_Macro | FK_Caf | FK_Unknown + +:: DefOrImpFunKind = FK_DefFunction !Bool| FK_ImpFunction !Bool | FK_DefMacro | FK_ImpMacro | FK_ImpCaf | FK_DefOrImpUnknown + cNameNotLocationDependent :== False cNameLocationDependent :== True @@ -419,7 +422,7 @@ cIsNonCoercible :== 2 , fun_type :: !Optional SymbolType , fun_pos :: !Position , fun_index :: !Int - , fun_kind :: !FunKind + , fun_kind :: !DefOrImpFunKind , fun_lifted :: !Int // , fun_type_ptr :: !TypeVarInfoPtr , fun_info :: !FunInfo @@ -545,8 +548,6 @@ cNonRecursiveAppl :== False | SK_GeneratedFunction !FunctionInfoPtr !Index | SK_TypeCode -// MW2 moved some type definitions - /* Some auxiliary type definitions used during fusion. Actually, these definitions should have been given in seperate module. Unfortunately, Clean's module system forbids cyclic dependencies between def modules. diff --git a/frontend/syntax.icl b/frontend/syntax.icl index ba2056d..0738d89 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -1,8 +1,6 @@ implementation module syntax -import StdEnv, compare_constructor - -import RWSDebug +import StdEnv, compare_constructor // ,RWSDebug import scanner, general, Heap, typeproperties, utilities @@ -76,7 +74,6 @@ where toString {import_module} = toString import_module :: ParsedModule :== Module [ParsedDefinition] :: ScannedModule :== Module (CollectedDefinitions (ParsedInstance FunDef) IndexRange) - :: ModuleKind = MK_Main | MK_Module | MK_System | MK_None :: RhsDefsOfType = ConsList ![ParsedConstructor] @@ -84,7 +81,6 @@ where toString {import_module} = toString import_module | TypeSpec !AType | EmptyRhs !BITVECT - :: CollectedDefinitions instance_kind macro_defs = { def_types :: ![TypeDef TypeRhs] , def_constructors :: ![ConsDef] @@ -140,6 +136,9 @@ cIsNotAFunction :== False | PD_Erroneous :: FunKind = FK_Function !Bool | FK_Macro | FK_Caf | FK_Unknown + +:: DefOrImpFunKind = FK_DefFunction !Bool| FK_ImpFunction !Bool | FK_DefMacro | FK_ImpMacro | FK_ImpCaf | FK_DefOrImpUnknown + cNameNotLocationDependent :== False cNameLocationDependent :== True @@ -269,8 +268,6 @@ cNameLocationDependent :== True | ID_Record !ImportedIdent !(Optional [ImportedIdent]) | ID_Instance !ImportedIdent !Ident !(![Type],![TypeContext]) -// MW2 moved some type definitions - cIsImportedLibrary :== True cIsImportedObject :== False :: ImportedObject = @@ -396,7 +393,7 @@ cMayBeNonCoercible :== 4 , fun_type :: !Optional SymbolType , fun_pos :: !Position , fun_index :: !Int - , fun_kind :: !FunKind + , fun_kind :: !DefOrImpFunKind , fun_lifted :: !Int // , fun_type_ptr :: !TypeVarInfoPtr , fun_info :: !FunInfo @@ -1563,17 +1560,17 @@ where instance <<< FunDef where - (<<<) file {fun_symb,fun_index,fun_body=ParsedBody bodies} = file <<< fun_symb <<< '.' <<< fun_index <<< ' ' <<< bodies - (<<<) file {fun_symb,fun_index,fun_body=CheckedBody {cb_args,cb_rhs},fun_info={fi_free_vars,fi_def_level,fi_calls}} = file <<< fun_symb <<< '.' - <<< fun_index <<< "C " <<< cb_args <<< " = " <<< cb_rhs -// <<< fun_index <<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< cb_args <<< " = " <<< cb_rhs - (<<<) file {fun_symb,fun_index,fun_body=TransformedBody {tb_args,tb_rhs},fun_info={fi_free_vars,fi_def_level,fi_calls}} = file <<< fun_symb <<< '.' - <<< fun_index <<< "T " <<< tb_args <<< '[' <<< fi_calls <<< ']' <<< " = " <<< tb_rhs -// <<< fun_index <<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< tb_args <<< " = " <<< tb_rhs - (<<<) file {fun_symb,fun_index,fun_body=BackendBody body,fun_type=Yes type} = file <<< type <<< '\n' <<< fun_symb <<< '.' - <<< fun_index <<< body <<< '\n' - (<<<) file {fun_symb,fun_index,fun_body=NoBody,fun_type=Yes type} = file <<< type <<< '\n' <<< fun_symb <<< '.' - <<< fun_index <<< "Array function\n" + (<<<) file {fun_symb,fun_body=ParsedBody bodies} = file <<< fun_symb <<< '.' <<< ' ' <<< bodies + (<<<) file {fun_symb,fun_body=CheckedBody {cb_args,cb_rhs},fun_info={fi_free_vars,fi_def_level,fi_calls}} = file <<< fun_symb <<< '.' + <<< "C " <<< cb_args <<< " = " <<< cb_rhs +// <<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< cb_args <<< " = " <<< cb_rhs + (<<<) file {fun_symb,fun_body=TransformedBody {tb_args,tb_rhs},fun_info={fi_free_vars,fi_def_level,fi_calls}} = file <<< fun_symb <<< '.' + <<< "T " <<< tb_args <<< '[' <<< fi_calls <<< ']' <<< " = " <<< tb_rhs +// <<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< tb_args <<< " = " <<< tb_rhs + (<<<) file {fun_symb,fun_body=BackendBody body,fun_type=Yes type} = file <<< type <<< '\n' <<< fun_symb <<< '.' + <<< body <<< '\n' + (<<<) file {fun_symb,fun_body=NoBody,fun_type=Yes type} = file <<< type <<< '\n' <<< fun_symb <<< '.' + <<< "Array function\n" instance <<< FunCall where diff --git a/frontend/trans.icl b/frontend/trans.icl index a4460cb..68c7a9f 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -2,9 +2,7 @@ implementation module trans import StdEnv -import syntax, transform, checksupport, StdCompare, check, utilities - -import RWSDebug +import syntax, transform, checksupport, StdCompare, check, utilities //,RWSDebug :: PartitioningInfo = { pi_marks :: !.{# Int} @@ -693,7 +691,7 @@ instance transform DynamicExpr where = ({dyn & dyn_expr = dyn_expr}, ti) unfold_state_to_ti us ti - :== { ti & ti_var_heap = us.us_var_heap, ti_symbol_heap = us.us_symbol_heap, ti_cleanup_info=us.us_cleanup_info } + :== { ti & ti_var_heap = us.us_var_heap, ti_symbol_heap = us.us_symbol_heap,ti_cleanup_info=us.us_cleanup_info } transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_info_ptr} ro ti | SwitchFusion False True @@ -851,9 +849,9 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf # (guard_expr, ti) = transformCase {outer_case & case_expr = guard_expr} ro ti = ([guard_expr], ti) lift_patterns_2 default_exists [guard_expr : guard_exprs] outer_case ro ti - # us = { us_var_heap = ti.ti_var_heap, us_symbol_heap = ti.ti_symbol_heap, us_opt_type_heaps = No, - us_cleanup_info=ti.ti_cleanup_info, us_handle_aci_free_vars = LeaveThem } - (outer_guards, us=:{us_cleanup_info}) = unfold outer_case.case_guards us + # us = { us_var_heap = ti.ti_var_heap, us_symbol_heap = ti.ti_symbol_heap, us_opt_type_heaps = No,us_cleanup_info=ti.ti_cleanup_info} + ui = {ui_handle_aci_free_vars = LeaveThem, ui_convert_module_n= -1,ui_conversion_table=No } + (outer_guards, us=:{us_cleanup_info}) = unfold outer_case.case_guards ui us (expr_info, ti_symbol_heap) = readPtr outer_case.case_info_ptr us.us_symbol_heap (new_info_ptr, ti_symbol_heap) = newPtr expr_info ti_symbol_heap new_cleanup_info = case expr_info of @@ -884,9 +882,9 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf non_unfoldable_args = filterWith not_unfoldable zipped ti_var_heap = foldSt (\({fv_info_ptr}, arg) -> writeVarInfo fv_info_ptr (VI_Expression arg)) unfoldable_args ti.ti_var_heap (new_expr, ti_symbol_heap) = possibly_add_let non_unfoldable_args ap_expr not_unfoldable glob_module ds_index ro ti.ti_symbol_heap - unfold_state = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = No, - us_cleanup_info=ti.ti_cleanup_info, us_handle_aci_free_vars = LeaveThem } - (unfolded_expr, unfold_state) = unfold new_expr unfold_state + unfold_state = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = No,us_cleanup_info=ti.ti_cleanup_info} + ui= {ui_handle_aci_free_vars = LeaveThem, ui_convert_module_n= -1,ui_conversion_table=No } + (unfolded_expr, unfold_state) = unfold new_expr ui unfold_state (final_expr, ti) = transform unfolded_expr { ro & ro_root_case_mode = NotRootCase } (unfold_state_to_ti unfold_state ti) = (Yes final_expr, ti) = match_and_instantiate linearities cons_index app_args guards case_default ro ti @@ -1002,9 +1000,11 @@ possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti (fresh_arg_types, ti_type_heaps) = substitute arg_types { th_vars = th_vars, th_attrs = th_attrs } (fresh_result_type, ti_type_heaps) = substitute ct_result_type ti_type_heaps us = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = Yes ti_type_heaps, - us_cleanup_info=ti.ti_cleanup_info, us_handle_aci_free_vars = SubstituteThem } + us_cleanup_info=ti.ti_cleanup_info } + ui = {ui_handle_aci_free_vars = SubstituteThem, ui_convert_module_n= -1,ui_conversion_table=No } (copied_expr, {us_var_heap=ti_var_heap, us_symbol_heap=ti_symbol_heap, us_cleanup_info=ti_cleanup_info, - us_opt_type_heaps = Yes ti_type_heaps}) = unfold new_expr us + us_opt_type_heaps = Yes ti_type_heaps}) + = unfold new_expr ui us fun_type = { st_vars = fresh_type_vars, st_args = fresh_arg_types, st_arity = fun_arity, st_result = fresh_result_type, st_context = [], st_attr_vars = [], st_attr_env = [] } fun_def = { fun_symb = ro_fun.symb_name @@ -1014,7 +1014,7 @@ possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti , fun_type = Yes fun_type , fun_pos = NoPos , fun_index = fun_index - , fun_kind = FK_Function cNameNotLocationDependent + , fun_kind = FK_ImpFunction cNameNotLocationDependent , fun_lifted = undeff , fun_info = { fi_calls = [] , fi_group_index = outer_fun_def.fun_info.fi_group_index @@ -1032,8 +1032,8 @@ possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti gf = { gf_fun_def = fun_def, gf_instance_info = II_Empty, gf_cons_args = new_cons_args, gf_fun_index = fun_index} ti_fun_heap = writePtr fun_info_ptr (FI_Function gf) ti.ti_fun_heap ti = { ti & ti_new_functions = [fun_info_ptr:ti.ti_new_functions], ti_var_heap = ti_var_heap, ti_fun_heap = ti_fun_heap, - ti_symbol_heap = ti_symbol_heap, ti_type_heaps = ti_type_heaps, ti_cleanup_info = ti_cleanup_info, - ti_recursion_introduced = old_ti_recursion_introduced } + ti_symbol_heap = ti_symbol_heap, ti_type_heaps = ti_type_heaps, + ti_cleanup_info = ti_cleanup_info, ti_recursion_introduced = old_ti_recursion_introduced } = ( App { app_symb = { ro_fun & symb_kind = SK_GeneratedFunction fun_info_ptr fun_index}, app_args = map free_var_to_bound_var ro_fun_args, app_info_ptr = nilPtr } , ti @@ -1247,14 +1247,15 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi new_fun_type = Yes { st_vars = fresh_type_vars, st_args = fresh_arg_types, st_arity = fun_arity, st_result = fresh_result_type, st_context = [], st_attr_vars = [], st_attr_env = [] } - new_fd_expanding = { fd & fun_body = Expanding new_fun_args, fun_arity = fun_arity,fun_type=new_fun_type, fun_index = ti_next_fun_nr, + new_fd_expanding = { fd & fun_body = Expanding new_fun_args, fun_arity = fun_arity,fun_type=new_fun_type, fun_index=ti_next_fun_nr, fun_info.fi_group_index = fi_group_index} new_gen_fd = { gf_fun_def = new_fd_expanding, gf_instance_info = II_Empty, gf_fun_index = ti_next_fun_nr, gf_cons_args = {cc_args = new_cons_args, cc_size = length new_cons_args, cc_linear_bits=new_linear_bits} } ti_fun_heap = writePtr fun_def_ptr (FI_Function new_gen_fd) ti_fun_heap us = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = Yes ti_type_heaps, - us_cleanup_info=ti_cleanup_info, us_handle_aci_free_vars = RemoveThem } - (tb_rhs, {us_var_heap,us_symbol_heap,us_opt_type_heaps=Yes type_heaps, us_cleanup_info}) = unfold tb_rhs us + us_cleanup_info=ti_cleanup_info } + ui = {ui_handle_aci_free_vars = RemoveThem, ui_convert_module_n= -1,ui_conversion_table=No } + (tb_rhs, {us_var_heap,us_symbol_heap,us_opt_type_heaps=Yes type_heaps, us_cleanup_info}) = unfold tb_rhs ui us ro = { ro & ro_root_case_mode = case tb_rhs of Case _ -> RootCase @@ -1267,7 +1268,7 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi = undef # (new_fun_rhs, ti) = transform tb_rhs ro { ti & ti_var_heap = us_var_heap, ti_fun_heap = ti_fun_heap, ti_symbol_heap = us_symbol_heap, ti_next_fun_nr = inc ti_next_fun_nr, ti_new_functions = [fun_def_ptr : ti_new_functions], - ti_fun_defs = ti_fun_defs, ti_type_heaps = type_heaps, ti_cleanup_info = us_cleanup_info, ti_trace=ti_trace } + ti_type_heaps = type_heaps, ti_fun_defs=ti_fun_defs,ti_cleanup_info = us_cleanup_info, ti_trace=ti_trace } 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)) // = undef diff --git a/frontend/transform.dcl b/frontend/transform.dcl index 299e5f2..1d290a3 100644 --- a/frontend/transform.dcl +++ b/frontend/transform.dcl @@ -15,13 +15,18 @@ partitionateMacros :: !IndexRange !Index !PredefinedSymbol !*{# FunDef} !*{# Dcl :: UnfoldState = { us_var_heap :: !.VarHeap , us_symbol_heap :: !.ExpressionHeap - , us_opt_type_heaps :: !.Optional .TypeHeaps - , us_cleanup_info :: ![ExprInfoPtr] - , us_handle_aci_free_vars :: !AciFreeVarHandleMode + , us_opt_type_heaps :: !.Optional .TypeHeaps, + us_cleanup_info :: ![ExprInfoPtr] } - + +:: UnfoldInfo = + { ui_handle_aci_free_vars :: !AciFreeVarHandleMode, + ui_convert_module_n :: !Int, // -1 if no conversion + ui_conversion_table :: !Optional ConversionTable + } + :: AciFreeVarHandleMode = LeaveThem | RemoveThem | SubstituteThem -class unfold a :: !a !*UnfoldState -> (!a, !*UnfoldState) +class unfold a :: !a !UnfoldInfo !*UnfoldState -> (!a, !*UnfoldState) instance unfold Expression, CasePatterns diff --git a/frontend/transform.icl b/frontend/transform.icl index 56a2d13..3d216b1 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -1,10 +1,9 @@ implementation module transform -import syntax, check, StdCompare, utilities, RWSDebug +import syntax, check, StdCompare, utilities; //, RWSDebug :: LiftState = { ls_var_heap :: !.VarHeap -// , ls_fun_defs :: !.{#FunDef} , ls_x :: !.LiftStateX , ls_expr_heap :: !.ExpressionHeap } @@ -209,30 +208,19 @@ where :: UnfoldState = { us_var_heap :: !.VarHeap , us_symbol_heap :: !.ExpressionHeap - , us_opt_type_heaps :: !.Optional .TypeHeaps - , us_cleanup_info :: ![ExprInfoPtr] - , us_handle_aci_free_vars :: !AciFreeVarHandleMode + , us_opt_type_heaps :: !.Optional .TypeHeaps, + us_cleanup_info :: ![ExprInfoPtr] } - -:: AciFreeVarHandleMode = LeaveThem | RemoveThem | SubstituteThem - -class unfold a :: !a !*UnfoldState -> (!a, !*UnfoldState) -instance unfold [a] | unfold a -where - unfold l us = mapSt unfold l us +:: UnfoldInfo = + { ui_handle_aci_free_vars :: !AciFreeVarHandleMode, + ui_convert_module_n :: !Int, // -1 if no conversion + ui_conversion_table :: !Optional ConversionTable + } -instance unfold (a,b) | unfold a & unfold b -where - unfold t us = app2St (unfold,unfold) t us +:: AciFreeVarHandleMode = LeaveThem | RemoveThem | SubstituteThem -instance unfold (Optional a) | unfold a -where - unfold (Yes x) us - # (x, us) = unfold x us - = (Yes x, us) - unfold no us - = (no, us) +class unfold a :: !a !UnfoldInfo !*UnfoldState -> (!a, !*UnfoldState) unfoldVariable :: !BoundVar !*UnfoldState -> (!Expression, !*UnfoldState) unfoldVariable var=:{var_name,var_info_ptr} us @@ -277,60 +265,59 @@ writeVarInfo var_info_ptr new_var_info var_heap instance unfold Expression where - unfold (Var var) us + unfold (Var var) ui us = unfoldVariable var us - unfold (App app) us - # (app, us) = unfold app us + unfold (App app) ui us + # (app, us) = unfold app ui us = (App app, us) - unfold (expr @ exprs) us - # ((expr,exprs), us) = unfold (expr,exprs) us + unfold (expr @ exprs) ui us + # ((expr,exprs), us) = unfold (expr,exprs) ui us = (expr @ exprs, us) - unfold (Let lad) us - # (lad, us) = unfold lad us + unfold (Let lad) ui us + # (lad, us) = unfold lad ui us = (Let lad, us) - unfold (Case case_expr) us - # (case_expr, us) = unfold case_expr us + unfold (Case case_expr) ui us + # (case_expr, us) = unfold case_expr ui us = (Case case_expr, us) - unfold (Selection is_unique expr selectors) us - # ((expr, selectors), us) = unfold (expr, selectors) us + unfold (Selection is_unique expr selectors) ui us + # ((expr, selectors), us) = unfold (expr, selectors) ui us = (Selection is_unique expr selectors, us) - unfold (Update expr1 selectors expr2) us - # (((expr1, expr2), selectors), us) = unfold ((expr1, expr2), selectors) us + unfold (Update expr1 selectors expr2) ui us + # (((expr1, expr2), selectors), us) = unfold ((expr1, expr2), selectors) ui us = (Update expr1 selectors expr2, us) - unfold (RecordUpdate cons_symbol expression expressions) us - # ((expression, expressions), us) = unfold (expression, expressions) us + unfold (RecordUpdate cons_symbol expression expressions) ui us + # ((expression, expressions), us) = unfold (expression, expressions) ui us = (RecordUpdate cons_symbol expression expressions, us) - unfold (TupleSelect symbol argn_nr expr) us - # (expr, us) = unfold expr us + unfold (TupleSelect symbol argn_nr expr) ui us + # (expr, us) = unfold expr ui us = (TupleSelect symbol argn_nr expr, us) - unfold (Lambda vars expr) us - # (expr, us) = unfold expr us + unfold (Lambda vars expr) ui us + # (expr, us) = unfold expr ui us = (Lambda vars expr, us) - unfold (MatchExpr opt_tuple cons_symb expr) us - # (expr, us) = unfold expr us + unfold (MatchExpr opt_tuple cons_symb expr) ui us + # (expr, us) = unfold expr ui us = (MatchExpr opt_tuple cons_symb expr, us) - unfold (DynamicExpr expr) us - # (expr, us) = unfold expr us + unfold (DynamicExpr expr) ui us + # (expr, us) = unfold expr ui us = (DynamicExpr expr, us) - unfold expr us + unfold expr ui us = (expr, us) instance unfold DynamicExpr where - unfold expr=:{dyn_expr} us - # (dyn_expr, us) = unfold dyn_expr us + unfold expr=:{dyn_expr} ui us + # (dyn_expr, us) = unfold dyn_expr ui us = ({ expr & dyn_expr = dyn_expr }, us) -/* Sjaak ... */ instance unfold Selection where - unfold (ArraySelection array_select expr_ptr index_expr) us=:{us_symbol_heap} + unfold (ArraySelection array_select expr_ptr index_expr) ui us=:{us_symbol_heap} # (new_ptr, us_symbol_heap) = newPtr EI_Empty us_symbol_heap - (index_expr, us) = unfold index_expr { us & us_symbol_heap = us_symbol_heap} + (index_expr, us) = unfold index_expr ui { us & us_symbol_heap = us_symbol_heap} = (ArraySelection array_select new_ptr index_expr, us) - unfold (DictionarySelection var selectors expr_ptr index_expr) us=:{us_symbol_heap} + unfold (DictionarySelection var selectors expr_ptr index_expr) ui us=:{us_symbol_heap} # (new_ptr, us_symbol_heap) = newPtr EI_Empty us_symbol_heap - (index_expr, us) = unfold index_expr { us & us_symbol_heap = us_symbol_heap} + (index_expr, us) = unfold index_expr ui { us & us_symbol_heap = us_symbol_heap} (var_expr, us) = unfoldVariable var us = case var_expr of App {app_symb={symb_kind= SK_Constructor _ }, app_args} @@ -340,43 +327,58 @@ where new_ptr index_expr, us) Var var -> (DictionarySelection var selectors new_ptr index_expr, us) - unfold record_selection ls - = (record_selection, ls) -/* ... Sjaak */ + unfold record_selection ui us + = (record_selection, us) instance unfold FreeVar where - unfold fv=:{fv_info_ptr,fv_name} us=:{us_var_heap} + unfold fv=:{fv_info_ptr,fv_name} ui us=:{us_var_heap} # (new_info_ptr, us_var_heap) = newPtr VI_Empty us_var_heap = ({ fv & fv_info_ptr = new_info_ptr }, { us & us_var_heap = writePtr fv_info_ptr (VI_Variable fv_name new_info_ptr) us_var_heap }) instance unfold App where - unfold app=:{app_symb, app_args, app_info_ptr} us - # (new_info_ptr, us) - = case is_function_or_macro app_symb.symb_kind of - True # (new_ptr, us_symbol_heap) = newPtr EI_Empty us.us_symbol_heap - -> (new_ptr, { us & us_symbol_heap = us_symbol_heap }) - _ -> case (app_symb.symb_kind, isNilPtr app_info_ptr) of - (SK_Constructor _, False) - # (app_info, us_symbol_heap) = readPtr app_info_ptr us.us_symbol_heap - (new_app_info, us_opt_type_heaps) = substitute_EI_DictionaryType app_info us.us_opt_type_heaps - (new_ptr, us_symbol_heap) = newPtr new_app_info us_symbol_heap - -> (new_ptr, { us & us_symbol_heap = us_symbol_heap, us_opt_type_heaps = us_opt_type_heaps }) - _ -> (nilPtr, us) - (app_args, us) = unfold app_args us - = ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, us) + unfold app=:{app_symb={symb_kind}, app_args, app_info_ptr} ui=:{ui_convert_module_n,ui_conversion_table} us + = case symb_kind of + SK_Function {glob_module,glob_object} + | ui_convert_module_n==glob_module + # (Yes conversion_table) = ui_conversion_table + # app={app & app_symb.symb_kind=SK_Function {glob_module=glob_module,glob_object=conversion_table.[cFunctionDefs].[glob_object]}} + -> unfold_function_app app ui us + -> unfold_function_app app ui us + SK_Macro {glob_module,glob_object} + | ui_convert_module_n==glob_module + # (Yes conversion_table) = ui_conversion_table + # app={app & app_symb.symb_kind=SK_Macro {glob_module=glob_module,glob_object=conversion_table.[cMacroDefs].[glob_object]}} + -> unfold_function_app app ui us + -> unfold_function_app app ui us + SK_OverloadedFunction {glob_module,glob_object} + | ui_convert_module_n==glob_module + # (Yes conversion_table) = ui_conversion_table + # app={app & app_symb.symb_kind=SK_OverloadedFunction {glob_module=glob_module,glob_object=conversion_table.[cFunctionDefs].[glob_object]}} + -> unfold_function_app app ui us + -> unfold_function_app app ui us + SK_LocalMacroFunction _ + -> unfold_function_app app ui us + SK_Constructor _ + | not (isNilPtr app_info_ptr) + # (app_info, us_symbol_heap) = readPtr app_info_ptr us.us_symbol_heap + (new_app_info, us_opt_type_heaps) = substitute_EI_DictionaryType app_info us.us_opt_type_heaps + (new_info_ptr, us_symbol_heap) = newPtr new_app_info us_symbol_heap + us={ us & us_symbol_heap = us_symbol_heap, us_opt_type_heaps = us_opt_type_heaps } + (app_args, us) = unfold app_args ui us + -> ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, us) + # (app_args, us) = unfold app_args ui us + -> ({ app & app_args = app_args}, us) + _ + # (app_args, us) = unfold app_args ui us + -> ({ app & app_args = app_args, app_info_ptr = nilPtr}, us) where - is_function_or_macro (SK_Function _) - = True - is_function_or_macro (SK_LocalMacroFunction _) - = True - is_function_or_macro (SK_Macro _) - = True - is_function_or_macro (SK_OverloadedFunction _) - = True - is_function_or_macro _ - = False + unfold_function_app app=:{app_args, app_info_ptr} ui us + # (new_info_ptr, us_symbol_heap) = newPtr EI_Empty us.us_symbol_heap + # us={ us & us_symbol_heap = us_symbol_heap } + # (app_args, us) = unfold app_args ui us + = ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, us) substitute_EI_DictionaryType (EI_DictionaryType class_type) (Yes type_heaps) # (new_class_type, type_heaps) = substitute class_type type_heaps @@ -386,19 +388,19 @@ where instance unfold LetBind where - unfold bind=:{lb_src} us - # (lb_src, us) = unfold lb_src us + unfold bind=:{lb_src} ui us + # (lb_src, us) = unfold lb_src ui us = ({ bind & lb_src = lb_src }, us) instance unfold (Bind a b) | unfold a where - unfold bind=:{bind_src} us - # (bind_src, us) = unfold bind_src us + unfold bind=:{bind_src} ui us + # (bind_src, us) = unfold bind_src ui us = ({ bind & bind_src = bind_src }, us) instance unfold Case where - unfold kees=:{ case_expr,case_guards,case_default,case_info_ptr} us=:{us_cleanup_info} + unfold kees=:{ case_expr,case_guards,case_default,case_info_ptr} ui us=:{us_cleanup_info} # (old_case_info, us_symbol_heap) = readPtr case_info_ptr us.us_symbol_heap (new_case_info, us_opt_type_heaps) = substitute_let_or_case_type old_case_info us.us_opt_type_heaps (new_info_ptr, us_symbol_heap) = newPtr new_case_info us_symbol_heap @@ -406,16 +408,16 @@ where EI_Extended _ _ -> [new_info_ptr:us_cleanup_info] _ -> us_cleanup_info us = { us & us_symbol_heap = us_symbol_heap, us_opt_type_heaps = us_opt_type_heaps, us_cleanup_info=us_cleanup_info } - ((case_guards,case_default), us) = unfold (case_guards,case_default) us + ((case_guards,case_default), us) = unfold (case_guards,case_default) ui us (case_expr, us) = update_active_case_info_and_unfold case_expr new_info_ptr us = ({ kees & case_expr = case_expr,case_guards = case_guards, case_default = case_default, case_info_ptr = new_info_ptr}, us) where - update_active_case_info_and_unfold case_expr=:(Var {var_info_ptr}) case_info_ptr us=:{us_handle_aci_free_vars} + update_active_case_info_and_unfold case_expr=:(Var {var_info_ptr}) case_info_ptr us # (case_info, us_symbol_heap) = readPtr case_info_ptr us.us_symbol_heap us = { us & us_symbol_heap = us_symbol_heap } = case case_info of EI_Extended (EEI_ActiveCase aci=:{aci_free_vars}) ei - #!(new_aci_free_vars, us) = case us_handle_aci_free_vars of + #!(new_aci_free_vars, us) = case ui.ui_handle_aci_free_vars of LeaveThem -> (aci_free_vars, us) RemoveThem -> (No, us) SubstituteThem -> case aci_free_vars of @@ -429,7 +431,7 @@ where # tb_args_ptrs = [ fv_info_ptr \\ {fv_info_ptr}<-tb_args ] (original_bindings, us_var_heap) = mapSt readPtr tb_args_ptrs us.us_var_heap us_var_heap = fold2St bind tb_args_ptrs new_aci_params us_var_heap - (tb_rhs, us) = unfold tb_rhs { us & us_var_heap = us_var_heap } + (tb_rhs, us) = unfold tb_rhs ui { us & us_var_heap = us_var_heap } us_var_heap = fold2St writePtr tb_args_ptrs original_bindings us.us_var_heap new_aci = { aci & aci_params = new_aci_params, aci_opt_unfolder = Yes fun_symb, aci_free_vars = new_aci_free_vars } new_eei = (EI_Extended (EEI_ActiveCase new_aci) ei) @@ -437,8 +439,8 @@ where -> (tb_rhs, { us & us_var_heap = us_var_heap, us_symbol_heap = us_symbol_heap }) _ # new_eei = EI_Extended (EEI_ActiveCase { aci & aci_free_vars = new_aci_free_vars }) ei us_symbol_heap = writePtr case_info_ptr new_eei us.us_symbol_heap - -> unfold case_expr { us & us_symbol_heap = us_symbol_heap } - _ -> unfold case_expr us + -> unfold case_expr ui { us & us_symbol_heap = us_symbol_heap } + _ -> unfold case_expr ui us where // XXX consider to store BoundVars in VI_Body bind fv_info_ptr {fv_name=name, fv_info_ptr=info_ptr} var_heap @@ -460,21 +462,20 @@ where _ -> unfold case_expr us */ update_active_case_info_and_unfold case_expr _ us - = unfold case_expr us + = unfold case_expr ui us unfoldBoundVar {var_info_ptr} us # (VI_Expression (Var act_var), us_var_heap) = readPtr var_info_ptr us.us_var_heap = (act_var, { us & us_var_heap = us_var_heap }) - instance unfold Let where - unfold lad=:{let_strict_binds, let_lazy_binds, let_expr, let_info_ptr} us + unfold lad=:{let_strict_binds, let_lazy_binds, let_expr, let_info_ptr} ui us # (let_strict_binds, us) = copy_bound_vars let_strict_binds us # (let_lazy_binds, us) = copy_bound_vars let_lazy_binds us - # (let_strict_binds, us) = unfold let_strict_binds us - # (let_lazy_binds, us) = unfold let_lazy_binds us - # (let_expr, us) = unfold let_expr us + # (let_strict_binds, us) = unfold let_strict_binds ui us + # (let_lazy_binds, us) = unfold let_lazy_binds ui us + # (let_expr, us) = unfold let_expr ui us (old_let_info, us_symbol_heap) = readPtr let_info_ptr us.us_symbol_heap (new_let_info, us_opt_type_heaps) = substitute_let_or_case_type old_let_info us.us_opt_type_heaps (new_info_ptr, us_symbol_heap) = newPtr new_let_info us_symbol_heap @@ -482,7 +483,7 @@ where { us & us_symbol_heap = us_symbol_heap, us_opt_type_heaps = us_opt_type_heaps }) where copy_bound_vars [bind=:{lb_dst} : binds] us - # (lb_dst, us) = unfold lb_dst us + # (lb_dst, us) = unfold lb_dst ui us (binds, us) = copy_bound_vars binds us = ([ {bind & lb_dst = lb_dst} : binds ], us) copy_bound_vars [] us @@ -503,36 +504,66 @@ substitute_let_or_case_type (EI_LetType let_type) (Yes type_heaps) instance unfold CasePatterns where - unfold (AlgebraicPatterns type patterns) us - # (patterns, us) = unfold patterns us + unfold (AlgebraicPatterns type patterns) ui us + # (patterns, us) = unfold patterns ui us = (AlgebraicPatterns type patterns, us) - unfold (BasicPatterns type patterns) us - # (patterns, us) = unfold patterns us + unfold (BasicPatterns type patterns) ui us + # (patterns, us) = unfold patterns ui us = (BasicPatterns type patterns, us) - unfold (DynamicPatterns patterns) us - # (patterns, us) = unfold patterns us + unfold (DynamicPatterns patterns) ui us + # (patterns, us) = unfold patterns ui us = (DynamicPatterns patterns, us) instance unfold BasicPattern where - unfold guard=:{bp_expr} us - # (bp_expr, us) = unfold bp_expr us + unfold guard=:{bp_expr} ui us + # (bp_expr, us) = unfold bp_expr ui us = ({ guard & bp_expr = bp_expr }, us) instance unfold AlgebraicPattern where - unfold guard=:{ap_vars,ap_expr} us - # (ap_vars, us) = unfold ap_vars us - (ap_expr, us) = unfold ap_expr us + unfold guard=:{ap_vars,ap_expr} ui us + # (ap_vars, us) = unfold ap_vars ui us + (ap_expr, us) = unfold ap_expr ui us = ({ guard & ap_vars = ap_vars, ap_expr = ap_expr }, us) instance unfold DynamicPattern where - unfold guard=:{dp_var,dp_rhs} us - # (dp_var, us) = unfold dp_var us - (dp_rhs, us) = unfold dp_rhs us + unfold guard=:{dp_var,dp_rhs} ui us + # (dp_var, us) = unfold dp_var ui us + (dp_rhs, us) = unfold dp_rhs ui us = ({ guard & dp_var = dp_var, dp_rhs = dp_rhs }, us) +instance unfold [a] | unfold a +where + unfold l ui us + // = mapSt unfold l ui us + = map_st l us + where + map_st [x : xs] s + # (x, s) = unfold x ui s + (xs, s) = map_st xs s + #! s = s + = ([x : xs], s) + map_st [] s + = ([], s) + +instance unfold (a,b) | unfold a & unfold b +where +// unfold t ui us = app2St (unfold,unfold) t ui us + unfold (a,b) ui us + # (a,us) = unfold a ui us + # (b,us) = unfold b ui us + = ((a,b),us) + +instance unfold (Optional a) | unfold a +where + unfold (Yes x) ui us + # (x, us) = unfold x ui us + = (Yes x, us) + unfold no ui us + = (no, us) + updateFunctionCalls :: ![FunCall] ![FunCall] !*{# FunDef} !*SymbolTable -> (![FunCall], !*{# FunDef}, !*SymbolTable) updateFunctionCalls calls collected_calls fun_defs symbol_table @@ -555,17 +586,28 @@ examineFunctionCall {id_info} fc=:{fc_index} (calls, symbol_table) (id_info, { ste_kind = STE_Called [fc_index], ste_index = NoIndex, ste_def_level = NotALevel, ste_previous = entry })) unfoldMacro :: !FunDef ![Expression] !*ExpandInfo -> (!Expression, !*ExpandInfo) -unfoldMacro {fun_body = TransformedBody {tb_args,tb_rhs}, fun_info = {fi_calls}} args (calls, es=:{es_var_heap,es_symbol_heap, es_symbol_table,es_fun_defs}) +unfoldMacro {fun_body = TransformedBody {tb_args,tb_rhs}, fun_info = {fi_calls},fun_kind,fun_symb} args (calls, es=:{es_var_heap,es_symbol_heap, es_symbol_table,es_fun_defs,es_expand_in_imp_module, es_main_dcl_module_n,es_dcl_modules}) # (let_binds, var_heap) = bind_expressions tb_args args [] es_var_heap - us = { us_symbol_heap = es_symbol_heap, us_var_heap = var_heap, us_opt_type_heaps = No, us_cleanup_info = [], - us_handle_aci_free_vars = RemoveThem } - (result_expr, {us_symbol_heap,us_var_heap}) = unfold tb_rhs us - (calls, fun_defs, es_symbol_table) = updateFunctionCalls fi_calls calls es_fun_defs es_symbol_table + # us = { us_symbol_heap = es_symbol_heap, us_var_heap = var_heap, us_opt_type_heaps = No,us_cleanup_info = []} + # (result_expr,dcl_modules,us_symbol_heap,us_var_heap) = unfold_and_convert tb_rhs es_dcl_modules us + with + unfold_and_convert tb_rhs dcl_modules us + # is_def_macro=case fun_kind of FK_DefMacro->True; _->False + | es_expand_in_imp_module && is_def_macro + # (dcl_mod,dcl_modules) = dcl_modules![es_main_dcl_module_n] + # ui = {ui_handle_aci_free_vars = RemoveThem, ui_convert_module_n = es_main_dcl_module_n, ui_conversion_table=dcl_mod.dcl_conversions } + # (result_expr,{us_symbol_heap,us_var_heap})= unfold tb_rhs ui us + = (result_expr,dcl_modules,us_symbol_heap,us_var_heap) + + # ui = {ui_handle_aci_free_vars = RemoveThem, ui_convert_module_n = -1 ,ui_conversion_table=No } + # (result_expr,{us_symbol_heap,us_var_heap})= unfold tb_rhs ui us + = (result_expr,dcl_modules,us_symbol_heap,us_var_heap) + # (calls, fun_defs, es_symbol_table) = updateFunctionCalls fi_calls calls es_fun_defs es_symbol_table | isEmpty let_binds - = (result_expr, (calls, { es & es_var_heap = us_var_heap, es_symbol_heap = us_symbol_heap, es_symbol_table = es_symbol_table, es_fun_defs=fun_defs })) + = (result_expr, (calls, { es & es_var_heap = us_var_heap, es_symbol_heap = us_symbol_heap, es_symbol_table = es_symbol_table, es_fun_defs=fun_defs,es_dcl_modules=dcl_modules })) # (new_info_ptr, us_symbol_heap) = newPtr EI_Empty us_symbol_heap = (Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = result_expr, let_info_ptr = new_info_ptr, let_expr_position = NoPos }, - (calls, { es & es_var_heap = us_var_heap, es_symbol_heap = us_symbol_heap, es_symbol_table = es_symbol_table,es_fun_defs=fun_defs })) + (calls, { es & es_var_heap = us_var_heap, es_symbol_heap = us_symbol_heap, es_symbol_table = es_symbol_table,es_fun_defs=fun_defs,es_dcl_modules=dcl_modules })) where bind_expressions [var : vars] [expr : exprs] binds var_heap # (binds, var_heap) = bind_expressions vars exprs binds var_heap @@ -625,7 +667,8 @@ where pationate_macro mod_index max_fun_nr macro_index (macro_defs, modules, pi) # (macro_def, macro_defs) = macro_defs![macro_index] - | macro_def.fun_kind == FK_Macro +// | macro_def.fun_kind == FK_Macro + | case macro_def.fun_kind of FK_DefMacro->True ; FK_ImpMacro->True; _ -> False = case macro_def.fun_body of CheckedBody body # macros_modules_pi = foldSt (visit_macro mod_index max_fun_nr) macro_def.fun_info.fi_calls @@ -641,15 +684,17 @@ where visit_macro mod_index max_fun_nr {fc_index} macros_modules_pi = pationate_macro mod_index max_fun_nr fc_index macros_modules_pi - expand_simple_macro mod_index macro_index macro=:{fun_body = CheckedBody body, fun_info, fun_symb, fun_pos} + expand_simple_macro mod_index macro_index macro=:{fun_body = CheckedBody body, fun_info, fun_symb, fun_pos,fun_kind} (macro_defs, modules, pi=:{pi_symbol_table,pi_symbol_heap,pi_var_heap,pi_error}) | macros_are_simple fun_info.fi_calls macro_defs # identPos = newPosition fun_symb fun_pos + # expand_in_imp_module=case fun_kind of FK_ImpMacro->True; _ -> False es = { es_symbol_table = pi_symbol_table, es_var_heap = pi_var_heap, es_symbol_heap = pi_symbol_heap, es_error = setErrorAdmin identPos pi_error, - es_fun_defs=macro_defs, es_module_n = mod_index, es_dcl_modules=modules + es_fun_defs=macro_defs, es_main_dcl_module_n = mod_index, es_dcl_modules=modules, + es_expand_in_imp_module=expand_in_imp_module } - (tb_args, tb_rhs, local_vars, fi_calls, {es_symbol_table, es_var_heap, es_symbol_heap, es_error,es_dcl_modules,es_fun_defs}) + # (tb_args, tb_rhs, local_vars, fi_calls, {es_symbol_table, es_var_heap, es_symbol_heap, es_error,es_dcl_modules,es_fun_defs}) = expandMacrosInBody [] body alias_dummy es macro = { macro & fun_body = TransformedBody { tb_args = tb_args, tb_rhs = tb_rhs}, fun_info = { fun_info & fi_calls = fi_calls, fi_local_vars = local_vars }} @@ -664,7 +709,9 @@ where # {fun_kind,fun_body} = macro_defs.[fc_index] = is_a_pattern_macro fun_kind fun_body && macros_are_simple calls macro_defs where - is_a_pattern_macro FK_Macro (TransformedBody {tb_args}) + is_a_pattern_macro FK_DefMacro (TransformedBody {tb_args}) + = True + is_a_pattern_macro FK_ImpMacro (TransformedBody {tb_args}) = True is_a_pattern_macro _ _ = False @@ -673,14 +720,31 @@ partitionateAndLiftFunctions :: ![IndexRange] !Index !PredefinedSymbol !*{# FunD -> (!*{! Group}, !*{# FunDef}, !.{# DclModule}, !*VarHeap, !*ExpressionHeap, !*SymbolTable, !*ErrorAdmin ) partitionateAndLiftFunctions ranges main_dcl_module_n alias_dummy fun_defs modules var_heap symbol_heap symbol_table error #! max_fun_nr = size fun_defs - # partitioning_info = { pi_var_heap = var_heap, pi_symbol_heap = symbol_heap, pi_symbol_table = symbol_table, - pi_error = error, pi_deps = [], pi_next_num = 0, pi_next_group = 0, pi_groups = [] } + # partitioning_info = { pi_var_heap = var_heap, pi_symbol_heap = symbol_heap, pi_symbol_table = symbol_table, + pi_error = error, pi_deps = [], pi_next_num = 0, pi_next_group = 0, pi_groups = [] } (fun_defs, modules, {pi_groups, pi_symbol_table, pi_var_heap, pi_symbol_heap, pi_error}) = foldSt (partitionate_functions main_dcl_module_n max_fun_nr) ranges (fun_defs, modules, partitioning_info) - groups = { {group_members = group} \\ group <- reverse pi_groups } + # (reversed_pi_groups,fun_defs) = remove_macros_from_groups_and_reverse pi_groups fun_defs [] + # groups = { {group_members = group} \\ group <- reversed_pi_groups } +// # groups = { {group_members = group} \\ group <- reverse pi_groups } = (groups, fun_defs, modules, pi_var_heap, pi_symbol_heap, pi_symbol_table, pi_error) where - + remove_macros_from_groups_and_reverse [group:groups] fun_defs result_groups + # (group,fun_defs) = remove_macros_from_group group fun_defs + = case group of + [] -> remove_macros_from_groups_and_reverse groups fun_defs result_groups + _ -> remove_macros_from_groups_and_reverse groups fun_defs [group:result_groups] + where + remove_macros_from_group [fun:funs] fun_defs + # (funs,fun_defs)=remove_macros_from_group funs fun_defs + | fun_defs.[fun].fun_info.fi_group_index<NoIndex + = (funs,fun_defs) + = ([fun:funs],fun_defs) + remove_macros_from_group [] fun_defs + = ([],fun_defs); + remove_macros_from_groups_and_reverse [] fun_defs result_groups + = (result_groups,fun_defs); + partitionate_functions mod_index max_fun_nr {ir_from,ir_to} funs_modules_pi = iFoldSt (partitionate_global_function mod_index max_fun_nr) ir_from ir_to funs_modules_pi @@ -702,11 +766,12 @@ where TransformedBody _ | fun_def.fun_info.fi_group_index == NoIndex # (fun_defs, pi) = add_called_macros fun_def.fun_info.fi_calls (fun_defs, pi) - -> (max_fun_nr, ({ fun_defs & [fun_index] = {fun_def & fun_info.fi_group_index = pi.pi_next_group }}, modules, - {pi & pi_next_group = inc pi.pi_next_group, pi_groups = [ [fun_index] : pi.pi_groups]})) +// -> (max_fun_nr, ({ fun_defs & [fun_index] = {fun_def & fun_info.fi_group_index = pi.pi_next_group }}, modules, + -> (max_fun_nr, ({ fun_defs & [fun_index] = {fun_def & fun_info.fi_group_index = -2-pi.pi_next_group }}, modules, + {pi & pi_next_group = inc pi.pi_next_group, pi_groups = [ [fun_index] : pi.pi_groups]} +// {pi & pi_next_group = pi.pi_next_group} + )) -> (max_fun_nr, (fun_defs, modules, pi)) - BackendBody _ - -> abort "partitionate_function BackendBody" visit_function mod_index max_fun_nr {fc_index} (min_dep, funs_modules_pi) # (next_min, funs_modules_pi) = partitionate_function mod_index max_fun_nr fc_index funs_modules_pi @@ -715,46 +780,52 @@ where try_to_close_group mod_index max_fun_nr fun_index fun_number min_dep def_level (fun_defs, modules, pi=:{pi_symbol_table, pi_var_heap, pi_symbol_heap, pi_deps, pi_groups, pi_next_group, pi_error}) | fun_number <= min_dep - # (pi_deps, group_without_macros, group_without_funs, fun_defs) + # (pi_deps, functions_in_group, macros_in_group, fun_defs) = close_group fun_index pi_deps [] [] max_fun_nr pi_next_group fun_defs -// (fun_defs, pi_var_heap, pi_symbol_heap) {ls_x={x_fun_defs=fun_defs}, ls_var_heap=pi_var_heap, ls_expr_heap=pi_symbol_heap} -// = liftFunctions def_level (group_without_macros ++ group_without_funs) pi_next_group cIclModIndex fun_defs pi_var_heap pi_symbol_heap - = liftFunctions def_level (group_without_macros ++ group_without_funs) pi_next_group main_dcl_module_n fun_defs pi_var_heap pi_symbol_heap - es - = expand_macros_in_group group_without_funs + = liftFunctions def_level (functions_in_group ++ macros_in_group) pi_next_group main_dcl_module_n fun_defs pi_var_heap pi_symbol_heap + es + = expand_macros_in_group macros_in_group { es_symbol_table = pi_symbol_table, es_var_heap = pi_var_heap, es_symbol_heap = pi_symbol_heap, - es_fun_defs=fun_defs, es_module_n=mod_index, es_dcl_modules=modules, + es_fun_defs=fun_defs, es_main_dcl_module_n=mod_index, es_dcl_modules=modules, + es_expand_in_imp_module=False, // function expand_macros fills in correct value es_error = pi_error } {es_symbol_table, es_var_heap, es_symbol_heap, es_error,es_dcl_modules,es_fun_defs} - = expand_macros_in_group group_without_macros es + = expand_macros_in_group functions_in_group es = (max_fun_nr, (es_fun_defs, es_dcl_modules, { pi & pi_deps = pi_deps, pi_var_heap = es_var_heap, pi_symbol_table = es_symbol_table, pi_error = es_error, pi_symbol_heap = es_symbol_heap, - pi_next_group = inc pi_next_group, pi_groups = [ group_without_macros ++ group_without_funs : pi_groups ] })) + pi_next_group = inc pi_next_group, + pi_groups = [ functions_in_group ++ macros_in_group : pi_groups ] })) +// pi_groups = if (isEmpty functions_in_group) pi_groups [ functions_in_group : pi_groups ] })) = (min_dep, (fun_defs, modules, pi)) where - close_group fun_index [d:ds] group_without_macros group_without_funs nr_of_fun_defs group_number fun_defs + close_group fun_index [d:ds] functions_in_group macros_in_group nr_of_fun_defs group_number fun_defs # (fun_def, fun_defs) = fun_defs![d] - fun_defs = { fun_defs & [d] = { fun_def & fun_info.fi_group_index = group_number }} - | fun_def.fun_kind == FK_Macro - # group_without_funs = [d : group_without_funs] +// fun_defs = { fun_defs & [d] = { fun_def & fun_info.fi_group_index = group_number }} +// | fun_def.fun_kind == FK_Macro + | case fun_def.fun_kind of FK_DefMacro->True ; FK_ImpMacro->True; _ -> False + # fun_defs = { fun_defs & [d] = { fun_def & fun_info.fi_group_index = -2-group_number }} + # macros_in_group = [d : macros_in_group] | d == fun_index - = (ds, group_without_macros, group_without_funs, fun_defs) - = close_group fun_index ds group_without_macros group_without_funs nr_of_fun_defs group_number fun_defs - # group_without_macros = [d : group_without_macros] + = (ds, functions_in_group, macros_in_group, fun_defs) + = close_group fun_index ds functions_in_group macros_in_group nr_of_fun_defs group_number fun_defs + # fun_defs = { fun_defs & [d] = { fun_def & fun_info.fi_group_index = group_number }} + # functions_in_group = [d : functions_in_group] | d == fun_index - = (ds, group_without_macros, group_without_funs, fun_defs) - = close_group fun_index ds group_without_macros group_without_funs nr_of_fun_defs group_number fun_defs + = (ds, functions_in_group, macros_in_group, fun_defs) + = close_group fun_index ds functions_in_group macros_in_group nr_of_fun_defs group_number fun_defs expand_macros_in_group group es = foldSt expand_macros group es expand_macros fun_index es # (fun_def,es) = es!es_fun_defs.[fun_index] - {fun_symb,fun_body = PartioningFunction body _, fun_info, fun_pos} = fun_def + {fun_symb,fun_body = PartioningFunction body _, fun_info, fun_pos,fun_kind} = fun_def identPos = newPosition fun_symb fun_pos - (tb_args, tb_rhs, fi_local_vars, fi_calls, es) - = expandMacrosInBody fun_info.fi_calls body alias_dummy { es & es_error = setErrorAdmin identPos es.es_error } + # expand_in_imp_module=case fun_kind of FK_ImpFunction _->True; FK_ImpMacro->True; FK_ImpCaf->True; _ -> False + es={ es & es_expand_in_imp_module=expand_in_imp_module, es_error = setErrorAdmin identPos es.es_error } + # (tb_args, tb_rhs, fi_local_vars, fi_calls, es) + = expandMacrosInBody fun_info.fi_calls body alias_dummy es fun_def = { fun_def & fun_body = TransformedBody { tb_args = tb_args, tb_rhs = tb_rhs}, fun_info = { fun_info & fi_calls = fi_calls, fi_local_vars = fi_local_vars }} = {es & es_fun_defs.[fun_index] = fun_def } @@ -768,27 +839,32 @@ where TransformedBody _ | macro_def.fun_info.fi_group_index == NoIndex # (macro_defs, pi) = add_called_macros macro_def.fun_info.fi_calls (macro_defs, pi) - -> ({ macro_defs & [fc_index] = {macro_def & fun_info.fi_group_index = pi.pi_next_group }}, - {pi & pi_next_group = inc pi.pi_next_group, pi_groups = [ [fc_index] : pi.pi_groups]}) +// -> ({ macro_defs & [fc_index] = {macro_def & fun_info.fi_group_index = pi.pi_next_group }}, + -> ({ macro_defs & [fc_index] = {macro_def & fun_info.fi_group_index = -2-pi.pi_next_group }}, + {pi & pi_next_group = inc pi.pi_next_group,pi_groups = [ [fc_index] : pi.pi_groups]} +// {pi & pi_next_group = pi.pi_next_group} + ) -> (macro_defs, pi) - - addFunctionCallsToSymbolTable calls fun_defs symbol_table = foldSt add_function_call_to_symbol_table calls ([], fun_defs, symbol_table) where add_function_call_to_symbol_table fc=:{fc_index} (collected_calls, fun_defs, symbol_table) # ({fun_symb = { id_info }, fun_kind}, fun_defs) = fun_defs![fc_index] - | fun_kind == FK_Macro - = (collected_calls, fun_defs, symbol_table) - # (entry, symbol_table) = readPtr id_info symbol_table - = ([fc : collected_calls], fun_defs, +// | fun_kind == FK_Macro + = case fun_kind of + FK_DefMacro + -> (collected_calls, fun_defs, symbol_table) + FK_ImpMacro + -> (collected_calls, fun_defs, symbol_table) + _ + # (entry, symbol_table) = readPtr id_info symbol_table + -> ([fc : collected_calls], fun_defs, symbol_table <:= (id_info, { ste_kind = STE_Called [fc_index], ste_index = NoIndex, ste_def_level = NotALevel, ste_previous = entry })) removeFunctionCallsFromSymbolTable calls fun_defs symbol_table = foldSt remove_function_call_from_symbol_table calls (fun_defs, symbol_table) where - remove_function_call_from_symbol_table {fc_index} (fun_defs, symbol_table) # ({fun_symb = { id_info }}, fun_defs) = fun_defs![fc_index] (entry, symbol_table) = readPtr id_info symbol_table @@ -928,9 +1004,9 @@ where = DynamicPatterns (map (\dynpattern -> { dynpattern & dp_rhs = expr_fun dynpattern.dp_rhs }) patterns) replace_variables_in_expression expr var_heap symbol_heap - # us = { us_var_heap = var_heap, us_symbol_heap = symbol_heap, us_opt_type_heaps = No, - us_cleanup_info = [], us_handle_aci_free_vars = RemoveThem } - (expr, us) = unfold expr us + # us = { us_var_heap = var_heap, us_symbol_heap = symbol_heap, us_opt_type_heaps = No,us_cleanup_info = []} + ui = {ui_handle_aci_free_vars = RemoveThem, ui_convert_module_n = -1, ui_conversion_table = No} + (expr, us) = unfold expr ui us = (expr, us.us_var_heap, us.us_symbol_heap) new_variable fv=:{fv_name, fv_info_ptr} var_heap @@ -1027,9 +1103,9 @@ where = ([ pattern : patterns ], var_heap, symbol_heap, error) where replace_variables vars expr ap_vars var_heap symbol_heap - # us = { us_var_heap = build_aliases vars ap_vars var_heap, us_symbol_heap = symbol_heap, us_opt_type_heaps = No, - us_cleanup_info=[], us_handle_aci_free_vars = RemoveThem } - (expr, us) = unfold expr us + # us = { us_var_heap = build_aliases vars ap_vars var_heap, us_symbol_heap = symbol_heap, us_opt_type_heaps = No,us_cleanup_info=[]} + ui = {ui_handle_aci_free_vars = RemoveThem, ui_convert_module_n= -1, ui_conversion_table=No} + (expr, us) = unfold expr ui us = (expr, us.us_var_heap, us.us_symbol_heap) build_aliases [var1 : vars1] [ {fv_name,fv_info_ptr} : vars2 ] var_heap @@ -1074,7 +1150,6 @@ liftFunctions min_level group group_index main_dcl_module_n fun_defs var_heap ex // = (fun_defs, var_heap, expr_heap) = {ls_x={x_fun_defs=fun_defs,x_main_dcl_module_n=main_dcl_module_n},ls_var_heap=var_heap, ls_expr_heap=expr_heap} where - add_free_vars_of_non_recursive_calls_to_function group_index fun (contains_free_vars, lifted_function_called, fun_defs) # (fun_def=:{fun_info}, fun_defs) = fun_defs![fun] { fi_free_vars,fi_def_level,fi_calls } = fun_info @@ -1085,7 +1160,8 @@ where where add_free_vars_of_non_recursive_call fun_def_level group_index {fc_index} (lifted_function_called, free_vars, fun_defs) # ({fun_info = {fi_free_vars,fi_group_index}}, fun_defs) = fun_defs![fc_index] - | fi_group_index == group_index +// | fi_group_index == group_index + | if (fi_group_index>=NoIndex) (fi_group_index==group_index) (-2-fi_group_index==group_index) = (lifted_function_called, free_vars, fun_defs) | isEmpty fi_free_vars = (lifted_function_called, free_vars, fun_defs) @@ -1104,7 +1180,8 @@ where where add_free_vars_of_recursive_call fun_def_level group_index {fc_index} (free_vars_added, free_vars, fun_defs) # ({fun_info = {fi_free_vars,fi_group_index}}, fun_defs) = fun_defs![fc_index] - | fi_group_index == group_index +// | fi_group_index == group_index + | if (fi_group_index>=NoIndex) (fi_group_index==group_index) (-2-fi_group_index==group_index) # (free_vars_added, free_vars) = add_free_variables fun_def_level fi_free_vars (free_vars_added, free_vars) = (free_vars_added, free_vars, fun_defs) = (free_vars_added, free_vars, fun_defs) @@ -1165,8 +1242,9 @@ where , es_symbol_heap :: !.ExpressionHeap , es_error :: !.ErrorAdmin, es_fun_defs :: !.{#FunDef}, - es_module_n :: !Int, - es_dcl_modules :: !.{# DclModule} + es_main_dcl_module_n :: !Int, + es_dcl_modules :: !.{# DclModule}, + es_expand_in_imp_module :: !Bool } class expand a :: !a !*ExpandInfo -> (!a, !*ExpandInfo) @@ -1177,11 +1255,13 @@ where # (app_args, (calls, es)) = expand app_args ei # (macro, es) = es!es_fun_defs.[glob_object] | macro.fun_arity == symb_arity - # (expr, ei) = unfoldMacro macro app_args (calls, es) - = (expr, ei) + = unfoldMacro macro app_args (calls, es) # (calls, es_symbol_table) = examineFunctionCall macro.fun_symb {fc_index = glob_object, fc_level = NotALevel} (calls, es.es_symbol_table) - = (App { app & app_symb = { symb & symb_kind = SK_Function {glob_object = glob_object, glob_module = glob_module} }, app_args = app_args }, - (calls, { es & es_symbol_table = es_symbol_table })) + | macro.fun_info.fi_group_index<NoIndex + # macro = {macro & fun_info.fi_group_index= -2-macro.fun_info.fi_group_index} + # es= {es & es_fun_defs.[glob_object]=macro} + = (App { app & app_symb = { symb & symb_kind = SK_Function {glob_object = glob_object, glob_module = glob_module} }, app_args = app_args },(calls, { es & es_symbol_table = es_symbol_table })) + = (App { app & app_symb = { symb & symb_kind = SK_Function {glob_object = glob_object, glob_module = glob_module} }, app_args = app_args },(calls, { es & es_symbol_table = es_symbol_table })) expand (App app=:{app_args}) ei # (app_args, ei) = expand app_args ei = (App { app & app_args = app_args }, ei) @@ -1590,7 +1670,7 @@ where -> (var, [{fv_name = var_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = 0} : free_vars ], { cos & cos_var_heap = writePtr var_info_ptr (VI_Count 1 is_global) cos.cos_var_heap }) _ - -> abort "collectVariables [BoundVar] (transform, 1227)" <<- (var_info ---> (var_name, ptrToInt var_info_ptr)) + -> abort "collectVariables [BoundVar] (transform, 1227)" // <<- (var_info ---> (var_name, ptrToInt var_info_ptr)) instance <<< (Ptr a) where diff --git a/frontend/type.icl b/frontend/type.icl index d925719..b93a962 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -1,8 +1,7 @@ implementation module type import StdEnv -import syntax, typesupport, check, analtypes, overloading, unitype, refmark, predef, utilities, compare_constructor -import RWSDebug +import syntax, typesupport, check, analtypes, overloading, unitype, refmark, predef, utilities, compare_constructor // , RWSDebug :: TypeInput = { ti_common_defs :: !{# CommonDefs } @@ -1056,7 +1055,6 @@ storeAttribute No type_attribute symbol_heap = symbol_heap getSymbolType ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_kind = SK_Function {glob_module,glob_object}, symb_arity, symb_name} ts -// | glob_module == cIclModIndex | glob_module == ti_main_dcl_module_n | glob_object>=size ts.ts_fun_env = abort symb_name.id_name; @@ -1075,7 +1073,8 @@ getSymbolType ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_kind (fun_type_copy,ts) = currySymbolType fun_type_copy symb_arity ts -> (fun_type_copy, cons_variables, [], ts) _ - -> abort "getSymbolType (type.icl)" ---> (symb_name, glob_object, fun_type) + -> abort ("getSymbolType "+++toString symb_name+++toString glob_object) +// -> abort "getSymbolType (type.icl)" ---> (symb_name, glob_object, fun_type) # {ft_type,ft_type_ptr,ft_specials} = ti_functions.[glob_module].[glob_object] | glob_module>=size ti_functions || glob_object>=size ti_functions.[glob_module] = abort (toString glob_module+++" "+++toString glob_object+++" "+++toString ti_main_dcl_module_n+++" "+++symb_name.id_name); @@ -1105,7 +1104,8 @@ getSymbolType ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_kind (fun_type_copy,ts) = currySymbolType fun_type_copy symb_arity ts -> (fun_type_copy, cons_variables, [], ts) _ - -> abort "getSymbolType (type.icl)" ---> (symb_name, glob_object, fun_type) + -> abort ("getSymbolType "+++toString symb_name+++toString glob_object) +// -> abort "getSymbolType (type.icl)" ---> (symb_name, glob_object, fun_type) getSymbolType ti=:{ti_common_defs} {symb_kind = SK_OverloadedFunction {glob_module,glob_object}, symb_arity} ts # {me_symb, me_type,me_type_ptr} = ti_common_defs.[glob_module].com_member_defs.[glob_object] (fun_type_copy, cons_variables, ts) = determineSymbolTypeOfFunction me_symb symb_arity me_type me_type_ptr ti_common_defs ts @@ -1122,7 +1122,7 @@ where VI_Type type _ -> type _ - -> abort ("requirements BoundVar" ---> (var_name <<- var_info)) + -> abort "requirements BoundVar" // ---> (var_name <<- var_info)) , Yes var_expr_ptr, (reqs, ts)) instance requirements App @@ -2316,8 +2316,8 @@ where , fun_body = NoBody , fun_type = Yes instance_type , fun_pos = me_pos - , fun_index = member_index - , fun_kind = FK_Unknown + , fun_index = member_index + , fun_kind = FK_DefOrImpUnknown , fun_lifted = 0 , fun_info = EmptyFunInfo } |