add extendable algebraic data types (merged from iTask branch)

git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@2149 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d

4 files changed, 20 insertions, 5 deletions

diff --git a/backend/Windows/Clean System Files/backend_library b/backend/Windows/Clean System Files/backend_library
index 9e7fbc5..04493a1 100644
--- a/backend/Windows/Clean System Files/backend_library
+++ b/backend/Windows/Clean System Files/backend_library
@@ -85,6 +85,7 @@ BETypes
 BENoTypes
 BEFlatType
 BEAlgebraicType
+BEExtendableAlgebraicType
 BERecordType
 BEAbsType
 BEConstructors
diff --git a/backend/backend.dcl b/backend/backend.dcl
index cfc7b1b..d9f959f 100644
--- a/backend/backend.dcl
+++ b/backend/backend.dcl
@@ -205,6 +205,8 @@ BEFlatType :: !BESymbolP !BEAttribution !BETypeVarListP !BackEnd -> (!BEFlatType
 // BEFlatTypeP BEFlatType (BESymbolP symbol,BEAttribution attribution,BETypeVarListP arguments);
 BEAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd;
 // void BEAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors);
+BEExtendableAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd;
+// void BEExtendableAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors);
 BERecordType :: !Int !BEFlatTypeP !BETypeNodeP !Int !BEFieldListP !BackEnd -> BackEnd;
 // void BERecordType (int moduleIndex,BEFlatTypeP lhs,BETypeNodeP constructorType,int is_boxed_record,BEFieldListP fields);
 BEAbsType :: !BEFlatTypeP !BackEnd -> BackEnd;
diff --git a/backend/backend.icl b/backend/backend.icl
index ef0fe09..6161bcb 100644
--- a/backend/backend.icl
+++ b/backend/backend.icl
@@ -550,6 +550,12 @@ BEAlgebraicType a0 a1 a2 = code {
 }
 // void BEAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors);
 
+BEExtendableAlgebraicType :: !BEFlatTypeP !BEConstructorListP !BackEnd -> BackEnd;
+BEExtendableAlgebraicType a0 a1 a2 = code {
+	ccall BEExtendableAlgebraicType "pp:V:p"
+}
+// void BEExtendableAlgebraicType (BEFlatTypeP lhs,BEConstructorListP constructors);
+
 BERecordType :: !Int !BEFlatTypeP !BETypeNodeP !Int !BEFieldListP !BackEnd -> BackEnd;
 BERecordType a0 a1 a2 a3 a4 a5 = code {
 	ccall BERecordType "IppIp:V:p"
diff --git a/backend/backendconvert.icl b/backend/backendconvert.icl
index 6ea31f1..aea02aa 100644
--- a/backend/backendconvert.icl
+++ b/backend/backendconvert.icl
@@ -819,11 +819,9 @@ convertTypeVar typeVar
 
 defineType :: ModuleIndex {#ConsDef} {#SelectorDef} Index CheckedTypeDef *BackEndState -> *BackEndState
 defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=AlgType constructorSymbols} be
-	# (flatType, be)
-		=	convertTypeLhs moduleIndex typeIndex td_attribute td_args be
-	# (constructors, be)
-		=	convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols be
-	=	appBackEnd (BEAlgebraicType flatType constructors) be
+	# (flatType, be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args be
+	# (constructors, be) = convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols be
+	= appBackEnd (BEAlgebraicType flatType constructors) be
 defineType moduleIndex constructors selectors typeIndex {td_attribute, td_args, td_rhs=RecordType {rt_constructor, rt_fields, rt_is_boxed_record}, td_fun_index} be
 	# constructorIndex = rt_constructor.ds_index
 	  constructorDef = constructors.[constructorIndex]
@@ -854,6 +852,14 @@ defineType moduleIndex _ _ typeIndex {td_attribute, td_args, td_rhs=AbstractType
  	=	beAbsType (convertTypeLhs moduleIndex typeIndex td_attribute td_args) be
 defineType moduleIndex _ _ typeIndex {td_attribute, td_args, td_rhs=AbstractSynType _ _} be
  	=	beAbsType (convertTypeLhs moduleIndex typeIndex td_attribute td_args) be
+defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=ExtendableAlgType constructorSymbols} be
+	# (flatType, be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args be
+	# (constructors, be) = convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols be
+	= appBackEnd (BEExtendableAlgebraicType flatType constructors) be
+defineType moduleIndex constructors _ typeIndex {td_ident, td_attribute, td_args, td_rhs=AlgConses constructorSymbols _} be
+	# (flatType, be) = convertTypeLhs moduleIndex typeIndex td_attribute td_args be
+	# (constructors, be) = convertConstructors typeIndex td_ident.id_name moduleIndex constructors constructorSymbols be
+	= appBackEnd (BEExtendableAlgebraicType flatType constructors) be
 defineType _ _ _ _ _ be
 	=	be