diff options
| author | johnvg | 2001-03-27 15:54:51 +0000 |
|---|---|---|
| committer | johnvg | 2001-03-27 15:54:51 +0000 |
| commit | 6b8957b10a9fd22ae5c890839645b01c99cf4244 (patch) | |
| tree | 57756ac99b2c64e853360f1a9dc754b1f74e465d /frontend | |
| parent | allow 'else fail' for all if nodes on root or in (diff) | |
unfold all macros and local functions in macros
changed Declaration type
fixed crash when macro appears only in dcl module
added make with caching in 'main'
use BoxedIdent in hashtable
git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@344 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d
Diffstat (limited to 'frontend')
| -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) |