in derived dynamic types, add uniqueness to algebraic types that are always unique

(the type definition has a * on the left),
add Bool to GTT_Constructor to indicate uniqueness,
generate TCE_UnqType in TypeCode for unique GTT_Constructor's,
this uniqueness property should be propagated, but this is not implemented yet



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

4 files changed, 23 insertions, 7 deletions

diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl
index 26ab7fc..2ce916e 100644
--- a/frontend/convertDynamics.icl
+++ b/frontend/convertDynamics.icl
@@ -560,7 +560,7 @@ where
 					-> type_code_constructor_expression PD_TC__StrictArray ci
 				PD_UnboxedArrayType
 					-> type_code_constructor_expression PD_TC__UnboxedArray ci
-	typeConstructor (GTT_Constructor fun_ident) ci
+	typeConstructor (GTT_Constructor fun_ident _) ci
 		# type_fun
 			=	App {app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr}
 		= (App {app_symb = cinp_dynamic_representation.dr_type_code_constructor_symb_ident, app_args = [type_fun], app_info_ptr = nilPtr}, ci)
diff --git a/frontend/overloading.icl b/frontend/overloading.icl
index a4e42e8..d501d40 100644
--- a/frontend/overloading.icl
+++ b/frontend/overloading.icl
@@ -32,7 +32,7 @@ import genericsupport, type_io_common
 						| CA_Context !TypeContext
 						| CA_LocalTypeCode !VarInfoPtr			/* for (local) type pattern variables */
 						| CA_GlobalTypeCode !TypeCodeInstance	/* for (global) type constructors */
-		
+
 instanceError symbol types err
 	# err = errorHeading "Overloading error" err
 	  format = { form_properties = cNoProperties, form_attr_position = No }
@@ -1004,7 +1004,12 @@ where
 				({ heaps & hp_type_heaps = hp_type_heaps }, ptrs))
 	adjust_member_application defs contexts  _ (CA_GlobalTypeCode {tci_constructor,tci_contexts}) _ heaps_and_ptrs
 		# (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs
-		= (EI_TypeCode (TCE_Constructor tci_constructor (expressionsToTypeCodeExpressions exprs)), heaps_and_ptrs)
+		  typeCodeExpressions = expressionsToTypeCodeExpressions exprs
+		= case tci_constructor of
+			GTT_Constructor _ True
+				-> (EI_TypeCode (TCE_UnqType (TCE_Constructor tci_constructor typeCodeExpressions)), heaps_and_ptrs)
+			_
+				-> (EI_TypeCode (TCE_Constructor tci_constructor typeCodeExpressions), heaps_and_ptrs)
 	adjust_member_application defs contexts _ (CA_LocalTypeCode new_var_ptr) _  heaps_and_ptrs
 		= (EI_TypeCode (TCE_Var new_var_ptr), heaps_and_ptrs)
 
@@ -1117,7 +1122,12 @@ where
 		= (TypeCodeExpression (TCE_Var new_var_ptr), heaps_and_ptrs)
 	convert_class_appl_to_expression defs contexts (CA_GlobalTypeCode {tci_constructor,tci_contexts}) heaps_and_ptrs
 		# (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs
-		= (TypeCodeExpression (TCE_Constructor tci_constructor (expressionsToTypeCodeExpressions exprs)), heaps_and_ptrs)
+		  typeCodeExpressions = expressionsToTypeCodeExpressions exprs
+		= case tci_constructor of
+			GTT_Constructor _ True
+				-> (TypeCodeExpression (TCE_UnqType (TCE_Constructor tci_constructor typeCodeExpressions)), heaps_and_ptrs)
+			_
+				-> (TypeCodeExpression (TCE_Constructor tci_constructor typeCodeExpressions), heaps_and_ptrs)
 
 	convert_reduced_contexts_to_expression defs contexts {rcs_class_context,rcs_constraints_contexts} heaps_and_ptrs
 		# (rcs_exprs, heaps_and_ptrs) = mapSt (convert_class_appl_to_expression defs contexts) rcs_constraints_contexts heaps_and_ptrs
@@ -1493,7 +1503,11 @@ toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} c
 			=	{	symb_ident = {id_name = "TD;"+++type.td_ident.id_name, id_info = nilPtr}
 				,	symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index}
 				}
-		= GTT_Constructor type_fun
+		# is_unique_type
+			= case type.td_attribute of
+				TA_Unique -> True
+				_ -> False
+		= GTT_Constructor type_fun is_unique_type
 
 fatal :: {#Char} {#Char} -> .a
 fatal function_name message
@@ -1511,7 +1525,7 @@ instance toTypeCodeExpression Type where
 			=	toTypeCodeExpression type (tci,var_heap,error)
 		# type_constructor = toTypeCodeConstructor type_index tci_common_defs
 		  (type_code_args, tci)
-		  	=	mapSt (toTypeCodeExpression) type_args (tci,var_heap,error)
+		  	=	mapSt toTypeCodeExpression type_args (tci,var_heap,error)
 		= (TCE_Constructor type_constructor type_code_args, tci)
 	toTypeCodeExpression (TAS cons_id type_args _) state
 		=	toTypeCodeExpression (TA cons_id type_args) state
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index d2a47c7..fd7ce17 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -1476,7 +1476,7 @@ instance == OverloadedListType
 
 ::	GlobalTCType
 	=	GTT_Basic !BasicType
-	|	GTT_Constructor !SymbIdent
+	|	GTT_Constructor !SymbIdent !Bool/*is unique type*/
 	|	GTT_PredefTypeConstructor !(Global Index)
 	|	GTT_Function
 
diff --git a/frontend/syntax.icl b/frontend/syntax.icl
index 8d429c3..da5445c 100644
--- a/frontend/syntax.icl
+++ b/frontend/syntax.icl
@@ -448,6 +448,8 @@ where
 		= file <<< "TCE_Selector " <<< selectors <<< "VAR " <<< info_ptr
 	(<<<) file (TCE_UniType vars type_code)
 		= file <<< "TCE_UniType " <<< vars <<< " " <<< type_code
+	(<<<) file (TCE_UnqType type_code)
+		= file <<< "TCE_UnqType " <<< type_code
 
 instance <<< (Ptr a)
 where