add type StringPos (from iTask branch)

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

4 files changed, 46 insertions, 24 deletions

diff --git a/frontend/checksupport.dcl b/frontend/checksupport.dcl
index b9ae928..acf6362 100644
--- a/frontend/checksupport.dcl
+++ b/frontend/checksupport.dcl
@@ -74,6 +74,7 @@ where
 instance Erroradmin ErrorAdmin, CheckState
 
 newPosition :: !Ident !Position -> IdentPos 
+stringPosition :: !String !Position -> StringPos
 
 checkError :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b
 checkWarning :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b
@@ -91,7 +92,7 @@ instance toIdent ConsDef, (TypeDef a), ClassDef, MemberDef, FunDef, SelectorDef
 instance toIdent SymbIdent, TypeSymbIdent, BoundVar, TypeVar, ATypeVar, Ident
 
 instance toInt STE_Kind
-instance <<< IdentPos, ExplImpInfo, DeclarationInfo
+instance <<< IdentPos, StringPos, ExplImpInfo, DeclarationInfo
 
 ::	ExpressionInfo =
 	{	ef_type_defs		:: !.{# CheckedTypeDef}
diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl
index 4a439d7..5ae31d2 100644
--- a/frontend/checksupport.icl
+++ b/frontend/checksupport.icl
@@ -56,6 +56,16 @@ newPosition id (PreDefPos file_name)
 newPosition id NoPos
 	= { ip_ident = id, ip_line = cNotALineNumber, ip_file = "???" }
 
+stringPosition :: !String !Position -> StringPos
+stringPosition id (FunPos file_name line_nr _)
+	= { sp_name = id, sp_line = line_nr, sp_file = file_name }
+stringPosition id (LinePos file_name line_nr)
+	= { sp_name = id, sp_line = line_nr, sp_file = file_name }
+stringPosition id (PreDefPos file_name)
+	= { sp_name = id, sp_line = cNotALineNumber, sp_file = file_name.id_name }
+stringPosition id NoPos
+	= { sp_name = id, sp_line = cNotALineNumber, sp_file = "???" }
+
 checkError :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b // PK
 checkError id mess error=:{ea_file,ea_loc=[]}
 	= { error & ea_file = ea_file <<< "Error " <<< " " <<< id <<< " " <<< mess <<< '\n', ea_ok = False }
@@ -504,6 +514,12 @@ where
 		= file <<< '[' <<< ip_file <<< ',' <<< ip_ident <<< ']'
 		= file <<< '[' <<< ip_file <<< ',' <<< ip_line <<< ',' <<< ip_ident <<< ']'
 
+instance <<< StringPos where
+	(<<<) file {sp_file,sp_line,sp_name}
+	| sp_line == cNotALineNumber
+		= file <<< '[' <<< sp_file <<< ',' <<< sp_name <<< ']'
+		= file <<< '[' <<< sp_file <<< ',' <<< sp_line <<< ',' <<< sp_name <<< ']'
+
 instance <<< ExplImpInfo
   where
 	(<<<) file (ExplImpInfo eii_ident eii_declaring_modules)
diff --git a/frontend/generics1.icl b/frontend/generics1.icl
index 44d017f..2d372b7 100644
--- a/frontend/generics1.icl
+++ b/frontend/generics1.icl
@@ -250,10 +250,10 @@ where
 				// needs a generic representation
 				-> case type_def.td_rhs of
 					SynType _
-						#  gs_error = reportError gc_ident gc_pos ("cannot derive a generic instance for a synonym type " +++ type_def.td_ident.id_name) gs.gs_error
+						#  gs_error = reportError gc_ident.id_name gc_pos ("cannot derive a generic instance for a synonym type " +++ type_def.td_ident.id_name) gs.gs_error
 						-> (funs_and_groups, {gs & gs_error = gs_error})	
 					AbstractType _
-						#  gs_error = reportError gc_ident gc_pos ("cannot derive a generic instance for an abstract type "  +++ type_def.td_ident.id_name) gs.gs_error
+						#  gs_error = reportError gc_ident.id_name gc_pos ("cannot derive a generic instance for an abstract type "  +++ type_def.td_ident.id_name) gs.gs_error
 						-> (funs_and_groups, {gs & gs_error = gs_error})	
 					_ 
 						-> case td_info.tdi_gen_rep of
@@ -334,7 +334,7 @@ where
 	convert {at_type=TB _} st
 		= (GTSAppCons KindConst [], st)  
 	convert {at_type=type} (modules, td_infos, heaps, error)
-		# error = reportError ident pos ("can not build generic representation for this type", type) error
+		# error = reportError ident.id_name pos ("can not build generic representation for this type", type) error
 		= (GTSE, (modules, td_infos, heaps, error))
 
 	convert_type_app {type_index} attr args (modules, td_infos, heaps, error)	
@@ -377,7 +377,7 @@ where
 	convert {at_type=TB _} st
 		= (GTSAppCons KindConst [], st)  
 	convert {at_type=type} (modules, td_infos, heaps, error)
-		# error = reportError predefined_idents.[PD_GenericBimap] pos ("can not build generic representation for this type", type) error
+		# error = reportError predefined_idents.[PD_GenericBimap].id_name pos ("can not build generic representation for this type", type) error
 		= (GTSE, (modules, td_infos, heaps, error))
 
 	convert_type_app {type_index=type_index=:{glob_module,glob_object},type_arity} attr args (modules, td_infos, heaps, error)
@@ -584,13 +584,13 @@ where
 			# args = [GTSField fi arg \\ arg <- args & fi <- ci_field_infos]
 			# prod_type = build_prod_type args
 			= (GTSRecord ci_record_info prod_type, st)
-			# error = reportError td_ident td_pos "cannot build a generic representation of an existential type" error
+			# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
 			= (GTSE, (modules, td_infos, heaps, error))
 	build_type {td_rhs=SynType type,td_ident, td_pos} type_infos (modules, td_infos, heaps, error)
-		# error = reportError td_ident td_pos "cannot build a generic representation of a synonym type" error
+		# error = reportError td_ident.id_name td_pos "cannot build a generic representation of a synonym type" error
 		= (GTSE, (modules, td_infos, heaps, error))
 	build_type td=:{td_rhs=(AbstractType _),td_ident, td_arity, td_args, td_pos} type_infos (modules, td_infos, heaps, error)
-		# error = reportError td_ident td_pos "cannot build a generic representation of an abstract type" error
+		# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an abstract type" error
 		= (GTSE, (modules, td_infos, heaps, error))
 
 	build_alt td_ident td_pos cons_def_sym=:{ds_index} cons_info (modules, td_infos, heaps, error)
@@ -599,7 +599,7 @@ where
 			# (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)	
 			# prod_type = build_prod_type args
 			= (GTSCons cons_info prod_type, st)
-			# error = reportError td_ident td_pos "cannot build a generic representation of an existential type" error
+			# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
 			= (GTSE, (modules, td_infos, heaps, error))
 
 	build_prod_type :: [GenTypeStruct] -> GenTypeStruct
@@ -664,10 +664,10 @@ buildTypeDefInfo td=:{td_rhs = AlgType alts} td_module main_module_index predefs
 buildTypeDefInfo td=:{td_rhs = RecordType {rt_constructor, rt_fields}} td_module main_module_index predefs funs_and_groups modules heaps error
 	= buildRecordTypeDefInfo td rt_constructor [x\\x<-:rt_fields] td_module main_module_index predefs funs_and_groups modules heaps error
 buildTypeDefInfo td=:{td_rhs = SynType type, td_ident, td_pos} td_module main_module_index predefs funs_and_groups modules heaps error
-	# error = reportError td_ident td_pos "cannot build constructor uinformation for a synonym type" error
+	# error = reportError td_ident.id_name td_pos "cannot build constructor uinformation for a synonym type" error
 	= buildAlgebraicTypeDefInfo td [] td_module main_module_index predefs funs_and_groups modules heaps error
 buildTypeDefInfo td=:{td_rhs = AbstractType _, td_ident, td_pos} td_module main_module_index predefs funs_and_groups modules heaps error
-	# error = reportError td_ident td_pos "cannot build constructor uinformation for an abstract type" error
+	# error = reportError td_ident.id_name td_pos "cannot build constructor uinformation for an abstract type" error
 	= buildAlgebraicTypeDefInfo td [] td_module main_module_index predefs funs_and_groups modules heaps error
 
 buildAlgebraicTypeDefInfo {td_ident, td_pos, td_arity} alts td_module main_module_index predefs
@@ -1104,11 +1104,11 @@ where
 		# (expr, var, heaps, error) = build_record type_def_mod [rt_constructor] heaps	error
 		= (expr, var, heaps, error)
 	build_expr_for_type_rhs type_def_mod (AbstractType _) heaps error
-		#! error = reportError td_ident td_pos "cannot build isomorphisms for an abstract type" error
+		#! error = reportError td_ident.id_name td_pos "cannot build isomorphisms for an abstract type" error
 		# dummy_fv = {fv_def_level=(-1), fv_count=0, fv_ident=makeIdent "dummy", fv_info_ptr=nilPtr}
 		= (EE, dummy_fv, heaps, error)
 	build_expr_for_type_rhs type_def_mod (SynType _) heaps error
-		#! error = reportError td_ident td_pos "cannot build isomorphisms for a synonym type" error
+		#! error = reportError td_ident.id_name td_pos "cannot build isomorphisms for a synonym type" error
 		# dummy_fv = {fv_def_level=(-1), fv_count=0, fv_ident=makeIdent "dummy", fv_info_ptr=nilPtr}
 		= (EE, dummy_fv, heaps, error)
 	
@@ -1909,7 +1909,7 @@ where
 			TransformedBody {tb_args,tb_rhs}	// user defined case
 				| has_generic_info
 					| fun_arity<>st.st_arity
-						# error = reportError gc_ident gc_pos ("incorrect arity " +++ toString (fun_arity-1)
+						# error = reportError gc_ident.id_name gc_pos ("incorrect arity " +++ toString (fun_arity-1)
 																+++ ", expected " +++ toString (st.st_arity-1)) error
 						-> (funs_and_groups, fun_defs, td_infos, modules, heaps, error)	
 					#! fun = {fun & fun_ident = fun_ident, fun_type = Yes st}
@@ -1917,7 +1917,7 @@ where
 					-> (funs_and_groups, fun_defs, td_infos, modules, heaps, error)
 					# fun_body = TransformedBody {tb_args = tl tb_args, tb_rhs = tb_rhs}
 					| fun_arity-1<>st.st_arity
-						# error = reportError gc_ident gc_pos ("incorrect arity " +++ toString (fun_arity-1)
+						# error = reportError gc_ident.id_name gc_pos ("incorrect arity " +++ toString (fun_arity-1)
 																+++ ", expected " +++ toString st.st_arity) error
 						-> (funs_and_groups, fun_defs, td_infos, modules, heaps, error)	
 					#! fun = {fun & fun_ident = fun_ident, fun_body = fun_body, fun_type = Yes st}
@@ -2138,9 +2138,8 @@ where
 				#! (expr, heaps)
 					= buildGenericApp bimap_module bimap_index bimap_ident kind [] heaps		
 				= ((non_gen_var, TVI_Expr False expr), funs_and_groups, heaps)
-
 buildGenericCaseBody main_module_index {gc_ident,gc_pos} has_generic_info st predefs funs_and_groups td_infos modules heaps error
-	# error = reportError gc_ident gc_pos "cannot specialize to this type" error
+	# error = reportError gc_ident.id_name gc_pos "cannot specialize to this type" error
 	= (TransformedBody {tb_args=[], tb_rhs=EE}, funs_and_groups, td_infos, modules, heaps, error)
 
 //  convert generic type contexts into normal type contexts
@@ -2279,7 +2278,7 @@ where
 		# opt_class_info = lookupGenericClassInfo gtc_kind gen_classes
 		# (tc_class, error) = case opt_class_info of 
 			No
-				# error = reportError fun_name fun_pos "no generic cases for this kind" error  
+				# error = reportError fun_name.id_name fun_pos "no generic cases for this kind" error  
 				-> (TCGeneric gtc, error)
 			Yes class_info 
 				# clazz = 
@@ -2388,7 +2387,7 @@ where
 				= buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident (KindArrow [KindConst]) [arg_expr] heaps
 			= (expr, (td_infos, heaps, error))
 	specialize type (td_infos, heaps, error)
-		#! error = reportError gen_ident gen_pos "cannot specialize " error 
+		#! error = reportError gen_ident.id_name gen_pos "cannot specialize " error 
 		= (EE, (td_infos, heaps, error))
 
 	specialize_type_var tv=:{tv_info_ptr} (td_infos, heaps=:{hp_type_heaps=th=:{th_vars}}, error)		
@@ -2427,7 +2426,7 @@ where
 	specialize (GTSAppCons KindConst []) (funs_and_groups, heaps, error)
 		# (expr, funs_and_groups, heaps)
 			= bimap_id_expression main_module_index predefs funs_and_groups heaps
-		= (expr ,(funs_and_groups, heaps, error))
+		= (expr, (funs_and_groups, heaps, error))
 	specialize (GTSAppCons kind arg_types) st
 		#! (arg_exprs, st) = mapSt specialize arg_types st
 		= build_generic_app kind arg_exprs gen_index gen_ident st
@@ -2495,7 +2494,7 @@ where
 			= bimap_id_expression main_module_index predefs funs_and_groups heaps
 		= (expr ,(funs_and_groups, heaps, error))
 	specialize type (funs_and_groups, heaps, error)
-		#! error = reportError gen_ident gen_pos "cannot specialize " error 
+		#! error = reportError gen_ident.id_name gen_pos "cannot specialize " error 
 		= (EE, (funs_and_groups, heaps, error))
 
 	specialize_type_var tv=:{tv_info_ptr} (funs_and_groups, heaps=:{hp_type_heaps=th=:{th_vars}}, error)		
@@ -2772,7 +2771,7 @@ where
 			= bimap_id_expression main_module_index predefs funs_and_groups heaps
 		= (expr ,(funs_and_groups, modules, heaps, error))
 	specialize type (funs_and_groups, modules, heaps, error)
-		#! error = reportError gen_ident gen_pos "cannot specialize " error 
+		#! error = reportError gen_ident.id_name gen_pos "cannot specialize " error 
 		= (EE, (funs_and_groups, modules, heaps, error))
 
 	specialize_type_var tv=:{tv_info_ptr} (funs_and_groups, modules, heaps=:{hp_type_heaps=th=:{th_vars}}, error)		
@@ -3402,7 +3401,7 @@ where
 		= (st, [], th, error)
 	build_symbol_type st gatvs (KindArrow kinds) order th error
 		| order > 2
-			# error = reportError ident pos "kinds of order higher then 2 are not supported" error
+			# error = reportError ident.id_name pos "kinds of order higher then 2 are not supported" error
 			= (st, [], th, error)
 		
 		# (arg_sts, arg_gatvss, th, error) 
@@ -3529,7 +3528,7 @@ where
 				= No
 
 reportError name pos msg error=:{ea_file} 
-	# ea_file = ea_file <<< "Error " <<< (newPosition name pos) <<< ":" <<< msg <<< '\n'
+	# ea_file = ea_file <<< "Error " <<< (stringPosition name pos) <<< ":" <<< msg <<< '\n'
 	= { error & ea_file = ea_file , ea_ok = False }
 
 reportWarning name pos msg error=:{ea_file}
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index 0f77b44..24d77ec 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -1476,6 +1476,12 @@ instance == OverloadedListType
 	,	ip_file		:: !FileName
 	}
 
+::	StringPos =
+	{	sp_name		:: !String
+	,	sp_line		:: !Int
+	,	sp_file		:: !FileName
+	}
+
 :: FileName			:== String
 
 :: FunctName		:== String