add instance declarations with a qualified class name

frontend/analtypes.icl

@@ -1018,12 +1018,12 @@ where
 			= check_kinds_of_class_instances common_defs (inc instance_index) instance_defs class_infos as
 	where	
 		check_kinds_of_class_instance :: !{#CommonDefs} !ClassInstance  !*ClassDefInfos !*AnalyseState -> (!*ClassDefInfos, !*AnalyseState)
-		check_kinds_of_class_instance common_defs {ins_class_index,ins_class_ident={ci_ident,ci_arity},ins_ident,ins_pos,ins_type={it_vars,it_types,it_context}} class_infos
+		check_kinds_of_class_instance common_defs {ins_class_index,ins_class_ident={ci_ident=Ident class_ident,ci_arity},ins_ident,ins_pos,ins_type={it_vars,it_types,it_context}} class_infos
 					as=:{as_type_var_heap,as_kind_heap,as_error}
 			# as_error = pushErrorAdmin (newPosition ins_ident ins_pos) as_error
 			  (as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars it_vars as_type_var_heap as_kind_heap
 			  as = { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap, as_error = as_error }
-			  ins_class = {glob_module=ins_class_index.gi_module,glob_object={ds_index=ins_class_index.gi_index,ds_ident=ci_ident,ds_arity=ci_arity}}
+			  ins_class = {glob_module=ins_class_index.gi_module,glob_object={ds_index=ins_class_index.gi_index,ds_ident=class_ident,ds_arity=ci_arity}}
 			  context = {tc_class = TCClass ins_class, tc_types = it_types, tc_var = nilPtr}
 			  (class_infos, as) = determine_kinds_of_type_contexts common_defs [context : it_context] class_infos as
 			= (class_infos, { as & as_error = popErrorAdmin as.as_error})
@@ -1107,7 +1107,7 @@ where
 			  (class_infos, as) = check_kinds_of_symbol_type common_defs ft_type class_infos
 			  							{ as & as_error = as_error }			  								
 			= (class_infos, { as & as_error = popErrorAdmin as.as_error})
-			
+
 	check_kinds_of_symbol_type :: !{#CommonDefs} !SymbolType !*ClassDefInfos !*AnalyseState -> (!*ClassDefInfos, !*AnalyseState)
 	check_kinds_of_symbol_type common_defs {st_vars,st_result,st_args,st_context} class_infos as=:{as_type_var_heap,as_kind_heap}
 		# (as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars st_vars as_type_var_heap as_kind_heap

frontend/check.icl

@@ -180,23 +180,38 @@ where
 			= (instance_defs, is, type_heaps, cs)
 
 	check_instance :: !ClassInstance !Index !u:InstanceSymbols !*TypeHeaps !*CheckState -> (!ClassInstance, !u:InstanceSymbols, !*TypeHeaps, !*CheckState)
-	check_instance ins=:{ins_class_ident={ci_ident={id_name,id_info}},ins_pos,ins_ident} module_index is type_heaps cs=:{cs_symbol_table}
-		#  	(entry, cs_symbol_table) = readPtr id_info cs_symbol_table
+	check_instance ins=:{ins_class_ident={ci_ident=Ident {id_name,id_info}},ins_pos,ins_ident} module_index is type_heaps cs=:{cs_symbol_table}
+		#  	({ste_index,ste_kind}, cs_symbol_table) = readPtr id_info cs_symbol_table
 		# 	cs = pushErrorAdmin (newPosition ins_ident ins_pos) { cs & cs_symbol_table = cs_symbol_table }
-		#   (ins, is, type_heaps, cs) = case entry.ste_kind of
+		#   (ins, is, type_heaps, cs) = case ste_kind of
 				STE_Class
-					# (class_def, is) = is!is_class_defs.[entry.ste_index]
-					-> check_class_instance	class_def module_index entry.ste_index module_index ins is type_heaps cs 
-				STE_Imported STE_Class decl_index	
- 					# (class_def, is) = is!is_modules.[decl_index].dcl_common.com_class_defs.[entry.ste_index]
-					-> check_class_instance class_def module_index entry.ste_index decl_index ins is type_heaps cs
+					# (class_def, is) = is!is_class_defs.[ste_index]
+					-> check_class_instance	class_def module_index ste_index module_index ins is type_heaps cs 
+				STE_Imported STE_Class decl_index
+ 					# (class_def, is) = is!is_modules.[decl_index].dcl_common.com_class_defs.[ste_index]
+					-> check_class_instance class_def module_index ste_index decl_index ins is type_heaps cs
 				ste -> (ins, is, type_heaps, { cs & cs_error = checkError id_name "class undefined" cs.cs_error })
 		= (ins, is, type_heaps, popErrorAdmin cs)
+	check_instance ins=:{ins_class_ident={ci_ident=QualifiedIdent module_ident class_name},ins_pos,ins_ident}
+			module_index is type_heaps cs
+		# cs = pushErrorAdmin (newPosition ins_ident ins_pos) cs
+		# (found,{decl_kind,decl_ident=type_ident,decl_index=class_index},cs) = search_qualified_ident module_ident class_name ClassNameSpaceN cs
+		| not found
+			# cs = {cs & cs_error = checkError ("'"+++module_ident.id_name+++"'."+++class_name) "class undefined" cs.cs_error}
+			= (ins, is, type_heaps, popErrorAdmin cs)
+			= case decl_kind of
+				STE_Imported STE_Class class_module
+					# (class_def, is) = is!is_modules.[class_module].dcl_common.com_class_defs.[class_index]
+					# ins = {ins & ins_class_ident.ci_ident=Ident class_def.class_ident}
+					-> check_class_instance class_def module_index class_index class_module ins is type_heaps cs
+				_
+					# cs = {cs & cs_error = checkError ("'"+++module_ident.id_name+++"'."+++class_name) "class undefined" cs.cs_error}
+					-> (ins, is, type_heaps, popErrorAdmin cs)
 
 	check_class_instance :: ClassDef !Index !Index !Index !ClassInstance !u:InstanceSymbols !*TypeHeaps !*CheckState 
 		-> (!ClassInstance, !u:InstanceSymbols, !*TypeHeaps, !*CheckState)
 	check_class_instance class_def module_index class_index class_mod_index
-			ins=:{ins_class_ident=ins_class_ident=:{ci_ident={id_name,id_info},ci_arity},ins_type,ins_specials,ins_pos,ins_ident}
+			ins=:{ins_class_ident=ins_class_ident=:{ci_ident,ci_arity},ins_type,ins_specials,ins_pos,ins_ident}
 			is=:{is_class_defs,is_modules} type_heaps cs=:{cs_symbol_table}	
 		| class_def.class_arity == ci_arity
 			# ins_class_index = {gi_index = class_index, gi_module = class_mod_index}
@@ -205,6 +220,7 @@ where
 							is.is_type_defs is.is_class_defs is.is_modules type_heaps cs
 			  is = { is & is_type_defs = is_type_defs, is_class_defs = is_class_defs, is_modules = is_modules }
 			= ({ins & ins_class_index = ins_class_index, ins_type = ins_type, ins_specials = ins_specials}, is, type_heaps, cs)
+			# (Ident {id_name}) = ci_ident
 			# cs = {cs & cs_error = checkError id_name ("wrong arity: expected "+++toString class_def.class_arity+++" found "+++toString ci_arity) cs.cs_error}
 			= (ins, is, type_heaps, cs)
 

frontend/explicitimports.icl

@@ -600,9 +600,9 @@ instance check_completeness ClassDef where
 		= check_completeness class_context cci ccs
 		
 instance check_completeness ClassInstance where
-	check_completeness {ins_class_index={gi_module,gi_index},ins_class_ident={ci_ident},ins_type} cci ccs
+	check_completeness {ins_class_index={gi_module,gi_index},ins_class_ident={ci_ident=Ident class_ident},ins_type} cci ccs
 		= check_completeness ins_type cci
-		  (check_whether_ident_is_imported ci_ident gi_module gi_index STE_Class cci ccs)
+		  (check_whether_ident_is_imported class_ident gi_module gi_index STE_Class cci ccs)
 
 instance check_completeness ConsDef
   where

frontend/generics1.icl

@@ -1841,7 +1841,7 @@ where
 			#! class_ident = genericIdentToClassIdent gc_ident.id_name this_kind
 			#! ins = 
 			 	{	ins_class_index = {gi_module=gs_main_module, gi_index=class_index}
-			 	,	ins_class_ident = {ci_ident=class_ident, ci_arity=1}
+			 	,	ins_class_ident = {ci_ident=Ident class_ident, ci_arity=1}
 				,	ins_ident 	= class_ident
 				,	ins_type 	= ins_type
 				,	ins_members	= {{cim_ident=ds_ident,cim_arity=ds_arity,cim_index=ds_index}}
@@ -1920,7 +1920,7 @@ where
 		# class_ds = {ds_index = class_index, ds_arity=1, ds_ident=class_ident}
 		#! ins =
 		 	{	ins_class_index = {gi_module=gs_main_module, gi_index=class_index}
-		 	,	ins_class_ident = {ci_ident=class_ident, ci_arity=1}
+		 	,	ins_class_ident = {ci_ident=Ident class_ident, ci_arity=1}
 			,	ins_ident 	= class_ident
 			,	ins_type 	= ins_type
 			,	ins_members	= {class_instance_member}

frontend/parse.icl

 implementation module parse
 
 import StdEnv
-import scanner, syntax, hashtable, utilities, predef, containers, compilerSwitches
+import scanner, syntax, hashtable, utilities, predef, containers
 
 ParseOnly :== False
 
@@ -715,7 +715,7 @@ where
 			# (subst, pState) = want_rest_substitutions type_var pState
 			= (True, subst, wantEndOfDefinition "substitution" pState)
 			= (False, [], pState)
-	
+
 	want_rest_substitutions type_var pState
 		# pState = wantToken GeneralContext "specials" EqualToken pState
 		  (type, pState) = want pState
@@ -1341,37 +1341,47 @@ wantClassDefinition parseContext pos pState
 
 wantInstanceDeclaration :: !ParseContext !Position !ParseState -> (!ParsedDefinition, !ParseState)
 wantInstanceDeclaration parseContext pi_pos pState
-	# (class_name, pState) = want pState
-	  (pi_class, pState) = stringToIdent class_name IC_Class pState
-	  ((pi_types, pi_context), pState) = want_instance_type pState
-	  (pi_ident, pState) = stringToIdent class_name (IC_Instance pi_types) pState
-	# (token, pState) = nextToken TypeContext pState
-	| isIclContext parseContext
-		# pState = want_begin_group token pState
-		  (pi_members, pState) = wantDefinitions (SetClassOrInstanceDefsContext parseContext) pState
-		  pState = wantEndGroup "instance" pState
-
-		= (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
-						pi_members = pi_members, pi_specials = SP_None, pi_pos = pi_pos}, pState)
-	// otherwise // ~ (isIclContext parseContext)
-		| token == CommaToken
-			# (pi_types_and_contexts, pState)	= want_instance_types pState
-			  (idents, pState)		= seqList [stringToIdent class_name (IC_Instance type) \\ (type,context) <- pi_types_and_contexts] pState
-			= (PD_Instances
-				[	{ pi_class = pi_class, pi_ident = ident, pi_types = type, pi_context = context
-					, pi_members = [], pi_specials = SP_None, pi_pos = pi_pos}
-				\\	(type,context)	<- [ (pi_types, pi_context) : pi_types_and_contexts ]
-				&	ident			<- [ pi_ident : idents ]
-				]
-			  , pState
-			  )
-		// otherwise // token <> CommaToken
-			# (specials, pState) = optionalSpecials (tokenBack pState)
-			  pState = wantEndOfDefinition "instance declaration" pState
+	# (token, pState) = nextToken GeneralContext pState
+	= case token of
+		IdentToken class_name
+			# (pi_class, pState) = stringToIdent class_name IC_Class pState
+			-> want_instance_declaration class_name (Ident pi_class) parseContext pi_pos pState
+		QualifiedIdentToken module_name class_name
+			# (module_ident, pState) = stringToQualifiedModuleIdent module_name class_name IC_Class pState
+			-> want_instance_declaration class_name (QualifiedIdent module_ident class_name) parseContext pi_pos pState
+		_
+			# pState = parseError "String" (Yes token) "identifier" pState
+			# (pi_class, pState) = stringToIdent "" IC_Class pState
+			-> want_instance_declaration "" (Ident pi_class) parseContext pi_pos pState
+	where
+	want_instance_declaration class_name pi_class parseContext pi_pos pState
+		# ((pi_types, pi_context), pState) = want_instance_type pState
+		  (pi_ident, pState) = stringToIdent class_name (IC_Instance pi_types) pState
+		# (token, pState) = nextToken TypeContext pState
+		| isIclContext parseContext
+			# pState = want_begin_group token pState
+			  (pi_members, pState) = wantDefinitions (SetClassOrInstanceDefsContext parseContext) pState
+			  pState = wantEndGroup "instance" pState
 			= (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
-							pi_members = [], pi_specials = specials, pi_pos = pi_pos}, pState)
-		
-where
+							pi_members = pi_members, pi_specials = SP_None, pi_pos = pi_pos}, pState)
+		// otherwise // ~ (isIclContext parseContext)
+			| token == CommaToken
+				# (pi_types_and_contexts, pState)	= want_instance_types pState
+				  (idents, pState)		= seqList [stringToIdent class_name (IC_Instance type) \\ (type,context) <- pi_types_and_contexts] pState
+				= (PD_Instances
+					[	{ pi_class = pi_class, pi_ident = ident, pi_types = type, pi_context = context
+						, pi_members = [], pi_specials = SP_None, pi_pos = pi_pos}
+					\\	(type,context)	<- [ (pi_types, pi_context) : pi_types_and_contexts ]
+					&	ident			<- [ pi_ident : idents ]
+					]
+				  , pState
+				  )
+			// otherwise // token <> CommaToken
+				# (specials, pState) = optionalSpecials (tokenBack pState)
+				  pState = wantEndOfDefinition "instance declaration" pState
+				= (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
+								pi_members = [], pi_specials = specials, pi_pos = pi_pos}, pState)
+
 	want_begin_group token pState  // For JvG layout
 		# // (token, pState) = nextToken TypeContext pState PK
 		  (token, pState)

frontend/syntax.dcl

@@ -295,7 +295,7 @@ cNameLocationDependent :== True
 	}
 	
 ::	ParsedInstance member =
-	{	pi_class 	:: !Ident
+	{	pi_class 	:: !IdentOrQualifiedIdent
 	,	pi_ident	:: !Ident
 	,	pi_types	:: ![Type]
 	,	pi_context	:: ![TypeContext]
@@ -304,6 +304,10 @@ cNameLocationDependent :== True
 	,	pi_specials	:: !Specials
 	}
 
+::	IdentOrQualifiedIdent
+	= Ident !Ident
+	| QualifiedIdent /*module*/!Ident !String
+
 /*
 	Objects of type Specials are used to specify specialized instances of overloaded functions.
 	These can only occur in definition modules. After parsing the SP_ParsedSubstitutions alternative
@@ -449,7 +453,7 @@ cNameLocationDependent :== True
 	}
 
 ::	ClassIdent =
-	{	ci_ident		:: !Ident
+	{	ci_ident		:: !IdentOrQualifiedIdent
 	,	ci_arity		:: !Int
 	}
 
@@ -666,7 +670,7 @@ cIsALocalVar	:== False
 	,	cc_linear_bits	::![Bool]
 	,	cc_producer		::!ProdClass
 	}
-		
+
 ::	ConsClass	:== Int
 
 ::	ProdClass	:== Bool
@@ -1436,7 +1440,7 @@ instance <<< (Module a) | <<< a, ParsedDefinition, InstanceType, AttributeVar, T
 			 IndexRange,
 			 FunType,
 			 GenericClassInfo,
-			 TCClass
+			 TCClass, IdentOrQualifiedIdent
 
 instance <<< FunctionBody
 

frontend/syntax.icl

@@ -941,6 +941,13 @@ where
 		_ 
 			= file <<< "STE_???"
 
+instance <<< IdentOrQualifiedIdent
+where
+	(<<<) file (Ident ident)
+		= file <<< ident
+	(<<<) file (QualifiedIdent module_ident name)
+		= file<<<'\''<<<module_ident<<<"'."<<<name
+
 readable :: !Ident -> String // somewhat hacky
 readable {id_name}
 	| size id_name>0 && id_name.[0]=='_'