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
BEAdjustArrayFunction
BENoRules
BERules
BEFlatType
BEAlgebraicType
BERecordType
BEAbsType
BEDefineAlgebraicType
BEDefineRecordType
BEAbstractType
BEConstructorList
BENoConstructors
BEDeclareField
......
......@@ -68,11 +68,10 @@ BEDefineRuleType
BEAdjustArrayFunction
BENoRules
BERules
BEFlatType
BEAlgebraicType
BEExtendableAlgebraicType
BERecordType
BEAbsType
BEDefineAlgebraicType
BEDefineExtensibleAlgebraicType
BEDefineRecordType
BEAbstractType
BEConstructorList
BENoConstructors
BEDeclareField
......
......@@ -11,7 +11,6 @@ definition module backend;
:: BEArgP (:== CPtr);
:: BERuleAltP (:== CPtr);
:: BEImpRuleP (:== CPtr);
:: BEFlatTypeP (:== CPtr);
:: BEConstructorListP (:== CPtr);
:: BEFieldListP (:== CPtr);
:: BENodeIdP (:== CPtr);
......@@ -170,16 +169,14 @@ BENoRules :: !BackEnd -> (!BEImpRuleP,!BackEnd);
// BEImpRuleP BENoRules ();
BERules :: !BEImpRuleP !BEImpRuleP !BackEnd -> (!BEImpRuleP,!BackEnd);
// BEImpRuleP BERules (BEImpRuleP rule,BEImpRuleP rules);
BEFlatType :: !BESymbolP !BEAttribution !BackEnd -> (!BEFlatTypeP,!BackEnd);
// BEFlatTypeP BEFlatType (BESymbolP symbol,BEAttribution attribution);
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;
// void BEAbsType (BEFlatTypeP lhs);
BEDefineAlgebraicType :: !BESymbolP !BEAttribution !BEConstructorListP !BackEnd -> BackEnd;
// void BEDefineAlgebraicType (BESymbolP symbol,BEAttribution attribution,BEConstructorListP constructors);
BEDefineExtensibleAlgebraicType :: !BESymbolP !BEAttribution !BEConstructorListP !BackEnd -> BackEnd;
// void BEDefineExtensibleAlgebraicType (BESymbolP symbol,BEAttribution attribution,BEConstructorListP constructors);
BEDefineRecordType :: !BESymbolP !BEAttribution !Int !Int !BETypeArgP !Int !BEFieldListP !BackEnd -> BackEnd;
// void BEDefineRecordType (BESymbolP symbol,BEAttribution attribution,int moduleIndex,int constructorIndex,BETypeArgP constructorArgs,int is_boxed_record,BEFieldListP fields);
BEAbstractType :: !BESymbolP !BackEnd -> BackEnd;
// void BEAbstractType (BESymbolP symbol);
BEConstructorList :: !BETypeNodeP !BEConstructorListP !BackEnd -> (!BEConstructorListP,!BackEnd);
// BEConstructorListP BEConstructorList (BETypeNodeP type,BEConstructorListP constructors);
BENoConstructors :: !BackEnd -> (!BEConstructorListP,!BackEnd);
......
......@@ -11,7 +11,6 @@ implementation module backend;
:: BEArgP :== CPtr;
:: BERuleAltP :== CPtr;
:: BEImpRuleP :== CPtr;
:: BEFlatTypeP :== CPtr;
:: BEConstructorListP :== CPtr;
:: BEFieldListP :== CPtr;
:: BENodeIdP :== CPtr;
......@@ -455,35 +454,29 @@ BERules a0 a1 a2 = code {
}
// BEImpRuleP BERules (BEImpRuleP rule,BEImpRuleP rules);
BEFlatType :: !BESymbolP !BEAttribution !BackEnd -> (!BEFlatTypeP,!BackEnd);
BEFlatType a0 a1 a2 = code {
ccall BEFlatType "pI:p:p"
BEDefineAlgebraicType :: !BESymbolP !BEAttribution !BEConstructorListP !BackEnd -> BackEnd;
BEDefineAlgebraicType a0 a1 a2 a3 = code {
ccall BEDefineAlgebraicType "pIp:V:p"
}
// BEFlatTypeP BEFlatType (BESymbolP symbol,BEAttribution attribution);
// void BEDefineAlgebraicType (BESymbolP symbol,BEAttribution attribution,BEConstructorListP constructors);
BEAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd;
BEAlgebraicType a0 a1 a2 = code {
ccall BEAlgebraicType "pp:V:p"
BEDefineExtensibleAlgebraicType :: !BESymbolP !BEAttribution !BEConstructorListP !BackEnd -> BackEnd;
BEDefineExtensibleAlgebraicType a0 a1 a2 a3 = code {
ccall BEDefineExtensibleAlgebraicType "pIp:V:p"
}
// void BEAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors);
// void BEDefineExtensibleAlgebraicType (BESymbolP symbol,BEAttribution attribution,BEConstructorListP constructors);
BEExtendableAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd;
BEExtendableAlgebraicType a0 a1 a2 = code {
ccall BEExtendableAlgebraicType "pp:V:p"
BEDefineRecordType :: !BESymbolP !BEAttribution !Int !Int !BETypeArgP !Int !BEFieldListP !BackEnd -> BackEnd;
BEDefineRecordType a0 a1 a2 a3 a4 a5 a6 a7 = code {
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;
BERecordType a0 a1 a2 a3 a4 a5 = code {
ccall BERecordType "IppIp:V:p"
BEAbstractType :: !BESymbolP !BackEnd -> BackEnd;
BEAbstractType a0 a1 = code {
ccall BEAbstractType "p:V:p"
}
// void BERecordType (int moduleIndex,BEFlatTypeP lhs,BETypeNodeP constructorType,int is_boxed_record,BEFieldListP fields);
BEAbsType :: !BEFlatTypeP !BackEnd -> BackEnd;
BEAbsType a0 a1 = code {
ccall BEAbsType "p:V:p"
}
// void BEAbsType (BEFlatTypeP lhs);
// void BEAbstractType (BESymbolP symbol);
BEConstructorList :: !BETypeNodeP !BEConstructorListP !BackEnd -> (!BEConstructorListP,!BackEnd);
BEConstructorList a0 a1 a2 = code {
......
......@@ -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
= (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
= 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
# (a1,bes) = type_symbol_m bes
(a2,bes) = convertAttribution attribute bes
type_var_heap = numberLhsTypeVars args 0 type_var_heap
(flat_type_p,bes) = accBackEnd (BEFlatType a1 a2) bes
= (flat_type_p,type_var_heap,bes)
= (a1,a2,type_var_heap,bes)
numberLhsTypeVars :: [ATypeVar] Int !*TypeVarHeap -> *TypeVarHeap
numberLhsTypeVars [{atv_variable={tv_info_ptr}}:x] arg_n 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 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)
= 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,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
constructorDef = constructors.[constructorIndex]
(flatType,type_var_heap,be)
(symbol_p,type_attribute,type_var_heap,be)
= if (td_fun_index<>NoIndex)
(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
......@@ -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
(constructorType,be) = constructorTypeFunction constructorDef 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
(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
be = appBackEnd (BEDefineRecordType symbol_p type_attribute moduleIndex constructorIndex type_arg_p (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,be)
where
......@@ -784,28 +783,26 @@ defineType moduleIndex constructors selectors typeIndex {td_attribute, td_args,
-> (expandedType,bes)
_
-> (constructorDef.cons_type,bes)
defineType moduleIndex _ _ typeIndex {td_attribute, td_args, td_rhs=AbstractType _} type_var_heap be
# (flatType,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be
be = appBackEnd (BEAbsType flatType) be
type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
defineType moduleIndex _ _ typeIndex {td_rhs=AbstractType _} type_var_heap be
# (symbol,be) = beTypeSymbol typeIndex moduleIndex be
be = appBackEnd (BEAbstractType symbol) be
= (type_var_heap,be)
defineType moduleIndex _ _ typeIndex {td_attribute, td_args, td_rhs=AbstractSynType _ _} type_var_heap be
# (flatType,type_var_heap,be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args type_var_heap be
be = appBackEnd (BEAbsType flatType) be
type_var_heap = remove_TVI_TypeVarArgN_in_args td_args type_var_heap
defineType moduleIndex _ _ typeIndex {td_rhs=AbstractSynType _ _} type_var_heap be
# (symbol,be) = beTypeSymbol typeIndex moduleIndex be
be = appBackEnd (BEAbstractType symbol) be
= (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)
= 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,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)
= 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,be)
defineType _ _ _ _ _ type_var_heap be
......@@ -818,7 +815,7 @@ define_dictionary_type moduleIndex constructors selectors typeIndex
{class_members} member_defs type_var_heap bes
# constructorIndex = rt_constructor.ds_index
constructorDef = constructors.[constructorIndex]
(flatType,type_var_heap,bes)
(symbol_p,type_attribute,type_var_heap,bes)
= if (td_fun_index<>NoIndex)
(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
......@@ -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
(constructorType,bes) = constructorTypeFunction constructorDef 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
(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
bes = appBackEnd (BEDefineRecordType symbol_p type_attribute moduleIndex constructorIndex type_arg_p (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,bes)
where
......@@ -965,6 +960,11 @@ declareDynamicTemp predefs
(v2,be) = f2 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 {dcl_common} predefs
= appBackEnd (BEDeclarePredefinedModule (size dcl_common.com_type_defs) (size dcl_common.com_cons_defs))
......@@ -1037,7 +1037,6 @@ predefineSymbols {dcl_common} predefs
constructors :: [(Int, Int, BESymbKind)]
constructors
= [(index, index-PD_Arity2TupleSymbol+2, BETupleSymb) \\ index <- [PD_Arity2TupleSymbol..PD_Arity32TupleSymbol]]
predefineConstructor (index, arity, symbolKind)
// sanity check ...
......@@ -1051,11 +1050,10 @@ predefineSymbols {dcl_common} predefs
type_be_f = @^^ BENormalTypeNode constructor_symbol_be_f BENoTypeArgs
constructors_be_f = @^^ BEConstructorList type_be_f BENoConstructors
type_symbol_be_f = BETypeSymbol predefs.[PD_UnitType].pds_def cPredefinedModuleIndex
flat_type_be_f = @^^ BEFlatType type_symbol_be_f (^= BENoUniAttr)
= appBackEnd
( BEDeclareConstructor predefs.[PD_UnitConsSymbol].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 predefs usedModules
......
......@@ -67,10 +67,9 @@ BEDefineRuleType
BEAdjustArrayFunction
BENoRules
BERules
BEFlatType
BEAlgebraicType
BERecordType
BEAbsType
BEDefineAlgebraicType
BEDefineRecordType
BEAbstractType
BEConstructorList
BENoConstructors
BEDeclareField
......
......@@ -984,13 +984,6 @@ BEConstructorSymbol (int constructorIndex, int moduleIndex)
Assert ((unsigned int) constructorIndex < module->bem_nConstructors);
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
|| (moduleIndex == kPredefinedModuleIndex && constructorSymbol->symb_kind != erroneous_symb));
......@@ -1952,7 +1945,7 @@ BEUpdateNode (BEArgP args)
Assert (args->arg_next->arg_node->node_kind == SelectorNode);
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);
......@@ -2552,21 +2545,8 @@ BEDeclareType (int typeIndex, int moduleIndex, CleanString name)
types [typeIndex]->symb_def = newSymbDef;
} /* 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
BEAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors)
BEDefineAlgebraicType (BESymbolP symbol, BEAttribution attribution, BEConstructorListP constructors)
{
Types type;
SymbDefP sdef;
......@@ -2574,7 +2554,8 @@ BEAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors)
type = ConvertAllocType (struct type);
type->type_lhs = lhs;
type->type_symbol = symbol;
type->type_attribute = attribution;
type->type_constructors = constructors;
nConstructors = 0;
......@@ -2594,47 +2575,53 @@ BEAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors)
type->type_nr_of_constructors = nConstructors;
Assert (type->type_lhs->ft_symbol->symb_kind == definition);
sdef = type->type_lhs->ft_symbol->symb_def;
Assert (symbol->symb_kind == definition);
sdef = symbol->symb_def;
Assert (sdef->sdef_kind == NEWDEFINITION);
sdef->sdef_kind = TYPE;
sdef->sdef_type = type;
} /* BEAlgebraicType */
}
void BEExtendableAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors)
void BEDefineExtensibleAlgebraicType (BESymbolP symbol, BEAttribution attribution, BEConstructorListP constructors)
{
Types type;
SymbDefP sdef;
type = ConvertAllocType (struct type);
type->type_lhs = lhs;
type->type_symbol = symbol;
type->type_attribute = attribution;
type->type_constructors = constructors;
type->type_nr_of_constructors = 0;
for (; constructors!=NULL; constructors=constructors->cl_next)
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_type = type;
}
void
BERecordType (int moduleIndex, BEFlatTypeP lhs, BETypeNodeP constructorType, int is_boxed_record, BEFieldListP fields)
void BEDefineRecordType
(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;
Types type;
SymbDefP sdef;
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_constructor = constructorType;
type->type_lhs = lhs;
type = ConvertAllocType (struct type);
type->type_symbol = symbol;
type->type_attribute = attribution;
type->type_constructors = constructor;
type->type_fields = fields;
......@@ -2653,8 +2640,8 @@ BERecordType (int moduleIndex, BEFlatTypeP lhs, BETypeNodeP constructorType, int
type->type_nr_of_constructors = 0;
Assert (type->type_lhs->ft_symbol->symb_kind == definition);
sdef = type->type_lhs->ft_symbol->symb_def;
Assert (symbol->symb_kind == definition);
sdef = symbol->symb_def;
Assert (sdef->sdef_kind == NEWDEFINITION);
sdef->sdef_checkstatus = TypeChecked;
sdef->sdef_kind = RECORDTYPE;
......@@ -2663,35 +2650,22 @@ BERecordType (int moduleIndex, BEFlatTypeP lhs, BETypeNodeP constructorType, int
sdef->sdef_boxed_record = is_boxed_record;
{
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;
constructor_symbol_p->symb_arity = 0;
module = &gBEState.be_modules [moduleIndex];
Assert (module->bem_constructors[constructor_index]==constructor_symbol_p);
module->bem_constructors[constructor_index] = type->type_lhs->ft_symbol;
}
} /* BERecordType */
gBEState.be_modules [moduleIndex].bem_constructors [constructorIndex] = symbol;
}
void
BEAbsType (BEFlatTypeP lhs)
BEAbstractType (BESymbolP symbol_p)
{
SymbDefP sdef;
SymbDefP sdef;
Assert (lhs->ft_symbol->symb_kind == definition);
sdef = lhs->ft_symbol->symb_def;
Assert (symbol_p->symb_kind == definition);
sdef = symbol_p->symb_def;
Assert (sdef->sdef_kind == NEWDEFINITION);
sdef->sdef_checkstatus = TypeChecked;
sdef->sdef_kind = ABSTYPE;
} /* BEAbsType */
}
BEConstructorListP
BENoConstructors (void)
......
......@@ -54,9 +54,6 @@ Clean (:: BERuleAltP (:== CPtr))
typedef struct imp_rule *BEImpRuleP;
Clean (:: BEImpRuleP (:== CPtr))
typedef struct flat_type *BEFlatTypeP;
Clean (:: BEFlatTypeP (:== CPtr))
typedef struct constructor_list *BEConstructorListP;
Clean (:: BEConstructorListP (:== CPtr))
......@@ -376,20 +373,17 @@ Clean (BENoRules :: BackEnd -> (BEImpRuleP, BackEnd))
BEImpRuleP BERules (BEImpRuleP rule, BEImpRuleP rules);
Clean (BERules :: BEImpRuleP BEImpRuleP BackEnd -> (BEImpRuleP, BackEnd))
BEFlatTypeP BEFlatType (BESymbolP symbol, BEAttribution attribution);
Clean (BEFlatType :: BESymbolP BEAttribution BackEnd -> (BEFlatTypeP, BackEnd))
void BEAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors);
Clean (BEAlgebraicType:: BEFlatTypeP BEConstructorListP BackEnd -> BackEnd)
void BEDefineAlgebraicType (BESymbolP symbol, BEAttribution attribution, BEConstructorListP constructors);
Clean (BEDefineAlgebraicType:: BESymbolP BEAttribution BEConstructorListP BackEnd -> BackEnd)
void BEExtendableAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors);
Clean (BEExtendableAlgebraicType:: BEFlatTypeP BEConstructorListP BackEnd -> BackEnd)
void BEDefineExtensibleAlgebraicType (BESymbolP symbol, BEAttribution attribution, BEConstructorListP constructors);
Clean (BEDefineExtensibleAlgebraicType:: BESymbolP BEAttribution BEConstructorListP BackEnd -> BackEnd)
void BERecordType (int moduleIndex, BEFlatTypeP lhs, BETypeNodeP constructorType, int is_boxed_record, BEFieldListP fields);
Clean (BERecordType :: Int BEFlatTypeP BETypeNodeP Int BEFieldListP BackEnd -> BackEnd)
void BEDefineRecordType (BESymbolP symbol, BEAttribution attribution, int moduleIndex, int constructorIndex, BETypeArgP constructor_args, int is_boxed_record, BEFieldListP fields);
Clean (BEDefineRecordType :: BESymbolP BEAttribution Int Int BETypeArgP Int BEFieldListP BackEnd -> BackEnd)
void BEAbsType (BEFlatTypeP lhs);
Clean (BEAbsType :: BEFlatTypeP BackEnd -> BackEnd)
void BEAbstractType (BESymbolP symbol);
Clean (BEAbstractType :: BESymbolP BackEnd -> BackEnd)
BEConstructorListP BENoConstructors (void);
Clean (BENoConstructors:: BackEnd -> (BEConstructorListP, BackEnd))
......
......@@ -996,7 +996,7 @@ static void GenLazyFieldSelectorEntry (SymbDef field_def,StateS recstate,int tot
update_root_node = ! ExpectsResultNode (offfieldstate);
record_name=field_def->sdef_type->type_lhs->ft_symbol->symb_def->sdef_ident->ident_name;
record_name=field_def->sdef_type->type_symbol->symb_def->sdef_ident->ident_name;
if (field_def->sdef_calledwithrootnode){
ealab = CurrentAltLabel;
......@@ -2782,7 +2782,7 @@ SymbDef create_select_function (Symbol selector_symbol,int selector_kind)
select_function_symbol=NewSymbol (definition);
select_function_symbol->symb_def=select_function_sdef;
record_state_p=&selector_sdef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_record_state;
record_state_p=&selector_sdef->sdef_type->type_symbol->symb_def->sdef_record_state;
fieldnr = selector_sdef->sdef_sel_field_number;
record_node_id=NewNodeId (NULL);
......
......@@ -977,7 +977,7 @@ void BuildOrFillLazyFieldSelector (SymbDef selector_sdef,StateKind result_state_
ConvertSymbolToDandNLabel (&dsellab,&nsellab,selector_sdef);
record_sdef=selector_sdef->sdef_type->type_lhs->ft_symbol->symb_def;
record_sdef=selector_sdef->sdef_type->type_symbol->symb_def;
record_name=record_sdef->sdef_ident->ident_name;
field_result_state_p=&record_sdef->sdef_record_state.state_record_arguments [selector_sdef->sdef_sel_field_number];
......@@ -1251,7 +1251,7 @@ static struct state *FillOrReduceFieldSelection_of_selection_in_single_field_unb
SymbDef record_sdef;
StateP record_state_p;
record_sdef=seldef->sdef_type->type_lhs->ft_symbol->symb_def;
record_sdef=seldef->sdef_type->type_symbol->symb_def;
record_state_p=&record_sdef->sdef_record_state;
if (record_state_p->state_type==RecordState && record_state_p->state_arity==1 && !record_sdef->sdef_boxed_record){
int asize,bsize;
......@@ -1283,7 +1283,7 @@ static struct state *FillOrReduceFieldSelection_of_selection_in_single_field_unb
int asize,bsize,apos,bpos,tot_asize,tot_bsize;
StateP record_state_p;
record_state_p=&seldef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_record_state;
record_state_p=&seldef->sdef_type->type_symbol->symb_def->sdef_record_state;
if (record_state_p->state_type!=RecordState)
error_in_function ("FillOrReduceFieldSelection_of_selection_in_single_field_unboxable_record");
......@@ -1303,7 +1303,7 @@ static struct state *FillOrReduceFieldSelection_of_selection_in_single_field_unb
int asize,bsize,apos,bpos,tot_asize,tot_bsize;
StateP record_state_p;
record_state_p=&seldef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_record_state;
record_state_p=&seldef->sdef_type->type_symbol->symb_def->sdef_record_state;
Build (arg_node,asp_p,bsp_p,code_gen_node_ids_p);
......@@ -1353,7 +1353,7 @@ static struct state *FillOrReduceFieldSelection_of_selection_in_single_field_unb
StateP record_state_p;
recindex = arg_node_id->nid_a_index;
record_sdef=seldef->sdef_type->type_lhs->ft_symbol->symb_def;
record_sdef=seldef->sdef_type->type_symbol->symb_def;
record_state_p=&record_sdef->sdef_record_state;
if (record_state_p->state_type!=RecordState)
......@@ -1412,7 +1412,7 @@ static struct state *FillOrReduceFieldSelection_of_selection_in_single_field_unb
recstate.state_kind = StrictOnA;
}
record_sdef=seldef->sdef_type->type_lhs->ft_symbol->symb_def;
record_sdef=seldef->sdef_type->type_symbol->symb_def;
DetermineFieldSizeAndPositionAndRecordSize (fieldnr,&a_size,&b_size,&apos, &bpos,&tot_asize,&tot_bsize,&record_sdef->sdef_record_state);
# if BOXED_RECORDS
if (record_sdef->sdef_boxed_record && (arg_node_id->nid_mark2 & (NID_RECORD_USED_BY_UPDATE | NID_RECORD_USED_BY_NON_SELECTOR_OR_UPDATES))==NID_RECORD_USED_BY_UPDATE
......@@ -1486,7 +1486,7 @@ static void FillOrReduceFieldSelection (Node node,SymbDef seldef,int *asp_p,int
BuildArg (arg,asp_p,bsp_p,code_gen_node_ids_p);
record_state_p=&seldef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_record_state;
record_state_p=&seldef->sdef_type->type_symbol->symb_def->sdef_record_state;
#if BOXED_RECORDS
if (node->node_arity<SELECTOR_L ?
arg->arg_state.state_type==SimpleState :
......@@ -1526,7 +1526,7 @@ static void FillOrReduceFieldSelection (Node node,SymbDef seldef,int *asp_p,int
arg_node_id=arg_node->node_node_id;
record_state_p=&seldef->sdef_type->type_lhs->ft_symbol->symb_def->sdef_record_state;
record_state_p=&seldef->sdef_type->type_symbol->symb_def->sdef_record_state;
tuple_state.state_type=TupleState;
tuple_state.state_arity=2;
......@@ -1575,7 +1575,7 @@ static void FillOrReduceFieldSelection (Node node,SymbDef seldef,int *asp_p,int
SymbDef record_sdef;
StateP record_state_p;
record_sdef=seldef->sdef_type->type_lhs->ft_symbol->symb_def;
record_sdef=seldef->sdef_type->type_symbol->symb_def;
record_state_p=&record_sdef->sdef_record_state;
if (record_state_p->state_type==RecordState && record_state_p->state_arity==1 && !record_sdef->sdef_boxed_record){
int asize,bsize;
......@@ -1613,7 +1613,7 @@ static void FillOrReduceFieldSelection (Node node,SymbDef seldef,int *asp_p,int