remove TC; types

type constructors in dynamic types are now uniquely represented by the
descriptor of their TD_ (type definition) function

backend/backendconvert.icl

@@ -383,7 +383,8 @@ backEndConvertModules p s main_dcl_module_n var_heap attr_var_heap be
 
 backEndConvertModulesH :: PredefinedSymbols FrontEndSyntaxTree !Int *BackEndState -> *BackEndState
 backEndConvertModulesH predefs {fe_icl = 
-	fe_icl =: {icl_name, icl_functions, icl_common,icl_global_functions,icl_imported_objects,icl_foreign_exports,icl_used_module_numbers, icl_modification_time},
+	fe_icl =: {icl_name, icl_functions, icl_common,icl_global_functions,
+				icl_type_funs, icl_imported_objects,icl_foreign_exports,icl_used_module_numbers, icl_modification_time},
 	fe_components, fe_dcls, fe_arrayInstances}
 	main_dcl_module_n backEnd
 	// sanity check ...
@@ -398,7 +399,8 @@ backEndConvertModulesH predefs {fe_icl =
 					=	backEnd
 	#  backEnd
 		=	abort "front end abort" backEnd
-*/	#! backEnd = appBackEnd (BESetMainDclModuleN main_dcl_module_n) backEnd
+*/
+	#! backEnd = appBackEnd (BESetMainDclModuleN main_dcl_module_n) backEnd
 	#! backEnd
 		=	appBackEnd (BEDeclareModules (size fe_dcls)) backEnd
 	#! backEnd
@@ -442,7 +444,8 @@ backEndConvertModulesH predefs {fe_icl =
 	#! backEnd
 		=	appBackEnd (BEDeclareIclModule icl_name.id_name icl_modification_time (size icl_functions) (size icl_common.com_type_defs) (size icl_common.com_cons_defs) (size icl_common.com_selector_defs)) (backEnd -*-> "BEDeclareIclModule")
 	#! backEnd
-		=	declareFunctionSymbols icl_functions functionIndices icl_global_functions (backEnd -*-> "declareFunctionSymbols")
+		=	declareFunctionSymbols icl_functions functionIndices
+				(icl_type_funs ++ icl_global_functions) (backEnd -*-> "declareFunctionSymbols")
 	#! backEnd
 		=	declare main_dcl_module_n icl_common (backEnd -*-> "declare (main_dcl_module_n)")
 	#! backEnd
@@ -470,6 +473,16 @@ backEndConvertModulesH predefs {fe_icl =
 			with
 				dcl_common
 					=	currentDcl.dcl_common
+	# backEnd
+		=	foldSt beExportFunction exported_local_type_funs backEnd
+
+		with	
+			exported_local_type_funs
+				| False && currentDcl.dcl_module_kind == MK_None
+					=	[]
+				// otherwise
+					=	flatten [[r.ir_from .. r.ir_to-1]
+									\\ r <- [icl_type_funs!!1]]
 	# backEnd = bindSpecialIdents predefs icl_used_module_numbers backEnd
 	#! backEnd = removeExpandedTypesFromDclModules fe_dcls icl_used_module_numbers backEnd
 	=	(backEnd -*-> "backend done")
@@ -483,7 +496,9 @@ declareOtherDclModules dcls main_dcl_module_n used_module_numbers
 where
 	declareOtherDclModule :: ModuleIndex DclModule -> BackEnder
 	declareOtherDclModule moduleIndex dclModule
-		| moduleIndex == main_dcl_module_n || moduleIndex == cPredefinedModuleIndex || not (inNumberSet moduleIndex used_module_numbers)
+		| moduleIndex == main_dcl_module_n
+		|| moduleIndex == cPredefinedModuleIndex
+		|| not (inNumberSet moduleIndex used_module_numbers)
 			=	identity
 		// otherwise
 			=	declareDclModule moduleIndex dclModule
@@ -494,7 +509,9 @@ defineOtherDclModules dcls main_dcl_module_n used_module_numbers
 where
 	defineOtherDclModule :: ModuleIndex DclModule -> BackEnder
 	defineOtherDclModule moduleIndex dclModule
-		| moduleIndex == main_dcl_module_n || moduleIndex == cPredefinedModuleIndex || not (inNumberSet moduleIndex used_module_numbers)
+		| moduleIndex == main_dcl_module_n
+		|| moduleIndex == cPredefinedModuleIndex
+		|| not (inNumberSet moduleIndex used_module_numbers)
 			=	identity		
 		// otherwise
 			=	defineDclModule moduleIndex dclModule
@@ -518,9 +535,11 @@ declareDclModule moduleIndex {dcl_name, dcl_modification_time, dcl_common, dcl_f
 	=	appBackEnd (BEDeclareDclModule moduleIndex dcl_name.id_name dcl_modification_time (isSystem dcl_module_kind) (size dcl_functions) (size dcl_common.com_type_defs) (size dcl_common.com_cons_defs) (size dcl_common.com_selector_defs))
 
 defineDclModule :: ModuleIndex DclModule -> BackEnder
-defineDclModule moduleIndex {dcl_name, dcl_common, dcl_functions,dcl_instances}
+defineDclModule moduleIndex
+		{dcl_name, dcl_common, dcl_functions, dcl_type_funs, dcl_instances}
 	=	declare moduleIndex dcl_common
-	o`	declareFunTypes moduleIndex dcl_functions dcl_instances.ir_from
+	o`	declareFunTypes moduleIndex dcl_functions
+			[{ir_from = 0, ir_to = dcl_instances.ir_from}, dcl_type_funs]
 
 removeExpandedTypesFromDclModules :: {#DclModule} NumberSet -> BackEnder
 removeExpandedTypesFromDclModules dcls used_module_numbers
@@ -654,7 +673,6 @@ declareFunctionSymbols functions functionIndices globalFunctions backEnd
 			where
 				functionName :: {#Char} Int [IndexRange] -> {#Char}
 				functionName name functionIndex icl_global_functions
-//					| trace_t ("|"+++toString functionIndex)
 					| index_in_ranges functionIndex icl_global_functions
 						=	name
 						=	(name +++ ";" +++ toString functionIndex)
@@ -744,28 +762,30 @@ instance declareWithIndex (TypeDef a) where
 	declareWithIndex typeIndex moduleIndex {td_ident}
 		=	appBackEnd (BEDeclareType typeIndex moduleIndex td_ident.id_name)
 
-declareFunTypes :: ModuleIndex {#FunType} Int -> BackEnder
-declareFunTypes moduleIndex funTypes nrOfDclFunctions
-		=	foldStateWithIndexA (declareFunType moduleIndex nrOfDclFunctions) funTypes
+declareFunTypes :: ModuleIndex {#FunType} [IndexRange] -> BackEnder
+declareFunTypes moduleIndex funTypes ranges
+		=	foldStateWithIndexA (declareFunType moduleIndex ranges) funTypes
 
-declareFunType :: ModuleIndex Index Int FunType -> BackEnder
-declareFunType moduleIndex nrOfDclFunctions functionIndex {ft_ident, ft_type_ptr}
+declareFunType :: ModuleIndex [IndexRange] Int FunType -> BackEnder
+declareFunType moduleIndex ranges functionIndex {ft_ident, ft_type_ptr}
 	= \be0 -> let (vi,be) = read_from_var_heap ft_type_ptr be0 in
 					(case vi of
 						VI_ExpandedType expandedType
-							->	beDeclareRuleType functionIndex moduleIndex (functionName ft_ident.id_name functionIndex nrOfDclFunctions)
+							->	beDeclareRuleType functionIndex moduleIndex (functionName ft_ident.id_name functionIndex ranges)
 							o`	beDefineRuleType functionIndex moduleIndex (convertTypeAlt functionIndex moduleIndex expandedType)
 						_
 							->	identity) be
 		where
-			functionName :: {#Char} Int Int -> {#Char}
-			functionName name functionIndex nrOfDclFunctions 
-//				| trace_tn (name+++(if (functionIndex < nrOfDclFunctions) "" (";" +++ toString functionIndex)))
-
-				| functionIndex < nrOfDclFunctions
+			functionName :: {#Char} Int [IndexRange] -> {#Char}
+			functionName name functionIndex ranges 
+				| index_in_ranges functionIndex ranges
 					=	name
-				// otherwise
-					=	name +++ ";" +++ toString functionIndex
+					=	(name +++ ";" +++ toString functionIndex)
+				where
+					index_in_ranges index [{ir_from, ir_to}:ranges]
+						= (index>=ir_from && index < ir_to) || index_in_ranges index ranges;
+					index_in_ranges index []
+						= False
 
 defineTypes :: ModuleIndex {#ConsDef} {#SelectorDef} {#CheckedTypeDef} -> BackEnder
 defineTypes moduleIndex constructors selectors types

backendC/CleanCompilerSources/backend.c

@@ -502,7 +502,10 @@ BEDeclareModules (int nModules)
 	gBEState.be_modules		= (BEModuleP) ConvertAlloc (nModules * sizeof (BEModuleS));
 
 	for (i = 0; i < nModules; i++)
+	{
 		gBEState.be_modules [i].bem_name	= NULL;
+		gBEState.be_modules [i].bem_nFunctions	= 0;
+	}
 } /* BEDeclareModules */
 
 BESymbolP
@@ -3431,15 +3434,21 @@ BEExportFunction (int functionIndex)
 
 	dclModule	= &gBEState.be_icl.beicl_dcl_module;
 
-	Assert ((unsigned int) functionIndex < dclModule->bem_nFunctions);
-	functionSymbol	= &dclModule->bem_functions [functionIndex];
-	Assert (functionSymbol->symb_kind == definition);
-	dclDef	= functionSymbol->symb_def;
+	if (((unsigned int) functionIndex < dclModule->bem_nFunctions))
+	{
+		functionSymbol	= &dclModule->bem_functions [functionIndex];
+		Assert (functionSymbol->symb_kind == definition);
+		dclDef	= functionSymbol->symb_def;
+	
+		dclDef->sdef_dcl_icl	= iclDef;
+
+		Assert (strcmp (iclDef->sdef_ident->ident_name, dclDef->sdef_ident->ident_name) == 0);
+	}
+	else
+		dclDef	= NULL;
 
-	Assert (strcmp (iclDef->sdef_ident->ident_name, dclDef->sdef_ident->ident_name) == 0);
 
 	iclDef->sdef_dcl_icl	= dclDef;
-	dclDef->sdef_dcl_icl	= iclDef;
 
 	iclDef->sdef_exported = True;
 } /* BEExportFunction */

frontend/convertDynamics.icl

@@ -646,14 +646,12 @@ where
 			# predef_type_index
 				=	type_index + FirstTypePredefinedSymbolIndex
 			=	constructorExp (predefinedTypeConstructor predef_type_index) SK_Function 0 ci
-	typeConstructor (GTT_Constructor cons_ident fun_ident) ci
-		# type_cons
-			=	App {app_symb = cons_ident, app_args = [], app_info_ptr = nilPtr}
+	typeConstructor (GTT_Constructor fun_ident) ci
 		# type_fun
 			=	App {app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr}
 		# (to_tc_symb, ci)
 			=	getSymbol PD_Dyn__to_TypeCodeConstructor SK_Function 2 ci 
-		=	(App {app_symb = to_tc_symb, app_args = [type_cons, type_fun], app_info_ptr = nilPtr}, ci)
+		=	(App {app_symb = to_tc_symb, app_args = [type_fun], app_info_ptr = nilPtr}, ci)
 	typeConstructor (GTT_Basic basic_type) ci
 		=	constructorExp (basicTypeConstructor basic_type) SK_Function 0 ci
 	typeConstructor GTT_Function ci

frontend/overloading.icl

@@ -1293,35 +1293,19 @@ toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} c
 	| module_index == cPredefinedModuleIndex
 		= GTT_PredefTypeConstructor type
 	// otherwise
-		# tc_type_index
-			=	type_index + 1
-		# types
-			=	common_defs.[module_index].com_type_defs
-		// sanity check ...
-		# type_ident
-			=	types.[type_index].td_ident.id_name
+		# type
+			=	common_defs.[module_index].com_type_defs.[type_index]
 		# td_fun_index
-			=	types.[type_index].td_fun_index
-		# tc_type_name
-			=	types.[tc_type_index].td_ident.id_name
-		| "TC;" +++ type_ident <> tc_type_name
-			=	fatal "toTypeCodeConstructor" ("name mismatch (" +++ type_ident +++ ", " +++ tc_type_name +++ ")")
-		// ... sanity check
-		# ({td_rhs=AlgType [{ds_ident, ds_index}:_]})
-				=	types.[tc_type_index]
-		# type_constructor
-			=	{	symb_ident = ds_ident
-				,	symb_kind = SK_Constructor {glob_module = module_index, glob_object = ds_index}
-				}
+			=	type.td_fun_index
 		// sanity check ...
 		| td_fun_index == NoIndex
-			=	fatal "toTypeCodeConstructor" ("no function (" +++ type_ident +++ ")")
+			=	fatal "toTypeCodeConstructor" ("no function (" +++ type.td_ident.id_name +++ ")")
 		// ... sanity check
 		# type_fun
-			=	{	symb_ident = {ds_ident & id_info = nilPtr} // this is wrong but let's give it a try
+			=	{	symb_ident = {type.td_ident & id_info = nilPtr} // this is wrong but let's give it a try
 				,	symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index}
 				}
-		= GTT_Constructor type_constructor type_fun
+		= GTT_Constructor type_fun
 
 fatal :: {#Char} {#Char} -> .a
 fatal function_name message

frontend/postparse.icl

@@ -1477,54 +1477,9 @@ reorganiseDefinitionsAndAddTypes mod_ident support_dynamics icl_module defs ca
 			,	import_file_position = NoPos
 			}
 		# imports = if (mod_ident == clean_types_module_ident) [] [clean_types_module]
-		# (rev_defs, ca)
-			=	addTypeConstructors defs [PD_Import imports] ca
-		= reorganiseDefinitions icl_module (reverse rev_defs) 0 0 0 0 ca
+		= reorganiseDefinitions icl_module [PD_Import imports : defs] 0 0 0 0 ca
+	// otherwise
 		= reorganiseDefinitions icl_module defs 0 0 0 0 ca
-	where
-		addTypeConstructors [] rev_defs ca
-			=	(rev_defs, ca)
-		addTypeConstructors [PD_Type type_def : defs] rev_defs ca
-			# (type_def, tc_def, ca)
-				=	addTypeConstructor type_def ca
-			= addTypeConstructors defs [PD_Type tc_def, PD_Type type_def : rev_defs] ca
-		addTypeConstructors [def : defs] rev_defs ca
-			=	addTypeConstructors defs [def : rev_defs] ca
-
-addTypeConstructor def=:{td_ident, td_attribute, td_attrs, td_args, td_arity, td_pos} ca=:{ca_hash_table}
-	# tc_name = "TC;" +++ td_ident.id_name
-	# ({boxed_ident=tc_cons_ident}, ca_hash_table) = putIdentInHashTable tc_name IC_Expression ca_hash_table
-	# ({boxed_ident=tc_type_ident}, ca_hash_table) = putIdentInHashTable tc_name IC_Type ca_hash_table
-	=	(def, type_tc_def tc_type_ident tc_cons_ident td_ident td_attribute td_attrs td_args
-												td_arity td_pos, { ca & ca_hash_table = ca_hash_table })
-	where
-		type_tc_def ident cons_ident type_ident attr attrs args arity position
-			= 	{	td_ident	= ident
-				,	td_index = NoIndex
-				,	td_arity = arity
-				,	td_args	= args
-				,	td_attrs = attrs
-				,	td_context = []
-				,	td_rhs = ConsList [type_tc_cons cons_ident type_ident args arity position]
-				,	td_attribute = attr
-				,	td_pos = position
-				,	td_used_types = []
-				,	td_fun_index = NoIndex
-				}
-		type_tc_cons cons_ident type_ident args arity position
-			=	{	pc_cons_ident = cons_ident
-				,	pc_cons_arity = 1
-				,	pc_exi_vars	= []
-				,	pc_arg_types = [type type_ident args arity]
-				,	pc_args_strictness	= NotStrict
-				,	pc_cons_prio = NoPrio
-				,	pc_cons_pos	= position
-				}
-		type type_ident args arity
-			=	{	at_attribute = TA_None
-				,	at_type = TA (MakeNewTypeSymbIdent type_ident arity)
-						[{at_attribute = TA_None, at_type = TV arg.atv_variable} \\ arg <- args]
-				}
 
 belongsToTypeSpec name prio new_name is_infix :==
 	name == new_name && sameFixity prio is_infix

frontend/syntax.dcl

@@ -1289,7 +1289,7 @@ instance == OverloadedListType
 
 ::	GlobalTCType
 	=	GTT_Basic !BasicType
-	|	GTT_Constructor !SymbIdent !SymbIdent // type_cons type_fun
+	|	GTT_Constructor !SymbIdent
 	|	GTT_PredefTypeConstructor !(Global Index)
 	|	GTT_Function
 

frontend/typereify.icl

@@ -598,8 +598,8 @@ instance reify GlobalTCType where
 			# predef_type_index
 				=	type_index + FirstTypePredefinedSymbolIndex
 			=	function (predefinedTypeConstructor predef_type_index)
-	reify (GTT_Constructor type_cons type_fun)
-		=	function PD_Dyn__to_TypeCodeConstructor ` type_cons ` type_fun
+	reify (GTT_Constructor type_fun)
+		=	function PD_Dyn__to_TypeCodeConstructor ` type_fun
 
 predefinedTypeConstructor predef_type_index
 	| predef_type_index == PD_ListType
@@ -638,38 +638,21 @@ basic value
 // copied and adopted from overloading
 toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} common_defs
 	| module_index == cPredefinedModuleIndex
-		=	GTT_PredefTypeConstructor type
+		= GTT_PredefTypeConstructor type
 	// otherwise
-		# tc_type_index
-			=	type_index + 1
-		# types
-			=	common_defs.[module_index].com_type_defs
-		// sanity check ...
-		# type_ident
-			=	types.[type_index].td_ident.id_name
-		# tc_type_name
-			=	types.[tc_type_index].td_ident.id_name
-		| "TC;" +++ type_ident <> tc_type_name
-			=	fatal "toTypeCodeConstructor" ("name mismatch (" +++ type_ident +++ ", " +++ tc_type_name +++ ")")
-		// ... sanity check
-		# ({td_rhs=AlgType [{ds_ident, ds_index}:_]})
-				=	types.[tc_type_index]
-		# type_constructor
-			=	{	symb_ident = ds_ident
-				,	symb_kind = SK_Constructor {glob_module = module_index, glob_object = ds_index}
-				}
+		# type
+			=	common_defs.[module_index].com_type_defs.[type_index]
 		# td_fun_index
-			=	types.[type_index].td_fun_index
+			=	type.td_fun_index
 		// sanity check ...
 		| td_fun_index == NoIndex
-			=	fatal "toTypeCodeConstructor" ("no function (" +++ type_ident
-						+++ " type " +++ toString type_index +++ " module " +++ toString module_index +++ ")")
+			=	fatal "toTypeCodeConstructor" ("no function (" +++ type.td_ident.id_name +++ ")")
 		// ... sanity check
 		# type_fun
-			=	{	symb_ident = {ds_ident & id_info = nilPtr} // this is wrong but let's give it a try
+			=	{	symb_ident = {type.td_ident & id_info = nilPtr} // this is wrong but let's give it a try
 				,	symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index}
 				}
-		=	GTT_Constructor type_constructor type_fun
+		= GTT_Constructor type_fun
 
 fatal :: {#Char} {#Char} -> .a
 fatal function_name message