generics1.icl

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

implementation module generics1

import StdEnv
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_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) = replace 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	
	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_info & gen_classes = createArray 32 [] }
		#! 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_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

:: ConsInfo = {ci_cons_info :: DefinedSymbol, ci_field_infos :: [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_info, cons_infos, funs_and_groups, gs_modules, heaps, gs_error)
		= buildTypeDefInfo type_index.gi_module type_def 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_info cons_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 type_index (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 (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 (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
		!DefinedSymbol 				// type_info
		![ConsInfo]					// constructor and field info symbols
		!PredefinedSymbols
		(!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
	-> 	( !GenTypeStruct			// the structure type
		, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
		)
buildStructType {gi_module,gi_index} type_info cons_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_info cons_infos (modules, td_infos, heaps, error)	
where
	build_type {td_rhs=AlgType alts, td_ident, td_pos} 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} 
			type_info  [{ci_cons_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		
			# type = GTSCons ci_cons_info prod_type
			= (GTSObject type_info 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_info cons_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_info cdis (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} {ci_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 ci_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 :: 
		!Index 				// type def module
		!CheckedTypeDef		// the type definition
		!Index				// icl module
		!PredefinedSymbols		
		!FunsAndGroups !*Modules !*Heaps !*ErrorAdmin
	-> 	( DefinedSymbol	// type info
		, ![ConsInfo]
		, !FunsAndGroups, !*Modules, !*Heaps, !*ErrorAdmin)
buildTypeDefInfo td_module td=:{td_rhs = AlgType alts} main_module_index predefs funs_and_groups modules heaps error
	= buildTypeDefInfo1 td_module td alts [] main_module_index predefs funs_and_groups modules heaps error
buildTypeDefInfo td_module td=:{td_rhs = RecordType {rt_constructor, rt_fields}} main_module_index predefs funs_and_groups modules heaps error
	= buildTypeDefInfo1 td_module td [rt_constructor] [x\\x<-:rt_fields] main_module_index predefs funs_and_groups modules heaps error
buildTypeDefInfo td_module td=:{td_rhs = SynType type, td_ident, td_pos} 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
	= buildTypeDefInfo1 td_module td [] [] main_module_index predefs funs_and_groups modules heaps error
buildTypeDefInfo td_module td=:{td_rhs = AbstractType _, td_ident, td_pos} 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
	= buildTypeDefInfo1 td_module td [] [] main_module_index predefs funs_and_groups modules heaps error

buildTypeDefInfo1 td_module {td_ident, td_pos, td_arity} alts fields 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
	# num_fields = length fields
	# new_group_index = inc group_index

	# type_def_dsc_index = fun_index
	# first_cons_dsc_index = fun_index + 1
	# cons_dsc_indexes = [first_cons_dsc_index .. first_cons_dsc_index + num_conses - 1]
	# first_field_dsc_index = first_cons_dsc_index + num_conses
	# field_dsc_indexes = [first_field_dsc_index .. first_field_dsc_index + num_fields - 1]
	# new_fun_index = first_field_dsc_index + num_fields

	# group = {group_members = [fun_index .. new_fun_index - 1]}
	# new_groups = [group:groups]
	
	# type_def_dsc_ds = {ds_arity=0, ds_ident=makeIdent("tdi_"+++td_ident.id_name), ds_index=type_def_dsc_index}
	# cons_dsc_dss = [ {ds_arity=0, ds_ident=makeIdent("cdi_"+++ds_ident.id_name), ds_index=i} \\ 
		{ds_ident} <- alts & i <- cons_dsc_indexes]
	# field_dsc_dss = [ {ds_arity=0, ds_ident=makeIdent("fdi_"+++fs_ident.id_name), ds_index=i} \\ 
		{fs_ident} <- fields & i <- field_dsc_indexes]

	# (type_def_dsc_fun, heaps) = build_type_def_dsc group_index cons_dsc_dss type_def_dsc_ds heaps	
	
	# (cons_dsc_funs, (modules, heaps)) = zipWithSt (build_cons_dsc group_index type_def_dsc_ds field_dsc_dss) cons_dsc_dss alts (modules, heaps)

	# (field_dsc_funs, (modules, heaps)) = zipWithSt (build_field_dsc group_index (hd cons_dsc_dss)) field_dsc_dss fields (modules, heaps)
	 
	// NOTE: reverse order (new functions are added at the head) 
	# new_funs = (reverse field_dsc_funs) ++ (reverse cons_dsc_funs) ++ [type_def_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}

	# (type_info_ds, (funs_and_groups, heaps)) 
		= build_type_info type_def_dsc_ds (funs_and_groups, heaps)
	
	# (cons_info_dss, (funs_and_groups, heaps)) 
		= mapSt build_cons_info cons_dsc_dss (funs_and_groups, heaps)

	# (field_info_dss, (funs_and_groups, heaps)) 
		= mapSt build_field_info field_dsc_dss (funs_and_groups, heaps)

	# cons_infos = case (cons_info_dss, field_info_dss) of
		([cons_info_ds], field_infos) -> [{ci_cons_info = cons_info_ds, ci_field_infos = field_infos}] 	 
		(cons_info_dss, []) -> [{ci_cons_info=x,ci_field_infos=[]}\\x<-cons_info_dss]
		_ -> abort "generics.icl sanity check: fields in non-record type\n"

	= (type_info_ds, cons_infos, funs_and_groups, modules, heaps, error)
where
	build_type_def_dsc group_index cons_info_dss {ds_ident} heaps
		# td_name_expr = makeStringExpr td_ident.id_name
		# td_arity_expr = makeIntExpr td_arity
		# num_conses_expr = makeIntExpr (length alts)
		# (cons_info_exprs, heaps) = mapSt (\x st->buildFunApp main_module_index x [] st) cons_info_dss heaps
		# (td_conses_expr, heaps) = makeListExpr cons_info_exprs predefs heaps
		
		# (body_expr, heaps) = buildPredefConsApp PD_CGenericTypeDefDescriptor 
			[ td_name_expr
			, td_arity_expr
			, num_conses_expr 
			, td_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 field_dsc_dss cons_info_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
		# arity_expr 			 = makeIntExpr cons_type.st_arity
		# (prio_expr, heaps)	 = make_prio_expr cons_priority heaps
		# (type_def_expr, heaps) = buildFunApp main_module_index type_def_info_ds [] heaps
		# (type_expr, heaps) 	 = make_type_expr cons_exi_vars cons_type heaps 			
		# (field_exprs, heaps)   = mapSt (\x st->buildFunApp main_module_index x [] st) field_dsc_dss heaps
		# (fields_expr, heaps)   =  makeListExpr field_exprs predefs heaps 
		# cons_index_expr		 = makeIntExpr cons_number
		# (body_expr, heaps) 
			= buildPredefConsApp PD_CGenericConsDescriptor 
				[ name_expr 
				, arity_expr
				, prio_expr
				, type_def_expr
				, type_expr
				, fields_expr 
				, cons_index_expr
				]  
				predefs heaps

		# fun = makeFunction cons_info_ds.ds_ident group_index [] body_expr No main_module_index td_pos		
		= (fun, (modules, heaps))
	where
		make_prio_expr NoPrio heaps
			= buildPredefConsApp PD_CGenConsNoPrio [] predefs heaps
		make_prio_expr (Prio assoc prio) 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 

		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 _ 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

	build_field_dsc group_index cons_dsc_ds field_dsc_ds {fs_ident, fs_index} (modules, heaps)
		# name_expr = makeStringExpr fs_ident.id_name
		# ({sd_field_nr}, modules)	
			= modules! [td_module].com_selector_defs.[fs_index]  		
		# index_expr = makeIntExpr sd_field_nr
		# (cons_expr, heaps) = buildFunApp main_module_index cons_dsc_ds [] heaps				
		# (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_cons_info cons_dsc_ds (funs_and_groups, heaps)
		# ident = makeIdent ("g"+++cons_dsc_ds.ds_ident.id_name)	

		# (cons_dsc_expr, heaps) = buildFunApp main_module_index cons_dsc_ds [] heaps

		# (body_expr, heaps) 
			= buildPredefConsApp PD_GenericConsInfo [cons_dsc_expr] predefs heaps		

		# (def_sym, funs_and_groups) = buildFunAndGroup ident [] body_expr No main_module_index td_pos funs_and_groups
		= (def_sym, (funs_and_groups, heaps))

	build_field_info field_dsc_ds (funs_and_groups, heaps)
		# ident = makeIdent ("g"+++field_dsc_ds.ds_ident.id_name)	

		# (field_dsc_expr, heaps) = buildFunApp main_module_index field_dsc_ds [] heaps

		# (body_expr, heaps) 
			= buildPredefConsApp PD_GenericFieldInfo [field_dsc_expr] predefs heaps		

		# (def_sym, funs_and_groups) = buildFunAndGroup ident [] body_expr No main_module_index td_pos funs_and_groups
		= (def_sym, (funs_and_groups, heaps))

	build_type_info type_dsc_ds (funs_and_groups, heaps)
		# ident = makeIdent ("g"+++type_dsc_ds.ds_ident.id_name)	

		# (type_dsc_expr, heaps) = buildFunApp main_module_index type_dsc_ds [] heaps

		# (body_expr, heaps) 
			= buildPredefConsApp PD_GenericTypeInfo [type_dsc_expr] predefs heaps		

		# (def_sym, funs_and_groups) = buildFunAndGroup ident [] body_expr No main_module_index td_pos funs_and_groups
		= (def_sym, (funs_and_groups, 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 False 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_conses True 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 is_record type_def_mod type_def_index cons_def_syms arg_expr heaps error
		# (case_alts, heaps, error)
			= build_exprs_for_conses is_record 0 (length cons_def_syms) type_def_mod cons_def_syms  heaps error
		# case_patterns = AlgebraicPatterns {glob_module = type_def_mod, glob_object = 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 :: !Bool !Int !Int !Int ![DefinedSymbol] !*Heaps !*ErrorAdmin
		-> ([AlgebraicPattern], !*Heaps, !*ErrorAdmin)
	build_exprs_for_conses is_record i n type_def_mod [] heaps error
		= ([], heaps, error)
	build_exprs_for_conses is_record i n type_def_mod [cons_def_sym:cons_def_syms] heaps error
		#! (alt, heaps, error) = build_expr_for_cons is_record i n type_def_mod cons_def_sym heaps error
		#! (alts, heaps, error) =  build_exprs_for_conses is_record (i+1) n type_def_mod cons_def_syms heaps error 		
		= ([alt:alts], heaps, error)

	// build conversion for a constructor	
	build_expr_for_cons :: !Bool !Int !Int !Int !DefinedSymbol !*Heaps !*ErrorAdmin 
		-> (AlgebraicPattern, !*Heaps, !*ErrorAdmin)
	build_expr_for_cons is_record 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, heaps) = build_fields is_record var_exprs heaps
			with
				build_fields False var_exprs heaps = (var_exprs, heaps)
				build_fields True var_exprs heaps = mapSdSt build_field var_exprs predefs heaps

		#! (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_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_index, 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 False 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_sum True type_def_mod [rt_constructor] heaps	error
		#! (expr, var, heaps) = build_case_object var expr predefs heaps
		= (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 ::
			!Bool				// is record 
			!Index 
			![DefinedSymbol] 
			!*Heaps !*ErrorAdmin
		-> 	( !Expression
			, !FreeVar			// top variable
			, !*Heaps, !*ErrorAdmin)
	build_sum is_record type_def_mod [] heaps error
		= abort "algebraic type with no constructors!\n"
	build_sum is_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 is_record 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 is_record 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 is_record type_def_mod left_def_syms heaps error
		#! (right_expr, right_var, heaps, error)
			= build_sum is_record 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 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 {glob_module = pds_module, glob_object = 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_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 {glob_module = pds_module, glob_object = 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 {glob_module = pds_module, glob_object = 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 {glob_module = pds_module, glob_object = 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 {glob_module = pds_module, glob_object = 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 {glob_module = pds_module, glob_object = 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}

	#! (common_defs, gs)
		= build_class_dictionaries common_defs gs

	= {gs & gs_modules.[gs_main_module] = common_defs}
where
	build_modules :: !Index (![ClassDef], ![MemberDef], !Int, !Int) !*GenericState
		-> ((![ClassDef], ![MemberDef], !Int, !Int), !*GenericState)
	build_modules module_index st gs=:{gs_modules,gs_used_modules}
		| module_index == size gs_modules
			= (st, gs)
		| not (inNumberSet module_index gs_used_modules)
			= build_modules (inc module_index) st gs		
			#! ({com_gencase_defs},gs_modules) = gs_modules![module_index] 
			#! (com_gencase_defs, st, gs) 
				= build_module module_index 0 {x\\x<-:com_gencase_defs} st {gs & gs_modules=gs_modules}
			#! gs = {gs & gs_modules.[module_index].com_gencase_defs = com_gencase_defs}
			= build_modules (inc module_index) st gs

	build_module module_index index com_gencase_defs st gs
		| index == size com_gencase_defs
			= (com_gencase_defs, st, gs)
			#! (gencase, com_gencase_defs) = com_gencase_defs ! [index]
			#! (gencase, st, gs) = on_gencase module_index index gencase st gs
			#! com_gencase_defs = {com_gencase_defs & [index] = gencase} 	
			= build_module module_index (inc index) com_gencase_defs st gs

	on_gencase :: !Index !Index
			!GenericCaseDef (![ClassDef], ![MemberDef], !Index, Index) !*GenericState
		-> (!GenericCaseDef,(![ClassDef], ![MemberDef], !Index, Index), !*GenericState)
	on_gencase module_index index
				gencase=:{gc_ident,gc_generic, gc_type_cons} st gs=:{gs_modules, gs_td_infos}
		#! (gen_def, gs_modules) = gs_modules![gc_generic.gi_module].com_generic_defs.[gc_generic.gi_index]
		#! (kind, gs_td_infos) = get_kind_of_type_cons gc_type_cons gs_td_infos

		// To generate all partially applied shorthand instances we need
		// classes for all partial applications of the gc_kind and for
		// all the argument kinds.
		// Additionally, we always need classes for base cases *, *->* and *->*->* 

		#! gs = {gs & gs_modules = gs_modules, gs_td_infos = gs_td_infos}
		#! subkinds = determine_subkinds kind 		
		#! kinds = 
			[ KindConst
			, KindArrow [KindConst]
			, KindArrow [KindConst, KindConst] 
			: subkinds]
		#! (st, gs) = foldSt (build_class_if_needed gen_def) kinds (st, gs)
		#! gencase = {gencase & gc_kind = kind}

		#! type_index = index_OBJECT_CONS_FIELD_type gencase.gc_type gs.gs_predefs
		| type_index>=0		
			# ({gc_body = GCB_FunIndex fun_index}) = gencase
			  gen_info_ptr = gen_def.gen_info_ptr

			  fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
			  ocf_index = {ocf_module=module_index,ocf_index=fun_index,ocf_ident=fun_ident}

			  (gen_info,generic_heap) = readPtr gen_info_ptr gs.gs_genh
			  gen_OBJECT_CONS_FIELD_indices = {gi\\gi<-:gen_info.gen_OBJECT_CONS_FIELD_indices}
			  gen_OBJECT_CONS_FIELD_indices = {gen_OBJECT_CONS_FIELD_indices & [type_index]=ocf_index}
			  gen_info = {gen_info & gen_OBJECT_CONS_FIELD_indices=gen_OBJECT_CONS_FIELD_indices}
			  generic_heap = writePtr gen_info_ptr gen_info generic_heap
			  gs = {gs & gs_genh=generic_heap}
			= (gencase, st, gs)

			= (gencase, st, gs)

	build_class_if_needed :: !GenericDef !TypeKind ((![ClassDef], ![MemberDef], !Index, Index), *GenericState)
		-> ((![ClassDef], ![MemberDef], !Index, Index), *GenericState)		
	build_class_if_needed gen_def kind ((classes, members, class_index, member_index), gs=:{gs_main_module, gs_genh})
		#! (opt_class_info, gs_genh) = lookup_generic_class_info gen_def kind gs_genh
		#! gs = {gs & gs_genh = gs_genh}
		= case opt_class_info of