Merge branch 'allow-simply-kinded-instances-of-unboxed-arrays-for-generics' into 'master'

Allow generic instances of unboxed arrays of non-basic types

See merge request clean-compiler-and-rts/compiler!3

frontend/checkgenerics.icl

@@ -319,6 +319,14 @@ where
 			# cs = {cs & cs_error = checkError type_def.td_ident "type synonym not allowed" cs.cs_error}
 			= (TA type_cons [], TypeConsSymb type_cons, type_defs, modules, heaps, cs)
 			= (TA type_cons [], TypeConsSymb type_cons, type_defs, modules, heaps, cs)
+	check_instance_type module_index (TA type_cons=:{type_ident={id_name=PD_UnboxedArray_String,id_info}} [element_type]) type_defs modules heaps cs
+		# (entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table
+		# cs & cs_symbol_table = cs_symbol_table
+		# (type_index, type_module) = retrieveGlobalDefinition entry STE_Type module_index
+		# type_cons & type_index = { glob_object = type_index, glob_module = type_module }
+		# (at_type, element_type_cons, type_defs, modules, heaps, cs) = check_instance_type module_index element_type.at_type type_defs modules heaps cs
+		# element_type & at_type = at_type
+		= (TA type_cons [element_type], TypeConsUnboxedArray element_type_cons, type_defs, modules, heaps, cs)
 	check_instance_type module_index (TB b) type_defs modules heaps cs
 		= (TB b, TypeConsBasic b, type_defs, modules,heaps, cs) 
 	check_instance_type module_index TArrow type_defs modules heaps cs

frontend/generics1.icl

@@ -433,7 +433,6 @@ where
 				#! {pds_module, pds_def} = psd_predefs_a.[PD_UnboxedArrayType]
 				| 	type_index.glob_module == pds_module
 					&& type_index.glob_object == pds_def
-					&& (case args of [{at_type=TB _}] -> True; _ -> False)
 					-> (GTSAppCons KindConst [], (modules, td_infos, heaps, error))
 				| otherwise
 					#! ({tdi_kinds}, td_infos) = td_infos ! [type_index.glob_module,type_index.glob_object]
@@ -1731,6 +1730,8 @@ where
 	get_kind_of_type_cons :: !TypeCons !*TypeDefInfos -> (!TypeKind, !*TypeDefInfos)
 	get_kind_of_type_cons (TypeConsBasic _) td_infos 
 		= (KindConst, td_infos)
+	get_kind_of_type_cons (TypeConsUnboxedArray _) td_infos
+		= (KindConst, td_infos)
 	get_kind_of_type_cons TypeConsArrow td_infos
 		= (KindArrow [KindConst,KindConst], td_infos)
 	get_kind_of_type_cons (TypeConsSymb {type_ident, type_index}) td_infos
@@ -1780,6 +1781,8 @@ where
 
 instance_vars_from_type_cons (TypeConsVar tv)
 	= [tv]
+instance_vars_from_type_cons (TypeConsUnboxedArray element_type_cons)
+	= instance_vars_from_type_cons element_type_cons
 instance_vars_from_type_cons _
 	= []
 

frontend/genericsupport.icl

@@ -104,6 +104,7 @@ genericIdentToFunIdent id_name type_cons
 type_cons_to_string :: !TypeCons -> {#Char}
 type_cons_to_string (TypeConsSymb {type_ident}) = toString type_ident
 type_cons_to_string (TypeConsBasic bt) = toString bt
+type_cons_to_string (TypeConsUnboxedArray tc) = "#ARRAY;" +++ type_cons_to_string tc
 type_cons_to_string TypeConsArrow = "ARROW"
 type_cons_to_string (TypeConsVar tv) = tv.tv_ident.id_name
 type_cons_to_string (TypeConsQualifiedIdent _ type_name) = type_name

frontend/hashtable.icl

@@ -45,9 +45,15 @@ where
 	(=<) (IC_InstanceMember types1) (IC_InstanceMember types2)
 		= compare_types types1 types2
 	(=<) (IC_GenericCase type1) (IC_GenericCase type2)
-		= type1 =< type2
+		# cmp = type1 =< type2
+		| cmp == Equal
+			= compare_unboxed_array_element_type type1 type2
+			= cmp
 	(=<) (IC_GenericDeriveClass type1) (IC_GenericDeriveClass type2)
-		= type1 =< type2
+		# cmp = type1 =< type2
+		| cmp == Equal
+			= compare_unboxed_array_element_type type1 type2
+			= cmp
 	(=<) (IC_Field typ_id1) (IC_Field typ_id2)
 		= typ_id1 =< typ_id2
 	(=<) (IC_TypeExtension module_name1) (IC_TypeExtension module_name2)
@@ -71,6 +77,16 @@ compare_types [] _
 compare_types _ []
 	= Greater
 
+compare_unboxed_array_element_type (TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=element_type1}]) (TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=element_type2}])
+	= compare_unboxed_array_element_type` element_type1 element_type2
+where
+	compare_unboxed_array_element_type` (TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=element_type1}]) (TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=element_type2}])
+		= compare_unboxed_array_element_type` element_type1 element_type2
+	compare_unboxed_array_element_type` t1 t2
+		= t1 =< t2
+compare_unboxed_array_element_type t1 t2
+	= Equal
+
 instance =< (!a,!b) |  =< a &  =< b
 where
 	(=<) (x1,y1) (x2,y2)

frontend/parse.icl

@@ -587,28 +587,13 @@ where
 		//# (type, pState) = wantType pState
 		# (ok, {at_type=type}, pState) = trySimpleType TA_None pState
 		# (ident, pState) = stringToIdent name (IC_GenericCase type) pState
-		# (generic_ident, pState) = stringToIdent name IC_Generic pState	
-		# (type_cons, generic_fun_ident, pState) = get_type_cons type pState
+		# (generic_ident, pState) = stringToIdent name IC_Generic pState
+		# (type_cons, pState) = get_type_cons type pState
+		# (generic_fun_ident, pState) = make_generic_fun_ident type_cons pState
 			with
-				get_type_cons (TA type_symb []) pState
-					= make_generic_fun_ident (TypeConsSymb type_symb) pState
-				get_type_cons (TA type_symb _) pState
-					# pState = parseError "generic type, no constructor arguments allowed" No " |}" pState
-					= (abort_no_TypeCons, abort_no_TypeCons, pState)
-				get_type_cons (TB tb) pState
-					= make_generic_fun_ident (TypeConsBasic tb) pState
-				get_type_cons TArrow pState
-					= make_generic_fun_ident TypeConsArrow pState
-				get_type_cons (TV tv) pState
-					= make_generic_fun_ident (TypeConsVar tv) pState
-				get_type_cons _ pState 
-					# pState = parseError "generic type" No " |}" pState
-					= (abort_no_TypeCons, abort_no_TypeCons, pState)
-				
 				make_generic_fun_ident type_cons pState
 					# generic_fun_ident = genericIdentToFunIdent name type_cons
-					  (generic_fun_ident,pState) = stringToIdent generic_fun_ident.id_name IC_Expression pState
-					= (type_cons, generic_fun_ident, pState)
+					= stringToIdent generic_fun_ident.id_name IC_Expression pState
 
 		# (token, pState) = nextToken GenericContext pState
 		# (geninfo_arg, gcf_generic_info, pState) = case token of
@@ -674,8 +659,6 @@ where
 			}
 		= (True, PD_GenericCase generic_case generic_fun_ident, pState)
 
-	abort_no_TypeCons => abort "no TypeCons"
-
 	wantForeignExportDefinition pState
 		# (token, pState) = nextToken GeneralContext pState
 		# (file_name,line_nr,pState) = getFileAndLineNr pState
@@ -2073,22 +2056,6 @@ where
 						 gc_gcf = GCFC ident class_ident}
 		= (derive_def, pState)
 
-	get_type_cons :: Type !*ParseState -> (TypeCons, !*ParseState)	
-	get_type_cons (TA type_symb []) pState
-		= (TypeConsSymb type_symb, pState)
-	get_type_cons (TB tb) pState
-		= (TypeConsBasic tb, pState)
-	get_type_cons TArrow pState
-		= (TypeConsArrow, pState)
-	get_type_cons (TV tv) pState
-		| isDclContext parseContext
-			= (TypeConsVar tv, pState)
-	get_type_cons (TQualifiedIdent module_id ident_name []) pState
-		= (TypeConsQualifiedIdent module_id ident_name, pState)
-	get_type_cons type pState 
-		# pState = parseError "generic type" No " type constructor" pState
-		= (abort "no TypeCons", pState)
-
 	parse_info_fields "OBJECT" token pState
 		= parse_OBJECT_info_fields token 0 pState
 	parse_info_fields "CONS" token pState
@@ -2198,6 +2165,24 @@ where
 			_
 				-> (GenericInstanceDependencies n_deps deps, token, pState)
 
+get_type_cons :: !Type !*ParseState -> (TypeCons, !*ParseState)
+get_type_cons (TA type_symb []) pState
+	= (TypeConsSymb type_symb, pState)
+get_type_cons (TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type}]) pState
+	# (element_type_cons, pState) = get_type_cons at_type pState
+	= (TypeConsUnboxedArray element_type_cons, pState)
+get_type_cons (TB tb) pState
+	= (TypeConsBasic tb, pState)
+get_type_cons TArrow pState
+	= (TypeConsArrow, pState)
+get_type_cons (TV tv) pState
+	= (TypeConsVar tv, pState)
+get_type_cons (TQualifiedIdent module_id ident_name []) pState
+	= (TypeConsQualifiedIdent module_id ident_name, pState)
+get_type_cons type pState
+	# pState = parseError "generic type" No "type constructor" pState
+	= (abort "no TypeCons", pState)
+
 /*
 	Type definitions
 */

frontend/syntax.dcl

@@ -460,6 +460,7 @@ instance == GenericDependency
 :: TypeCons 
 	= TypeConsSymb TypeSymbIdent 
 	| TypeConsBasic BasicType 
+	| TypeConsUnboxedArray TypeCons
 	| TypeConsArrow
 	| TypeConsVar TypeVar
 	| TypeConsQualifiedIdent !Ident !String 

frontend/type.icl

@@ -2597,7 +2597,24 @@ where
 				= (error, IT_Node ins it_less it_greater)
 			| ins.glob_object==new_ins_index && ins.glob_module==new_ins_module
 				= (error, IT_Node ins it_less it_greater)
+			# cmp = check_unboxed_arrays ins_types it_types
+			| cmp == Smaller
+				# (error, it_less) = insert ins_types new_ins_index new_ins_module modules error it_less
+				= (error, IT_Node ins it_less it_greater)
+			| cmp == Greater
+				# (error, it_greater) = insert ins_types new_ins_index new_ins_module modules error it_greater
+				= (error, IT_Node ins it_less it_greater)
 				= (checkError ins_types " instance is overlapping" error, IT_Node ins it_less it_greater)
+		where
+			check_unboxed_arrays [TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=elem_type1}]] [TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=elem_type2}]]
+				| elem_type1=:(TV _) || elem_type2=:(TV _)
+					= Equal
+				# cmp = elem_type1 =< elem_type2
+				| cmp <> Equal
+					= cmp
+					= check_unboxed_arrays [elem_type1] [elem_type2]
+			check_unboxed_arrays _ _
+				= Equal
 
 	check_types_of_instances ins_pos common_defs class_module class_index types state
 		# {class_cons_vars} = common_defs.[class_module].com_class_defs.[class_index]