mark polymorphic instances of Array, UList and UTSList with SP_GenerateRecordInstances

frontend/check.icl

@@ -3391,16 +3391,10 @@ checkInstancesOfDclModule mod_index	(nr_of_dcl_functions_and_instances, nr_of_dc
 	  			 ++ reverse rev_special_defs
 	  			 ++ gen_funs
 	  			)
-  	  			
-	#  cs = { cs & cs_predef_symbols=cs_predef_symbols,cs_error = cs_error}
-	#! mod_index_of_std_array = cs.cs_predef_symbols.[PD_StdArray].pds_def
+
+	# cs & cs_predef_symbols=cs_predef_symbols, cs_error=cs_error
 	# (com_member_defs, com_instance_defs, dcl_functions, cs)
-	  		= case mod_index_of_std_array==mod_index of
-				False
-					-> (com_member_defs, com_instance_defs, dcl_functions, cs)
-				True
-					-> adjust_instance_types_of_array_functions_in_std_array_dcl mod_index
-							com_member_defs com_instance_defs dcl_functions cs
+		= adjust_instance_types_of_std_array_and_std_list_functions mod_index com_member_defs com_instance_defs dcl_functions cs
 	#! dcl_mod = {dcl_mod & dcl_functions = dcl_functions,
 			  				dcl_specials = { ir_from = nr_of_dcl_functions_and_instances,
 			  								ir_to = nr_of_dcl_funs_insts_and_specs },
@@ -3414,22 +3408,32 @@ checkInstancesOfDclModule mod_index	(nr_of_dcl_functions_and_instances, nr_of_dc
 	   dcl_modules = { dcl_modules & [mod_index] = dcl_mod }
 	= (dcl_modules, heaps, cs)
   where
-	adjust_instance_types_of_array_functions_in_std_array_dcl array_mod_index class_members class_instances fun_types cs=:{cs_predef_symbols}
-		#! nr_of_instances = size class_instances
-		# ({pds_def}, cs_predef_symbols) = cs_predef_symbols![PD_ArrayClass]
-		  (offset_table, class_members, cs_predef_symbols) = arrayFunOffsetToPD_IndexTable class_members cs_predef_symbols
-		  (class_instances, fun_types, cs_predef_symbols) 
-				= iFoldSt (adjust_instance_types_of_array_functions array_mod_index pds_def offset_table) 0 nr_of_instances
-						(class_instances, fun_types, cs_predef_symbols)
-		= (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols })
+	adjust_instance_types_of_std_array_and_std_list_functions mod_index class_members class_instances fun_types cs=:{cs_predef_symbols}
+		| mod_index == cs_predef_symbols.[PD_StdArray].pds_def
+			#! nr_of_instances = size class_instances
+			# ({pds_def}, cs_predef_symbols) = cs_predef_symbols![PD_ArrayClass]
+			  (offset_table, class_members, cs_predef_symbols) = arrayFunOffsetToPD_IndexTable class_members cs_predef_symbols
+			  (class_instances, fun_types, cs_predef_symbols) 
+					= iFoldSt (adjust_instance_types_of_array_functions mod_index pds_def offset_table) 0 nr_of_instances
+							(class_instances, fun_types, cs_predef_symbols)
+			= (class_members, class_instances, fun_types, {cs & cs_predef_symbols = cs_predef_symbols})
+		| mod_index == cs_predef_symbols.[PD_StdStrictLists].pds_def
+			#! n_of_instances = size class_instances
+			# (class_instances, cs_predef_symbols)
+				= iFoldSt (adjust_instances_of__SystemStrictLists_module mod_index) 0 n_of_instances (class_instances, cs_predef_symbols)
+			= (class_members, class_instances, fun_types, {cs & cs_predef_symbols = cs_predef_symbols})
+			= (class_members, class_instances, fun_types, cs)
 	where
-		adjust_instance_types_of_array_functions :: .Index !Index !{#.Index} !Int !*(!u:{# ClassInstance},!*{# FunType},!v:{#PredefinedSymbol})
-			 -> (!u:{# ClassInstance},!*{# FunType},!v:{#PredefinedSymbol})
+		adjust_instance_types_of_array_functions :: Index !Index !{#Index} !Int !*(!*{#ClassInstance},!*{#FunType},!v:{#PredefinedSymbol})
+																			   -> (!*{#ClassInstance},!*{#FunType},!v:{#PredefinedSymbol})
 		adjust_instance_types_of_array_functions array_mod_index array_class_index offset_table inst_index (class_instances, fun_types, predef_symbols)
 			# ({ins_class_index={gi_module,gi_index},ins_type,ins_members}, class_instances) = class_instances![inst_index]
 			| gi_module == array_mod_index && gi_index == array_class_index && elemTypeIsStrict ins_type.it_types predef_symbols
 				# fun_types = iFoldSt (make_instance_strict ins_members offset_table) 0 (size ins_members) fun_types
-				= (class_instances, fun_types, predef_symbols)
+				| is_polymorphic_unboxed_array_instance_type ins_type.it_types predef_symbols
+					# class_instances & [inst_index].ins_specials = SP_GenerateRecordInstances
+					= (class_instances, fun_types, predef_symbols)
+					= (class_instances, fun_types, predef_symbols)
 				= (class_instances, fun_types, predef_symbols)
 
 		make_instance_strict :: !{#ClassInstanceMember} !{#Index} !Int !*{# FunType} -> *{# FunType}
@@ -3439,6 +3443,25 @@ checkInstancesOfDclModule mod_index	(nr_of_dcl_functions_and_instances, nr_of_dc
 			  (Yes symbol_type) = inst_def.ft_type
 			= {instance_defs & [cim_index] = {inst_def & ft_type = makeElemTypeOfArrayFunctionStrict inst_def.ft_type ins_offset offset_table}}
 
+		is_polymorphic_unboxed_array_instance_type [TA {type_index={glob_object,glob_module}} _, TV _ : _] predef_symbols
+			= glob_module == predef_symbols.[PD_PredefinedModule].pds_def && glob_object == predef_symbols.[PD_UnboxedArrayType].pds_def
+		is_polymorphic_unboxed_array_instance_type _ _
+			= False
+
+		adjust_instances_of__SystemStrictLists_module :: !Index !Int !*(!*{#ClassInstance},!v:{#PredefinedSymbol})
+																	-> (!*{#ClassInstance},!v:{#PredefinedSymbol})
+		adjust_instances_of__SystemStrictLists_module strict_lists_mod_index inst_index (class_instances, predef_symbols)
+			# ({ins_class_index={gi_module,gi_index},ins_type={it_types}}, class_instances) = class_instances![inst_index]
+			| gi_module==strict_lists_mod_index
+				&& (gi_index==predef_symbols.[PD_UListClass].pds_def || gi_index==predef_symbols.[PD_UTSListClass].pds_def)
+				= case it_types of
+					[TV _]
+						# class_instances & [inst_index].ins_specials = SP_GenerateRecordInstances
+						-> (class_instances, predef_symbols)
+					_
+						-> (class_instances, predef_symbols)
+				= (class_instances, predef_symbols)
+
 checkPredefinedDclModule :: !NumberSet ![Int] !(IntKeyHashtable SolvedImports) !Int !Bool !LargeBitvect !Bool
 							!(Module (CollectedDefinitions ClassInstance)) !Index !*ExplImpInfos !*{#DclModule} !*{#*{#FunDef}} !*Heaps !*CheckState
 												 -> (!(!Int,!Index,![FunType]), !(!*ExplImpInfos,!*{#DclModule},!*{#*{#FunDef}},!*Heaps,!*CheckState))

frontend/checktypes.icl

@@ -1464,6 +1464,8 @@ checkSpecialTypeVars (SP_ParsedSubstitutions env) cs
 	= (SP_ParsedSubstitutions env, cs)
 checkSpecialTypeVars SP_None cs
 	= (SP_None, cs)
+checkSpecialTypeVars SP_GenerateRecordInstances cs
+	= (SP_GenerateRecordInstances, cs)
 
 checkFunSpecialTypeVars :: !FunSpecials !*CheckState -> (!FunSpecials, !*CheckState)
 checkFunSpecialTypeVars (FSP_ParsedSubstitutions env) cs
@@ -1501,6 +1503,8 @@ checkSpecialTypes mod_index (SP_ParsedSubstitutions envs) type_defs modules heap
 	= (SP_Substitutions specials, ots.ots_type_defs, ots.ots_modules, heaps, cs)
 checkSpecialTypes mod_index SP_None type_defs modules heaps cs
 	= (SP_None, type_defs, modules, heaps, cs)
+checkSpecialTypes mod_index SP_GenerateRecordInstances type_defs modules heaps cs
+	= (SP_GenerateRecordInstances, type_defs, modules, heaps, cs)
 
 checkFunSpecialTypes :: !Index !FunSpecials !v:{#CheckedTypeDef} !u:{#DclModule} !*TypeHeaps !*CheckState
 						   -> (!FunSpecials,!x:{#CheckedTypeDef},!w:{#DclModule},!.TypeHeaps,!.CheckState), [u v <= w, v u <= x];

frontend/overloading.icl

@@ -304,7 +304,8 @@ where
 
 	get_specials :: Specials -> [Special]
 	get_specials (SP_ContextTypes specials) = specials
-	get_specials SP_None 					= []
+	get_specials SP_None = []
+	get_specials SP_GenerateRecordInstances = []
 
 	adjust_type_attributes :: !{#CommonDefs} ![Type] ![Type] !*Coercions !*TypeHeaps -> (Bool, !*Coercions, !*TypeHeaps)
 	adjust_type_attributes defs act_types form_types coercion_env type_heaps
@@ -795,6 +796,8 @@ where
 		= match defs (t1,ts1) (t2,ts2) type_heaps
 	match defs [] [] type_heaps
 		= (True, type_heaps)
+	match defs _ _ type_heaps // in case of a kind error
+		= (False, type_heaps)
 
 instance match ConsVariable
 where
@@ -1029,7 +1032,7 @@ where
 			= [(index, new_ptrs ++ ptrs) : dict_types]
 			= [(new_index, new_ptrs) : dt]
 	
-selectFromDictionary  dict_mod dict_index member_index defs
+selectFromDictionary dict_mod dict_index member_index defs
 	# (RecordType {rt_fields}) = defs.[dict_mod].com_type_defs.[dict_index].td_rhs
 	  { fs_ident, fs_index } = rt_fields.[member_index]
 	= { glob_module = dict_mod, glob_object = { ds_ident = fs_ident, ds_index = fs_index, ds_arity = 1 }}
@@ -1060,7 +1063,7 @@ where
             # index = -1 - cim_index
             = (EI_Instance {glob_module=glob_module, glob_object={ds_ident=cim_ident, ds_arity=n_class_exprs, ds_index=index}} class_exprs,
                                 heaps_and_ptrs)
-	adjust_member_application defs contexts  {me_ident,me_offset,me_class={glob_module,glob_object}} (CA_Context tc) class_exprs (heaps=:{hp_type_heaps}, ptrs)
+	adjust_member_application defs contexts {me_offset,me_class={glob_module,glob_object}} (CA_Context tc) class_exprs (heaps=:{hp_type_heaps}, ptrs)
 		# (class_context, address, hp_type_heaps) = determineContextAddress contexts defs tc hp_type_heaps
 		# {class_dictionary={ds_index,ds_ident}} = defs.[glob_module].com_class_defs.[glob_object]
 		  selector = selectFromDictionary glob_module ds_index me_offset defs

frontend/syntax.dcl

@@ -342,6 +342,7 @@ cNameLocationDependent :== True
 	| SP_Substitutions 		 	![SpecialSubstitution]
 	| SP_ContextTypes			![Special]
 	| SP_TypeOffset				!Int					// index in SP_Substitutions for specialized instance
+	| SP_GenerateRecordInstances	// for unboxed arrays and lists
 	| SP_None
 
 ::	FunSpecials

frontend/syntax.icl

@@ -313,7 +313,7 @@ where
 	(<<<) file (BasicPatterns type patterns) = file <<< " " <<<patterns
 	(<<<) file (AlgebraicPatterns type patterns) = file <<< patterns
 	(<<<) file (DynamicPatterns patterns) = file <<< patterns
-	(<<<) file (OverloadedListPatterns type decons_expr patterns) = file <<< decons_expr <<< " " <<< patterns
+	(<<<) file (OverloadedListPatterns type decons_expr patterns) = file <<< ' ' <<< decons_expr <<< ' ' <<< patterns
 	(<<<) file (NewTypePatterns type patterns) = file <<< patterns
 	(<<<) file NoPattern = file 
 
@@ -412,7 +412,7 @@ where
 		= file <<< "DictionariesFunction " <<< dictionaries <<< expr <<< expr_type
 	(<<<) file ExprToBeRemoved = file <<< "** ExprToBeRemoved **"
 	(<<<) file expr         				= abort ("<<< (Expression)" )
-	
+
 instance <<< LetBind
 where
 	(<<<) file {lb_dst, lb_src}
@@ -673,6 +673,10 @@ where
 		= file <<< " = " <<< data 
 	(<<<) file (RecordType record)
 		= file <<< " = " <<< '{' <<< record <<< '}'
+	(<<<) file (ExtensibleAlgType data)
+		= file <<< " = " <<< data <<< " | .."
+	(<<<) file (AlgConses data _)
+		= file <<< " | " <<< data
 	(<<<) file _
 		= file 
 

frontend/trans.icl

@@ -5059,11 +5059,12 @@ where
 instance <<< Specials
 where
 	(<<<) file spec = case spec of
+		SP_None							-> file <<< "SP_None"
 		(SP_ParsedSubstitutions 	_)	-> file <<< "SP_ParsedSubstitutions"
 		(SP_Substitutions 		 	_)	-> file <<< "SP_Substitutions"
 		(SP_ContextTypes			l)	-> file <<< "(SP_ContextTypes: " <<< l <<< ")"
 		(SP_TypeOffset				_)	-> file <<< "SP_TypeOffset"
-		SP_None							-> file <<< "SP_None"
+		SP_GenerateRecordInstances		-> file <<< "SP_GenerateRecordInstances"
 
 instance <<< Special
 where