generics1.icl

//**************************************************************************************
// Generic programming features 
//**************************************************************************************

implementation module generics1

import StdEnv,compare_types
import check
from checktypes import createClassDictionaries
from transform import ::Group
import genericsupport

// Data types

:: FunDefs :== {#FunDef}
:: Modules :== {#CommonDefs}
:: DclModules :== {#DclModule}
:: Groups :== {!Group}

:: FunsAndGroups= ! {
		fg_fun_index :: !Index,
		fg_group_index :: !Index,
		fg_funs :: ![FunDef],
		fg_groups :: ![Group],
		fg_bimap_functions :: !BimapFunctions
	}

:: BimapFunctions = {
		bimap_id_function :: !FunctionIndexAndIdent,
		bimap_fromto_function :: !FunctionIndexAndIdent,
		bimap_tofrom_function :: !FunctionIndexAndIdent,
		bimap_to_function :: !FunctionIndexAndIdent,
		bimap_from_function :: !FunctionIndexAndIdent,
		bimap_arrow_function :: !FunctionIndexAndIdent,
		bimap_arrow_arg_id_function :: !FunctionIndexAndIdent,
		bimap_arrow_res_id_function :: !FunctionIndexAndIdent,
		bimap_from_Bimap_function :: !FunctionIndexAndIdent,
		bimap_PAIR_function :: !FunctionIndexAndIdent,
		bimap_EITHER_function :: !FunctionIndexAndIdent,
		bimap_OBJECT_function :: !FunctionIndexAndIdent,
		bimap_CONS_function :: !FunctionIndexAndIdent,
		bimap_RECORD_function :: !FunctionIndexAndIdent,
		bimap_FIELD_function :: !FunctionIndexAndIdent
	}

:: FunctionIndexAndIdent = {	
		fii_index :: !Index,
		fii_ident :: Ident
	}

:: *GenericState = 
	{ gs_modules :: !*Modules
	, gs_exprh :: !*ExpressionHeap
	, gs_genh :: !*GenericHeap
	, gs_varh :: !*VarHeap
	, gs_tvarh :: !*TypeVarHeap
	, gs_avarh :: !*AttrVarHeap 
	, gs_error :: !*ErrorAdmin
	, gs_symtab :: !*SymbolTable
	, gs_dcl_modules :: !*DclModules
	, gs_td_infos :: !*TypeDefInfos
	, gs_funs :: !*{#FunDef}
	, gs_groups :: {!Group}
	// non-unique, read only
	, gs_predefs :: !PredefinedSymbols
	, gs_main_module :: !Index
	, gs_used_modules :: !NumberSet
	}

// Exported functions

convertGenerics :: 
		!Int 					// index of the main dcl module
		!NumberSet				// set of used modules
		!{#CommonDefs} 			// common definitions of all modules
		!{!Group} 				// groups of functions
		!*{# FunDef} 			// functions
		!*TypeDefInfos 			// type definition information of all modules
		!*Heaps 				// all heaps
		!*HashTable 			// needed for what creating class dictionaries
		!*PredefinedSymbols 	// predefined symbols
		!u:{# DclModule}		// dcl modules
		!*ErrorAdmin 			// to report errors
	->  ( !{#CommonDefs}		// common definitions of all modules
		, !{!Group}				// groups of functions
		, !*{# FunDef}			// function definitions
		, ![IndexRange]			// index ranges of generated functions
		, !*TypeDefInfos		// type definition infos
		, !*Heaps				// all heaps
		, !*HashTable			// needed for creating class dictinaries
		, !*PredefinedSymbols	// predefined symbols	
		, !u:{# DclModule}		// dcl modules
		, !*ErrorAdmin			// to report errors
		)
convertGenerics main_dcl_module_n used_module_numbers modules groups funs td_infos heaps hash_table u_predefs dcl_modules error
	#! modules = {x \\ x <-: modules} 			// unique copy
	#! dcl_modules = { x \\ x <-: dcl_modules } 	// unique copy
	#! size_predefs = size u_predefs
	#! (predefs, u_predefs) = arrayCopyBegin u_predefs size_predefs // non-unique copy

	#! td_infos = clearTypeDefInfos td_infos
	#! (modules, heaps) = clearGenericDefs modules heaps

	# {hp_var_heap, hp_generic_heap, hp_type_heaps={th_vars, th_attrs}, hp_expression_heap} = heaps
	# gs = 
		{ gs_modules = modules
		, gs_symtab = hash_table.hte_symbol_heap
		, gs_dcl_modules = dcl_modules
		, gs_td_infos = td_infos
		, gs_exprh = hp_expression_heap	
		, gs_genh = hp_generic_heap	
		, gs_varh = hp_var_heap
		, gs_tvarh = th_vars
		, gs_avarh = th_attrs
		, gs_error = error	
		, gs_funs = funs
		, gs_groups = groups	
		, gs_predefs = predefs
		, gs_main_module = main_dcl_module_n
		, gs_used_modules = used_module_numbers
		} 

	# (generic_ranges, gs) = convert_generics gs

	#	{ 	gs_modules = modules, gs_symtab, gs_dcl_modules = dcl_modules, gs_td_infos = td_infos, 
			gs_genh = hp_generic_heap, gs_varh = hp_var_heap, gs_tvarh = th_vars, gs_avarh = th_attrs, 
			gs_exprh = hp_expression_heap,	
			gs_error = error, gs_funs = funs, gs_groups = groups,
			gs_predefs = predefs, gs_main_module = main_dcl_module_n, gs_used_modules = used_module_numbers} = gs
	#! hash_table = { hash_table & hte_symbol_heap = gs_symtab }
	#! heaps = 
		{ hp_expression_heap = hp_expression_heap
		, hp_var_heap = hp_var_heap
		, hp_generic_heap = hp_generic_heap
		, hp_type_heaps = { th_vars = th_vars, th_attrs = th_attrs }
		}
	= (modules, groups, funs, generic_ranges, td_infos, heaps, hash_table, u_predefs, dcl_modules, error)
where
	convert_generics :: !*GenericState -> (![IndexRange], !*GenericState)
	convert_generics gs		
		# (iso_range, bimap_functions, gs) = buildGenericRepresentations gs
		| not gs.gs_error.ea_ok = ([], gs)	

		# gs = buildClasses gs
		| not gs.gs_error.ea_ok = ([], gs)

		# (instance_range, gs) = convertGenericCases bimap_functions gs
		| not gs.gs_error.ea_ok = ([], gs)	

		#! gs = convertGenericTypeContexts gs

		= ([/*iso_range,*/instance_range], gs)

// clear stuff that might have been left over
// from compilation of other icl modules

clearTypeDefInfos :: !*{#*{#TypeDefInfo}} -> *{#*{#TypeDefInfo}}
clearTypeDefInfos td_infos
	= clear_modules 0 td_infos
where
	clear_modules n td_infos
		| n == size td_infos
			= td_infos
			#! (td_infos1, td_infos) = td_infos![n]
			#! td_infos1 = clear_td_infos 0 td_infos1
			#! td_infos = {td_infos & [n]=td_infos1}
			= clear_modules (inc n) td_infos 
			
	clear_td_infos n td_infos 			
		| n == size td_infos
			= td_infos
			#! (td_info, td_infos) = td_infos![n]
			#! td_infos = {td_infos & [n] = {td_info & tdi_gen_rep = No}}
			= clear_td_infos (inc n) td_infos 

clearGenericDefs :: !*{#CommonDefs} !*Heaps -> (!*{#CommonDefs},!*Heaps)
clearGenericDefs modules heaps
	= clear_module 0 modules  heaps
where
	initial_gen_classes
		= createArray 32 []

	clear_module n modules heaps
		| n == size modules
			= (modules, heaps)
			#! ({com_generic_defs}, modules) = modules![n]
			#! (com_generic_defs, heaps) = updateArraySt clear_generic_def {x\\x<-:com_generic_defs} heaps 			
			#! modules = {modules & [n].com_generic_defs = com_generic_defs}
			= clear_module (inc n) modules heaps

	clear_generic_def generic_def=:{gen_info_ptr} heaps=:{hp_generic_heap}
		#! (gen_info, hp_generic_heap) = readPtr gen_info_ptr hp_generic_heap
		#! gen_info & gen_classes = initial_gen_classes
		#! hp_generic_heap = writePtr gen_info_ptr gen_info hp_generic_heap
		= (generic_def, {heaps & hp_generic_heap = hp_generic_heap})
		
//	generic type representation

// generic representation is built for each type argument of
// generic cases of the current module
buildGenericRepresentations :: !*GenericState -> (!IndexRange,!BimapFunctions,!*GenericState)
buildGenericRepresentations gs=:{gs_main_module, gs_modules, gs_funs, gs_groups}
	#! (size_funs, gs_funs) = usize gs_funs
	#! size_groups = size gs_groups
	#! ({com_gencase_defs}, gs_modules) = gs_modules![gs_main_module]
	
	#! gs = { gs & gs_modules = gs_modules, gs_funs = gs_funs, gs_groups = gs_groups }
	
	# undefined_function_and_ident = {fii_index = -1,fii_ident = undef}
	  bimap_functions = {
				bimap_id_function = undefined_function_and_ident,
				bimap_fromto_function = undefined_function_and_ident,
				bimap_tofrom_function = undefined_function_and_ident,
				bimap_to_function = undefined_function_and_ident,
				bimap_from_function = undefined_function_and_ident,
		  		bimap_arrow_function = undefined_function_and_ident,
		  		bimap_arrow_arg_id_function = undefined_function_and_ident,
		  		bimap_arrow_res_id_function = undefined_function_and_ident,
		  		bimap_from_Bimap_function = undefined_function_and_ident,
		  		bimap_PAIR_function = undefined_function_and_ident,
		  		bimap_EITHER_function = undefined_function_and_ident,
		  		bimap_OBJECT_function = undefined_function_and_ident,
		  		bimap_CONS_function = undefined_function_and_ident,
		  		bimap_RECORD_function = undefined_function_and_ident,
		  		bimap_FIELD_function = undefined_function_and_ident
	  		}
	  funs_and_groups = {fg_fun_index=size_funs, fg_group_index=size_groups, fg_funs=[], fg_groups=[],fg_bimap_functions= bimap_functions}
	#! (funs_and_groups, gs)
		= foldArraySt build_generic_representation com_gencase_defs (funs_and_groups, gs)

	# {fg_fun_index,fg_funs=new_funs,fg_groups=new_groups,fg_bimap_functions} = funs_and_groups 
	# {gs_funs, gs_groups} = gs
	#! gs_funs = arrayPlusRevList gs_funs new_funs
	#! gs_groups = arrayPlusRevList gs_groups new_groups

	#! range = {ir_from = size_funs, ir_to = fg_fun_index}

	= (range, fg_bimap_functions, {gs & gs_funs = gs_funs, gs_groups = gs_groups})
where
	build_generic_representation 
			{gc_type_cons=TypeConsSymb {type_index={glob_module,glob_object},type_ident},gc_body=GCB_FunIndex fun_index,gc_ident,gc_pos}
			(funs_and_groups, gs)
		# (type_def,gs) = gs!gs_modules.[glob_module].com_type_defs.[glob_object]
		# (td_info, gs) = gs!gs_td_infos.[glob_module,glob_object]
		= case gs.gs_funs.[fun_index].fun_body of
			TransformedBody _ 
				// does not need a generic representation
				-> (funs_and_groups, gs)
			GeneratedBody	
				// 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
						-> (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
						-> (funs_and_groups, {gs & gs_error = gs_error})	
					_ 
						-> case td_info.tdi_gen_rep of
							Yes _
								-> (funs_and_groups, gs)	// generic representation is already built
							No
								# type_def_gi = {gi_module=glob_module,gi_index=glob_object}
								# (gen_type_rep, funs_and_groups, gs)
									= buildGenericTypeRep type_def_gi funs_and_groups gs
								# td_info = {td_info & tdi_gen_rep = Yes gen_type_rep}
								# gs = {gs & gs_td_infos.[glob_module,glob_object] = td_info}
								-> (funs_and_groups, gs)
	build_generic_representation _ st = st

:: TypeInfos
	= AlgebraicInfo !DefinedSymbol ![DefinedSymbol]
	| RecordInfo !DefinedSymbol ![DefinedSymbol]

buildGenericTypeRep :: !GlobalIndex /*type def index*/ !FunsAndGroups !*GenericState ->	(!GenericTypeRep,!FunsAndGroups,!*GenericState)
buildGenericTypeRep type_index funs_and_groups
		gs=:{gs_modules, gs_predefs, gs_main_module, gs_error, gs_td_infos, gs_exprh, gs_varh, gs_genh, gs_avarh, gs_tvarh}
	# heaps = 
		{ hp_expression_heap = gs_exprh
		, hp_var_heap = gs_varh
		, hp_generic_heap = gs_genh
		, hp_type_heaps = { th_vars = gs_tvarh, th_attrs = gs_avarh }
		}

	# (type_def, gs_modules) = gs_modules![type_index.gi_module].com_type_defs.[type_index.gi_index]

	# (type_infos, funs_and_groups, gs_modules, heaps, gs_error)
		= buildTypeDefInfo type_def type_index.gi_module gs_main_module gs_predefs funs_and_groups gs_modules heaps gs_error

	# (atype, (gs_modules, gs_td_infos, heaps, gs_error)) 
		= buildStructType type_index type_infos gs_predefs (gs_modules, gs_td_infos, heaps, gs_error)
	
	# (from_fun_ds, funs_and_groups, heaps, gs_error)
		= buildConversionFrom type_index.gi_module type_def gs_main_module gs_predefs funs_and_groups heaps gs_error

	# (to_fun_ds, funs_and_groups, heaps, gs_error)
		= buildConversionTo type_index.gi_module type_def gs_main_module gs_predefs funs_and_groups heaps gs_error

	# (iso_fun_ds, funs_and_groups, heaps, gs_error)
		= buildConversionIso type_def from_fun_ds to_fun_ds gs_main_module gs_predefs funs_and_groups heaps gs_error

	# {hp_expression_heap, hp_var_heap, hp_generic_heap, hp_type_heaps={th_vars, th_attrs}} = heaps
	# gs = {gs	& gs_modules = gs_modules
				, gs_td_infos = gs_td_infos
				, gs_error = gs_error
				, gs_avarh = th_attrs
				, gs_tvarh = th_vars
				, gs_varh = hp_var_heap
				, gs_genh = hp_generic_heap
				, gs_exprh = hp_expression_heap
		   }
	= ({gtr_type=atype,gtr_iso=iso_fun_ds,gtr_to=to_fun_ds,gtr_from=from_fun_ds}, funs_and_groups, gs)
	
//	the structure type

convertATypeToGenTypeStruct :: !Ident !Position !PredefinedSymbols !AType (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin) 
													   -> (GenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convertATypeToGenTypeStruct ident pos predefs type st
	= convert type st
where	
	convert {at_type=TA type_symb args, at_attribute} st
		= convert_type_app type_symb at_attribute args st
	convert {at_type=TAS type_symb args _, at_attribute} st
		= convert_type_app type_symb at_attribute args st
	convert {at_type=(CV tv) :@: args} st
		#! (args, st) = mapSt convert args st
		= (GTSAppVar tv args, st)
	convert {at_type=x --> y} st
		#! (x, st) = convert x st
		#! (y, st) = convert y st
		= (GTSArrow x y, st)
	convert {at_type=TV tv} st
		= (GTSVar tv, st)  
	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
		= (GTSE, (modules, td_infos, heaps, error))

	convert_type_app {type_index} attr args (modules, td_infos, heaps, error)	
		# (type_def, modules) = modules![type_index.glob_module].com_type_defs.[type_index.glob_object]
		= case type_def.td_rhs of 
			SynType atype
				# (expanded_type, th) = expandSynonymType type_def attr args heaps.hp_type_heaps 
				-> convert {at_type = expanded_type, at_attribute = attr} 
					(modules, td_infos, {heaps & hp_type_heaps = th}, error) 
			_
				#! {pds_module, pds_def} = predefs.[PD_UnboxedArrayType]
				| 	type_index.glob_module == pds_module
					&& type_index.glob_object == pds_def
					&& (case args of [{at_type=TB _}] -> True; _ -> False)
					-> (GTSAppCons KindConst [], (modules, td_infos, heaps, error))
				| otherwise
					#! ({tdi_kinds}, td_infos) = td_infos ! [type_index.glob_module,type_index.glob_object]
					#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
					#! (args, st) = mapSt  convert args (modules, td_infos, heaps, error)
					-> (GTSAppCons kind args, st)  

convert_bimap_AType_to_GenTypeStruct :: !AType !Position !PredefinedSymbols (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin) 
														 -> (GenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
convert_bimap_AType_to_GenTypeStruct type pos predefs st
	= convert type st
where
	convert {at_type=TA type_symb args, at_attribute} st
		= convert_type_app type_symb at_attribute args st
	convert {at_type=TAS type_symb args _, at_attribute} st
		= convert_type_app type_symb at_attribute args st
	convert {at_type=(CV tv) :@: args} st
		#! (args, st) = mapSt convert args st
		= (GTSAppVar tv args, st)
	convert {at_type=x --> y} st
		#! (x, st) = convert x st
		#! (y, st) = convert y st
		= (GTSArrow x y, st)  
	convert {at_type=TV tv} st
		= (GTSVar tv, st)  
	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
		= (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)
		# (type_def, modules) = modules![glob_module].com_type_defs.[glob_object]
		= case type_def.td_rhs of 
			SynType atype
				# (expanded_type, th) = expandSynonymType type_def attr args heaps.hp_type_heaps
				-> convert {at_type = expanded_type, at_attribute = attr} 
					(modules, td_infos, {heaps & hp_type_heaps = th}, error) 
			AbstractType _
				#! {pds_module, pds_def} = predefs.[PD_UnboxedArrayType]
				| glob_module == pds_module && glob_object == pds_def
					&& (case args of [{at_type=TB _}] -> True; _ -> False)
					-> (GTSAppCons KindConst [], (modules, td_infos, heaps, error))
			RecordType _
				# {pds_module, pds_def} = predefs.[PD_TypeBimap]
				| glob_module == pds_module && glob_object == pds_def
					&& case args of [_,_] -> True; _ -> False
					#! (tdi_kinds,td_infos) = td_infos![glob_module,glob_object].tdi_kinds
					#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
					#! (args, st) = convert_args args (modules, td_infos, heaps, error)
					-> (GTSAppBimap kind args, st)
			AlgType alts
				# n_args = length args
				| n_args>0 && type_arity==n_args
					# (can_generate_bimap_to_or_from,modules,heaps)
						= can_generate_bimap_to_or_from_for_this_type type_def glob_module alts modules heaps
					| can_generate_bimap_to_or_from
						#! (tdi_kinds,td_infos) = td_infos![glob_module,glob_object].tdi_kinds			
						#! (args, st) = convert_args args (modules, td_infos, heaps, error)
						-> (GTSAppConsSimpleType {gi_module=type_index.glob_module,gi_index=type_index.glob_object} (KindArrow tdi_kinds) args, st)
						-> 	convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
			_
				-> 	convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
	where
		convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
			#! (tdi_kinds,td_infos) = td_infos![glob_module,glob_object].tdi_kinds
			#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
			#! (args, st) = convert_args args (modules, td_infos, heaps, error)
			= (GTSAppCons kind args, st)

	can_generate_bimap_to_or_from_for_this_type :: !CheckedTypeDef !Index ![DefinedSymbol] !*Modules !*Heaps -> (!Bool,!*Modules,!*Heaps)
	can_generate_bimap_to_or_from_for_this_type type_def=:{td_args} type_def_module_n alts modules heaps=:{hp_type_heaps}
		# th_vars = number_type_arguments td_args 0 hp_type_heaps.th_vars
		#! ok = check_constructors alts type_def_module_n modules th_vars
		# th_vars = remove_type_argument_numbers td_args th_vars
		# heaps = {heaps & hp_type_heaps={hp_type_heaps & th_vars=th_vars}}
		= (ok,modules,heaps)
	where
		check_constructors :: ![DefinedSymbol] !Index !Modules !TypeVarHeap -> Bool
		check_constructors [{ds_index}:constructors] type_def_module_n modules th_vars
			# {cons_type,cons_exi_vars} = modules.[type_def_module_n].com_cons_defs.[ds_index]
			= isEmpty cons_exi_vars &&
			  isEmpty cons_type.st_context &&
			  check_constructor cons_type.st_args 0 th_vars &&
			  check_constructors constructors type_def_module_n modules th_vars
		check_constructors [] type_def_module_n modules th_vars
			= True

		check_constructor :: ![AType] !Int !TypeVarHeap -> Bool
		check_constructor [{at_type=TV {tv_info_ptr}}:atypes] used_type_vars th_vars
			= case sreadPtr tv_info_ptr th_vars of
				TVI_GenTypeVarNumber arg_n
					# arg_mask = 1<<arg_n
					| used_type_vars bitand arg_mask<>0
						-> False
						# used_type_vars = used_type_vars bitor arg_mask
						-> check_constructor atypes used_type_vars th_vars
		check_constructor [_:_] used_type_vars th_vars
			= False
		check_constructor [] used_type_vars th_vars
			= True

	convert_args args st
		= mapSt convert args st

// the structure type of a generic type can often be simplified
// because bimaps for types not containing generic variables are indentity bimaps
simplify_bimap_GenTypeStruct :: ![TypeVar] !GenTypeStruct !*Heaps -> (!GenTypeStruct, !*Heaps)
simplify_bimap_GenTypeStruct gvars type heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}} 
	#! th_vars = foldSt mark_type_var gvars th_vars
	#! (type, th_vars) = simplify type th_vars
	#! th_vars = foldSt clear_type_var gvars th_vars 
	= (type, { heaps & hp_type_heaps = { hp_type_heaps & th_vars = th_vars}})
where
	simplify t=:(GTSAppCons KindConst [])  st
		= (t, st)
	simplify (GTSAppCons kind=:(KindArrow kinds) args) st
		# formal_arity = length kinds
		# actual_arity = length args
		# contains_gen_vars = occurs_list args st
		| formal_arity == actual_arity && not contains_gen_vars
			= (GTSAppConsBimapKindConst, st)
			# (args, st) = mapSt simplify args st
			= (GTSAppCons kind args, st)
	simplify (GTSAppConsSimpleType type_symbol_n kind args) st
		# contains_gen_vars = occurs_list args st
		| not contains_gen_vars
			= (GTSAppConsBimapKindConst, st)
			# (args, st) = mapSt simplify args st
			= (GTSAppConsSimpleType type_symbol_n kind args, st)
	simplify t=:(GTSAppBimap KindConst [])  st
		= (t, st)
	simplify (GTSAppBimap kind=:(KindArrow kinds) args) st
		# formal_arity = length kinds
		# actual_arity = length args
		# contains_gen_vars = occurs_list args st
		| formal_arity == actual_arity && not contains_gen_vars
			= (GTSAppConsBimapKindConst, st)
			# (args, st) = mapSt simplify args st
			= (GTSAppBimap kind args, st)
	simplify (GTSArrow x y) st
		# contains_gen_vars = occurs2 x y st
		| not contains_gen_vars
			= (GTSAppConsBimapKindConst, st)
			# (x, st) = simplify x st
			# (y, st) = simplify y st
			= (GTSArrow x y, st)
	simplify (GTSAppVar tv args) st
		# (args, st) = mapSt simplify args st
		= (GTSAppVar tv args, st)	
	simplify t=:(GTSVar tv) st
		= (t, st)
	simplify (GTSPair x y) st
		# (x, st) = simplify x st
		# (y, st) = simplify y st
		= (GTSPair x y, st)
	simplify (GTSEither x y) st
		# (x, st) = simplify x st
		# (y, st) = simplify y st
		= (GTSEither x y, st)
	simplify (GTSCons cons_info_ds x) st
		# (x, st) = simplify x st
		= (GTSCons cons_info_ds x, st)
	simplify (GTSRecord cons_info_ds x) st
		# (x, st) = simplify x st
		= (GTSRecord cons_info_ds x, st)
	simplify (GTSField field_info_ds x) st
		# (x, st) = simplify x st
		= (GTSField field_info_ds x, st)
	simplify (GTSObject type_info_ds x) st
		# (x, st) = simplify x st
		= (GTSObject type_info_ds x, st)
		
	occurs (GTSAppCons _ args) st 	= occurs_list args st
	occurs (GTSAppConsSimpleType _ _ args) st 	= occurs_list args st
	occurs (GTSAppBimap _ args) st 	= occurs_list args st
	occurs (GTSAppVar tv args) st 	= type_var_occurs tv st || occurs_list args st		
	occurs (GTSVar tv) st			= type_var_occurs tv st
	occurs (GTSArrow x y) st 		= occurs2 x y st
	occurs (GTSPair x y) st			= occurs2 x y st
	occurs (GTSEither x y) st		= occurs2 x y st
	occurs (GTSCons _ arg) st 		= occurs arg st	
	occurs (GTSRecord _ arg) st		= occurs arg st
	occurs (GTSField _ arg) st 		= occurs arg st	
	occurs (GTSObject _ arg) st 	= occurs arg st	
	occurs GTSE st 					= False

	occurs2 x y st
		= occurs x st || occurs y st

	occurs_list [] st
		= False
	occurs_list [x:xs] st 
		= occurs x st || occurs_list xs st

	type_var_occurs tv th_vars
		= case sreadPtr tv.tv_info_ptr th_vars of
			TVI_Empty = False
			TVI_Used = True

	mark_type_var tv=:{tv_info_ptr} th_vars 
		# (tv_info, th_vars) = readPtr tv_info_ptr th_vars
		= case tv_info of
			TVI_Empty = writePtr tv_info_ptr TVI_Used th_vars 
			_ = abort "type var is not empty"

	clear_type_var {tv_info_ptr} th_vars
		= writePtr tv_info_ptr TVI_Empty th_vars 

buildStructType ::
		!GlobalIndex				// type def global index
		!TypeInfos					// type, constructor and field info symbols
		!PredefinedSymbols
		(!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
	-> 	( !GenTypeStruct			// the structure type
		, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
		)
buildStructType {gi_module,gi_index} type_infos predefs (modules, td_infos, heaps, error)
	# (type_def=:{td_ident}, modules) = modules![gi_module].com_type_defs.[gi_index]	
	= build_type type_def type_infos (modules, td_infos, heaps, error)	
where
	build_type {td_rhs=AlgType alts, td_ident, td_pos} (AlgebraicInfo type_info cons_infos) st
		# (cons_args, st) = zipWithSt (build_alt td_ident td_pos) alts cons_infos st
		# type = build_sum_type cons_args
		= (GTSObject type_info type, st)
	build_type
			{td_rhs=RecordType {rt_constructor}, td_ident, td_pos} 
			(RecordInfo ci_record_info ci_field_infos) 
			(modules, td_infos, heaps, error)
		# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[rt_constructor.ds_index]
		| isEmpty cons_exi_vars
			# (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)		
			# 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
			= (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
		= (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
		= (GTSE, (modules, td_infos, heaps, error))

	build_alt td_ident td_pos cons_def_sym=:{ds_index} cons_info (modules, td_infos, heaps, error)
		# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[ds_index]
		| isEmpty cons_exi_vars
			# (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
			= (GTSE, (modules, td_infos, heaps, error))

	build_prod_type :: [GenTypeStruct] -> GenTypeStruct
	build_prod_type types 
		= listToBin build_pair build_unit types	
	where
		build_pair x y = GTSPair x y
		build_unit = GTSAppCons KindConst []	

	build_sum_type :: [GenTypeStruct] -> GenTypeStruct
	build_sum_type types
		= listToBin build_either build_void types
	where
		build_either x y = GTSEither x y
		build_void = abort "sanity check: no alternatives in a type\n"		

/*
// build a product of types
buildProductType :: ![AType] !PredefinedSymbols -> AType
buildProductType types predefs 
	= listToBin build_pair build_unit types
where
	build_pair x y = buildPredefTypeApp PD_TypePAIR [x, y] predefs	
	build_unit  = buildPredefTypeApp PD_TypeUNIT [] predefs

// build a sum of types		
buildSumType :: ![AType] !PredefinedSymbols -> AType
buildSumType types predefs 
	= listToBin build_either build_void types
where
	build_either x y = buildPredefTypeApp PD_TypeEITHER [x, y] predefs	
	build_void  = abort "sum of zero types\n"
*/

// build a binary representation of a list
listToBin :: (a a -> a) a [a] -> a 
listToBin bin tip [] = tip
listToBin bin tip [x] = x
listToBin bin tip xs
	# (l,r) = splitAt ((length xs) / 2) xs
	= bin (listToBin bin tip l) (listToBin bin tip r)

// build application of a predefined type constructor 
buildPredefTypeApp :: !Int [AType] !PredefinedSymbols -> AType
buildPredefTypeApp predef_index args predefs
	# {pds_module, pds_def} = predefs.[predef_index]
	# pds_ident = predefined_idents.[predef_index]
	# global_index = {glob_module = pds_module, glob_object = pds_def}
	# type_symb = MakeTypeSymbIdent global_index pds_ident (length args) 		  
	= makeAType (TA type_symb args) TA_Multi

//	build type infos
buildTypeDefInfo :: 
		!CheckedTypeDef		// the type definition
		!Index 				// type def module
		!Index				// icl module
		!PredefinedSymbols		
		!FunsAndGroups !*Modules !*Heaps !*ErrorAdmin
	-> 	(!TypeInfos, !FunsAndGroups, !*Modules, !*Heaps, !*ErrorAdmin)
buildTypeDefInfo td=:{td_rhs = AlgType alts} td_module main_module_index predefs funs_and_groups modules heaps error
	= buildAlgebraicTypeDefInfo td alts td_module main_module_index predefs funs_and_groups modules heaps error
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
	= 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
	= 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
				funs_and_groups=:{fg_fun_index=fun_index,fg_group_index=group_index,fg_funs=funs,fg_groups=groups} modules heaps error

	# num_conses = length alts
	# new_group_index = inc group_index

	# cons_desc_list_index = fun_index
	  type_def_dsc_index = cons_desc_list_index + 1
	  first_gen_type_index = type_def_dsc_index + 1
	  first_cons_dsc_index = first_gen_type_index + num_conses
	  new_fun_index = first_cons_dsc_index + num_conses

	# group = {group_members = [fun_index .. new_fun_index - 1]}
	# new_groups = [group:groups]

	# cons_desc_list_ds = {ds_arity=0, ds_ident=makeIdent ("cli_"+++td_ident.id_name), ds_index=cons_desc_list_index}
	  type_def_dsc_ds = {ds_arity=0, ds_ident=makeIdent ("tdi_"+++td_ident.id_name), ds_index=type_def_dsc_index}
	  gen_type_dss = [ {ds_arity=0, ds_ident=makeIdent ("gti_"+++ds_ident.id_name), ds_index=i} \\ 
		{ds_ident} <- alts & i <- [first_gen_type_index .. first_gen_type_index + num_conses - 1]]
	  cons_dsc_dss = [ {ds_arity=0, ds_ident=makeIdent ("cdi_"+++ds_ident.id_name), ds_index=i} \\ 
		{ds_ident} <- alts & i <- [first_cons_dsc_index .. first_cons_dsc_index + num_conses - 1]]

	# (cons_desc_list_fun, heaps) = build_cons_desc_list_function group_index cons_desc_list_ds cons_dsc_dss heaps	

	  (type_def_dsc_fun, heaps) = build_type_def_dsc group_index type_def_dsc_ds cons_desc_list_ds heaps

	  (gen_type_dsc_funs, (modules, heaps)) = zipWithSt (build_gen_type_function group_index main_module_index td_module td_pos predefs) gen_type_dss alts (modules, heaps)

	  (cons_dsc_funs, (modules, heaps)) = zipWith3St (build_cons_dsc group_index type_def_dsc_ds) cons_dsc_dss gen_type_dss alts (modules, heaps)

	// NOTE: reverse order (new functions are added at the head) 
	# new_funs = reverse cons_dsc_funs ++ reverse gen_type_dsc_funs ++ [type_def_dsc_fun, cons_desc_list_fun : funs] 

	# funs_and_groups = {funs_and_groups & fg_fun_index=new_fun_index, fg_group_index=new_group_index, fg_funs=new_funs, fg_groups=new_groups}

	# cons_infos = AlgebraicInfo type_def_dsc_ds cons_dsc_dss

	= (cons_infos, funs_and_groups, modules, heaps, error)
where
	build_cons_desc_list_function group_index {ds_ident} cons_info_dss heaps
		# (cons_info_exprs, heaps) = mapSt (\x st->buildFunApp main_module_index x [] st) cons_info_dss heaps
		# (gtd_conses_expr, heaps) = makeListExpr cons_info_exprs predefs heaps // gtd_conses
		# fun = makeFunction ds_ident group_index [] gtd_conses_expr No main_module_index td_pos
		= (fun, heaps)

	build_type_def_dsc group_index {ds_ident} cons_desc_list_ds heaps
		# td_name_expr = makeStringExpr td_ident.id_name // gtd_name
		# td_arity_expr = makeIntExpr td_arity // gtd_arity
		# num_conses_expr = makeIntExpr (length alts) // gtd_num_conses
		# (gtd_conses_expr, heaps) = buildFunApp main_module_index cons_desc_list_ds [] heaps // gtd_conses
		# (body_expr, heaps) = buildPredefConsApp PD_CGenericTypeDefDescriptor
			[td_name_expr, td_arity_expr, num_conses_expr, gtd_conses_expr] // TODO: module_name_expr
			predefs heaps
		# fun = makeFunction ds_ident group_index [] body_expr No main_module_index td_pos
		= (fun, heaps)

	build_cons_dsc group_index type_def_info_ds {ds_ident} gen_type_ds cons_ds (modules, heaps)
		# ({cons_ident,cons_type,cons_priority,cons_number,cons_exi_vars}, modules)
			= modules![td_module].com_cons_defs.[cons_ds.ds_index]
		# name_expr 			 = makeStringExpr cons_ident.id_name // gcd_name
		# arity_expr 			 = makeIntExpr cons_type.st_arity // gcd_arity
		# (prio_expr, heaps)	 = make_prio_expr cons_priority predefs heaps // gcd_prio
		# (type_def_expr, heaps) = buildFunApp main_module_index type_def_info_ds [] heaps // gcd_type_def
		# (type_expr, heaps)	 = buildFunApp main_module_index gen_type_ds [] heaps // gcd_type
		# cons_index_expr		 = makeIntExpr cons_number // gcd_index
		# (body_expr, heaps)
			= buildPredefConsApp PD_CGenericConsDescriptor 
				[name_expr, arity_expr, prio_expr, type_def_expr, type_expr, cons_index_expr]
				predefs heaps
		# fun = makeFunction ds_ident group_index [] body_expr No main_module_index td_pos
		= (fun, (modules, heaps))

make_prio_expr NoPrio predefs heaps
	= buildPredefConsApp PD_CGenConsNoPrio [] predefs heaps
make_prio_expr (Prio assoc prio) predefs heaps
	# assoc_predef = case assoc of
		NoAssoc 	-> PD_CGenConsAssocNone 
		LeftAssoc 	-> PD_CGenConsAssocLeft
		RightAssoc 	-> PD_CGenConsAssocRight
	# (assoc_expr, heaps) = buildPredefConsApp assoc_predef [] predefs heaps 	
	# prio_expr = makeIntExpr prio
	= buildPredefConsApp PD_CGenConsPrio [assoc_expr, prio_expr] predefs heaps 

buildRecordTypeDefInfo {td_ident, td_pos, td_arity} alt fields td_module main_module_index predefs
				funs_and_groups=:{fg_fun_index=fun_index,fg_group_index=group_index,fg_funs=funs,fg_groups=groups} modules heaps error

	# num_fields = length fields
	# new_group_index = inc group_index

	# gen_type_index = fun_index
	  field_list_index = gen_type_index + 1
	  cons_dsc_index = field_list_index + 1
	  first_field_dsc_index = cons_dsc_index + 1
	  new_fun_index = first_field_dsc_index + num_fields

	# group = {group_members = [fun_index .. new_fun_index - 1]}
	# new_groups = [group:groups]

	# gen_type_ds = {ds_arity=0, ds_ident=makeIdent ("gti_"+++alt.ds_ident.id_name), ds_index=gen_type_index}
	  field_list_ds = {ds_arity=0, ds_ident=makeIdent ("fli_"+++alt.ds_ident.id_name), ds_index=field_list_index}
	  record_dsc_ds = {ds_arity=0, ds_ident=makeIdent ("rdi_"+++alt.ds_ident.id_name), ds_index=cons_dsc_index}
	  field_dsc_dss = [ {ds_arity=0, ds_ident=makeIdent ("fdi_"+++fs_ident.id_name), ds_index=i} \\ 
		{fs_ident} <- fields & i <- [first_field_dsc_index .. first_field_dsc_index + num_fields - 1]]

	# (gen_type_dsc_fun, (modules, heaps)) = build_gen_type_function group_index main_module_index td_module td_pos predefs gen_type_ds alt (modules, heaps)

	  (field_list_fun, (modules, heaps)) = build_field_list_function group_index field_list_ds (modules, heaps)

	  (record_dsc_fun, (modules, heaps)) = build_record_dsc group_index td_ident record_dsc_ds gen_type_ds field_list_ds alt (modules, heaps)

	  (field_dsc_funs, (modules, heaps)) = zipWithSt (build_field_dsc group_index record_dsc_ds) field_dsc_dss fields (modules, heaps)
	 
	// NOTE: reverse order (new functions are added at the head) 
	# new_funs = reverse field_dsc_funs ++ [record_dsc_fun, field_list_fun, gen_type_dsc_fun : funs]

	# funs_and_groups = {funs_and_groups & fg_fun_index=new_fun_index, fg_group_index=new_group_index, fg_funs=new_funs, fg_groups=new_groups}

	# cons_infos = RecordInfo record_dsc_ds field_dsc_dss

	= (cons_infos, funs_and_groups, modules, heaps, error)
where
	build_field_list_function group_index field_list_ds (modules, heaps)
		# field_exprs		 	 = [makeStringExpr id_name \\ {fs_ident={id_name}}<-fields]
		# (fields_expr, heaps)   = makeListExpr field_exprs predefs heaps // grd_fields
		# fun = makeFunction field_list_ds.ds_ident group_index [] fields_expr No main_module_index td_pos		
		= (fun, (modules, heaps))

	build_record_dsc group_index td_ident cons_info_ds gen_type_ds field_list_ds cons_ds (modules, heaps)
		# ({cons_ident,cons_type,cons_priority,cons_number}, modules)
			= modules![td_module].com_cons_defs.[cons_ds.ds_index]
		# name_expr 			 = makeStringExpr td_ident.id_name /*cons_ident.id_name*/ // grd_name
		# arity_expr 			 = makeIntExpr cons_type.st_arity // grd_arity
		# td_arity_expr 		 = makeIntExpr td_arity // grd_type_arity
		# (type_expr, heaps)	 = buildFunApp main_module_index gen_type_ds [] heaps // grd_type
		# (fields_expr, heaps)	 = buildFunApp main_module_index field_list_ds [] heaps // grd_fields
		# (body_expr, heaps)
			= buildPredefConsApp PD_CGenericRecordDescriptor
				[name_expr, arity_expr, td_arity_expr, type_expr, fields_expr]
				predefs heaps
		# fun = makeFunction cons_info_ds.ds_ident group_index [] body_expr No main_module_index td_pos		
		= (fun, (modules, heaps))

	build_field_dsc group_index record_dsc_ds field_dsc_ds {fs_ident, fs_index} (modules, heaps)
		# ({sd_field_nr}, modules)
			= modules![td_module].com_selector_defs.[fs_index]
		# name_expr = makeStringExpr fs_ident.id_name // gfd_name
		# index_expr = makeIntExpr sd_field_nr // gfd_index
		# (cons_expr, heaps) = buildFunApp main_module_index record_dsc_ds [] heaps // gfd_cons
		# (body_expr, heaps) 
			= buildPredefConsApp PD_CGenericFieldDescriptor 
				[name_expr, index_expr, cons_expr]
				predefs heaps
		# fun = makeFunction field_dsc_ds.ds_ident group_index [] body_expr No main_module_index td_pos		
		= (fun, (modules, heaps))

build_gen_type_function group_index main_module_index td_module td_pos predefs cons_info_ds cons_ds (modules, heaps)
	# ({cons_type,cons_exi_vars}, modules) = modules![td_module].com_cons_defs.[cons_ds.ds_index]
	# (type_expr, heaps) 	 = make_type_expr cons_exi_vars cons_type heaps
	# fun = makeFunction cons_info_ds.ds_ident group_index [] type_expr No main_module_index td_pos		
	= (fun, (modules, heaps))
where
	make_type_expr [] {st_vars, st_args, st_result} heaps=:{hp_type_heaps=type_heaps=:{th_vars}}
		# (_,th_vars) = foldSt (\ {tv_info_ptr} (n, th_vars) -> (n+1, writePtr tv_info_ptr (TVI_GenTypeVarNumber n) th_vars)) st_vars (0,th_vars)
		# heaps = {heaps & hp_type_heaps={type_heaps & th_vars=th_vars}}
		# (arg_exprs, heaps) = mapSt make_expr1 st_args heaps
		# (result_expr, heaps) = make_expr1 st_result heaps
		# {hp_type_heaps=type_heaps=:{th_vars}} = heaps
		# th_vars = foldSt (\ {tv_info_ptr} th_vars -> writePtr tv_info_ptr TVI_Empty th_vars) st_vars th_vars
		# heaps = {heaps & hp_type_heaps={type_heaps & th_vars=th_vars}}
		= curry arg_exprs result_expr heaps
	where
		curry [] result_expr heaps 
			= (result_expr, heaps)
		curry [x:xs] result_expr heaps
			# (y, heaps) = curry xs result_expr heaps
			= make_arrow x y heaps

		make_expr1 :: !AType !*Heaps -> (!Expression, !*Heaps)
		make_expr1 {at_type} heaps = make_expr at_type heaps

		make_expr :: !Type !*Heaps -> (!Expression, !*Heaps)
		make_expr (TA type_symb arg_types) heaps
			# (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
			# (type_cons, heaps) = make_type_cons type_symb.type_ident.id_name heaps 
			= make_apps type_cons arg_exprs heaps
		make_expr (TAS type_symb arg_types _) heaps
			# (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
			# (type_cons, heaps) = make_type_cons type_symb.type_ident.id_name heaps 
			= make_apps type_cons arg_exprs heaps
		make_expr (x --> y) heaps
			# (x, heaps) = make_expr1 x heaps
			# (y, heaps) = make_expr1 y heaps				
			= make_arrow x y heaps
		make_expr TArrow heaps 
			= make_type_cons "(->)" heaps
		make_expr (TArrow1 type) heaps
			# (arg_expr, heaps) = make_expr1 type heaps 
			# (arrow_expr, heaps) = make_type_cons "(->)" heaps
			= make_app arrow_expr arg_expr heaps
		make_expr (CV {tv_info_ptr} :@: arg_types) heaps
			# (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
			# (tv_expr, heaps) = make_type_var tv_info_ptr heaps
			= make_apps tv_expr arg_exprs heaps
		make_expr (TB bt) heaps
			= make_type_cons (toString bt) heaps	
		make_expr (TV {tv_info_ptr}) heaps 
			= make_type_var tv_info_ptr heaps 
		make_expr (GTV {tv_info_ptr}) heaps
			= make_type_var tv_info_ptr heaps 
		make_expr (TQV {tv_info_ptr}) heaps 
			= make_type_var tv_info_ptr heaps
		make_expr TE heaps
			= make_error_type_cons heaps
		make_expr (TFA _ _) heaps
			// error is reported in convertATypeToGenTypeStruct
			= make_error_type_cons heaps
		make_expr (TFAC _ _ _) heaps
			// error is reported in convertATypeToGenTypeStruct
			= make_error_type_cons heaps
		make_expr _ heaps
			= abort "type does not match\n"

		make_apps x [] heaps 
			= (x, heaps)
		make_apps x [y:ys] heaps
			# (z, heaps) = make_app x y heaps	
			= make_apps z ys heaps

		make_type_var tv_info_ptr heaps
			#! type_var_n = case sreadPtr tv_info_ptr heaps.hp_type_heaps.th_vars of
								TVI_GenTypeVarNumber n -> n
			= buildPredefConsApp PD_CGenTypeVar [makeIntExpr type_var_n] predefs heaps									

		make_arrow x y heaps = buildPredefConsApp PD_CGenTypeArrow [x, y] predefs heaps

		make_app x y heaps = buildPredefConsApp PD_CGenTypeApp [x, y] predefs heaps 	 

		make_error_type_cons heaps = make_type_cons "<error>" heaps
	make_type_expr [_:_] {st_vars, st_args, st_result} heaps
		// Error "cannot build a generic representation of an existential type" is reported in buildStructType
		= make_type_cons "<error>" heaps

	make_type_cons name heaps
		# name_expr = makeStringExpr name
		= buildPredefConsApp PD_CGenTypeCons [name_expr] predefs heaps

//	conversions functions

// buildConversionIso
buildConversionIso :: 
		!CheckedTypeDef		// the type definition
		!DefinedSymbol		// from fun
		!DefinedSymbol	 	// to fun
		!Index				// main module
		!PredefinedSymbols
		FunsAndGroups !*Heaps !*ErrorAdmin
	-> (!DefinedSymbol,
		FunsAndGroups,!*Heaps,!*ErrorAdmin)
buildConversionIso type_def=:{td_ident, td_pos} from_fun to_fun
		main_dcl_module_n predefs funs_and_groups heaps error
	#! (from_expr, heaps) 	= buildFunApp main_dcl_module_n from_fun [] heaps
	#! (to_expr, heaps) 	= buildFunApp main_dcl_module_n to_fun [] heaps	
	#! (iso_expr, heaps) 	= build_bimap_record to_expr from_expr predefs heaps
	
	#! ident = makeIdent ("iso" +++ td_ident.id_name)
	#! (def_sym, funs_and_groups) = buildFunAndGroup ident [] iso_expr No main_dcl_module_n td_pos funs_and_groups
	= (def_sym, funs_and_groups, heaps, error)

build_bimap_record to_expr from_expr predefs heaps 
	= buildPredefConsApp PD_ConsBimap [to_expr, from_expr] predefs heaps	

// conversion from type to generic
buildConversionTo ::
		!Index				// type def module
		!CheckedTypeDef 	// the type def
		!Index 				// main module
		!PredefinedSymbols
		!FunsAndGroups !*Heaps !*ErrorAdmin
	-> 	(!DefinedSymbol,
		 FunsAndGroups,!*Heaps,!*ErrorAdmin)
buildConversionTo		
		type_def_mod 
		type_def=:{td_rhs, td_ident, td_index, td_pos} 
		main_module_index predefs funs_and_groups heaps error
	# (arg_expr, arg_var, heaps) = buildVarExpr "x" heaps 
	# (body_expr, heaps, error) = 
		build_expr_for_type_rhs type_def_mod td_index td_rhs arg_expr heaps error
	# fun_name = makeIdent ("toGeneric" +++ td_ident.id_name)
	| not error.ea_ok
		# (def_sym, funs_and_groups) 
			= (buildFunAndGroup fun_name [] EE No main_module_index td_pos funs_and_groups)
		= (def_sym, funs_and_groups, heaps, error)
		# (def_sym, funs_and_groups) 
			= (buildFunAndGroup fun_name [arg_var] body_expr No main_module_index td_pos funs_and_groups)
		= (def_sym, funs_and_groups, heaps, error)
where
	// build conversion for type rhs
	build_expr_for_type_rhs :: 
			!Int 				// type def module
			!Int 				// type def index 
			!TypeRhs			// type def rhs 
			!Expression			// expression of the function argument variable   
			!*Heaps 
			!*ErrorAdmin
		-> 	( !Expression		// generated expression
			, !*Heaps	// state
			, !*ErrorAdmin)
 	build_expr_for_type_rhs type_def_mod type_def_index (AlgType def_symbols) arg_expr heaps error
		= build_expr_for_conses type_def_mod type_def_index def_symbols arg_expr heaps error
	build_expr_for_type_rhs type_def_mod type_def_index (RecordType {rt_constructor}) arg_expr heaps error		
		= build_expr_for_record type_def_mod type_def_index rt_constructor arg_expr heaps error
	build_expr_for_type_rhs type_def_mod type_def_index (AbstractType _) arg_expr  heaps error
		#! error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build isomorphisms for an abstract type" error
		= (EE, heaps, error)
	build_expr_for_type_rhs type_def_mod type_def_index (SynType _) arg_expr  heaps error
		#! error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build isomorphisms for a synonym type" error
		= (EE, heaps, error)

	// build conversion for constructors of a type def 	
	build_expr_for_conses type_def_mod type_def_index cons_def_syms arg_expr heaps error
		# (case_alts, heaps, error)
			= build_exprs_for_conses 0 (length cons_def_syms) type_def_mod cons_def_syms  heaps error
		# case_patterns = AlgebraicPatterns {gi_module = type_def_mod, gi_index = type_def_index} case_alts
		# (case_expr, heaps) = buildCaseExpr arg_expr case_patterns heaps
		= (case_expr, heaps, error)

	// build conversions for constructors 	
	build_exprs_for_conses :: !Int !Int !Int ![DefinedSymbol] !*Heaps !*ErrorAdmin
		-> ([AlgebraicPattern], !*Heaps, !*ErrorAdmin)
	build_exprs_for_conses i n type_def_mod [] heaps error
		= ([], heaps, error)
	build_exprs_for_conses i n type_def_mod [cons_def_sym:cons_def_syms] heaps error
		#! (alt, heaps, error) = build_expr_for_cons i n type_def_mod cons_def_sym heaps error
		#! (alts, heaps, error) =  build_exprs_for_conses (i+1) n type_def_mod cons_def_syms heaps error 		
		= ([alt:alts], heaps, error)

	// build conversion for a constructor	
	build_expr_for_cons :: !Int !Int !Int !DefinedSymbol !*Heaps !*ErrorAdmin 
		-> (AlgebraicPattern, !*Heaps, !*ErrorAdmin)
	build_expr_for_cons i n type_def_mod cons_def_sym=:{ds_ident, ds_arity} heaps error	
		#! names = ["x" +++ toString (i+1) +++ toString k \\ k <- [1..ds_arity]]
		#! (var_exprs, vars, heaps) = buildVarExprs names heaps 

		#! arg_exprs = var_exprs

		#! (expr, heaps) = build_prod arg_exprs predefs heaps
		#! (expr, heaps) = build_cons expr predefs heaps
		#! (expr, heaps) = build_sum i n expr predefs heaps
				
		#! (expr, heaps) = build_object expr predefs heaps
						
		#! alg_pattern = {
			ap_symbol = {glob_module = type_def_mod, glob_object = cons_def_sym},
			ap_vars = vars,
			ap_expr = expr,
			ap_position = NoPos
			}
		= (alg_pattern, heaps, error)	

	build_sum :: !Int !Int !Expression !PredefinedSymbols !*Heaps -> (!Expression, !*Heaps)
	build_sum i n expr predefs heaps
		| n == 0 	= abort "build sum of zero elements\n"
		| i >= n	= abort "error building sum"
		| n == 1 	= (expr, heaps)
		| i < (n/2) 
			# (expr, heaps) = build_sum i (n/2) expr predefs heaps
			= build_left expr predefs heaps
		| otherwise
			# (expr, heaps) = build_sum (i - (n/2)) (n - (n/2)) expr predefs heaps
			= build_right expr predefs heaps

	// build conversion for a record type def
	build_expr_for_record type_def_mod type_def_index cons_def_sym=:{ds_ident, ds_arity} arg_expr heaps error
		#! names = ["x1" +++ toString k \\ k <- [1..ds_arity]]
		#! (var_exprs, vars, heaps) = buildVarExprs names heaps 
		#! (arg_exprs, heaps) = mapSdSt build_field var_exprs predefs heaps
		#! (expr, heaps) = build_prod arg_exprs predefs heaps
		#! (expr, heaps) = build_record expr predefs heaps
		#! alg_pattern = { ap_symbol = {glob_module = type_def_mod, glob_object = cons_def_sym},
						   ap_vars = vars, ap_expr = expr, ap_position = NoPos }
		# case_patterns = AlgebraicPatterns {gi_module = type_def_mod, gi_index = type_def_index} [alg_pattern]
		# (case_expr, heaps) = buildCaseExpr arg_expr case_patterns heaps
		= (case_expr, heaps, error)

	build_prod :: ![Expression] !PredefinedSymbols !*Heaps -> (!Expression, !*Heaps)
	build_prod [] predefs heaps = build_unit heaps
	where
		build_unit heaps = buildPredefConsApp PD_ConsUNIT [] predefs heaps 	
	build_prod [expr] predefs heaps = (expr, heaps)
	build_prod exprs predefs heaps
		# (lexprs, rexprs) = splitAt ((length exprs)/2) exprs  
		# (lexpr, heaps) = build_prod lexprs predefs heaps
		# (rexpr, heaps) = build_prod rexprs predefs heaps
		= build_pair lexpr rexpr predefs heaps

buildConversionFrom	::	
		!Index				// type def module
		!CheckedTypeDef 	// the type def
		!Index 				// main module
		!PredefinedSymbols
		!FunsAndGroups !*Heaps !*ErrorAdmin
	-> (!DefinedSymbol,
		 FunsAndGroups,!*Heaps,!*ErrorAdmin)
buildConversionFrom
		type_def_mod 
		type_def=:{td_rhs, td_ident, td_pos} 
		main_module_index predefs funs_and_groups heaps error
	# (body_expr, arg_var, heaps, error) = 
		build_expr_for_type_rhs type_def_mod td_rhs heaps error
	# fun_name = makeIdent ("fromGeneric" +++ td_ident.id_name)
	| not error.ea_ok
		# (def_sym, funs_and_groups) 
			= (buildFunAndGroup fun_name [] EE No main_module_index td_pos funs_and_groups)
		= (def_sym, funs_and_groups, heaps, error)
		# (def_sym, funs_and_groups) 
			= (buildFunAndGroup fun_name [arg_var] body_expr No main_module_index td_pos funs_and_groups)
		= (def_sym, funs_and_groups, heaps, error)
where
	// build expression for type def rhs
	build_expr_for_type_rhs :: 
			!Index				// type def module
			!TypeRhs			// type rhs
			!*Heaps !*ErrorAdmin	
		-> 	( !Expression		// body expresssion
			, !FreeVar
			, !*Heaps, !*ErrorAdmin)
	build_expr_for_type_rhs type_def_mod (AlgType def_symbols) heaps error
		#! (expr, var, heaps, error) = build_sum type_def_mod def_symbols heaps error
		#! (expr, var, heaps) = build_case_object var expr predefs heaps
		= (expr, var, heaps, error)
	build_expr_for_type_rhs type_def_mod (RecordType {rt_constructor}) heaps error				
		# (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
		# 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
		# dummy_fv = {fv_def_level=(-1), fv_count=0, fv_ident=makeIdent "dummy", fv_info_ptr=nilPtr}
		= (EE, dummy_fv, heaps, error)
	
	// build expression for sums
	build_sum :: !Index ![DefinedSymbol] !*Heaps !*ErrorAdmin -> (!Expression,!FreeVar/*top variable*/,!*Heaps,!*ErrorAdmin)
	build_sum type_def_mod [] heaps error
		= abort "algebraic type with no constructors!\n"
	build_sum type_def_mod [def_symbol] heaps error
		#! (cons_app_expr, cons_arg_vars, heaps) = build_cons_app type_def_mod def_symbol heaps
		#! (prod_expr, var, heaps) = build_prod False cons_app_expr cons_arg_vars heaps 
		#! (alt_expr, var, heaps) = build_case_cons var prod_expr predefs heaps
		= (alt_expr, var, heaps, error)
	build_sum type_def_mod def_symbols heaps error
		#! (left_def_syms, right_def_syms) = splitAt ((length def_symbols) /2) def_symbols
		#! (left_expr, left_var, heaps, error) 
			= build_sum type_def_mod left_def_syms heaps error
		#! (right_expr, right_var, heaps, error)
			= build_sum type_def_mod right_def_syms heaps error	
		#! (case_expr, var, heaps)
			= build_case_either left_var left_expr right_var right_expr predefs heaps
		= (case_expr, var, heaps, error)

	build_record :: !Index ![DefinedSymbol] !*Heaps !*ErrorAdmin -> (!Expression,!FreeVar/*top variable*/,!*Heaps,!*ErrorAdmin)
	build_record type_def_mod [def_symbol] heaps error
		#! (cons_app_expr, cons_arg_vars, heaps) = build_cons_app type_def_mod def_symbol heaps
		#! (prod_expr, var, heaps) = build_prod True cons_app_expr cons_arg_vars heaps 
		#! (alt_expr, var, heaps) = build_case_record var prod_expr predefs heaps
		= (alt_expr, var, heaps, error)

	// build expression for products
	build_prod :: 
			!Bool							// is record
			!Expression   					// result of the case on product
			![FreeVar] 						// list of variables of the constructor pattern
			!*Heaps
		-> 	( !Expression					// generated product
			, !FreeVar						// top variable
			, !*Heaps
			)
	build_prod is_record expr [] heaps
		= build_case_unit expr heaps	
	build_prod is_record expr [cons_arg_var] heaps
		| is_record
			= build_case_field cons_arg_var expr predefs heaps
			= (expr, cons_arg_var, heaps)
	build_prod is_record expr cons_arg_vars heaps
		#! (left_vars, right_vars) = splitAt ((length cons_arg_vars) /2) cons_arg_vars		 
		#! (expr, right_var, heaps) = build_prod is_record expr right_vars heaps
		#! (expr, left_var, heaps) = build_prod is_record expr left_vars heaps
		#! (case_expr, var, heaps) = build_case_pair left_var right_var expr predefs heaps
		= (case_expr, var, heaps) 
	
	// build constructor application expression
	build_cons_app :: !Index !DefinedSymbol !*Heaps 
		-> (!Expression, ![FreeVar], !*Heaps)
	build_cons_app cons_mod def_symbol=:{ds_arity} heaps
		#! names = ["x"  +++ toString k \\ k <- [1..ds_arity]]
		#! (var_exprs, vars, heaps) = buildVarExprs names heaps 
		#! (expr, heaps) = buildConsApp cons_mod def_symbol var_exprs heaps
	 	= (expr, vars, heaps)

	build_case_unit body_expr heaps
		# unit_pat = buildPredefConsPattern PD_ConsUNIT [] body_expr predefs
		# {pds_module, pds_def} = predefs.[PD_TypeUNIT]
		# case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [unit_pat]
		= build_case_expr case_patterns heaps

build_pair x y predefs heaps
	= buildPredefConsApp PD_ConsPAIR [x, y] predefs heaps

build_left x predefs heaps
	= buildPredefConsApp PD_ConsLEFT [x] predefs heaps

build_right x predefs heaps
	= buildPredefConsApp PD_ConsRIGHT [x] predefs heaps

build_object expr predefs heaps
	= buildPredefConsApp PD_ConsOBJECT [expr] predefs heaps						

build_cons expr predefs heaps
	= buildPredefConsApp PD_ConsCONS [expr] predefs heaps

build_record expr predefs heaps
	= buildPredefConsApp PD_ConsRECORD [expr] predefs heaps

build_field var_expr predefs heaps
	= buildPredefConsApp PD_ConsFIELD [var_expr] predefs heaps 

build_case_pair var1 var2 body_expr predefs heaps
	# pair_pat = buildPredefConsPattern PD_ConsPAIR [var1, var2] body_expr predefs	
	# {pds_module, pds_def} = predefs.[PD_TypePAIR]
	# case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [pair_pat]
	= build_case_expr case_patterns heaps

build_case_either left_var left_expr right_var right_expr predefs heaps
	# left_pat = buildPredefConsPattern PD_ConsLEFT [left_var] left_expr predefs
	# right_pat = buildPredefConsPattern PD_ConsRIGHT [right_var] right_expr predefs
	# {pds_module, pds_def} = predefs.[PD_TypeEITHER]
	# case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [left_pat, right_pat]
	= build_case_expr case_patterns heaps

build_case_object var body_expr predefs heaps
	# pat = buildPredefConsPattern PD_ConsOBJECT [var] body_expr predefs	
	# {pds_module, pds_def} = predefs.[PD_TypeOBJECT]
	# case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [pat]
	= build_case_expr case_patterns heaps

build_case_cons var body_expr predefs heaps
	# pat = buildPredefConsPattern PD_ConsCONS [var] body_expr predefs	
	# {pds_module, pds_def} = predefs.[PD_TypeCONS]
	# case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [pat]
	= build_case_expr case_patterns heaps 

build_case_record var body_expr predefs heaps
	# pat = buildPredefConsPattern PD_ConsRECORD [var] body_expr predefs	
	# {pds_module, pds_def} = predefs.[PD_TypeRECORD]
	# case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [pat]
	= build_case_expr case_patterns heaps 

build_case_field var body_expr predefs heaps
	# pat = buildPredefConsPattern PD_ConsFIELD [var] body_expr predefs	
	# {pds_module, pds_def} = predefs.[PD_TypeFIELD]
	# case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [pat]
	= build_case_expr case_patterns heaps 

// case with a variable as the selector expression
build_case_expr case_patterns heaps
	# (var_expr, var, heaps) = buildVarExpr "c" heaps
	# (case_expr, heaps) = buildCaseExpr var_expr case_patterns heaps
	= (case_expr, var, heaps)

// build kind indexed classes 

buildClasses :: !*GenericState -> *GenericState
buildClasses gs=:{gs_main_module}
	#! ({com_class_defs,com_member_defs},gs) = gs!gs_modules.[gs_main_module]
	#! num_classes = size com_class_defs
	#! num_members = size com_member_defs

	#! ((classes, members, new_num_classes, new_num_members), gs)
		= build_modules 0 ([], [], num_classes, num_members) gs

	// obtain common definitions again because com_gencase_defs are updated 
	#! (common_defs,gs) = gs!gs_modules.[gs_main_module]
	# common_defs = {common_defs & com_class_defs = arrayPlusRevList com_class_defs classes
								 , com_member_defs = arrayPlusRevList com_member_defs members}