add preliminary implementation of deriving instances using generics for testing purposes

frontend/check.icl

@@ -5,7 +5,7 @@ import StdEnv, compare_types
 import syntax, expand_types, parse, checksupport, utilities, checktypes, transform, predef
 import explicitimports, comparedefimp, checkFunctionBodies, containers, typesupport
 import typereify
-from checkgenerics import checkGenericDefs,checkGenericCaseDefs,convert_generic_instances,create_gencase_funtypes
+from checkgenerics import checkGenericDefs,checkGenericCaseDefs,convert_generic_instances,create_gencase_funtypes,get_generic_index
 
 cUndef :== (-1)
 cDummyArray :== {}
@@ -310,6 +310,21 @@ where
 					= check_icl_instance_members (class_member_n+1) instance_member_n member_mod_index ins_members class_members class_ident ins_pos ins_type
 												instance_types n_icl_functions new_instance_members member_defs type_defs icl_functions modules var_heap type_heaps cs
 				| ins_member.cim_ident == class_member.ds_ident
+					| icl_functions.[ins_member.cim_index].fun_body=:GenerateInstanceBody _
+						# ({fun_body=GenerateInstanceBody generic_ident},icl_functions) = icl_functions![ins_member.cim_index]
+						#! main_module_n = cs.cs_x.x_main_dcl_module_n
+						# (generic_index,cs) = get_generic_index generic_ident main_module_n cs
+
+						# ({me_type,me_class_vars,me_priority}, member_defs, modules)
+							= getMemberDef member_mod_index class_member.ds_index x_main_dcl_module_n member_defs modules
+						  (fun,icl_functions) = icl_functions![ins_member.cim_index];
+						  fun & fun_body = GenerateInstanceBodyChecked generic_ident generic_index, fun_arity = class_member.ds_arity, fun_priority = me_priority
+						  icl_functions & [ins_member.cim_index] = fun
+						  (instance_type,type_defs,modules,var_heap,type_heaps,cs)
+							= make_class_member_instance_type ins_type me_type me_class_vars type_defs modules var_heap type_heaps cs
+						  instance_types = [(ins_member.cim_index, instance_type) : instance_types]
+						= check_icl_instance_members (class_member_n+1) (instance_member_n+1) member_mod_index ins_members class_members class_ident ins_pos ins_type
+													instance_types n_icl_functions new_instance_members member_defs type_defs icl_functions modules var_heap type_heaps cs
 					#! instance_member_arity=icl_functions.[ins_member.cim_index].fun_arity
 					| instance_member_arity <> class_member.ds_arity
 						# cs & cs_error = checkError class_member.ds_ident ("defined with wrong arity ("+++toString instance_member_arity+++" instead of "+++toString class_member.ds_arity+++")") cs.cs_error
@@ -2376,16 +2391,16 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
 					| icl_mem_index < size icl_members
 						# icl_member = icl_members.[icl_mem_index]
 						| icl_member.cim_ident.id_name==dcl_member.cim_ident.id_name
-							# new_table = {new_table & [dcl_member.cim_index] = icl_member.cim_index}
+							# new_table & [dcl_member.cim_index] = icl_member.cim_index
 							= build_conversion_table_for_instances_of_members_with_default_instances (dcl_mem_index+1) (icl_mem_index+1) dcl_members icl_members new_table n_icl_functions icl_instance error
 						| icl_member.cim_ident.id_name<dcl_member.cim_ident.id_name
 							# error = checkErrorWithPosition icl_instance.ins_ident icl_instance.ins_pos (icl_member.cim_ident.id_name+++" is not a member of this class") error
 							= build_conversion_table_for_instances_of_members_with_default_instances dcl_mem_index (icl_mem_index+1) dcl_members icl_members new_table n_icl_functions icl_instance error
 							# icl_members = add_possible_default_instance dcl_member icl_mem_index n_icl_functions icl_members
-							# new_table = {new_table & [dcl_member.cim_index] = n_icl_functions}
+							# new_table & [dcl_member.cim_index] = n_icl_functions
 							= build_conversion_table_for_instances_of_members_with_default_instances (dcl_mem_index+1) (icl_mem_index+1) dcl_members icl_members new_table (n_icl_functions+1) icl_instance error
 						# icl_members = add_possible_default_instance dcl_member icl_mem_index n_icl_functions icl_members
-						# new_table = {new_table & [dcl_member.cim_index] = n_icl_functions}
+						# new_table & [dcl_member.cim_index] = n_icl_functions
 						= build_conversion_table_for_instances_of_members_with_default_instances (dcl_mem_index+1) (icl_mem_index+1) dcl_members icl_members new_table (n_icl_functions+1) icl_instance error
 					| icl_mem_index < size icl_members
 						# error = checkErrorWithPosition icl_instance.ins_ident icl_instance.ins_pos (icl_members.[icl_mem_index].cim_ident.id_name+++" is not a member of this class") error
@@ -2406,7 +2421,7 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
 				| mem_index < size dcl_members
 					# dcl_member = dcl_members.[mem_index]
 					# icl_member = icl_members.[mem_index]
-					# new_table = {new_table & [dcl_member.cim_index] = icl_member.cim_index}
+					# new_table & [dcl_member.cim_index] = icl_member.cim_index
 					= build_conversion_table_for_instances_of_members (inc mem_index) dcl_members icl_members new_table
 					= new_table
 

frontend/checkFunctionBodies.icl

@@ -365,9 +365,13 @@ where
 		# (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
 		= (Var { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, result_expr, expr_heap)
 
-checkFunctionBodies  GeneratedBody function_ident_for_errors e_input e_state e_info cs
+checkFunctionBodies GeneratedBody function_ident_for_errors e_input e_state e_info cs
 	= (GeneratedBody, [], e_state, e_info, cs)
 		//---> ("checkFunctionBodies: function to derive ", function_ident_for_errors)
+checkFunctionBodies (GenerateInstanceBodyChecked generic_ident generic_index) function_ident_for_errors e_input e_state e_info cs
+	= (GenerateInstanceBodyChecked generic_ident generic_index, [], e_state, e_info, cs)
+checkFunctionBodies (GenerateInstanceBody generic_ident) function_ident_for_errors e_input e_state e_info cs
+	= (GenerateInstanceBody generic_ident, [], e_state, e_info, cs)
 checkFunctionBodies  _ function_ident_for_errors e_input=:{ei_expr_level,ei_mod_index} e_state=:{es_var_heap, es_fun_defs} e_info cs
 	= abort ("checkFunctionBodies " +++ toString function_ident_for_errors +++ "\n")
 

frontend/checkgenerics.dcl

@@ -15,3 +15,5 @@ convert_generic_instances :: !Int !Int !*{#GenericCaseDef} !*{#ClassDef} !*Symbo
 
 create_gencase_funtypes :: !Index !*{#GenericCaseDef} !*Heaps
 			-> (!Index,![FunType],!*{#GenericCaseDef},!*Heaps)
+
+get_generic_index :: !Ident !Index !*CheckState -> (!GlobalIndex, !*CheckState)

frontend/parse.icl

@@ -453,10 +453,13 @@ where
 	   		# (gendef, pState) = wantGenericDefinition parseContext pos pState
 	   		= (True, gendef, pState)
 	try_definition parseContext DeriveToken pos pState
-		| ~(isGlobalContext parseContext)
+		| isGlobalContext parseContext
+			# (gendef, pState) = wantDeriveDefinition parseContext pos pState
+			= (True, gendef, pState)
+		| isInstanceDefsContext parseContext
+			# (derive_instance_def, pState) = wantDeriveInstanceDefinition parseContext pos pState
+			= (True, derive_instance_def, pState)
 			= (False,abort "no def(2)",parseError "definition" No "derive declarations are only at the global level" pState)   		
-	   		# (gendef, pState) = wantDeriveDefinition parseContext pos pState
-	   		= (True, gendef, pState)
 	try_definition parseContext InstanceToken pos pState
 		| ~(isGlobalContext parseContext)
 			= (False,abort "no def(2)",parseError "definition" No "instance declarations are only at the global level" pState)
@@ -1676,10 +1679,22 @@ wantInstanceDeclaration parseContext pi_pos pState
 		| isIclContext parseContext
 			# (begin_members, pState) = begin_member_group token pState
 			| not begin_members
+				# pi = {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
+						pi_specials = SP_None, pi_pos = pi_pos}
+				| token=:DeriveToken
+					# (token, pState) = nextToken FunctionContext pState
+					= case token of
+						IdentToken generic_function_name
+							# (member_ident, pState) = stringToIdent class_name IC_Expression pState
+							# (generic_ident, pState) = stringToIdent generic_function_name IC_Generic pState
+							# pState = wantEndOfDefinition "derive instance" pState
+							-> (PD_Instance {pim_pi = pi, pim_members = [PD_DeriveInstanceMember pi_pos member_ident generic_ident]}, pState)
+						_
+							# pState = parseError "derive instance member" (Yes token) "generic function name" pState
+							-> (PD_Instance {pim_pi = pi, pim_members = []}, pState)
+				
 				# pState = wantEndOfDefinition "instance declaration" (tokenBack pState)
-				= (PD_Instance {pim_pi = {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
-										  pi_specials = SP_None, pi_pos = pi_pos},
-								pim_members = []}, pState)
+				= (PD_Instance {pim_pi = pi, pim_members = []}, pState)
 				# (pi_members, pState) = wantDefinitions (SetInstanceDefsContext parseContext) pState
 				  pState = wantEndGroup "instance" pState
 				= (PD_Instance {pim_pi = {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
@@ -2196,6 +2211,25 @@ get_type_cons type pState
 	# pState = parseError "generic type" No "type constructor" pState
 	= (abort "no TypeCons", pState)
 
+wantDeriveInstanceDefinition :: !ParseContext !Position !*ParseState -> (!ParsedDefinition, !*ParseState)
+wantDeriveInstanceDefinition parseContext pos pState
+	# (token, pState) = nextToken FunctionContext pState
+	= case token of
+		IdentToken member_name
+			# (member_ident, pState) = stringToIdent member_name IC_Expression pState
+			# (token, pState) = nextToken FunctionContext pState
+			-> case token of
+				IdentToken generic_function_name
+					# (generic_ident, pState) = stringToIdent generic_function_name IC_Generic pState
+					# pState = wantEndOfDefinition "derive instance" pState
+					-> (PD_DeriveInstanceMember pos member_ident generic_ident,pState)
+				_
+					# pState = parseError "derive instance member" (Yes token) "generic function name" pState
+					-> (PD_Erroneous,pState)
+		_
+			# pState = parseError "derive instance member" (Yes token) "member name" pState
+			-> (PD_Erroneous,pState)
+
 /*
 	Type definitions
 */
@@ -4481,8 +4515,6 @@ where
 				= (False, abort "no case alt", pState)
 			= (False, abort "no case alt", tokenBack pState)
 
-//	caseSeperator t = t == EqualToken || t == ArrowToken // to enable Clean 1.3.x case expressions
-
 	// FIXME: it would be better if this would use (tryExpression cIsNotPattern)
 	// but there's no function tryExpression available yet
 	try_pattern :: !Token !ParseState -> (!Bool, ParsedExpr, !ParseState)

frontend/postparse.icl

@@ -376,6 +376,8 @@ instance collectFunctions FunDef where
 	collectFunctions fun_def=:{fun_body = ParsedBody bodies} icl_module ca
 		# (bodies, ca) = collectFunctions bodies icl_module ca
 		= ({fun_def & fun_body = ParsedBody bodies}, ca)
+	collectFunctions fun_def=:{fun_body = GenerateInstanceBody _} icl_module ca
+		= (fun_def, ca)
 
 instance collectFunctions ParsedBody where
 	collectFunctions pb=:{pb_rhs} icl_module ca
@@ -1658,6 +1660,12 @@ where
 					-> ([ fun : fun_defs ], ca)
 			_
 				-> collect_member_instances defs (postParseError fun_pos "function body expected" ca)
+	collect_member_instances [PD_DeriveInstanceMember pos member_ident generic_ident : defs] ca
+		# fun_body = GenerateInstanceBody generic_ident
+		  fun_def = {fun_ident = member_ident, fun_arity = 0, fun_priority = NoPrio, fun_type = No, fun_kind = (FK_Function False),
+					 fun_body = fun_body, fun_pos = pos, fun_lifted = 0, fun_info = EmptyFunInfo }
+		  (fun_defs, ca) = collect_member_instances defs ca
+		= ([fun_def : fun_defs], ca)
 	collect_member_instances [] ca
 	    = ([], ca)	
 

frontend/syntax.dcl

@@ -271,6 +271,7 @@ cIsNotAFunction :== False
 	|	PD_Generic GenericDef
 	| 	PD_GenericCase GenericCaseDef Ident
 	|	PD_Derive [GenericCaseDef]
+	|	PD_DeriveInstanceMember Position Ident Ident
 	|	PD_Erroneous
 
 ::	FunKind = FK_Function !Bool | FK_Macro | FK_Caf | FK_NodeDefOrFunction | FK_Unknown
@@ -719,6 +720,8 @@ FI_FusedMember :== 512			// used in module trans to mark fused versions of insta
 					| TransformedBody !TransformedBody
 					| Expanding ![FreeVar] // the parameters of the newly generated function
 					| GeneratedBody // the body will be generated automatically - for generics
+					| GenerateInstanceBody !Ident
+					| GenerateInstanceBodyChecked !Ident !GlobalIndex
 					| NoBody
 
 ::	FunDef =
@@ -1004,7 +1007,7 @@ cNotVarNumber :== -1
 	,	ct_result_type	:: !AType
 	,	ct_cons_types 	:: ![[AType]]
 	}
-		
+
 ::	SymbIdent =
 	{	symb_ident		:: !Ident
 	,	symb_kind		:: !SymbKind

frontend/transform.icl

@@ -1291,7 +1291,10 @@ partitionate_function mod_index max_fun_nr fun_index pi ps
 						)
 				-> (max_fun_nr, ps)
 		GeneratedBody
-			// do not allocate a group, it will be allocated during generic phase
+			// do not allocate a group, it will be allocated during the generic phase
+			-> (max_fun_nr, ps)
+		GenerateInstanceBodyChecked _ _
+			// do not allocate a group, it will be allocated during the generic phase
 			-> (max_fun_nr, ps)
 
 partitionate_called_function :: Int Int !Int PartitioningInfo !*PartitioningState -> (!Int,!*PartitioningState)
@@ -1322,7 +1325,10 @@ partitionate_called_function mod_index max_fun_nr fun_index pi ps
 						)
 				-> (max_fun_nr, ps)
 		GeneratedBody
-			// do not allocate a group, it will be allocated during generic phase
+			// do not allocate a group, it will be allocated during the generic phase
+			-> (max_fun_nr, ps)
+		GenerateInstanceBodyChecked _ _
+			// do not allocate a group, it will be allocated during the generic phase
 			-> (max_fun_nr, ps)
 
 index_in_ranges index [!{ir_from, ir_to}:ranges!]