checking the kinds of all function-, instance-, class- and member-types

before typecheking (see new module "checkKindCorrectness")


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

3 files changed, 8 insertions, 100 deletions

diff --git a/frontend/check.icl b/frontend/check.icl
index 74db3f3..c7427be 100644
--- a/frontend/check.icl
+++ b/frontend/check.icl
@@ -3,7 +3,7 @@ implementation module check
 import StdEnv
 
 import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef
-import explicitimports, comparedefimp, checkFunctionBodies, containers, portToNewSyntax
+import explicitimports, comparedefimp, checkFunctionBodies, containers, portToNewSyntax, compilerSwitches
 
 cPredefinedModuleIndex 	:== 1
 cUndef :== (-1)
@@ -392,7 +392,6 @@ where
 				  cs_error = pushErrorAdmin (newPosition class_name ins_pos) cs.cs_error
 				  (instance_type, _, type_heaps, Yes (modules, type_defs), Yes cs_error)
 				  		= determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None type_heaps (Yes (modules, type_defs, x_main_dcl_module_n)) (Yes cs_error)
-				  (type_defs, modules, cs_error) = checkTopLevelKinds x_main_dcl_module_n True me_symb instance_type type_defs modules cs_error
 				  cs_error = popErrorAdmin cs_error
 				  (st_context, var_heap) = initializeContextVariables instance_type.st_context var_heap
 				= check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members class_name ins_pos ins_type
@@ -630,7 +629,6 @@ where
 			  		= pushErrorAdmin (newPosition class_name ins_pos) cs_error
 			  (instance_type, new_ins_specials, type_heaps, Yes (modules, _), Yes cs_error)
 			  		= determineTypeOfMemberInstance me_type me_class_vars ins_type ins_specials type_heaps (Yes (modules, {}, cUndef)) (Yes cs_error)
-			  (_, modules, cs_error) = checkTopLevelKinds x_main_dcl_module_n False me_symb instance_type cDummyArray modules cs_error
 			  cs_error
 			  		= popErrorAdmin cs_error
 			  (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
@@ -669,54 +667,6 @@ where
 			= (tc_types, error)
 
 
-checkTopLevelKinds :: !Index !Bool Ident !SymbolType n:{# CheckedTypeDef} !r:{# DclModule} !*ErrorAdmin
-					-> (!n:{# CheckedTypeDef}, !r:{# DclModule}, !*ErrorAdmin)
-checkTopLevelKinds x_main_dcl_module_n is_icl_module me_symb st=:{st_args, st_result} type_defs modules cs_error
-	#! first_wrong = firstIndex (\{at_type} -> not (kind_is_ok x_main_dcl_module_n is_icl_module type_defs modules 0 at_type)) [st_result:st_args]
-	# cs_error
-	  		= case first_wrong of
-	  			(-1)
-	  				-> cs_error
-	  			_ 
-	  				-> checkError "instance type has wrong kind" 
-	  				  			(   "(e.g. "
-	  				  			 +++arg_string first_wrong
-	  				  			 +++" of member "
-	  				  			 +++toString me_symb
-	  				  			 +++")"
-	  				  			) 
-	  				  			cs_error
-= (type_defs, modules, cs_error)
-  where
-	kind_is_ok x_main_dcl_module_n is_icl_module type_defs modules demanded_kind type=:(TA {type_index={glob_object,glob_module}} args)
-		# {td_arity}
-				= if (glob_module==x_main_dcl_module_n && is_icl_module) type_defs.[glob_object]
-				     modules.[glob_module].dcl_common.com_type_defs.[glob_object]
-		= demanded_kind == td_arity-length args
-	kind_is_ok _ _ _ modules 0 (_ --> _)
-		= True
-	kind_is_ok _ _ _ modules _ (_ :@: _)
-		= True
-	kind_is_ok _ _ _ _ 0 (TB _)
-		= True
-	kind_is_ok _ _ _ _ _ (GTV _)
-		= True
-	kind_is_ok _ _ _ _ _ (TV _)
-		= True
-	kind_is_ok _ _ _ _ _ (TQV _)
-		= True
-	kind_is_ok _ _ _ _ _ _
-		= False
-		
-
-
-consOptional (Yes thing) things
-	= [ thing : things]
-consOptional No things
-	= things
-
-
-
 initializeContextVariables :: ![TypeContext] !*VarHeap ->  (![TypeContext], !*VarHeap)
 initializeContextVariables contexts var_heap
 	= mapSt add_variable_to_context contexts var_heap
diff --git a/frontend/frontend.icl b/frontend/frontend.icl
index 1630061..44d4397 100644
--- a/frontend/frontend.icl
+++ b/frontend/frontend.icl
@@ -1,9 +1,7 @@
 implementation module frontend
 
-import scanner, parse, postparse, check, type, trans, convertcases, overloading, utilities, convertDynamics, convertimportedtypes
-//import RWSDebug
-import analtypes
-import generics
+import scanner, parse, postparse, check, type, trans, convertcases, overloading, utilities, convertDynamics,
+		convertimportedtypes, checkKindCorrectness, compilerSwitches, analtypes, generics
 
 :: FrontEndSyntaxTree
 	=	{	fe_icl :: !IclModule
@@ -127,6 +125,10 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac
 	# error_admin = {ea_file = error, ea_loc = [], ea_ok = True }
 	# ti_common_defs = {{dcl_common \\ {dcl_common} <-: dcl_mods } & [main_dcl_module_n] = icl_common }
 	# (td_infos, type_heaps, error_admin) = analTypeDefs ti_common_defs icl_used_module_numbers type_heaps error_admin
+      (fun_defs, th_vars, td_infos, error_admin) 
+      		= checkKindCorrectness icl_used_module_numbers main_dcl_module_n icl_instances 
+      				ti_common_defs dcl_mods fun_defs type_heaps.th_vars td_infos error_admin
+      type_heaps = { type_heaps & th_vars = th_vars }
 	# heaps = { heaps & hp_type_heaps = type_heaps }
 
 	#! (components, ti_common_defs, fun_defs, generic_range, td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin) = 
diff --git a/frontend/type.icl b/frontend/type.icl
index ebd5fe9..ec20ace 100644
--- a/frontend/type.icl
+++ b/frontend/type.icl
@@ -2,7 +2,7 @@ implementation module type
 
 import StdEnv
 import syntax, typesupport, check, analtypes, overloading, unitype, refmark, predef, utilities, compare_constructor // , RWSDebug
-import cheat
+import cheat, compilerSwitches
 import generics // AA
 
 ::	TypeInput =
@@ -863,17 +863,6 @@ addPropagationAttributesToAType modules type=:{at_type = TA cons_id=:{type_index
 	  (prop_class, th_vars, prop_td_infos) = propClassification glob_object glob_module props modules prop_type_heaps.th_vars prop_td_infos
 	  (at_attribute, prop_class, th_attrs, prop_attr_vars, prop_attr_env, prop_error)
 	  		= determine_attribute_of_cons modules at_attribute cons_args prop_class prop_type_heaps.th_attrs prop_attr_vars prop_attr_env prop_error
-	  ({tdi_kinds}, prop_td_infos)
-	  		= prop_td_infos![glob_module,glob_object]
-	  prop_error
-	  		= case prop_error of
-	  			No
-	  				// this function is called after typechecking (during transformations)
-	  				-> No
-	  			Yes error_admin
-	  				# (_, error_admin)
-	  					= unsafeFold2St (check_kind type_name modules) tdi_kinds cons_args (1, error_admin)
-	  				-> Yes error_admin
 	= ({ type & at_type = TA cons_id cons_args, at_attribute = at_attribute }, prop_class,  { ps & prop_attr_vars = prop_attr_vars,
 			prop_td_infos = prop_td_infos, prop_attr_env = prop_attr_env,
 				prop_type_heaps = { prop_type_heaps & th_vars = th_vars, th_attrs = th_attrs}, prop_error = prop_error })
@@ -935,39 +924,6 @@ addPropagationAttributesToAType modules type=:{at_type = TA cons_id=:{type_index
 		combine_attributes cons_attr _ _ attr_var_heap attr_vars attr_env ps_error
 			= (cons_attr, attr_var_heap, attr_vars, attr_env, ps_error)
 
-		check_kind type_name modules type_kind {at_type} (arg_nr, error_admin)
-			# ok
-					= kind_is_ok modules (my_kind_to_int type_kind) at_type
-			| ok
-				= (arg_nr+1, error_admin)
-			# error_admin = errorHeading type_error error_admin
-			= (arg_nr+1, { error_admin & ea_file = error_admin.ea_file <<< " argument " <<< arg_nr <<< " of type " <<< type_name 
-													<<< " expected kind " <<< type_kind <<< "\n" })
-		  where
-			kind_is_ok modules demanded_kind (TA {type_index={glob_object,glob_module}} args)
-				# {td_arity}
-						= modules.[glob_module].com_type_defs.[glob_object]
-				= demanded_kind == td_arity-length args
-			kind_is_ok modules 0 (_ --> _)
-				= True
-			kind_is_ok modules _ (_ :@: _)
-				= True
-			kind_is_ok modules 0 (TB _)
-				= True
-			kind_is_ok modules _ (GTV _)
-				= True
-			kind_is_ok modules _ (TV _)
-				= True
-			kind_is_ok modules _ (TQV _)
-				= True
-			kind_is_ok modules _ _
-				= False
-		
-			my_kind_to_int KindConst
-				= 0
-			my_kind_to_int (KindArrow k)
-				= length k
-
 addPropagationAttributesToAType modules type=:{at_type} ps
 	# (at_type, ps) = addPropagationAttributesToType modules at_type ps
 	= ({ type & at_type = at_type }, NoPropClass, ps)