Commit 3ae8f92b authored by johnvg@science.ru.nl's avatar johnvg@science.ru.nl

add abstract newtypes

parent 41cd21f5
......@@ -835,6 +835,10 @@ defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args
be = appBackEnd (BEDefineExtensibleAlgebraicType symbol_p type_attribute constructors) be
type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
= (type_var_heap,be)
defineType moduleIndex _ _ typeIndex {td_rhs=AbstractNewType _ _} type_var_heap be
# (symbol,be) = beTypeSymbol typeIndex moduleIndex be
be = appBackEnd (BEAbstractType symbol) be
= (type_var_heap,be)
defineType _ _ _ _ _ type_var_heap be
= (type_var_heap,be)
......@@ -2444,6 +2448,6 @@ markExports {dcl_functions,dcl_common={com_type_defs,com_cons_defs,com_selector_
= beExportField True fs_index
export_constructor constructor_index
| com_cons_defs.[constructor_index].cons_number <> ConsNumberNewType
| not (IsNewTypeOrAbstractNewTypeCons com_cons_defs.[constructor_index].cons_number)
= beExportConstructor constructor_index
= \ bs=:{bes_backEnd} -> bs
......@@ -634,6 +634,9 @@ 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)
AbstractNewType 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)
ExtensibleAlgType _
# (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)
......@@ -792,6 +795,8 @@ where
= check_abstract_type spec_properties td_ident td_args td_pos as
AbstractSynType spec_properties _
= check_abstract_type spec_properties td_ident td_args td_pos as
AbstractNewType spec_properties _
= check_abstract_type spec_properties td_ident td_args td_pos as
_
= as
with
......
......@@ -200,6 +200,10 @@ where
= (TopSignClass, scs)
sign_class_of_type_def module_index (AlgConses conses _) group_nr ci scs
= (TopSignClass, scs)
sign_class_of_type_def _ (AbstractNewType properties _) _ _ scs
| properties bitand cIsNonCoercible == 0
= (PostiveSignClass, 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]
......@@ -483,6 +487,8 @@ where
= (PropClass, pcs)
prop_class_of_type_def module_index (AlgConses conses _) group_nr ci pcs
= (PropClass, pcs)
prop_class_of_type_def _ (AbstractNewType properties _) _ _ 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]
......
......@@ -1347,7 +1347,7 @@ renumber_icl_definitions_without_functions_as_dcl_definitions (Yes icl_to_dcl_in
# com_selector_defs=reorder_and_enlarge_array com_selector_defs n_dictionary_selectors icl_to_dcl_index_table.[cSelectorDefs]
{sd_ident=dummy_ident,sd_field=dummy_ident,sd_type=dummy_symbol_type,sd_exi_vars=[],sd_field_nr=0,sd_type_index=0,sd_type_ptr=nilPtr,sd_pos=NoPos}
# com_cons_defs=reorder_and_enlarge_array com_cons_defs n_dictionary_constructors icl_to_dcl_index_table.[cConstructorDefs]
{cons_ident=dummy_ident,cons_type=dummy_symbol_type,cons_priority=NoPrio,cons_number=NoIndex,cons_type_index= -1,cons_exi_vars=[],cons_type_ptr=nilPtr,cons_pos=NoPos}
{cons_ident=dummy_ident,cons_type=dummy_symbol_type,cons_priority=NoPrio,cons_number=NoIndex,cons_type_index= -1,cons_exi_vars=[],cons_type_ptr=nilPtr,cons_pos=NoPos}
# com_class_defs=reorder_array com_class_defs icl_to_dcl_index_table.[cClassDefs]
# com_member_defs=reorder_array com_member_defs icl_to_dcl_index_table.[cMemberDefs]
# com_instance_defs=reorder_array com_instance_defs icl_to_dcl_index_table.[cInstanceDefs]
......@@ -1492,9 +1492,13 @@ where
can_be_only_in_dcl def_kind
= def_kind == cTypeDefs || def_kind == cSelectorDefs || def_kind == cClassDefs || def_kind == cGenericDefs
is_abstract_type com_type_defs decl_index
= case com_type_defs.[decl_index].td_rhs of (AbstractType _) -> True ; (AbstractSynType _ _) -> True ; _ -> False
is_abstract_type com_type_defs decl_index
= case com_type_defs.[decl_index].td_rhs of
AbstractType _ -> True
AbstractSynType _ _ -> True
AbstractNewType _ _ -> True
_ -> False
add_dcl_declaration info_ptr entry (Declaration dcl) def_index decl_index (conversion_table, icl_sizes, icl_defs, symbol_table)
# (icl_index, icl_sizes) = icl_sizes![def_index]
= ( { conversion_table & [def_index].[decl_index] = icl_index }
......@@ -1523,16 +1527,17 @@ where
# new_cons_defs = if (dcl_cons_index==(-1)) new_cons_defs [ com_cons_defs.[dcl_cons_index] : new_cons_defs ]
= ([ { td & td_rhs = NewType cons} : new_type_defs ],new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,cs)
add_type_def td=:{td_ident, td_pos, td_rhs = AbstractType _} new_type_defs new_cons_defs new_selector_defs conversion_table icl_sizes icl_decl_symbols cs
# cs_error = checkError "abstract type not defined in implementation module" ""
(setErrorAdmin (newPosition td_ident td_pos) cs.cs_error)
= (new_type_defs,new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,{ cs & cs_error = cs_error })
# cs & cs_error = abstract_type_error td_ident td_pos cs.cs_error
= (new_type_defs,new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,cs)
add_type_def td=:{td_ident, td_pos, td_rhs = AbstractSynType _ _} new_type_defs new_cons_defs new_selector_defs conversion_table icl_sizes icl_decl_symbols cs
# cs_error = checkError "abstract type not defined in implementation module" ""
(setErrorAdmin (newPosition td_ident td_pos) cs.cs_error)
= (new_type_defs,new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,{ cs & cs_error = cs_error })
# cs & cs_error = abstract_type_error td_ident td_pos cs.cs_error
= (new_type_defs,new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,cs)
add_type_def td=:{td_pos, td_rhs = ExtensibleAlgType 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 = ExtensibleAlgType conses} : new_type_defs],new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,cs)
add_type_def td=:{td_ident, td_pos, td_rhs = AbstractNewType _ _} new_type_defs new_cons_defs new_selector_defs conversion_table icl_sizes icl_decl_symbols cs
# cs & cs_error = abstract_type_error td_ident td_pos cs.cs_error
= (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)
......@@ -1550,6 +1555,9 @@ where
is_field (STE_Field _) = True
is_field _ = False
abstract_type_error td_ident td_pos error
= checkError "abstract type not defined in implementation module" "" (setErrorAdmin (newPosition td_ident td_pos) error)
add_dcl_definition {com_selector_defs} dcl=:(Declaration {decl_kind = STE_Field _, decl_index})
(new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, copied_defs, conversion_table, icl_sizes, icl_decl_symbols, cs)
= (new_type_defs, new_class_defs, new_cons_defs, [ com_selector_defs.[decl_index] : new_selector_defs ], new_member_defs, new_generic_defs, copied_defs, conversion_table, icl_sizes, icl_decl_symbols, cs)
......
......@@ -1380,30 +1380,36 @@ where
= (kind, st_arity, ft_priority, e_state, e_info, cs)
determine_info_of_symbol entry=:{ste_kind=STE_Imported kind mod_index,ste_index} symb_index e_input e_state e_info=:{ef_modules} cs
# (mod_def, ef_modules) = ef_modules![mod_index]
# (kind, arity, priority) = ste_kind_to_symbol_kind kind ste_index mod_index mod_def
# (kind, arity, priority, cs) = ste_kind_to_symbol_kind kind ste_index mod_index mod_def cs
= (kind, arity, priority, e_state, { e_info & ef_modules = ef_modules }, cs)
where
ste_kind_to_symbol_kind :: !STE_Kind !Index !Index !DclModule -> (!SymbKind, !Int, !Priority);
ste_kind_to_symbol_kind STE_Member def_index mod_index {dcl_common={com_member_defs}}
ste_kind_to_symbol_kind :: !STE_Kind !Index !Index !DclModule !*CheckState -> (!SymbKind, !Int, !Priority, !*CheckState)
ste_kind_to_symbol_kind STE_Member def_index mod_index {dcl_common={com_member_defs}} cs
# {me_type={st_arity},me_priority} = com_member_defs.[def_index]
= (SK_OverloadedFunction { glob_object = def_index, glob_module = mod_index }, st_arity, me_priority)
ste_kind_to_symbol_kind STE_Constructor def_index mod_index {dcl_common={com_cons_defs}}
# {cons_type={st_arity,st_args,st_context},cons_priority,cons_number} = com_cons_defs.[def_index]
| cons_number <> ConsNumberNewType
= (SK_OverloadedFunction { glob_object = def_index, glob_module = mod_index }, st_arity, me_priority, cs)
ste_kind_to_symbol_kind STE_Constructor def_index mod_index {dcl_common={com_cons_defs}} cs
# {cons_ident,cons_type={st_arity,st_args,st_context},cons_priority,cons_number} = com_cons_defs.[def_index]
| not (IsNewTypeOrAbstractNewTypeCons cons_number)
| isEmpty st_context && no_TFAC_argument st_args
= (SK_Constructor {glob_object = def_index, glob_module = mod_index}, st_arity, cons_priority)
= (SK_OverloadedConstructor {glob_object = def_index, glob_module = mod_index}, st_arity, cons_priority)
= (SK_NewTypeConstructor {gi_index = def_index, gi_module = mod_index}, st_arity, cons_priority)
= (SK_Constructor {glob_object = def_index, glob_module = mod_index}, st_arity, cons_priority, cs)
= (SK_OverloadedConstructor {glob_object = def_index, glob_module = mod_index}, st_arity, cons_priority, cs)
| cons_number == ConsNumberNewType
= (SK_NewTypeConstructor {gi_index = def_index, gi_module = mod_index}, st_arity, cons_priority, cs)
# cs & cs_error = checkError cons_ident.id_name "abstract new type constructor may not be used" cs.cs_error
= (SK_NewTypeConstructor {gi_index = def_index, gi_module = mod_index}, st_arity, cons_priority, cs)
determine_info_of_symbol {ste_kind=STE_Member, ste_index} _ e_input=:{ei_mod_index} e_state e_info=:{ef_member_defs} cs
# ({me_type={st_arity},me_priority}, ef_member_defs) = ef_member_defs![ste_index]
= (SK_OverloadedFunction { glob_object = ste_index, glob_module = ei_mod_index}, st_arity, me_priority,
e_state, { e_info & ef_member_defs = ef_member_defs }, cs)
determine_info_of_symbol {ste_kind=STE_Constructor, ste_index} _ e_input=:{ei_mod_index} e_state e_info cs
# ({cons_type={st_arity,st_args,st_context},cons_priority,cons_number}, e_info) = e_info!ef_cons_defs.[ste_index]
| cons_number <> ConsNumberNewType
# ({cons_type={st_arity,st_args,st_context},cons_priority,cons_number,cons_ident}, e_info) = e_info!ef_cons_defs.[ste_index]
| not (IsNewTypeOrAbstractNewTypeCons cons_number)
| isEmpty st_context && no_TFAC_argument st_args
= (SK_Constructor {glob_object = ste_index, glob_module = ei_mod_index}, st_arity, cons_priority, e_state, e_info, cs)
= (SK_OverloadedConstructor {glob_object = ste_index, glob_module = ei_mod_index}, st_arity, cons_priority, e_state, e_info, cs)
| cons_number == ConsNumberNewType
= (SK_NewTypeConstructor {gi_index = ste_index, gi_module = ei_mod_index}, st_arity, cons_priority, e_state, e_info, cs)
# cs & cs_error = checkError cons_ident "abstract new type constructor may not be used" cs.cs_error
= (SK_NewTypeConstructor {gi_index = ste_index, gi_module = ei_mod_index}, st_arity, cons_priority, e_state, e_info, cs)
determine_info_of_symbol {ste_kind=STE_DclFunction, ste_index} _ e_input=:{ei_mod_index} e_state=:{es_calls} e_info=:{ef_is_macro_fun} cs
# ({ft_type={st_arity},ft_priority}, e_info) = e_info!ef_modules.[ei_mod_index].dcl_functions.[ste_index]
......@@ -1438,7 +1444,7 @@ checkQualifiedIdentExpression free_vars module_id ident_name is_expr_list e_inpu
-> (app_expr, free_vars, e_state, e_info, cs)
STE_Imported STE_Constructor mod_index
# ({cons_type={st_arity,st_args,st_context},cons_priority,cons_number}, e_info) = e_info!ef_modules.[mod_index].dcl_common.com_cons_defs.[decl_index]
| cons_number <> ConsNumberNewType
| not (IsNewTypeOrAbstractNewTypeCons cons_number)
| isEmpty st_context
| no_TFAC_argument st_args
# kind = SK_Constructor { glob_object = decl_index, glob_module = mod_index }
......@@ -1857,6 +1863,12 @@ checkPatternConstructor mod_index is_expr_list {ste_index, ste_kind} cons_ident
= (AP_Constant (APK_NewTypeConstructor cons_type_index) cons_symbol cons_priority, ps, e_info, {cs & cs_error = cs_error})
# cs & cs_error = checkError cons_ident "constructor argument is missing" cs_error
= (AP_NewType cons_symbol cons_type_index AP_Empty opt_var, ps, e_info, cs)
| cons_number == ConsNumberAbstractNewType
# cs_error = checkError cons_ident "abstract new type constructor may not be used" cs_error
| is_expr_list
= (AP_Constant (APK_NewTypeConstructor cons_type_index) cons_symbol cons_priority, ps, e_info, {cs & cs_error = cs_error})
# cs & cs_error = checkError cons_ident "constructor argument is missing" cs_error
= (AP_NewType cons_symbol cons_type_index AP_Empty opt_var, ps, e_info, cs)
| cons_number == ConsNumberAddedConstructor
# (type_rhs,e_info)
= case ste_kind of
......@@ -1915,6 +1927,12 @@ checkQualifiedPatternConstructor ste_kind ste_index decl_ident module_name ident
= (AP_Constant (APK_NewTypeConstructor cons_type_index) cons_symbol cons_priority, ps, e_info, {cs & cs_error = cs_error})
# cs & cs_error = checkError ident_name "constructor argument is missing" cs_error
= (AP_NewType cons_symbol cons_type_index AP_Empty opt_var, ps, e_info, cs)
| cons_number == ConsNumberAbstractNewType
# cs_error = checkError ident_name "abstract new type constructor may not be used" cs_error
| is_expr_list
= (AP_Constant (APK_NewTypeConstructor cons_type_index) cons_symbol cons_priority, ps, e_info, {cs & cs_error = cs_error})
# cs & cs_error = checkError ident_name "constructor argument is missing" cs_error
= (AP_NewType cons_symbol cons_type_index AP_Empty opt_var, ps, e_info, cs)
| cons_number == ConsNumberAddedConstructor
# (type_rhs,e_info)
= case ste_kind of
......
......@@ -482,7 +482,7 @@ where
check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:AlgType 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]}
(type_def_args_to_TA_args 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=:RecordType {rt_constructor={ds_index,ds_arity}, rt_fields}}
......@@ -535,7 +535,7 @@ where
check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:NewType {ds_index}} 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]}
(type_def_args_to_TA_args td_args)}
class_defs_ts_ti_cs = bind_types_of_constructor cti ConsNumberNewType (atype_vars_to_type_vars td_args) attr_vars type_lhs ds_index class_defs_ts_ti_cs
= (td_rhs, class_defs_ts_ti_cs)
check_rhs_of_TypeDef {td_rhs = AbstractSynType properties type} _ cti (class_defs,ts,ti,cs)
......@@ -544,7 +544,7 @@ where
check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:ExtensibleAlgType 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]}
(type_def_args_to_TA_args 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_attribute,td_rhs = td_rhs=:UncheckedAlgConses type_ext_ident conses} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} class_defs_ts_ti_cs
......@@ -569,12 +569,21 @@ where
# class_defs_ts_ti_cs = (class_defs,ts,ti,cs)
# 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]}
(type_def_args_to_TA_args td_args)}
class_defs_ts_ti_cs = bind_types_of_added_constructors cti (atype_vars_to_type_vars td_args) attr_vars type_lhs conses class_defs_ts_ti_cs
= (AlgConses conses {gi_module=type_module,gi_index=type_index}, class_defs_ts_ti_cs)
check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:AbstractNewType _ {ds_index}} 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)
(type_def_args_to_TA_args td_args)}
class_defs_ts_ti_cs = bind_types_of_constructor cti ConsNumberAbstractNewType (atype_vars_to_type_vars td_args) attr_vars type_lhs ds_index class_defs_ts_ti_cs
= (td_rhs, class_defs_ts_ti_cs)
check_rhs_of_TypeDef {td_rhs} _ _ class_defs_ts_ti_cs
= (td_rhs, class_defs_ts_ti_cs)
type_def_args_to_TA_args td_args
= [{at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]
atype_vars_to_type_vars atype_vars
= [atv_variable \\ {atv_variable} <- atype_vars]
......
......@@ -122,6 +122,13 @@ 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 (AbstractNewType _ dclConstructor) (NewType iclConstructor) dcl_cons_defs icl_cons_defs comp_st
| dclConstructor.ds_index<>iclConstructor.ds_index
= (False, icl_cons_defs, comp_st)
# dcl_cons_def = dcl_cons_defs.[dclConstructor.ds_index]
(icl_cons_def, icl_cons_defs) = icl_cons_defs![iclConstructor.ds_index]
# (ok, comp_st) = compare_cons_def_types True icl_cons_def dcl_cons_def comp_st
= (ok, icl_cons_defs, comp_st)
compare_rhs_of_types (ExtensibleAlgType []) (ExtensibleAlgType []) dcl_cons_defs icl_cons_defs comp_st
= (True, icl_cons_defs, comp_st)
compare_rhs_of_types (ExtensibleAlgType dclConstructors) (ExtensibleAlgType iclConstructors) dcl_cons_defs icl_cons_defs comp_st
......@@ -1103,6 +1110,8 @@ instance t_corresponds TypeRhs where
= t_corresponds dclConstructor iclConstructor
t_corresponds (ExtensibleAlgType dclConstructors) (ExtensibleAlgType iclConstructors)
= t_corresponds dclConstructors iclConstructors
t_corresponds (AbstractNewType _ dclConstructor) (NewType iclConstructor)
= t_corresponds dclConstructor iclConstructor
// sanity check ...
t_corresponds UnknownType _
......
......@@ -27,7 +27,7 @@ DontCollectImportedConstructors:==4
, ets_type_heaps :: !.TypeHeaps
, ets_var_heap :: !.VarHeap
, ets_main_dcl_module_n :: !Int
, ets_contains_unexpanded_abs_syn_type :: !Bool
, ets_contains_unexpanded_abs_syn_or_new_type :: !Bool
}
class expandSynTypes a :: !Int !{#CommonDefs} !a !*ExpandTypeState -> (!Bool,!a, !*ExpandTypeState)
......
......@@ -54,7 +54,7 @@ DontCollectImportedConstructorsAndRestorePointers:==4
convertSymbolType :: !Bool !{#CommonDefs} !SymbolType !Int !*ImportedTypes !ImportedConstructors !*TypeHeaps !*VarHeap
-> (!SymbolType, !*ImportedTypes,!ImportedConstructors,!*TypeHeaps,!*VarHeap)
convertSymbolType rem_annots common_defs st main_dcl_module_n imported_types collected_imports type_heaps var_heap
# (st, ets_contains_unexpanded_abs_syn_type,ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap)
# (st, _, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap)
= convertSymbolType_ (if rem_annots (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask) ExpandAbstractSynTypesMask) common_defs st main_dcl_module_n imported_types collected_imports type_heaps var_heap
= (st, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap)
......@@ -71,7 +71,7 @@ convertSymbolTypeWithoutCollectingImportedConstructors rem_annots common_defs st
= if rem_annots
(RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask bitor DontCollectImportedConstructorsAndRestorePointers)
(ExpandAbstractSynTypesMask bitor DontCollectImportedConstructorsAndRestorePointers)
# (st, ets_contains_unexpanded_abs_syn_type,ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap)
# (st, _, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap)
= convertSymbolType_ rem_annots common_defs st main_dcl_module_n imported_types [] type_heaps var_heap
= (st, ets_type_defs, ets_type_heaps, ets_var_heap)
......@@ -83,7 +83,7 @@ convertSymbolType_ rem_annots common_defs st main_dcl_module_n imported_types c
, ets_type_heaps = type_heaps
, ets_var_heap = var_heap
, ets_main_dcl_module_n = main_dcl_module_n
, ets_contains_unexpanded_abs_syn_type = False
, ets_contains_unexpanded_abs_syn_or_new_type = False
}
# {st_args,st_result,st_context,st_args_strictness} = st
#! (_,(st_args,st_result), ets) = expandSynTypes rem_annots common_defs (st_args,st_result) ets
......@@ -96,8 +96,8 @@ convertSymbolType_ rem_annots common_defs st main_dcl_module_n imported_types c
, st_args_strictness = insert_n_strictness_values_at_beginning (new_st_arity-length st_args) st_args_strictness
, st_context = []
}
# {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap,ets_contains_unexpanded_abs_syn_type} = ets
= (st, ets_contains_unexpanded_abs_syn_type, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap)
# {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap,ets_contains_unexpanded_abs_syn_or_new_type} = ets
= (st, ets_contains_unexpanded_abs_syn_or_new_type, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap)
addTypesOfDictionaries :: !{#CommonDefs} ![TypeContext] ![AType] -> [AType]
addTypesOfDictionaries common_defs type_contexts type_args
......@@ -136,7 +136,7 @@ where
, ets_type_heaps :: !.TypeHeaps
, ets_var_heap :: !.VarHeap
, ets_main_dcl_module_n :: !Int
, ets_contains_unexpanded_abs_syn_type :: !Bool
, ets_contains_unexpanded_abs_syn_or_new_type :: !Bool
}
class expandSynTypes a :: !Int !{#CommonDefs} !a !*ExpandTypeState -> (!Bool,!a, !*ExpandTypeState)
......@@ -223,21 +223,21 @@ expand_syn_types_in_TA rem_annots common_defs ta_type attribute ets=:{ets_type_d
SynType rhs_type
-> expand_type types td_args td_attribute rhs_type rem_annots attribute ets
AbstractSynType _ rhs_type
| (rem_annots bitand ExpandAbstractSynTypesMask)<>0
| rem_annots bitand ExpandAbstractSynTypesMask<>0
-> expand_type types td_args td_attribute rhs_type rem_annots attribute ets
# ets = {ets & ets_contains_unexpanded_abs_syn_type=True }
# ets & ets_contains_unexpanded_abs_syn_or_new_type=True
#! (changed,types, ets) = expandSynTypes rem_annots common_defs types ets
# ta_type = if changed
( case ta_type of
TA type_symb _ -> TA type_symb types
TAS type_symb _ strictness -> TAS type_symb types strictness
) ta_type
| glob_module == ets.ets_main_dcl_module_n
-> (changed,ta_type, ets)
-> (changed,ta_type, collect_imported_constructors common_defs glob_module td_rhs ets)
-> update_TA_types_if_changed changed ta_type types ets
NewType {ds_index}
# {cons_type={st_args=[arg_type:_]}} = common_defs.[glob_module].com_cons_defs.[ds_index];
-> expand_type types td_args td_attribute arg_type rem_annots attribute ets
AbstractNewType _ {ds_index}
| rem_annots bitand ExpandAbstractSynTypesMask<>0
# {cons_type={st_args=[arg_type:_]}} = common_defs.[glob_module].com_cons_defs.[ds_index];
-> expand_type types td_args td_attribute arg_type rem_annots attribute ets
# ets & ets_contains_unexpanded_abs_syn_or_new_type=True
#! (changed,types, ets) = expandSynTypes rem_annots common_defs types ets
-> update_TA_types_if_changed changed ta_type types ets
_
#! (changed,types, ets) = expandSynTypes rem_annots common_defs types ets
# ta_type = if changed
......@@ -246,8 +246,9 @@ expand_syn_types_in_TA rem_annots common_defs ta_type attribute ets=:{ets_type_d
TAS type_symb _ strictness -> TAS type_symb types strictness
) ta_type
| glob_module == ets.ets_main_dcl_module_n || (rem_annots bitand DontCollectImportedConstructorsAndRestorePointers)<>0
-> (changed,ta_type, ets)
-> (changed,ta_type, collect_imported_constructors common_defs glob_module td_rhs ets)
-> update_TA_types_if_changed changed ta_type types ets
# ets = collect_imported_constructors common_defs glob_module td_rhs ets
-> update_TA_types_if_changed changed ta_type types ets
where
expand_type types td_args td_attribute rhs_type rem_annots attribute ets
| (rem_annots bitand DontCollectImportedConstructorsAndRestorePointers)==0
......@@ -293,10 +294,17 @@ where
substitute_rhs rem_annots rhs_type type_heaps
| rem_annots bitand RemoveAnnotationsMask<>0
# (_, rhs_type) = removeAnnotations rhs_type
# (_,type,heaps) = substitute rhs_type type_heaps
= (type,heaps)
# (_,type,heaps) = substitute rhs_type type_heaps
= (type,heaps)
# (_,type,heaps) = substitute rhs_type type_heaps
= (type,heaps)
# (_,type,heaps) = substitute rhs_type type_heaps
= (type,heaps)
update_TA_types_if_changed changed=:False ta_type types ets
= (changed, ta_type, ets)
update_TA_types_if_changed changed=:True (TA type_symb _) types ets
= (changed, TA type_symb types, ets)
update_TA_types_if_changed changed=:True (TAS type_symb _ strictness) types ets
= (changed, TAS type_symb types strictness, ets)
collect_imported_constructors :: !{#.CommonDefs} !.Int !.TypeRhs !*ExpandTypeState -> .ExpandTypeState
collect_imported_constructors common_defs mod_index (RecordType {rt_constructor}) ets=:{ets_collected_conses,ets_var_heap}
......
......@@ -2293,14 +2293,24 @@ where
want_type_rhs token=:OpenToken parseContext td=:{td_attribute} annot pState
| isIclContext parseContext
= (PD_Erroneous, parseError "type RHS" (Yes token) "type definition" pState)
# pState = wantToken TypeContext "Abstract type synonym" ColonDefinesToken pState
# name = td.td_ident.id_name
(atype, pState) = want pState // Atype
# (td_attribute, properties) = determine_properties annot td_attribute
td = {td & td_rhs = AbstractTypeSpec properties atype, td_attribute=td_attribute}
# pState = wantToken TypeContext "Abstract type synonym" CloseToken pState
| td_attribute == TA_Anonymous || td_attribute == TA_Unique || td_attribute == TA_None
= (PD_Type td, pState)
# name = td.td_ident.id_name
(td_attribute, properties) = determine_properties annot td_attribute
| td_attribute =: TA_Anonymous || td_attribute =: TA_Unique || td_attribute =: TA_None
# (token, pState) = nextToken TypeContext pState
# td & td_attribute = td_attribute
| token=:ColonDefinesToken
# (atype, pState) = want pState // Atype
td & td_rhs = AbstractTypeSpec properties atype
pState = wantToken TypeContext "Abstract type synonym" CloseToken pState
= (PD_Type td, pState)
| token=:DefinesColonToken
# (exi_vars, pState) = optionalExistentialQuantifiedVariables pState
(token, pState) = nextToken GeneralContext pState
(condef, pState) = want_newtype_constructor exi_vars token pState
td & td_rhs = AbstractNewTypeCons properties condef
pState = wantToken TypeContext "Abstract new type" CloseToken pState
= (PD_Type td, pState)
= (PD_Type td, parseErrorSimple name "only synonym types and new types can be hidden" pState)
= (PD_Type td, parseError "abstract type" No ("type attribute "+toString td_attribute+" for abstract type "+name+" is not") (tokenBack pState))
want_type_rhs BarToken parseContext td=:{td_ident,td_attribute} annot pState
......
......@@ -1458,7 +1458,14 @@ reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = NewTypeCons cons_d
(fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca
type_def = { type_def & td_rhs = NewType cons_symb }
c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = [ParsedConstructorToConsDef cons_def : c_defs.def_constructors] }
= (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca)
= (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca)
reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = AbstractNewTypeCons properties cons_def=:{pc_cons_ident,pc_cons_arity}} : defs] def_counts=:{cons_count,type_count} ca
# cons_symb = { ds_ident = pc_cons_ident, ds_arity = pc_cons_arity, ds_index = cons_count }
def_counts & cons_count=cons_count+1, type_count=type_count+1
(fun_defs, c_defs, imports, imported_objects,foreign_exports, ca) = reorganiseDefinitions icl_module defs def_counts ca
type_def & td_rhs = AbstractNewType properties cons_symb
c_defs & def_types = [type_def : c_defs.def_types], def_constructors = [ParsedConstructorToConsDef cons_def : c_defs.def_constructors]
= (fun_defs, c_defs, imports, imported_objects,foreign_exports, ca)
reorganiseDefinitions icl_module [PD_Type type_def=:{td_ident, td_rhs = SelectorList rec_cons_id exivars is_boxed_record sel_defs, td_pos } : defs] def_counts=:{cons_count,sel_count,type_count} ca
# (sel_syms, new_count) = determine_symbols_of_selectors sel_defs sel_count
def_counts & cons_count=cons_count+1, sel_count=new_count, type_count=type_count+1
......
......@@ -185,6 +185,7 @@ instance == FunctionOrMacroIndex
| NewTypeCons !ParsedConstructor
| EmptyRhs !BITVECT
| AbstractTypeSpec !BITVECT !AType
| AbstractNewTypeCons !BITVECT !ParsedConstructor
| ExtensibleConses ![ParsedConstructor]
| MoreConses !Ident ![ParsedConstructor]
......@@ -583,6 +584,7 @@ cIsImportedObject :== False
| NewType !DefinedSymbol
| AbstractType !BITVECT
| AbstractSynType !BITVECT !AType
| AbstractNewType !BITVECT !DefinedSymbol
| ExtensibleAlgType ![DefinedSymbol]
| AlgConses ![DefinedSymbol] !GlobalIndex
| UncheckedAlgConses !Ident ![DefinedSymbol]
......@@ -1019,8 +1021,10 @@ cNotVarNumber :== -1
}
// Possible values for cons_number (-1 is reserved for NoIndex):
ConsNumberNewType :== -2
ConsNumberAddedConstructor :== -3
ConsNumberAddedConstructor :== -2
ConsNumberNewType :== -3
ConsNumberAbstractNewType :== -4
IsNewTypeOrAbstractNewTypeCons cons_number :== cons_number <= ConsNumberNewType
:: SelectorDef =
{ sd_ident :: !Ident // IC_Selector
......
......@@ -676,6 +676,10 @@ where
= file <<< " = " <<< data <<< " | .."
(<<<) file (AlgConses data _)
= file <<< " | " <<< data
(<<<) file (NewType symbol)
= file <<< " =: " <<< symbol
(<<<) file (AbstractSynType _ type)
= file <<< " (:== " <<< type <<< ')'
(<<<) file _
= file
......
......@@ -4652,13 +4652,13 @@ where
# (FI_Function {gf_fun_def,gf_fun_index}) = sreadPtr fun_ptr fun_heap
{fun_type = Yes ft=:{st_args,st_result}, fun_info = {fi_group_index,fi_properties}} = gf_fun_def
ets =
{ ets_type_defs = imported_types
, ets_collected_conses = collected_imports
, ets_type_heaps = type_heaps
, ets_var_heap = var_heap
, ets_main_dcl_module_n = main_dcl_module_n
, ets_contains_unexpanded_abs_syn_type = False
}
{ ets_type_defs = imported_types
, ets_collected_conses = collected_imports
, ets_type_heaps = type_heaps
, ets_var_heap = var_heap
, ets_main_dcl_module_n = main_dcl_module_n
, ets_contains_unexpanded_abs_syn_or_new_type = False
}
#! (_,(st_args,st_result), {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap})
= expandSynTypes (if (fi_properties bitand FI_HasTypeSpec == 0) (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask) ExpandAbstractSynTypesMask) common_defs (st_args,st_result) ets
# ft = { ft & st_result = st_result, st_args = st_args }
......
......@@ -135,8 +135,12 @@ where
// unimplemented
= (tcl_file,wtis)
write_type_info (NewType _) tcl_file wtis
#! tcl_file = fwritec AbstractTypeCode tcl_file;
// unimplemented
#! tcl_file = fwritec AbstractTypeCode tcl_file;
// unimplemented
= (tcl_file,wtis)
write_type_info (AbstractNewType _ _) tcl_file wtis
#! tcl_file = fwritec AbstractTypeCode tcl_file;
// unimplemented
= (tcl_file,wtis)
instance WriteTypeInfo DefinedSymbol
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment