Skip to content
GitLab
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
Expand all Hide whitespace changes
Inline Side-by-side
backend/Windows/Clean System Files/backend_library
View file @ 30f695d8
......@@ -85,6 +85,7 @@ BETypes
BENoTypes
BEFlatType
BEAlgebraicType
BEExtendableAlgebraicType
BERecordType
BEAbsType
BEConstructors
......
backend/backend.dcl
View file @ 30f695d8
......@@ -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;
......
backend/backend.icl
View file @ 30f695d8
......@@ -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"
......
backend/backendconvert.icl
View file @ 30f695d8
......@@ -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
......
frontend/analtypes.icl
View file @ 30f695d8
......@@ -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)
......
frontend/analunitypes.icl
View file @ 30f695d8
......@@ -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]
......
frontend/check.icl
View file @ 30f695d8
......@@ -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)
......
frontend/checkFunctionBodies.icl
View file @ 30f695d8
This diff is collapsed.
frontend/checksupport.icl
View file @ 30f695d8
......@@ -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
......
frontend/checktypes.icl
View file @ 30f695d8
......@@ -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))
......
frontend/classify.icl
View file @ 30f695d8
......@@ -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))
......
frontend/comparedefimp.icl
View file @ 30f695d8
......@@ -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 _
......
frontend/convertDynamics.icl
View file @ 30f695d8
......@@ -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 |
......
frontend/convertcases.icl
View file @ 30f695d8
......@@ -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}
......
frontend/generics1.icl
View file @ 30f695d8
......@@ -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