Skip to content
GitLab
Commit 00b04d8a authored by Artem Alimarine's avatar Artem Alimarine
Browse files

support for generic type context like in 

foo :: a a -> Bool | eq{|*|} a
parent 017accb7
Hide whitespace changes
Inline Side-by-side
backend/backendconvert.icl
View file @ 00b04d8a
......@@ -15,7 +15,7 @@ import backendsupport, backendpreprocess
// trace macro
(-*->) infixl
(-*->) value trace
:== value // ---> trace
:== value //---> trace
/*
sfoldr op r l
:== foldr l
......@@ -1257,10 +1257,10 @@ convertRules rules main_dcl_module_n aliasDummyId be
= convert t rulesP be
convertRule :: Ident (Int,FunDef) Int -> BEMonad BEImpRuleP
convertRule aliasDummyId (index, {fun_type=Yes type, fun_body=body, fun_pos, fun_kind, fun_symb}) main_dcl_module_n
convertRule aliasDummyId (index, {fun_type=Yes type, fun_body=body, fun_pos, fun_kind, fun_symb, fun_info}) main_dcl_module_n
// | trace_tn fun_symb.id_name
= beRule index (cafness fun_kind)
(convertTypeAlt index main_dcl_module_n (type -*-> ("convertRule", fun_symb.id_name, index, type)))
(convertTypeAlt index main_dcl_module_n (type -*-> ("convertRule", fun_symb.id_name, index, type, (fun_info.fi_group_index, body))))
(convertFunctionBody index (positionToLineNumber fun_pos) aliasDummyId body main_dcl_module_n)
where
cafness :: FunKind -> Int
......
backend/backendinterface.icl
View file @ 00b04d8a
......@@ -385,7 +385,7 @@ where
= ([type : reversedTypes], reversedContexts)
dictionary_to_context klass args
= {tc_class = klass, tc_types = [at_type \\ {at_type} <- args], tc_var = nilPtr}
= {tc_class = TCClass klass, tc_types = [at_type \\ {at_type} <- args], tc_var = nilPtr}
typeToClass :: DictionaryToClassInfo TypeSymbIdent -> Optional (Global DefinedSymbol)
typeToClass info {type_name, type_arity, type_index={glob_module, glob_object}}
......
frontend/StdCompare.dcl
View file @ 00b04d8a
......@@ -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
......
frontend/StdCompare.icl
View file @ 00b04d8a
......@@ -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
......
frontend/analtypes.icl
View file @ 00b04d8a
......@@ -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
......
frontend/check.icl
View file @ 00b04d8a
......@@ -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
......
frontend/checktypes.icl
View file @ 00b04d8a
......@@ -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)
......
frontend/comparedefimp.icl
View file @ 00b04d8a
......@@ -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
......
frontend/convertimportedtypes.icl
View file @ 00b04d8a
......@@ -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))
frontend/explicitimports.icl
View file @ 00b04d8a
......@@ -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
......
frontend/frontend.icl
View file @ 00b04d8a
......@@ -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)
......
frontend/general.dcl
View file @ 00b04d8a
......@@ -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}
......
frontend/general.icl
View file @ 00b04d8a
......@@ -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
......
frontend/generics1.icl
View file @ 00b04d8a
......@@ -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)