universally quantified types added

frontend/analtypes.icl

@@ -208,6 +208,18 @@ where
 			  {uki_kind_heap, uki_error} = unifyKinds tk KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error}
 			  (ldep2, tks, is_non_coercible, conds_as) = check_type_list modules form_tvs types (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error })
 			= (min ldep1 ldep2, [tk : tks], is_non_coercible || (type_props bitand cIsNonCoercible <> 0), conds_as)
+	analTypes has_root_attr modules form_tvs (TFA vars type) (conds, as=:{as_heaps,as_kind_heap})
+		# (th_vars, as_kind_heap) = new_local_kind_variables vars (as_heaps.th_vars, as_kind_heap)
+		= analTypes has_root_attr modules form_tvs type (conds, { as & as_heaps = { as_heaps & th_vars = th_vars}, as_kind_heap = as_kind_heap})
+	where
+		new_local_kind_variables :: [ATypeVar] !(!*TypeVarHeap,!*KindHeap) -> (!*TypeVarHeap,!*KindHeap)
+		new_local_kind_variables td_args (type_var_heap, as_kind_heap)
+			= foldSt new_kind td_args (type_var_heap, as_kind_heap)
+		where
+			new_kind :: !ATypeVar !(!*TypeVarHeap,!*KindHeap) -> (!*TypeVarHeap,!*KindHeap)
+			new_kind {atv_variable={tv_info_ptr},atv_attribute} (type_var_heap, kind_heap)
+				# (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap
+				= (	type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr))
 	analTypes has_root_attr modules form_tvs type conds_as
 		= (cMAXINT, KI_Const, cIsHyperStrict, conds_as)
 	
@@ -228,11 +240,11 @@ where
 	check_types_of_cons :: ![AType] !Bool !Index  !Level ![TypeVar] !TypeAttribute ![AttrInequality] !Conditions !*TypeSymbols !*TypeInfo !*CheckState
 		-> *(![AType], ![[ATypeVar]], ![AttrInequality], !TypeProperties, !Conditions, !Int, !*TypeSymbols, !*TypeInfo, !*CheckState)
 */
-	new_local_kind_variables :: .[ATypeVar] *(*Heap TypeVarInfo,*Heap KindInfo) -> (!Bool,!.Heap TypeVarInfo,!.Heap KindInfo);
+	new_local_kind_variables :: [ATypeVar] !(!*TypeVarHeap,!*KindHeap) -> (!Bool,!*TypeVarHeap,!*KindHeap)
 	new_local_kind_variables td_args (type_var_heap, as_kind_heap)
 		= foldSt new_kind td_args (True, type_var_heap, as_kind_heap)
 	where
-		new_kind :: ATypeVar *(.Bool,*Heap TypeVarInfo,*Heap KindInfo) -> (!Bool,!.Heap TypeVarInfo,!.Heap KindInfo);
+		new_kind :: !ATypeVar !(!Bool,!*TypeVarHeap,!*KindHeap) -> (!Bool,!*TypeVarHeap,!*KindHeap)
 		new_kind {atv_variable={tv_info_ptr},atv_attribute} (coercible, type_var_heap, kind_heap)
 			# (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap
 			= (coercible && is_not_a_variable atv_attribute, type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr),

frontend/analunitypes.icl

@@ -299,20 +299,20 @@ signClassOfType (arg_type --> res_type) sign use_top_sign group_nr ci scs
 	  (res_class, _, scs) = signClassOfType res_type.at_type PositiveSign use_top_sign group_nr ci scs
 	= (sign *+ (arg_class + res_class), BottomSignClass, scs)
 
+signClassOfType (TFA vars type) sign use_top_sign group_nr ci scs
+	= signClassOfType type sign use_top_sign group_nr ci scs
+
 signClassOfType type _ _ _ _ scs
 	= (BottomSignClass, BottomSignClass, scs)
 
 propClassification :: !Index !Index ![PropClassification] !{# CommonDefs } !*TypeVarHeap !*TypeDefInfos
 	-> (!PropClassification, !*TypeVarHeap, !*TypeDefInfos)
 propClassification type_index module_index hio_props defs type_var_heap td_infos
-// MW3..
-	| type_index>=size td_infos.[module_index]
-		// must be a dictionary => doesn't propagate
+	| type_index >= size td_infos.[module_index]
 		= (0, type_var_heap, td_infos)
-// ..MW3
-	# {td_args, td_name} = defs.[module_index].com_type_defs.[type_index]
-	  (td_info, td_infos) = td_infos![module_index].[type_index]
-	= determinePropClassOfTypeDef type_index module_index td_args td_info hio_props defs type_var_heap td_infos
+		# {td_args, td_name} = defs.[module_index].com_type_defs.[type_index]
+		  (td_info, td_infos) = td_infos![module_index].[type_index]
+		= determinePropClassOfTypeDef type_index module_index td_args td_info hio_props defs type_var_heap td_infos
 
 determinePropClassOfTypeDef :: !Int !Int ![ATypeVar] !TypeDefInfo ![PropClassification] !{# CommonDefs} !*TypeVarHeap !*TypeDefInfos
 	-> (!PropClassification,!*TypeVarHeap, !*TypeDefInfos)
@@ -542,6 +542,9 @@ where
 	prop_class_of_type_list [] _ _ _ _ cumm_class pcs
 		= (cumm_class, pcs)
 
+propClassOfType (TFA vars type) group_nr ci pcs
+	= propClassOfType type group_nr ci pcs
+
 propClassOfType _ _ _ pcs
 	= (NoPropClass, NoPropClass, pcs)
 

frontend/checkKindCorrectness.icl

@@ -72,7 +72,7 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs
 	check_class com_member_defs class_def=:{class_name, class_args, class_members}
 			(class_defs_accu, th_vars, td_infos, error_admin)
 		# th_vars
-				= foldSt init_type_var class_args th_vars
+				= init_type_vars class_args th_vars
 		  (th_vars, td_infos, error_admin)
 		  		= foldlArraySt (\{ds_index} state
 									-> check_member_without_context class_args 
@@ -87,7 +87,7 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs
 		# error_admin
 				= setErrorAdmin (newPosition me_symb me_pos) error_admin
 		  th_vars
-				= foldSt init_type_var st_vars th_vars
+				= init_type_vars st_vars th_vars
 		  th_vars
 		  		= fold2St copy_TVI class_args me_class_vars th_vars
 		  (th_vars, td_infos, error_admin)
@@ -121,7 +121,7 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs
 		  error_admin
 		  		= setErrorAdmin (newPosition ins_ident ins_pos) error_admin
 		  th_vars
-		  		= foldSt init_type_var ins_type.it_vars th_vars
+		  		= init_type_vars ins_type.it_vars th_vars
 		  (th_vars, td_infos, error_admin)
 		  		= unsafeFold3St possibly_check_type expected_kinds [1..] 
 		  				ins_type.it_types (th_vars, td_infos, error_admin)
@@ -223,7 +223,7 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs
 		# error_admin
 				= setErrorAdmin (newPosition fun_symb fun_pos) error_admin
 		  th_vars
-				= foldSt init_type_var st_vars th_vars
+				= init_type_vars st_vars th_vars
 		  (th_vars, td_infos, error_admin)
 		  		= unsafeFold2St (check_atype KindConst) 
 		  				[0..] [st_result:st_args] (th_vars, td_infos, error_admin)
@@ -291,6 +291,11 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs
 		# error_admin
 		  		= check_equality_of_kinds arg_nr expected_kind KindConst error_admin
 		= (th_vars, td_infos, error_admin)
+// Sjaak ... 170801
+	check_type expected_kind arg_nr (TFA vars type) (th_vars, td_infos, error_admin)
+		# th_vars = init_type_vars [ atv_variable \\ {atv_variable} <- vars ] th_vars
+		= check_type expected_kind arg_nr type (th_vars, td_infos, error_admin)
+// ... Sjaak 170801
 	
 	check_context common_defs {tc_class, tc_types} 
 			(bv_uninitialized_mods, th_vars, td_infos, error_admin)
@@ -303,8 +308,11 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs
 	  where
 		descending i = [i:descending (i-1)]
 		  
-	init_type_var {tv_info_ptr} th_vars
-		= writePtr tv_info_ptr TVI_Empty th_vars
+	init_type_vars vars tv_heap
+		= foldSt init_type_var vars tv_heap
+	where
+		init_type_var {tv_info_ptr} tv_heap
+			= tv_heap <:= (tv_info_ptr, TVI_Empty)
 		
 	unify_var_kinds expected_kind tv=:{tv_name, tv_info_ptr} th_vars error_admin
 		# (tvi, th_vars)