From 8f235418ef16fc1341fef9698688c3fdee20b79f Mon Sep 17 00:00:00 2001
From: johnvg
Date: Tue, 14 Aug 2012 10:03:06 +0000
Subject: 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
---
 frontend/parse.icl | 35 +++++++++++++++++++++++++++++++----
 1 file changed, 31 insertions(+), 4 deletions(-)

(limited to 'frontend/parse.icl')

diff --git a/frontend/parse.icl b/frontend/parse.icl
index 721a66a..c97e7c3 100644
--- a/frontend/parse.icl
+++ b/frontend/parse.icl
@@ -1806,8 +1806,8 @@ where
   					-> want_record_type_rhs name True exi_vars pState
 	 		  		->	(PD_Type td, parseError "Record type" No ("after ! in definition of record type "+name+" { ") pState)
 			_
-				# (condefs, pState)	= want_constructor_list exi_vars token pState
-				# td = {td & td_rhs = ConsList condefs}
+				# (condefs, extendable_algebraic_type, pState) = want_constructor_list exi_vars token pState
+				# td & td_rhs = if extendable_algebraic_type (ExtendableConses condefs) (ConsList condefs)
 				| annot == AN_None
 	 		  		->	(PD_Type td, pState)
 					->	(PD_Type td, parseError "Algebraic type" No ("No lhs strictness annotation for the algebraic type "+name) pState)
@@ -1851,6 +1851,20 @@ where
 			= (PD_Type td, 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
+		# name					= td_ident.id_name
+		  pState				= verify_annot_attr annot td_attribute name pState
+		  (exi_vars, pState)	= optionalExistentialQuantifiedVariables pState
+		  (token, pState)		= nextToken GeneralContext pState // should be TypeContext
+		  (condefs, pState)		= want_more_constructors exi_vars token pState
+		  (file_name, pState) = getFilename pState
+		  module_name = file_name % (0,size file_name-4)
+		  (type_ext_ident, pState) = stringToIdent name (IC_TypeExtension module_name) pState
+		  td & td_rhs			= MoreConses type_ext_ident condefs
+		| annot == AN_None
+	 		= (PD_Type td, pState)
+	 		= (PD_Type td, parseError "Algebraic type" No ("No lhs strictness annotation for the algebraic type "+name) pState)
+
 	want_type_rhs token parseContext td=:{td_attribute} annot pState
 		| isIclContext parseContext
 			= (PD_Erroneous, parseError "type RHS" (Yes token) "type definition" pState)
@@ -1879,14 +1893,27 @@ where
 			= (TA_None, cAllBitsClear)
 			= (attr, cIsNonCoercible)
 
-	want_constructor_list :: ![ATypeVar] !Token !ParseState -> (.[ParsedConstructor],ParseState)
+	want_constructor_list :: ![ATypeVar] !Token !ParseState -> (![ParsedConstructor],!Bool,!ParseState)
+	want_constructor_list exi_vars DotDotToken pState
+		= ([], True, pState)
 	want_constructor_list exi_vars token pState
 		# (cons,pState) = want_constructor exi_vars token pState
 		  (token, pState) = nextToken TypeContext pState
 		| token == BarToken
 			# (exi_vars, pState) = optionalExistentialQuantifiedVariables pState
 			  (token, pState) = nextToken GeneralContext pState
-			  (cons_list, pState) = want_constructor_list exi_vars token pState
+			  (cons_list, extendable_algebraic_type, pState) = want_constructor_list exi_vars token pState
+			= ([cons : cons_list], extendable_algebraic_type, pState)
+			= ([cons], False, tokenBack pState)
+
+	want_more_constructors :: ![ATypeVar] !Token !ParseState -> (![ParsedConstructor],!ParseState)
+	want_more_constructors exi_vars token pState
+		# (cons,pState) = want_constructor exi_vars token pState
+		  (token, pState) = nextToken TypeContext pState
+		| token == BarToken
+			# (exi_vars, pState) = optionalExistentialQuantifiedVariables pState
+			  (token, pState) = nextToken GeneralContext pState
+			  (cons_list, pState) = want_more_constructors exi_vars token pState
 			= ([cons : cons_list], pState)
 			= ([cons], tokenBack pState)
 
-- 
cgit v1.2.3