Commit 30f695d8 authored by John van Groningen's avatar John van Groningen
Browse files

add extendable algebraic data types (merged from iTask branch)

parent c2b4d5ac
......@@ -85,6 +85,7 @@ BETypes
BENoTypes
BEFlatType
BEAlgebraicType
BEExtendableAlgebraicType
BERecordType
BEAbsType
BEConstructors
......
......@@ -205,6 +205,8 @@ BEFlatType :: !BESymbolP !BEAttribution !BETypeVarListP !BackEnd -> (!BEFlatType
// BEFlatTypeP BEFlatType (BESymbolP symbol,BEAttribution attribution,BETypeVarListP arguments);
BEAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd;
// void BEAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors);
BEExtendableAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd;
// void BEExtendableAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors);
BERecordType :: !Int !BEFlatTypeP !BETypeNodeP !Int !BEFieldListP !BackEnd -> BackEnd;
// void BERecordType (int moduleIndex,BEFlatTypeP lhs,BETypeNodeP constructorType,int is_boxed_record,BEFieldListP fields);
BEAbsType :: !BEFlatTypeP !BackEnd -> BackEnd;
......
......@@ -550,6 +550,12 @@ BEAlgebraicType a0 a1 a2 = code {
}
// void BEAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors);
BEExtendableAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd;
BEExtendableAlgebraicType a0 a1 a2 = code {
ccall BEExtendableAlgebraicType "pp:V:p"
}
// void BEExtendableAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors);
BERecordType :: !Int !BEFlatTypeP !BETypeNodeP !Int !BEFieldListP !BackEnd -> BackEnd;
BERecordType a0 a1 a2 a3 a4 a5 = code {
ccall BERecordType "IppIp:V:p"
......
......@@ -819,11 +819,9 @@ convertTypeVar typeVar
defineType :: ModuleIndex {#ConsDef} {#SelectorDef} Index CheckedTypeDef *BackEndState -> *BackEndState
defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=AlgType constructorSymbols} be
# (flatType, be)
= convertTypeLhs moduleIndex typeIndex td_attribute td_args be
# (constructors, be)
= convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols be
= appBackEnd (BEAlgebraicType flatType constructors) be
# (flatType, be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args be
# (constructors, be) = convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols be
= appBackEnd (BEAlgebraicType flatType constructors) be
defineType moduleIndex constructors selectors typeIndex {td_attribute, td_args, td_rhs=RecordType {rt_constructor, rt_fields, rt_is_boxed_record}, td_fun_index} be
# constructorIndex = rt_constructor.ds_index
constructorDef = constructors.[constructorIndex]
......@@ -854,6 +852,14 @@ defineType moduleIndex _ _ typeIndex {td_attribute, td_args, td_rhs=AbstractType
= beAbsType (convertTypeLhs moduleIndex typeIndex td_attribute td_args) be
defineType moduleIndex _ _ typeIndex {td_attribute, td_args, td_rhs=AbstractSynType _ _} be
= beAbsType (convertTypeLhs moduleIndex typeIndex td_attribute td_args) be
defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=ExtendableAlgType constructorSymbols} be
# (flatType, be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args be
# (constructors, be) = convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols be
= appBackEnd (BEExtendableAlgebraicType flatType constructors) be
defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=AlgConses constructorSymbols _} be
# (flatType, be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args be
# (constructors, be) = convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols be
= appBackEnd (BEExtendableAlgebraicType flatType constructors) be
defineType _ _ _ _ _ be
= be
......
......@@ -619,9 +619,9 @@ where
(kinds_in_group, (as_kind_heap, as_td_infos)) = mapSt determine_kinds group (as.as_kind_heap, as.as_td_infos)
as_kind_heap = unify_var_binds conds.con_var_binds as_kind_heap
(normalized_top_vars, (kind_var_store, as_kind_heap)) = normalize_top_vars conds.con_top_var_binds 0 as_kind_heap
(as_kind_heap, as_td_infos)
= update_type_def_infos modules type_properties normalized_top_vars group kinds_in_group kind_var_store as_kind_heap as_td_infos
as & as_kind_heap = as_kind_heap, as_td_infos = as_td_infos
(as_kind_heap, as_td_infos, as_error)
= update_type_def_infos modules type_properties normalized_top_vars group kinds_in_group kind_var_store as_kind_heap as_td_infos as.as_error
as & as_kind_heap = as_kind_heap, as_td_infos = as_td_infos, as_error = as_error
= foldSt (check_dcl_properties modules dcl_types dcl_mod_index type_properties) group as
init_type_def_infos modules gi=:{gi_module,gi_index} (is_abstract_type, type_def_infos, as_type_var_heap, kind_heap)
......@@ -633,6 +633,12 @@ where
AbstractSynType properties _
# type_def_infos = init_abstract_type_def properties td_args gi_module gi_index type_def_infos
-> (True, type_def_infos, as_type_var_heap, kind_heap)
ExtendableAlgType _
# (tdi_kinds, (as_type_var_heap, kind_heap)) = newKindConstVariables td_args (as_type_var_heap, kind_heap)
-> (is_abstract_type, {type_def_infos & [gi_module].[gi_index].tdi_kinds = tdi_kinds}, as_type_var_heap, kind_heap)
AlgConses _ _
# (tdi_kinds, (as_type_var_heap, kind_heap)) = newKindConstVariables td_args (as_type_var_heap, kind_heap)
-> (is_abstract_type, {type_def_infos & [gi_module].[gi_index].tdi_kinds = tdi_kinds}, as_type_var_heap, kind_heap)
_
# (tdi_kinds, (as_type_var_heap, kind_heap)) = newKindVariables td_args (as_type_var_heap, kind_heap)
-> (is_abstract_type, {type_def_infos & [gi_module].[gi_index].tdi_kinds = tdi_kinds}, as_type_var_heap, kind_heap)
......@@ -652,6 +658,14 @@ where
# (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap
= (KindVar kind_info_ptr, (type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr)))
newKindConstVariables td_args (type_var_heap, as_kind_heap)
= mapSt new_kind_const td_args (type_var_heap, as_kind_heap)
where
new_kind_const :: ATypeVar *(*TypeVarHeap,*KindHeap) -> (!TypeKind,!(!*TypeVarHeap,!*KindHeap));
new_kind_const {atv_variable={tv_info_ptr}} (type_var_heap, kind_heap)
# (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap
= (KindVar kind_info_ptr, (writePtr tv_info_ptr (TVI_TypeKind kind_info_ptr) type_var_heap, kind_heap))
anal_type_def modules gi=:{gi_module,gi_index} (group_properties, conds, as=:{as_error})
# {com_type_defs,com_cons_defs} = modules.[gi_module]
{td_ident,td_pos,td_args,td_rhs} = com_type_defs.[gi_index]
......@@ -669,6 +683,12 @@ where
= (cv_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error}))
anal_rhs_of_type_def modules com_cons_defs (NewType cons) conds_as
= analTypesOfConstructor modules com_cons_defs cons conds_as
anal_rhs_of_type_def modules com_cons_defs (ExtendableAlgType conses) conds_as
# (cons_properties, (conds,as)) = analTypesOfConstructors modules com_cons_defs conses conds_as
= ((cons_properties bitand (bitnot cIsHyperStrict)) /*bitor cIsNonCoercible*/, (conds,as))
anal_rhs_of_type_def modules com_cons_defs (AlgConses conses _) conds_as
# (cons_properties, (conds,as)) = analTypesOfConstructors modules com_cons_defs conses conds_as
= ((cons_properties bitand (bitnot cIsHyperStrict)) /*bitor cIsNonCoercible*/, (conds,as))
determine_kinds {gi_module,gi_index} (kind_heap, td_infos)
# (td_info=:{tdi_kinds}, td_infos) = td_infos![gi_module,gi_index]
......@@ -721,17 +741,24 @@ where
# (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap
= normalize_var kind_info_ptr kind_info (kind_store, kind_heap)
update_type_def_infos modules type_properties top_vars group updated_kinds_of_group kind_store kind_heap td_infos
# (_,as_kind_heap,as_td_infos) = fold2St (update_type_def_info modules (type_properties bitor cIsAnalysed) top_vars) group updated_kinds_of_group (kind_store, kind_heap, td_infos)
= (as_kind_heap,as_td_infos)
update_type_def_infos modules type_properties top_vars group updated_kinds_of_group kind_store kind_heap td_infos error
# (_,as_kind_heap,as_td_infos,error)
= fold2St (update_type_def_info modules (type_properties bitor cIsAnalysed) top_vars) group updated_kinds_of_group (kind_store,kind_heap,td_infos,error)
= (as_kind_heap,as_td_infos,error)
where
update_type_def_info modules type_properties top_vars {gi_module,gi_index} updated_kinds
(kind_store,kind_heap,td_infos)
(kind_store,kind_heap,td_infos,error)
# (td_info=:{tdi_kinds}, td_infos) = td_infos![gi_module].[gi_index]
# (group_vars, cons_vars, kind_store, kind_heap) = determine_type_def_info tdi_kinds updated_kinds top_vars kind_store kind_heap
# td_info & tdi_properties = type_properties, tdi_kinds = updated_kinds, tdi_group_vars = group_vars, tdi_cons_vars = cons_vars
#! td_infos & [gi_module,gi_index] = td_info
= (kind_store, kind_heap, td_infos)
| type_properties bitand cIsNonCoercible<>0
# type_def = modules.[gi_module].com_type_defs.[gi_index]
| not (isUniqueAttr type_def.td_attribute) && is_ExtendableAlgType_or_AlgConses type_def.td_rhs
# error = checkErrorWithPosition type_def.td_ident type_def.td_pos "a non unique extendable algebraic data type must be coercible" error
= (kind_store, kind_heap, td_infos, error)
= (kind_store, kind_heap, td_infos, error)
= (kind_store, kind_heap, td_infos, error)
determine_type_def_info [KindVar kind_info_ptr : kind_vars] [kind : kinds] top_vars kind_store kind_heap
# (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap
......@@ -752,6 +779,10 @@ where
is_a_top_var var_number []
= False
is_ExtendableAlgType_or_AlgConses (ExtendableAlgType _) = True
is_ExtendableAlgType_or_AlgConses (AlgConses _ _) = True
is_ExtendableAlgType_or_AlgConses _ = False
check_dcl_properties modules dcl_types dcl_mod_index properties {gi_module, gi_index} as
| gi_module == dcl_mod_index && gi_index < size dcl_types
# {td_ident, td_rhs, td_args, td_pos} = dcl_types.[gi_index]
......@@ -1166,6 +1197,10 @@ isUniqueTypeRhs common_defs mod_index (RecordType {rt_constructor={ds_index}}) s
= constructor_is_unique mod_index ds_index common_defs state
isUniqueTypeRhs common_defs mod_index (NewType {ds_index}) state
= constructor_is_unique mod_index ds_index common_defs state
isUniqueTypeRhs common_defs mod_index (ExtendableAlgType constructors) state
= has_unique_constructor constructors common_defs mod_index state
isUniqueTypeRhs common_defs mod_index (AlgConses constructors _) state
= has_unique_constructor constructors common_defs mod_index state
isUniqueTypeRhs common_defs mod_index _ state
= (False, state)
......
......@@ -196,6 +196,10 @@ where
| properties bitand cIsNonCoercible == 0
= (PostiveSignClass, scs)
= (TopSignClass, scs)
sign_class_of_type_def module_index (ExtendableAlgType conses) group_nr ci scs
= (TopSignClass, scs)
sign_class_of_type_def module_index (AlgConses conses _) group_nr ci scs
= (TopSignClass, scs)
sign_class_of_type_conses module_index [{ds_index}:conses] group_nr ci cumm_sign_class scs
#! cons_def = ci.[module_index].com_cons_defs.[ds_index]
......@@ -473,6 +477,10 @@ where
= (PropClass, pcs)
prop_class_of_type_def _ (AbstractSynType properties _) _ _ pcs
= (PropClass, pcs)
prop_class_of_type_def module_index (ExtendableAlgType conses) group_nr ci pcs
= (PropClass, pcs)
prop_class_of_type_def module_index (AlgConses conses _) group_nr ci pcs
= (PropClass, pcs)
prop_class_of_type_conses module_index [{ds_index}:conses] group_nr ci cumm_prop_class pcs
#! cons_def = ci.[module_index].com_cons_defs.[ds_index]
......
......@@ -951,6 +951,8 @@ collectCommonDefinitions {def_types,def_constructors,def_selectors,def_classes,d
sizes = { sizes & [cGenericCaseDefs] = size }
= (sizes, defs)
where
type_def_to_dcl {td_rhs=UncheckedAlgConses type_ext_ident _, td_ident, td_pos} (decl_index, decls)
= (inc decl_index, [Declaration {decl_ident = type_ext_ident, decl_pos = td_pos, decl_kind = STE_TypeExtension, decl_index = decl_index} : decls])
type_def_to_dcl {td_ident, td_pos} (decl_index, decls)
= (inc decl_index, [Declaration {decl_ident = td_ident, decl_pos = td_pos, decl_kind = STE_Type, decl_index = decl_index} : decls])
......@@ -1187,6 +1189,20 @@ renumber_icl_definitions_as_dcl_definitions (Yes icl_to_dcl_index_table) icl_siz
= { td & td_rhs = NewType {cons & ds_index=icl_to_dcl_index_table.[cConstructorDefs,cons.ds_index]} }
renumber_type_def td
= td
renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_TypeExtension, decl_index}) cdefs
# (type_def,cdefs) = cdefs!com_type_defs.[decl_index]
# type_def = renumber_type_extension_def type_def
# cdefs={cdefs & com_type_defs.[decl_index]=type_def}
= (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cTypeDefs,decl_index]},cdefs)
where
renumber_type_extension_def td=:{td_rhs = UncheckedAlgConses type_ext_ident conses}
# conses = [{cons & ds_index=icl_to_dcl_index_table.[cConstructorDefs,cons.ds_index]} \\ cons <- conses]
= {td & td_rhs = UncheckedAlgConses type_ext_ident conses}
renumber_type_extension_def td=:{td_rhs = AlgConses conses type_ext_ident}
# conses = [{cons & ds_index=icl_to_dcl_index_table.[cConstructorDefs,cons.ds_index]} \\ cons <- conses]
= {td & td_rhs = AlgConses conses type_ext_ident}
renumber_type_extension_def td
= td
renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Constructor, decl_index}) cdefs
= (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cConstructorDefs,decl_index]},cdefs)
renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Field _, decl_index}) cdefs
......@@ -1407,6 +1423,18 @@ where
# (cop_td_indexes, cop_cd_indexes, cop_gd_indexes) = copied_defs
# copied_defs = (cop_td_indexes, cop_cd_indexes, [decl_index:cop_gd_indexes])
= (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, [generic_def:new_generic_defs], copied_defs, conversion_table, icl_sizes, icl_decl_symbols, cs)
add_dcl_definition {com_type_defs,com_cons_defs} dcl=:(Declaration {decl_kind = STE_TypeExtension, decl_index})
(new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, (cop_td_indexes, cop_cd_indexes, cop_gd_indexes), conversion_table, icl_sizes, icl_decl_symbols, cs)
# type_def = com_type_defs.[decl_index]
(new_type_defs,new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,cs) = add_type_def type_def new_type_defs new_cons_defs new_selector_defs conversion_table icl_sizes icl_decl_symbols cs
cop_td_indexes = [decl_index : cop_td_indexes]
= (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, (cop_td_indexes, cop_cd_indexes, cop_gd_indexes), conversion_table, icl_sizes, icl_decl_symbols, cs)
where
add_type_def td=:{td_pos, td_rhs = UncheckedAlgConses type_ext_ident conses} new_type_defs new_cons_defs new_selector_defs conversion_table icl_sizes icl_decl_symbols cs
# (conses,(new_cons_defs,conversion_table,icl_sizes,icl_decl_symbols,cs)) = copy_and_redirect_cons_symbols com_cons_defs td_pos conses (new_cons_defs,conversion_table,icl_sizes,icl_decl_symbols,cs)
= ([{ td & td_rhs = UncheckedAlgConses type_ext_ident conses} : new_type_defs],new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,cs)
add_type_def td new_type_defs new_cons_defs new_selector_defs conversion_table icl_sizes icl_decl_symbols cs
= ([td : new_type_defs],new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,cs)
add_dcl_definition _ _ result = result
copy_and_redirect_cons_symbols com_cons_defs td_pos [cons:conses] (new_cons_defs,conversion_table,icl_sizes,icl_decl_symbols,cs)
......
This diff is collapsed.
......@@ -21,6 +21,7 @@ where
toInt STE_DclFunction = cFunctionDefs
toInt (STE_FunctionOrMacro _) = cMacroDefs
toInt (STE_DclMacroOrLocalMacroFunction _)= cMacroDefs
toInt STE_TypeExtension = cTypeDefs
toInt _ = NoIndex
instance Erroradmin ErrorAdmin
......
......@@ -133,7 +133,7 @@ retrieveTypeDefinition type_ptr mod_index symbol_table used_types
with
retrieve_type_definition (STE_UsedQualifiedType uqt_mod_index uqt_index orig_kind)
| uqt_mod_index==mod_index && uqt_index==ste_index
= (ste_index, mod_index, symbol_table, used_types)
= (ste_index, mod_index, symbol_table, used_types)
= retrieve_type_definition orig_kind
retrieve_type_definition (STE_Imported STE_Type ste_mod_index)
= (ste_index, ste_mod_index, symbol_table <:= (type_ptr, { entry & ste_kind = STE_UsedType ste_mod_index this_kind }), used_types)
......@@ -376,9 +376,9 @@ where
# type_lhs = { at_attribute = cti_lhs_attribute,
at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_ident td_arity)
[{at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
ts_ti_cs = bind_types_of_constructors cti 0 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs conses ts_ti_cs
ts_ti_cs = bind_types_of_constructors cti 0 (atype_vars_to_type_vars td_args) attr_vars type_lhs conses ts_ti_cs
= (td_rhs, ts_ti_cs)
check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_constructor=rec_cons=:{ds_index,ds_arity}, rt_fields}}
check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_constructor={ds_index,ds_arity}, rt_fields}}
attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} (ts,ti,cs)
# type_lhs = { at_attribute = cti_lhs_attribute,
at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_ident td_arity)
......@@ -386,7 +386,7 @@ where
cs = if (ds_arity>32)
{ cs & cs_error = checkError ("Record has too many fields ("+++toString ds_arity+++",") "32 are allowed)" cs.cs_error }
cs;
(ts, ti, cs) = bind_types_of_constructor cti 0 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs rec_cons (ts,ti,cs)
(ts, ti, cs) = bind_types_of_constructor cti 0 (atype_vars_to_type_vars td_args) attr_vars type_lhs ds_index (ts,ti,cs)
# (rec_cons_def, ts) = ts!ts_cons_defs.[ds_index]
# {cons_type = { st_vars,st_args,st_result,st_attr_vars }, cons_exi_vars} = rec_cons_def
# (ts_selector_defs, ti_var_heap, cs_error) = check_selectors 0 rt_fields cti_type_index st_args st_result st_vars st_attr_vars cons_exi_vars
......@@ -429,33 +429,69 @@ where
# type_lhs = { at_attribute = cti_lhs_attribute,
at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_ident td_arity)
[{at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
ts_ti_cs = bind_types_of_constructor cti -2 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs cons ts_ti_cs
ts_ti_cs = bind_types_of_constructor cti -2 (atype_vars_to_type_vars td_args) attr_vars type_lhs cons.ds_index ts_ti_cs
= (td_rhs, ts_ti_cs)
check_rhs_of_TypeDef {td_rhs = AbstractSynType properties type} _ cti ts_ti_cs
# (type, type_attr, ts_ti_cs) = bindTypes cti type ts_ti_cs
= (AbstractSynType properties type, ts_ti_cs)
check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:ExtendableAlgType conses} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} class_defs_ts_ti_cs
# type_lhs = { at_attribute = cti_lhs_attribute,
at_type = TA (MakeTypeSymbIdent {glob_object = cti_type_index, glob_module = cti_module_index} td_ident td_arity)
[{at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
class_defs_ts_ti_cs = bind_types_of_constructors cti 0 (atype_vars_to_type_vars td_args) attr_vars type_lhs conses class_defs_ts_ti_cs
= (td_rhs, class_defs_ts_ti_cs)
check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:UncheckedAlgConses type_ext_ident conses} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs
# (ts,ti,cs) = ts_ti_cs
(type_index, type_module, cs_symbol_table, ti_used_types) = retrieveTypeDefinition td_ident.id_info cti_module_index cs.cs_symbol_table ti.ti_used_types
ti & ti_used_types = ti_used_types
cs & cs_symbol_table = cs_symbol_table
| type_index <> NotFound
# ts_ti_cs = (ts,ti,cs)
// to do check if ExtendableAlgType
# type_lhs = { at_attribute = cti_lhs_attribute,
at_type = TA (MakeTypeSymbIdent { glob_object = type_index, glob_module = type_module } td_ident td_arity)
[{at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
ts_ti_cs = bind_types_of_added_constructors cti (atype_vars_to_type_vars td_args) attr_vars type_lhs conses ts_ti_cs
= (AlgConses conses {gi_module=type_module,gi_index=type_index}, ts_ti_cs)
# cs & cs_error = checkError td_ident "undefined" cs.cs_error
= (td_rhs, (ts,ti,cs))
check_rhs_of_TypeDef {td_rhs} _ _ ts_ti_cs
= (td_rhs, ts_ti_cs)
atype_vars_to_type_vars atype_vars
= [atv_variable \\ {atv_variable} <- atype_vars]
bind_types_of_constructors :: !CurrentTypeInfo !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymbol] !(!*TypeSymbols,!*TypeInfo,!*CheckState)
-> (!*TypeSymbols, !*TypeInfo, !*CheckState)
bind_types_of_constructors cti cons_index free_vars free_attrs type_lhs [cons=:{ds_arity,ds_ident,ds_index}:conses] (ts,ti,cs)
# (ts,cs) = if (ds_arity>32)
(constructor_has_too_many_arguments ds_index ds_ident ds_arity ts cs)
(ts,cs);
# ts_ti_cs = bind_types_of_constructor cti cons_index free_vars free_attrs type_lhs cons (ts,ti,cs)
# ts_ti_cs = bind_types_of_constructor cti cons_index free_vars free_attrs type_lhs ds_index (ts,ti,cs)
= bind_types_of_constructors cti (inc cons_index) free_vars free_attrs type_lhs conses ts_ti_cs
bind_types_of_constructors _ _ _ _ _ [] ts_ti_cs
= ts_ti_cs
bind_types_of_added_constructors :: !CurrentTypeInfo ![TypeVar] ![AttributeVar] !AType ![DefinedSymbol]
!(!*TypeSymbols,!*TypeInfo,!*CheckState)
-> (!*TypeSymbols,!*TypeInfo,!*CheckState)
bind_types_of_added_constructors cti free_vars free_attrs type_lhs [{ds_arity,ds_ident,ds_index}:conses] (ts,ti,cs)
# (ts,cs) = if (ds_arity>32)
(constructor_has_too_many_arguments ds_index ds_ident ds_arity ts cs)
(ts,cs);
# class_defs_ts_ti_cs = bind_types_of_constructor cti -3 free_vars free_attrs type_lhs ds_index (ts,ti,cs)
= bind_types_of_added_constructors cti free_vars free_attrs type_lhs conses class_defs_ts_ti_cs
bind_types_of_added_constructors _ _ _ _ [] class_defs_ts_ti_cs
= class_defs_ts_ti_cs
constructor_has_too_many_arguments ds_index ds_ident ds_arity ts cs
# (cons_pos,ts2) = ts!ts_cons_defs.[ds_index].cons_pos
= (ts2, {cs & cs_error = checkErrorWithPosition ds_ident cons_pos ("Constructor has too many arguments ("+++toString ds_arity+++", 32 are allowed)") cs.cs_error})
bind_types_of_constructor :: !CurrentTypeInfo !Index ![TypeVar] ![AttributeVar] !AType !DefinedSymbol !(!*TypeSymbols,!*TypeInfo,!*CheckState)
bind_types_of_constructor :: !CurrentTypeInfo !Index ![TypeVar] ![AttributeVar] !AType !Index !(!*TypeSymbols,!*TypeInfo,!*CheckState)
-> (!*TypeSymbols, !*TypeInfo, !*CheckState)
bind_types_of_constructor cti=:{cti_lhs_attribute} cons_index free_vars free_attrs type_lhs {ds_index} (ts, ti=:{ti_type_heaps}, cs)
# (cons_def, ts) = ts!ts_cons_defs.[ds_index]
bind_types_of_constructor cti=:{cti_lhs_attribute} cons_number free_vars free_attrs type_lhs cons_index (ts, ti=:{ti_type_heaps}, cs)
# (cons_def, ts) = ts!ts_cons_defs.[cons_index]
# (exi_vars, (ti_type_heaps, cs))
= addExistentionalTypeVariablesToSymbolTable cti_lhs_attribute cons_def.cons_exi_vars ti_type_heaps cs
(st_args, st_attr_env, (ts, ti, cs))
......@@ -464,9 +500,9 @@ where
attr_vars = add_universal_attr_vars st_args free_attrs
cons_type = {cons_def.cons_type & st_vars = free_vars, st_args = st_args, st_result = type_lhs, st_attr_vars = attr_vars, st_attr_env = st_attr_env}
(new_type_ptr, ti_var_heap) = newPtr VI_Empty ti.ti_var_heap
cons_def = { cons_def & cons_type = cons_type, cons_number = cons_index, cons_type_index = cti.cti_type_index, cons_exi_vars = exi_vars,
cons_def = { cons_def & cons_type = cons_type, cons_number = cons_number, cons_type_index = cti.cti_type_index, cons_exi_vars = exi_vars,
cons_type_ptr = new_type_ptr }
= ({ts & ts_cons_defs.[ds_index] = cons_def}, { ti & ti_var_heap = ti_var_heap }, { cs & cs_symbol_table=symbol_table})
= ({ts & ts_cons_defs.[cons_index] = cons_def}, { ti & ti_var_heap = ti_var_heap }, { cs & cs_symbol_table=symbol_table})
where
bind_types_of_cons :: ![AType] !CurrentTypeInfo ![TypeVar] ![AttrInequality] !(!*TypeSymbols, !*TypeInfo, !*CheckState)
-> (![AType], ![AttrInequality],!(!*TypeSymbols, !*TypeInfo, !*CheckState))
......
......@@ -685,11 +685,13 @@ instance consumerRequirements Case where
_ -> False
inspect_patterns :: !{#CommonDefs} !Bool !CasePatterns ![(Int,Bool)] -> (!Bool,!Bool)
inspect_patterns common_defs has_default (AlgebraicPatterns {glob_object,glob_module} _) constructors_and_unsafe_bits
# type_def = common_defs.[glob_module].com_type_defs.[glob_object]
inspect_patterns common_defs has_default (AlgebraicPatterns {gi_index,gi_module} algebraic_patterns) constructors_and_unsafe_bits
# type_def = common_defs.[gi_module].com_type_defs.[gi_index]
defined_symbols = case type_def.td_rhs of
AlgType defined_symbols -> defined_symbols
RecordType {rt_constructor} -> [rt_constructor]
ExtendableAlgType defined_symbols -> defined_symbols
AlgConses defined_symbols _ -> defined_symbols
all_constructors = [ ds_index \\ {ds_index}<-defined_symbols ]
all_sorted_constructors = if (is_sorted all_constructors)
all_constructors
......@@ -699,15 +701,17 @@ instance consumerRequirements Case where
= (appearance_loop [0,1] constructors_and_unsafe_bits, not (multimatch_loop has_default constructors_and_unsafe_bits))
inspect_patterns common_defs has_default (OverloadedListPatterns overloaded_list _ _) constructors_and_unsafe_bits
# type_def = case overloaded_list of
UnboxedList {glob_module,glob_object} _ _ _
-> common_defs.[glob_module].com_type_defs.[glob_object]
UnboxedTailStrictList {glob_object,glob_module} _ _ _
-> common_defs.[glob_module].com_type_defs.[glob_object]
OverloadedList {glob_object,glob_module} _ _ _
-> common_defs.[glob_module].com_type_defs.[glob_object]
UnboxedList {gi_index,gi_module} _ _ _
-> common_defs.[gi_module].com_type_defs.[gi_index]
UnboxedTailStrictList {gi_index,gi_module} _ _ _
-> common_defs.[gi_module].com_type_defs.[gi_index]
OverloadedList {gi_index,gi_module} _ _ _
-> common_defs.[gi_module].com_type_defs.[gi_index]
defined_symbols = case type_def.td_rhs of
AlgType defined_symbols -> defined_symbols
RecordType {rt_constructor} -> [rt_constructor]
ExtendableAlgType defined_symbols -> defined_symbols
AlgConses defined_symbols _ -> defined_symbols
all_constructors = [ ds_index \\ {ds_index}<-defined_symbols ]
all_sorted_constructors = if (is_sorted all_constructors) all_constructors (sortBy (<) all_constructors)
= (appearance_loop all_sorted_constructors constructors_and_unsafe_bits, not (multimatch_loop has_default constructors_and_unsafe_bits))
......
......@@ -72,6 +72,14 @@ where
compare_rhs_of_types (AbstractSynType _ dclType) (SynType iclType) dcl_cons_defs icl_cons_defs comp_st
# (ok, comp_st) = compare dclType iclType comp_st
= (ok, icl_cons_defs, comp_st)
compare_rhs_of_types (ExtendableAlgType []) (ExtendableAlgType []) dcl_cons_defs icl_cons_defs comp_st
= (True, icl_cons_defs, comp_st)
compare_rhs_of_types (ExtendableAlgType dclConstructors) (ExtendableAlgType iclConstructors) dcl_cons_defs icl_cons_defs comp_st
= compare_constructor_lists dclConstructors iclConstructors dcl_cons_defs icl_cons_defs comp_st
compare_rhs_of_types (AlgConses dclConstructors dcl_type_index) (AlgConses iclConstructors icl_type_index) dcl_cons_defs icl_cons_defs comp_st
| dcl_type_index==icl_type_index
= compare_constructor_lists dclConstructors iclConstructors dcl_cons_defs icl_cons_defs comp_st
= (False, icl_cons_defs, comp_st)
compare_rhs_of_types dcl_type icl_type dcl_cons_defs icl_cons_defs comp_st
= (False, icl_cons_defs, comp_st)
......@@ -85,7 +93,7 @@ where
= compare_constructor_lists dcl_conses icl_conses dcl_cons_defs icl_cons_defs comp_st
= (False, icl_cons_defs, comp_st)
= (False, icl_cons_defs, comp_st)
compare_constructor_lists [dcl_cons : dcl_conses] [] dcl_cons_defs icl_cons_defs comp_st
compare_constructor_lists _ _ dcl_cons_defs icl_cons_defs comp_st
= (False, icl_cons_defs, comp_st)
compare_constructors do_compare_result_types cons_index dcl_cons_defs icl_cons_defs comp_st
......@@ -962,6 +970,8 @@ instance t_corresponds TypeRhs where
= t_corresponds dclType iclType
t_corresponds (NewType dclConstructor) (NewType iclConstructor)
= t_corresponds dclConstructor iclConstructor
t_corresponds (ExtendableAlgType dclConstructors) (ExtendableAlgType iclConstructors)
= t_corresponds dclConstructors iclConstructors
// sanity check ...
t_corresponds UnknownType _
......
......@@ -20,7 +20,7 @@ import type_io;
:: DynamicRepresentation =
!{ dr_type_ident :: SymbIdent
, dr_dynamic_type :: Global Index
, dr_dynamic_type :: GlobalIndex
, dr_dynamic_symbol :: Global DefinedSymbol
, dr_type_code_constructor_symb_ident :: SymbIdent
}
......@@ -740,7 +740,7 @@ create_dynamic_and_selector_idents common_defs predefined_symbols
# dynamic_defined_symbol
= {glob_module = pds_module1, glob_object = rt_constructor}
# dynamic_type = {glob_module = pds_module1, glob_object = pds_def1}
# dynamic_type = {gi_module = pds_module1, gi_index = pds_def1}
# dynamic_temp_symb_ident
= { SymbIdent |
......
......@@ -1590,7 +1590,7 @@ where
true_expr = BasicExpr (BVB True)
(var_args,cs_var_heap) = make_free_vars cons_arity cs_var_heap
pattern = {ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = true_expr, ap_position = position}
patterns = AlgebraicPatterns {glob_module=global_type_index.gi_module,glob_object=global_type_index.gi_index} [pattern]
patterns = AlgebraicPatterns global_type_index [pattern]
(case_expr_ptr, cs_expr_heap) = newPtr EI_Empty cs_expr_heap
case_expr = Case {case_expr = case_var, case_guards = patterns, case_default = Yes fail_expr, case_ident = No,
case_explicit = False, case_info_ptr = case_expr_ptr, case_default_pos = NoPos}
......
......@@ -401,7 +401,7 @@ where
| can_generate_bimap_to_or_from
#! (tdi_kinds,td_infos) = td_infos![glob_module,glob_object].tdi_kinds
#! (args, st) = convert_args args (modules, td_infos, heaps, error)
-> (GTSAppConsSimpleType type_index (KindArrow tdi_kinds) args, st)
-> (GTSAppConsSimpleType {gi_module=type_index.glob_module,gi_index=type_index.glob_object} (KindArrow tdi_kinds) args, st)
-> convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
_
-> convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
......@@ -976,7 +976,7 @@ where
build_expr_for_conses is_record type_def_mod type_def_index cons_def_syms arg_expr heaps error
# (case_alts, heaps, error)
= build_exprs_for_conses is_record 0 (length cons_def_syms) type_def_mod cons_def_syms heaps error
# case_patterns = AlgebraicPatterns {glob_module = type_def_mod, glob_object = type_def_index} case_alts
# case_patterns = AlgebraicPatterns {gi_module = type_def_mod, gi_index = type_def_index} case_alts
# (case_expr, heaps) = buildCaseExpr arg_expr case_patterns heaps
= (case_expr, heaps, error)
......@@ -1049,7 +1049,7 @@ buildConversionFrom ::
FunsAndGroups,!*Heaps,!*ErrorAdmin)
buildConversionFrom
type_def_mod
type_def=:{td_rhs, td_ident, td_index, td_pos}
type_def=:{td_rhs, td_ident, td_pos}
main_module_index predefs funs_and_groups heaps error
# (body_expr, arg_var, heaps, error) =
build_expr_for_type_rhs type_def_mod td_rhs heaps error
......@@ -1148,7 +1148,7 @@ where
build_case_unit body_expr heaps
# unit_pat = buildPredefConsPattern PD_ConsUNIT [] body_expr predefs
# {pds_module, pds_def} = predefs.[PD_TypeUNIT]
# case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [unit_pat]
# case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [unit_pat]
= build_case_expr case_patterns heaps
build_pair x y predefs heaps
......@@ -1172,32 +1172,32 @@ build_field var_expr predefs heaps
build_case_pair var1 var2 body_expr predefs heaps
# pair_pat = buildPredefConsPattern PD_ConsPAIR [var1, var2] body_expr predefs
# {pds_module, pds_def} = predefs.[PD_TypePAIR]
# case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [pair_pat]
# case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [pair_pat]
= build_case_expr case_patterns heaps
build_case_either left_var left_expr right_var right_expr predefs heaps
# left_pat = buildPredefConsPattern PD_ConsLEFT [left_var] left_expr predefs
# right_pat = buildPredefConsPattern PD_ConsRIGHT [right_var] right_expr predefs
# {pds_module, pds_def} = predefs.[PD_TypeEITHER]
# case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [left_pat, right_pat]
# case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [left_pat, right_pat]
= build_case_expr case_patterns heaps
build_case_object var body_expr predefs heaps
# pat = buildPredefConsPattern PD_ConsOBJECT [var] body_expr predefs
# {pds_module, pds_def} = predefs.[PD_TypeOBJECT]
# case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [pat]
# case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [pat]
= build_case_expr case_patterns heaps