aboutsummaryrefslogtreecommitdiff
path: root/frontend
diff options
context:
space:
mode:
Diffstat (limited to 'frontend')
-rw-r--r--frontend/StdCompare.dcl2
-rw-r--r--frontend/StdCompare.icl8
-rw-r--r--frontend/analtypes.icl13
-rw-r--r--frontend/check.icl5
-rw-r--r--frontend/checktypes.icl135
-rw-r--r--frontend/comparedefimp.icl9
-rw-r--r--frontend/convertimportedtypes.icl32
-rw-r--r--frontend/explicitimports.icl8
-rw-r--r--frontend/frontend.icl1
-rw-r--r--frontend/general.dcl4
-rw-r--r--frontend/general.icl11
-rw-r--r--frontend/generics1.icl206
-rw-r--r--frontend/genericsupport.dcl20
-rw-r--r--frontend/genericsupport.icl40
-rw-r--r--frontend/overloading.icl37
-rw-r--r--frontend/parse.icl55
-rw-r--r--frontend/postparse.icl3
-rw-r--r--frontend/predef.dcl4
-rw-r--r--frontend/predef.icl11
-rw-r--r--frontend/syntax.dcl20
-rw-r--r--frontend/syntax.icl25
-rw-r--r--frontend/trans.icl26
-rw-r--r--frontend/type.icl10
-rw-r--r--frontend/typesupport.icl46
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