diff options
| -rw-r--r-- | frontend/StdCompare.icl | 2 | ||||
| -rw-r--r-- | frontend/analtypes.icl | 2 | ||||
| -rw-r--r-- | frontend/check.icl | 395 | ||||
| -rw-r--r-- | frontend/checkFunctionBodies.icl | 19 | ||||
| -rw-r--r-- | frontend/checksupport.dcl | 3 | ||||
| -rw-r--r-- | frontend/checksupport.icl | 149 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 26 | ||||
| -rw-r--r-- | frontend/comparedefimp.icl | 29 | ||||
| -rw-r--r-- | frontend/convertcases.icl | 9 | ||||
| -rw-r--r-- | frontend/explicitimports.icl | 85 | ||||
| -rw-r--r-- | frontend/hashtable.icl | 12 | ||||
| -rw-r--r-- | frontend/main.icl | 229 | ||||
| -rw-r--r-- | frontend/overloading.icl | 1 | ||||
| -rw-r--r-- | frontend/parse.icl | 3 | ||||
| -rw-r--r-- | frontend/refmark.icl | 6 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 16 | ||||
| -rw-r--r-- | frontend/syntax.icl | 57 | ||||
| -rw-r--r-- | frontend/trans.icl | 12 | ||||
| -rw-r--r-- | frontend/transform.dcl | 5 | ||||
| -rw-r--r-- | frontend/transform.icl | 515 | ||||
| -rw-r--r-- | frontend/type.icl | 46 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 2 | ||||
| -rw-r--r-- | frontend/unitype.icl | 6 |
23 files changed, 1102 insertions, 527 deletions
diff --git a/frontend/StdCompare.icl b/frontend/StdCompare.icl index 5b03c09..495feba 100644 --- a/frontend/StdCompare.icl +++ b/frontend/StdCompare.icl @@ -178,7 +178,7 @@ where compare_arguments (App app1) (App app2) = app1 =< app2 compare_arguments (Var v1) (Var v2) = v1 =< v2 compare_arguments (fun1 @ args1) (fun2 @ args2) = (fun1,args1) =< (fun2,args2) - compare_arguments (Lambda vars1 expr1) (Lambda vars2 expr2) = (vars1,expr1) =< (vars2,expr2) +// compare_arguments (Lambda vars1 expr1) (Lambda vars2 expr2) = (vars1,expr1) =< (vars2,expr2) compare_arguments EE EE = Equal compare_arguments _ _ = Greater | less_constructor expr1 expr2 diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index ac1f79b..eba2be5 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -1,7 +1,7 @@ implementation module analtypes import StdEnv -import syntax, checksupport, checktypes, check, typesupport, utilities, analunitypes, RWSDebug +import syntax, checksupport, checktypes, check, typesupport, utilities, analunitypes //, RWSDebug :: UnifyKindsInfo = { uki_kind_heap ::!.KindHeap diff --git a/frontend/check.icl b/frontend/check.icl index 60fa246..179ead9 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -52,8 +52,7 @@ where = ([var:vars], symbol_table, th_vars, error) // otherwise = add_vars_to_symbol_table vars symbol_table th_vars (checkError id_name "(variable) already defined" error) - - + // ..AA checkTypeClasses :: !Index !Index !*{#ClassDef} !*{#MemberDef} !*{#CheckedTypeDef} !*{#DclModule} !*TypeHeaps !*CheckState @@ -216,15 +215,15 @@ where STE_Class # (class_def, is) = class_by_index entry.ste_index is -> check_class_instance class_def module_index entry.ste_index module_index ins is type_heaps cs - STE_Imported STE_Class dcl_index - # (class_def, is) = class_by_module_index dcl_index entry.ste_index is - -> check_class_instance class_def module_index entry.ste_index dcl_index ins is type_heaps cs + STE_Imported STE_Class decl_index + # (class_def, is) = class_by_module_index decl_index entry.ste_index is + -> check_class_instance class_def module_index entry.ste_index decl_index ins is type_heaps cs STE_Generic # (generic_def, is) = generic_by_index entry.ste_index is -> check_generic_instance generic_def module_index entry.ste_index module_index ins is type_heaps cs - STE_Imported STE_Generic dcl_index - # (gen_def, is) = generic_by_module_index dcl_index entry.ste_index is - -> check_generic_instance gen_def module_index entry.ste_index dcl_index ins is type_heaps cs + STE_Imported STE_Generic decl_index + # (gen_def, is) = generic_by_module_index decl_index entry.ste_index is + -> check_generic_instance gen_def module_index entry.ste_index decl_index ins is type_heaps cs ste -> (ins, is, type_heaps, { cs & cs_error = checkError id_name "class or generic undefined" cs.cs_error }) = (ins, is, type_heaps, popErrorAdmin cs) @@ -232,15 +231,15 @@ where class_by_index class_index is=:{is_class_defs} # (class_def, is_class_defs) = is_class_defs![class_index] = (class_def, {is & is_class_defs = is_class_defs}) - class_by_module_index dcl_index class_index is=:{is_modules} - # (dcl_mod, is_modules) = is_modules![dcl_index] + class_by_module_index decl_index class_index is=:{is_modules} + # (dcl_mod, is_modules) = is_modules![decl_index] class_def = dcl_mod.dcl_common.com_class_defs.[class_index] = (class_def, {is & is_modules = is_modules }) generic_by_index gen_index is=:{is_generic_defs} # (gen_def, is_generic_defs) = is_generic_defs![gen_index] = (gen_def, {is & is_generic_defs = is_generic_defs}) - generic_by_module_index dcl_index gen_index is=:{is_modules} - # (dcl_mod, is_modules) = is_modules![dcl_index] + generic_by_module_index decl_index gen_index is=:{is_modules} + # (dcl_mod, is_modules) = is_modules![decl_index] gen_def = dcl_mod.dcl_common.com_generic_defs.[gen_index] = (gen_def, {is & is_modules = is_modules }) @@ -346,10 +345,10 @@ where get_class_def {ste_kind = STE_Class, ste_index} mod_index class_defs modules # (class_def, class_defs) = class_defs![ste_index] = (ste_index, mod_index, class_def, class_defs, modules) - get_class_def {ste_kind = STE_Imported STE_Class dcl_index, ste_index, ste_def_level} mod_index class_defs modules - # (dcl_mod, modules) = modules![dcl_index] + get_class_def {ste_kind = STE_Imported STE_Class decl_index, ste_index, ste_def_level} mod_index class_defs modules + # (dcl_mod, modules) = modules![decl_index] # class_def = dcl_mod.dcl_common.com_class_defs.[ste_index] - = (ste_index, dcl_index, class_def, class_defs, modules) + = (ste_index, decl_index, class_def, class_defs, modules) get_class_def _ mod_index class_defs modules = (NotFound, -1/*cIclModIndex*/, abort "no class definition", class_defs, modules) */ @@ -801,6 +800,9 @@ where createCommonDefinitions {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances, def_generics} = { com_type_defs = { type \\ type <- def_types } + + , com_unexpanded_type_defs = {} + , com_cons_defs = { cons \\ cons <- def_constructors } , com_selector_defs = { sel \\ sel <- def_selectors } , com_class_defs = { class_def \\ class_def <- def_classes } @@ -867,24 +869,23 @@ collectCommonfinitions {def_types,def_constructors,def_selectors,def_macros,def_ // ..AA = (sizes, defs) where - type_def_to_dcl {td_name, td_pos} (dcl_index, decls) - = (inc dcl_index, [{ dcl_ident = td_name, dcl_pos = td_pos, dcl_kind = STE_Type, dcl_index = dcl_index } : decls]) - cons_def_to_dcl {cons_symb, cons_pos} (dcl_index, decls) - = (inc dcl_index, [{ dcl_ident = cons_symb, dcl_pos = cons_pos, dcl_kind = STE_Constructor, dcl_index = dcl_index } : decls]) - selector_def_to_dcl {sd_symb, sd_field, sd_pos} (dcl_index, decls) - = (inc dcl_index, [{ dcl_ident = sd_field, dcl_pos = sd_pos, dcl_kind = STE_Field sd_symb, dcl_index = dcl_index } : decls]) - class_def_to_dcl {class_name, class_pos} (dcl_index, decls) - = (inc dcl_index, [{ dcl_ident = class_name, dcl_pos = class_pos, dcl_kind = STE_Class, dcl_index = dcl_index } : decls]) - member_def_to_dcl {me_symb, me_pos} (dcl_index, decls) - = (inc dcl_index, [{ dcl_ident = me_symb, dcl_pos = me_pos, dcl_kind = STE_Member, dcl_index = dcl_index } : decls]) - instance_def_to_dcl {ins_class, ins_ident, ins_pos} (dcl_index, decls) - = (inc dcl_index, [{ dcl_ident = ins_ident, dcl_pos = ins_pos, dcl_kind = STE_Instance ins_class.glob_object.ds_ident, dcl_index = dcl_index } : decls]) - + type_def_to_dcl {td_name, td_pos} (decl_index, decls) + = (inc decl_index, [Declaration { decl_ident = td_name, decl_pos = td_pos, decl_kind = STE_Type, decl_index = decl_index } : decls]) + cons_def_to_dcl {cons_symb, cons_pos} (decl_index, decls) + = (inc decl_index, [Declaration { decl_ident = cons_symb, decl_pos = cons_pos, decl_kind = STE_Constructor, decl_index = decl_index } : decls]) + selector_def_to_dcl {sd_symb, sd_field, sd_pos} (decl_index, decls) + = (inc decl_index, [Declaration { decl_ident = sd_field, decl_pos = sd_pos, decl_kind = STE_Field sd_symb, decl_index = decl_index } : decls]) + class_def_to_dcl {class_name, class_pos} (decl_index, decls) + = (inc decl_index, [Declaration { decl_ident = class_name, decl_pos = class_pos, decl_kind = STE_Class, decl_index = decl_index } : decls]) + member_def_to_dcl {me_symb, me_pos} (decl_index, decls) + = (inc decl_index, [Declaration { decl_ident = me_symb, decl_pos = me_pos, decl_kind = STE_Member, decl_index = decl_index } : decls]) + instance_def_to_dcl {ins_class, ins_ident, ins_pos} (decl_index, decls) + = (inc decl_index, [Declaration { decl_ident = ins_ident, decl_pos = ins_pos, decl_kind = STE_Instance ins_class.glob_object.ds_ident, decl_index = decl_index } : decls]) // AA.. - generic_def_to_dcl {gen_name, gen_member_name, gen_type, gen_pos} (dcl_index, decls) - # generic_decl = { dcl_ident = gen_name, dcl_pos = gen_pos, dcl_kind = STE_Generic, dcl_index = dcl_index } - # member_decl = { dcl_ident = gen_member_name, dcl_pos = gen_pos, dcl_kind = STE_Generic, dcl_index = dcl_index } - = (inc dcl_index, [generic_decl, member_decl : decls]) + generic_def_to_dcl {gen_name, gen_member_name, gen_type, gen_pos} (decl_index, decls) + # generic_decl = Declaration { decl_ident = gen_name, decl_pos = gen_pos, decl_kind = STE_Generic, decl_index = decl_index } + # member_decl = Declaration { decl_ident = gen_member_name, decl_pos = gen_pos, decl_kind = STE_Generic, decl_index = decl_index } + = (inc decl_index, [generic_decl, member_decl : decls]) // ..AA collectMacros {ir_from,ir_to} macro_defs sizes_defs @@ -894,16 +895,16 @@ collectFunctionTypes fun_types (sizes, defs) # (size, defs) = foldSt fun_type_to_dcl fun_types (0, defs) = ({ sizes & [cFunctionDefs] = size }, defs) where - fun_type_to_dcl {ft_symb, ft_pos} (dcl_index, decls) - = (inc dcl_index, [{ dcl_ident = ft_symb, dcl_pos = ft_pos, dcl_kind = STE_DclFunction, dcl_index = dcl_index } : decls]) + fun_type_to_dcl {ft_symb, ft_pos} (decl_index, decls) + = (inc decl_index, [Declaration { decl_ident = ft_symb, decl_pos = ft_pos, decl_kind = STE_DclFunction, decl_index = decl_index } : decls]) collectGlobalFunctions def_index from_index to_index fun_defs (sizes, defs) # (defs, fun_defs) = iFoldSt fun_def_to_dcl from_index to_index (defs, fun_defs) = (fun_defs, ({ sizes & [def_index] = to_index - from_index }, defs)) where - fun_def_to_dcl dcl_index (defs, fun_defs) - # ({fun_symb, fun_pos}, fun_defs) = fun_defs![dcl_index] - = ([{ dcl_ident = fun_symb, dcl_pos = fun_pos, dcl_kind = STE_FunctionOrMacro [], dcl_index = dcl_index } : defs], fun_defs) + fun_def_to_dcl decl_index (defs, fun_defs) + # ({fun_symb, fun_pos}, fun_defs) = fun_defs![decl_index] + = ([Declaration { decl_ident = fun_symb, decl_pos = fun_pos, decl_kind = STE_FunctionOrMacro [], decl_index = decl_index } : defs], fun_defs) gimme_a_lazy_array_type :: !u:{.a} -> v:{.a}, [u<=v] gimme_a_lazy_array_type a = a @@ -923,7 +924,7 @@ renumber_icl_definitions_as_dcl_definitions _ icl_decl_symbols modules cdefs icl with create_icl_to_dcl_index_table_for_kind :: !Int !{#Int} -> {#Int} create_icl_to_dcl_index_table_for_kind table_size dcl_to_icl_table - # icl_to_dcl_index_table_for_kind = {createArray table_size NoIndex & [dcl_to_icl_table.[dcl_index]]=dcl_index \\ dcl_index<- [0..size dcl_to_icl_table-1]} + # icl_to_dcl_index_table_for_kind = {createArray table_size NoIndex & [dcl_to_icl_table.[decl_index]]=decl_index \\ decl_index<- [0..size dcl_to_icl_table-1]} #! max_index=size icl_to_dcl_index_table_for_kind-1 # icl_to_dcl_index_table_for_kind = number_NoIndex_elements max_index max_index icl_to_dcl_index_table_for_kind with @@ -945,11 +946,11 @@ renumber_icl_definitions_as_dcl_definitions _ icl_decl_symbols modules cdefs icl # (icl_decl_symbols,cdefs) = renumber_icl_decl_symbols icl_decl_symbols cdefs = ([icl_decl_symbol : icl_decl_symbols],cdefs) where - renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Type, dcl_index} cdefs - # (type_def,cdefs) = cdefs!com_type_defs.[dcl_index] + renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Type, decl_index}) cdefs + # (type_def,cdefs) = cdefs!com_type_defs.[decl_index] # type_def = renumber_type_def type_def - # cdefs={cdefs & com_type_defs.[dcl_index]=type_def} - = ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cTypeDefs,dcl_index]},cdefs) + # cdefs={cdefs & com_type_defs.[decl_index]=type_def} + = (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cTypeDefs,decl_index]},cdefs) where renumber_type_def td=:{td_rhs = AlgType conses} # conses = [{cons & ds_index=icl_to_dcl_index_table.[cConstructorDefs,cons.ds_index]} \\ cons <- conses] @@ -960,23 +961,21 @@ renumber_icl_definitions_as_dcl_definitions _ icl_decl_symbols modules cdefs icl = {td & td_rhs=RecordType {rt_constructor=rt_constructor,rt_fields=rt_fields}} renumber_type_def td = td - renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Constructor, dcl_index} cdefs - = ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cConstructorDefs,dcl_index]},cdefs) - renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Field _, dcl_index} cdefs - = ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cSelectorDefs,dcl_index]},cdefs) - renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Member, dcl_index} cdefs - = ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cMemberDefs,dcl_index]},cdefs) - renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Class, dcl_index} cdefs - # (class_def,cdefs) = cdefs!com_class_defs.[dcl_index] + renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Constructor, decl_index}) cdefs + = (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cConstructorDefs,decl_index]},cdefs) + renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Field _, decl_index}) cdefs + = (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cSelectorDefs,decl_index]},cdefs) + renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Member, decl_index}) cdefs + = (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cMemberDefs,decl_index]},cdefs) + renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Class, decl_index}) cdefs + # (class_def,cdefs) = cdefs!com_class_defs.[decl_index] # class_members = {{class_member & ds_index=icl_to_dcl_index_table.[cMemberDefs,class_member.ds_index]} \\ class_member <-: class_def.class_members} # class_def = {class_def & class_members=class_members} - # cdefs = {cdefs & com_class_defs.[dcl_index] =class_def} - = ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cClassDefs,dcl_index]},cdefs) -// AA.. - renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Generic, dcl_index} cdefs - = ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cGenericDefs,dcl_index]},cdefs) - ---> ("renumber_icl_decl_symbol: " +++ icl_decl_symbol.dcl_ident.id_name) -// ..AA + # cdefs = {cdefs & com_class_defs.[decl_index] =class_def} + = (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cClassDefs,decl_index]},cdefs) + renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Generic, decl_index}) cdefs + = (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cGenericDefs,decl_index]},cdefs) + ---> ("renumber_icl_decl_symbol: " +++ icl_decl_symbol.decl_ident.id_name) renumber_icl_decl_symbol icl_decl_symbol cdefs = (icl_decl_symbol,cdefs) # cdefs=reorder_common_definitions cdefs @@ -987,10 +986,11 @@ renumber_icl_definitions_as_dcl_definitions _ icl_decl_symbols modules cdefs icl # com_selector_defs=reorder_array com_selector_defs icl_to_dcl_index_table.[cSelectorDefs] # com_class_defs=reorder_array com_class_defs icl_to_dcl_index_table.[cClassDefs] # com_member_defs=reorder_array com_member_defs icl_to_dcl_index_table.[cMemberDefs] - # com_generic_defs=reorder_array com_generic_defs icl_to_dcl_index_table.[cGenericDefs] // AA - = { com_type_defs=com_type_defs,com_cons_defs=com_cons_defs,com_selector_defs=com_selector_defs, - com_class_defs=com_class_defs,com_member_defs=com_member_defs,com_instance_defs=com_instance_defs, - com_generic_defs = com_generic_defs/*AA*/} + # com_generic_defs=reorder_array com_generic_defs icl_to_dcl_index_table.[cGenericDefs] + = { + com_unexpanded_type_defs={},com_type_defs=com_type_defs,com_cons_defs=com_cons_defs,com_selector_defs=com_selector_defs, + com_class_defs=com_class_defs,com_member_defs=com_member_defs,com_instance_defs=com_instance_defs,com_generic_defs=com_generic_defs + } where reorder_array array index_array # new_array={e\\e<-:array} @@ -999,8 +999,6 @@ renumber_icl_definitions_as_dcl_definitions _ icl_decl_symbols modules cdefs icl # modules = {modules & [main_dcl_module_n].dcl_conversions=Yes conversion_table} = (icl_decl_symbols,modules,cdefs,cs) - - combineDclAndIclModule :: ModuleKind *{#.DclModule} [Declaration] (CollectedDefinitions a b) *{#.Int} *CheckState -> (!*{#DclModule},![Declaration],!CollectedDefinitions a b,!*{#Int},!.CheckState); combineDclAndIclModule MK_Main modules icl_decl_symbols icl_definitions icl_sizes cs = (modules, icl_decl_symbols, icl_definitions, icl_sizes, cs) @@ -1032,28 +1030,28 @@ combineDclAndIclModule _ modules icl_decl_symbols icl_definitions icl_sizes cs , { cs & cs_symbol_table = cs_symbol_table } ) where - add_to_conversion_table first_macro_index dcl_common decl=:{dcl_ident=dcl_ident=:{id_info},dcl_kind,dcl_index,dcl_pos} + add_to_conversion_table first_macro_index dcl_common decl=:(Declaration {decl_ident=decl_ident=:{id_info},decl_kind,decl_index,decl_pos}) (moved_dcl_defs, conversion_table, icl_sizes, icl_defs, cs) # (entry=:{ste_kind,ste_index,ste_def_level}, cs_symbol_table) = readPtr id_info cs.cs_symbol_table | ste_kind == STE_Empty - # def_index = toInt dcl_kind - | can_be_only_in_dcl def_index && not (def_index==cTypeDefs && is_abstract_type dcl_common.com_type_defs dcl_index) + # def_index = toInt decl_kind + | can_be_only_in_dcl def_index && not (def_index==cTypeDefs && is_abstract_type dcl_common.com_type_defs decl_index) # (conversion_table, icl_sizes, icl_defs, cs_symbol_table) - = add_dcl_declaration id_info entry decl def_index dcl_index (conversion_table, icl_sizes, icl_defs, cs_symbol_table) + = add_dcl_declaration id_info entry decl def_index decl_index (conversion_table, icl_sizes, icl_defs, cs_symbol_table) = ([ decl : moved_dcl_defs ], conversion_table, icl_sizes, icl_defs, { cs & cs_symbol_table = cs_symbol_table }) | def_index == cMacroDefs # (conversion_table, icl_defs, cs_symbol_table) - = add_macro_declaration id_info entry decl def_index (dcl_index - first_macro_index) dcl_index + = add_macro_declaration id_info entry decl def_index (decl_index - first_macro_index) decl_index (conversion_table, icl_defs, cs_symbol_table) = ([ decl : moved_dcl_defs ], conversion_table, icl_sizes, icl_defs, { cs & cs_symbol_table = cs_symbol_table }) - # cs_error = checkError "definition module" "undefined in implementation module" (setErrorAdmin (newPosition dcl_ident dcl_pos) cs.cs_error) + # cs_error = checkError "definition module" "undefined in implementation module" (setErrorAdmin (newPosition decl_ident decl_pos) cs.cs_error) = (moved_dcl_defs, conversion_table, icl_sizes, icl_defs, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }) - | ste_def_level == cGlobalScope && ste_kind == dcl_kind - # def_index = toInt dcl_kind - dcl_index = if (def_index == cMacroDefs) (dcl_index - first_macro_index) dcl_index - = (moved_dcl_defs, { conversion_table & [def_index].[dcl_index] = ste_index }, icl_sizes, icl_defs, { cs & cs_symbol_table = cs_symbol_table }) + | ste_def_level == cGlobalScope && ste_kind == decl_kind + # def_index = toInt decl_kind + decl_index = if (def_index == cMacroDefs) (decl_index - first_macro_index) decl_index + = (moved_dcl_defs, { conversion_table & [def_index].[decl_index] = ste_index }, icl_sizes, icl_defs, { cs & cs_symbol_table = cs_symbol_table }) # cs_error = checkError "definition module" "conflicting definition in implementation module" - (setErrorAdmin (newPosition dcl_ident dcl_pos) cs.cs_error) + (setErrorAdmin (newPosition decl_ident decl_pos) cs.cs_error) = (moved_dcl_defs, conversion_table, icl_sizes, icl_defs, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }) /* To be done : cClassDefs and cMemberDefs */ @@ -1062,26 +1060,26 @@ where = def_kind == cTypeDefs || def_kind == cConstructorDefs || def_kind == cSelectorDefs || def_kind == cClassDefs || def_kind == cMemberDefs /*AA*/ || def_kind == cGenericDefs - is_abstract_type com_type_defs dcl_index - = case com_type_defs.[dcl_index].td_rhs of (AbstractType _) -> True ; _ -> False + is_abstract_type com_type_defs decl_index + = case com_type_defs.[decl_index].td_rhs of (AbstractType _) -> True ; _ -> False - add_dcl_declaration info_ptr entry dcl def_index dcl_index (conversion_table, icl_sizes, icl_defs, symbol_table) + add_dcl_declaration info_ptr entry (Declaration dcl) def_index decl_index (conversion_table, icl_sizes, icl_defs, symbol_table) # (icl_index, icl_sizes) = icl_sizes![def_index] - = ( { conversion_table & [def_index].[dcl_index] = icl_index } + = ( { conversion_table & [def_index].[decl_index] = icl_index } , { icl_sizes & [def_index] = inc icl_index } - , [ { dcl & dcl_index = icl_index } : icl_defs ] - , NewEntry symbol_table info_ptr dcl.dcl_kind icl_index cGlobalScope entry + , [ Declaration { dcl & decl_index = icl_index } : icl_defs ] + , NewEntry symbol_table info_ptr dcl.decl_kind icl_index cGlobalScope entry ) - add_macro_declaration info_ptr entry dcl def_index dcl_index icl_index (conversion_table, icl_defs, symbol_table) - = ( { conversion_table & [def_index].[dcl_index] = icl_index } - , [ { dcl & dcl_index = icl_index } : icl_defs ] - , NewEntry symbol_table info_ptr dcl.dcl_kind icl_index cGlobalScope entry + add_macro_declaration info_ptr entry (Declaration dcl) def_index decl_index icl_index (conversion_table, icl_defs, symbol_table) + = ( { conversion_table & [def_index].[decl_index] = icl_index } + , [ Declaration { dcl & decl_index = icl_index } : icl_defs ] + , NewEntry symbol_table info_ptr dcl.decl_kind icl_index cGlobalScope entry ) - add_dcl_definition {com_type_defs} dcl=:{dcl_kind = STE_Type, dcl_index} - (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, cs) - # type_def = com_type_defs.[dcl_index] + add_dcl_definition {com_type_defs} dcl=:(Declaration {decl_kind = STE_Type, decl_index}) + (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs,cs) + # type_def = com_type_defs.[decl_index] (new_type_defs, cs) = add_type_def type_def new_type_defs cs = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, cs) where @@ -1115,29 +1113,29 @@ where is_field (STE_Field _) = True is_field _ = False - add_dcl_definition {com_cons_defs} dcl=:{dcl_kind = STE_Constructor, dcl_index} - (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, cs) - = (new_type_defs, new_class_defs, [ com_cons_defs.[dcl_index] : new_cons_defs ], new_selector_defs, new_member_defs, new_generic_defs, cs) - add_dcl_definition {com_selector_defs} dcl=:{dcl_kind = STE_Field _, dcl_index} - (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, cs) - = (new_type_defs, new_class_defs, new_cons_defs, [ com_selector_defs.[dcl_index] : new_selector_defs ], new_member_defs, new_generic_defs, cs) - add_dcl_definition {com_class_defs} dcl=:{dcl_kind = STE_Class, dcl_index, dcl_pos} - (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, cs) - # class_def = com_class_defs.[dcl_index] - (new_class_defs, cs) = add_class_def dcl_pos class_def new_class_defs cs + add_dcl_definition {com_cons_defs} dcl=:(Declaration {decl_kind = STE_Constructor, decl_index}) + (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs,new_generic_defs,cs) + = (new_type_defs, new_class_defs, [ com_cons_defs.[decl_index] : new_cons_defs ], new_selector_defs, new_member_defs,new_generic_defs,cs) + add_dcl_definition {com_selector_defs} dcl=:(Declaration {decl_kind = STE_Field _, decl_index}) + (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs,new_generic_defs,cs) + = (new_type_defs, new_class_defs, new_cons_defs, [ com_selector_defs.[decl_index] : new_selector_defs ], new_member_defs,new_generic_defs,cs) + add_dcl_definition {com_class_defs} dcl=:(Declaration {decl_kind = STE_Class, decl_index, decl_pos}) + (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs,new_generic_defs,cs) + # class_def = com_class_defs.[decl_index] + (new_class_defs, cs) = add_class_def decl_pos class_def new_class_defs cs = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, cs) where - add_class_def dcl_pos cd=:{class_members} new_class_defs cs - # (new_class_members, cs) = mapSt (redirect_defined_symbol STE_Member dcl_pos) [ cm \\ cm<-:class_members ] cs + add_class_def decl_pos cd=:{class_members} new_class_defs cs + # (new_class_members, cs) = mapSt (redirect_defined_symbol STE_Member decl_pos) [ cm \\ cm<-:class_members ] cs = ([{cd & class_members={cm \\ cm<-new_class_members}}:new_class_defs], cs) - add_dcl_definition {com_member_defs} dcl=:{dcl_kind = STE_Member, dcl_index, dcl_pos} - (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, cs) - # member_def = com_member_defs.[dcl_index] + add_dcl_definition {com_member_defs} dcl=:(Declaration {decl_kind = STE_Member, decl_index, decl_pos}) + (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs,new_generic_defs,cs) + # member_def = com_member_defs.[decl_index] = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, [member_def:new_member_defs], new_generic_defs, cs) // AA.. - add_dcl_definition {com_generic_defs} dcl=:{dcl_kind = STE_Generic, dcl_index, dcl_pos} + add_dcl_definition {com_generic_defs} dcl=:(Declaration {decl_kind = STE_Generic, decl_index, decl_pos}) (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, cs) - # generic_def = com_generic_defs.[dcl_index] + # generic_def = com_generic_defs.[decl_index] = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, [generic_def:new_generic_defs], cs) // ..AA @@ -1312,6 +1310,8 @@ checkDclModules imports_of_icl_mod dcl_modules icl_functions heaps cs=:{cs_symbo -> ([ident:expl_imp_symbols_accu], nr_of_expl_imp_symbols+1, [ini:expl_imp_indices_accu], cs_symbol_table) +//import StdDebug + checkDclComponent :: !{![Int]} !{![Int]} ![[(Index, Position, [ImportNrAndIdents])]] ![Int] !(!Int, !*ExplImpInfos, !*{# DclModule}, !*{# FunDef}, !*Heaps,!*CheckState) -> (!Int, !*ExplImpInfos, !.{# DclModule}, !.{# FunDef}, !.Heaps,!.CheckState) @@ -1451,27 +1451,26 @@ checkDclComponent components_array super_components expl_imp_indices mod_indices (expl_imp_infos, dcl_modules, cs_symbol_table) # ({dcls_local_for_import, dcls_import}, dcl_modules) = dcl_modules![mod_index].dcl_declared - (dcl_modules, expl_imp_infos, cs_symbol_table) + # (dcl_modules, expl_imp_infos, cs_symbol_table) = updateExplImpInfo super_components.[mod_index] mod_index dcls_import dcls_local_for_import dcl_modules expl_imp_infos cs_symbol_table = (expl_imp_infos, dcl_modules, cs_symbol_table) check_expl_imp_completeness_of_dcl_mod_within_non_trivial_component mod_index {si_explicit} (dcl_modules, icl_functions, hp_expression_heap, cs) - # ({dcl_declared}, dcl_modules) - = dcl_modules![mod_index] - ({dcls_local_for_import, dcls_import}) - = dcl_declared - cs - = addDeclarationsOfDclModToSymbolTable mod_index dcls_local_for_import dcls_import cs - (dcl_modules, icl_functions, hp_expression_heap, cs=:{cs_symbol_table}) - = checkExplicitImportCompleteness si_explicit - dcl_modules icl_functions hp_expression_heap cs - cs_symbol_table - = removeImportsAndLocalsOfModuleFromSymbolTable dcl_declared cs.cs_symbol_table - = (dcl_modules, icl_functions, hp_expression_heap, { cs & cs_symbol_table = cs_symbol_table }) + # ({dcl_declared}, dcl_modules) + = dcl_modules![mod_index] + ({dcls_local_for_import, dcls_import}) + = dcl_declared + cs + = addDeclarationsOfDclModToSymbolTable mod_index dcls_local_for_import dcls_import cs + (dcl_modules, icl_functions, hp_expression_heap, cs=:{cs_symbol_table}) + = checkExplicitImportCompleteness si_explicit + dcl_modules icl_functions hp_expression_heap cs + cs_symbol_table + = removeImportsAndLocalsOfModuleFromSymbolTable dcl_declared cs.cs_symbol_table + = (dcl_modules, icl_functions, hp_expression_heap, { cs & cs_symbol_table = cs_symbol_table }) - compute_used_module_nrs (mod_index, _, _) (mod_nr_accu, dcl_modules) | inNumberSet mod_index mod_nr_accu = (mod_nr_accu, dcl_modules) @@ -1479,7 +1478,6 @@ compute_used_module_nrs (mod_index, _, _) (mod_nr_accu, dcl_modules) = dcl_modules![mod_index] = (addNr mod_index (numberSetUnion dcl_imported_module_numbers mod_nr_accu), dcl_modules) - checkDclModuleWithinComponent dcl_imported_module_numbers component_nr is_on_cycle modules_in_component_set super_components imports_ikh mod_index @@ -1615,6 +1613,7 @@ check_module1 {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cde determine_indexes_of_members [] next_fun_index = ([], next_fun_index) +replace_icl_macros_by_dcl_macros :: ModuleKind IndexRange [Declaration] *{#DclModule} *CheckState -> (![Declaration],!*{#DclModule},!*CheckState); replace_icl_macros_by_dcl_macros MK_Main icl_macro_index_range decls dcl_modules cs = (decls,dcl_modules,cs) replace_icl_macros_by_dcl_macros _ {ir_from=first_icl_macro_index,ir_to=end_icl_macro_index} decls dcl_modules cs @@ -1627,19 +1626,29 @@ replace_icl_macros_by_dcl_macros _ {ir_from=first_icl_macro_index,ir_to=end_icl_ with create_icl_to_dcl_index_table_for_kind :: !{#Int} -> {#Int} create_icl_to_dcl_index_table_for_kind dcl_to_icl_table - = {createArray (end_icl_macro_index-first_icl_macro_index) NoIndex & [dcl_to_icl_table.[dcl_index]-first_icl_macro_index]=dcl_index \\ dcl_index<- [0..size dcl_to_icl_table-1]} + # macro_renumber_table = createArray (end_icl_macro_index-first_icl_macro_index) NoIndex + # size_dcl_to_icl_table = size dcl_to_icl_table + # macro_renumber_table = fill_macro_renumber_table 0 macro_renumber_table + with + fill_macro_renumber_table decl_index macro_renumber_table + | decl_index<size_dcl_to_icl_table + # i=dcl_to_icl_table.[decl_index] + | i>=first_icl_macro_index && i<end_icl_macro_index + = fill_macro_renumber_table (decl_index+1) {macro_renumber_table & [i-first_icl_macro_index]=decl_index} + = fill_macro_renumber_table (decl_index+1) macro_renumber_table // for a macro that only occurs in the dcl module and not in the icl module + = macro_renumber_table + = macro_renumber_table + # decls = replace_icl_macros_by_dcl_macros decls with - replace_icl_macros_by_dcl_macros [decl=:{dcl_kind=STE_FunctionOrMacro _,dcl_index}:decls] - # icl_n=macro_renumber_table.[dcl_index-first_icl_macro_index] + replace_icl_macros_by_dcl_macros [decl=:(Declaration decl_record=:{decl_kind=STE_FunctionOrMacro _,decl_index}):decls] + # icl_n=macro_renumber_table.[decl_index-first_icl_macro_index] # decls = replace_icl_macros_by_dcl_macros decls; - | dcl_index>=first_icl_macro_index && dcl_index<end_icl_macro_index && icl_n<>NoIndex -// && trace_tn decl.dcl_ident - = [{decl & dcl_kind=STE_FunctionOrMacro [], dcl_index=first_macro_n+icl_n} : decls] + | decl_index>=first_icl_macro_index && decl_index<end_icl_macro_index && icl_n<>NoIndex + = [Declaration {decl_record & decl_kind=STE_FunctionOrMacro [], decl_index=first_macro_n+icl_n} : decls] = [decl : decls] replace_icl_macros_by_dcl_macros [decl:decls] - # decls = replace_icl_macros_by_dcl_macros decls; - = [decl : decls] + = [decl : replace_icl_macros_by_dcl_macros decls] replace_icl_macros_by_dcl_macros [] = [] = (decls,dcl_modules,cs) @@ -1677,8 +1686,10 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func (icl_sizes_without_added_dcl_defs, sizes) = memcpy sizes (dcl_modules, local_defs, cdefs, icl_sizes, cs) = combineDclAndIclModule mod_type init_dcl_modules local_defs cdefs sizes cs + | not cs.cs_error.ea_ok = (False, abort "evaluated error 1 (check.icl)", {}, {}, No, {}, cs.cs_x.x_main_dcl_module_n,heaps, cs.cs_predef_symbols, cs.cs_symbol_table, cs.cs_error.ea_file, []) + # icl_common = createCommonDefinitions cdefs (local_defs,dcl_modules,icl_common,cs) @@ -1726,6 +1737,7 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func = switch_port_to_new_syntax (writeExplImportsToFile "icl.txt" imports.si_explicit dcl_modules cs) (dcl_modules, cs) + imports_ikh = ikhInsert` False nr_of_modules imports ikhEmpty // maps the module indices of all modules in the actual component to all explicit @@ -1820,6 +1832,7 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func (main_dcl_module, dcl_modules) = dcl_modules![main_dcl_module_n] + (icl_mod, heaps, cs_error) = compareDefImp icl_sizes_without_added_dcl_defs untransformed_fun_bodies main_dcl_module_n unexpanded_icl_type_defs main_dcl_module icl_mod heaps cs_error @@ -1915,8 +1928,8 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func collect_specialized_functions spec_index last_index dcl_fun_types conversion_table (icl_functions, next_fun_index, heaps) | spec_index < last_index - # {ft_type,ft_specials = SP_FunIndex dcl_index} = dcl_fun_types.[spec_index] - icl_index = conversion_table.[dcl_index] + # {ft_type,ft_specials = SP_FunIndex decl_index} = dcl_fun_types.[spec_index] + icl_index = conversion_table.[decl_index] (icl_fun, icl_functions) = icl_functions![icl_index] (new_fun_def, heaps) = build_function next_fun_index icl_fun ft_type heaps (new_fun_defs, funs_index_heaps) @@ -2165,32 +2178,32 @@ addImportedSymbolsToSymbolTable importing_mod opt_macro_range modules_in_compone = (decls_accu, dcl_modules, cs) // this function is for old syntax only - add_consequences_to_symbol_table _ {dcl_kind=STE_FunctionOrMacro _} dcl_modules cs + add_consequences_to_symbol_table _ (Declaration {decl_kind=STE_FunctionOrMacro _}) dcl_modules cs = ([], dcl_modules, cs) - add_consequences_to_symbol_table importing_mod {dcl_index, dcl_kind=STE_Imported ste_kind mod_index} dcl_modules cs - = add_consequences importing_mod dcl_index ste_kind mod_index dcl_modules cs + add_consequences_to_symbol_table importing_mod (Declaration {decl_index, decl_kind=STE_Imported ste_kind mod_index}) dcl_modules cs + = add_consequences importing_mod decl_index ste_kind mod_index dcl_modules cs where - add_consequences _ dcl_index STE_Type mod_index dcl_modules cs + add_consequences _ decl_index STE_Type mod_index dcl_modules cs # (td=:{td_rhs}, dcl_modules) - = dcl_modules![mod_index].dcl_common.com_type_defs.[dcl_index] + = dcl_modules![mod_index].dcl_common.com_type_defs.[decl_index] = case td_rhs of RecordType {rt_fields} -> foldlArraySt (add_field importing_mod mod_index) rt_fields ([], dcl_modules, cs) _ -> ([], dcl_modules, cs) - add_consequences importing_mod dcl_index STE_Class mod_index dcl_modules cs + add_consequences importing_mod decl_index STE_Class mod_index dcl_modules cs # (cd=:{class_members}, dcl_modules) - = dcl_modules![mod_index].dcl_common.com_class_defs.[dcl_index] + = dcl_modules![mod_index].dcl_common.com_class_defs.[decl_index] = foldlArraySt (add_member importing_mod mod_index) class_members ([], dcl_modules, cs) - add_consequences _ dcl_index _ mod_index dcl_modules cs + add_consequences _ decl_index _ mod_index dcl_modules cs = ([], dcl_modules, cs) add_field importing_mod mod_index {fs_index} (declarations_accu, dcl_modules, cs) # (sd=:{sd_symb, sd_field, sd_pos}, dcl_modules) = dcl_modules![mod_index].dcl_common.com_selector_defs.[fs_index] declaration - = { dcl_ident = sd_field, dcl_pos = sd_pos, - dcl_kind = STE_Imported (STE_Field sd_symb) mod_index, dcl_index = fs_index } + = Declaration { decl_ident = sd_field, decl_pos = sd_pos, + decl_kind = STE_Imported (STE_Field sd_symb) mod_index, decl_index = fs_index } (is_new, cs) = add_declaration_to_symbol_table No declaration importing_mod cs | is_new @@ -2200,18 +2213,18 @@ addImportedSymbolsToSymbolTable importing_mod opt_macro_range modules_in_compone # (sd=:{me_symb, me_pos}, dcl_modules) = dcl_modules![mod_index].dcl_common.com_member_defs.[ds_index] declaration - = { dcl_ident = me_symb, dcl_pos = me_pos, - dcl_kind = STE_Imported STE_Member mod_index, dcl_index = ds_index } + = Declaration { decl_ident = me_symb, decl_pos = me_pos, + decl_kind = STE_Imported STE_Member mod_index, decl_index = ds_index } (is_new, cs) = add_declaration_to_symbol_table No declaration importing_mod cs | is_new = ([declaration:declarations_accu], dcl_modules, cs) = (declarations_accu, dcl_modules, cs) -add_declaration_to_symbol_table opt_dcl_macro_range {dcl_kind=STE_FunctionOrMacro _, dcl_ident, dcl_index} _ cs - = addImportedFunctionOrMacro opt_dcl_macro_range dcl_ident dcl_index cs -add_declaration_to_symbol_table yes_for_icl_module {dcl_kind=dcl_kind=:STE_Imported def_kind def_mod, dcl_ident, dcl_index, dcl_pos} importing_mod cs - = addSymbol yes_for_icl_module dcl_ident dcl_pos dcl_kind def_kind dcl_index def_mod importing_mod cs +add_declaration_to_symbol_table opt_dcl_macro_range (Declaration {decl_kind=STE_FunctionOrMacro _, decl_ident, decl_index}) _ cs + = addImportedFunctionOrMacro opt_dcl_macro_range decl_ident decl_index cs +add_declaration_to_symbol_table yes_for_icl_module (Declaration {decl_kind=decl_kind=:STE_Imported def_kind def_mod, decl_ident, decl_index, decl_pos}) importing_mod cs + = addSymbol yes_for_icl_module decl_ident decl_pos decl_kind def_kind decl_index def_mod importing_mod cs updateExplImpInfo :: [Int] Index {!Declaration} {!Declaration} u:{#DclModule} {!{!*ExplImpInfo}} *SymbolTable @@ -2220,6 +2233,7 @@ updateExplImpInfo super_components mod_index dcls_import dcls_local_for_import dcl_modules expl_imp_infos cs_symbol_table # (changed_symbols, (expl_imp_infos, cs_symbol_table)) = mapSt markExplImpSymbols super_components (expl_imp_infos, cs_symbol_table) + cs_symbol_table = switch_import_syntax (foldlArraySt opt_store_instance_with_class_symbol dcls_local_for_import cs_symbol_table) @@ -2228,6 +2242,7 @@ updateExplImpInfo super_components mod_index dcls_import dcls_local_for_import = switch_import_syntax (foldlArraySt opt_store_instance_with_class_symbol dcls_import cs_symbol_table) cs_symbol_table + (dcl_modules, expl_imp_infos, cs_symbol_table) = foldlArraySt (update_expl_imp_for_marked_symbol mod_index) dcls_local_for_import (dcl_modules, expl_imp_infos, cs_symbol_table) @@ -2239,8 +2254,60 @@ updateExplImpInfo super_components mod_index dcls_import dcls_local_for_import changed_symbols cs_symbol_table = (dcl_modules, expl_imp_infos, cs_symbol_table) - -opt_store_instance_with_class_symbol decl=:{dcl_kind=STE_Imported (STE_Instance class_ident) _} cs_symbol_table +/* +ste_kind_to_string :: STE_Kind -> String +ste_kind_to_string ste_kind = case ste_kind of + STE_FunctionOrMacro _ + -> "STE_FunctionOrMacro" + STE_Type + -> "STE_Type" + STE_Constructor + -> "STE_Constructor" + STE_Selector _ + -> "STE_Selector" + STE_Field _ + -> "STE_Field" + STE_Class + -> "STE_Class" + STE_Member + -> "STE_Member" + STE_Instance _ + -> "STE_Instance" + STE_Variable _ + -> "STE_Variable" + STE_TypeVariable _ + -> "STE_TypeVariable" + STE_TypeAttribute _ + -> "STE_TypeAttribute" + STE_BoundTypeVariable _ + -> "STE_BoundTypeVariable" + STE_Imported ste_kind2 _ + -> "STE_Imported "+++ste_kind_to_string ste_kind2 + STE_DclFunction + -> "STE_DclFunction" + STE_Module _ + -> "STE_Module" + STE_ClosedModule + -> "STE_ClosedModule" + STE_Empty + -> "STE_Empty" + STE_DictType _ + -> "STE_DictType" + STE_DictCons _ + -> "STE_DictCons" + STE_DictField _ + -> "STE_DictField" + STE_Called _ + -> "STE_Called" + STE_ExplImpSymbol _ + -> "STE_ExplImpSymbol" + STE_ExplImpComponentNrs _ _ + -> "STE_ExplImpComponentNrs" + STE_BelongingSymbol _ + -> "STE_BelongingSymbol" +*/ + +opt_store_instance_with_class_symbol decl=:(Declaration {decl_kind=STE_Imported (STE_Instance class_ident) _}) cs_symbol_table /* This function is only for old import syntax. All declared instances for a class have to be collected */ @@ -2248,15 +2315,14 @@ opt_store_instance_with_class_symbol decl=:{dcl_kind=STE_Imported (STE_Instance opt_store_instance_with_class_symbol _ cs_symbol_table = cs_symbol_table - -update_expl_imp_for_marked_symbol mod_index decl=:{dcl_ident} (dcl_modules, expl_imp_infos, cs_symbol_table) +update_expl_imp_for_marked_symbol mod_index decl=:(Declaration {decl_ident}) (dcl_modules, expl_imp_infos, cs_symbol_table) # (ste, cs_symbol_table) - = readPtr dcl_ident.id_info cs_symbol_table + = readPtr decl_ident.id_info cs_symbol_table = updateExplImpForMarkedSymbol mod_index decl ste dcl_modules expl_imp_infos cs_symbol_table -update_expl_imp_for_marked_local_symbol mod_index decl=:{dcl_ident} (dcl_modules, expl_imp_infos, cs_symbol_table) +update_expl_imp_for_marked_local_symbol mod_index decl=:(Declaration {decl_ident}) (dcl_modules, expl_imp_infos, cs_symbol_table) # (ste, cs_symbol_table) - = readPtr dcl_ident.id_info cs_symbol_table + = readPtr decl_ident.id_info cs_symbol_table = updateExplImpForMarkedLocalSymbol mod_index decl ste dcl_modules expl_imp_infos cs_symbol_table updateExplImpForMarkedLocalSymbol :: !Index Declaration !SymbolTableEntry !u:{#DclModule} !{!{!*ExplImpInfo}} !*SymbolTable @@ -2311,11 +2377,17 @@ doSomeThingsThatHaveToBeDoneAfterTheWholeComponentHasBeenChecked mod_index #! main_dcl_module_n = cs.cs_x.x_main_dcl_module_n # (dcl_modules, hp_type_heaps, cs_error) - = case mod_index==main_dcl_module_n of + = +/* case mod_index==main_dcl_module_n of True + + # (type_defs, dcl_modules) = dcl_modules![mod_index].dcl_common.com_type_defs + # dcl_modules = { dcl_modules & [mod_index].dcl_common.com_unexpanded_type_defs = { el \\ el <-:type_defs } } + -> (dcl_modules, hp_type_heaps, cs_error) False - -> expand_syn_types_of_dcl_mod mod_index (dcl_modules, hp_type_heaps, cs_error) + -> +*/ expand_syn_types_of_dcl_mod mod_index (dcl_modules, hp_type_heaps, cs_error) (dcl_mod=:{dcl_functions, dcl_common}, dcl_modules) = dcl_modules![mod_index] nr_of_dcl_functions @@ -2363,8 +2435,13 @@ doSomeThingsThatHaveToBeDoneAfterTheWholeComponentHasBeenChecked mod_index expand_syn_types_of_dcl_mod mod_index (dcl_modules, hp_type_heaps, cs_error) # (type_defs, dcl_modules) = dcl_modules![mod_index].dcl_common.com_type_defs + + dcl_modules + = { dcl_modules & [mod_index].dcl_common.com_unexpanded_type_defs = type_defs } + unique_type_defs = { el \\ el <-:type_defs } + (expanded_type_defs, dcl_modules, hp_type_heaps, cs_error) = expandSynonymTypes mod_index unique_type_defs dcl_modules hp_type_heaps cs_error dcl_modules @@ -2461,10 +2538,9 @@ checkDclModule dcl_imported_module_numbers super_components imports_ikh componen heaps = { heaps & hp_expression_heap = hp_expression_heap } dcl_common = { dcl_common & com_type_defs = e_info.ef_type_defs, com_selector_defs = e_info.ef_selector_defs, com_class_defs = e_info.ef_class_defs, - com_instance_defs = com_instance_defs, com_cons_defs = e_info.ef_cons_defs, - com_generic_defs = e_info.ef_generic_defs, //AA - com_member_defs = e_info.ef_member_defs } - + com_instance_defs = com_instance_defs, com_cons_defs = e_info.ef_cons_defs, com_member_defs = e_info.ef_member_defs, + com_generic_defs = e_info.ef_generic_defs //AA + } (modules, expl_imp_info, cs_symbol_table) = updateExplImpInfo super_components mod_index dcls_import dcl_mod.dcl_declared.dcls_local_for_import modules expl_imp_info cs.cs_symbol_table @@ -2715,7 +2791,7 @@ array_to_list a = [el\\el<-:a] Ste_Empty :== STE_Empty dummy_decl - =: { dcl_ident = { id_name = "", id_info = nilPtr }, dcl_pos = NoPos, dcl_kind = STE_Empty, dcl_index = cUndef } + =: { decl_ident = { id_name = "", id_info = nilPtr }, decl_pos = NoPos, decl_kind = STE_Empty, decl_index = cUndef } possibly_write_expl_imports_of_main_dcl_mod_to_file imports_ikh dcl_modules cs | switch_port_to_new_syntax False True @@ -2728,4 +2804,3 @@ possibly_write_expl_imports_of_main_dcl_mod_to_file imports_ikh dcl_modules cs -> (dcl_modules, cs) Yes {si_explicit} -> writeExplImportsToFile "dcl.txt" si_explicit dcl_modules cs - diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl index cb54608..c26c484 100644 --- a/frontend/checkFunctionBodies.icl +++ b/frontend/checkFunctionBodies.icl @@ -522,6 +522,7 @@ where (gs, pattern_scheme, pattern_variables, defaul, free_vars, e_state, e_info, cs) = check_guarded_expressions free_vars gs pattern_variables case_name e_input e_state e_info cs = check_guarded_expression free_vars g gs pattern_scheme pattern_variables defaul case_name e_input e_state e_info cs + check_guarded_expression free_vars {calt_pattern,calt_rhs={rhs_alts,rhs_locals}} patterns pattern_scheme pattern_variables defaul case_name e_input=:{ei_expr_level,ei_mod_index} e_state=:{es_fun_defs,es_var_heap} e_info cs # (pattern, (var_env, array_patterns), {ps_fun_defs,ps_var_heap}, e_info, cs) @@ -911,7 +912,6 @@ checkExpression free_vars (PE_Generic id=:{id_name,id_info} kind) e_input e_stat checkExpression free_vars expr e_input e_state e_info cs = abort "checkExpression (checkFunctionBodies.icl, line 868)" // <<- expr - checkIdentExpression :: !Bool ![FreeVar] !Ident !ExpressionInput !*ExpressionState !u:ExpressionInfo !*CheckState -> (!Expression, ![FreeVar], !*ExpressionState, !u:ExpressionInfo, !*CheckState) checkIdentExpression is_expr_list free_vars id=:{id_info} e_input e_state e_info cs=:{cs_symbol_table} @@ -1883,23 +1883,6 @@ buildPattern mod_index APK_Macro {glob_object} args opt_var ps e_info=:{ef_modul = (pattern, ps, { e_info & ef_modules = ef_modules, ef_cons_defs = ef_cons_defs }, { cs & cs_error = cs_error }) - -////////////////////////////////////////////////////////////////////////////////// -////////////////////////////////////////////////////////////////////////////////// -////////////////////////////////////////////////////////////////////////////////// -////////////////////////////////////////////////////////////////////////////////// -////////////////////////////////////////////////////////////////////////////////// -////////////////////////////////////////////////////////////////////////////////// -////////////////////////////////////////////////////////////////////////////////// -////////////////////////////////////////////////////////////////////////////////// -////////////////////////////////////////////////////////////////////////////////// -////////////////////////////////////////////////////////////////////////////////// -////////////////////////////////////////////////////////////////////////////////// -////////////////////////////////////////////////////////////////////////////////// -////////////////////////////////////////////////////////////////////////////////// -////////////////////////////////////////////////////////////////////////////////// -////////////////////////////////////////////////////////////////////////////////// - getPredefinedGlobalSymbol :: !Index !Index !STE_Kind !Int !*CheckState -> (!Global DefinedSymbol, !*CheckState) getPredefinedGlobalSymbol symb_index module_index req_ste_kind arity cs=:{cs_predef_symbols,cs_symbol_table} # (pre_def_mod, cs_predef_symbols) = cs_predef_symbols![module_index] diff --git a/frontend/checksupport.dcl b/frontend/checksupport.dcl index 2a998ad..7d3734f 100644 --- a/frontend/checksupport.dcl +++ b/frontend/checksupport.dcl @@ -51,6 +51,9 @@ cConversionTableSize :== 9 // AA :: CommonDefs = { com_type_defs :: !.{# CheckedTypeDef} + + , com_unexpanded_type_defs :: !{# CheckedTypeDef} + , com_cons_defs :: !.{# ConsDef} , com_selector_defs :: !.{# SelectorDef} , com_class_defs :: !.{# ClassDef} diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl index a45c9e4..2b289c7 100644 --- a/frontend/checksupport.icl +++ b/frontend/checksupport.icl @@ -5,7 +5,7 @@ import syntax, predef, containers import utilities from check import checkFunctions -import RWSDebug +//import RWSDebug :: VarHeap :== Heap VarInfo @@ -65,6 +65,9 @@ where :: CommonDefs = { com_type_defs :: !.{# CheckedTypeDef} + + , com_unexpanded_type_defs :: !{# CheckedTypeDef} + , com_cons_defs :: !.{# ConsDef} , com_selector_defs :: !.{# SelectorDef} , com_class_defs :: !.{# ClassDef} @@ -230,9 +233,9 @@ convertIndex index table_index No retrieveGlobalDefinition :: !SymbolTableEntry !STE_Kind !Index -> (!Index, !Index) -retrieveGlobalDefinition {ste_kind = STE_Imported kind dcl_index, ste_def_level, ste_index} requ_kind mod_index +retrieveGlobalDefinition {ste_kind = STE_Imported kind decl_index, ste_def_level, ste_index} requ_kind mod_index | kind == requ_kind - = (ste_index, dcl_index) + = (ste_index, decl_index) = (NotFound, mod_index) retrieveGlobalDefinition {ste_kind,ste_def_level,ste_index} requ_kind mod_index | ste_kind == requ_kind && ste_def_level == cGlobalScope @@ -241,9 +244,9 @@ retrieveGlobalDefinition {ste_kind,ste_def_level,ste_index} requ_kind mod_index getBelongingSymbols :: !Declaration !v:{#DclModule} -> (!BelongingSymbols, !v:{#DclModule}) -getBelongingSymbols {dcl_kind=STE_Imported STE_Type def_mod_index, dcl_index} dcl_modules +getBelongingSymbols (Declaration {decl_kind=STE_Imported STE_Type def_mod_index, decl_index}) dcl_modules # ({td_rhs}, dcl_modules) - = dcl_modules![def_mod_index].dcl_common.com_type_defs.[dcl_index] + = dcl_modules![def_mod_index].dcl_common.com_type_defs.[decl_index] = case td_rhs of AlgType constructors -> (BS_Constructors constructors, dcl_modules) @@ -251,9 +254,9 @@ getBelongingSymbols {dcl_kind=STE_Imported STE_Type def_mod_index, dcl_index} dc -> (BS_Fields rt_fields, dcl_modules) _ -> (BS_Nothing, dcl_modules) -getBelongingSymbols {dcl_kind=STE_Imported STE_Class def_mod_index, dcl_index} dcl_modules +getBelongingSymbols (Declaration {decl_kind=STE_Imported STE_Class def_mod_index, decl_index}) dcl_modules # ({class_members}, dcl_modules) - = dcl_modules![def_mod_index].dcl_common.com_class_defs.[dcl_index] + = dcl_modules![def_mod_index].dcl_common.com_class_defs.[decl_index] = (BS_Members class_members, dcl_modules) getBelongingSymbols _ dcl_modules = (BS_Nothing, dcl_modules) @@ -284,7 +287,7 @@ where remove_declared_symbols_in_array symbol_index symbols symbol_table | symbol_index<size symbols #! (symbol,symbols) = symbols![symbol_index] - # {dcl_ident={id_info}}=symbol + # (Declaration {decl_ident={id_info}})=symbol #! entry = sreadPtr id_info symbol_table # {ste_kind,ste_def_level} = entry | ste_kind == STE_Empty || ste_def_level > cModuleScope @@ -292,11 +295,13 @@ where # symbol_table = symbol_table <:= (id_info, entry.ste_previous) = case ste_kind of STE_Field selector_id - #! dcl_index = symbols.[symbol_index].dcl_index - -> remove_declared_symbols_in_array (symbol_index+1) symbols (removeFieldFromSelectorDefinition selector_id NoIndex dcl_index symbol_table) + #! declaration = symbols.[symbol_index] + # (Declaration {decl_index}) = declaration + -> remove_declared_symbols_in_array (symbol_index+1) symbols (removeFieldFromSelectorDefinition selector_id NoIndex decl_index symbol_table) STE_Imported (STE_Field selector_id) def_mod - #! dcl_index = symbols.[symbol_index].dcl_index - -> remove_declared_symbols_in_array (symbol_index+1) symbols (removeFieldFromSelectorDefinition selector_id def_mod dcl_index symbol_table) + #! declaration = symbols.[symbol_index] + # (Declaration {decl_index}) = declaration + -> remove_declared_symbols_in_array (symbol_index+1) symbols (removeFieldFromSelectorDefinition selector_id def_mod decl_index symbol_table) _ -> remove_declared_symbols_in_array (symbol_index+1) symbols symbol_table = symbol_table @@ -330,34 +335,36 @@ addDeclarationsOfDclModToSymbolTable ste_index locals imported cs where add_imports_in_array_to_symbol_table symbol_index symbols cs=:{cs_x} | symbol_index<size symbols - #! ({dcl_ident,dcl_pos,dcl_kind},symbols) = symbols![symbol_index] - = case dcl_kind of + #! (Declaration {decl_ident,decl_pos,decl_kind},symbols) = symbols![symbol_index] + = case decl_kind of STE_Imported def_kind def_mod - #! dcl_index= symbols.[symbol_index].dcl_index - (_, cs) - = addSymbol No dcl_ident dcl_pos dcl_kind - def_kind dcl_index def_mod cUndef cs + #! declaration = symbols.[symbol_index] + # (Declaration {decl_index}) = declaration + # (_, cs) + = addSymbol No decl_ident decl_pos decl_kind + def_kind decl_index def_mod cUndef cs -> add_imports_in_array_to_symbol_table (symbol_index+1) symbols cs STE_FunctionOrMacro _ - #! dcl_index= symbols.[symbol_index].dcl_index - (_, cs) - = addImportedFunctionOrMacro No dcl_ident dcl_index cs + #! declaration = symbols.[symbol_index] + # (Declaration {decl_index}) = declaration + # (_, cs) + = addImportedFunctionOrMacro No decl_ident decl_index cs -> add_imports_in_array_to_symbol_table (symbol_index+1) symbols cs = cs addLocalSymbolsForImportToSymbolTable :: !Int !{!Declaration} Int !*CheckState -> .CheckState; addLocalSymbolsForImportToSymbolTable symbol_index symbols mod_index cs | symbol_index<size symbols - # ({dcl_ident,dcl_pos,dcl_kind,dcl_index},symbols) = symbols![symbol_index] - = case dcl_kind of + # (Declaration {decl_ident,decl_pos,decl_kind,decl_index},symbols) = symbols![symbol_index] + = case decl_kind of STE_FunctionOrMacro _ # (_, cs) - = addImportedFunctionOrMacro No dcl_ident dcl_index cs + = addImportedFunctionOrMacro No decl_ident decl_index cs -> addLocalSymbolsForImportToSymbolTable (symbol_index+1) symbols mod_index cs STE_Imported def_kind def_mod # (_, cs) - = addSymbol No dcl_ident dcl_pos dcl_kind - def_kind dcl_index mod_index cUndef cs + = addSymbol No decl_ident decl_pos decl_kind + def_kind decl_index mod_index cUndef cs -> addLocalSymbolsForImportToSymbolTable (symbol_index+1) symbols mod_index cs = cs @@ -391,14 +398,14 @@ addFieldToSelectorDefinition {id_info} glob_field_index cs=:{cs_symbol_table} -> { cs & cs_symbol_table = NewEntry cs.cs_symbol_table id_info (STE_Selector [glob_field_index]) NoIndex cModuleScope entry } addSymbol :: !(Optional a) !Ident !Position !STE_Kind !STE_Kind !.Int !.Int !Int !*CheckState -> (!Bool, !.CheckState) -addSymbol yes_for_icl_module ident pos dcl_kind def_kind def_index def_mod importing_mod cs=:{cs_symbol_table} +addSymbol yes_for_icl_module ident pos decl_kind def_kind def_index def_mod importing_mod cs=:{cs_symbol_table} # (entry, cs_symbol_table) = readPtr ident.id_info cs_symbol_table = add_indirectly_imported_symbol yes_for_icl_module entry ident pos def_kind def_index def_mod importing_mod { cs & cs_symbol_table = cs_symbol_table } where add_indirectly_imported_symbol _ {ste_kind = STE_Empty} {id_info} _ def_kind def_index def_mod _ cs=:{cs_symbol_table} # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table - cs = { cs & cs_symbol_table = NewEntry cs_symbol_table id_info dcl_kind def_index cModuleScope entry} + cs = { cs & cs_symbol_table = NewEntry cs_symbol_table id_info decl_kind def_index cModuleScope entry} = case def_kind of STE_Field selector_id -> (True, addFieldToSelectorDefinition selector_id { glob_module = def_mod, glob_object = def_index } cs) @@ -421,26 +428,26 @@ addGlobalDefinitionsToSymbolTable :: ![Declaration] !*CheckState -> .CheckState; addGlobalDefinitionsToSymbolTable decls cs = foldSt add_global_definition decls cs where - add_global_definition {dcl_ident=ident=:{id_info},dcl_pos,dcl_kind,dcl_index} cs=:{cs_symbol_table} + add_global_definition (Declaration {decl_ident=ident=:{id_info},decl_pos,decl_kind,decl_index}) cs=:{cs_symbol_table} #! entry = sreadPtr id_info cs_symbol_table | entry.ste_def_level < cGlobalScope - # cs = { cs & cs_symbol_table = NewEntry cs_symbol_table id_info dcl_kind dcl_index cGlobalScope entry } - = case dcl_kind of + # cs = { cs & cs_symbol_table = NewEntry cs_symbol_table id_info decl_kind decl_index cGlobalScope entry } + = case decl_kind of STE_Field selector_id - -> addFieldToSelectorDefinition selector_id { glob_module = NoIndex, glob_object = dcl_index } cs + -> addFieldToSelectorDefinition selector_id { glob_module = NoIndex, glob_object = decl_index } cs _ -> cs - = { cs & cs_error = checkErrorWithIdentPos (newPosition ident dcl_pos) " multiply defined" cs.cs_error} + = { cs & cs_error = checkErrorWithIdentPos (newPosition ident decl_pos) " multiply defined" cs.cs_error} removeImportedSymbolsFromSymbolTable :: Declaration !*SymbolTable -> .SymbolTable -removeImportedSymbolsFromSymbolTable {dcl_ident=dcl_ident=:{id_info}, dcl_index} symbol_table +removeImportedSymbolsFromSymbolTable (Declaration {decl_ident=decl_ident=:{id_info}, decl_index}) symbol_table # ({ste_kind,ste_def_level,ste_previous}, symbol_table) = readPtr id_info symbol_table symbol_table = symbol_table <:= (id_info, ste_previous) = case ste_kind of STE_Imported (STE_Field selector_id) def_mod - -> removeFieldFromSelectorDefinition selector_id def_mod dcl_index symbol_table + -> removeFieldFromSelectorDefinition selector_id def_mod decl_index symbol_table _ -> symbol_table @@ -463,12 +470,12 @@ removeDeclarationsFromSymbolTable :: ![Declaration] !Int !*SymbolTable -> *Symbo removeDeclarationsFromSymbolTable decls scope symbol_table = foldSt (remove_declaration scope) decls symbol_table where - remove_declaration scope decl=:{dcl_ident={id_info}, dcl_index} symbol_table + remove_declaration scope decl=:(Declaration {decl_ident={id_info}, decl_index}) symbol_table # ({ste_kind,ste_previous}, symbol_table) = readPtr id_info symbol_table = case ste_kind of STE_Field field_id - # symbol_table = removeFieldFromSelectorDefinition field_id NoIndex dcl_index symbol_table + # symbol_table = removeFieldFromSelectorDefinition field_id NoIndex decl_index symbol_table | ste_previous.ste_def_level == scope -> symbol_table <:= (id_info, ste_previous.ste_previous) -> symbol_table <:= (id_info, ste_previous) @@ -522,12 +529,12 @@ newFreeVariable new_var [] local_declaration_for_import :: !u:Declaration .Index -> v:Declaration, [u <= v] -local_declaration_for_import decl=:{dcl_kind=STE_FunctionOrMacro _} module_n +local_declaration_for_import decl=:(Declaration {decl_kind=STE_FunctionOrMacro _}) module_n = decl -local_declaration_for_import decl=:{dcl_kind=STE_Imported _ _} module_n +local_declaration_for_import decl=:(Declaration {decl_kind=STE_Imported _ _}) module_n = abort "local_declaration_for_import" -local_declaration_for_import decl=:{dcl_kind} module_n - = {decl & dcl_kind = STE_Imported dcl_kind module_n} +local_declaration_for_import decl=:(Declaration declaration_record=:{decl_kind}) module_n + = Declaration {declaration_record & decl_kind = STE_Imported decl_kind module_n} get_ident :: !ImportDeclaration -> Ident @@ -627,12 +634,66 @@ instance <<< DeclarationInfo where (<<<) file {di_decl, di_instances} = file <<< di_decl <<< di_instances - + import_ident :: Ident import_ident =: { id_name = "import", id_info = nilPtr } +/* +ste_kind_to_string :: STE_Kind -> String +ste_kind_to_string ste_kind + = case ste_kind of + STE_FunctionOrMacro _ + -> "STE_FunctionOrMacro" + STE_Type + -> "STE_Type" + STE_Constructor + -> "STE_Constructor" + STE_Selector _ + -> "STE_Selector" + STE_Field _ + -> "STE_Field" + STE_Class + -> "STE_Class" + STE_Member + -> "STE_Member" + STE_Instance _ + -> "STE_Instance" + STE_Variable _ + -> "STE_Variable" + STE_TypeVariable _ + -> "STE_TypeVariable" + STE_TypeAttribute _ + -> "STE_TypeAttribute" + STE_BoundTypeVariable _ + -> "STE_BoundTypeVariable" + STE_Imported ste_kind2 _ + -> "STE_Imported "+++ste_kind_to_string ste_kind2 + STE_DclFunction + -> "STE_DclFunction" + STE_Module _ + -> "STE_Module" + STE_ClosedModule + -> "STE_ClosedModule" + STE_Empty + -> "STE_Empty" + STE_DictType _ + -> "STE_DictType" + STE_DictCons _ + -> "STE_DictCons" + STE_DictField _ + -> "STE_DictField" + STE_Called _ + -> "STE_Called" + STE_ExplImpSymbol _ + -> "STE_ExplImpSymbol" + STE_ExplImpComponentNrs _ _ + -> "STE_ExplImpComponentNrs" + STE_BelongingSymbol _ + -> "STE_BelongingSymbol" +*/ + restoreHeap :: !Ident !*SymbolTable -> .SymbolTable restoreHeap {id_info} cs_symbol_table - # ({ste_previous}, cs_symbol_table) + # ({ste_previous}, cs_symbol_table) = readPtr id_info cs_symbol_table - = writePtr id_info ste_previous cs_symbol_table + = writePtr id_info ste_previous cs_symbol_table diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index c50c9a5..9a6b601 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -1,7 +1,7 @@ implementation module checktypes import StdEnv -import syntax, checksupport, check, typesupport, utilities, RWSDebug +import syntax, checksupport, check, typesupport, utilities //, RWSDebug :: TypeSymbols = @@ -379,12 +379,14 @@ where look_for_cycles mod_index {at_type} expst = look_for_cycles mod_index at_type expst +import StdDebug + expandSynType :: !Index !Index !*ExpandState -> *ExpandState expandSynType mod_index type_index expst=:{exp_type_defs} # (type_def, exp_type_defs) = exp_type_defs![type_index] expst = { expst & exp_type_defs = exp_type_defs } = case type_def.td_rhs of - SynType type=:{at_type = TA {type_name,type_index={glob_object,glob_module}} types} + SynType type=:{at_type = TA {type_name,type_index={glob_object,glob_module}} types} # ({td_args,td_attribute,td_rhs}, _, exp_type_defs, exp_modules) = getTypeDef glob_object glob_module mod_index expst.exp_type_defs expst.exp_modules expst = { expst & exp_type_defs = exp_type_defs, exp_modules = exp_modules } -> case td_rhs of @@ -429,6 +431,26 @@ expand_syn_types module_index type_index nr_of_types expst # expst = expandSynType module_index type_index expst = expand_syn_types module_index (inc type_index) nr_of_types expst = expand_syn_types module_index (inc type_index) nr_of_types expst +/* +Tracea_tn a + # s=size a + # f=stderr + # r=t 0 f + with + t i f + | i<s && file_to_true (stderr <<< i <<< '\n' <<< a.[i] <<< '\n') + = t (i+1) f + = True + = r + +file_to_true :: !File -> Bool; +file_to_true file = code { + .inline file_to_true + pop_b 2 + pushB TRUE + .end + } +*/ expandSynonymTypes :: !.Index !*{#CheckedTypeDef} !*{#.DclModule} !*TypeHeaps !*ErrorAdmin -> (!.{#CheckedTypeDef},!.{#DclModule},!.TypeHeaps,!.ErrorAdmin) diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index 44374a4..beb6224 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -85,6 +85,12 @@ compareDefImp :: !{#Int} !{!FunctionBody} !Int !{#CheckedTypeDef} !DclModule !*I -> (!.IclModule,!.Heaps,!.ErrorAdmin) compareDefImp size_uncopied_icl_defs untransformed main_dcl_module_n icl_com_type_defs main_dcl_module icl_module heaps error_admin + + +// | print_function_body_array untransformed +// && print_function_body_array icl_module.icl_functions + + // icl definitions with indices >= size_uncopied_icl_defs.[def_type] don't have to be compared, // because they are copies of definitions that appear exclusively in the dcl module = case main_dcl_module.dcl_conversions of @@ -106,7 +112,7 @@ compareDefImp size_uncopied_icl_defs untransformed main_dcl_module_n icl_com_typ (_, tc_state, error_admin) = compareWithConversions size_uncopied_icl_defs.[cTypeDefs] conversion_table.[cTypeDefs] - dcl_common.com_type_defs icl_com_type_defs tc_state error_admin + dcl_common.com_unexpanded_type_defs icl_com_type_defs tc_state error_admin (icl_com_cons_defs, tc_state, error_admin) = compareWithConversions size_uncopied_icl_defs.[cConstructorDefs] conversion_table.[cConstructorDefs] @@ -867,6 +873,7 @@ continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_index icl_app_sy = ec_state = give_error icl_app_symb.symb_name ec_state where + names_are_compatible :: Int Int {#FunDef} -> Bool; names_are_compatible dcl_index icl_index icl_functions # dcl_function = icl_functions.[dcl_index] icl_function = icl_functions.[icl_index] @@ -930,3 +937,23 @@ do_nothing ec_state give_error s ec_state = { ec_state & ec_error_admin = checkError s error_message ec_state.ec_error_admin } +/* +print_function_body_array function_bodies + = print_function_bodies 0 + where + print_function_bodies i + | i<size function_bodies + = Trace_tn i && Trace_tn function_bodies.[i] && print_function_bodies (i+1) + = True; + +Trace_tn d + = file_to_true (stderr <<< d <<< '\n') + +file_to_true :: !File -> Bool; +file_to_true file = code { + .inline file_to_true + pop_b 2 + pushB TRUE + .end + }; +*/ diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index 5c2d6ff..a38f4aa 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -1124,7 +1124,7 @@ weightedRefCountOfCase dcl_functions common_defs depth this_case=:{case_expr, ca = weightedRefCountInPatternExpr rc_main_dcl_module_n dcl_functions common_defs depth expr info weighted_ref_count_in_default dcl_functions common_defs depth No info = ([], info) - + weighted_ref_count_in_case_patterns dcl_functions common_defs depth (AlgebraicPatterns type patterns) collected_imports var_heap expr_heap = mapSt (weighted_ref_count_in_algebraic_pattern dcl_functions common_defs depth) patterns ([], collected_imports, var_heap, expr_heap) where @@ -1411,7 +1411,7 @@ my_zip [x:xs][y:ys] = [(x,y) : my_zip xs ys] instance distributeLets Case where - distributeLets depth kees=:{case_info_ptr,case_guards,case_default,case_expr} dl_info=:{di_var_heap, di_expr_heap} + distributeLets depth kees=:{case_info_ptr,case_guards,case_default,case_expr} dl_info=:{di_var_heap, di_expr_heap} # (EI_CaseTypeAndRefCounts case_type { rcc_all_variables = tot_ref_counts , rcc_default_variables = ref_counts_in_default, rcc_pattern_variables = ref_counts_in_patterns }, di_expr_heap) = readPtr case_info_ptr di_expr_heap // di_expr_heap = di_expr_heap <:= (case_info_ptr, EI_CaseType case_type) new_depth = inc depth @@ -1567,10 +1567,15 @@ where instance <<< (Ptr a) where (<<<) file ptr = file <<< ptrToInt ptr +/* +instance <<< BoundVar +where + (<<<) file {var_name,var_info_ptr} = file <<< var_name <<< '[' <<< var_info_ptr <<< ']' instance <<< FunctionBody where (<<<) file (TransformedBody {tb_rhs}) = file <<< tb_rhs +*/ instance <<< CountedVariable where diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl index 3485570..515fd17 100644 --- a/frontend/explicitimports.icl +++ b/frontend/explicitimports.icl @@ -10,7 +10,7 @@ import StdEnv , fs_error :: !.ErrorAdmin } -import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef, RWSDebug, cheat +import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef, cheat//, RWSDebug cUndef :== (-1) implies a b :== not a || b @@ -25,7 +25,6 @@ implies a b :== not a || b , si_implicit :: ![(Index, Position)] // module indices } - markExplImpSymbols :: !Int !*(!*{!*{!u:ExplImpInfo}}, !*SymbolTable) -> (!.[Ident],!(!{!{!u:ExplImpInfo}},!.SymbolTable)) markExplImpSymbols component_nr (expl_imp_info, cs_symbol_table) @@ -61,8 +60,6 @@ markExplImpSymbols component_nr (expl_imp_info, cs_symbol_table) (eii_ident, eii) = get_eei_ident eii = (eii_ident, { expl_imp_info & [component_nr, i] = eii }) - - updateExplImpForMarkedSymbol :: !Index !Declaration !SymbolTableEntry !u:{#DclModule} !{!{!*ExplImpInfo}} !*SymbolTable -> (!u:{#DclModule}, !{!{!.ExplImpInfo}}, !.SymbolTable) @@ -73,7 +70,6 @@ updateExplImpForMarkedSymbol mod_index decl {ste_kind=STE_ExplImpComponentNrs co updateExplImpForMarkedSymbol _ _ entry dcl_modules expl_imp_infos cs_symbol_table = (dcl_modules, expl_imp_infos, cs_symbol_table) - addExplImpInfo :: !Index Declaration ![Declaration] !ComponentNrAndIndex !(!u:{#DclModule}, !{!{!*ExplImpInfo}}, !v:SymbolTable) -> (!u:{#DclModule}, !{!{!.ExplImpInfo}}, !v:SymbolTable) addExplImpInfo mod_index decl instances { cai_component_nr, cai_index } (dcl_modules, expl_imp_infos, cs_symbol_table) @@ -108,12 +104,11 @@ addExplImpInfo mod_index decl instances { cai_component_nr, cai_index } (dcl_mod , cs_symbol_table ) - optStoreInstanceWithClassSymbol :: Declaration !Ident !*SymbolTable -> .SymbolTable optStoreInstanceWithClassSymbol decl class_ident cs_symbol_table // this function is only for old syntax | switch_import_syntax False True - = cs_symbol_table + = cs_symbol_table # (class_ste, cs_symbol_table) = readPtr class_ident.id_info cs_symbol_table = case class_ste.ste_kind of @@ -124,8 +119,6 @@ optStoreInstanceWithClassSymbol decl class_ident cs_symbol_table _ -> cs_symbol_table - - foldlBelongingSymbols f bs st :== case bs of BS_Constructors constructors @@ -136,6 +129,18 @@ foldlBelongingSymbols f bs st -> foldlArraySt (\{ds_ident} st -> f ds_ident st) members st BS_Nothing -> st +/* +imp_decl_to_string (ID_Function {ii_ident={id_name}}) = "ID_Function "+++toString id_name +imp_decl_to_string (ID_Class {ii_ident={id_name}} _) = "ID_Class "+++toString id_name +imp_decl_to_string (ID_Type {ii_ident={id_name}} _) = "ID_Type "+++toString id_name +imp_decl_to_string (ID_Record {ii_ident={id_name}} _) = "ID_Record "+++toString id_name +imp_decl_to_string (ID_Instance {ii_ident={id_name}} _ _ ) = "ID_Instance "+++toString id_name +imp_decl_to_string (ID_OldSyntax idents) = "ID_OldSyntax "+++idents_to_string idents + where + idents_to_string [] = "" + idents_to_string [{id_name}] = toString id_name + idents_to_string [{id_name}:l] = toString id_name+++","+++idents_to_string l +*/ solveExplicitImports :: !(IntKeyHashtable [(Int,Position,[ImportNrAndIdents])]) !{#Int} !Index !*(!v:{#DclModule},!*{#Int},!{!*ExplImpInfo},!*CheckState) @@ -238,30 +243,30 @@ solveExplicitImports expl_imp_indices_ikh modules_in_component_set importing_mod = abort "sanity check nr 2765 failed in module check" = eii_declaring_modules - get_nth_belonging_decl position belong_nr decl dcl_modules - # (STE_Imported _ def_mod_index) = decl.dcl_kind + get_nth_belonging_decl position belong_nr decl=:(Declaration {decl_kind}) dcl_modules + # (STE_Imported _ def_mod_index) = decl_kind (belongin_symbols, dcl_modules) = getBelongingSymbols decl dcl_modules = case belongin_symbols of BS_Constructors constructors # {ds_ident, ds_index} = constructors!!belong_nr - -> ({ dcl_ident = ds_ident, dcl_pos = position, - dcl_kind = STE_Imported STE_Constructor def_mod_index, - dcl_index = ds_index }, dcl_modules) + -> (Declaration { decl_ident = ds_ident, decl_pos = position, + decl_kind = STE_Imported STE_Constructor def_mod_index, + decl_index = ds_index }, dcl_modules) BS_Fields rt_fields # {fs_name, fs_index} = rt_fields.[belong_nr] ({sd_symb}, dcl_modules) = dcl_modules![def_mod_index].dcl_common.com_selector_defs.[fs_index] - -> ({ dcl_ident = fs_name, dcl_pos = position, - dcl_kind = STE_Imported (STE_Field sd_symb) def_mod_index, - dcl_index = fs_index }, dcl_modules) + -> (Declaration { decl_ident = fs_name, decl_pos = position, + decl_kind = STE_Imported (STE_Field sd_symb) def_mod_index, + decl_index = fs_index }, dcl_modules) BS_Members class_members # {ds_ident, ds_index} = class_members.[belong_nr] - -> ({ dcl_ident = ds_ident, dcl_pos = position, - dcl_kind = STE_Imported STE_Member def_mod_index, - dcl_index = ds_index }, dcl_modules) + -> (Declaration { decl_ident = ds_ident, decl_pos = position, + decl_kind = STE_Imported STE_Member def_mod_index, + decl_index = ds_index }, dcl_modules) - get_all_belongs decl dcl_modules + get_all_belongs decl=:(Declaration {decl_kind,decl_index}) dcl_modules # (belonging_symbols, dcl_modules) = getBelongingSymbols decl dcl_modules = case belonging_symbols of @@ -270,9 +275,9 @@ solveExplicitImports expl_imp_indices_ikh modules_in_component_set importing_mod BS_Fields rt_fields -> ([fs_name \\ {fs_name}<-:rt_fields], dcl_modules) BS_Members class_members - # (STE_Imported _ def_mod_index) = decl.dcl_kind + # (STE_Imported _ def_mod_index) = decl_kind ({class_members}, dcl_modules) - = dcl_modules![def_mod_index].dcl_common.com_class_defs.[decl.dcl_index] + = dcl_modules![def_mod_index].dcl_common.com_class_defs.[decl_index] -> ([ds_ident \\ {ds_ident}<-:class_members], dcl_modules) BS_Nothing -> ([], dcl_modules) @@ -392,7 +397,6 @@ solveExplicitImports expl_imp_indices_ikh modules_in_component_set importing_mod = (True, getBelongingSymbolsFromID ini_imp_decl) = search_imported_symbol imported_symbol t - belong_ident_found :: !Ident !(Optional [ImportedIdent]) -> Bool belong_ident_found belong_ident No // like from m import ::T @@ -457,7 +461,6 @@ solveExplicitImports expl_imp_indices_ikh modules_in_component_set importing_mod impDeclToNameSpaceString (ID_Record _ _) = "type" impDeclToNameSpaceString (ID_Instance _ _ _)= "instance" - get_eei_ident (eii=:ExplImpInfo eii_ident _) = (eii_ident, eii) :: CheckCompletenessState = @@ -503,11 +506,11 @@ checkExplicitImportCompleteness dcls_explicit dcl_modules icl_functions expr_hea = (ccs_dcl_modules, ccs_icl_functions, ccs_expr_heap, cs) where checkCompleteness :: !Int !Position !Declaration !*CheckCompletenessStateBox -> *CheckCompletenessStateBox - checkCompleteness main_dcl_module_n import_position {dcl_ident, dcl_index, dcl_kind=STE_FunctionOrMacro _} ccs - = checkCompletenessOfMacro dcl_ident dcl_index main_dcl_module_n import_position ccs - checkCompleteness main_dcl_module_n import_position {dcl_ident, dcl_index, dcl_kind=STE_Imported (STE_FunctionOrMacro _) mod_index} ccs - = checkCompletenessOfMacro dcl_ident dcl_index main_dcl_module_n import_position ccs - checkCompleteness main_dcl_module_n import_position {dcl_ident, dcl_index, dcl_kind=STE_Imported expl_imp_kind mod_index} ccs + checkCompleteness main_dcl_module_n import_position (Declaration {decl_ident, decl_index, decl_kind=STE_FunctionOrMacro _}) ccs + = checkCompletenessOfMacro decl_ident decl_index main_dcl_module_n import_position ccs + checkCompleteness main_dcl_module_n import_position (Declaration {decl_ident, decl_index, decl_kind=STE_Imported (STE_FunctionOrMacro _) mod_index}) ccs + = checkCompletenessOfMacro decl_ident decl_index main_dcl_module_n import_position ccs + checkCompleteness main_dcl_module_n import_position (Declaration {decl_ident, decl_index, decl_kind=STE_Imported expl_imp_kind mod_index}) ccs #! ({dcl_common,dcl_functions}, ccs) = ccs!box_ccs.ccs_dcl_modules.[mod_index] cci = { box_cci = { cci_import_position = import_position, cci_main_dcl_module_n=main_dcl_module_n }} = continuation expl_imp_kind dcl_common dcl_functions cci ccs @@ -515,24 +518,24 @@ checkExplicitImportCompleteness dcls_explicit dcl_modules icl_functions expr_hea continuation :: !STE_Kind CommonDefs !{# FunType} !CheckCompletenessInputBox !*CheckCompletenessStateBox -> *CheckCompletenessStateBox continuation STE_Type dcl_common dcl_functions cci ccs - = check_completeness dcl_common.com_type_defs.[dcl_index] cci ccs + = check_completeness dcl_common.com_type_defs.[decl_index] cci ccs continuation STE_Constructor dcl_common dcl_functions cci ccs - = check_completeness dcl_common.com_cons_defs.[dcl_index] cci ccs + = check_completeness dcl_common.com_cons_defs.[decl_index] cci ccs continuation (STE_Field _) dcl_common dcl_functions cci ccs - = check_completeness dcl_common.com_selector_defs.[dcl_index] cci ccs + = check_completeness dcl_common.com_selector_defs.[decl_index] cci ccs continuation STE_Class dcl_common dcl_functions cci ccs - = check_completeness dcl_common.com_class_defs.[dcl_index] cci ccs + = check_completeness dcl_common.com_class_defs.[decl_index] cci ccs continuation STE_Member dcl_common dcl_functions cci ccs - = check_completeness dcl_common.com_member_defs.[dcl_index] cci ccs + = check_completeness dcl_common.com_member_defs.[decl_index] cci ccs continuation (STE_Instance _) dcl_common dcl_functions cci ccs - = check_completeness dcl_common.com_instance_defs.[dcl_index] cci ccs + = check_completeness dcl_common.com_instance_defs.[decl_index] cci ccs continuation STE_DclFunction dcl_common dcl_functions cci ccs - = check_completeness dcl_functions.[dcl_index] cci ccs + = check_completeness dcl_functions.[decl_index] cci ccs checkCompletenessOfMacro :: !Ident !Index !Int !Position !*CheckCompletenessStateBox -> *CheckCompletenessStateBox - checkCompletenessOfMacro dcl_ident dcl_index main_dcl_module_n import_position ccs - #! ({fun_body}, ccs) = ccs!box_ccs.ccs_icl_functions.[dcl_index] - ccs = { ccs & box_ccs.ccs_set_of_visited_icl_funs.[dcl_index] = True } + checkCompletenessOfMacro decl_ident decl_index main_dcl_module_n import_position ccs + #! ({fun_body}, ccs) = ccs!box_ccs.ccs_icl_functions.[decl_index] + ccs = { ccs & box_ccs.ccs_set_of_visited_icl_funs.[decl_index] = True } cci = { box_cci = { cci_import_position = import_position, cci_main_dcl_module_n=main_dcl_module_n }} = check_completeness fun_body cci ccs @@ -687,7 +690,7 @@ instance check_completeness Expression where o (check_completeness expr2) cci ) ccs check_completeness expr _ _ - = abort "explicitimports:check_completeness (Expression) does not match" <<- expr + = abort "explicitimports:check_completeness (Expression) does not match" //<<- expr instance check_completeness FunctionBody where check_completeness (CheckedBody body) cci ccs diff --git a/frontend/hashtable.icl b/frontend/hashtable.icl index e9ebca4..1ca48b5 100644 --- a/frontend/hashtable.icl +++ b/frontend/hashtable.icl @@ -3,7 +3,7 @@ implementation module hashtable import predef, syntax, StdCompare, compare_constructor :: HashTableEntry - = HTE_Ident !Ident !IdentClass !Int !HashTableEntry !HashTableEntry + = HTE_Ident !BoxedIdent !IdentClass !Int !HashTableEntry !HashTableEntry | HTE_Empty :: HashTable = @@ -115,11 +115,15 @@ where insert name ident_class hte_mark0 hte_symbol_heap HTE_Empty # (hte_symbol_ptr, hte_symbol_heap) = newPtr EmptySymbolTableEntry hte_symbol_heap # ident = { id_name = name, id_info = hte_symbol_ptr} - = ({boxed_ident=ident}, hte_symbol_heap, HTE_Ident ident ident_class hte_mark0 HTE_Empty HTE_Empty) - insert name ident_class hte_mark0 hte_symbol_heap (HTE_Ident hte_ident=:{id_name,id_info} hte_class hte_mark hte_left hte_right) +// = ({boxed_ident=ident}, hte_symbol_heap, HTE_Ident ident ident_class hte_mark0 HTE_Empty HTE_Empty) + # boxed_ident={boxed_ident=ident} + = (boxed_ident, hte_symbol_heap, HTE_Ident boxed_ident ident_class hte_mark0 HTE_Empty HTE_Empty) +// insert name ident_class hte_mark0 hte_symbol_heap (HTE_Ident hte_ident=:{id_name,id_info} hte_class hte_mark hte_left hte_right) + insert name ident_class hte_mark0 hte_symbol_heap (HTE_Ident hte_ident=:{boxed_ident={id_name,id_info}} hte_class hte_mark hte_left hte_right) # cmp = (name,ident_class) =< (id_name,hte_class) | cmp == Equal - = ({boxed_ident=hte_ident}, hte_symbol_heap, HTE_Ident hte_ident hte_class (hte_mark bitand hte_mark0) hte_left hte_right) +// = ({boxed_ident=hte_ident}, hte_symbol_heap, HTE_Ident hte_ident hte_class (hte_mark bitand hte_mark0) hte_left hte_right) + = (hte_ident, hte_symbol_heap, HTE_Ident hte_ident hte_class (hte_mark bitand hte_mark0) hte_left hte_right) | cmp == Smaller #! (boxed_ident, hte_symbol_heap, hte_left) = insert name ident_class hte_mark0 hte_symbol_heap hte_left = (boxed_ident, hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right) diff --git a/frontend/main.icl b/frontend/main.icl index f653f88..a796406 100644 --- a/frontend/main.icl +++ b/frontend/main.icl @@ -19,7 +19,6 @@ Start world (ms.ms_out, ms.ms_files))) world = fclose ms_out world - CommandLoop proj ms=:{ms_io} # (answer, ms_io) = freadline (ms_io <<< "> ") (command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer)) @@ -43,7 +42,7 @@ CommandLoop proj ms=:{ms_io} } -:: *MainState funs funtypes types conses classes instances members selectors = +:: *MainState = { ms_io :: !*File , ms_error :: !*File , ms_out :: !*File @@ -51,48 +50,68 @@ CommandLoop proj ms=:{ms_io} , ms_files :: !*Files } -:: ModuleTree = ModuleNode !InterMod !ModuleTree !ModuleTree | NoModules +:: InterMod = + { inter_name :: !String + , inter_modules :: !{# String} +/* , inter_fun_defs :: !{# FunDef} + , inter_icl_dcl_conversions :: !Optional {# Index} +*/ + } + +:: ModuleTree = ModuleNode !String !ModuleTree !ModuleTree | NoModules -containsModule name (ModuleNode {inter_name = {id_name}} left right) - # cmp = id_name =< name - | cmp == Equal +containsModule name (ModuleNode inter_name left right) + | inter_name == name = True - | cmp == Smaller + | inter_name < name = containsModule name right = containsModule name left containsModule name NoModules = False -addModule name mod tree=:(ModuleNode this_mod=:{inter_name = {id_name}} left right) - # cmp = id_name =< name - | cmp == Equal +addModule name mod tree=:(ModuleNode this_mod left right) + | this_mod == name = tree - | cmp == Smaller + | this_mod < name = ModuleNode this_mod left (addModule name mod right) = ModuleNode this_mod (addModule name mod left) right addModule _ mod NoModules = ModuleNode mod NoModules NoModules +:: DclCache = { + dcl_modules::!{#DclModule}, + functions_and_macros::!{#FunDef}, + predef_symbols::!.PredefinedSymbols, + hash_table::!.HashTable, + heaps::!.Heaps + }; + :: Project = - { proj_main_module :: !Ident - , proj_hash_table :: !.HashTable - , proj_predef_symbols :: !.PredefinedSymbols + { proj_main_module :: !String , proj_modules :: !ModuleTree + , proj_cache :: !.DclCache } -:: InterMod = - { inter_name :: Ident - , inter_modules :: !{# Ident} - , inter_fun_defs :: !{# FunDef} - , inter_icl_dcl_conversions :: !Optional {# Index} - , inter_dcl_icl_conversions :: !Optional {# Index} - } - +empty_cache :: *DclCache +empty_cache + # heaps = {hp_var_heap = newHeap, hp_expression_heap = newHeap, hp_type_heaps = {th_vars = newHeap, th_attrs = newHeap}} + # (predef_symbols, hash_table) = buildPredefinedSymbols newHashTable + = {dcl_modules={},functions_and_macros={},predef_symbols=predef_symbols,hash_table=hash_table,heaps=heaps} DoCommand ['c':_] argument proj ms # (file_name, rest_input) = SplitAtLayoutChar (dropWhile isSpace argument) - (opt_mod, ms) = compileModule (toString file_name) ms + (opt_mod,dcl_cache,ms) = compileModule (toString file_name) empty_cache ms = (False, proj, ms) + +DoCommand ['m':_] argument proj ms + # (file_name, rest_input) = SplitAtLayoutChar (dropWhile isSpace argument) + # mod_name = toString file_name + # dcl_cache=empty_cache + # (opt_mod, ms) = makeProject { proj_main_module=mod_name, + proj_modules=NoModules, + proj_cache=dcl_cache} ms + = (False, proj, ms) + DoCommand ['s':_] argument proj ms=:{ms_io, ms_files} # (file_name, rest_input) = SplitAtLayoutChar (dropWhile isSpace argument) file_name = toString (file_name++['.icl']) @@ -100,26 +119,33 @@ DoCommand ['s':_] argument proj ms=:{ms_io, ms_files} (lines,file) = freadlines file (ok,files) = fclose file files = (False, proj, {ms & ms_io = ms_io <<< ("file "+++file_name+++" "+++toString (length lines)+++" lines\n") <<< lines <<< "\n", ms_files = files}) + DoCommand ['t':_] argument proj ms=:{ms_files, ms_io} # (file_names, ms_files, ms_io) = converFileToListOfStrings "testfiles" ms_files ms_io - = (False, proj, foldSt check_module file_names { ms & ms_files = ms_files, ms_io = ms_io }) + # (dcl_cache,ms) = foldSt check_module file_names (empty_cache,{ ms & ms_files = ms_files, ms_io = ms_io }) + = (False, proj, ms) where - check_module file_name ms - # (opt_mod, ms) = compileModule file_name (ms ---> file_name) + check_module file_name (dcl_cache,ms) + # ms = {ms & ms_io = ms.ms_io <<< "Compiling " <<< file_name <<< "\n"} + # (opt_mod, dcl_cache,ms) = compileModule file_name dcl_cache ms = case opt_mod of No - -> { ms & ms_io = ms.ms_io <<< file_name <<< " is not OK\n" } + -> (dcl_cache,{ ms & ms_io = ms.ms_io <<< file_name <<< " is not OK\n" }) _ - -> ms + -> (dcl_cache,ms) + DoCommand ['p':_] argument proj ms=:{ms_io, ms_files} # (file_name, rest_input) = SplitAtLayoutChar (dropWhile isSpace argument) (predef_symbols, hash_table) = buildPredefinedSymbols newHashTable (mod_ident, hash_table) = putIdentInHashTable (toString file_name) IC_Module hash_table - = (False, Yes { proj_main_module = mod_ident.boxed_ident, proj_hash_table = hash_table, proj_predef_symbols = predef_symbols, proj_modules = NoModules }, ms) + = (False, Yes { proj_main_module = mod_ident.boxed_ident.id_name,proj_modules = NoModules,proj_cache=empty_cache }, ms) + DoCommand ['q':_] argument proj ms = (True, proj, ms) + DoCommand ['h':_] argument proj ms=:{ms_io} = (False, proj, {ms & ms_io = ms_io <<< "No help available. Sorry.\n"}) + DoCommand command argument proj ms=:{ms_io} = (False, proj, {ms & ms_io = ms_io <<< toString command <<< "?\n"}) @@ -139,79 +165,111 @@ SplitAtLayoutChar [x:xs] where (word, rest_input) = SplitAtLayoutChar xs -compileModule mod_name ms - # (predef_symbols, hash_table) = buildPredefinedSymbols newHashTable - (mod_ident, hash_table) = putIdentInHashTable mod_name IC_Module hash_table - (opt_module, predef_symbols, hash_table, ms) = loadModule mod_ident.boxed_ident predef_symbols hash_table ms - = (opt_module, ms) - -loadModule mod_ident predef_symbols hash_table ms=:{ms_files,ms_error,ms_io,ms_out,ms_paths} - # heaps = { hp_var_heap = newHeap, hp_expression_heap = newHeap, hp_type_heaps = { th_vars = newHeap, th_attrs = newHeap }} - # (optional_syntax_tree,_,_,_,predef_symbols, hash_table, ms_files, ms_error, ms_io, ms_out,_,_) - = frontEndInterface FrontEndPhaseAll mod_ident {sp_locations = [], sp_paths = ms_paths} {} {} No predef_symbols hash_table ms_files ms_error ms_io ms_out No heaps +compileModule :: String *DclCache *MainState -> *(!Optional InterMod,!*DclCache,!*MainState); +compileModule mod_name dcl_cache ms + # (mod_ident, hash_table) = putIdentInHashTable mod_name IC_Module dcl_cache.hash_table + dcl_cache = {dcl_cache & hash_table=hash_table} + = loadModule mod_ident.boxed_ident dcl_cache ms + +loadModule :: Ident *DclCache *MainState -> *(!Optional InterMod,!*DclCache,!*MainState); +loadModule mod_ident {dcl_modules,functions_and_macros,predef_symbols,hash_table,heaps} ms=:{ms_files,ms_error,ms_io,ms_out,ms_paths} + # (optional_syntax_tree,cached_functions_and_macros,_,main_dcl_module_n,predef_symbols, hash_table, ms_files, ms_error, ms_io, ms_out,_,heaps) + = frontEndInterface FrontEndPhaseAll mod_ident {sp_locations = [], sp_paths = ms_paths} dcl_modules functions_and_macros No predef_symbols hash_table ms_files ms_error ms_io ms_out No heaps # ms = {ms & ms_files=ms_files, ms_error=ms_error,ms_io=ms_io,ms_out=ms_out} = case optional_syntax_tree of - Yes {fe_icl={icl_functions}, fe_dcls, fe_dclIclConversions, fe_iclDclConversions} - -> (Yes (buildInterMod mod_ident fe_dcls icl_functions fe_dclIclConversions fe_iclDclConversions), predef_symbols, hash_table, ms) + Yes {fe_icl={/*icl_functions,*/icl_used_module_numbers}, fe_dcls, fe_dclIclConversions, fe_iclDclConversions} + # dcl_modules={{dcl_module \\ dcl_module<-:fe_dcls} & [main_dcl_module_n].dcl_conversions=No} + # var_heap = remove_expanded_types_from_dcl_modules 0 dcl_modules icl_used_module_numbers heaps.hp_var_heap + # heaps = {heaps & hp_var_heap = var_heap } + -> (Yes (buildInterMod mod_ident icl_used_module_numbers fe_dcls /*icl_functions fe_dclIclConversions fe_iclDclConversions*/), + {dcl_modules=dcl_modules,functions_and_macros=cached_functions_and_macros,predef_symbols=predef_symbols,hash_table=hash_table,heaps=heaps}, ms) No - -> (No, predef_symbols, hash_table, ms) + -> (No, {dcl_modules=dcl_modules,functions_and_macros=cached_functions_and_macros,predef_symbols=predef_symbols,hash_table=hash_table,heaps=heaps},ms) -makeProject (Yes proj=:{proj_main_module,proj_hash_table,proj_predef_symbols}) ms - # (main_mod, proj_predef_symbols, proj_hash_table, ms) = loadModule proj_main_module proj_predef_symbols proj_hash_table ms - proj = { proj & proj_hash_table = proj_hash_table, proj_predef_symbols = proj_predef_symbols } +remove_expanded_types_from_dcl_modules :: Int {#DclModule} NumberSet *VarHeap -> *VarHeap +remove_expanded_types_from_dcl_modules module_n dcls used_module_numbers var_heap + | module_n<size dcls + | module_n==cPredefinedModuleIndex || not (inNumberSet module_n used_module_numbers) + = remove_expanded_types_from_dcl_modules (module_n+1) dcls used_module_numbers var_heap + # var_heap = remove_expanded_types_from_dcl_module 0 dcls.[module_n].dcl_functions var_heap + with + remove_expanded_types_from_dcl_module :: Int {#FunType} *VarHeap -> *VarHeap + remove_expanded_types_from_dcl_module function_n dcl_functions var_heap + | function_n<size dcl_functions + # {ft_type_ptr} = dcl_functions.[function_n] + # (ft_type,var_heap) = readPtr ft_type_ptr var_heap + = case ft_type of + VI_ExpandedType expandedType + # var_heap = writePtr ft_type_ptr VI_Empty var_heap + -> remove_expanded_types_from_dcl_module (function_n+1) dcl_functions var_heap + _ + -> remove_expanded_types_from_dcl_module (function_n+1) dcl_functions var_heap + = var_heap + = remove_expanded_types_from_dcl_modules (module_n+1) dcls used_module_numbers var_heap + = var_heap + +choose_random_module random_n modules + # n_modules = length modules; + # module_n = toInt (random_n*toReal n_modules) + # module_n = if (module_n<0) 0 (if (module_n>=n_modules) (n_modules-1) module_n) + # r = find_and_remove_module 0 modules; + with + find_and_remove_module n [modjule:modules] + | n==module_n + = (modjule,modules); + # (found_module,modules) = find_and_remove_module (n+1) modules; + = (found_module,[modjule:modules]); + = r; + +//import MersenneTwister + +makeProject :: *Project *MainState -> *(!Optional Project,!*MainState); +makeProject proj=:{proj_main_module,proj_cache} ms + # (main_mod,dcl_cache,ms) = compileModule proj_main_module proj_cache ms + # proj = {proj & proj_cache=dcl_cache} = case main_mod of Yes main_mod=:{inter_modules} - # (proj_modules, ms) = collect_modules [ mod \\ mod <-: inter_modules ] (ModuleNode main_mod NoModules NoModules) ms +// # random_numbers = genRandReal 100; + # random_numbers = [] + # (proj_modules,proj,ms) = collect_modules [ mod \\ mod <-: inter_modules ] (ModuleNode main_mod.inter_name NoModules NoModules) random_numbers proj ms -> (Yes { proj & proj_modules = proj_modules }, ms) _ - -> (Yes proj, ms) + -> (Yes proj,ms) where - collect_modules [{id_name} : modules] collected_modules ms + collect_modules :: [String] ModuleTree [Real] *Project *MainState -> *(!ModuleTree,!*Project,!*MainState); + collect_modules [] collected_modules random_numbers proj ms + = (collected_modules,proj,ms) + collect_modules [id_name : modules] collected_modules random_numbers proj ms +// collect_modules modules collected_modules [random_number:random_numbers] proj ms +// # (id_name,modules) = choose_random_module random_number modules + | id_name=="_predefined" + = collect_modules modules collected_modules random_numbers proj ms | containsModule id_name collected_modules - = collect_modules modules collected_modules ms - # (this_mod, ms) = compileModule id_name ms + = collect_modules modules collected_modules random_numbers proj ms + # ms = {ms & ms_io = ms.ms_io <<< "Compiling " <<< id_name <<< "\n"} + # dcl_cache = proj.proj_cache +// # dcl_cache = empty_cache + # (this_mod,dcl_cache,ms) = compileModule id_name dcl_cache ms + # proj = {proj & proj_cache=dcl_cache} = case this_mod of Yes new_mod - -> collect_modules (modules ++ [ mod \\ mod <-: new_mod.inter_modules ]) (addModule id_name new_mod collected_modules) ms + # collected_modules = addModule id_name new_mod.inter_name collected_modules + # modules = modules ++ [ mod \\ mod <-: new_mod.inter_modules | not (containsModule mod collected_modules) && not (isMember mod modules)] + -> collect_modules modules collected_modules random_numbers proj ms _ - -> (NoModules, ms) - collect_modules [{id_name} : modules] collected_modules ms - = (collected_modules, ms) + # ms = {ms & ms_io = ms.ms_io <<< "Compiling " <<< id_name <<< " failed \n"} + -> collect_modules modules collected_modules random_numbers proj ms +// -> (NoModules, ms) -buildInterMod name dcl_modules fun_defs dcl_icl_conversions /* RWS ... */ icl_dcl_conversions /* ... RWS */ - = { inter_name = name - , inter_modules = { dcl_name \\ {dcl_name} <-: dcl_modules } +buildInterMod name icl_used_module_numbers dcl_modules // fun_defs dcl_icl_conversions icl_dcl_conversions + # used_dcl_modules = [modjule \\ modjule <-: dcl_modules & module_n<-[0..] | inNumberSet module_n icl_used_module_numbers ] + = { inter_name = name.id_name + , inter_modules = { dcl_name.id_name \\ {dcl_name} <- used_dcl_modules } +/* , inter_fun_defs = fun_defs -/* RWS ... - , inter_icl_dcl_conversions = build_icl_dcl_conversions (size fun_defs) dcl_icl_conversions -*/ , inter_icl_dcl_conversions = icl_dcl_conversions -/* ... RWS */ - , inter_dcl_icl_conversions = dcl_icl_conversions - } -/* RWS -where - build_icl_dcl_conversions table_size (Yes conversion_table) - # dcl_table_size = size conversion_table - icl_dcl_conversions = update_conversion_array 0 dcl_table_size conversion_table (createArray table_size NoIndex) - = Yes (fill_empty_positions 0 table_size dcl_table_size icl_dcl_conversions) - build_icl_dcl_conversions table_size No - = No - - update_conversion_array dcl_index dcl_table_size conversion_table icl_conversions - | dcl_index < dcl_table_size - # icl_index = conversion_table.[dcl_index] - = update_conversion_array (inc dcl_index) dcl_table_size conversion_table - { icl_conversions & [icl_index] = dcl_index } - = icl_conversions - - fill_empty_positions next_index table_size next_new_index icl_conversions - | next_index < table_size - | icl_conversions.[next_index] == NoIndex - = fill_empty_positions (inc next_index) table_size (inc next_new_index) { icl_conversions & [next_index] = next_new_index } - = fill_empty_positions (inc next_index) table_size next_new_index icl_conversions - = icl_conversions */ + } /* RWS showComponents :: !*{! Group} !Int !Bool !*{# FunDef} !*File -> (!*{! Group}, !*{# FunDef},!*File) @@ -231,7 +289,6 @@ where = show_component funs show_types fun_defs (file <<< fun_def) // = show_component funs show_types fun_defs (file <<< fun_def.fun_symb) - showComponents2 :: !{! Group} !Int !*{# FunDef} !{! ConsClasses} !*File -> (!*{# FunDef},!*File) showComponents2 comps comp_index fun_defs acc_args file | comp_index >= (size comps) diff --git a/frontend/overloading.icl b/frontend/overloading.icl index a81c1b9..bd16b9e 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -96,7 +96,6 @@ instanceError symbol types err = { err & ea_file = err.ea_file <<< " \"" <<< symbol <<< "\" no instance available of type " <:: (format, types, Yes initialTypeVarBeautifulizer) <<< '\n' } - uniqueError symbol types err # err = errorHeading "Overloading/Uniqueness error" err format = { form_properties = cAnnotated, form_attr_position = No } diff --git a/frontend/parse.icl b/frontend/parse.icl index 0acf7ef..54e8f08 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -4,7 +4,8 @@ import StdEnv import scanner, syntax, hashtable, utilities, predef ParseOnly :== False -import RWSDebug + +//import RWSDebug toLineAndColumn {fp_line, fp_col} = {lc_line = fp_line, lc_column = fp_col} diff --git a/frontend/refmark.icl b/frontend/refmark.icl index 46d369d..275c915 100644 --- a/frontend/refmark.icl +++ b/frontend/refmark.icl @@ -1,7 +1,7 @@ implementation module refmark import StdEnv -import syntax, Heap, typesupport, check, overloading, unitype, utilities, RWSDebug +import syntax, Heap, typesupport, check, overloading, unitype, utilities //, RWSDebug NotASelector :== -1 @@ -522,7 +522,7 @@ where VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [], occ_observing = False, occ_bind = OB_Empty }), expr_heap) _ - -> abort ("initial_occurrence (remark.icl)" ---> ((fv_name,fv_info_ptr) <<- var_info)) + -> abort ("initial_occurrence (refmark.icl)" ---> ((fv_name,fv_info_ptr) ))//<<- var_info)) make_shared_vars_non_unique vars coercion_env var_heap expr_heap error @@ -553,7 +553,7 @@ where -> (coercion_env, expr_heap, error) -> (coercion_env, expr_heap, uniquenessError (CP_Expression (FreeVar free_var)) " demanded attribute cannot be offered by shared object" error) _ - -> abort ("make_shared_occurrence_non_unique" ---> ((free_var, var_expr_ptr) <<- expr_info)) + -> abort ("make_shared_occurrence_non_unique" ---> ((free_var, var_expr_ptr) )) // <<- expr_info)) make_selection_non_unique fv {su_multiply} cee = make_shared_occurrences_non_unique fv su_multiply cee diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index f186ef8..e910c78 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -66,11 +66,13 @@ instance toString Ident */ | STE_BelongingSymbol !Int -:: Declaration = - { dcl_ident :: !Ident - , dcl_pos :: !Position - , dcl_kind :: !STE_Kind - , dcl_index :: !Index +:: Declaration = Declaration !DeclarationRecord + +:: DeclarationRecord = + { decl_ident :: !Ident + , decl_pos :: !Position + , decl_kind :: !STE_Kind + , decl_index :: !Index } :: ComponentNrAndIndex = @@ -1061,7 +1063,7 @@ cIsNotStrict :== False | Update !Expression ![Selection] Expression | RecordUpdate !(Global DefinedSymbol) !Expression ![Bind Expression (Global FieldSymbol)] | TupleSelect !DefinedSymbol !Int !Expression - | Lambda .[FreeVar] !Expression +// | Lambda .[FreeVar] !Expression | BasicExpr !BasicValue !BasicType | WildCard | Conditional !Conditional @@ -1236,6 +1238,8 @@ instance <<< (Module a) | <<< a, ParsedDefinition, InstanceType, AttributeVar, T (Optional a) | <<< a, ConsVariable, BasicType, Annotation, Selection, SelectorDef, ConsDef, LocalDefs, FreeVar, ClassInstance, SignClassification, TypeCodeExpression, CoercionPosition, AttrInequality, LetBind, Declaration, STE_Kind, BoundVar +instance <<< FunctionBody + instance == TypeAttribute instance == Annotation /* diff --git a/frontend/syntax.icl b/frontend/syntax.icl index ad5d362..6330f69 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -62,11 +62,13 @@ where toString {import_module} = toString import_module | STE_ExplImpComponentNrs ![ComponentNrAndIndex] ![Declaration] | STE_BelongingSymbol !Int -:: Declaration = - { dcl_ident :: !Ident - , dcl_pos :: !Position - , dcl_kind :: !STE_Kind - , dcl_index :: !Index +:: Declaration = Declaration !DeclarationRecord + +:: DeclarationRecord = + { decl_ident :: !Ident + , decl_pos :: !Position + , decl_kind :: !STE_Kind + , decl_index :: !Index } :: ComponentNrAndIndex = @@ -1028,7 +1030,7 @@ cIsNotStrict :== False | Update !Expression ![Selection] Expression | RecordUpdate !(Global DefinedSymbol) !Expression ![Bind Expression (Global FieldSymbol)] | TupleSelect !DefinedSymbol !Int !Expression - | Lambda .[FreeVar] !Expression +// | Lambda .[FreeVar] !Expression | BasicExpr !BasicValue !BasicType | WildCard | Conditional !Conditional @@ -1212,8 +1214,8 @@ where = True needs_brackets (Case _) = True - needs_brackets (Lambda _ _) - = True +// needs_brackets (Lambda _ _) +// = True needs_brackets (Selection _ _ _) = True needs_brackets _ @@ -1373,12 +1375,16 @@ where instance <<< SymbIdent where - (<<<) file symb=:{symb_kind = SK_Function symb_index } = file <<< symb.symb_name <<< '@' <<< symb_index - (<<<) file symb=:{symb_kind = SK_LocalMacroFunction symb_index } = file <<< symb.symb_name <<< '@' <<< symb_index - (<<<) file symb=:{symb_kind = SK_GeneratedFunction _ symb_index } = file <<< symb.symb_name <<< '@' <<< symb_index - (<<<) file symb=:{symb_kind = SK_OverloadedFunction symb_index } = file <<< symb.symb_name <<< "[o]@" <<< symb_index - (<<<) file symb=:{symb_kind = SK_Constructor symb_index } = file <<< symb.symb_name <<< '@' <<< symb_index - (<<<) file symb = file <<< symb.symb_name + (<<<) file symb=:{symb_kind = SK_Function symb_index } + = file <<< symb.symb_name <<< '@' <<< symb_index + (<<<) file symb=:{symb_kind = SK_LocalMacroFunction symb_index } + = file <<< symb.symb_name <<< '@' <<< symb_index + (<<<) file symb=:{symb_kind = SK_GeneratedFunction _ symb_index } + = file <<< symb.symb_name <<< '@' <<< symb_index + (<<<) file symb=:{symb_kind = SK_OverloadedFunction symb_index } + = file <<< symb.symb_name <<< "[o]@" <<< symb_index + (<<<) file symb + = file <<< symb.symb_name instance <<< TypeSymbIdent where @@ -1479,7 +1485,7 @@ where (<<<) file (Update expr1 selections expr2) = file <<< '{' <<< expr1 <<< " & " <<< selections <<< " = " <<< expr2 <<< '}' (<<<) file (RecordUpdate cons_symbol expression expressions) = file <<< '{' <<< cons_symbol <<< ' ' <<< expression <<< " & " <<< expressions <<< '}' (<<<) file (TupleSelect field field_nr expr) = file <<< expr <<<'.' <<< field_nr - (<<<) file (Lambda vars expr) = file <<< '\\' <<< vars <<< " -> " <<< expr +// (<<<) file (Lambda vars expr) = file <<< '\\' <<< vars <<< " -> " <<< expr (<<<) file WildCard = file <<< '_' (<<<) file (MatchExpr _ cons expr) = file <<< cons <<< " =: " <<< expr (<<<) file EE = file <<< "** E **" @@ -1640,13 +1646,24 @@ where (<<<) 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 - (<<<) 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 - <<< tb_args <<< " = " <<< tb_rhs - (<<<) file {fun_symb,fun_body=BackendBody body,fun_type=Yes type} = file <<< type <<< '\n' <<< fun_symb <<< '.' +// <<< '.' <<< 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 +// <<< '.' <<< 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_body=NoBody,fun_type=Yes type} = file <<< type <<< '\n' <<< fun_symb <<< '.' <<< "Array function\n" +instance <<< FunctionBody +where + (<<<) file (ParsedBody bodies) = file <<< bodies + (<<<) file (CheckedBody {cb_args,cb_rhs}) = file <<< "C " <<< cb_args <<< " = " <<< cb_rhs + (<<<) file (TransformedBody {tb_args,tb_rhs}) = file <<< "T " <<< tb_args <<< " = " <<< tb_rhs + (<<<) file (BackendBody body) = file <<< body <<< '\n' + (<<<) file NoBody = file <<< "Array function\n" + instance <<< FunCall where (<<<) file { fc_level,fc_index } @@ -1916,8 +1933,8 @@ where instance <<< Declaration where - (<<<) file { dcl_ident, dcl_kind } - = file <<< dcl_ident <<< '<' <<< ptrToInt dcl_ident.id_info <<< '>' <<< '(' <<< dcl_kind <<< ')' + (<<<) file (Declaration { decl_ident, decl_kind }) + = file <<< decl_ident <<< '<' <<< ptrToInt decl_ident.id_info <<< '>' <<< '(' <<< decl_kind <<< ')' instance <<< STE_Kind where diff --git a/frontend/trans.icl b/frontend/trans.icl index d73e620..c536762 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -847,7 +847,8 @@ 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 = { 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_local_macro_functions = No } 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 @@ -880,7 +881,8 @@ 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} + 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_local_macro_functions = No } 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) @@ -990,7 +992,7 @@ 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_cleanup_info=ti.ti_cleanup_info, us_local_macro_functions=No } 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}) @@ -1016,7 +1018,7 @@ possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti , fi_properties = outer_fun_def.fun_info.fi_properties } } - cc_args_from_outer_fun = [ cons_arg \\ cons_arg <- outer_cons_args.cc_args & used <- used_mask | used ] + # cc_args_from_outer_fun = [ cons_arg \\ cons_arg <- outer_cons_args.cc_args & used <- used_mask | used ] cc_linear_bits_from_outer_fun = [ cons_arg \\ cons_arg <- outer_cons_args.cc_linear_bits & used <- used_mask | used ] new_cons_args = { cc_size = fun_arity, cc_args = repeatn nr_of_lifted_vars cPassive++cc_args_from_outer_fun, cc_linear_bits = repeatn nr_of_lifted_vars False++cc_linear_bits_from_outer_fun } @@ -1425,7 +1427,7 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi us = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = Yes { ti_type_heaps & th_vars = th_vars, th_attrs = th_attrs }, - us_cleanup_info=ti_cleanup_info } + us_cleanup_info=ti_cleanup_info,us_local_macro_functions=No } 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 ti_type_heaps, us_cleanup_info}) diff --git a/frontend/transform.dcl b/frontend/transform.dcl index 1d290a3..d8845ed 100644 --- a/frontend/transform.dcl +++ b/frontend/transform.dcl @@ -12,11 +12,14 @@ partitionateAndLiftFunctions :: ![IndexRange] !Index !PredefinedSymbol !*{# FunD partitionateMacros :: !IndexRange !Index !PredefinedSymbol !*{# FunDef} !*{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin -> (!*{# FunDef}, !.{# DclModule}, !*VarHeap, !*ExpressionHeap, !*SymbolTable, !*ErrorAdmin ) +:: CopiedLocalFunctions + :: UnfoldState = { us_var_heap :: !.VarHeap , us_symbol_heap :: !.ExpressionHeap , us_opt_type_heaps :: !.Optional .TypeHeaps, - us_cleanup_info :: ![ExprInfoPtr] + us_cleanup_info :: ![ExprInfoPtr], + us_local_macro_functions :: !Optional CopiedLocalFunctions } :: UnfoldInfo = diff --git a/frontend/transform.icl b/frontend/transform.icl index 8025976..18f45b1 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -78,10 +78,10 @@ where lift (TupleSelect symbol argn_nr expr) ls # (expr, ls) = lift expr ls = (TupleSelect symbol argn_nr expr, ls) - lift (Lambda vars expr) ls +/* lift (Lambda vars expr) ls # (expr, ls) = lift expr ls = (Lambda vars expr, ls) - lift (MatchExpr opt_tuple cons_symb expr) ls +*/ lift (MatchExpr opt_tuple cons_symb expr) ls # (expr, ls) = lift expr ls = (MatchExpr opt_tuple cons_symb expr, ls) lift expr ls @@ -100,63 +100,44 @@ where lift app=:{app_symb = app_symbol=:{symb_arity,symb_kind = SK_Function {glob_object,glob_module}}, app_args} ls # (app_args, ls) = lift app_args ls | glob_module == ls.ls_x.LiftStateX.x_main_dcl_module_n -// #! fun_def = ls.ls_fun_defs.[glob_object] #! fun_def = ls.ls_x.x_fun_defs.[glob_object] # {fun_info={fi_free_vars}} = fun_def fun_lifted = length fi_free_vars | fun_lifted > 0 - # (app_args, ls_var_heap, ls_expr_heap) = add_free_variables fi_free_vars app_args ls.ls_var_heap ls.ls_expr_heap + # (app_args, ls_var_heap, ls_expr_heap) = add_free_variables_in_app fi_free_vars app_args ls.ls_var_heap ls.ls_expr_heap = ({ app & app_args = app_args, app_symb = { app_symbol & symb_arity = symb_arity + fun_lifted }}, { ls & ls_var_heap = ls_var_heap, ls_expr_heap = ls_expr_heap }) = ({ app & app_args = app_args }, ls) = ({ app & app_args = app_args }, ls) - where - add_free_variables :: ![FreeVar] ![Expression] !u:VarHeap !*ExpressionHeap -> (![Expression],!u:VarHeap,!*ExpressionHeap) - add_free_variables [] app_args var_heap expr_heap - = (app_args, var_heap, expr_heap) - add_free_variables [{fv_name, fv_info_ptr} : free_vars] app_args var_heap expr_heap - #! var_info = sreadPtr fv_info_ptr var_heap - = case var_info of - VI_LiftedVariable var_info_ptr - # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - -> add_free_variables free_vars [Var { var_name = fv_name, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr } : app_args] - var_heap expr_heap - _ - # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - -> add_free_variables free_vars [Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr } : app_args] - var_heap expr_heap - lift app=:{app_symb = app_symbol=:{symb_arity,symb_kind = SK_LocalMacroFunction glob_object}, app_args} ls # (app_args, ls) = lift app_args ls -// #! fun_def = ls.ls_fun_defs.[glob_object] #! fun_def = ls.ls_x.x_fun_defs.[glob_object] # {fun_info={fi_free_vars}} = fun_def fun_lifted = length fi_free_vars | fun_lifted > 0 - # (app_args, ls_var_heap, ls_expr_heap) = add_free_variables fi_free_vars app_args ls.ls_var_heap ls.ls_expr_heap + # (app_args, ls_var_heap, ls_expr_heap) = add_free_variables_in_app fi_free_vars app_args ls.ls_var_heap ls.ls_expr_heap = ({ app & app_args = app_args, app_symb = { app_symbol & symb_arity = symb_arity + fun_lifted }}, { ls & ls_var_heap = ls_var_heap, ls_expr_heap = ls_expr_heap }) = ({ app & app_args = app_args }, ls) - where - add_free_variables :: ![FreeVar] ![Expression] !u:VarHeap !*ExpressionHeap -> (![Expression],!u:VarHeap,!*ExpressionHeap) - add_free_variables [] app_args var_heap expr_heap - = (app_args, var_heap, expr_heap) - add_free_variables [{fv_name, fv_info_ptr} : free_vars] app_args var_heap expr_heap - #! var_info = sreadPtr fv_info_ptr var_heap - = case var_info of - VI_LiftedVariable var_info_ptr - # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - -> add_free_variables free_vars [Var { var_name = fv_name, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr } : app_args] - var_heap expr_heap - _ - # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - -> add_free_variables free_vars [Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr } : app_args] - var_heap expr_heap - lift app=:{app_args} ls # (app_args, ls) = lift app_args ls = ({ app & app_args = app_args }, ls) +add_free_variables_in_app :: ![FreeVar] ![Expression] !u:VarHeap !*ExpressionHeap -> (![Expression],!u:VarHeap,!*ExpressionHeap) +add_free_variables_in_app [] app_args var_heap expr_heap + = (app_args, var_heap, expr_heap) +add_free_variables_in_app [{fv_name, fv_info_ptr} : free_vars] app_args var_heap expr_heap + #! var_info = sreadPtr fv_info_ptr var_heap + = case var_info of + VI_LiftedVariable var_info_ptr + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + -> add_free_variables_in_app free_vars [Var { var_name = fv_name, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr } : app_args] + var_heap expr_heap + _ + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + -> add_free_variables_in_app free_vars [Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr } : app_args] + var_heap expr_heap + instance lift LetBind where lift bind=:{lb_src} ls @@ -205,23 +186,6 @@ where # (dp_rhs, ls) = lift dp_rhs ls = ({ pattern & dp_rhs = dp_rhs }, ls) -:: UnfoldState = - { us_var_heap :: !.VarHeap - , us_symbol_heap :: !.ExpressionHeap - , 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 !UnfoldInfo !*UnfoldState -> (!a, !*UnfoldState) - unfoldVariable :: !BoundVar !*UnfoldState -> (!Expression, !*UnfoldState) unfoldVariable var=:{var_name,var_info_ptr} us #! (var_info, us) = readVarInfo var_info_ptr us @@ -244,10 +208,10 @@ unfoldVariable var=:{var_name,var_info_ptr} us _ -> (Var var, us) where - substitute_class_types class_types no=:No - = (class_types, no) + substitute_class_types class_types No + = (class_types, No) substitute_class_types class_types (Yes type_heaps) - # (_, new_class_types, type_heaps) = substitute class_types type_heaps + # (_,new_class_types, type_heaps) = substitute class_types type_heaps = (new_class_types, Yes type_heaps) readVarInfo var_info_ptr us @@ -263,6 +227,36 @@ writeVarInfo var_info_ptr new_var_info var_heap VI_Extended extensions _ -> writePtr var_info_ptr (VI_Extended extensions new_var_info) var_heap _ -> writePtr var_info_ptr new_var_info var_heap +:: CopiedLocalFunction = { + old_function_n :: !Int, + new_function_n :: !Int + } + +:: CopiedLocalFunctions = { + copied_local_functions :: [CopiedLocalFunction], + used_copied_local_functions :: [CopiedLocalFunction], + new_copied_local_functions :: [CopiedLocalFunction], + next_local_function_n :: !Int + } + +:: UnfoldState = + { us_var_heap :: !.VarHeap + , us_symbol_heap :: !.ExpressionHeap + , us_opt_type_heaps :: !.Optional .TypeHeaps, + us_cleanup_info :: ![ExprInfoPtr], + us_local_macro_functions :: !Optional CopiedLocalFunctions + } + +:: 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 !UnfoldInfo !*UnfoldState -> (!a, !*UnfoldState) + instance unfold Expression where unfold (Var var) ui us @@ -291,10 +285,10 @@ where unfold (TupleSelect symbol argn_nr expr) ui us # (expr, us) = unfold expr ui us = (TupleSelect symbol argn_nr expr, us) - unfold (Lambda vars expr) ui us +/* unfold (Lambda vars expr) ui us # (expr, us) = unfold expr ui us = (Lambda vars expr, us) - unfold (MatchExpr opt_tuple cons_symb expr) ui 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) ui us @@ -340,7 +334,7 @@ instance unfold App where 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} + 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]}} @@ -358,8 +352,48 @@ where # 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_LocalMacroFunction local_macro_function_n + # (us_local_macro_functions,us) = us!us_local_macro_functions + -> case us_local_macro_functions of + No + -> unfold_function_app app ui us + uslocal_macro_functions=:(Yes local_macro_functions) + # (new_local_macro_function_n,us_local_macro_functions) = determine_new_local_macro_function_n local_macro_function_n local_macro_functions + with + determine_new_local_macro_function_n local_macro_function_n local_macro_functions=:{copied_local_functions,used_copied_local_functions,new_copied_local_functions,next_local_function_n} + # new_local_macro_function_n = search_new_local_macro_function_n used_copied_local_functions + | new_local_macro_function_n>=0 + = (new_local_macro_function_n,us_local_macro_functions) + # (new_local_macro_function_n,used_copied_local_functions) = search_new_local_macro_function_n_and_add_to_used_functions copied_local_functions used_copied_local_functions + | new_local_macro_function_n>=0 + = (new_local_macro_function_n,Yes {local_macro_functions & used_copied_local_functions=used_copied_local_functions}) + # (new_local_macro_function_n,used_copied_local_functions) = search_new_local_macro_function_n_and_add_to_used_functions new_copied_local_functions used_copied_local_functions + | new_local_macro_function_n>=0 + = (new_local_macro_function_n,Yes {local_macro_functions & used_copied_local_functions=used_copied_local_functions}) + # new_local_function = {old_function_n=local_macro_function_n,new_function_n=next_local_function_n} + # new_copied_local_functions=new_copied_local_functions++[new_local_function] + # us_local_macro_functions=Yes {copied_local_functions=copied_local_functions, + new_copied_local_functions=new_copied_local_functions, + used_copied_local_functions=[new_local_function:used_copied_local_functions], + next_local_function_n=next_local_function_n+1} + = (next_local_function_n,us_local_macro_functions) + where + search_new_local_macro_function_n [{old_function_n,new_function_n}:local_functions] + | local_macro_function_n==old_function_n + = new_function_n + = search_new_local_macro_function_n local_functions + search_new_local_macro_function_n [] + = -1 + + search_new_local_macro_function_n_and_add_to_used_functions [copied_local_function=:{old_function_n,new_function_n}:local_functions] used_copied_local_functions + | local_macro_function_n==old_function_n + = (new_function_n,[copied_local_function:used_copied_local_functions]) + = search_new_local_macro_function_n_and_add_to_used_functions local_functions used_copied_local_functions + search_new_local_macro_function_n_and_add_to_used_functions [] used_copied_local_functions + = (-1,used_copied_local_functions) + # us={us & us_local_macro_functions=us_local_macro_functions} + # app={app & app_symb.symb_kind=SK_LocalMacroFunction new_local_macro_function_n} + -> 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 @@ -381,7 +415,7 @@ where = ({ 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 + # (_,new_class_type, type_heaps) = substitute class_type type_heaps = (EI_DictionaryType new_class_type, Yes type_heaps) substitute_EI_DictionaryType x opt_type_heaps = (x, opt_type_heaps) @@ -495,11 +529,10 @@ substitute_let_or_case_type (EI_Extended extensions expr_info) yes_type_heaps # (new_expr_info, yes_type_heaps) = substitute_let_or_case_type expr_info yes_type_heaps = (EI_Extended extensions new_expr_info, yes_type_heaps) substitute_let_or_case_type (EI_CaseType case_type) (Yes type_heaps) - # (_, new_case_type, type_heaps) = substitute case_type type_heaps + # (_,new_case_type, type_heaps) = substitute case_type type_heaps = (EI_CaseType new_case_type, Yes type_heaps) -// = (EI_CaseType case_type, Yes type_heaps) substitute_let_or_case_type (EI_LetType let_type) (Yes type_heaps) - # (_, new_let_type, type_heaps) = substitute let_type type_heaps + # (_,new_let_type, type_heaps) = substitute let_type type_heaps = (EI_LetType new_let_type, Yes type_heaps) instance unfold CasePatterns @@ -564,13 +597,16 @@ where unfold no ui us = (no, us) +//import StdDebug + updateFunctionCalls :: ![FunCall] ![FunCall] !*{# FunDef} !*SymbolTable -> (![FunCall], !*{# FunDef}, !*SymbolTable) updateFunctionCalls calls collected_calls fun_defs symbol_table = foldSt add_function_call calls (collected_calls, fun_defs, symbol_table) where - add_function_call fc (collected_calls, fun_defs, symbol_table) - # ({fun_symb}, fun_defs) = fun_defs![fc.fc_index] + add_function_call fc=:{fc_index} (collected_calls, fun_defs, symbol_table) +// # fc_index = trace ("add_function_call: "+++toString fc_index+++" ") fc_index + # ({fun_symb}, fun_defs) = fun_defs![fc_index] (collected_calls, symbol_table) = examineFunctionCall fun_symb fc (collected_calls, symbol_table) = (collected_calls, fun_defs, symbol_table) @@ -585,29 +621,149 @@ examineFunctionCall {id_info} fc=:{fc_index} (calls, symbol_table) -> ( [ fc : calls ], symbol_table <:= (id_info, { ste_kind = STE_Called [fc_index], ste_index = NoIndex, ste_def_level = NotALevel, ste_previous = entry })) +copy_macro_and_local_functions :: FunDef (Optional CopiedLocalFunctions) *ExpandState -> (!FunDef,![(CopiedLocalFunction,FunDef)],!Optional CopiedLocalFunctions,!*ExpandState); +copy_macro_and_local_functions macro=:{fun_kind} local_macro_functions es + # is_def_macro=case fun_kind of FK_DefMacro->True; _->False + # (macro,local_macro_functions,es) = copy_macro_or_local_macro_function is_def_macro macro local_macro_functions es + # (new_functions,local_macro_functions,es) = copy_local_functions_of_macro local_macro_functions is_def_macro [] es + = (macro,new_functions,local_macro_functions,es) + +copy_local_functions_of_macro :: (Optional CopiedLocalFunctions) Bool [CopiedLocalFunction] *ExpandState -> (![(CopiedLocalFunction,FunDef)],!Optional CopiedLocalFunctions,!*ExpandState); +copy_local_functions_of_macro local_macro_functions is_def_macro local_functions_to_be_copied es + # (local_functions_to_be_copied,local_macro_functions) = add_new_local_functions_to_be_copied local_functions_to_be_copied local_macro_functions + with + add_new_local_functions_to_be_copied local_functions_to_be_copied local_macro_functions=:(Yes copied_local_macro_functions=:{new_copied_local_functions=[]}) + = (local_functions_to_be_copied,Yes {copied_local_macro_functions & used_copied_local_functions=[]}) + add_new_local_functions_to_be_copied local_functions_to_be_copied (Yes {copied_local_functions,new_copied_local_functions,next_local_function_n}) + # local_macro_functions=Yes {copied_local_functions=copied_local_functions++new_copied_local_functions, + new_copied_local_functions=[],used_copied_local_functions=[],next_local_function_n=next_local_function_n} + = (local_functions_to_be_copied++new_copied_local_functions,local_macro_functions) + = case local_functions_to_be_copied of + [] + -> ([],local_macro_functions,es) + [(old_and_new_function_n=:{old_function_n,new_function_n}):local_functions_to_be_copied] + # (function,es)=es!es_fun_defs.[old_function_n] + + #! function_group_index=function.fun_info.fi_group_index + # es = {es & es_fun_defs.[old_function_n].fun_info.fi_group_index= if (function_group_index>NoIndex) (-2-function_group_index) function_group_index} + # function = {function & fun_info.fi_group_index=if (function_group_index<NoIndex) (-2-function_group_index) function_group_index} + + # (function,local_macro_functions,es) = copy_macro_or_local_macro_function is_def_macro function local_macro_functions es + # function={function & fun_index=new_function_n} + # (new_functions,local_macro_functions,es) = copy_local_functions_of_macro local_macro_functions is_def_macro local_functions_to_be_copied es + -> ([(old_and_new_function_n,function):new_functions],local_macro_functions,es) + +update_calls calls No + = calls +update_calls calls (Yes {used_copied_local_functions=[]}) + = calls +update_calls calls (Yes {used_copied_local_functions}) + # calls = remove_old_calls calls + = add_new_calls used_copied_local_functions calls +where + remove_old_calls [call=:{fc_index}:calls] + | contains_old_function_n used_copied_local_functions +// # calls = trace ("remove_old_calls1: "+++toString fc_index) calls + = remove_old_calls calls +// # calls = trace ("remove_old_calls2: "+++toString fc_index) calls + = [call:remove_old_calls calls] + where + contains_old_function_n [{old_function_n}:local_functions] + = fc_index==old_function_n || contains_old_function_n local_functions + contains_old_function_n [] + = False + remove_old_calls [] + = [] + + add_new_calls [{new_function_n}:local_functions] calls +// # local_functions = trace ("add_new_calls: "+++toString new_function_n) local_functions + = add_new_calls local_functions [{fc_index=new_function_n,fc_level=NotALevel}:calls] + add_new_calls [] calls + = calls + +copy_macro_or_local_macro_function :: !Bool !FunDef !(Optional CopiedLocalFunctions) !*ExpandState -> (!FunDef,!Optional CopiedLocalFunctions,!.ExpandState); +copy_macro_or_local_macro_function is_def_macro macro=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_kind,fun_info={fi_local_vars,fi_calls}} local_macro_functions es=:{es_var_heap,es_symbol_heap,es_expand_in_imp_module,es_main_dcl_module_n,es_dcl_modules} + # (tb_args,es_var_heap) = create_new_arguments tb_args es_var_heap + with + create_new_arguments [var=:{fv_name,fv_info_ptr} : vars] var_heap + # (new_vars,var_heap) = create_new_arguments vars var_heap + # (new_info, var_heap) = newPtr VI_Empty var_heap + # new_var = { fv_name = fv_name, fv_def_level = NotALevel, fv_info_ptr = new_info, fv_count = 0 } + = ([new_var : new_vars], writePtr fv_info_ptr (VI_Variable fv_name new_info) var_heap) + create_new_arguments [] var_heap + = ([],var_heap) + # us = { us_symbol_heap = es_symbol_heap, us_var_heap = es_var_heap, us_opt_type_heaps = No,us_cleanup_info = [], + us_local_macro_functions = local_macro_functions } + # (result_expr,dcl_modules,{us_local_macro_functions,us_symbol_heap,us_var_heap}) = unfold_and_convert es_dcl_modules us + with + unfold_and_convert dcl_modules us + | 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 } + # (expr,es) = unfold tb_rhs ui us + = (expr,dcl_modules,es) + + # ui = {ui_handle_aci_free_vars = RemoveThem, ui_convert_module_n = -1 ,ui_conversion_table=No } + # (expr,es) = unfold tb_rhs ui us + = (expr,dcl_modules,es) + # (fi_local_vars,us_var_heap) = update_local_vars fi_local_vars us_var_heap + with + update_local_vars :: ![FreeVar] !*(Heap VarInfo) -> (![FreeVar],!*Heap VarInfo); + update_local_vars [fv=:{fv_info_ptr}:fvs] var_heap + # (fvs,var_heap)=update_local_vars fvs var_heap + # (fv_info,var_heap) = readPtr fv_info_ptr var_heap +// # fv = {fv & fv_info_ptr=case fv_info of (VI_Variable _ info_ptr) -> info_ptr} + # fv = {fv & fv_info_ptr=case fv_info of + (VI_Variable _ info_ptr) -> info_ptr + } + = ([fv:fvs],var_heap) + update_local_vars [] var_heap + = ([],var_heap) + # fi_calls = update_calls fi_calls us_local_macro_functions + = ({macro & fun_body = TransformedBody {tb_args=tb_args,tb_rhs=result_expr},fun_info.fi_local_vars=fi_local_vars,fun_info.fi_calls=fi_calls},us_local_macro_functions, + {es & es_var_heap=us_var_heap, es_symbol_heap=us_symbol_heap, es_dcl_modules=dcl_modules}) + unfoldMacro :: !FunDef ![Expression] !*ExpandInfo -> (!Expression, !*ExpandInfo) -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}) +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_fun_defs,es_expand_in_imp_module,es_main_dcl_module_n,es_dcl_modules}) + # is_def_macro=case fun_kind of FK_DefMacro->True; _->False # (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 = []} - # (result_expr,dcl_modules,us_symbol_heap,us_var_heap) = unfold_and_convert tb_rhs es_dcl_modules us + #! size_fun_defs = size es_fun_defs + # copied_local_functions = Yes { copied_local_functions=[],used_copied_local_functions=[],new_copied_local_functions=[],next_local_function_n=size_fun_defs} + # us = { us_symbol_heap = es_symbol_heap, us_var_heap = var_heap, us_opt_type_heaps = No,us_cleanup_info = [], us_local_macro_functions = copied_local_functions } + # (result_expr,dcl_modules,{us_local_macro_functions,us_symbol_heap,us_var_heap}) = unfold_and_convert es_dcl_modules us with - unfold_and_convert tb_rhs dcl_modules us - # is_def_macro=case fun_kind of FK_DefMacro->True; _->False + unfold_and_convert dcl_modules us | 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) + # 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) = unfold tb_rhs ui us + = (result_expr,dcl_modules,us) + + # ui = {ui_handle_aci_free_vars = RemoveThem, ui_convert_module_n = -1 ,ui_conversion_table=No } + # (result_expr,us) = unfold tb_rhs ui us + = (result_expr,dcl_modules,us) + + # es = {es & es_var_heap = us_var_heap, es_symbol_heap = us_symbol_heap, es_dcl_modules=dcl_modules} + # fi_calls = update_calls fi_calls us_local_macro_functions + # (new_functions,us_local_macro_functions,es) = copy_local_functions_of_macro us_local_macro_functions is_def_macro [] es + # {es_symbol_heap,es_symbol_table,es_fun_defs,es_new_fun_def_numbers} = es + # (es_fun_defs,es_new_fun_def_numbers) = case new_functions of + [] + -> (es_fun_defs,es_new_fun_def_numbers) + _ + # last_function_index = case us_local_macro_functions of (Yes {next_local_function_n}) -> next_local_function_n-1 + # new_fun_defs = new_fun_defs + with + new_fun_defs :: *{!FunDef} + new_fun_defs => {fun_def \\ (_,fun_def)<-new_functions} + -> ({if (i<size_fun_defs) es_fun_defs.[i] new_fun_defs.[i-size_fun_defs] \\ i<-[0..last_function_index]} // inefficient + ,[size_fun_defs:es_new_fun_def_numbers]) # (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,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,es_dcl_modules=dcl_modules })) + = (result_expr, (calls, { es & es_symbol_table = es_symbol_table, es_fun_defs=fun_defs,es_new_fun_def_numbers=es_new_fun_def_numbers })) + # (new_info_ptr, es_symbol_heap) = newPtr EI_Empty es_symbol_heap + # result_expr=Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = result_expr, let_info_ptr = new_info_ptr, let_expr_position = NoPos } + = (result_expr, (calls, { es & es_symbol_table = es_symbol_table, es_symbol_heap=es_symbol_heap, es_fun_defs=fun_defs,es_new_fun_def_numbers=es_new_fun_def_numbers })) where bind_expressions [var : vars] [expr : exprs] binds var_heap # (binds, var_heap) = bind_expressions vars exprs binds var_heap @@ -615,6 +771,7 @@ where bind_expressions _ _ binds var_heap = (binds, var_heap) + bind_expression :: FreeVar Expression [LetBind] *(Heap VarInfo) -> (![LetBind],!*Heap VarInfo); bind_expression {fv_count} expr binds var_heap | fv_count == 0 = (binds, var_heap) @@ -655,6 +812,10 @@ partitionateMacros {ir_from,ir_to} mod_index alias_dummy fun_defs modules var_he pi_error = error, pi_deps = [], pi_next_num = 0, pi_next_group = 0, pi_groups = [] } (fun_defs, modules, {pi_symbol_table, pi_var_heap, pi_symbol_heap, pi_error, pi_next_group, pi_groups, pi_deps}) = iFoldSt (pationate_macro mod_index max_fun_nr) ir_from ir_to (fun_defs, modules, partitioning_info) + +// # (size_fun_defs,fun_defs) = usize fun_defs +// # fun_defs=trace ("size_fun_defs: "+++toString size_fun_defs+++" ") fun_defs; + = (foldSt reset_body_of_rhs_macro pi_deps fun_defs, modules, pi_var_heap, pi_symbol_heap, pi_symbol_table, pi_error) where reset_body_of_rhs_macro macro_index macro_defs @@ -692,11 +853,11 @@ where 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_main_dcl_module_n = mod_index, es_dcl_modules=modules, - es_expand_in_imp_module=expand_in_imp_module - } + es_expand_in_imp_module=expand_in_imp_module,es_new_fun_def_numbers=[] + } # (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}, + # 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 }} = ({ es_fun_defs & [macro_index] = macro }, es_dcl_modules, { pi & pi_symbol_table = es_symbol_table, pi_symbol_heap = es_symbol_heap, pi_var_heap = es_var_heap, pi_error = es_error }) @@ -716,6 +877,64 @@ where is_a_pattern_macro _ _ = False +add_new_macros_to_groups :: ![Int] !Int Int *{#FunDef} [Int] [[Int]] -> (!Int,!*{#FunDef},![Int],![[Int]]); +add_new_macros_to_groups [new_macro_fun_def_index] n_fun_defs_after_expanding_macros pi_next_group es_fun_defs functions_in_group pi_groups + = add_new_macro_and_local_functions_to_groups new_macro_fun_def_index n_fun_defs_after_expanding_macros pi_next_group es_fun_defs functions_in_group pi_groups +add_new_macros_to_groups [new_macro_fun_def_index:macro_fun_def_numbers=:[next_macro_fun_def_index:_]] n_fun_defs_after_expanding_macros pi_next_group es_fun_defs functions_in_group pi_groups + # (pi_next_group,es_fun_defs,functions_in_group,pi_groups) + = add_new_macro_and_local_functions_to_groups new_macro_fun_def_index next_macro_fun_def_index pi_next_group es_fun_defs functions_in_group pi_groups + = add_new_macros_to_groups macro_fun_def_numbers n_fun_defs_after_expanding_macros pi_next_group es_fun_defs functions_in_group pi_groups +add_new_macros_to_groups [] n_fun_defs_after_expanding_macros pi_next_group es_fun_defs functions_in_group pi_groups + = (pi_next_group,es_fun_defs,functions_in_group,pi_groups) + +add_new_macro_and_local_functions_to_groups :: !Int !Int Int *{#FunDef} [Int] [[Int]] -> (!Int,!*{#FunDef},![Int],![[Int]]); +add_new_macro_and_local_functions_to_groups new_macro_fun_def_index n_fun_defs_after_expanding_macros pi_next_group es_fun_defs functions_in_group pi_groups + # (pi_next_group,es_fun_defs,functions_in_group,macros) + = add_macros_to_current_group new_macro_fun_def_index n_fun_defs_after_expanding_macros pi_next_group es_fun_defs functions_in_group [] + # (macros_with_group_numbers,es_fun_defs) = add_group_numbers macros es_fun_defs + with + add_group_numbers [fun_def_index:l] es_fun_defs + # (group_number,es_fun_defs) = es_fun_defs![fun_def_index].fun_info.fi_group_index +// # group_number=trace ("add_group_numbers: "+++toString fun_def_index+++" "+++toString group_number+++"\n") group_number; + # (l,es_fun_defs) = add_group_numbers l es_fun_defs + = ([(fun_def_index,group_number):l],es_fun_defs) + add_group_numbers [] es_fun_defs + = ([],es_fun_defs) + # sorted_macros_with_group_numbers = sortBy (\(_,group_number1) (_,group_number2) -> group_number1<group_number2) macros_with_group_numbers + # (pi_next_group,pi_groups) = partition_macros_in_groups sorted_macros_with_group_numbers [] (-1) pi_next_group pi_groups + with + partition_macros_in_groups [(fun_def_index,fun_def_group_number):l] [] group_number pi_next_group pi_groups + = partition_macros_in_groups l [fun_def_index] fun_def_group_number pi_next_group pi_groups + partition_macros_in_groups [(fun_def_index,fun_def_group_number):l] group group_number pi_next_group pi_groups + | fun_def_group_number==group_number + = partition_macros_in_groups l [fun_def_index:group] group_number pi_next_group pi_groups + # pi_groups=[group:pi_groups] + # pi_next_group=pi_next_group+1 + = partition_macros_in_groups l [fun_def_index] fun_def_group_number pi_next_group pi_groups + partition_macros_in_groups [] [] group_number pi_next_group pi_groups + = (pi_next_group,pi_groups) + partition_macros_in_groups [] last_group group_number pi_next_group pi_groups + = (pi_next_group+1,[last_group:pi_groups]) + = (pi_next_group,es_fun_defs,functions_in_group,pi_groups) + +add_macros_to_current_group :: !Int !Int Int *{#FunDef} [Int] [Int] -> (!Int,!*{#FunDef},![Int],![Int]); +add_macros_to_current_group new_macro_fun_def_index n_fun_defs_after_expanding_macros pi_next_group es_fun_defs functions_in_group macros + | new_macro_fun_def_index>=n_fun_defs_after_expanding_macros + = (pi_next_group,es_fun_defs,functions_in_group,macros) + | es_fun_defs.[new_macro_fun_def_index].fun_info.fi_group_index<=NoIndex + = abort ("add_macros_to_current_group: "+++toString new_macro_fun_def_index) +// +++" "+++toString es_fun_defs.[new_macro_fun_def_index].fun_info.fi_group_index) + + | es_fun_defs.[new_macro_fun_def_index].fun_info.fi_group_index==pi_next_group +// # new_macro_fun_def_index=trace ("add_macros_to_current_group1: "+++toString new_macro_fun_def_index+++"\n") new_macro_fun_def_index; + # functions_in_group=[new_macro_fun_def_index:functions_in_group] + = add_macros_to_current_group (new_macro_fun_def_index+1) n_fun_defs_after_expanding_macros pi_next_group es_fun_defs functions_in_group macros + +// # new_macro_fun_def_index=trace ("add_macros_to_current_group2: "+++toString new_macro_fun_def_index+++"\n") new_macro_fun_def_index; +// # pi_groups=[[new_macro_fun_def_index]:pi_groups] +// # pi_next_group=pi_next_group+1 + = add_macros_to_current_group (new_macro_fun_def_index+1) n_fun_defs_after_expanding_macros pi_next_group es_fun_defs functions_in_group [new_macro_fun_def_index:macros] + partitionateAndLiftFunctions :: ![IndexRange] !Index !PredefinedSymbol !*{# FunDef} !*{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin -> (!*{! 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 @@ -737,9 +956,11 @@ where 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) + + = ([fun:funs],fun_defs) remove_macros_from_group [] fun_defs = ([],fun_defs); remove_macros_from_groups_and_reverse [] fun_defs result_groups @@ -753,6 +974,7 @@ where = funs_modules_pi partitionate_function mod_index max_fun_nr fun_index (fun_defs, modules, pi) +// # fun_index = trace ("partitionate_function: "+++toString fun_index+++" ") fun_index # (fun_def, fun_defs) = fun_defs![fun_index] = case fun_def.fun_body of CheckedBody body @@ -766,8 +988,8 @@ 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, - -> (max_fun_nr, ({ fun_defs & [fun_index] = {fun_def & fun_info.fi_group_index = -2-pi.pi_next_group }}, modules, + -> (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} )) @@ -776,27 +998,29 @@ where 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 = (min next_min min_dep, funs_modules_pi) - + 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, functions_in_group, macros_in_group, fun_defs) = close_group fun_index pi_deps [] [] max_fun_nr pi_next_group fun_defs {ls_x={x_fun_defs=fun_defs}, ls_var_heap=pi_var_heap, ls_expr_heap=pi_symbol_heap} - = 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 + = 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_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} + { es_symbol_table = pi_symbol_table, es_var_heap = pi_var_heap, es_symbol_heap = pi_symbol_heap, + es_fun_defs=fun_defs, es_main_dcl_module_n=mod_index, es_dcl_modules=modules, es_new_fun_def_numbers=[], + 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,es_new_fun_def_numbers} = expand_macros_in_group functions_in_group es + # (n_fun_defs_after_expanding_macros,es_fun_defs) = usize es_fun_defs + # (pi_next_group,es_fun_defs,functions_in_group,pi_groups) + = add_new_macros_to_groups (reverse es_new_fun_def_numbers) n_fun_defs_after_expanding_macros pi_next_group es_fun_defs functions_in_group pi_groups = (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 = [ 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] functions_in_group macros_in_group nr_of_fun_defs group_number fun_defs @@ -805,6 +1029,7 @@ where // | 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 }} +// # fun_defs = { fun_defs & [d] = { fun_def & fun_info.fi_group_index = group_number }} # macros_in_group = [d : macros_in_group] | d == fun_index = (ds, functions_in_group, macros_in_group, fun_defs) @@ -833,14 +1058,17 @@ where add_called_macros calls macro_defs_and_pi = foldSt add_called_macro calls macro_defs_and_pi where - add_called_macro {fc_index} (macro_defs, pi) + add_called_macro {fc_index} (macro_defs, pi) +// # fc_index = trace ("add_called_macro: "+++toString fc_index+++" ") fc_index # (macro_def, macro_defs) = macro_defs![fc_index] = case macro_def.fun_body of 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 }}, - -> ({ macro_defs & [fc_index] = {macro_def & fun_info.fi_group_index = -2-pi.pi_next_group }}, +// # fc_index = trace ("add_called_macro2: "+++toString fc_index+++" ") fc_index +// -> ({ macro_defs & [fc_index] = {macro_def & fun_info.fi_group_index = -2-pi.pi_next_group }}, + -> ({ 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]} // {pi & pi_next_group = pi.pi_next_group} ) @@ -897,11 +1125,13 @@ expandCheckedAlternative {ca_rhs, ca_position} ei # (ca_rhs, ei) = expand ca_rhs ei = ((ca_rhs, ca_position), ei) +/* cContainsFreeVars :== True cContainsNoFreeVars :== False cMacroIsCalled :== True cNoMacroIsCalled :== False +*/ class GetSetPatternRhs a where @@ -957,6 +1187,7 @@ where ( \ guard_expr -> { this_case & case_guards = AlgebraicPatterns type [{ alg_pattern & ap_expr = guard_expr }] } ) split_case symbol_heap -> (Yes cees, var_heap, symbol_heap) + No -> (No, var_heap, symbol_heap) BasicPatterns type [basic_pattern] @@ -967,6 +1198,7 @@ where ( \ guard_expr -> { this_case & case_guards = BasicPatterns type [ { basic_pattern & bp_expr = guard_expr }] }) split_case symbol_heap -> (Yes cees, var_heap, symbol_heap) + No -> (No, var_heap, symbol_heap) DynamicPatterns [dynamic_pattern] @@ -977,6 +1209,7 @@ where ( \ guard_expr -> { this_case & case_guards = DynamicPatterns [ { dynamic_pattern & dp_rhs = guard_expr }] }) split_case symbol_heap -> (Yes cees, var_heap, symbol_heap) + No -> (No, var_heap, symbol_heap) _ @@ -1011,7 +1244,14 @@ where = var_heap <:= (fv_info_ptr, VI_Alias var) set_alias _ var_heap = var_heap - +/* + push_expression_into_guards expr_fun (AlgebraicPatterns type patterns) + = AlgebraicPatterns type (map (\algpattern -> { algpattern & ap_expr = expr_fun algpattern.ap_expr }) patterns) + push_expression_into_guards expr_fun (BasicPatterns type patterns) + = BasicPatterns type (map (\baspattern -> { baspattern & bp_expr = expr_fun baspattern.bp_expr }) patterns) + push_expression_into_guards expr_fun (DynamicPatterns patterns) + = DynamicPatterns (map (\dynpattern -> { dynpattern & dp_rhs = expr_fun dynpattern.dp_rhs }) patterns) +*/ push_expression_into_guards_and_default expr_fun split_case symbol_heap = push_expression_into_guards_and_default split_case symbol_heap where @@ -1048,7 +1288,7 @@ where = (Case {cees & case_info_ptr=new_case_info_ptr},symbol_heap) 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 = { us_var_heap = var_heap, us_symbol_heap = symbol_heap, us_opt_type_heaps = No,us_cleanup_info = [], us_local_macro_functions = No } 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) @@ -1072,7 +1312,6 @@ where # (lb_src, var_heap, expr_heap) = replace_variables_in_expression lb_src var_heap expr_heap = ([{ bind & lb_src = lb_src } : rev_binds], var_heap, expr_heap) - push_let_expression_into_guards lad (AlgebraicPatterns type patterns) var_heap expr_heap # (patterns, var_heap, expr_heap) = push_let_expression_into_algebraic_pattern lad patterns var_heap expr_heap = (AlgebraicPatterns type patterns, var_heap, expr_heap) @@ -1147,8 +1386,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=[]} - ui = {ui_handle_aci_free_vars = RemoveThem, ui_convert_module_n= -1, ui_conversion_table=No} + # var_heap = build_aliases vars ap_vars var_heap + # us = { us_var_heap = var_heap, us_symbol_heap = symbol_heap, us_opt_type_heaps = No,us_cleanup_info=[], us_local_macro_functions = No } + 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) @@ -1288,7 +1528,8 @@ where es_fun_defs :: !.{#FunDef}, es_main_dcl_module_n :: !Int, es_dcl_modules :: !.{# DclModule}, - es_expand_in_imp_module :: !Bool + es_expand_in_imp_module :: !Bool, + es_new_fun_def_numbers :: ![Int] } class expand a :: !a !*ExpandInfo -> (!a, !*ExpandInfo) @@ -1297,18 +1538,49 @@ instance expand Expression where expand (App app=:{app_symb = symb=:{symb_arity, symb_kind = SK_Macro {glob_object,glob_module}}, app_args}) ei # (app_args, (calls, es)) = expand app_args ei - (macro, es) = es!es_fun_defs.[glob_object] - | macro.fun_arity == symb_arity + # (macro, es) = es!es_fun_defs.[glob_object] + #! macro_group_index=macro.fun_info.fi_group_index + # es = {es & es_fun_defs.[glob_object].fun_info.fi_group_index= if (macro_group_index>NoIndex) (-2-macro_group_index) macro_group_index} + | macro.fun_arity == symb_arity = 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) - es = { 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)) - = (App { app & app_symb = { symb & symb_kind = SK_Function {glob_object = glob_object, glob_module = glob_module} }, app_args = app_args },(calls, es)) + + # macro = {macro & fun_info.fi_group_index=if (macro_group_index<NoIndex) (-2-macro_group_index) macro_group_index} + #! new_function_index = size es.es_fun_defs + # copied_local_functions = Yes { copied_local_functions=[],used_copied_local_functions=[],new_copied_local_functions=[],next_local_function_n=new_function_index+1} + + # (macro,new_functions,local_macro_functions,es) = copy_macro_and_local_functions macro copied_local_functions es +// # new_function_index=trace ("new_function_index: "+++toString new_function_index+++"\n") new_function_index; + # macro={macro & fun_index=new_function_index} + # last_function_index = case local_macro_functions of (Yes {next_local_function_n}) -> next_local_function_n-1 + # es = add_new_fun_defs [({old_function_n=glob_object,new_function_n=new_function_index},macro):new_functions] new_function_index last_function_index es + with + add_new_fun_defs new_functions new_function_index last_function_index es=:{es_fun_defs,es_new_fun_def_numbers} + # new_fun_defs = new_fun_defs + with + new_fun_defs :: *{!FunDef} + new_fun_defs => {fun_def \\ (_,fun_def)<-new_functions} + # es_fun_defs = {if (i<new_function_index) es_fun_defs.[i] new_fun_defs.[i-new_function_index] \\ i<-[0..last_function_index]} // inefficient + = {es & es_fun_defs=es_fun_defs,es_new_fun_def_numbers=[new_function_index:es_new_fun_def_numbers]} + + # (calls, es_symbol_table) = examineFunctionCall macro.fun_symb {fc_index = new_function_index, fc_level = NotALevel} (calls, es.es_symbol_table) + # app = App { app & app_symb = { symb & symb_kind = SK_LocalMacroFunction new_function_index }, app_args = app_args } + +/* | 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.[new_function_index]=macro} + = (app, (calls, { es & es_symbol_table = es_symbol_table })) +*/ + = (app, (calls, { es & es_symbol_table = es_symbol_table })) + +/* + # (calls, es_symbol_table) = examineFunctionCall macro.fun_symb {fc_index = glob_object, fc_level = NotALevel} (calls, es.es_symbol_table) + # app = App { app & app_symb = { symb & symb_kind = SK_Function {glob_object = glob_object, glob_module = glob_module} }, app_args = app_args } + | 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, (calls, { es & es_symbol_table = es_symbol_table })) + = (app, (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) @@ -1335,10 +1607,10 @@ where expand (TupleSelect symbol argn_nr expr) ei # (expr, ei) = expand expr ei = (TupleSelect symbol argn_nr expr, ei) - expand (Lambda vars expr) ei +/* expand (Lambda vars expr) ei # (expr, ei) = expand expr ei = (Lambda vars expr, ei) - expand (MatchExpr opt_tuple cons_symb expr) ei +*/ expand (MatchExpr opt_tuple cons_symb expr) ei # (expr, ei) = expand expr ei = (MatchExpr opt_tuple cons_symb expr, ei) expand expr ei @@ -1669,7 +1941,6 @@ where # (case_default, free_vars, cos) = collectVariables case_default free_vars cos = ({ kees & case_expr = case_expr, case_guards = case_guards, case_default = case_default }, free_vars, cos) - instance collectVariables CasePatterns where collectVariables (AlgebraicPatterns type patterns) free_vars cos diff --git a/frontend/type.icl b/frontend/type.icl index e03c019..8c7f98e 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -1856,13 +1856,52 @@ addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars,st_con st_attr_vars = st_attr_vars ++ take (length new_attrs - length st_attr_vars) new_attrs, st_arity = st_arity + nr_of_lifted_arguments, st_context = take (length new_context - length st_context) new_context ++ st_context } - :: FunctionRequirements = { fe_requirements :: !Requirements , fe_context :: !Optional [TypeContext] , fe_index :: !Index , fe_location :: !IdentPos } +/* +ste_kind_to_string s + = case s of + (STE_FunctionOrMacro _) + -> "STE_FunctionOrMacro" + STE_Type + -> "STE_Type" + STE_Constructor + -> "STE_Constructor" + (STE_Selector _) + -> "STE_Selector" + STE_Class + -> "STE_Class" + (STE_Field _) + -> "STE_Field" + STE_Member + -> "STE_Member" + (STE_Instance _) + -> "STE_Instance" + (STE_Variable _) + -> "STE_Variable" + (STE_TypeVariable _) + -> "STE_TypeVariable" + (STE_TypeAttribute _) + -> "STE_TypeAttribute" + (STE_BoundTypeVariable _) + -> "STE_BoundTypeVariable" + (STE_Imported a b) + -> "STE_Imported "+++ ste_kind_to_string a + STE_DclFunction + -> "STE_DclFunction" + (STE_Module _) + -> "STE_Module" + STE_ClosedModule + -> "STE_ClosedModule" + STE_Empty + -> "STE_Empty" + _ + -> "STE_???" +*/ typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !NumberSet !*TypeDefInfos !*Heaps !*PredefinedSymbols !*File !*File !{# DclModule} -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*TypeDefInfos, !*Heaps, !*PredefinedSymbols, !*File, !*File) @@ -1871,7 +1910,6 @@ typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_de //typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !NumberSet !*Heaps !*PredefinedSymbols !*File !*File !{# DclModule} // -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !.TypeDefInfos, !*Heaps, !*PredefinedSymbols, !*File, !*File) //typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_defs imports modules used_module_numbers heaps=:{hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file out dcl_modules - #! fun_env_size = size fun_defs # ts_error = {ea_file = file, ea_loc = [], ea_ok = True } @@ -1933,8 +1971,8 @@ where collect_imported_instances imports common_defs dummy error class_instances type_var_heap td_infos = foldSt (collect_imported_instance common_defs) imports (dummy, error, class_instances, type_var_heap, td_infos) - collect_imported_instance common_defs {dcl_ident, dcl_kind = STE_Imported (STE_Instance _) mod_index, dcl_index } state - = update_instances_of_class common_defs mod_index dcl_index state + collect_imported_instance common_defs (Declaration {decl_kind = STE_Imported (STE_Instance _) mod_index, decl_index }) state + = update_instances_of_class common_defs mod_index decl_index state collect_imported_instance common_defs _ state = state diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index d1aaef5..e9010e5 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -1,7 +1,7 @@ implementation module typesupport import StdEnv, StdCompare -import syntax, parse, check, unitype, utilities, checktypes, RWSDebug +import syntax, parse, check, unitype, utilities, checktypes //, RWSDebug :: Store :== Int diff --git a/frontend/unitype.icl b/frontend/unitype.icl index 1959938..418d2fc 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -2,7 +2,7 @@ implementation module unitype import StdEnv -import syntax, analunitypes, type, utilities, checktypes, RWSDebug +import syntax, analunitypes, type, utilities, checktypes //, RWSDebug import cheat @@ -455,7 +455,7 @@ where (AVI_Attr attr, attr_var_heap) -> (True,attr, attr_var_heap) (info, attr_var_heap) - -> abort ("expand_attribute (unitype.icl)" ---> (av_name <<- info )) + -> abort ("expand_attribute (unitype.icl)" )//---> (av_name <<- info )) expand_attribute attr attr_var_heap = (False,attr, attr_var_heap) @@ -479,7 +479,7 @@ where (AVI_Attr attr, attr_var_heap) -> (True,attr, attr_var_heap) (info, attr_var_heap) - -> abort ("expand_attribute (unitype.icl)" ---> (av_name <<- info )) + -> abort ("expand_attribute (unitype.icl)" )//---> (av_name <<- info )) expand_attribute attr attr_var_heap = (False,attr, attr_var_heap) |