diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/StdCompare.dcl | 2 | ||||
| -rw-r--r-- | frontend/StdCompare.icl | 8 | ||||
| -rw-r--r-- | frontend/analtypes.icl | 13 | ||||
| -rw-r--r-- | frontend/check.icl | 5 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 135 | ||||
| -rw-r--r-- | frontend/comparedefimp.icl | 9 | ||||
| -rw-r--r-- | frontend/convertimportedtypes.icl | 32 | ||||
| -rw-r--r-- | frontend/explicitimports.icl | 8 | ||||
| -rw-r--r-- | frontend/frontend.icl | 1 | ||||
| -rw-r--r-- | frontend/general.dcl | 4 | ||||
| -rw-r--r-- | frontend/general.icl | 11 | ||||
| -rw-r--r-- | frontend/generics1.icl | 206 | ||||
| -rw-r--r-- | frontend/genericsupport.dcl | 20 | ||||
| -rw-r--r-- | frontend/genericsupport.icl | 40 | ||||
| -rw-r--r-- | frontend/overloading.icl | 37 | ||||
| -rw-r--r-- | frontend/parse.icl | 55 | ||||
| -rw-r--r-- | frontend/postparse.icl | 3 | ||||
| -rw-r--r-- | frontend/predef.dcl | 4 | ||||
| -rw-r--r-- | frontend/predef.icl | 11 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 20 | ||||
| -rw-r--r-- | frontend/syntax.icl | 25 | ||||
| -rw-r--r-- | frontend/trans.icl | 26 | ||||
| -rw-r--r-- | frontend/type.icl | 10 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 46 |
24 files changed, 575 insertions, 156 deletions
diff --git a/frontend/StdCompare.dcl b/frontend/StdCompare.dcl index eb08b3f..f9cebea 100644 --- a/frontend/StdCompare.dcl +++ b/frontend/StdCompare.dcl @@ -15,7 +15,7 @@ instance =< Type, SymbIdent instance == BasicType, TypeVar, AttributeVar, AttrInequality, TypeSymbIdent, DefinedSymbol, TypeContext , BasicValue, FunKind, (Global a) | == a, Priority, Assoc, Type, - ConsVariable, SignClassification, TypeCons + ConsVariable, SignClassification, TypeCons, TCClass instance < MemberDef diff --git a/frontend/StdCompare.icl b/frontend/StdCompare.icl index 91593b7..64ba219 100644 --- a/frontend/StdCompare.icl +++ b/frontend/StdCompare.icl @@ -48,6 +48,14 @@ instance == TypeContext where (==) tc1 tc2 = tc1.tc_class == tc2.tc_class && tc1.tc_types == tc2.tc_types +instance == TCClass +where + (==) (TCClass x) (TCClass y) = x == y + (==) (TCGeneric {gtc_class}) (TCClass y) = gtc_class == y + (==) (TCClass x) (TCGeneric {gtc_class}) = x == gtc_class + (==) (TCGeneric {gtc_generic=g1,gtc_kind=k1}) (TCGeneric {gtc_generic=g2,gtc_kind=k2}) + = g1 == g2 && k1 == k2 + instance == BasicType where (==) bt1 bt2 = equal_constructor bt1 bt2 diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index 5b299cf..cdf6bfd 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -681,12 +681,17 @@ determine_kinds_of_type_contexts modules type_contexts class_infos as = foldSt (determine_kinds_of_type_context modules) type_contexts (class_infos, as) where determine_kinds_of_type_context :: !{#CommonDefs} !TypeContext !(!*ClassDefInfos, !*AnalyseState) -> (!*ClassDefInfos, !*AnalyseState) - determine_kinds_of_type_context modules {tc_class={glob_module,glob_object={ds_ident,ds_index}},tc_types} (class_infos, as) + determine_kinds_of_type_context modules {tc_class=TCClass {glob_module,glob_object={ds_ident,ds_index}},tc_types} (class_infos, as) # (class_kinds, class_infos) = class_infos![glob_module,ds_index] | length class_kinds == length tc_types # as = fold2St (verify_kind_of_type modules) class_kinds tc_types as = (class_infos, as) = abort ("determine_kinds_of_type_context" ---> (ds_ident, class_kinds, tc_types)) + determine_kinds_of_type_context modules {tc_class=TCGeneric {gtc_generic,gtc_kind},tc_types} (class_infos, as) + | length tc_types == 1 + # as = verify_kind_of_type modules gtc_kind (hd tc_types) as + = (class_infos, as) + = abort ("determine_kinds_of_type_context" ---> (gtc_generic.glob_object.ds_ident, gtc_kind, tc_types)) verify_kind_of_type modules req_kind type as # (kind_of_type, as=:{as_kind_heap,as_error}) = determineKind modules type as @@ -772,8 +777,10 @@ where determine_kinds_of_context_classes contexts class_infos_and_as = foldSt (determine_kinds_of_context_class modules) contexts class_infos_and_as where - determine_kinds_of_context_class modules {tc_class={glob_module,glob_object={ds_index}}} infos_and_as + determine_kinds_of_context_class modules {tc_class=TCClass {glob_module,glob_object={ds_index}}} infos_and_as = determine_kinds_of_class modules glob_module ds_index infos_and_as + determine_kinds_of_context_class modules {tc_class=TCGeneric {gtc_kind}} infos_and_as + = infos_and_as bind_kind_vars type_vars kind_ptrs type_var_heap = fold2St bind_kind_var type_vars kind_ptrs type_var_heap @@ -880,7 +887,7 @@ where (as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars it_vars as_type_var_heap as_kind_heap as = { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap, as_error = as_error } (class_infos, as) = determine_kinds_of_type_contexts common_defs - [{tc_class = ins_class, tc_types = it_types, tc_var = nilPtr} : it_context] class_infos as + [{tc_class = TCClass ins_class, tc_types = it_types, tc_var = nilPtr} : it_context] class_infos as = (class_infos, { as & as_error = popErrorAdmin as.as_error}) check_kinds_of_generics common_defs index generic_defs class_infos gen_heap as diff --git a/frontend/check.icl b/frontend/check.icl index 28bc2a5..cd4cb8a 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -884,7 +884,7 @@ checkAndCollectTypesOfContextsOfSpecials :: [TypeContext] *PredefinedSymbols *Er checkAndCollectTypesOfContextsOfSpecials type_contexts predef_symbols error = mapSt2 check_and_collect_context_types_of_special type_contexts predef_symbols error where - check_and_collect_context_types_of_special {tc_class={glob_object={ds_ident,ds_index},glob_module},tc_types} predef_symbols error + check_and_collect_context_types_of_special {tc_class=TCClass {glob_object={ds_ident,ds_index},glob_module},tc_types} predef_symbols error | hasNoTypeVariables tc_types = (tc_types, predef_symbols,error) # {pds_def,pds_module} = predef_symbols.[PD_ArrayClass] @@ -894,6 +894,8 @@ where | glob_module==pds_module && ds_index==pds_def && is_lazy_or_strict_list tc_types predef_symbols = (tc_types, predef_symbols,error) = (tc_types, predef_symbols,checkError ds_ident.id_name "illegal specialization" error) + check_and_collect_context_types_of_special {tc_class=TCGeneric {gtc_generic},tc_types} predef_symbols error + = (tc_types, predef_symbols,checkError gtc_generic.glob_object.ds_ident.id_name "genenric specials are illegal" error) hasNoTypeVariables [] = True @@ -3408,6 +3410,7 @@ where <=< adjustPredefSymbol PD_ConsRIGHT mod_index STE_Constructor <=< adjustPredefSymbol PD_GenericBimap mod_index STE_Generic <=< adjustPredefSymbol PD_bimapId mod_index STE_DclFunction + <=< adjustPredefSymbol PD_TypeGenericDict mod_index STE_Type ) # (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_StdMisc] | pre_mod.pds_def == mod_index diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index 19f63a7..5b25c06 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -3,7 +3,7 @@ implementation module checktypes import StdEnv import syntax, checksupport, check, typesupport, utilities, compilerSwitches // , RWSDebug - +import genericsupport :: TypeSymbols = { ts_type_defs :: !.{# CheckedTypeDef} @@ -671,9 +671,11 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de where is_type_var (TV _) = True is_type_var _ = False - - compare_context_and_instance_types ins_class it_types {tc_class, tc_types} cs_error - | ins_class<>tc_class + + compare_context_and_instance_types ins_class it_types {tc_class=TCGeneric _, tc_types} cs_error + = cs_error + compare_context_and_instance_types ins_class it_types {tc_class=TCClass clazz, tc_types} cs_error + | ins_class<>clazz = cs_error # are_equal = fold2St compare_context_and_instance_type it_types tc_types True @@ -807,76 +809,59 @@ where checkTypeContext :: !Index !TypeContext !(!v:{# ClassDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState) -> (!TypeContext,!(!v:{# ClassDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)) -checkTypeContext mod_index tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ident=ds_ident=:{id_name,id_info},ds_arity}},tc_types} - (class_defs, ots, oti, cs=:{cs_symbol_table, cs_predef_symbols}) - # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table - cs = { cs & cs_symbol_table = cs_symbol_table } - # (class_index, class_module) = retrieveGlobalDefinition entry STE_Class mod_index - | class_index <> NotFound - # (class_def, class_index, class_defs, ots_modules) = getClassDef class_index class_module mod_index class_defs ots.ots_modules - ots = { ots & ots_modules = ots_modules } - (tc_types, (ots, oti, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs) - cs = check_context_types class_def.class_name tc_types cs - tc = { tc & tc_class = { tc_class & glob_object = { class_name & ds_index = class_index }, glob_module = class_module }, tc_types = tc_types} - | class_def.class_arity == ds_arity - = (tc, (class_defs, ots, oti, cs)) - = (tc, (class_defs, ots, oti, { cs & cs_error = checkError id_name "used with wrong arity" cs.cs_error })) - = ({tc & tc_types = []}, (class_defs, ots, oti, { cs & cs_error = checkError id_name "undefined" cs.cs_error })) +checkTypeContext mod_index tc=:{tc_class, tc_types} (class_defs, ots, oti, cs) + # (tc_class, (class_defs, ots, cs=:{cs_error})) = check_context_class tc_class (class_defs, ots, cs) + | cs_error.ea_ok + # (tc_types, (ots, oti, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs) + # cs = check_context_types tc_class tc_types cs + = ({tc & tc_class = tc_class, tc_types = tc_types}, (class_defs, ots, oti, cs)) + = ({tc & tc_types = []}, (class_defs, ots, oti, cs)) where - - check_context_types tc_class [] cs=:{cs_error} - = { cs & cs_error = checkError tc_class "type context should contain one or more type variables" cs_error} - check_context_types tc_class [((CV {tv_name}) :@: _):_] cs=:{cs_error} - = cs -// = { cs & cs_error = checkError tv_name "not allowed as higher order type variable in context" cs_error} - check_context_types tc_class [TV _ : types] cs - = cs - check_context_types tc_class [type : types] cs - = check_context_types tc_class types cs -checkTypeContext1 :: !Index !TypeContext !(!v:{# ClassDef}, !x:{# GenericDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState) - -> (!TypeContext,!(!v:{# ClassDef}, !x:{# GenericDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)) -checkTypeContext1 mod_index tc (class_defs, generic_defs, ots, oti, cs) - # (entry, cs) = get_entry tc cs - = check_context mod_index entry tc (class_defs, generic_defs, ots, oti, cs) -where - get_entry tc cs=:{cs_symbol_table} - # (entry, cs_symbol_table) = readPtr tc.tc_class.glob_object.ds_ident.id_info cs_symbol_table - = (entry, {cs & cs_symbol_table = cs_symbol_table}) - - check_context - mod_index - entry - tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ident=ds_ident=:{id_name,id_info},ds_arity}},tc_types} - (class_defs, generic_defs, ots, oti, cs) + check_context_class (TCClass cl) (class_defs, ots, cs) + # (entry, cs_symbol_table) = readPtr cl.glob_object.ds_ident.id_info cs.cs_symbol_table + # cs = { cs & cs_symbol_table = cs_symbol_table } # (class_index, class_module) = retrieveGlobalDefinition entry STE_Class mod_index | class_index <> NotFound # (class_def, class_index, class_defs, ots_modules) = getClassDef class_index class_module mod_index class_defs ots.ots_modules - ots = { ots & ots_modules = ots_modules } - (tc_types, (ots, oti, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs) - cs = check_context_types class_def.class_name tc_types cs - tc = { tc & tc_class = { tc_class & glob_object = { class_name & ds_index = class_index }, glob_module = class_module }, tc_types = tc_types} - | class_def.class_arity == ds_arity - = (tc, (class_defs, generic_defs, ots, oti, cs)) - = (tc, (class_defs, generic_defs, ots, oti, { cs & cs_error = checkError id_name "used with wrong arity" cs.cs_error })) - = ({tc & tc_types = []}, (class_defs, generic_defs, ots, oti, { cs & cs_error = checkError id_name "class undefined" cs.cs_error })) - check_context - mod_index - entry - tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ident=ds_ident=:{id_name,id_info},ds_arity}},tc_types} - (class_defs, generic_defs, ots, oti, cs) - # (generic_index, generic_module) = retrieveGlobalDefinition entry STE_Generic mod_index + # ots = { ots & ots_modules = ots_modules } + | class_def.class_arity == cl.glob_object.ds_arity + # checked_class = + { cl + & glob_module = class_module + , glob_object = {cl.glob_object & ds_index = class_index} + } + = (TCClass checked_class, (class_defs, ots, cs)) + # cs_error = checkError cl.glob_object.ds_ident "class used with wrong arity" cs.cs_error + = (TCClass cl, (class_defs, ots, {cs & cs_error = cs_error})) + # cs_error = checkError cl.glob_object.ds_ident "class undefined" cs.cs_error + = (TCClass cl, (class_defs, ots, {cs & cs_error = cs_error})) + check_context_class (TCGeneric gtc=:{gtc_generic, gtc_kind}) (class_defs, ots, cs) + # gen_name = gtc_generic.glob_object.ds_ident + # (entry, cs_symbol_table) = readPtr gen_name.id_info cs.cs_symbol_table + # cs = { cs & cs_symbol_table = cs_symbol_table } + # clazz = + { glob_module = -1 + , glob_object = + { ds_ident = genericIdentToClassIdent gen_name gtc_kind + , ds_arity = 1 + , ds_index = -1 + } + } + + # (generic_index, generic_module) = retrieveGlobalDefinition entry STE_Generic mod_index | generic_index <> NotFound - # (generic_def, generic_index, generic_defs, ots_modules) = getGenericDef generic_index generic_module mod_index generic_defs ots.ots_modules - ots = { ots & ots_modules = ots_modules } - (tc_types, (ots, oti, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs) - //cs = check_context_types generic_def.gen_name tc_types cs - tc = { tc & tc_class = { tc_class & glob_object = { class_name & ds_index = generic_index }, glob_module = generic_module }, tc_types = tc_types} - | ds_arity == 1 - = (tc, (class_defs, generic_defs, ots, oti, cs)) - = (tc, (class_defs, generic_defs, ots, oti, { cs & cs_error = checkError id_name "used with wrong arity" cs.cs_error })) - = ({tc & tc_types = []}, (class_defs, generic_defs, ots, oti, { cs & cs_error = checkError id_name "generic undefined" cs.cs_error })) - + | gtc_generic.glob_object.ds_arity == 1 + # checked_gen = + { glob_module = generic_module + , glob_object = {gtc_generic.glob_object & ds_index = generic_index} + } + = (TCGeneric {gtc & gtc_generic = checked_gen, gtc_class=clazz}, (class_defs, ots, cs)) + # cs_error = checkError gen_name "generic used with wrong arity: generic has always has one class argument" cs.cs_error + = (TCGeneric {gtc & gtc_class=clazz}, (class_defs, ots, {cs & cs_error = cs_error})) + # cs_error = checkError gen_name "generic undefined" cs.cs_error + = (TCGeneric {gtc & gtc_class=clazz}, (class_defs, ots, {cs & cs_error = cs_error})) + check_context_types tc_class [] cs=:{cs_error} = { cs & cs_error = checkError tc_class "type context should contain one or more type variables" cs_error} check_context_types tc_class [((CV {tv_name}) :@: _):_] cs=:{cs_error} @@ -887,6 +872,7 @@ where check_context_types tc_class [type : types] cs = check_context_types tc_class types cs + checkTypeContexts :: ![TypeContext] !Index !v:{# ClassDef} !u:OpenTypeSymbols !*OpenTypeInfo !*CheckState -> (![TypeContext], !u:{# CheckedTypeDef}, !v:{# ClassDef}, u:{# DclModule}, !*TypeHeaps, !*CheckState) checkTypeContexts tcs mod_index class_defs ots oti cs @@ -1412,7 +1398,7 @@ where [ field : rev_fields ] var_heap symbol_table = (rev_fields, var_heap, symbol_table) - build_context_fields mod_index field_nr [{tc_class = {glob_module, glob_object={ds_index}}}:tcs] rec_type rec_type_index + build_context_fields mod_index field_nr [{tc_class = TCClass {glob_module, glob_object={ds_index}}}:tcs] rec_type rec_type_index next_selector_index rev_fields rev_field_types class_defs modules var_heap symbol_table # ({class_name, class_arity, class_dictionary = {ds_ident, ds_index}}, _, class_defs, modules) = getClassDef ds_index glob_module mod_index class_defs modules type_symb = MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident class_arity @@ -1432,6 +1418,17 @@ where (field, var_heap, symbol_table) = build_field field_nr class_name.id_name rec_type_index rec_type field_type next_selector_index var_heap symbol_table = build_context_fields mod_index (inc field_nr) tcs rec_type rec_type_index (inc next_selector_index) [ field : rev_fields ] [field_type : rev_field_types] class_defs modules var_heap symbol_table + + build_context_fields mod_index field_nr [{tc_class = TCGeneric {gtc_generic, gtc_kind}} :tcs] rec_type rec_type_index + next_selector_index rev_fields rev_field_types class_defs modules var_heap symbol_table + // FIXME: We do not know the type before the generic phase. + // The generic phase currently does not update the type. + # field_type = makeAttributedType TA_Multi TE + # class_name = genericIdentToClassIdent gtc_generic.glob_object.ds_ident gtc_kind + # (field, var_heap, symbol_table) = build_field field_nr class_name.id_name rec_type_index rec_type field_type next_selector_index var_heap symbol_table + = build_context_fields mod_index (inc field_nr) tcs rec_type rec_type_index (inc next_selector_index) [ field : rev_fields ] + [field_type : rev_field_types] class_defs modules var_heap symbol_table + build_context_fields mod_index field_nr [] rec_type rec_type_index next_selector_index rev_fields rev_field_types class_defs modules var_heap symbol_table = (next_selector_index, rev_fields, rev_field_types , class_defs, modules, var_heap, symbol_table) diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index a0ffc60..9acbb72 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -724,6 +724,15 @@ instance t_corresponds TypeContext where = t_corresponds dclDef.tc_class iclDef.tc_class &&& t_corresponds dclDef.tc_types iclDef.tc_types +instance t_corresponds TCClass where + t_corresponds (TCClass class1) (TCClass class2) + = t_corresponds class1 class2 + t_corresponds (TCGeneric {gtc_generic=gen1, gtc_kind=kind1}) (TCGeneric {gtc_generic=gen2, gtc_kind=kind2}) + = t_corresponds gen1 gen2 + &&& equal kind1 kind2 + t_corresponds _ _ + = return False + instance t_corresponds DefinedSymbol where t_corresponds dclDef iclDef = equal dclDef.ds_ident iclDef.ds_ident diff --git a/frontend/convertimportedtypes.icl b/frontend/convertimportedtypes.icl index 904521a..a740d08 100644 --- a/frontend/convertimportedtypes.icl +++ b/frontend/convertimportedtypes.icl @@ -10,9 +10,16 @@ convertDclModule main_dcl_module_n dcl_mods common_defs imported_types imported_ # {dcl_functions,dcl_common=dcl_common=:{com_type_defs,com_cons_defs,com_selector_defs},dcl_macro_conversions} = dcl_mods.[main_dcl_module_n] = case dcl_macro_conversions of Yes _ - # (icl_type_defs, imported_types) = imported_types![main_dcl_module_n] + #!(icl_type_defs, imported_types) = imported_types![main_dcl_module_n] + common_defs = { common \\ common <-: common_defs } common_defs = { common_defs & [main_dcl_module_n] = dcl_common } +/* + // AA: HACK: extend dcl modules with the icl module + icl_common = common_defs.[main_dcl_module_n] + common_defs = arrayPlusList common_defs [icl_common] + common_defs = { common_defs & [main_dcl_module_n] = dcl_common } +*/ types_and_heaps = convert_dcl_functions dcl_functions common_defs ( { imported_types & [main_dcl_module_n] = com_type_defs }, imported_conses, var_heap, type_heaps) types_and_heaps = convertConstructorTypes com_cons_defs main_dcl_module_n common_defs types_and_heaps (imported_types, imported_conses, var_heap, type_heaps) = convertSelectorTypes com_selector_defs main_dcl_module_n common_defs types_and_heaps @@ -24,7 +31,7 @@ where = iFoldSt (convert_dcl_function dcl_functions common_defs) 0 (size dcl_functions) types_and_heaps convert_dcl_function dcl_functions common_defs dcl_index (imported_types, imported_conses, var_heap, type_heaps) - # {ft_type, ft_type_ptr} = dcl_functions.[dcl_index] + #!{ft_type, ft_type_ptr, ft_symb} = dcl_functions.[dcl_index] (ft_type, imported_types, imported_conses, type_heaps, var_heap) = convertSymbolType cDontRemoveAnnotations common_defs ft_type main_dcl_module_n imported_types imported_conses type_heaps var_heap = (imported_types, imported_conses, var_heap <:= (ft_type_ptr, VI_ExpandedType ft_type), type_heaps) @@ -33,7 +40,7 @@ convertConstructorTypes cons_defs main_dcl_module_n common_defs types_and_heaps = iFoldSt (convert_constructor_type common_defs cons_defs) 0 (size cons_defs) types_and_heaps where convert_constructor_type common_defs cons_defs cons_index (imported_types, imported_conses, var_heap, type_heaps) - # {cons_type_ptr, cons_type} = cons_defs.[cons_index] + #!{cons_type_ptr, cons_type, cons_symb} = cons_defs.[cons_index] (cons_type, imported_types, imported_conses, type_heaps, var_heap) = convertSymbolType cDontRemoveAnnotations common_defs cons_type main_dcl_module_n imported_types imported_conses type_heaps var_heap = (imported_types, imported_conses, var_heap <:= (cons_type_ptr, VI_ExpandedType cons_type), type_heaps) @@ -42,7 +49,7 @@ convertSelectorTypes selector_defs main_dcl_module_n common_defs types_and_heaps = iFoldSt (convert_selector_type common_defs selector_defs) 0 (size selector_defs) types_and_heaps where convert_selector_type common_defs selector_defs sel_index (imported_types, imported_conses, var_heap, type_heaps) - # {sd_type_ptr, sd_type} = selector_defs.[sel_index] + #!{sd_type_ptr, sd_type, sd_symb} = selector_defs.[sel_index] (sd_type, imported_types, imported_conses, type_heaps, var_heap) = convertSymbolType cDontRemoveAnnotations common_defs sd_type main_dcl_module_n imported_types imported_conses type_heaps var_heap = (imported_types, imported_conses, var_heap <:= (sd_type_ptr, VI_ExpandedType sd_type), type_heaps) @@ -50,7 +57,7 @@ where convertIclModule :: !Int !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps -> (!*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps) convertIclModule main_dcl_module_n common_defs imported_types imported_conses var_heap type_heaps - # types_and_heaps = convertConstructorTypes common_defs.[main_dcl_module_n].com_cons_defs main_dcl_module_n common_defs (imported_types, imported_conses, var_heap, type_heaps) + #! types_and_heaps = convertConstructorTypes common_defs.[main_dcl_module_n].com_cons_defs main_dcl_module_n common_defs (imported_types, imported_conses, var_heap, type_heaps) = convertSelectorTypes common_defs.[main_dcl_module_n].com_selector_defs main_dcl_module_n common_defs types_and_heaps convertImportedTypeSpecifications :: !Int !{# DclModule} !{# {# FunType} } !{# CommonDefs} !ImportedConstructors !ImportedFunctions @@ -62,7 +69,7 @@ convertImportedTypeSpecifications main_dcl_module_n dcl_mods dcl_functions commo # abstract_type_indexes = iFoldSt (determine_abstract_type com_type_defs) 0 (size com_type_defs) [] | isEmpty abstract_type_indexes -> convert_imported_type_specs dcl_functions common_defs imported_conses imported_functions imported_types type_heaps var_heap - # (icl_type_defs, imported_types) = imported_types![main_dcl_module_n] + #!(icl_type_defs, imported_types) = imported_types![main_dcl_module_n] type_defs = foldSt (insert_abstract_type /*conversion_table.[cTypeDefs]*/) abstract_type_indexes { icl_type_def \\ icl_type_def <-: icl_type_defs } (imported_types, type_heaps, var_heap) = convert_imported_type_specs dcl_functions common_defs imported_conses imported_functions @@ -93,21 +100,21 @@ where = convert_imported_constructors common_defs imported_conses imported_types type_heaps var_heap convert_imported_function dcl_functions common_defs {glob_object,glob_module} (imported_types, imported_conses, type_heaps, var_heap) - # {ft_type_ptr,ft_type} = dcl_functions.[glob_module].[glob_object] + #!{ft_type_ptr,ft_type,ft_symb} = dcl_functions.[glob_module].[glob_object] (ft_type, imported_types, imported_conses, type_heaps, var_heap) = convertSymbolType cDontRemoveAnnotations common_defs ft_type main_dcl_module_n imported_types imported_conses type_heaps var_heap = (imported_types, imported_conses, type_heaps, var_heap <:= (ft_type_ptr, VI_ExpandedType ft_type)) - + convert_imported_constructors common_defs [] imported_types type_heaps var_heap = (imported_types, type_heaps, var_heap) convert_imported_constructors common_defs [ {glob_module, glob_object} : conses ] imported_types type_heaps var_heap - # {com_cons_defs,com_selector_defs} = common_defs.[glob_module] + #!{com_cons_defs,com_selector_defs} = common_defs.[glob_module] {cons_type_ptr,cons_type,cons_type_index,cons_symb} = common_defs.[glob_module].com_cons_defs.[glob_object] (cons_type, imported_types, conses, type_heaps, var_heap) = convertSymbolType cDontRemoveAnnotations common_defs cons_type main_dcl_module_n imported_types conses type_heaps var_heap var_heap = var_heap <:= (cons_type_ptr, VI_ExpandedType cons_type) ({td_rhs}, imported_types) = imported_types![glob_module].[cons_type_index] -// ---> ("convert_imported_constructors", cons_symb, cons_type) + //---> ("convert_imported_constructors", cons_symb, cons_type) = case td_rhs of RecordType {rt_fields} # (imported_types, conses, type_heaps, var_heap) @@ -118,9 +125,8 @@ where -> convert_imported_constructors common_defs conses imported_types type_heaps var_heap where convert_type_of_imported_field module_index selector_defs fields field_index (imported_types, conses, type_heaps, var_heap) - # field_index = fields.[field_index].fs_index - {sd_type_ptr,sd_type} = selector_defs.[field_index] + #!field_index = fields.[field_index].fs_index + {sd_type_ptr,sd_type,sd_symb} = selector_defs.[field_index] (sd_type, imported_types, conses, type_heaps, var_heap) = convertSymbolType cDontRemoveAnnotations common_defs sd_type main_dcl_module_n imported_types conses type_heaps var_heap = (imported_types, conses, type_heaps, var_heap <:= (sd_type_ptr, VI_ExpandedType sd_type)) - diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl index 1918283..bd2cea2 100644 --- a/frontend/explicitimports.icl +++ b/frontend/explicitimports.icl @@ -824,9 +824,13 @@ instance check_completeness Type where = ccs instance check_completeness TypeContext where - check_completeness {tc_class, tc_types} cci ccs + check_completeness {tc_class=TCClass class_symb, tc_types} cci ccs = check_completeness tc_types cci - (check_whether_ident_is_imported tc_class.glob_object.ds_ident STE_Class cci ccs) + (check_whether_ident_is_imported class_symb.glob_object.ds_ident STE_Class cci ccs) + check_completeness {tc_class=TCGeneric {gtc_generic}, tc_types} cci ccs + = check_completeness tc_types cci + (check_whether_ident_is_imported gtc_generic.glob_object.ds_ident STE_Generic cci ccs) + instance check_completeness (TypeDef TypeRhs) where check_completeness td=:{td_rhs, td_context} cci ccs diff --git a/frontend/frontend.icl b/frontend/frontend.icl index 97f4778..5161197 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -211,7 +211,6 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an = (-1,predef_symbols) # (cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap) = analyseGroups common_defs imported_funs array_instances.ali_instances_range main_dcl_module_n stdStrictLists_module_n (components -*-> "Analyse") fun_defs var_heap expression_heap - // # (components, fun_defs, error) = showComponents2 components 0 fun_defs acc_args error (components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap, acc_args) diff --git a/frontend/general.dcl b/frontend/general.dcl index 5169ee3..fa4f821 100644 --- a/frontend/general.dcl +++ b/frontend/general.dcl @@ -5,6 +5,7 @@ from StdEnv import instance <<< Int,class <<< (..),instance + Int,class + (..),i 0.2*/ //1.3 from StdEnv import <<<, +, ~ +from StdString import String //3.1 instance ~ Bool @@ -32,6 +33,9 @@ hasOption :: (Optional x) -> Bool :: Choice a b = Either a | Or b (--->) infix :: .a !b -> .a | <<< b +(<---) infix :: !.a !b -> .a | <<< b +traceValue :: !String !String .a -> .a + (-?->) infix :: .a !(!Bool, !b) -> .a | <<< b instance + {#Char} diff --git a/frontend/general.icl b/frontend/general.icl index 3506334..cd25cbc 100644 --- a/frontend/general.icl +++ b/frontend/general.icl @@ -67,6 +67,17 @@ where = val = halt +// Strict version of --->, which evaluates its lhs first +(<---) infix :: !.a !b -> .a | <<< b +(<---) value message = value ---> message + +// Tracing evaluation of a value, otherwise acts like identity +traceValue :: !String !String .a -> .a +traceValue contextdesc valuedesc value += (value <--- (contextdesc+++" <<== "+++valuedesc)) ---> (contextdesc+++" ==>> "+++valuedesc) + + + (-?->) infix :: .a !(!Bool, !b) -> .a | <<< b (-?->) val (cond, message) | cond diff --git a/frontend/generics1.icl b/frontend/generics1.icl index 9acad49..5f0ead6 100644 --- a/frontend/generics1.icl +++ b/frontend/generics1.icl @@ -16,6 +16,15 @@ from transform import Group import genericsupport +//**************************************************************************************** +// tracing +//**************************************************************************************** +traceGenerics context message x + //:== traceValue context message x + :== x + + + //************************************************************************************** // Data types //************************************************************************************** @@ -77,33 +86,43 @@ convertGenerics #! td_infos = clearTypeDefInfos td_infos //---> ("used module numbers ", main_dcl_module_n, numberSetToList used_module_numbers) - #! (modules, heaps) = clearGenericDefs modules heaps - - #! (iso_range, funs, groups, td_infos, modules, heaps, error) - = buildGenericRepresentations - (main_dcl_module_n /*---> "====================== call buildGenericRepresentations"*/) - predefs - funs groups td_infos modules heaps error + #! (modules, heaps) + = traceGenerics "convertGenerics" "buildGenericRepresentations" + (clearGenericDefs modules heaps) + + # (iso_range, funs, groups, td_infos, modules, heaps, error) + = traceGenerics "convertGenerics" "buildGenericRepresentations" + (buildGenericRepresentations main_dcl_module_n predefs + funs groups td_infos modules heaps error) + | not error.ea_ok = (modules, groups, funs, [], td_infos, heaps, hash_table, u_predefs, dcl_modules, error) // build classes for each kind of each generic function #! (modules, dcl_modules, heaps, symbol_table, td_infos, error) - = buildClasses + = traceGenerics "convertGenerics" "buildClasses" + (buildClasses main_dcl_module_n used_module_numbers - modules dcl_modules heaps hash_table.hte_symbol_heap td_infos error - //---> ("====================== call buildClasses") + modules dcl_modules heaps hash_table.hte_symbol_heap td_infos error) #! hash_table = { hash_table & hte_symbol_heap = symbol_table } | not error.ea_ok = (modules, groups, funs, [], td_infos, heaps, hash_table, u_predefs, dcl_modules, error) #! (instance_range, funs, groups, modules, dcl_modules, td_infos, heaps, error) - = convertGenericCases main_dcl_module_n used_module_numbers predefs funs groups modules dcl_modules td_infos heaps error - //---> ("====================== call convertGenericCases") + = traceGenerics "convertGenerics" "convertGenericCases" + (convertGenericCases main_dcl_module_n used_module_numbers predefs funs groups modules dcl_modules td_infos heaps error) | not error.ea_ok = (modules, groups, funs, [], td_infos, heaps, hash_table, u_predefs, dcl_modules, error) + + #! (funs, modules, dcl_modules, heaps, error) + = traceGenerics "convertGenerics" "convertGenericTypeContexts" + (convertGenericTypeContexts main_dcl_module_n used_module_numbers predefs funs modules dcl_modules heaps error) + + | not error.ea_ok + = (modules, groups, funs, [], td_infos, heaps, hash_table, u_predefs, dcl_modules, error) + //#! funs = dump_funs 0 funs //#! dcl_modules = dump_dcl_modules 0 dcl_modules //#! error = error ---> "************************* generic phase completed ******************** " @@ -907,7 +926,7 @@ where #! (type_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap #! (tc_var_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap #! type_context = - { tc_class = {glob_module = module_index, glob_object=class_ds} + { tc_class = TCClass {glob_module = module_index, glob_object=class_ds} , tc_types = [ TV class_var ] , tc_var = tc_var_ptr } @@ -1183,7 +1202,7 @@ where build_context {gci_class, gci_module, gci_kind} tv hp_var_heap # (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap # type_context = - { tc_class = + { tc_class = TCClass { glob_module=gci_module // the same as icl module , glob_object = { ds_ident = genericIdentToClassIdent gc_name gci_kind @@ -1454,6 +1473,165 @@ where buildGenericCaseBody main_module_index {gc_name,gc_pos} st predefs td_infos modules heaps error # error = reportError gc_name gc_pos "cannot specialize to this type" error = (TransformedBody {tb_args=[], tb_rhs=EE}, td_infos, modules, heaps, error) + +//**************************************************************************************** +// convert generic type contexts into normal type contexts +//**************************************************************************************** + +convertGenericTypeContexts :: + !Index !NumberSet !PredefinedSymbols !*FunDefs !*Modules !*DclModules !*Heaps !*ErrorAdmin + -> (!*FunDefs, !*Modules, !*DclModules, !*Heaps, !*ErrorAdmin) +convertGenericTypeContexts main_module_index used_module_numbers predefs funs modules dcl_modules heaps error + # (funs, (modules, heaps, error)) = convert_functions 0 funs (modules, heaps, error) + + # (modules, dcl_modules, (heaps, error)) = convert_modules 0 modules dcl_modules (heaps, error) + + = (funs, modules, dcl_modules, heaps, error) +where + convert_functions fun_index funs st + | fun_index == size funs + = (funs, st) + # (fun, funs) = funs ! [fun_index] + # (fun, st) = convert_function fun st + # funs = {funs & [fun_index] = fun} + = convert_functions (inc fun_index) funs st + where + convert_function :: !FunDef (!*Modules, !*Heaps, !*ErrorAdmin) + -> (!FunDef, (!*Modules, !*Heaps, !*ErrorAdmin)) + convert_function fun=:{fun_type=Yes symbol_type=:{st_context}, fun_symb, fun_pos} st + # (has_converted, st_context, st) = convert_contexts fun_symb fun_pos st_context st + | has_converted + # fun = {fun & fun_type = Yes {symbol_type & st_context = st_context}} + = (fun, st) + = (fun, st) + convert_function fun st + = (fun, st) + + convert_modules module_index modules dcl_modules st + | module_index == size modules + = (modules, dcl_modules, st) + # (modules, dcl_modules, st) = convert_module module_index modules dcl_modules st + = convert_modules (inc module_index) modules dcl_modules st + + convert_module :: + !Index !*Modules !*DclModules (!*Heaps, !*ErrorAdmin) + -> (!*Modules, !*DclModules, (!*Heaps, !*ErrorAdmin)) + convert_module module_index modules dcl_modules st + | inNumberSet module_index used_module_numbers + #! (common_defs, modules) = modules ! [module_index] + #! (dcl_module=:{dcl_functions, dcl_common}, dcl_modules) = dcl_modules ! [module_index] + + #! (common_defs, modules, st) = convert_common_defs common_defs modules st + #! (dcl_common, modules, st) = convert_common_defs dcl_common modules st + #! (dcl_functions, modules, st) = convert_dcl_functions {x\\x<-:dcl_functions} modules st + + # dcl_modules = + { dcl_modules & [module_index] = + { dcl_module + & dcl_functions = dcl_functions + , dcl_common = dcl_common + } + } + # modules = {modules & [module_index] = common_defs} + = (modules, dcl_modules, st) + | otherwise + = (modules, dcl_modules, st) + + convert_common_defs common_defs=:{com_class_defs, com_member_defs, com_instance_defs} modules (heaps, error) + # (com_class_defs, st) + = updateArraySt convert_class {x\\x<-:com_class_defs} (modules, heaps, error) + # (com_member_defs, st) + = updateArraySt convert_member {x\\x<-:com_member_defs} st + # (com_instance_defs, (modules, heaps, error)) + = updateArraySt convert_instance {x\\x<-:com_instance_defs} st + + # common_defs = + { common_defs + & com_class_defs = com_class_defs + , com_member_defs = com_member_defs + , com_instance_defs = com_instance_defs + } + + = (common_defs, modules, (heaps, error)) + where + convert_class _ class_def=:{class_name, class_pos, class_context} st + # (ok, class_context, st) = convert_contexts class_name class_pos class_context st + | ok + # class_def={class_def & class_context = class_context} + = (class_def, st) + = (class_def, st) + convert_member _ member_def=:{me_symb, me_pos, me_type=me_type=:{st_context}} st + # (ok, st_context, st) = convert_contexts me_symb me_pos st_context st + | ok + # member_def={member_def & me_type = {me_type & st_context = st_context}} + = (member_def, st) + = (member_def, st) + + convert_instance _ ins=:{ins_type=ins_type=:{it_context}, ins_ident, ins_pos} st + # (ok, it_context, st) = convert_contexts ins_ident ins_pos it_context st + | ok + # ins={ins & ins_type = {ins_type & it_context = it_context}} + = (ins, st) + = (ins, st) + + convert_dcl_functions dcl_functions modules (heaps, error) + # (dcl_functions, (modules, heaps, error)) + = updateArraySt convert_dcl_function dcl_functions (modules, heaps, error) + = (dcl_functions, modules, (heaps, error)) + where + convert_dcl_function _ fun=:{ft_type=ft_type=:{st_context}, ft_symb, ft_pos} st + # (ok, st_context, st) = convert_contexts ft_symb ft_pos st_context st + | ok + # fun={fun & ft_type = {ft_type & st_context = st_context}} + = (fun, st) + = (fun, st) + + convert_contexts fun_name fun_pos [] st + = (False, [], st) + convert_contexts fun_name fun_pos all_tcs=:[tc:tcs] st + # (ok1, tc, st) = convert_context fun_name fun_pos tc st + # (ok2, tcs, st) = convert_contexts fun_name fun_pos tcs st + | ok1 || ok2 + = (True, [tc:tcs], st) + = (False, all_tcs, st) + + convert_context :: !Ident !Position !TypeContext (!*Modules, !*Heaps, !*ErrorAdmin) + -> (!Bool, !TypeContext, (!*Modules, !*Heaps, !*ErrorAdmin)) + convert_context fun_name fun_pos tc=:{tc_class=TCGeneric gtc=:{gtc_generic, gtc_kind, gtc_class}} (modules, heaps=:{hp_generic_heap}, error) + + # ({gen_info_ptr}, modules) = modules ! [gtc_generic.glob_module] . com_generic_defs . [gtc_generic.glob_object.ds_index] + # ({gen_classes}, hp_generic_heap) = readPtr gen_info_ptr hp_generic_heap + # opt_class_info = lookupGenericClassInfo gtc_kind gen_classes + # (tc_class, error) = case opt_class_info of + No + # error = reportError fun_name fun_pos "no generic cases for this kind" error + -> (TCGeneric gtc, error) + Yes class_info + # clazz = + { glob_module = class_info.gci_module + , glob_object = + { ds_ident = genericIdentToClassIdent gtc_generic.glob_object.ds_ident gtc_kind + , ds_arity = 1 + , ds_index = class_info.gci_class + } + } + //-> (TCClass clazz, error) + + /* + AA HACK: dummy dictionary + */ + #! {pds_module, pds_def} = predefs.[PD_TypeGenericDict] + #! pds_ident = predefined_idents.[PD_TypeGenericDict] + # dictionary = + { glob_module = pds_module + , glob_object={ds_ident=pds_ident, ds_arity=1, ds_index=pds_def} + } + -> (TCGeneric {gtc & gtc_class=clazz, gtc_dictionary=dictionary}, error) + + = (True, {tc & tc_class=tc_class}, (modules, {heaps & hp_generic_heap=hp_generic_heap}, error)) + convert_context fun_name fun_pos tc st + = (False, tc, st) + //**************************************************************************************** // specialization diff --git a/frontend/genericsupport.dcl b/frontend/genericsupport.dcl index 670979c..193afb2 100644 --- a/frontend/genericsupport.dcl +++ b/frontend/genericsupport.dcl @@ -12,6 +12,15 @@ addGenericClassInfo :: !GenericClassInfos -> !GenericClassInfos +getGenericClassInfo :: + !(Global Index) + !TypeKind + !{#CommonDefs} + !*GenericHeap + -> + ( Optional GenericClassInfo + , !*GenericHeap + ) getGenericMember :: !(Global Index) // generic !TypeKind // kind argument @@ -22,6 +31,17 @@ getGenericMember :: , !*GenericHeap ) +getGenericClass :: + !(Global Index) // generic + !TypeKind // kind argument + !{#CommonDefs} // modules + !*GenericHeap + -> + ( Optional (Global Index) + , !*GenericHeap + ) + + //**************************************************************************************** // Ident Helpers //**************************************************************************************** diff --git a/frontend/genericsupport.icl b/frontend/genericsupport.icl index b9033e2..2e42006 100644 --- a/frontend/genericsupport.icl +++ b/frontend/genericsupport.icl @@ -2,6 +2,21 @@ implementation module genericsupport import syntax, checksupport +getGenericClassInfo :: + !(Global Index) + !TypeKind + !{#CommonDefs} + !*GenericHeap + -> + ( Optional GenericClassInfo + , !*GenericHeap + ) +getGenericClassInfo {glob_module, glob_object} kind modules generic_heap + #! (gen_def=:{gen_info_ptr}) = modules.[glob_module].com_generic_defs.[glob_object] + #! ({gen_classes}, generic_heap) = readPtr gen_info_ptr generic_heap + #! opt_class_info = lookupGenericClassInfo kind gen_classes + = (opt_class_info, generic_heap) + getGenericMember :: !(Global Index) // generic !TypeKind // kind argument @@ -11,14 +26,31 @@ getGenericMember :: ( Optional (Global Index) , !*GenericHeap ) -getGenericMember {glob_module, glob_object} kind modules generic_heap - #! (gen_def=:{gen_info_ptr}) = modules.[glob_module].com_generic_defs.[glob_object] - #! ({gen_classes}, generic_heap) = readPtr gen_info_ptr generic_heap - = case lookupGenericClassInfo kind gen_classes of +getGenericMember gen kind modules generic_heap + # (opt_class_info, generic_heap) = getGenericClassInfo gen kind modules generic_heap + = case opt_class_info of No -> (No, generic_heap) Yes {gci_module, gci_member} #! member_glob = {glob_module = gci_module, glob_object = gci_member} -> (Yes member_glob, generic_heap) + +getGenericClass :: + !(Global Index) // generic + !TypeKind // kind argument + !{#CommonDefs} // modules + !*GenericHeap + -> + ( Optional (Global Index) + , !*GenericHeap + ) +getGenericClass gen kind modules generic_heap + # (opt_class_info, generic_heap) = getGenericClassInfo gen kind modules generic_heap + = case opt_class_info of + No -> (No, generic_heap) + Yes {gci_module, gci_class} + #! class_glob = {glob_module = gci_module, glob_object = gci_class} + -> (Yes class_glob, generic_heap) + lookupGenericClassInfo :: !TypeKind !GenericClassInfos -> !(Optional GenericClassInfo) lookupGenericClassInfo kind class_infos diff --git a/frontend/overloading.icl b/frontend/overloading.icl index 1e6f6c9..996cf6c 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -162,7 +162,11 @@ where = (CA_Context tc, [{ tc & tc_var = tc_var } : new_contexts], special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error) - reduce_any_context tc=:{tc_class=class_symb=:{glob_object={ds_index},glob_module},tc_types} defs instance_info new_contexts + reduce_any_context tc=:{tc_class=class_symb=:(TCGeneric {gtc_class})} defs instance_info new_contexts + special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error + = reduce_any_context {tc & tc_class = TCClass gtc_class} defs instance_info new_contexts + special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error + reduce_any_context tc=:{tc_class=class_symb=:(TCClass {glob_object={ds_index},glob_module}),tc_types} defs instance_info new_contexts special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error | is_predefined_symbol glob_module ds_index PD_TypeCodeClass predef_symbols # (red_context, (new_contexts, special_instances, type_pattern_vars, var_heap)) @@ -173,7 +177,9 @@ where (var_heap, type_heaps) coercion_env predef_symbols error = (CA_Instance class_appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error) - reduce_context {tc_class=class_symb=:{glob_object={ds_index},glob_module},tc_types} defs + reduce_context tc=:{tc_class=TCGeneric {gtc_class}} defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error + = reduce_context {tc & tc_class = TCClass gtc_class} defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error + reduce_context {tc_class=TCClass class_symb=:{glob_object={ds_index},glob_module},tc_types} defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error # {class_members,class_context,class_args,class_name} = defs.[glob_module].com_class_defs.[ds_index] | size class_members > 0 @@ -342,9 +348,11 @@ where _ -> (False, coercion_env) - context_is_reducible {tc_class,tc_types = [type : types]} predef_symbols + context_is_reducible {tc_class=TCClass class_symb,tc_types = [type : types]} predef_symbols // = type_is_reducible type && is_reducible types - = type_is_reducible type && types_are_reducible types type tc_class predef_symbols + = type_is_reducible type && types_are_reducible types type class_symb predef_symbols + context_is_reducible tc=:{tc_class=TCGeneric {gtc_class}, tc_types = [type : types]} predef_symbols + = type_is_reducible type && types_are_reducible types type gtc_class predef_symbols type_is_reducible (TempV _) = False @@ -810,7 +818,10 @@ where sub_classes = foldSt (remove_doubles super_classes) contexts [] = (sub_classes, type_heaps) - generate_super_classes {tc_class={glob_object={ds_index},glob_module},tc_types} (super_classes, type_heaps) + + generate_super_classes tc=:{tc_class=TCGeneric {gtc_class}} st + = generate_super_classes {tc & tc_class=TCClass gtc_class} st + generate_super_classes {tc_class=TCClass {glob_object={ds_index},glob_module},tc_types} (super_classes, type_heaps) # {class_args,class_members,class_context,class_dictionary} = defs.[glob_module].com_class_defs.[ds_index] th_vars = fold2St set_type class_args tc_types type_heaps.th_vars = foldSt subst_context_and_generate_super_classes class_context (super_classes, { type_heaps & th_vars = th_vars }) @@ -1029,10 +1040,16 @@ where determine_address :: !TypeContext !TypeContext ![(Int, Global DefinedSymbol)] !{#CommonDefs} !*TypeHeaps -> (!Optional [(Int, Global DefinedSymbol)],!*TypeHeaps) + determine_address tc1=:{tc_class=TCGeneric {gtc_class=class1}} tc2=:{tc_class=TCGeneric {gtc_class=class2}} address defs type_heaps + = determine_address {tc1 & tc_class=TCClass class1} {tc2 & tc_class=TCClass class2} address defs type_heaps + determine_address tc1=:{tc_class=TCGeneric {gtc_class=class1}} tc2 address defs type_heaps + = determine_address {tc1 & tc_class=TCClass class1} tc2 address defs type_heaps + determine_address tc1 tc2=:{tc_class=TCGeneric {gtc_class=class2}} address defs type_heaps + = determine_address tc1 {tc2 & tc_class=TCClass class2} address defs type_heaps determine_address tc1 tc2 address defs type_heaps=:{th_vars} | tc1 == tc2 = (Yes address, type_heaps) - # {tc_class={glob_object={ds_index},glob_module}} = tc2 + # {tc_class=TCClass {glob_object={ds_index},glob_module}} = tc2 {class_args,class_members,class_context,class_dictionary} = defs.[glob_module].com_class_defs.[ds_index] th_vars = foldr2 (\{tv_info_ptr} type -> writePtr tv_info_ptr (TVI_Type type)) th_vars class_args tc2.tc_types (_, super_instances, type_heaps) = substitute class_context { type_heaps & th_vars = th_vars } @@ -1161,7 +1178,7 @@ where = (ok, { ui_fun_defs & [fun_index] = fun_def }, ui_fun_env, ui_symbol_heap, type_code_info, var_heap, ui_error, predef_symbols) = (False, fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error, predef_symbols) - determine_class_argument {tc_class={glob_object={ds_ident={id_name}}}, tc_var} (variables, var_heap) + determine_class_argument {tc_class, tc_var} (variables, var_heap) # (var_info, var_heap) = readPtr tc_var var_heap = case var_info of VI_ForwardClassVar var_info_ptr @@ -1169,14 +1186,14 @@ where -> case var_info of VI_Empty # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap - -> ([var_info_ptr : variables], var_heap <:= (var_info_ptr, VI_ClassVar (build_var_name id_name) new_info_ptr 0)) + -> ([var_info_ptr : variables], var_heap <:= (var_info_ptr, VI_ClassVar (build_var_name (toString tc_class)) new_info_ptr 0)) _ -> abort ("determine_class_argument 1 (overloading.icl)") //<<- var_info) VI_Empty # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap var_heap = var_heap - -> ([tc_var : variables], var_heap <:= (tc_var, VI_ClassVar (build_var_name id_name) new_info_ptr 0)) + -> ([tc_var : variables], var_heap <:= (tc_var, VI_ClassVar (build_var_name (toString tc_class)) new_info_ptr 0)) _ -> abort ("determine_class_argument 2 (overloading.icl)") // <<- var_info) @@ -1848,7 +1865,7 @@ where instance <<< TypeContext where - (<<<) file tc = file <<< tc.tc_class.glob_object.ds_ident <<< ' ' <<< tc.tc_types <<< " <" <<< tc.tc_var <<< '>' + (<<<) file tc = file <<< toString tc.tc_class <<< ' ' <<< tc.tc_types <<< " <" <<< tc.tc_var <<< '>' instance <<< Special where diff --git a/frontend/parse.icl b/frontend/parse.icl index 53be8dd..84ff453 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -1381,7 +1381,8 @@ where # (more_contexts, pState) = want_contexts pState = (contexts ++ more_contexts, pState) = (contexts, tokenBack pState) - + +/* want_context pState # (class_names, pState) = wantSequence CommaToken TypeContext pState (types, pState) = wantList "type arguments" tryBrackType pState // tryBrackAType ?? @@ -1394,7 +1395,57 @@ where (class_ident, pState) = stringToIdent class_name IC_Class pState tc_class = { glob_object = MakeDefinedSymbol class_ident NoIndex (length types), glob_module = NoIndex } = ([{ tc_class = tc_class, tc_types = types, tc_var = nilPtr } : contexts], pState) - +*/ +/**/ + want_context pState + # (tc_classes, pState) = wantSepList "classes" CommaToken TypeContext try_tc_class pState + # (types, pState) = wantList "type arguments" tryBrackType pState // tryBrackAType ?? + # {ps_error} = pState + #! ok = ps_error.pea_ok + # pState = {pState & ps_error = ps_error} + | ok + = mapSt (build_context types (length types)) tc_classes pState + = ([], pState) + + try_tc_class pState + # (token, pState) = nextToken GeneralContext pState + = case token of + IdentToken name + # (token, pState) = nextToken GeneralContext pState + -> case token of + GenericOpenToken + # (ident, pState) = stringToIdent name IC_Generic pState + # (kind, pState) = wantKind pState + # generic_global_ds = { glob_object = MakeDefinedSymbol ident NoIndex 1, glob_module = NoIndex } + # class_global_ds = { glob_object = MakeDefinedSymbol {id_name="<no class>",id_info=nilPtr} NoIndex 1, glob_module = NoIndex} + + # gen_type_context = + { gtc_generic = { glob_object = MakeDefinedSymbol ident NoIndex 1, glob_module = NoIndex } + , gtc_kind = kind + , gtc_class = { glob_object = MakeDefinedSymbol {id_name="<no class>",id_info=nilPtr} NoIndex 1, glob_module = NoIndex} + , gtc_dictionary = { glob_object = MakeDefinedSymbol {id_name="<no generic dictionary>",id_info=nilPtr} NoIndex 1, glob_module = NoIndex} + } + + -> (True, TCGeneric gen_type_context, pState) + _ + # pState = tokenBack pState + # (ident, pState) = stringToIdent name IC_Class pState + # class_global_ds = { glob_object = MakeDefinedSymbol ident NoIndex (-1), glob_module = NoIndex } + -> (True, TCClass class_global_ds, pState) + _ + -> (False, abort "no tc_class", tokenBack pState) + + build_context types length_types (TCClass class_global_ds=:{glob_object}) pState + # tc_class = TCClass {class_global_ds & glob_object = {glob_object & ds_arity = length_types}} + = ({ tc_class = tc_class, tc_var = nilPtr, tc_types = types}, pState) + build_context types 1 (TCGeneric gtc=:{gtc_generic=gtc_generic=:{glob_object}}) pState + # gtc = { gtc & gtc_generic = {gtc_generic & glob_object = {glob_object & ds_arity = 1}}} + = ({ tc_class = TCGeneric gtc, tc_var = nilPtr, tc_types = types }, pState) + + build_context types length_types tc_class=:(TCGeneric _) pState + # pState = parseErrorSimple "type context" "generic class can have only one class argument" pState + = (abort "No TypeContext", pState) +/**/ optionalCoercions :: !ParseState -> ([AttrInequality], ParseState) optionalCoercions pState # (token, pState) = nextToken TypeContext pState diff --git a/frontend/postparse.icl b/frontend/postparse.icl index c4c9ecf..40f25b1 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -1318,7 +1318,7 @@ reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = EmptyRhs propertie c_defs = { c_defs & def_types = [type_def : c_defs.def_types] } = (fun_defs, c_defs, imports, imported_objects, ca) reorganiseDefinitions icl_module [PD_Class class_def=:{class_name,class_arity,class_args} members : defs] cons_count sel_count mem_count type_count ca - # type_context = { tc_class = {glob_module = NoIndex, glob_object = {ds_ident = class_name, ds_arity = class_arity, ds_index = NoIndex }}, + # type_context = { tc_class = TCClass {glob_module = NoIndex, glob_object = {ds_ident = class_name, ds_arity = class_arity, ds_index = NoIndex }}, tc_types = [ TV tv \\ tv <- class_args ], tc_var = nilPtr} (mem_defs, mem_macros, ca) = check_symbols_of_class_members members type_context ca (mem_symbs, mem_defs, class_size) = reorganise_member_defs mem_defs mem_count @@ -1427,7 +1427,6 @@ reorganiseDefinitions icl_module [PD_GenericCase gc : defs] cons_count sel_count #! fun = MakeNewImpOrDefFunction fun_name gc.gc_arity bodies (FK_Function cNameNotLocationDependent) NoPrio No gc.gc_pos #! inst = { gc & gc_body = GCB_FunDef fun } #! c_defs = {c_defs & def_generic_cases = [inst : c_defs.def_generic_cases]} - ---> ("collected", gc.gc_name, gc.gc_type_cons, length bodies) = (fun_defs, c_defs, imports, imported_objects, ca) reorganiseDefinitions icl_module [PD_Derive derive_defs : defs] cons_count sel_count mem_count type_count ca diff --git a/frontend/predef.dcl b/frontend/predef.dcl index c85e4b1..7a53a64 100644 --- a/frontend/predef.dcl +++ b/frontend/predef.dcl @@ -171,7 +171,9 @@ PD_ConsPAIR :== 188 PD_GenericBimap :== 189 PD_bimapId :== 190 -PD_NrOfPredefSymbols :== 191 +PD_TypeGenericDict :== 191 + +PD_NrOfPredefSymbols :== 192 GetTupleConsIndex tup_arity :== PD_Arity2TupleSymbol + tup_arity - 2 GetTupleTypeIndex tup_arity :== PD_Arity2TupleType + tup_arity - 2 diff --git a/frontend/predef.icl b/frontend/predef.icl index 8c4ee6b..162044d 100644 --- a/frontend/predef.icl +++ b/frontend/predef.icl @@ -171,7 +171,9 @@ PD_ConsPAIR :== 188 PD_GenericBimap :== 189 PD_bimapId :== 190 -PD_NrOfPredefSymbols :== 191 +PD_TypeGenericDict :== 191 + +PD_NrOfPredefSymbols :== 192 (<<=) infixl (<<=) symbol_table val @@ -296,6 +298,8 @@ predefined_idents [PD_ConsPAIR] = i "PAIR", [PD_GenericBimap] = i "bimap", [PD_bimapId] = i "bimapId", + + [PD_TypeGenericDict] = i "GenericDict", [PD_StdMisc] = i "StdMisc", [PD_abort] = i "abort", @@ -445,7 +449,8 @@ where <<- (local_predefined_idents, IC_Type, PD_TypePAIR) <<- (local_predefined_idents, IC_Expression, PD_ConsPAIR) <<- (local_predefined_idents, IC_Generic, PD_GenericBimap) - <<- (local_predefined_idents, IC_Expression, PD_bimapId) + <<- (local_predefined_idents, IC_Expression, PD_bimapId) + <<- (local_predefined_idents, IC_Type, PD_TypeGenericDict) <<- (local_predefined_idents, IC_Module, PD_StdMisc) <<- (local_predefined_idents, IC_Expression, PD_abort) @@ -572,7 +577,7 @@ where me_type = { st_vars = [], st_args = [], st_args_strictness=NotStrict, st_arity = 0, st_result = { at_attribute = TA_None, at_type = TV class_var }, - st_context = [ {tc_class = {glob_module = NoIndex, glob_object = {ds_ident = tc_class_name, ds_arity = 1, ds_index = NoIndex }}, + st_context = [ {tc_class = TCClass {glob_module = NoIndex, glob_object = {ds_ident = tc_class_name, ds_arity = 1, ds_index = NoIndex }}, tc_types = [ TV class_var ], tc_var = nilPtr}], st_attr_vars = [], st_attr_env = [] } diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index a71433a..136363e 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -871,13 +871,22 @@ cNonRecursiveAppl :== False } :: TypeContext = - { tc_class :: !Global DefinedSymbol + { tc_class :: !TCClass , tc_types :: ![Type] , tc_var :: !VarInfoPtr } -:: TCClass = TCClass !(Global DefinedSymbol) - | TCGeneric !(Global DefinedSymbol) !TypeKind +//AA: class in a type context is either normal class or a generic class +:: TCClass = TCClass !(Global DefinedSymbol) // Normal class + | TCGeneric !GenericTypeContext // Generic class + +:: GenericTypeContext = + { gtc_generic :: !(Global DefinedSymbol) + , gtc_kind :: !TypeKind + , gtc_class :: !(Global DefinedSymbol) // generated class + , gtc_dictionary:: !(Global DefinedSymbol) // HACK: dictionary different from the one contained in the class + } +//..AA :: AType = { at_attribute :: !TypeAttribute @@ -1355,7 +1364,8 @@ instance <<< (Module a) | <<< a, ParsedDefinition, InstanceType, AttributeVar, T TypeCons, IndexRange, FunType, - GenericClassInfo + GenericClassInfo, + TCClass instance <<< FunctionBody @@ -1365,6 +1375,8 @@ instance == TypeAttribute instance == Annotation instance == GlobalIndex +instance toString TCClass + instance <<< FunCall EmptySymbolTableEntry :== EmptySymbolTableEntryCAF.boxed_symbol_table_entry diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 43bf2a6..28b9649 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -844,13 +844,22 @@ cNotVarNumber :== -1 } :: TypeContext = - { tc_class :: !Global DefinedSymbol + { tc_class :: !TCClass , tc_types :: ![Type] , tc_var :: !VarInfoPtr } -:: TCClass = TCClass !(Global DefinedSymbol) - | TCGeneric !(Global DefinedSymbol) !TypeKind +//AA: class in a type context is either normal class or a generic class +:: TCClass = TCClass !(Global DefinedSymbol) // Normal class + | TCGeneric !GenericTypeContext // Generic class + +:: GenericTypeContext = + { gtc_generic :: !(Global DefinedSymbol) + , gtc_kind :: !TypeKind + , gtc_class :: !(Global DefinedSymbol) // generated class + , gtc_dictionary:: !(Global DefinedSymbol) // HACK: dictionary different from the one contained in the class + } +//..AA :: AType = { at_attribute :: !TypeAttribute @@ -1544,6 +1553,16 @@ instance <<< TypeContext where (<<<) file co = file <<< co.tc_class <<< " " <<< co.tc_types <<< " <" <<< co.tc_var <<< '>' +instance <<< TCClass +where + (<<<) file (TCClass glob) = file <<< glob + (<<<) file (TCGeneric {gtc_generic,gtc_kind}) = file <<< gtc_generic <<< gtc_kind + +instance toString TCClass +where + toString (TCClass clazz) = clazz.glob_object.ds_ident.id_name + toString (TCGeneric {gtc_generic,gtc_kind}) = gtc_generic.glob_object.ds_ident.id_name +++ toString gtc_kind + instance <<< SymbIdent where (<<<) file symb=:{symb_kind = SK_Function symb_index } diff --git a/frontend/trans.icl b/frontend/trans.icl index da85abc..492bba3 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -2494,7 +2494,7 @@ transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args | glob_module==ro.ro_stdStrictLists_module_n && is_cons_or_decons_of_UList_or_UTSList glob_object glob_module ro.ro_imported_funs && (not (isEmpty app_args)) // && trace_tn ("transformApplication "+++toString symb.symb_name) # {ft_type} = ro.ro_imported_funs.[glob_module].[glob_object] // type of cons instance of instance List [#] a | U(TS)List a - # [{tc_class={glob_module,glob_object={ds_index}}}:_] = ft_type.st_context + # [{tc_class=TCClass {glob_module,glob_object={ds_index}}}:_] = ft_type.st_context # member_n=find_member_n 0 symb.symb_name.id_name ro.ro_common_defs.[glob_module].com_class_defs.[ds_index].class_members # cons_u_member_index=ro.ro_common_defs.[glob_module].com_class_defs.[ds_index].class_members.[member_n].ds_index # {me_symb,me_offset}=ro.ro_common_defs.[glob_module].com_member_defs.[cons_u_member_index] @@ -2966,6 +2966,7 @@ convertSymbolType rem_annots common_defs st main_dcl_module_n imported_types co # {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap} = ets = (st, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) + /* expandSynTypesInSymbolType rem_annots common_defs st=:{st_args,st_args_strictness,st_result,st_context} ets # (_,(st_args,st_result), ets) = expandSynTypes rem_annots common_defs (st_args,st_result) ets @@ -2988,12 +2989,28 @@ addTypesOfDictionaries :: !{#CommonDefs} ![TypeContext] ![AType] -> [AType] addTypesOfDictionaries common_defs type_contexts type_args = mapAppend (add_types_of_dictionary common_defs) type_contexts type_args where - add_types_of_dictionary common_defs {tc_class = {glob_module, glob_object={ds_index}}, tc_types} + add_types_of_dictionary common_defs {tc_class = TCGeneric {gtc_dictionary={glob_module,glob_object={ds_ident,ds_index}}}, tc_types} + + /* + AA HACK: + Generic classes are always generated locally, + and therefore the their dictionaries are also generated localy. + Overloaded functions in DCL modules can have generic context restrictions, i.e. they will + get generic class dictionaries. + Problem: DCL function types refer to ICL type defs of dictionaries. + Solution: plug a dummy dictinary type, defined in StdGeneric. + It is possible because all generic class have one class argument and one member. + */ + # dict_type_symb = MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident 1 + # type_arg = { at_attribute = TA_Multi, at_type=hd tc_types } + = {at_attribute = TA_Multi, at_type = TA dict_type_symb [type_arg]} + + add_types_of_dictionary common_defs {tc_class = TCClass {glob_module, glob_object={ds_index,ds_ident}}, tc_types} # {class_arity, class_dictionary={ds_ident,ds_index}, class_cons_vars} = common_defs.[glob_module].com_class_defs.[ds_index] - dict_type_symb + # dict_type_symb = MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident class_arity - = { at_attribute = TA_Multi, /* at_annotation = AN_Strict, */ at_type = TA dict_type_symb ( + = { at_attribute = TA_Multi, /* at_annotation = AN_Strict, */ at_type = TA dict_type_symb ( // map (\type -> { at_attribute = TA_Multi, at_annotation = AN_None, at_type = type }) tc_types) } fst (mapSt (\type class_cons_vars -> let at_attribute = if (lowest_bit class_cons_vars) TA_MultiOfPropagatingConsVar TA_Multi @@ -3003,6 +3020,7 @@ where tc_types class_cons_vars))} + lowest_bit int :== int bitand 1 <> 0 //@ expandSynTypes diff --git a/frontend/type.icl b/frontend/type.icl index afb63a6..09249f4 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -826,10 +826,12 @@ freshSymbolType is_appl fresh_context_vars st=:{st_vars,st_args,st_result,st_con = attr_heap <:= (av_info_ptr, AVI_Empty) - collect_cons_variables_in_tc common_defs tc=:{tc_class={glob_module,glob_object={ds_index}}, tc_types} collected_cons_vars + collect_cons_variables_in_tc common_defs tc=:{tc_class=TCClass {glob_module,glob_object={ds_index}}, tc_types} collected_cons_vars # {class_cons_vars} = common_defs.[glob_module].com_class_defs.[ds_index] = collect_cons_variables tc_types class_cons_vars collected_cons_vars - + collect_cons_variables_in_tc common_defs tc=:{tc_class=TCGeneric {gtc_class}} collected_cons_vars + = collect_cons_variables_in_tc common_defs {tc & tc_class=TCClass gtc_class} collected_cons_vars + collect_cons_variables [] class_cons_vars collected_cons_vars = collected_cons_vars collect_cons_variables [type : tc_types] class_cons_vars collected_cons_vars @@ -1904,7 +1906,7 @@ where pds_ident = predefined_idents.[PD_TypeCodeMember] tc_member_symb = { symb_name = pds_ident, symb_kind = SK_OverloadedFunction {glob_module = pds_module, glob_object = pds_def }} (new_var_ptr, var_heap) = newPtr VI_Empty var_heap - context = {tc_class = tc_class_symb, tc_types = [fresh_var], tc_var = new_var_ptr} + context = {tc_class = TCClass tc_class_symb, tc_types = [fresh_var], tc_var = new_var_ptr} (expr_ptr, expr_heap) = newPtr EI_Empty expr_heap -> fresh_local_dynamics loc_dynamics (inc var_store, type_heaps, var_heap, expr_heap <:= (dyn_ptr, EI_TempDynamicType No loc_dynamics tdt_type [context] expr_ptr tc_member_symb), predef_symbols) @@ -1976,7 +1978,7 @@ where build_type_context tc_class_symb {tv_info_ptr} (var_heap, type_var_heap) # (TVI_Type fresh_var, type_var_heap) = readPtr tv_info_ptr type_var_heap (new_var_ptr, var_heap) = newPtr VI_Empty var_heap - = ({tc_class = tc_class_symb, tc_types = [fresh_var], tc_var = new_var_ptr}, (var_heap, type_var_heap)) + = ({tc_class = TCClass tc_class_symb, tc_types = [fresh_var], tc_var = new_var_ptr}, (var_heap, type_var_heap)) add_universal_vars_to_type [] at = at diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index 9ef6cf0..aa2e3f6 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -2,6 +2,7 @@ implementation module typesupport import StdEnv, StdCompare import syntax, parse, check, unitype, utilities, checktypes, compilerSwitches +import genericsupport :: Store :== Int @@ -428,19 +429,19 @@ where = var_heap <:= (spec_tc.tc_var, VI_ForwardClassVar tc_var) = mark_specified_context tcs spec_tc var_heap - clean_up_type_context tc=:{tc_types} (collected_contexts, env, error) - # (cur, tc_types, env) = cleanUpClosed tc.tc_types env + clean_up_type_context tc=:{tc_types, tc_class} (collected_contexts, env, error) + # (cur, tc_types, env) = cleanUpClosed tc_types env | checkCleanUpResult cur cUndefinedVar = (collected_contexts, env, error) | checkCleanUpResult cur cLiftedVar - = ([{ tc & tc_types = tc_types } : collected_contexts ], env, liftedContextError tc.tc_class.glob_object.ds_ident error) + = ([{ tc & tc_types = tc_types } : collected_contexts ], env, liftedContextError (toString tc_class) error) = ([{ tc & tc_types = tc_types } : collected_contexts ], env, error) clean_up_lifted_type_context tc=:{tc_types,tc_var} (collected_contexts, env, error) # (cur, tc_types, env) = cleanUpClosed tc.tc_types env | checkCleanUpResult cur cLiftedVar | checkCleanUpResult cur cDefinedVar - = (collected_contexts, env, liftedContextError tc.tc_class.glob_object.ds_ident error) + = (collected_contexts, env, liftedContextError (toString tc.tc_class) error) = ([{ tc & tc_types = tc_types } : collected_contexts], env, error) | otherwise = (collected_contexts, env, error) @@ -985,12 +986,12 @@ equivalent st=:{st_args,st_result,st_context,st_attr_env} tst=:{tst_args,tst_res = (False, attr_env, heaps) = (False, attr_env, heaps) where - equivalent_list_of_contexts [] contexts defs heaps + equivalent_list_of_contexts [] contexts defs heaps = (True, heaps) equivalent_list_of_contexts [tc : tcs] contexts defs heaps # (ok, heaps) = contains_context tc contexts defs heaps | ok - = equivalent_list_of_contexts tcs contexts defs heaps + = equivalent_list_of_contexts tcs contexts defs heaps = (False, heaps) contains_context tc1 [tc2 : tcs] defs heaps @@ -1001,16 +1002,23 @@ where contains_context tc1 [] defs heaps = (False, heaps) - equivalent_contexts tc {tc_class,tc_types} defs heaps - | tc_class == tc.tc_class - = equiv tc.tc_types tc_types heaps - # {glob_object={ds_index},glob_module} = tc_class + equivalent_contexts tc1=:{tc_class=TCGeneric {gtc_class=class1}} tc2=:{tc_class=TCGeneric {gtc_class=class2}} defs heaps + = equivalent_contexts {tc1 & tc_class = TCClass class1} {tc2 & tc_class = TCClass class2} defs heaps + equivalent_contexts tc1=:{tc_class=TCGeneric {gtc_class=class1}} tc2 defs heaps + = equivalent_contexts {tc1 & tc_class = TCClass class1} tc2 defs heaps + equivalent_contexts tc1 tc2=:{tc_class=TCGeneric {gtc_class=class2}} defs heaps + = equivalent_contexts tc1 {tc2 & tc_class = TCClass class2} defs heaps + equivalent_contexts tc1=:{tc_class=TCClass class1, tc_types=types1} {tc_class=TCClass class2, tc_types=types2} defs heaps + | class1 == class2 + # (ok, heaps) = equiv types1 types2 heaps + = (ok, heaps) + # {glob_object={ds_index},glob_module} = class2 #! class_def = defs.[glob_module].com_class_defs.[ds_index] # {class_context,class_args} = class_def | isEmpty class_context = (False, heaps) - # th_vars = bind_class_args class_args tc_types heaps.th_vars - = equivalent_superclasses class_context tc defs { heaps & th_vars = th_vars } + # th_vars = bind_class_args class_args types2 heaps.th_vars + = equivalent_superclasses class_context tc1 defs { heaps & th_vars = th_vars } where bind_class_args [{tv_info_ptr} : vars] [type : types] type_var_heap = bind_class_args vars types (writePtr tv_info_ptr (TVI_Type type) type_var_heap) @@ -1210,8 +1218,16 @@ where instance writeType TypeContext where - writeType file opt_beautifulizer (form, {tc_class={glob_object={ds_ident}}, tc_types}) - = writeType (file <<< ds_ident <<< ' ') opt_beautifulizer (form, tc_types) + //writeType file opt_beautifulizer (form, {tc_class={glob_object={ds_ident}}, tc_types}) + // = writeType (file <<< ds_ident <<< ' ') opt_beautifulizer (form, tc_types) + writeType file opt_beautifulizer (form, {tc_class, tc_types}) + # file = write_tc_class tc_class file + = writeType (file <<< ' ') opt_beautifulizer (form, tc_types) + where + write_tc_class (TCClass {glob_object={ds_ident}}) file + = file <<< ds_ident + write_tc_class (TCGeneric {gtc_class={glob_object={ds_ident}}}) file + = file <<< ds_ident instance writeType SAType where @@ -1493,7 +1509,7 @@ where instance <<< TypeContext where - (<<<) file co = file <<< co.tc_class.glob_object.ds_ident <<< " <" <<< ptrToInt co.tc_var <<< '>' <<< " " <<< co.tc_types + (<<<) file co = file <<< co.tc_class <<< " <" <<< ptrToInt co.tc_var <<< '>' <<< " " <<< co.tc_types instance <<< AttrCoercion |