Commit 19fdc6be authored by johnvg@science.ru.nl's avatar johnvg@science.ru.nl

remove struct flat_type, replace fields type_lhs by type_symbol and...

remove struct flat_type, replace fields type_lhs by type_symbol and type_attribute, remove BEFlatType, adjust BEAbstractType, replace BEAlgebraicType, BEExtendableAlgebraicType and BERecordType by BEDefineAlgebraicType, BEDefineExtensibleAlgebraicType and BEDefineRecordType, add constructor index argument to BEDefineRecordType and pass TypeArgP instead of TypeNodeP to remove hack in this function and BEConstructorSymbol
parent 766d7eee
...@@ -68,10 +68,9 @@ BEDefineRuleType ...@@ -68,10 +68,9 @@ BEDefineRuleType
BEAdjustArrayFunction BEAdjustArrayFunction
BENoRules BENoRules
BERules BERules
BEFlatType BEDefineAlgebraicType
BEAlgebraicType BEDefineRecordType
BERecordType BEAbstractType
BEAbsType
BEConstructorList BEConstructorList
BENoConstructors BENoConstructors
BEDeclareField BEDeclareField
......
...@@ -68,11 +68,10 @@ BEDefineRuleType ...@@ -68,11 +68,10 @@ BEDefineRuleType
BEAdjustArrayFunction BEAdjustArrayFunction
BENoRules BENoRules
BERules BERules
BEFlatType BEDefineAlgebraicType
BEAlgebraicType BEDefineExtensibleAlgebraicType
BEExtendableAlgebraicType BEDefineRecordType
BERecordType BEAbstractType
BEAbsType
BEConstructorList BEConstructorList
BENoConstructors BENoConstructors
BEDeclareField BEDeclareField
......
...@@ -11,7 +11,6 @@ definition module backend; ...@@ -11,7 +11,6 @@ definition module backend;
:: BEArgP (:== CPtr); :: BEArgP (:== CPtr);
:: BERuleAltP (:== CPtr); :: BERuleAltP (:== CPtr);
:: BEImpRuleP (:== CPtr); :: BEImpRuleP (:== CPtr);
:: BEFlatTypeP (:== CPtr);
:: BEConstructorListP (:== CPtr); :: BEConstructorListP (:== CPtr);
:: BEFieldListP (:== CPtr); :: BEFieldListP (:== CPtr);
:: BENodeIdP (:== CPtr); :: BENodeIdP (:== CPtr);
...@@ -170,16 +169,14 @@ BENoRules :: !BackEnd -> (!BEImpRuleP,!BackEnd); ...@@ -170,16 +169,14 @@ BENoRules :: !BackEnd -> (!BEImpRuleP,!BackEnd);
// BEImpRuleP BENoRules (); // BEImpRuleP BENoRules ();
BERules :: !BEImpRuleP !BEImpRuleP !BackEnd -> (!BEImpRuleP,!BackEnd); BERules :: !BEImpRuleP !BEImpRuleP !BackEnd -> (!BEImpRuleP,!BackEnd);
// BEImpRuleP BERules (BEImpRuleP rule,BEImpRuleP rules); // BEImpRuleP BERules (BEImpRuleP rule,BEImpRuleP rules);
BEFlatType :: !BESymbolP !BEAttribution !BackEnd -> (!BEFlatTypeP,!BackEnd); BEDefineAlgebraicType :: !BESymbolP !BEAttribution !BEConstructorListP !BackEnd -> BackEnd;
// BEFlatTypeP BEFlatType (BESymbolP symbol,BEAttribution attribution); // void BEDefineAlgebraicType (BESymbolP symbol,BEAttribution attribution,BEConstructorListP constructors);
BEAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd; BEDefineExtensibleAlgebraicType :: !BESymbolP !BEAttribution !BEConstructorListP !BackEnd -> BackEnd;
// void BEAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors); // void BEDefineExtensibleAlgebraicType (BESymbolP symbol,BEAttribution attribution,BEConstructorListP constructors);
BEExtendableAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd; BEDefineRecordType :: !BESymbolP !BEAttribution !Int !Int !BETypeArgP !Int !BEFieldListP !BackEnd -> BackEnd;
// void BEExtendableAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors); // void BEDefineRecordType (BESymbolP symbol,BEAttribution attribution,int moduleIndex,int constructorIndex,BETypeArgP constructorArgs,int is_boxed_record,BEFieldListP fields);
BERecordType :: !Int !BEFlatTypeP !BETypeNodeP !Int !BEFieldListP !BackEnd -> BackEnd; BEAbstractType :: !BESymbolP !BackEnd -> BackEnd;
// void BERecordType (int moduleIndex,BEFlatTypeP lhs,BETypeNodeP constructorType,int is_boxed_record,BEFieldListP fields); // void BEAbstractType (BESymbolP symbol);
BEAbsType :: !BEFlatTypeP !BackEnd -> BackEnd;
// void BEAbsType (BEFlatTypeP lhs);
BEConstructorList :: !BETypeNodeP !BEConstructorListP !BackEnd -> (!BEConstructorListP,!BackEnd); BEConstructorList :: !BETypeNodeP !BEConstructorListP !BackEnd -> (!BEConstructorListP,!BackEnd);
// BEConstructorListP BEConstructorList (BETypeNodeP type,BEConstructorListP constructors); // BEConstructorListP BEConstructorList (BETypeNodeP type,BEConstructorListP constructors);
BENoConstructors :: !BackEnd -> (!BEConstructorListP,!BackEnd); BENoConstructors :: !BackEnd -> (!BEConstructorListP,!BackEnd);
......
...@@ -11,7 +11,6 @@ implementation module backend; ...@@ -11,7 +11,6 @@ implementation module backend;
:: BEArgP :== CPtr; :: BEArgP :== CPtr;
:: BERuleAltP :== CPtr; :: BERuleAltP :== CPtr;
:: BEImpRuleP :== CPtr; :: BEImpRuleP :== CPtr;
:: BEFlatTypeP :== CPtr;
:: BEConstructorListP :== CPtr; :: BEConstructorListP :== CPtr;
:: BEFieldListP :== CPtr; :: BEFieldListP :== CPtr;
:: BENodeIdP :== CPtr; :: BENodeIdP :== CPtr;
...@@ -455,35 +454,29 @@ BERules a0 a1 a2 = code { ...@@ -455,35 +454,29 @@ BERules a0 a1 a2 = code {
} }
// BEImpRuleP BERules (BEImpRuleP rule,BEImpRuleP rules); // BEImpRuleP BERules (BEImpRuleP rule,BEImpRuleP rules);
BEFlatType :: !BESymbolP !BEAttribution !BackEnd -> (!BEFlatTypeP,!BackEnd); BEDefineAlgebraicType :: !BESymbolP !BEAttribution !BEConstructorListP !BackEnd -> BackEnd;
BEFlatType a0 a1 a2 = code { BEDefineAlgebraicType a0 a1 a2 a3 = code {
ccall BEFlatType "pI:p:p" ccall BEDefineAlgebraicType "pIp:V:p"
} }
// BEFlatTypeP BEFlatType (BESymbolP symbol,BEAttribution attribution); // void BEDefineAlgebraicType (BESymbolP symbol,BEAttribution attribution,BEConstructorListP constructors);
BEAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd; BEDefineExtensibleAlgebraicType :: !BESymbolP !BEAttribution !BEConstructorListP !BackEnd -> BackEnd;
BEAlgebraicType a0 a1 a2 = code { BEDefineExtensibleAlgebraicType a0 a1 a2 a3 = code {
ccall BEAlgebraicType "pp:V:p" ccall BEDefineExtensibleAlgebraicType "pIp:V:p"
} }
// void BEAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors); // void BEDefineExtensibleAlgebraicType (BESymbolP symbol,BEAttribution attribution,BEConstructorListP constructors);
BEExtendableAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd; BEDefineRecordType :: !BESymbolP !BEAttribution !Int !Int !BETypeArgP !Int !BEFieldListP !BackEnd -> BackEnd;
BEExtendableAlgebraicType a0 a1 a2 = code { BEDefineRecordType a0 a1 a2 a3 a4 a5 a6 a7 = code {
ccall BEExtendableAlgebraicType "pp:V:p" ccall BEDefineRecordType "pIIIpIp:V:p"
} }
// void BEExtendableAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors); // void BEDefineRecordType (BESymbolP symbol,BEAttribution attribution,int moduleIndex,int constructorIndex,BETypeArgP constructor_args,int is_boxed_record,BEFieldListP fields);
BERecordType :: !Int !BEFlatTypeP !BETypeNodeP !Int !BEFieldListP !BackEnd -> BackEnd; BEAbstractType :: !BESymbolP !BackEnd -> BackEnd;
BERecordType a0 a1 a2 a3 a4 a5 = code { BEAbstractType a0 a1 = code {
ccall BERecordType "IppIp:V:p" ccall BEAbstractType "p:V:p"
} }
// void BERecordType (int moduleIndex,BEFlatTypeP lhs,BETypeNodeP constructorType,int is_boxed_record,BEFieldListP fields); // void BEAbstractType (BESymbolP symbol);
BEAbsType :: !BEFlatTypeP !BackEnd -> BackEnd;
BEAbsType a0 a1 = code {
ccall BEAbsType "p:V:p"
}
// void BEAbsType (BEFlatTypeP lhs);
BEConstructorList :: !BETypeNodeP !BEConstructorListP !BackEnd -> (!BEConstructorListP,!BackEnd); BEConstructorList :: !BETypeNodeP !BEConstructorListP !BackEnd -> (!BEConstructorListP,!BackEnd);
BEConstructorList a0 a1 a2 = code { BEConstructorList a0 a1 a2 = code {
......
...@@ -725,17 +725,18 @@ define_dictionary_types type_i class_i type_i_stop moduleIndex constructors sele ...@@ -725,17 +725,18 @@ define_dictionary_types type_i class_i type_i_stop moduleIndex constructors sele
= define_dictionary_types (type_i+1) (class_i+1) type_i_stop moduleIndex constructors selectors types class_defs member_defs type_var_heap bes = define_dictionary_types (type_i+1) (class_i+1) type_i_stop moduleIndex constructors selectors types class_defs member_defs type_var_heap bes
= (type_var_heap,bes) = (type_var_heap,bes)
convertTypeLhs :: ModuleIndex Index TypeAttribute [ATypeVar] !*TypeVarHeap !*BackEndState -> (!BEFlatTypeP, !*TypeVarHeap,!*BackEndState) convertTypeLhs :: ModuleIndex Index TypeAttribute [ATypeVar] !*TypeVarHeap !*BackEndState
-> (!BESymbolP,!BEAttribution, !*TypeVarHeap,!*BackEndState)
convertTypeLhs moduleIndex typeIndex attribute args type_var_heap bes convertTypeLhs moduleIndex typeIndex attribute args type_var_heap bes
= convertTypeDefToFlatType (beTypeSymbol typeIndex moduleIndex) attribute args type_var_heap bes = convertTypeDefToFlatType (beTypeSymbol typeIndex moduleIndex) attribute args type_var_heap bes
convertTypeDefToFlatType :: (BEMonad BESymbolP) TypeAttribute [ATypeVar] !*TypeVarHeap !*BackEndState -> (!BEFlatTypeP, !*TypeVarHeap,!*BackEndState) convertTypeDefToFlatType :: (BEMonad BESymbolP) TypeAttribute [ATypeVar] !*TypeVarHeap !*BackEndState
-> (!BESymbolP,!BEAttribution,!*TypeVarHeap,!*BackEndState)
convertTypeDefToFlatType type_symbol_m attribute args type_var_heap bes convertTypeDefToFlatType type_symbol_m attribute args type_var_heap bes
# (a1,bes) = type_symbol_m bes # (a1,bes) = type_symbol_m bes
(a2,bes) = convertAttribution attribute bes (a2,bes) = convertAttribution attribute bes
type_var_heap = numberLhsTypeVars args 0 type_var_heap type_var_heap = numberLhsTypeVars args 0 type_var_heap
(flat_type_p,bes) = accBackEnd (BEFlatType a1 a2) bes = (a1,a2,type_var_heap,bes)
= (flat_type_p,type_var_heap,bes)
numberLhsTypeVars :: [ATypeVar] Int !*TypeVarHeap -> *TypeVarHeap numberLhsTypeVars :: [ATypeVar] Int !*TypeVarHeap -> *TypeVarHeap
numberLhsTypeVars [{atv_variable={tv_info_ptr}}:x] arg_n type_var_heap numberLhsTypeVars [{atv_variable={tv_info_ptr}}:x] arg_n type_var_heap
...@@ -753,16 +754,16 @@ remove_TVI_TypeVarArgN_in_args [] type_var_heap ...@@ -753,16 +754,16 @@ remove_TVI_TypeVarArgN_in_args [] type_var_heap
defineType :: ModuleIndex {#ConsDef} {#SelectorDef} Index CheckedTypeDef !*TypeVarHeap !*BackEndState -> (!*TypeVarHeap,!*BackEndState) defineType :: ModuleIndex {#ConsDef} {#SelectorDef} Index CheckedTypeDef !*TypeVarHeap !*BackEndState -> (!*TypeVarHeap,!*BackEndState)
defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=AlgType constructorSymbols} type_var_heap be defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=AlgType constructorSymbols} type_var_heap be
# (flatType,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be # (symbol_p,type_attribute,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be
(constructors,type_var_heap,be) (constructors,type_var_heap,be)
= convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols type_var_heap be = convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols type_var_heap be
be = appBackEnd (BEAlgebraicType flatType constructors) be be = appBackEnd (BEDefineAlgebraicType symbol_p type_attribute constructors) be
type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
= (type_var_heap,be) = (type_var_heap,be)
defineType moduleIndex constructors selectors typeIndex {td_attribute, td_args, td_rhs=RecordType {rt_constructor, rt_fields, rt_is_boxed_record}, td_fun_index} type_var_heap be defineType moduleIndex constructors selectors typeIndex {td_attribute, td_args, td_rhs=RecordType {rt_constructor, rt_fields, rt_is_boxed_record}, td_fun_index} type_var_heap be
# constructorIndex = rt_constructor.ds_index # constructorIndex = rt_constructor.ds_index
constructorDef = constructors.[constructorIndex] constructorDef = constructors.[constructorIndex]
(flatType,type_var_heap,be) (symbol_p,type_attribute,type_var_heap,be)
= if (td_fun_index<>NoIndex) = if (td_fun_index<>NoIndex)
(convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be) (convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be)
// define the record without marking, to prevent code generation for many unused generic dictionaries // define the record without marking, to prevent code generation for many unused generic dictionaries
...@@ -771,9 +772,7 @@ defineType moduleIndex constructors selectors typeIndex {td_attribute, td_args, ...@@ -771,9 +772,7 @@ defineType moduleIndex constructors selectors typeIndex {td_attribute, td_args,
= convertSelectors moduleIndex selectors rt_fields constructorDef.cons_type.st_args_strictness type_var_heap be = convertSelectors moduleIndex selectors rt_fields constructorDef.cons_type.st_args_strictness type_var_heap be
(constructorType,be) = constructorTypeFunction constructorDef be (constructorType,be) = constructorTypeFunction constructorDef be
(type_arg_p,type_var_heap,be) = convertTypeDefAnnotatedTypeArgs constructorType.st_args constructorType.st_args_strictness type_var_heap be (type_arg_p,type_var_heap,be) = convertTypeDefAnnotatedTypeArgs constructorType.st_args constructorType.st_args_strictness type_var_heap be
(symbol_p,be) = beConstructorSymbol moduleIndex constructorIndex be be = appBackEnd (BEDefineRecordType symbol_p type_attribute moduleIndex constructorIndex type_arg_p (if rt_is_boxed_record 1 0) fields) be
(constructorTypeNode,be) = accBackEnd (BENormalTypeNode symbol_p type_arg_p) be
be = appBackEnd (BERecordType moduleIndex flatType constructorTypeNode (if rt_is_boxed_record 1 0) fields) be
type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
= (type_var_heap,be) = (type_var_heap,be)
where where
...@@ -784,28 +783,26 @@ defineType moduleIndex constructors selectors typeIndex {td_attribute, td_args, ...@@ -784,28 +783,26 @@ defineType moduleIndex constructors selectors typeIndex {td_attribute, td_args,
-> (expandedType,bes) -> (expandedType,bes)
_ _
-> (constructorDef.cons_type,bes) -> (constructorDef.cons_type,bes)
defineType moduleIndex _ _ typeIndex {td_attribute, td_args, td_rhs=AbstractType _} type_var_heap be defineType moduleIndex _ _ typeIndex {td_rhs=AbstractType _} type_var_heap be
# (flatType,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be # (symbol,be) = beTypeSymbol typeIndex moduleIndex be
be = appBackEnd (BEAbsType flatType) be be = appBackEnd (BEAbstractType symbol) be
type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
= (type_var_heap,be) = (type_var_heap,be)
defineType moduleIndex _ _ typeIndex {td_attribute, td_args, td_rhs=AbstractSynType _ _} type_var_heap be defineType moduleIndex _ _ typeIndex {td_rhs=AbstractSynType _ _} type_var_heap be
# (flatType,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be # (symbol,be) = beTypeSymbol typeIndex moduleIndex be
be = appBackEnd (BEAbsType flatType) be be = appBackEnd (BEAbstractType symbol) be
type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
= (type_var_heap,be) = (type_var_heap,be)
defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=ExtensibleAlgType constructorSymbols} type_var_heap be defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=ExtensibleAlgType constructorSymbols} type_var_heap be
# (flatType,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be # (symbol_p,type_attribute,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be
(constructors,type_var_heap,be) (constructors,type_var_heap,be)
= convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols type_var_heap be = convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols type_var_heap be
be = appBackEnd (BEExtendableAlgebraicType flatType constructors) be 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 = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
= (type_var_heap,be) = (type_var_heap,be)
defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=AlgConses constructorSymbols _} type_var_heap be defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=AlgConses constructorSymbols _} type_var_heap be
# (flatType,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be # (symbol_p,type_attribute,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be
(constructors,type_var_heap,be) (constructors,type_var_heap,be)
= convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols type_var_heap be = convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols type_var_heap be
be = appBackEnd (BEExtendableAlgebraicType flatType constructors) be 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 = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
= (type_var_heap,be) = (type_var_heap,be)
defineType _ _ _ _ _ type_var_heap be defineType _ _ _ _ _ type_var_heap be
...@@ -818,7 +815,7 @@ define_dictionary_type moduleIndex constructors selectors typeIndex ...@@ -818,7 +815,7 @@ define_dictionary_type moduleIndex constructors selectors typeIndex
{class_members} member_defs type_var_heap bes {class_members} member_defs type_var_heap bes
# constructorIndex = rt_constructor.ds_index # constructorIndex = rt_constructor.ds_index
constructorDef = constructors.[constructorIndex] constructorDef = constructors.[constructorIndex]
(flatType,type_var_heap,bes) (symbol_p,type_attribute,type_var_heap,bes)
= if (td_fun_index<>NoIndex) = if (td_fun_index<>NoIndex)
(convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap bes) (convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap bes)
// define the record without marking, to prevent code generation for many unused generic dictionaries // define the record without marking, to prevent code generation for many unused generic dictionaries
...@@ -827,9 +824,7 @@ define_dictionary_type moduleIndex constructors selectors typeIndex ...@@ -827,9 +824,7 @@ define_dictionary_type moduleIndex constructors selectors typeIndex
= convert_dictionary_selectors moduleIndex selectors rt_fields (size class_members) constructorDef.cons_type.st_args_strictness member_defs type_var_heap bes = convert_dictionary_selectors moduleIndex selectors rt_fields (size class_members) constructorDef.cons_type.st_args_strictness member_defs type_var_heap bes
(constructorType,bes) = constructorTypeFunction constructorDef bes (constructorType,bes) = constructorTypeFunction constructorDef bes
(type_arg_p,type_var_heap,bes) = convertTypeDefAnnotatedTypeArgs constructorType.st_args constructorType.st_args_strictness type_var_heap bes (type_arg_p,type_var_heap,bes) = convertTypeDefAnnotatedTypeArgs constructorType.st_args constructorType.st_args_strictness type_var_heap bes
(symbol_p,bes) = beConstructorSymbol moduleIndex constructorIndex bes bes = appBackEnd (BEDefineRecordType symbol_p type_attribute moduleIndex constructorIndex type_arg_p (if rt_is_boxed_record 1 0) fields) bes
(constructorTypeNode,bes) = accBackEnd (BENormalTypeNode symbol_p type_arg_p) bes
bes = appBackEnd (BERecordType moduleIndex flatType constructorTypeNode (if rt_is_boxed_record 1 0) fields) bes
type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
= (type_var_heap,bes) = (type_var_heap,bes)
where where
...@@ -965,6 +960,11 @@ declareDynamicTemp predefs ...@@ -965,6 +960,11 @@ declareDynamicTemp predefs
(v2,be) = f2 be (v2,be) = f2 be
:== f v1 v2 be :== f v1 v2 be
@^&^ f f1 v2 f3 be
# (v1,be) = f1 be
(v3,be) = f3 be
:== f v1 v2 v3 be
predefineSymbols :: DclModule PredefinedSymbols -> BackEnder predefineSymbols :: DclModule PredefinedSymbols -> BackEnder
predefineSymbols {dcl_common} predefs predefineSymbols {dcl_common} predefs
= appBackEnd (BEDeclarePredefinedModule (size dcl_common.com_type_defs) (size dcl_common.com_cons_defs)) = appBackEnd (BEDeclarePredefinedModule (size dcl_common.com_type_defs) (size dcl_common.com_cons_defs))
...@@ -1037,7 +1037,6 @@ predefineSymbols {dcl_common} predefs ...@@ -1037,7 +1037,6 @@ predefineSymbols {dcl_common} predefs
constructors :: [(Int, Int, BESymbKind)] constructors :: [(Int, Int, BESymbKind)]
constructors constructors
= [(index, index-PD_Arity2TupleSymbol+2, BETupleSymb) \\ index <- [PD_Arity2TupleSymbol..PD_Arity32TupleSymbol]] = [(index, index-PD_Arity2TupleSymbol+2, BETupleSymb) \\ index <- [PD_Arity2TupleSymbol..PD_Arity32TupleSymbol]]
predefineConstructor (index, arity, symbolKind) predefineConstructor (index, arity, symbolKind)
// sanity check ... // sanity check ...
...@@ -1051,11 +1050,10 @@ predefineSymbols {dcl_common} predefs ...@@ -1051,11 +1050,10 @@ predefineSymbols {dcl_common} predefs
type_be_f = @^^ BENormalTypeNode constructor_symbol_be_f BENoTypeArgs type_be_f = @^^ BENormalTypeNode constructor_symbol_be_f BENoTypeArgs
constructors_be_f = @^^ BEConstructorList type_be_f BENoConstructors constructors_be_f = @^^ BEConstructorList type_be_f BENoConstructors
type_symbol_be_f = BETypeSymbol predefs.[PD_UnitType].pds_def cPredefinedModuleIndex type_symbol_be_f = BETypeSymbol predefs.[PD_UnitType].pds_def cPredefinedModuleIndex
flat_type_be_f = @^^ BEFlatType type_symbol_be_f (^= BENoUniAttr)
= appBackEnd = appBackEnd
( BEDeclareConstructor predefs.[PD_UnitConsSymbol].pds_def cPredefinedModuleIndex "_Unit" ( BEDeclareConstructor predefs.[PD_UnitConsSymbol].pds_def cPredefinedModuleIndex "_Unit"
o` BEDeclareType predefs.[PD_UnitType].pds_def cPredefinedModuleIndex "_Unit" o` BEDeclareType predefs.[PD_UnitType].pds_def cPredefinedModuleIndex "_Unit"
o` @^^ BEAlgebraicType flat_type_be_f constructors_be_f) o` @^&^ BEDefineAlgebraicType type_symbol_be_f BENoUniAttr constructors_be_f)
bindSpecialIdents :: PredefinedSymbols NumberSet -> BackEnder bindSpecialIdents :: PredefinedSymbols NumberSet -> BackEnder
bindSpecialIdents predefs usedModules bindSpecialIdents predefs usedModules
......
...@@ -67,10 +67,9 @@ BEDefineRuleType ...@@ -67,10 +67,9 @@ BEDefineRuleType
BEAdjustArrayFunction BEAdjustArrayFunction
BENoRules BENoRules
BERules BERules
BEFlatType BEDefineAlgebraicType
BEAlgebraicType BEDefineRecordType
BERecordType BEAbstractType
BEAbsType
BEConstructorList BEConstructorList
BENoConstructors BENoConstructors
BEDeclareField BEDeclareField
......
...@@ -984,13 +984,6 @@ BEConstructorSymbol (int constructorIndex, int moduleIndex) ...@@ -984,13 +984,6 @@ BEConstructorSymbol (int constructorIndex, int moduleIndex)
Assert ((unsigned int) constructorIndex < module->bem_nConstructors); Assert ((unsigned int) constructorIndex < module->bem_nConstructors);
constructorSymbol = module->bem_constructors [constructorIndex]; constructorSymbol = module->bem_constructors [constructorIndex];
/* RWS +++ hack for record constructors, remove this */
if (constructorSymbol->symb_kind == erroneous_symb){
/* store index in symb_arity until BERecordType is called, should be passed directly to BERecordType */
constructorSymbol->symb_arity = constructorIndex;
return constructorSymbol;
}
Assert (constructorSymbol->symb_kind == definition || constructorSymbol->symb_kind == cons_symb Assert (constructorSymbol->symb_kind == definition || constructorSymbol->symb_kind == cons_symb
|| (moduleIndex == kPredefinedModuleIndex && constructorSymbol->symb_kind != erroneous_symb)); || (moduleIndex == kPredefinedModuleIndex && constructorSymbol->symb_kind != erroneous_symb));
...@@ -1952,7 +1945,7 @@ BEUpdateNode (BEArgP args) ...@@ -1952,7 +1945,7 @@ BEUpdateNode (BEArgP args)
Assert (args->arg_next->arg_node->node_kind == SelectorNode); Assert (args->arg_next->arg_node->node_kind == SelectorNode);
Assert (args->arg_next->arg_node->node_arity == BESelector); Assert (args->arg_next->arg_node->node_arity == BESelector);
recordSymbol = args->arg_next->arg_node->node_symbol->symb_def->sdef_type->type_lhs->ft_symbol; recordSymbol = args->arg_next->arg_node->node_symbol->symb_def->sdef_type->type_symbol;
node = ConvertAllocType (NodeS); node = ConvertAllocType (NodeS);
...@@ -2552,21 +2545,8 @@ BEDeclareType (int typeIndex, int moduleIndex, CleanString name) ...@@ -2552,21 +2545,8 @@ BEDeclareType (int typeIndex, int moduleIndex, CleanString name)
types [typeIndex]->symb_def = newSymbDef; types [typeIndex]->symb_def = newSymbDef;
} /* BEDeclareType */ } /* BEDeclareType */
BEFlatTypeP
BEFlatType (BESymbolP symbol, BEAttribution attribution)
{
FlatType flatType;
flatType = ConvertAllocType (struct flat_type);
flatType->ft_symbol = symbol;
flatType->ft_attribute = (AttributeKind) attribution;;
return (flatType);
} /* BEFlatType */
void void
BEAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors) BEDefineAlgebraicType (BESymbolP symbol, BEAttribution attribution, BEConstructorListP constructors)
{ {
Types type; Types type;
SymbDefP sdef; SymbDefP sdef;
...@@ -2574,7 +2554,8 @@ BEAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors) ...@@ -2574,7 +2554,8 @@ BEAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors)
type = ConvertAllocType (struct type); type = ConvertAllocType (struct type);
type->type_lhs = lhs; type->type_symbol = symbol;
type->type_attribute = attribution;
type->type_constructors = constructors; type->type_constructors = constructors;
nConstructors = 0; nConstructors = 0;
...@@ -2594,47 +2575,53 @@ BEAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors) ...@@ -2594,47 +2575,53 @@ BEAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors)
type->type_nr_of_constructors = nConstructors; type->type_nr_of_constructors = nConstructors;
Assert (type->type_lhs->ft_symbol->symb_kind == definition); Assert (symbol->symb_kind == definition);
sdef = type->type_lhs->ft_symbol->symb_def; sdef = symbol->symb_def;
Assert (sdef->sdef_kind == NEWDEFINITION); Assert (sdef->sdef_kind == NEWDEFINITION);
sdef->sdef_kind = TYPE; sdef->sdef_kind = TYPE;
sdef->sdef_type = type; sdef->sdef_type = type;
} /* BEAlgebraicType */ }
void BEExtendableAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors) void BEDefineExtensibleAlgebraicType (BESymbolP symbol, BEAttribution attribution, BEConstructorListP constructors)
{ {
Types type; Types type;
SymbDefP sdef; SymbDefP sdef;
type = ConvertAllocType (struct type); type = ConvertAllocType (struct type);
type->type_lhs = lhs; type->type_symbol = symbol;
type->type_attribute = attribution;
type->type_constructors = constructors; type->type_constructors = constructors;
type->type_nr_of_constructors = 0; type->type_nr_of_constructors = 0;
for (; constructors!=NULL; constructors=constructors->cl_next) for (; constructors!=NULL; constructors=constructors->cl_next)
constructors->cl_constructor->type_node_symbol->symb_def->sdef_type = type; constructors->cl_constructor->type_node_symbol->symb_def->sdef_type = type;
sdef = type->type_lhs->ft_symbol->symb_def; sdef = symbol->symb_def;
sdef->sdef_kind = TYPE; sdef->sdef_kind = TYPE;
sdef->sdef_type = type; sdef->sdef_type = type;
} }
void void BEDefineRecordType
BERecordType (int moduleIndex, BEFlatTypeP lhs, BETypeNodeP constructorType, int is_boxed_record, BEFieldListP fields) (BESymbolP symbol, BEAttribution attribution, int moduleIndex, int constructorIndex, BETypeArgP constructor_args, int is_boxed_record, BEFieldListP fields)
{ {
struct symbol *constructor_symbol_p;
BETypeNodeP constructorType;
int nFields; int nFields;
Types type; Types type;
SymbDefP sdef; SymbDefP sdef;
BEConstructorListP constructor; BEConstructorListP constructor;
type = ConvertAllocType (struct type); constructor_symbol_p = gBEState.be_modules [moduleIndex].bem_constructors [constructorIndex];
constructor = ConvertAllocType (struct constructor_list); constructorType = BENormalTypeNode (constructor_symbol_p,constructor_args);
constructor = ConvertAllocType (struct constructor_list);
constructor->cl_next = NULL; constructor->cl_next = NULL;
constructor->cl_constructor = constructorType; constructor->cl_constructor = constructorType;
type->type_lhs = lhs; type = ConvertAllocType (struct type);
type->type_symbol = symbol;
type->type_attribute = attribution;
type->type_constructors = constructor; type->type_constructors = constructor;
type->type_fields = fields; type->type_fields = fields;
...@@ -2653,8 +2640,8 @@ BERecordType (int moduleIndex, BEFlatTypeP lhs, BETypeNodeP constructorType, int ...@@ -2653,8 +2640,8 @@ BERecordType (int moduleIndex, BEFlatTypeP lhs, BETypeNodeP constructorType, int
type->type_nr_of_constructors = 0; type->type_nr_of_constructors = 0;
Assert (type->type_lhs->ft_symbol->symb_kind == definition); Assert (symbol->symb_kind == definition);
sdef = type->type_lhs->ft_symbol->symb_def; sdef = symbol->symb_def;
Assert (sdef->sdef_kind == NEWDEFINITION); Assert (sdef->sdef_kind == NEWDEFINITION);
sdef->sdef_checkstatus = TypeChecked; sdef->sdef_checkstatus = TypeChecked;
sdef->sdef_kind = RECORDTYPE; sdef->sdef_kind = RECORDTYPE;
...@@ -2663,35 +2650,22 @@ BERecordType (int moduleIndex, BEFlatTypeP lhs, BETypeNodeP constructorType, int ...@@ -2663,35 +2650,22 @@ BERecordType (int moduleIndex, BEFlatTypeP lhs, BETypeNodeP constructorType, int
sdef->sdef_boxed_record = is_boxed_record; sdef->sdef_boxed_record = is_boxed_record;
{ constructor_symbol_p->symb_arity = 0;
int constructor_index;
struct symbol *constructor_symbol_p;
BEModuleP module;
constructor_symbol_p = constructorType->type_node_symbol;
/* BEConstructorSymbol has stored the index in symb_arity, should be passed directly to BERecordType */
constructor_index = constructor_symbol_p->symb_arity;
constructor_symbol_p->symb_arity = 0;
module = &gBEState.be_modules [moduleIndex]; gBEState.be_modules [moduleIndex].bem_constructors [constructorIndex] = symbol;
}
Assert (module->bem_constructors[constructor_index]==constructor_symbol_p);
module->bem_constructors[constructor_index] = type->type_lhs->ft_symbol;
}
} /* BERecordType */