path: root/frontend/generics.icl

implementation module generics

import StdEnv
import _aconcat
import hashtable
import checksupport
import checktypes
import check
from transform import Group
import analtypes

// whether to generate CONS 
// (needed for function that use CONS, like toString) 
supportCons :== True

// whether to bind _cons_info to actual constructor info
// (needed for functions that create CONS, like fromString)			
supportConsInfo :== False && supportCons

// whether generate missing alternatives 		
supportPartialInstances :== True

:: *GenericState = {
	gs_modules				:: !*{#CommonDefs},
	gs_fun_defs				:: !*{# FunDef},
	gs_groups				:: !{!Group},
	gs_td_infos 			:: !*TypeDefInfos,
	gs_gtd_infos			:: !*GenericTypeDefInfos,
	gs_heaps				:: !*Heaps,
	gs_main_dcl_module_n	:: !Index,
	gs_first_fun			:: !Index,
	gs_last_fun				:: !Index,
	gs_first_group			:: !Index,
	gs_last_group			:: !Index,
	gs_predefs				:: !PredefinedSymbols,
	gs_error 				:: !*ErrorAdmin	
	}

:: GenericTypeDefInfo  
	= GTDI_Empty 							// no generic rep needed
	| GTDI_Generic GenericTypeRep			// generic representataion

:: GenericTypeDefInfos :== {# .{GenericTypeDefInfo}}

:: GenericTypeRep = 
	{	gtr_type 				:: !AType			// generic type representation
	,	gtr_type_args			:: ![TypeVar]		// same as in td_info
	,	gtr_iso					:: !DefinedSymbol	// isomorphim function index 		
	,	gtr_isomap_group		:: !Index 			// isomap function group
	,	gtr_isomap				:: !DefinedSymbol	// isomap function for the type
 	,	gtr_isomap_from			:: !DefinedSymbol	// from-part of isomap
	,	gtr_isomap_to			:: !DefinedSymbol 	// to-part	
	,	gtr_type_info			:: !DefinedSymbol	// type def info
	,	gtr_cons_infos			:: ![DefinedSymbol] // constructor informations
	}

EmptyDefinedSymbol :== MakeDefinedSymbol {id_name="",id_info=nilPtr} NoIndex 0	
EmptyGenericType :== 
	{	gtr_type 		= makeAType TE TA_None
	,	gtr_type_args	= [] 
	,	gtr_iso 		= EmptyDefinedSymbol 
	,	gtr_isomap_group = NoIndex 
	,	gtr_isomap 		= EmptyDefinedSymbol
	,	gtr_isomap_from = EmptyDefinedSymbol
	,	gtr_isomap_to 	= EmptyDefinedSymbol
	,	gtr_type_info 	= EmptyDefinedSymbol
	,	gtr_cons_infos 	= []
	}

:: IsoDirection = IsoTo | IsoFrom

instance toBool GenericTypeDefInfo where
	toBool GTDI_Empty 		= False
	toBool (GTDI_Generic _) 	= True

convertGenerics :: !{!Group} !Int !{#CommonDefs} !*{# FunDef} !*TypeDefInfos !*Heaps !*HashTable !*PredefinedSymbols !u:{# DclModule} !*ErrorAdmin 
	-> (!{!Group}, !{#CommonDefs}, !*{# FunDef}, !IndexRange, !*TypeDefInfos, !*Heaps, !*HashTable, !*PredefinedSymbols, !u:{# DclModule}, !*ErrorAdmin)
convertGenerics 
		groups main_dcl_module_n modules fun_defs td_infos heaps
		hash_table predefs dcl_modules error

	#! (fun_defs_size, fun_defs) = usize fun_defs 
	#! groups_size = size groups	

	#! (predef_size, predefs) = usize predefs
	#! (gs_predefs, predefs) = arrayCopyBegin predefs predef_size
	
	// ??? How to map 2-d unique array not so ugly ??? 
	#! (td_infos_sizes, td_infos) = get_sizes 0 td_infos
		with 
			get_sizes :: Int !*TypeDefInfos -> ([Int], !*TypeDefInfos)
			get_sizes n td_infos
				#! td_infos_size = size td_infos
				| n == td_infos_size = ([], td_infos)
				#! row_size = size td_infos.[n]
				# (row_sizes, td_infos) = get_sizes (n + 1) td_infos
				= ([row_size : row_sizes], td_infos)
	#! gtd_infos = { createArray s GTDI_Empty \\ s <- td_infos_sizes } 
								
	#! gs = {gs_modules = {m \\m <-: modules}, // unique copy
			gs_groups = groups, gs_fun_defs = fun_defs, 
			gs_td_infos = td_infos,
			gs_gtd_infos = gtd_infos, 
			gs_heaps = heaps,
			gs_main_dcl_module_n = main_dcl_module_n,
			gs_first_fun = fun_defs_size, gs_last_fun = fun_defs_size,
			gs_first_group = groups_size, gs_last_group = groups_size,
			gs_predefs = gs_predefs,
			gs_error = error} 
	
	
	#! gs = collectInstanceKinds gs
		//---> "*** collect kinds used in generic instances and update generics with them"
	#! (ok,gs) = gs!gs_error.ea_ok
	| not ok 
		= return gs predefs hash_table dcl_modules
			
	#! gs = buildClasses gs
		//---> "*** build generic classes for all used kinds"
	#! (ok,gs) = gs!gs_error.ea_ok
	| not ok 
		= return gs predefs hash_table dcl_modules

	#! (generic_types, gs) = collectGenericTypes gs
		//---> "*** collect types of generics (needed for generic representation)"
	#! (ok,gs) = gs!gs_error.ea_ok
	| not ok 
		= return gs predefs hash_table dcl_modules

	#! (instance_types, gs) = convertInstances gs
		//---> "*** bind generic instances to classes and collect instance types"
	#! (ok,gs) = gs!gs_error.ea_ok
	| not ok 
		= return gs predefs hash_table dcl_modules
	
	#! (cons_funs, cons_groups, gs) = buildConsInstances gs
	| not ok 
		//---> "*** bind function for CONS"
		= return gs predefs hash_table dcl_modules
			
	#! (td_indexes, gs) = collectGenericTypeDefs generic_types instance_types gs	
		//---> "*** collect type definitions for which a generic representation must be created"
	#! (ok,gs) = gs!gs_error.ea_ok
	| not ok 
		= return gs predefs hash_table dcl_modules

	#! (iso_funs, iso_groups, gs) = buildIsoFunctions td_indexes gs	
		//---> "*** build isomorphisms for type definitions"	
	#! (ok,gs) = gs!gs_error.ea_ok
	| not ok 
		= return gs predefs hash_table dcl_modules

	#! (isomap_type_funs, isomap_type_groups, gs) = buildIsomapsForTypeDefs td_indexes gs	
		//---> "*** build maps for type definitions"	
	#! (ok,gs) = gs!gs_error.ea_ok
	| not ok 
		= return gs predefs hash_table dcl_modules

	#! (isomap_gen_funs, isomap_gen_groups, gs) = buildIsomapsForGenerics gs 		
		//---> "*** build maps for generic function types"	
	#! (ok,gs) = gs!gs_error.ea_ok
	| not ok 
		= return gs predefs hash_table dcl_modules

	#! (instance_funs, instance_groups, gs) = buildInstances gs
		//---> "*** build instances"	
	#! (ok,gs) = gs!gs_error.ea_ok
	| not ok 
		= return gs predefs hash_table dcl_modules


	#! (star_funs, star_groups, gs) = buildKindConstInstances gs
		//---> "*** build shortcut instances for kind *"	
	#! (ok,gs) = gs!gs_error.ea_ok
	| not ok 
		= return gs predefs hash_table dcl_modules

	// the order in the lists below is important! 
	// Indexes are allocated in that order.
	#! new_funs = cons_funs ++ iso_funs ++ isomap_type_funs ++ isomap_gen_funs ++ instance_funs ++ star_funs
	#! new_groups = cons_groups ++ iso_groups ++ isomap_type_groups ++ isomap_gen_groups ++ instance_groups ++ star_groups	

	#! gs = addFunsAndGroups new_funs new_groups gs	
		//---> "*** add geenrated functions"
	#! (ok,gs) = gs!gs_error.ea_ok
	| not ok 
		= return gs predefs hash_table dcl_modules

	#! gs = determineMemberTypes 0 0 gs
		//---> "*** determine types of member instances"	
	#! (ok,gs) = gs!gs_error.ea_ok
	| not ok 
		= return gs predefs hash_table dcl_modules
	
	//| True
	//	= abort "-----------------\n"
				
	#! {gs_modules, gs_groups, gs_fun_defs, gs_td_infos, 
		gs_heaps,
		gs_error} = gs	
	
	#! {hte_symbol_heap} = hash_table
	#! cs = {
		cs_symbol_table = hte_symbol_heap, 
		cs_predef_symbols = predefs, 
		cs_error = gs_error, 
		cs_x= {
			x_needed_modules = 0,
			x_main_dcl_module_n = main_dcl_module_n, 
			x_is_dcl_module = False,
			x_type_var_position = 0
			}
		}

	#! (dcl_modules, gs_modules, gs_heaps, cs) = 
		create_class_dictionaries 0 dcl_modules gs_modules gs_heaps cs
//		create_class_dictionaries1 main_dcl_module_n dcl_modules gs_modules gs_heaps cs
			//---> "*** create class dictionaries"	

	# {cs_symbol_table, cs_predef_symbols, cs_error} = cs
	# hash_table = { hash_table & hte_symbol_heap = cs_symbol_table }	
	
	#! index_range = {ir_from = gs.gs_first_fun, ir_to = gs.gs_last_fun}
		 			
	= (	gs_groups, gs_modules, gs_fun_defs, index_range, gs_td_infos, gs_heaps, hash_table, 
		cs_predef_symbols, dcl_modules, cs_error)
where
	return {gs_modules, gs_groups, gs_fun_defs, gs_td_infos, gs_gtd_infos, gs_heaps, gs_main_dcl_module_n, gs_error} predefs hash_table dcl_modules  
		= (	gs_groups, gs_modules, gs_fun_defs, {ir_from=0,ir_to=0}, 
			gs_td_infos, gs_heaps, hash_table, predefs, dcl_modules, gs_error)

	create_class_dictionaries module_index dcl_modules  modules heaps cs 
		#! size_of_modules = size modules
		| module_index == size_of_modules
			= (dcl_modules, modules, heaps, cs)
			#! (dcl_modules, modules, heaps, cs) = 
				create_class_dictionaries1 module_index dcl_modules  modules heaps cs
			= create_class_dictionaries (inc module_index) dcl_modules modules heaps cs		

	create_class_dictionaries1
			module_index dcl_modules modules 
			heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}, hp_var_heap}
			cs 
		#! (common_defs, modules) = modules![module_index]
		#! class_defs = { x \\ x <-: common_defs.com_class_defs } // make unique copy		
		#! (class_defs, dcl_modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, hp_var_heap, cs) =
				createClassDictionaries 
					module_index 
					class_defs 
					dcl_modules 
					(size common_defs.com_type_defs) 
					(size common_defs.com_selector_defs) 
					(size common_defs.com_cons_defs) 
					th_vars hp_var_heap cs

		#! common_defs = { common_defs & 
			com_class_defs = class_defs, 
			com_type_defs = arrayPlusList common_defs.com_type_defs new_type_defs,
			com_selector_defs = arrayPlusList common_defs.com_selector_defs new_selector_defs,
			com_cons_defs = arrayPlusList common_defs.com_cons_defs new_cons_defs}

		#! heaps = {heaps & hp_var_heap = hp_var_heap, hp_type_heaps = {hp_type_heaps & th_vars = th_vars}} 
		#! modules = { modules & [module_index] = common_defs } 		
		= (dcl_modules, modules, heaps, cs)		
	
convertInstances :: !*GenericState	
	-> (![Global Index], !*GenericState)
convertInstances gs
	= convert_modules 0 gs 
where

	convert_modules module_index gs=:{gs_modules}
		#! num_modules = size gs_modules
		| module_index == num_modules
			= ([], gs)	
		#! (common_defs, gs_modules) = gs_modules ! [module_index] 
		#! instance_defs = {i \\ i <-: common_defs.com_instance_defs} // make unique copy		

		#! (new_types, instance_defs, gs) =
			convert_instances module_index 0 instance_defs {gs & gs_modules = gs_modules}
		#! (types, gs) = convert_modules (inc module_index) gs
		
		#! {gs_modules} = gs
		#! (common_defs, gs_modules) = gs_modules ! [module_index]
		#! gs_modules = { gs_modules & [module_index] = {common_defs & com_instance_defs = instance_defs}} 
		= (new_types ++ types, {gs & gs_modules = gs_modules})

	convert_instances module_index instance_index instance_defs gs
		#! num_instance_defs = size instance_defs
		| instance_index == num_instance_defs
			= ([], instance_defs, gs)													
		#! (new_types, instance_defs, gs) = convert_instance module_index instance_index instance_defs gs 			
		#! (types, instance_defs, gs) = convert_instances module_index (inc instance_index) instance_defs gs		
		= (new_types ++ types, instance_defs, gs)	
		
	convert_instance :: !Index !Index !*{#ClassInstance} !*GenericState
		-> (![Global Index], !*{#ClassInstance}, !*GenericState)	
	convert_instance 
			module_index instance_index instance_defs 
			gs=:{gs_td_infos, gs_modules, gs_error, gs_fun_defs, gs_predefs, gs_heaps}
		#! (instance_def=:{ins_class,ins_ident,ins_pos}, instance_defs) = instance_defs ! [instance_index]
		| not instance_def.ins_is_generic
			# gs = { gs 
				& 	gs_td_infos = gs_td_infos
				, 	gs_modules = gs_modules
				,	gs_fun_defs = gs_fun_defs
				, 	gs_heaps = gs_heaps
				, 	gs_error = gs_error }	
			= ([], instance_defs, gs)
		
		// determine the kind of the instance type
		#! it_type = hd instance_def.ins_type.it_types
		#! (kind, gs_td_infos) = kindOfType it_type gs_td_infos

		#! (generic_def, gs_modules) = getGenericDef ins_class.glob_module ins_class.glob_object.ds_index gs_modules
		#! (ok, class_ds) = getGenericClassForKind generic_def kind
		| not ok
			= abort ("no class " +++ ins_ident.id_name +++ "for kind" +++ toString kind) 

		// bind the instance to the class
		#! instance_def = 
			{ 	instance_def 
			& 	ins_class = {glob_module=ins_class.glob_module, glob_object=class_ds} 
			,	ins_ident = makeIdent (ins_ident.id_name +++ ":" +++ (toString kind))
			}
		#! (is_partial, gs_fun_defs) = check_if_partial instance_def gs_predefs gs_fun_defs
		 	
		#! (ok, gs_modules, gs_error) = check_instance_args instance_def gs_modules gs_error
		| not ok
			#! instance_defs = { instance_defs & [instance_index] = instance_def}
			#! gs = { gs 
				& 	gs_td_infos = gs_td_infos
				, 	gs_modules = gs_modules
				,	gs_fun_defs = gs_fun_defs
				, 	gs_heaps = gs_heaps
				, 	gs_error = gs_error }	
			= ([], instance_defs, gs)

		#! gs_heaps = check_cons_instance generic_def instance_def it_type gs_predefs gs_heaps 
	
		#! (maybe_td_index, instance_def, gs_modules, gs_error) = 
			determine_type_def_index it_type instance_def is_partial gs_modules gs_error
		#! gs = { gs 
			& 	gs_td_infos = gs_td_infos
			, 	gs_modules = gs_modules
			,	gs_fun_defs = gs_fun_defs
			, 	gs_heaps = gs_heaps
			, 	gs_error = gs_error }	
		#! instance_defs = { instance_defs & [instance_index] = instance_def}
		= (maybe_td_index, instance_defs, gs)
	
	determine_type_def_index 
			(TA {type_index, type_name} _) 
			instance_def=:{ins_generate, ins_ident, ins_pos}
			is_partial 
			gs_modules gs_error
		#! ({td_rhs, td_index}, gs_modules) = getTypeDef type_index.glob_module type_index.glob_object gs_modules
		= determine_td_index td_rhs gs_modules gs_error
	where
		determine_td_index (AlgType _) gs_modules gs_error
			| ins_generate 
				= ([type_index], instance_def, gs_modules, gs_error)
			| supportPartialInstances && is_partial
				= ([type_index], {instance_def & ins_partial = True}, gs_modules, gs_error)
					//---> ("collected partial instance type", type_name, type_index)			
			| otherwise
				= ([], instance_def, gs_modules, gs_error)
		determine_td_index (RecordType _) gs_modules gs_error
			| ins_generate 
				= ([type_index], instance_def, gs_modules, gs_error)
			| supportPartialInstances && is_partial
				= ([type_index], {instance_def & ins_partial = True}, gs_modules, gs_error)			
					//---> ("collected partial instance type", type_name, type_index)			
			| otherwise
				= ([], instance_def, gs_modules, gs_error)
		determine_td_index (SynType _) gs_modules gs_error
			# gs_error = checkErrorWithIdentPos 
				(newPosition ins_ident ins_pos) 
				"generic instance type cannot be a sysnonym type" 
				gs_error 				 
			= ([], instance_def, gs_modules, gs_error)			
		determine_td_index (AbstractType _) gs_modules gs_error
			| ins_generate
				# gs_error = checkErrorWithIdentPos 
					(newPosition ins_ident ins_pos) 
					"cannot generate an instance for an abstract data type" 
					gs_error 				 
				= ([], instance_def, gs_modules, gs_error)									
				= ([], instance_def, gs_modules, gs_error)
	determine_type_def_index (TB _) instance_def _ gs_modules gs_error
		= ([], instance_def, gs_modules, gs_error)			
	determine_type_def_index _ instance_def=:{ins_ident,ins_pos} _ gs_modules gs_error
		#! gs_error = checkErrorWithIdentPos 
			(newPosition ins_ident ins_pos) 
			"generic instance type must be a type constructor or a primitive type" 
			gs_error 				 
		= ([], instance_def, gs_modules, gs_error)
	
	check_if_partial :: !ClassInstance !PredefinedSymbols !*{#FunDef} -> (!Bool, !*{#FunDef})
	check_if_partial instance_def=:{ins_members, ins_ident, ins_type, ins_generate} gs_predefs gs_fun_defs		
		= 	case supportPartialInstances of
			True
				| ins_generate
					-> (False, gs_fun_defs)
				| check_if_predef (hd ins_type.it_types) gs_predefs
					-> (False, gs_fun_defs) // PAIR, EITHER, CONS, UNIT
				#! ins_fun_ds = ins_members.[0]
				| ins_fun_ds.ds_index == NoIndex // can this happen?
					-> (False, gs_fun_defs)
				| otherwise					
					#! (fun_def, gs_fun_defs) = gs_fun_defs ! [ins_fun_ds.ds_index]
					#  (TransformedBody {tb_rhs}) = fun_def.fun_body  
					-> case tb_rhs of
						Case {case_default=No} 	-> (True, gs_fun_defs)
						_ 						-> (False, gs_fun_defs)
			False -> (False, gs_fun_defs)
		where
			check_if_predef (TA {type_index={glob_module, glob_object}} _) gs_predefs
			 	# {pds_module, pds_def} = gs_predefs.[PD_TypeUNIT]
			 	| glob_module == pds_module && glob_object == pds_def
			 		= True
			 	# {pds_module, pds_def} = gs_predefs.[PD_TypePAIR]
			 	| glob_module == pds_module && glob_object == pds_def
			 		= True
			 	# {pds_module, pds_def} = gs_predefs.[PD_TypeEITHER]
			 	| glob_module == pds_module && glob_object == pds_def
			 		= True
			 	# {pds_module, pds_def} = gs_predefs.[PD_TypeCONS]
			 	| glob_module == pds_module && glob_object == pds_def
			 		= True
				| otherwise
					= False				
			check_if_predef _ gs_predefs 
				= False						
								
	check_cons_instance 
			{gen_cons_ptr} {ins_members}
			(TA {type_index={glob_module, glob_object}} _) 
			predefs heaps
		| not supportConsInfo 
			= heaps	
		# {pds_module, pds_def} = predefs.[PD_TypeCONS]
		| glob_module <> pds_module || glob_object <> pds_def
			= heaps
		# {hp_type_heaps=hp_type_heaps=:{th_vars}}=heaps				
		# th_vars = writePtr gen_cons_ptr (TVI_ConsInstance ins_members.[0]) th_vars		
		= {heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}	
	check_cons_instance _ _ _ _ heaps 
		= heaps	
				
	check_instance_args 
			instance_def=:{ins_class={glob_module,glob_object}, ins_ident, ins_pos, ins_type, ins_generate} 
			gs_modules gs_error
		| ins_generate 
			= (True, gs_modules, gs_error)
	
		# (class_def=:{class_members}, gs_modules) =  
			getClassDef glob_module glob_object.ds_index gs_modules 
		# (member_def, gs_modules) = 
			getMemberDef glob_module class_def.class_members.[0].ds_index gs_modules
		| member_def.me_type.st_arity <> instance_def.ins_members.[0].ds_arity
			# gs_error = checkErrorWithIdentPos (newPosition ins_ident ins_pos) "generic instance function has incorrect arity" gs_error
			= (False, gs_modules, gs_error)	
			= (True, gs_modules, gs_error)	

collectGenericTypes :: !*GenericState -> (![Type], !*GenericState)
collectGenericTypes gs=:{gs_modules} 
	# (types, gs_modules) = collect_in_modules 0 0 gs_modules
	= (types, {gs & gs_modules = gs_modules})
where
	collect_in_modules module_index generic_index gs_modules
		#! size_gs_modules = size gs_modules 
		| module_index == size_gs_modules
			= ([], gs_modules) 
		# (generic_defs, gs_modules) = gs_modules ! [module_index].com_generic_defs 
		#! size_generic_defs = size generic_defs
		| generic_index == size_generic_defs
			= collect_in_modules (inc module_index) 0 gs_modules
		# {gen_type={gt_type={st_args, st_result}}} = generic_defs . [generic_index]
		# (types, gs_modules) = collect_in_modules module_index (inc generic_index) gs_modules
		= ([at_type \\ {at_type} <- [st_result:st_args]] ++ types, gs_modules)	


buildConsInstances :: !*GenericState -> (![FunDef], ![Group], !*GenericState)
buildConsInstances gs 
	| supportConsInfo
		= build_cons_instances 0 0 gs
		= ([], [], gs)
where
	build_cons_instances module_index generic_index gs=:{gs_modules}
		#! size_gs_modules = size gs_modules 
		| module_index == size_gs_modules
			= ([], [], {gs & gs_modules = gs_modules}) 
		# (generic_defs, gs_modules) = gs_modules ! [module_index].com_generic_defs
		# gs = {gs & gs_modules = gs_modules} 
		#! size_generic_defs = size generic_defs
		| generic_index == size_generic_defs
			= build_cons_instances (inc module_index) 0 gs
		# (fun, group, gs) = build_cons_instance generic_defs.[generic_index] gs				
		# (funs, groups, gs) = build_cons_instances module_index (inc generic_index) gs
		= ([fun:funs], [group:groups], gs)	

	build_cons_instance generic_def gs
		#! (fun_index, group_index, gs) 	= newFunAndGroupIndex gs		
		#! (ins_fun_def_sym, gs) = get_cons_fun generic_def gs		
		#! {gs_fun_defs, gs_predefs, gs_heaps} = gs
		#! fun_def_sym = 
			{	ds_ident = makeIdent (ins_fun_def_sym.ds_ident.id_name +++ ":cons_info")
			,	ds_arity = ins_fun_def_sym.ds_arity + 1
			,	ds_index = fun_index
			}		
		#! gs_heaps = set_cons_fun generic_def fun_def_sym gs_heaps	

		#! (ins_fun_def, gs_fun_defs) = gs_fun_defs ! [ins_fun_def_sym.ds_index]		

		#! (fun_def, gs_heaps) = copyFunDef ins_fun_def fun_index group_index gs_heaps

		#! (fun_def, gs_heaps) = parametrize_with_cons_info fun_def gs_predefs gs_heaps
		
		#! group = {group_members = [fun_index]}
			
		= (fun_def, group, {gs & gs_fun_defs = gs_fun_defs, gs_heaps = gs_heaps})
			//---> ("build_cons_instance", ins_fun_def, fun_def)
	where 
		parametrize_with_cons_info fun_def=:{fun_arity, fun_body} predefs heaps		
			# (var_expr, var, heaps) = buildVarExpr "cons_info" heaps
			# (TransformedBody tb=:{tb_args, tb_rhs}) = fun_body
			# (tb_rhs, heaps) = mapExprSt (replace_cons_info var_expr) tb_rhs  heaps 	
			# fun_def = 
				{ fun_def 
				& fun_arity = fun_arity + 1
				, fun_body = TransformedBody {tb & tb_args = [var:tb_args], tb_rhs = tb_rhs}
				}				
			= (fun_def, heaps) 
		where
			{pds_module,pds_def} = predefs.[PD_cons_info]	
			replace_cons_info 
					var_expr 
					expr=:(App {app_symb={symb_kind=SK_Function {glob_object, glob_module}}}) 
					heaps
				| pds_module == glob_module && pds_def == glob_object			
					= (var_expr, heaps)
						//---> ("replace_cons_info", expr, var_expr)
					= (expr, heaps)
						//---> ("replace_cons_info: App expr1", expr)
							
			replace_cons_info var_expr expr=:(App app) heaps
				= (expr, heaps)
					//--->  ("replace_cons_info: App expr2", expr) 
						 
			replace_cons_info var_expr expr heaps
				= (expr, heaps)
	
	get_cons_fun 
			{gen_cons_ptr, gen_pos, gen_name} 
			gs=:{gs_heaps=gs_heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}, gs_error}
		# (info, th_vars) = readPtr gen_cons_ptr th_vars
		# gs_heaps = { gs_heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars }}	
		# (fun_def_sym, gs_error) = case info of		
			TVI_ConsInstance fun_def_sym
				-> (fun_def_sym, gs_error)				
			TVI_Empty
				-> (EmptyDefinedSymbol, reportError gen_name gen_pos "no CONS instance provided" gs_error)
		= (fun_def_sym, {gs & gs_heaps = gs_heaps, gs_error = gs_error})						

	set_cons_fun 
			{gen_cons_ptr} fun_def_sym
			gs_heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}
		# th_vars = writePtr gen_cons_ptr (TVI_ConsInstance fun_def_sym) th_vars
		= { gs_heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars }}	
							
collectInstanceKinds :: !*GenericState -> !*GenericState
collectInstanceKinds gs
	= collect_instance_kinds 0 0 gs
where
	collect_instance_kinds module_index instance_index gs=:{gs_modules}
		#! size_modules = size gs_modules
		| module_index == size_modules
			= gs
		#! (common_defs, gs_modules) = gs_modules ! [module_index]
		#! size_instance_defs = size common_defs.com_instance_defs
		| instance_index == size_instance_defs
			= collect_instance_kinds (inc module_index) 0 {gs & gs_modules = gs_modules} 
				
		#! gs = collect_instance module_index instance_index {gs & gs_modules = gs_modules}
		
		= collect_instance_kinds module_index (inc instance_index) gs

	collect_instance module_index instance_index gs=:{gs_heaps, gs_modules, gs_td_infos}
		
		#! (instance_def=:{ins_class, ins_is_generic, ins_type}, gs_modules) = 
			getInstanceDef module_index instance_index gs_modules
		| not instance_def.ins_is_generic 
			= {gs & gs_modules = gs_modules, gs_heaps = gs_heaps }

		#! (generic_def, gs_modules) = getGenericDef ins_class.glob_module ins_class.glob_object.ds_index gs_modules		
		#! (kind, gs_td_infos) = kindOfType (hd ins_type.it_types) gs_td_infos		
		#! gs_heaps = update_kind generic_def kind gs_heaps		
		= {gs & gs_modules = gs_modules, gs_heaps = gs_heaps, gs_td_infos = gs_td_infos}
		
	update_kind {gen_kinds_ptr} kind gs_heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}
		#! (TVI_Kinds kinds, th_vars) = readPtr gen_kinds_ptr th_vars
		#! kinds = eqMerge [kind] kinds
		#! th_vars = writePtr gen_kinds_ptr (TVI_Kinds kinds) th_vars
		= {gs_heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}

buildClasses :: !*GenericState -> !*GenericState
buildClasses gs 
	= build_modules 0 gs
where
	build_modules module_index gs=:{gs_modules}
		#! size_gs_modules = size gs_modules 
		| module_index == size_gs_modules
			= { gs & gs_modules = gs_modules }	 		

		#! common_defs = gs_modules . [module_index]
		#! (common_defs, gs=:{gs_modules}) = build_module module_index common_defs gs	
		#! gs = {gs & gs_modules = {gs_modules & [module_index] = common_defs}}					

		= build_modules (inc module_index) gs	
			
	build_module module_index common_defs gs		 

		#! {com_generic_defs,com_class_defs, com_member_defs} = common_defs 
		
		#! class_index = size com_class_defs
		#! member_index = size com_member_defs
		#! com_generic_defs = {x \\ x <-: com_generic_defs} // make unique copy
			
		# (new_class_defs, new_member_defs, com_generic_defs, _, _, gs) = 
			build_generics module_index 0 class_index member_index com_generic_defs gs	

		# common_defs = 
			{	common_defs 
			&	com_class_defs = arrayPlusRevList com_class_defs new_class_defs
			,	com_member_defs = arrayPlusRevList com_member_defs new_member_defs
			, 	com_generic_defs = com_generic_defs
			}
		= (common_defs, gs)
		
	build_generics module_index generic_index class_index member_index generic_defs gs
		#! size_generic_defs = size generic_defs
		| generic_index == size_generic_defs
			= ([], [], generic_defs, class_index, member_index, gs)
		#! (generic_def, generic_defs) = generic_defs ! [generic_index]	
		#! (new_class_defs, new_member_defs, generic_def, class_index, member_index, gs) = 
			build_generic module_index class_index member_index generic_def gs
		#! generic_defs = {generic_defs & [generic_index] = generic_def}
		#! (new_class_defs1, new_member_defs1, generic_defs, class_index, member_index, gs) = 
			build_generics module_index (inc generic_index) class_index member_index generic_defs gs
		= (new_class_defs ++ new_class_defs1, new_member_defs ++ new_member_defs1,
			generic_defs, class_index, member_index, gs)
		
	build_generic module_index class_index member_index generic_def gs		
		# (kinds, gs) = get_kinds generic_def gs
		= build_classes kinds generic_def module_index class_index member_index gs
	
	build_classes :: ![TypeKind] !GenericDef !Index !Index !Index !*GenericState
		-> (![ClassDef], ![MemberDef], !GenericDef, !Index, !Index, !*GenericState)
	build_classes [] generic_def module_index class_index member_index gs 
		= ([], [], generic_def, class_index, member_index, gs)
	build_classes [kind:kinds] generic_def module_index class_index member_index gs 	
		#! (class_def, member_def, generic_def, gs) = 
			buildClassDef1 module_index class_index member_index generic_def kind gs
		#! (class_defs, member_defs, generic_def, class_index, member_index, gs) = 
			build_classes kinds generic_def module_index (inc class_index) (inc member_index) gs
		= ([class_def:class_defs], [member_def:member_defs], generic_def, class_index, member_index, gs) 			 

	get_kinds {gen_kinds_ptr} gs=:{gs_heaps=gs_heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}}
		#! (TVI_Kinds kinds, th_vars) = readPtr gen_kinds_ptr th_vars
		#! th_vars = writePtr gen_kinds_ptr TVI_Empty th_vars
		= (kinds, {gs & gs_heaps = {gs_heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}})
		 				
// find all types whose generic representation is needed
collectGenericTypeDefs :: ![Type] [Global Index] !*GenericState
	-> (![Global Index], !*GenericState)
collectGenericTypeDefs generic_types instance_td_indexes gs
	# (td_indexes, gs) = collect_in_types generic_types gs
	# (td_indexes, gs) = add_instance_indexes td_indexes instance_td_indexes gs
	= (map fst td_indexes, gs)
where
	add_instance_indexes td_indexes [] gs 
		= (td_indexes, gs)
	add_instance_indexes 
			td_indexes 
			[type_index=:{glob_module, glob_object} : itdis] 
			gs=:{gs_gtd_infos, gs_td_infos}
		# (gtd_info, gs_gtd_infos) = gs_gtd_infos ! [glob_module, glob_object]
		# gs_gtd_infos = {gs_gtd_infos & [glob_module, glob_object] = GTDI_Generic EmptyGenericType}
		# (td_info, gs_td_infos) = gs_td_infos ! [glob_module, glob_object]
		# gs = {gs & gs_td_infos = gs_td_infos, gs_gtd_infos = gs_gtd_infos}
		| toBool gtd_info // already marked
			= add_instance_indexes td_indexes itdis gs
				//---> ("instance type already added", type_index)
			# gs_gtd_infos = {gs_gtd_infos & [glob_module, glob_object] = GTDI_Generic EmptyGenericType}
			= add_instance_indexes (merge_td_indexes [(type_index, td_info.tdi_group_nr)] td_indexes) itdis gs
				//---> ("add instance type index", type_index)

	collect_in_types :: ![Type] !*GenericState  
		-> (![(Global Index, Int)], !*GenericState)
	collect_in_types [] gs = ([], gs)
	collect_in_types [type:types] gs
		# (td_indexes1, gs) = collect_in_type type gs
		# (td_indexes2, gs) = collect_in_types types gs
		= (merge_td_indexes td_indexes1 td_indexes2, gs)
		
	collect_in_type :: !Type !*GenericState 
		-> (![(Global Index, Int)], !*GenericState)		
	collect_in_type (TA {type_arity=0, type_name} _) gs=:{gs_gtd_infos, gs_td_infos, gs_modules}
		// types with no arguments do not need mapping to be built:
		// their mapping is identity
		= ([], gs)
			//---> ("ignore type", type_name)  
	collect_in_type (TA {type_index, type_name} args) gs=:{gs_gtd_infos, gs_td_infos, gs_modules}
		# {glob_module, glob_object} = type_index	
		#! (gtd_info, gs_gtd_infos) = gs_gtd_infos ! [glob_module, glob_object]
		| toBool gtd_info // already marked
			= ([], {gs & gs_gtd_infos = gs_gtd_infos})
				//---> ("already marked type", type_name, type_index)
		#! gs_gtd_infos = {gs_gtd_infos & [glob_module, glob_object] = GTDI_Generic EmptyGenericType}
			//---> ("collect in type", type_name.id_name, type_index)						
		#! (type_def, gs_modules) = getTypeDef glob_module glob_object gs_modules
		#! (td_info, gs_td_infos) = gs_td_infos ! [glob_module, glob_object]
		# gs = {gs & gs_td_infos = gs_td_infos, gs_gtd_infos = gs_gtd_infos, gs_modules = gs_modules}
		# (td_indexes, gs) = collect_in_type_def_rhs glob_module type_def gs
		= (merge_td_indexes [(type_index, td_info.tdi_group_nr)] td_indexes, gs)				
	collect_in_type (arg --> res) gs
		#! (td_indexes1, gs) = collect_in_type arg.at_type gs
		#! (td_indexes2, gs) = collect_in_type res.at_type gs
		= (td_indexes1 ++ td_indexes2, gs)
	collect_in_type (cons_var :@: args) gs
		# types = [ at_type \\ {at_type} <- args] 
		= collect_in_types types gs				
	collect_in_type _ gs
		= ([], gs)
	
	collect_in_type_def_rhs :: !Index !CheckedTypeDef !*GenericState 
		-> (![(Global Index, Int)], !*GenericState)		 
	collect_in_type_def_rhs mod {td_rhs=(AlgType cons_def_symbols)} gs
		= collect_in_conses mod cons_def_symbols gs
	collect_in_type_def_rhs mod {td_rhs=(RecordType {rt_constructor})}	gs
		= collect_in_conses mod [rt_constructor] gs				
	collect_in_type_def_rhs mod {td_rhs=(SynType {at_type})}	gs			
		= collect_in_type at_type gs 
	collect_in_type_def_rhs mod {td_rhs=(AbstractType _), td_name, td_pos} gs=:{gs_error}				
		# gs_error = checkErrorWithIdentPos
				(newPosition td_name td_pos) 
				"cannot build generic type representation for an abstract type" 
				gs_error
		= ([], {gs & gs_error = gs_error})
		//= ([], {gs & gs_error = checkWarning td_name "abstract data type" gs_error})
	
	collect_in_conses :: !Index ![DefinedSymbol] !*GenericState 
		-> (![(Global Index, Int)], !*GenericState)
	collect_in_conses mod [] gs 
		= ([], gs)
	collect_in_conses mod [{ds_index, ds_ident} : cons_def_symbols] gs=:{gs_modules}
		#! ({cons_type={st_args}}, gs_modules) = getConsDef mod ds_index gs_modules
			//---> ("mark cons " +++ ds_ident.id_name)
		#! types = [ at_type \\ {at_type} <- st_args] 
		#! (td_indexes1, gs) = collect_in_types types {gs & gs_modules=gs_modules}
		#! (td_indexes2, gs) = collect_in_conses mod cons_def_symbols gs
		= (merge_td_indexes td_indexes1 td_indexes2, gs)

	collect_in_symbol_type {st_args, st_result} gs
		# (td_indexes1, gs) = collect_in_types (map (\x->x.at_type) st_args)  gs
		# (td_indexes2, gs) = collect_in_type st_result.at_type gs
		= (merge_td_indexes td_indexes1 td_indexes2, gs)
		 
	merge_td_indexes x y 
		= mergeBy (\(_,l) (_,r) ->l < r) x y 


buildIsoFunctions :: ![Global Index] !*GenericState
	-> (![FunDef], ![Group], !*GenericState)
buildIsoFunctions [] gs = ([], [], gs)
buildIsoFunctions [type_index:type_indexes] gs
	# (iso_funs1, iso_groups1, gs) = build_function type_index gs
	# (iso_funs2, iso_groups2, gs) = buildIsoFunctions type_indexes gs	 
	= (iso_funs1 ++ iso_funs2, iso_groups1 ++ iso_groups2, gs) 
where
	build_function {glob_module, glob_object} gs
	
		# (generic_rep_type, gs) = buildGenericRepType glob_module glob_object gs
	
		# (type_info_def_sym, cons_info_def_syms, info_fun_defs, info_groups, gs) = 
			build_cons_infos glob_module glob_object gs

		# (iso_def_sym, iso_fun_defs, iso_groups, gs) =
			build_isos glob_module glob_object cons_info_def_syms gs  

		# gs = fill_generic_type_info
			glob_module glob_object 
			generic_rep_type
			iso_def_sym
			type_info_def_sym cons_info_def_syms
			gs	
		
		= (info_fun_defs ++ iso_fun_defs, info_groups ++ iso_groups, gs)	

	fill_generic_type_info 
			module_index type_def_index
			generic_rep_type 
			iso_def_sym 
			type_info_def_sym
			cons_info_def_syms
			gs=:{gs_gtd_infos, gs_modules}

		# (type_def=:{td_args}, gs_modules) = getTypeDef module_index type_def_index gs_modules 
		# gtd_info = GTDI_Generic 
			{ 	gtr_type 		= generic_rep_type
			,	gtr_type_args	= [atv_variable \\ {atv_variable} <- td_args] 
			,	gtr_iso 		= iso_def_sym
			,	gtr_isomap_group= NoIndex
			,	gtr_isomap		= EmptyDefinedSymbol		
			,	gtr_isomap_from	= EmptyDefinedSymbol		
			,	gtr_isomap_to	= EmptyDefinedSymbol
			,	gtr_type_info	= type_info_def_sym		
			,	gtr_cons_infos 	= cons_info_def_syms
			}	
		# gs_gtd_infos = {gs_gtd_infos & [module_index, type_def_index] = gtd_info} 
		= {gs & gs_modules = gs_modules, gs_gtd_infos = gs_gtd_infos}	 	

	build_isos module_index type_def_index cons_infos gs

		# (from_fun_index, 	from_group_index, gs) 	= newFunAndGroupIndex gs
		# (to_fun_index, 	to_group_index, gs) 	= newFunAndGroupIndex gs
		# (iso_fun_index, 	iso_group_index, gs) 	= newFunAndGroupIndex gs		

		# {gs_modules} = gs
		# (type_def=:{td_name}, gs_modules) = getTypeDef module_index type_def_index gs_modules 
		# gs = {gs & gs_modules = gs_modules}

		# iso_def_sym = {
			ds_ident  = {id_name="iso:"+++type_def.td_name.id_name, id_info = nilPtr },
			ds_index  = iso_fun_index,
			ds_arity  = 0	
			}
	
		# from_def_sym = {
			ds_ident  = {id_name="iso_from:"+++type_def.td_name.id_name, id_info = nilPtr },
			ds_index  = from_fun_index,
			ds_arity  = 1	
			}
	
		# to_def_sym = {
			ds_ident  = {id_name="iso_to:"+++type_def.td_name.id_name, id_info = nilPtr },
			ds_index  = to_fun_index,
			ds_arity  = 1	
			}

		# (from_fun_def, gs) = buildIsoFrom from_def_sym from_group_index module_index type_def gs	
		# (to_fun_def, gs) = buildIsoTo to_def_sym to_group_index module_index type_def cons_infos gs	
		# (iso_fun_def, gs) = 
			//buildUndefFunction iso_fun_index iso_group_index iso_name 1 gs_predefs gs_heaps	
			buildIsoRecord iso_def_sym iso_group_index from_def_sym to_def_sym gs	
		
		# fun_defs = [from_fun_def, to_fun_def, iso_fun_def]
		# groups = 
			[	{group_members=[from_fun_index]}
			, 	{group_members=[to_fun_index]}
			,	{group_members=[iso_fun_index]}
			] 
		= (iso_def_sym, fun_defs, groups, gs)
		
	build_cons_infos module_index type_def_index gs
		= 	case supportCons of
			False -> (EmptyDefinedSymbol, [], [], [], gs)
			True  -> build_cons_infos1 module_index type_def_index gs		

	build_cons_infos1 module_index type_def_index gs=:{gs_modules}
		# (type_def=:{td_rhs}, gs_modules) = getTypeDef module_index type_def_index gs_modules				 
		# (common_defs, gs_modules) = gs_modules ! [module_index]				
		# gs = {gs & gs_modules = gs_modules}
		
		# (type_fun_index, group_index, gs) = newFunAndGroupIndex gs				
		# type_fun_sym = 
			{	ds_ident = makeIdent ("type_info_" +++ type_def.td_name.id_name)
			, 	ds_index = type_fun_index
			,	ds_arity = 0
			}
				
		# (cons_fun_syms, cons_fun_defs, gs) = case td_rhs of
			(AlgType alts) 
				-> build_alg_cons_infos alts 0 type_fun_sym group_index common_defs gs
			(RecordType {rt_constructor}) 
				-> build_alg_cons_infos [rt_constructor] 0 type_fun_sym group_index common_defs gs
			_ -> ([], [], gs)
			
		# (type_fun_def, gs) = 
			build_type_info type_def type_fun_sym group_index cons_fun_syms gs

		# group = 
			{	group_members = [type_fun_index : [ds_index \\ {ds_index} <- cons_fun_syms]]
			}
		= (type_fun_sym, cons_fun_syms, [type_fun_def:cons_fun_defs], [group], gs)
		
	build_alg_cons_infos [] cons_num type_info_def_sym group_index common_defs gs
		= ([], [], gs)  	
	build_alg_cons_infos [cons_def_sym:cons_def_syms] cons_num type_info_def_sym group_index common_defs	gs
		# (fi, fd, gs) = build_cons_info cons_def_sym cons_num type_info_def_sym group_index common_defs gs
		# (fis, fds, gs) = build_alg_cons_infos cons_def_syms (inc cons_num) type_info_def_sym group_index common_defs	gs
		= ([fi:fis], [fd:fds], gs) 

	build_cons_info {ds_index,ds_arity} cons_num type_info_def_sym group_index common_defs gs
		# {cons_symb, cons_arity, cons_pos} = common_defs.com_cons_defs.[ds_index]		
		# (fun_index, gs) = newFunIndex gs		
		# def_sym = 
			{	ds_ident = makeIdent ("cons_info_" +++ cons_symb.id_name)
			, 	ds_index = fun_index
			,	ds_arity = 0
			}
		# {gs_modules,gs_heaps, gs_predefs, gs_main_dcl_module_n}	= gs
		# cons_name_expr = makeStringExpr ("\""+++cons_symb.id_name+++"\"") gs_predefs
		# cons_arity_expr = makeIntExpr ds_arity
		# cons_num_expr = makeIntExpr cons_num
		# (cons_type_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n type_info_def_sym [] gs_heaps 
		
		# (cons_info_expr, gs_heaps) = buildPredefConsApp 
				PD_ConsConsDefInfo 
				[	cons_name_expr
				, 	cons_arity_expr
				, 	cons_num_expr
				, 	cons_type_expr
				] 
				gs_predefs gs_heaps
		# fun_def = makeFunction def_sym group_index [] cons_info_expr No [] [] cons_pos				
			
		//# (fun_def, gs_heaps) = buildUndefFunction def_sym group_index gs_predefs gs_heaps
		= (def_sym, fun_def, {gs & gs_modules=gs_modules, gs_heaps=gs_heaps})
	
	build_type_info 
			{td_pos,td_name} 
			type_info_def_sym 
			group_index 
			cons_info_def_syms 
			gs=:{gs_predefs, gs_heaps, gs_main_dcl_module_n}
		# name_expr = makeStringExpr ("\""+++td_name.id_name+++"\"") gs_predefs
		# kind_expr = makeIntExpr type_info_def_sym.ds_arity
		# (cons_info_exprs, gs_heaps) = mapSt build_app cons_info_def_syms gs_heaps  
			with 
				build_app cons_info_def_sym h 
					//= buildUndefFunApp [] gs_predefs h
					= buildFunApp gs_main_dcl_module_n cons_info_def_sym [] h
				
		# (cons_info_list_expr, gs_heaps) = makeListExpr cons_info_exprs gs_predefs	gs_heaps	
		# (body_expr, gs_heaps) = buildPredefConsApp 
			PD_ConsTypeDefInfo 
			[	name_expr
			, 	kind_expr
			,	cons_info_list_expr
			] 
			gs_predefs gs_heaps
		# fun_def = makeFunction type_info_def_sym group_index [] body_expr No [] [] td_pos				
		= (fun_def, {gs & gs_heaps=gs_heaps})
			
buildIsomapsForTypeDefs :: ![Global Index] !*GenericState
	-> (![FunDef], ![Group], !*GenericState)
buildIsomapsForTypeDefs td_indexes gs=:{gs_last_group}
	# gs = foldSt fill_function_indexes td_indexes gs
	# first_group = gs_last_group
	# (funs, gs) = build_isomap_functions td_indexes gs
	# (last_group, gs) = gs ! gs_last_group
	# groups = createArray (last_group - first_group) []
		//---> ("created " +++ toString (last_group - first_group) +++ " isomap groups")
	# groups = collect_groups first_group funs groups
	# groups = [ {group_members = fs} \\ fs <-: groups ] 
	= (funs, groups, gs)
where	

	fill_function_indexes :: !(Global Index) !*GenericState -> !*GenericState
	fill_function_indexes {glob_module, glob_object} gs

		# (kind, gs) = get_kind glob_module glob_object gs 
		| kind == KindConst
			// types of kind * do not need isomaps - they are identity
			= gs

		# (from_fun_index, gs) = newFunIndex gs
		# (to_fun_index, gs) = newFunIndex gs
		# (rec_fun_index, gs) = newFunIndex gs

		# (gs=:{gs_gtd_infos, gs_modules}) = gs
		# (type_def=:{td_name, td_arity}, gs_modules) = getTypeDef glob_module glob_object gs_modules
		# (GTDI_Generic gt, gs_gtd_infos) = gs_gtd_infos ! [glob_module, glob_object]

		# gtd_info = GTDI_Generic {gt & 
			gtr_isomap_from 	= { 
				ds_ident = {id_name="isomap_from:"+++td_name.id_name, id_info=nilPtr}, 
				ds_index = from_fun_index, 
				ds_arity = (td_arity + 1)
				},
			gtr_isomap_to 	= { 
				ds_ident = {id_name="isomap_to:"+++td_name.id_name, id_info=nilPtr}, 
				ds_index = to_fun_index, 
				ds_arity = (td_arity + 1)
				},
			gtr_isomap 		= { 
				ds_ident = {id_name="isomap:"+++td_name.id_name, id_info=nilPtr}, 
				ds_index = rec_fun_index, 
				ds_arity = td_arity
				}
			}		
		# gs_gtd_infos = {gs_gtd_infos & [glob_module, glob_object] = gtd_info}		
		= {gs & gs_gtd_infos = gs_gtd_infos, gs_modules = gs_modules}			

	get_kind module_index type_index gs=:{gs_td_infos}	
		# (kind, gs_td_infos) = kindOfTypeDef module_index type_index gs_td_infos 
		= (kind, {gs & gs_td_infos = gs_td_infos})

	build_isomap_functions :: ![Global Index] !*GenericState
		-> (![FunDef], !*GenericState)		
	build_isomap_functions [] gs = ([], gs)
	build_isomap_functions [{glob_module, glob_object}:td_indexes] gs
		# (funs1, gs) = build_isomap_function glob_module glob_object gs
		# (funs2, gs) = build_isomap_functions td_indexes gs
		= (funs1 ++ funs2, gs)
	
	build_isomap_function module_index type_def_index gs

		# (kind, gs) = get_kind module_index type_def_index gs
		| kind == KindConst
			// types of kind * do not need isomaps - they are identity
			= ([], gs)

		# (group_index, gs)  = get_group module_index type_def_index gs

		# {gs_modules, gs_gtd_infos} = gs
		# (type_def=:{td_name}, gs_modules) = getTypeDef module_index type_def_index gs_modules
		
		# (GTDI_Generic {gtr_isomap, gtr_isomap_to, gtr_isomap_from}, gs_gtd_infos) 
			= gs_gtd_infos![module_index, type_def_index]
		
		# gs = { gs & gs_gtd_infos = gs_gtd_infos, gs_modules = gs_modules } 

		# (from_fun_def, gs) = 
			buildIsomapFromTo IsoFrom gtr_isomap_from group_index module_index type_def_index gs
		# (to_fun_def, gs) = 
			buildIsomapFromTo IsoTo gtr_isomap_to group_index module_index type_def_index gs
		# (rec_fun_def, gs) = 
			buildIsomapForTypeDef gtr_isomap group_index module_index type_def gtr_isomap_from gtr_isomap_to gs
		
		# funs = [ from_fun_def, to_fun_def, rec_fun_def ]		
		= (funs, gs)
			//---> from_fun_def 
		
	collect_groups :: !Index ![FunDef] !*{[Index]} -> !*{[Index]} 
	collect_groups first_group_index [] groups = groups
	collect_groups first_group_index [fun=:{fun_symb, fun_index, fun_info={fi_group_index}}:funs] groups
		# (group, groups) = groups ! [fi_group_index - first_group_index]
		# groups = {groups & [fi_group_index - first_group_index] = [fun_index:group]}
			//---> ("add fun " +++ fun_symb.id_name +++ " "+++ toString fun_index +++ 
			//		" to group " +++ toString fi_group_index) 
		= collect_groups first_group_index funs groups 

	get_group :: !Index  !Index !*GenericState 
		-> (!Index, !*GenericState)
	get_group module_index type_def_index gs=:{gs_gtd_infos}
		#! gtd_info = gs_gtd_infos . [module_index, type_def_index]
		# (GTDI_Generic gt) = gtd_info
		| gt.gtr_isomap_group <> NoIndex // group index already allocated
			= (gt.gtr_isomap_group, gs)
					
		# (group_index, gs=:{gs_td_infos, gs_gtd_infos}) 
			= newGroupIndex {gs & gs_gtd_infos = gs_gtd_infos}
				
		# (type_def_info, gs_td_infos) = gs_td_infos ! [module_index, type_def_index]
		# gs_gtd_infos = update_group group_index type_def_info.tdi_group gs_gtd_infos				
		= (group_index, { gs & gs_gtd_infos = gs_gtd_infos, gs_td_infos = gs_td_infos})
			//---> ("type group number of type " +++ toString module_index +++ " " +++ 
			//		toString type_def_index +++ " is " +++ toString type_def_info.tdi_group_nr)

	update_group :: !Index ![Global Index] !*GenericTypeDefInfos -> !*GenericTypeDefInfos
	update_group group_index [] gtd_infos = gtd_infos	
	update_group group_index [{glob_module, glob_object}:type_def_global_indexes] gtd_infos
		# (gtd_info, gtd_infos) = gtd_infos ! [glob_module, glob_object]
		# (GTDI_Generic gt) = gtd_info
		| gt.gtr_isomap_group <> NoIndex 
			= abort "sanity check: updating already updated group\n"
		# gtd_info = GTDI_Generic {gt & gtr_isomap_group = group_index }
		# gtd_infos = {gtd_infos & [glob_module, glob_object] = gtd_info}
		= update_group group_index type_def_global_indexes gtd_infos


buildIsomapsForGenerics :: !*GenericState
	-> (![FunDef], ![Group], !*GenericState)
buildIsomapsForGenerics gs
	= build_modules 0 gs
where
	build_modules module_index gs=:{gs_modules}
		#! num_modules = size gs_modules
		| module_index == num_modules
			= ([], [], gs)					
		# (common_defs, gs_modules) = gs_modules ! [module_index]
		#  {com_generic_defs} = common_defs
		# com_generic_defs = {g \\ g <-: com_generic_defs} // make unique copy		
		# (new_funs, new_groups, com_generic_defs, gs) =
			build_isomaps module_index 0 com_generic_defs {gs & gs_modules = gs_modules}
		# (funs, groups, gs) = build_modules (inc module_index) gs
		# {gs_modules} = gs
		# gs_modules = { gs_modules & [module_index] = {common_defs & com_generic_defs = com_generic_defs}} 
		= (new_funs ++ funs, new_groups ++ groups, {gs & gs_modules = gs_modules})

	build_isomaps module_index generic_index generic_defs gs		
		#! num_generic_defs = size generic_defs
		| generic_index == num_generic_defs
			= ([], [], generic_defs, gs)													
		# (new_funs, new_groups, generic_defs, gs) = build_isomap module_index generic_index generic_defs gs 			
		# (funs, groups, generic_defs, gs) = build_isomaps module_index (inc generic_index) generic_defs gs		
		= (new_funs ++ funs, new_groups ++ groups, generic_defs, gs)	

	build_isomap module_index generic_index generic_defs gs				
		# (generic_def=:{gen_name, gen_type}, generic_defs) = generic_defs ! [generic_index] 		
		# (fun_index, group_index, gs) = newFunAndGroupIndex gs 		
		# def_sym = {
			ds_ident = {id_name="isomap:"+++gen_name.id_name, id_info = nilPtr}, 
			ds_index = fun_index, 
			ds_arity = gen_type.gt_arity
			}
		# generic_defs = {generic_defs & [generic_index] = {generic_def & gen_isomap = def_sym}}				
		# (fun_def, gs) = buildIsomapForGeneric def_sym group_index generic_def gs
		//# (fun_def, gs) = build_undef_fun def_sym group_index gs	
		# group = {group_members = [fun_index]}			
		= ([fun_def], [group], generic_defs, gs)
	where
		build_undef_fun def_sym group gs=:{gs_heaps, gs_predefs}
			# (fun_def, gs_heaps) = buildUndefFunction def_sym group gs_predefs gs_heaps
			= (fun_def, {gs & gs_heaps = gs_heaps})
						
// generate instances  
buildInstances :: !*GenericState	
	-> (![FunDef], ![Group], !*GenericState)
buildInstances gs
	= build_modules 0 gs
where
	build_modules :: !Index !*GenericState 
		-> (![FunDef], ![Group], !*GenericState)
	build_modules module_index gs=:{gs_modules}
		#! num_modules = size gs_modules
		| module_index == num_modules
			= ([], [], gs)					
		# (common_defs, gs_modules) = gs_modules ! [module_index]
		#  {com_instance_defs} = common_defs
		# com_instance_defs = {i \\ i <-: com_instance_defs} // make unique copy		
		# (new_funs, new_groups, com_instance_defs, gs) =
			build_instances module_index 0 com_instance_defs {gs & gs_modules = gs_modules}
		# (funs, groups, gs) = build_modules (inc module_index) gs
		# {gs_modules} = gs
		# gs_modules = { gs_modules & [module_index] = {common_defs & com_instance_defs = com_instance_defs}} 
		= (new_funs ++ funs, new_groups ++ groups, {gs & gs_modules = gs_modules})

	build_instances :: !Index !Index !*{#ClassInstance} !*GenericState 
		-> (![FunDef], ![Group], !*{#ClassInstance}, !*GenericState)
	build_instances module_index instance_index instance_defs gs
		#! num_instance_defs = size instance_defs
		| instance_index == num_instance_defs
			= ([], [], instance_defs, gs)													
		# (new_funs, new_groups, instance_defs, gs) = build_instance module_index instance_index instance_defs gs 			
		# (funs, groups, instance_defs, gs) = build_instances module_index (inc instance_index) instance_defs gs		
		= (new_funs ++ funs, new_groups ++ groups, instance_defs, gs)	
	
	build_instance :: !Index !Index !*{#ClassInstance} !*GenericState 
		-> (![FunDef], ![Group], !*{#ClassInstance}, !*GenericState)	
	build_instance module_index instance_index instance_defs gs=:{gs_modules}
		# (instance_def, instance_defs) = instance_defs ! [instance_index]
		| not instance_def.ins_is_generic 
			= ([], [], instance_defs, gs)
		
		| instance_def.ins_generate
			#! (fun_def, fun_def_sym, gs) = build_instance_fun instance_def gs 	
			#! instance_def = { instance_def & ins_members = {fun_def_sym} }		
			#! instance_defs = {instance_defs & [instance_index] = instance_def} 
			= ([fun_def], [{group_members = [fun_def.fun_index]}], instance_defs, gs)

		| supportPartialInstances && instance_def.ins_partial			

			#! (fun_def, fun_def_sym, gs) = build_instance_fun instance_def gs 

			#! (instance_def, ins_fun_def, gs) 
				= move_instance instance_def gs
			#! instance_defs = {instance_defs & [instance_index] = instance_def} 

			#! (ins_fun_def, gs) = add_generic_alternative ins_fun_def fun_def gs
			
			= (	[fun_def, ins_fun_def], 
				[{group_members = [fun_def.fun_index]}, {group_members = [ins_fun_def.fun_index]}], 
				instance_defs, gs)
					//---> ("build partial instance", instance_def.ins_ident, instance_def.ins_type)

		| otherwise
			= ([], [], instance_defs, gs)
			
	add_generic_alternative ins_fun_def gen_fun_def gs=:{gs_heaps, gs_main_dcl_module_n}	
		# (TransformedBody tb) = ins_fun_def.fun_body
		# (Case cas) = tb.tb_rhs
		
		#! (arg_exprs, new_tb_args, gs_heaps) =  buildBoundVarExprs tb.tb_args gs_heaps
		
		#! gen_fun_ds = 
			{	ds_arity = gen_fun_def.fun_arity
			,	ds_ident = gen_fun_def.fun_symb
			,	ds_index = gen_fun_def.fun_index
			}
		#! (app_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n gen_fun_ds arg_exprs gs_heaps 		
		#! case_expr = Case {cas & case_default = (Yes app_expr)}
		
		#! ins_fun_def = 
			{	ins_fun_def
			&	fun_body = TransformedBody {tb & tb_rhs=case_expr, tb_args = new_tb_args}
			, 	fun_info =
				{	ins_fun_def.fun_info 
				& 	fi_calls = 
					[	{fc_level = NotALevel, fc_index = gen_fun_def.fun_index}
					:	ins_fun_def.fun_info.fi_calls ]
				} 
			}

		= (ins_fun_def, {gs & gs_heaps = gs_heaps})
			//---> ("created generic alterntaive for " +++ ins_fun_def.fun_symb.id_name)

	move_instance instance_def=:{ins_members, ins_pos} gs
		# (new_fun_index, new_fun_group, gs=:{gs_fun_defs, gs_predefs, gs_heaps}) 
			= newFunAndGroupIndex gs
		# ins_fun_index = ins_members.[0].ds_index
		# (ins_fun_def, gs_fun_defs) = gs_fun_defs ! [ins_fun_index]

		// set new indexes in the function
		# new_ins_fun_def =
			{	ins_fun_def
			&	fun_index = new_fun_index
			,	fun_info = {ins_fun_def.fun_info & fi_group_index = new_fun_group}	
			}							
		#! new_member = {ins_members.[0] & ds_index = new_fun_index}
		#! instance_def = {instance_def & ins_members = {new_member}}
		
		// build a dummy function and set it at the old position
		#! (undef_expr, gs_heaps) = buildUndefFunApp [] gs_predefs gs_heaps
		#! (arg_vars,  gs_heaps)  = 
			mapSt buildFreeVar0 ["v" +++ toString i \\ i <- [1..ins_fun_def.fun_arity]] gs_heaps
		# {fun_symb, fun_arity, fun_index, fun_info, fun_type, fun_pos} = ins_fun_def
		#! dummy_def_sym = 
			{	ds_ident = fun_symb
			,	ds_arity = fun_arity
			,	ds_index = ins_fun_index
			}
		#! dummy_fun_def = 
			makeFunction dummy_def_sym fun_info.fi_group_index arg_vars undef_expr fun_type [] [] fun_pos					
		#! gs_fun_defs = {gs_fun_defs & [ins_fun_index] = dummy_fun_def}
				
		= (instance_def, new_ins_fun_def, {gs & gs_fun_defs = gs_fun_defs, gs_heaps = gs_heaps})
								
	build_instance_fun instance_def gs=:{gs_modules}
				# {ins_class, ins_generic} = instance_def				
		# (class_def, gs_modules) = getClassDef ins_class.glob_module ins_class.glob_object.ds_index gs_modules
		# (member_def, gs_modules) = getMemberDef ins_class.glob_module class_def.class_members.[0].ds_index gs_modules
		# (generic_def, gs_modules) = getGenericDef ins_generic.glob_module ins_generic.glob_object gs_modules 

		# (fun_index, group_index, gs) = newFunAndGroupIndex {gs & gs_modules=gs_modules}
		# fun_def_sym = {
			ds_ident = instance_def.ins_ident, 
			ds_index = fun_index, 
			ds_arity = member_def.me_type.st_arity
			}
						
		//# (fun_def, gs) = build_dummy_instance fun_def_sym group_index gs	
		# (fun_def, gs) = buildInstance fun_def_sym group_index instance_def generic_def gs
		= (fun_def, fun_def_sym, gs)
			
	build_dummy_instance fun_def_sym group_index gs=:{gs_predefs, gs_heaps}
		# (fun_def, gs_heaps) = buildUndefFunction fun_def_sym group_index gs_predefs gs_heaps
		= (fun_def, {gs & gs_heaps = gs_heaps}) 

// generate kind star instances  
buildKindConstInstances :: !*GenericState	
	-> (![FunDef], ![Group], !*GenericState)
buildKindConstInstances gs
	= build_modules 0 gs
where
	build_modules :: !Index !*GenericState 
		-> (![FunDef], ![Group], !*GenericState)
	build_modules module_index gs=:{gs_modules}

		#! num_modules = size gs_modules
		| module_index == num_modules
			= ([], [], {gs & gs_modules = gs_modules})					
		# (new_funs, new_groups, instance_defs, gs) =
			build_instances module_index 0 {gs & gs_modules = gs_modules}
		# (funs, groups, gs) = build_modules (inc module_index) gs
		# {gs_modules} = gs

		// add instances 
		# (common_defs=:{com_instance_defs}, gs_modules) = gs_modules ! [module_index]		
		# com_instance_defs = arrayPlusList com_instance_defs instance_defs		
		# gs_modules = { gs_modules & [module_index] = {common_defs & com_instance_defs = com_instance_defs}} 
		= (new_funs ++ funs, new_groups ++ groups, {gs & gs_modules = gs_modules})

	build_instances :: !Index !Index !*GenericState 
		-> (![FunDef], ![Group], ![ClassInstance], !*GenericState)
	build_instances module_index instance_index gs=:{gs_modules}
		# ({com_instance_defs}, gs_modules) = gs_modules ! [module_index]
		#! num_instance_defs = size com_instance_defs		
		# gs = { gs & gs_modules = gs_modules }		
		| instance_index == num_instance_defs
			= ([], [], [], gs)
																
		# (new_funs, new_groups, new_instance_defs, gs) = build_instance module_index instance_index gs 			
		# (funs, groups, instance_defs, gs) = build_instances module_index (inc instance_index) gs		
		= (new_funs ++ funs, new_groups ++ groups, new_instance_defs ++ instance_defs, gs)	
	build_instance :: !Index !Index !*GenericState 
		-> (![FunDef], ![Group], ![ClassInstance], !*GenericState)	
	build_instance module_index instance_index gs=:{gs_modules, gs_td_infos, gs_heaps}
		# (instance_def, gs_modules) = getInstanceDef module_index instance_index gs_modules		
		# {	ins_ident, ins_type, ins_pos,
			ins_generate, ins_is_generic, ins_generic} = instance_def
		
		| not (/*ins_generate &&*/ ins_is_generic)
			= ([], [], [], {gs & gs_td_infos = gs_td_infos, gs_modules = gs_modules, gs_heaps = gs_heaps})

		# it_type = hd ins_type.it_types
		#! (kind, gs_td_infos) = kindOfType it_type gs_td_infos
		| kind == KindConst
			= ([], [], [], { gs & gs_td_infos = gs_td_infos, gs_modules = gs_modules, gs_heaps = gs_heaps})

		# (generic_def, gs_modules) = getGenericDef ins_generic.glob_module ins_generic.glob_object gs_modules
		# (ok, class_def_sym) = getGenericClassForKind generic_def KindConst
		| not ok
			= abort "no class for kind *"			
		# (class_def, gs_modules) = getClassDef ins_generic.glob_module class_def_sym.ds_index gs_modules 
		# (member_def, gs_modules) = getMemberDef ins_generic.glob_module class_def.class_members.[0].ds_index gs_modules 	

		# (new_ins_type, gs_heaps) = 
			build_instance_type ins_type kind {glob_module=ins_generic.glob_module, glob_object=class_def_sym} gs_heaps

		# gs = {gs & gs_modules=gs_modules, gs_td_infos = gs_td_infos, gs_heaps = gs_heaps}
		# (fun_index, group_index, gs) = newFunAndGroupIndex gs
		# fun_def_sym = {
			ds_ident = class_def.class_name, // kind star name 
			ds_index = fun_index, 
			ds_arity = member_def.me_type.st_arity
			}
						
		//# (fun_def, gs) = build_dummy_instance fun_def_sym group_index gs	
		# generic_def_sym = {
			ds_ident=generic_def.gen_name, 
			ds_index=ins_generic.glob_object,
			ds_arity=0
			}
		# (fun_def, gs) = 
			buildKindConstInstance fun_def_sym group_index ins_generic.glob_module generic_def_sym kind gs

		# new_instance_def = {
			ins_class 		= {glob_module = ins_generic.glob_module, glob_object = class_def_sym},	
			ins_ident 		= class_def.class_name,	
			ins_type  		= new_ins_type,
			ins_members 	= {fun_def_sym},
			ins_specials 	= SP_None,
			ins_pos			= ins_pos, 
			ins_is_generic	= True, 
			ins_generate	= False,
			ins_partial		= False,
			ins_generic 	= ins_generic
			}
			//---> fun_def

		= ([fun_def], [{group_members = [fun_index]}], [new_instance_def], gs)
		
	build_dummy_instance fun_def_sym group_index gs=:{gs_predefs, gs_heaps}
		# (fun_def, gs_heaps) = buildUndefFunction fun_def_sym group_index gs_predefs gs_heaps
		= (fun_def, {gs & gs_heaps = gs_heaps})
		
	build_instance_type ins_type=:{it_vars, it_types, it_context} (KindArrow kinds) class_glob_def_sym heaps		
		# type_var_names = ["a" +++ toString i \\ i <- [1 .. (length kinds) - 1]]
		# (type_vars, heaps) = mapSt buildTypeVar type_var_names heaps
		# type_var_types = map TV type_vars 	
		# new_type_args = map (\t->makeAType t TA_Multi) type_var_types

		# (TA type_symb_ident=:{type_arity} type_args) = hd it_types		
		# new_type = TA	{type_symb_ident & type_arity = type_arity + length new_type_args} (type_args ++ new_type_args)
		
		# (new_contexts, heaps) = mapSt (build_type_context class_glob_def_sym) type_var_types heaps
		
		# new_ins_type = { ins_type & 
			it_vars = it_vars ++ type_vars,
			it_types = [new_type],
			it_context = it_context ++ new_contexts
			}
		= (new_ins_type, heaps)
			//---> new_ins_type
		
	build_type_var name heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}
		# (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars
		# type_var = {
			tv_name = {id_name = name, id_info = nilPtr},
			tv_info_ptr = tv_info_ptr
			}
		= (	type_var, {heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars}})
			
	build_type_context class_glob_def_sym type heaps=:{hp_var_heap}
		# (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap			
		# type_context = {
		
			tc_class = class_glob_def_sym,
			tc_types = [type],
			tc_var	 = var_info_ptr
			}
		= (type_context, {heaps & hp_var_heap = hp_var_heap})	
									
// for all generic instances determine and set types
// of their functions
determineMemberTypes :: !Index !Index !*GenericState	
	-> !*GenericState
determineMemberTypes module_index ins_index 
		gs=:{gs_modules, gs_fun_defs, gs_heaps=gs_heaps=:{hp_var_heap, hp_type_heaps}}
	# (num_modules, gs_modules) = usize gs_modules
	| module_index == num_modules
		= {gs & gs_modules = gs_modules}
	# (common_defs=:{com_instance_defs}, gs_modules) = gs_modules![module_index]		
	| ins_index == size com_instance_defs
		= determineMemberTypes (inc module_index) 0 {gs & gs_modules = gs_modules} 		
	# (instance_def, com_instance_defs) = com_instance_defs![ins_index]
	| not instance_def.ins_is_generic		
		= determineMemberTypes module_index (inc ins_index) {gs & gs_modules = gs_modules}
	
	# {ins_class, ins_type, ins_members} = instance_def
	# (class_def, gs_modules) = getClassDef ins_class.glob_module ins_class.glob_object.ds_index gs_modules
	# (member_def, gs_modules) = getMemberDef ins_class.glob_module class_def.class_members.[0].ds_index gs_modules
	# {me_type, me_class_vars}  = member_def
		
		
		
	// determine type of the member instance		
	# (symbol_type, _, hp_type_heaps, _, _) = 
		determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None hp_type_heaps No No
	# (st_context, hp_var_heap) = initializeContextVariables symbol_type.st_context hp_var_heap
	# symbol_type = {symbol_type & st_context = st_context}			
	
	// update the instance function
	# fun_index = ins_members.[0].ds_index
	# (fun_def, gs_fun_defs) = gs_fun_defs![fun_index]
	# fun_def = {fun_def & fun_type = (Yes symbol_type)} 

	# gs_fun_defs = {gs_fun_defs & [fun_index] = fun_def}
	
	# gs = { gs & 
		gs_modules = gs_modules, 
		gs_fun_defs = gs_fun_defs,
		gs_heaps = {gs_heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap} 
		}

	= determineMemberTypes module_index (inc ins_index) gs

kindOfTypeDef :: Index Index !*TypeDefInfos -> (!TypeKind, !*TypeDefInfos)
kindOfTypeDef module_index td_index td_infos 
	# ({tdi_kinds}, td_infos) = td_infos![module_index, td_index] 
	| isEmpty tdi_kinds
		= (KindConst, td_infos)
		= (KindArrow (tdi_kinds ++ [KindConst]), td_infos)

kindOfType :: !Type !*TypeDefInfos -> (!TypeKind, !*TypeDefInfos)
kindOfType (TA type_cons args) td_infos
	# {glob_object,glob_module} = type_cons.type_index
	# ({tdi_kinds}, td_infos) = td_infos![glob_module,glob_object] 
	# kinds = drop (length args) tdi_kinds	
	| isEmpty kinds 
		= (KindConst, td_infos) 
		= (KindArrow (kinds ++ [KindConst]), td_infos)
kindOfType (TV _) td_infos = (KindConst, td_infos)
kindOfType (GTV _) td_infos = (KindConst, td_infos)
kindOfType (TQV _) td_infos = (KindConst, td_infos)
kindOfType _ td_infos = (KindConst, td_infos)
			
buildClassDef :: /*generic*/!(Global DefinedSymbol) !TypeKind !*GenericState
	-> (/*class*/!(Global DefinedSymbol), !*GenericState)	
buildClassDef 
		generic_glob=:{glob_module, glob_object={ds_ident, ds_index}} 
		kind 
		gs=:{gs_modules, gs_heaps=gs_heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}, hp_var_heap}}
	#! (common_defs=:{com_generic_defs, com_class_defs, com_member_defs}, gs_modules) = gs_modules![glob_module]
	#! (generic_def=:{gen_name=gen_name=:{id_name}, gen_type, gen_pos, gen_classes}, com_generic_defs) = com_generic_defs![ds_index]
	
	// check if the class is already created
	# (found, class_symbol) = getGenericClassForKind generic_def kind
	| found 
		= (	{glob_module = glob_module, glob_object = class_symbol}, 
			{gs & gs_modules = gs_modules}) 

	#! id_name = id_name +++ ":" +++ (toString kind) 
	#! ident = {id_name = id_name, id_info = nilPtr}

	// allocate new class and member
	#! class_index = size com_class_defs
	#! class_ds = {ds_ident = ident, ds_index = class_index, ds_arity = 1}
	#! glob_class = {glob_module = glob_module, glob_object = class_ds}	       
	#! member_index = size com_member_defs

	// class argument
	#! (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars 
	#! class_arg = {tv_name = {id_name = "class_var", id_info = nilPtr}, tv_info_ptr = tv_info_ptr}	

	// member
	#! (type_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap 
	#! (tc_var_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap  
	#! type_context = { 
		tc_class = glob_class,
		tc_types = [ TV class_arg ], 
		tc_var = tc_var_ptr 				// ???
		}
	#! hp_type_heaps = {hp_type_heaps & th_vars = th_vars}	
	#! (member_type, hp_type_heaps) = buildMemberType1 generic_def kind class_arg hp_type_heaps
	#! member_type = { member_type & st_context = [type_context : gen_type.gt_type.st_context] }
	#! member_def = {
		me_symb = ident,
		me_class = {glob_module = glob_module, glob_object = class_index},
		me_offset = 0,
		me_type = member_type,
		me_type_ptr = type_ptr,				// empty
		me_class_vars = [class_arg], 		// the same variable as in the class
		me_pos = gen_pos,
		me_priority = NoPrio
		}
	
	// class
	#! class_member = {ds_ident=ident, ds_index = member_index, ds_arity = member_def.me_type.st_arity}
	#! class_dictionary = { 
		ds_ident = {id_name = id_name, id_info = nilPtr}, 
		ds_arity = 0, 
		ds_index = NoIndex/*index in the type def table, filled in later*/ 
		}
	#! class_def = { 
		class_name = ident, 
		class_arity = 1,  
		class_args = [class_arg],
	    class_context = [], 
	    class_pos = gen_pos, 
	    class_members = createArray 1 class_member, 
	    class_cons_vars = case kind of KindConst -> 0; _ -> 1,
	    class_dictionary = class_dictionary
	    }	 
	    
	#! com_class_defs = append_array com_class_defs class_def
	#! com_member_defs = append_array com_member_defs member_def	
	#! generic_def = {generic_def & gen_classes = [{gci_kind = kind, gci_class = class_ds} : gen_classes] }
	#! com_generic_defs = {(copy_array com_generic_defs) & [ds_index] = generic_def}
	#! common_defs = {common_defs & 
		com_class_defs = com_class_defs, 
		com_generic_defs = com_generic_defs, 
		com_member_defs = com_member_defs}	
	#! gs_modules = {gs_modules & [glob_module] = common_defs} 
	#! gs = { gs &
		gs_modules = gs_modules,
		gs_heaps = { gs_heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap}
		}		
	= (glob_class, gs) 
		//---> ("generated class " +++ id_name)
where
	append_array array el 
//1.3
		= arrayConcat array {el}
//3.1
/*2.0
		= r2
	where
		r2={r1 & [s]=el}
		r1={r0 & [i]=array.[i] \\ i<-[0..s-1]} 	
		r0 = _createArray (s+1)
		s = size array		
0.2*/
	copy_array array = {x \\ x <-: array}	

buildClassDef1 :: !Index !Index !Index !GenericDef !TypeKind !*GenericState
	-> (!ClassDef, !MemberDef!, !GenericDef, *GenericState)	
buildClassDef1 	module_index class_index member_index generic_def=:{gen_name, gen_classes} kind gs=:{gs_heaps}
	#! ident = makeIdent (gen_name.id_name +++ ":" +++ (toString kind))
	#! class_ds={ds_ident=ident, ds_index=class_index, ds_arity=0}
	#! (class_var, gs_heaps) = build_class_var gs_heaps
	#! (member_def, gs_heaps) = build_member module_index class_index member_index class_var class_ds generic_def gs_heaps
	#! class_def = build_class module_index class_index member_index class_var kind ident generic_def member_def
	#! generic_def = { generic_def & 	gen_classes = [{gci_kind=kind,gci_class=class_ds}:gen_classes]}
	= (class_def, member_def, generic_def, {gs & gs_heaps = gs_heaps}) 
		//---> ("generated class " +++ ident.id_name)
where

	build_class_var heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}
		#! (class_var, th_vars) = freshTypeVar (makeIdent "class_var") th_vars
		=(class_var, {heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars}})

	build_member 
			module_index class_index member_index 
			class_var class_ds=:{ds_ident} generic_def=:{gen_type} 
			heaps=:{hp_var_heap, hp_type_heaps}
		#! (type_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap 
		#! (tc_var_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap  
		#! type_context = { 
			tc_class = {glob_module = module_index, glob_object=class_ds},
			tc_types = [ TV class_var ], 
			tc_var = tc_var_ptr 				// ???
			}
		#! (member_type, hp_type_heaps) = buildMemberType1 generic_def kind class_var hp_type_heaps
		#! member_type = { member_type & st_context = [type_context : gen_type.gt_type.st_context] }
		#! member_def = {
			me_symb = ds_ident, // same name as class
			me_class = {glob_module = module_index, glob_object = class_index},
			me_offset = 0,
			me_type = member_type,
			me_type_ptr = type_ptr,				// empty
			me_class_vars = [class_var], 		// the same variable as in the class
			me_pos = generic_def.gen_pos,
			me_priority = NoPrio
			}
		= (member_def, {heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap})
	
	build_class 
			module_index class_index member_index class_var kind ident 
			generic_def=:{gen_pos} member_def=:{me_type}
		#! class_member = {ds_ident=ident, ds_index = member_index, ds_arity = me_type.st_arity}
		#! class_dictionary = { 
			ds_ident = ident, 
			ds_arity = 0, 
			ds_index = NoIndex/*index in the type def table, filled in later*/ 
			}
		#! class_def = { 
			class_name = ident, 
			class_arity = 1,  
			class_args = [class_var],
		    class_context = [], 
		    class_pos = gen_pos, 
		    class_members = createArray 1 class_member, 
		    class_cons_vars = case kind of KindConst -> 0; _ -> 1,
		    class_dictionary = class_dictionary
		    }	 
			
		= class_def	

currySymbolType :: !SymbolType !String !*TypeHeaps 
	-> (!AType, ![AttributeVar], ![AttrInequality], !*TypeHeaps)
currySymbolType {st_args=[], st_result} attr_var_name th
	= (st_result, [], [], th)
currySymbolType {st_args, st_result} attr_var_name th=:{th_attrs}
	#! (first_cum_av, th_attrs) = freshAttrVar (makeIdent (attr_var_name+++"1")) th_attrs
	#! (at, attr_vars, ais, index, th_attrs) = curry_type st_args st_result (TA_Var first_cum_av) 2 th_attrs
	= (at, [first_cum_av:attr_vars], ais, {th & th_attrs = th_attrs})
where
	curry_type [] type cum_attr index th_attrs 
		= (type, [], [], index, th_attrs)
	curry_type [at=:{at_attribute}] type cum_attr index th_attrs
		#! t = makeAType (at --> type) cum_attr
		= (t, [], [], index, th_attrs) 						 
	curry_type [at=:{at_attribute}:ats] type cum_attr index th_attrs
		#! (next_cum_attr, avs1, ais1, index, th_attrs) = combine_attributes at_attribute cum_attr index th_attrs
		#! (res_type, avs2, ais2, index, th_attrs) = curry_type ats type next_cum_attr index th_attrs 
		#! t = makeAType (at --> res_type) cum_attr
		= (t, avs1 ++ avs2, ais1 ++ ais2, index, th_attrs) 
	
	combine_attributes TA_Unique cum_attr index th_attrs
		= (TA_Unique, [], [], index, th_attrs)
	combine_attributes (TA_Var av) (TA_Var cum_av) index th_attrs
		#! (new_av, th_attrs) = freshAttrVar (makeIdent (attr_var_name+++"_"+++toString index)) th_attrs
		#! ais = [
			{ai_offered=new_av, ai_demanded=av},
			{ai_offered=new_av, ai_demanded=cum_av}]
		= (TA_Var new_av, [new_av], ais, (inc index), th_attrs)
	combine_attributes (TA_Var _) cum_attr index th_attrs
		= (cum_attr, [], [], index, th_attrs)
	combine_attributes _ (TA_Var cum_av) index th_attrs
		#! (new_av, th_attrs) = freshAttrVar (makeIdent (attr_var_name+++"_"+++toString index)) th_attrs
		= (TA_Var new_av, [new_av], [{ai_offered=new_av, ai_demanded=cum_av}], (inc index), th_attrs)
	combine_attributes _ cum_attr index th_attrs
		= (cum_attr, [], [], index, th_attrs)


currySymbolType1 :: !SymbolType !String !*TypeHeaps 
	-> (!AType, ![AttributeVar], ![AttrInequality], !*TypeHeaps)
currySymbolType1 {st_args=[], st_result} attr_var_name th
	= (st_result, [], [], th)
currySymbolType1 {st_args, st_result} attr_var_name th=:{th_attrs}
	// TA_None indicates top-level attribute
	#! (at, attr_vars, ais, index, th_attrs) = curry_type st_args st_result TA_None 2 th_attrs
	= (at, attr_vars, ais, {th & th_attrs = th_attrs})
where
	curry_type [] type cum_attr index th_attrs 
		= (type, [], [], index, th_attrs)
	curry_type [at=:{at_attribute}] type cum_attr index th_attrs
		#! t = makeAType (at --> type) (if (cum_attr == TA_None) TA_Multi cum_attr)
		= (t, [], [], index, th_attrs)		 						 
	curry_type [at=:{at_attribute}:ats] type cum_attr index th_attrs
		#! (next_cum_attr, avs1, ais1, index, th_attrs) = combine_attributes at_attribute cum_attr index th_attrs
		#! (res_type, avs2, ais2, index, th_attrs) = curry_type ats type next_cum_attr index th_attrs 
		#! t = makeAType (at --> res_type) cum_attr
		= (t, avs1 ++ avs2, ais1 ++ ais2, index, th_attrs) 
	
	combine_attributes TA_Unique cum_attr index th_attrs
		= (TA_Unique, [], [], index, th_attrs)
	combine_attributes (TA_Var av) (TA_Var cum_av) index th_attrs
		#! (new_av, th_attrs) = freshAttrVar (makeIdent (attr_var_name+++"_"+++toString index)) th_attrs
		#! ais = [
			{ai_offered=new_av, ai_demanded=av},
			{ai_offered=new_av, ai_demanded=cum_av}]
		= (TA_Var new_av, [new_av], ais, (inc index), th_attrs)
	combine_attributes (TA_Var av) TA_None index th_attrs
		#! (new_av, th_attrs) = freshAttrVar (makeIdent (attr_var_name+++"_"+++toString index)) th_attrs
		= (TA_Var new_av, [new_av], [{ai_offered=new_av, ai_demanded=av}], (inc index), th_attrs)		
	combine_attributes (TA_Var _) cum_attr index th_attrs
		= (cum_attr, [], [], index, th_attrs)
	combine_attributes _ (TA_Var cum_av) index th_attrs
		#! (new_av, th_attrs) = freshAttrVar (makeIdent (attr_var_name+++"_"+++toString index)) th_attrs
		= (TA_Var new_av, [new_av], [{ai_offered=new_av, ai_demanded=cum_av}], (inc index), th_attrs)
	combine_attributes _ TA_None index th_attrs
		#! (new_av, th_attrs) = freshAttrVar (makeIdent (attr_var_name+++"_"+++toString index)) th_attrs
		= (TA_Var new_av, [new_av], [], (inc index), th_attrs)
	combine_attributes _ cum_attr index th_attrs
		= (cum_attr, [], [], index, th_attrs)


buildMemberType1 :: !GenericDef !TypeKind !TypeVar !*TypeHeaps -> (!SymbolType, !*TypeHeaps)
buildMemberType1 generic_def=:{gen_name,gen_type} kind class_var th 

	#! (gen_type, th) = freshGenericType gen_type th

	// Collect attributes of generic variables. 
	// The attributes are instantiated along with the variables.
	#! (gen_vars_with_attrs, generic_avs, th) = collect_generic_var_attrs gen_type th
	
	// build additional arguments that emerge due to lifting
	#! (new_args, atvss, new_avs, attr_inequalities, th) = build_args gen_type gen_vars_with_attrs kind th

	#! atvss = case atvss of 
		[] 		-> repeatn gen_type.gt_arity []
		atvss	-> transpose atvss
	
	// substitute generic variables for types
	// all non-generic variables must be left intact
	#! th = clearSymbolType gen_type.gt_type th	
 	#! th = build_generic_var_substs gen_vars_with_attrs class_var atvss kind th
	#! th = build_attr_var_substs gen_type.gt_type.st_attr_vars generic_avs kind th
	#! (st, th) = substituteInSymbolType gen_type.gt_type th

	// update generated fields
	#! instantiation_tvs	 = [atv_variable \\ {atv_variable} <- (flatten atvss)]
	#! st = { st &
			st_vars 		= [class_var : instantiation_tvs ++ st.st_vars]
		,	st_arity 		= (length new_args) + st.st_arity
		,	st_args 		= new_args ++ st.st_args  
		, 	st_attr_vars 	= st.st_attr_vars ++ new_avs
		,	st_attr_env 	= st.st_attr_env ++ attr_inequalities
		}
	= (st, th)
		//---> ("member type", gen_name, kind, st)
where

	collect_generic_var_attrs {gt_type, gt_vars} th
		#! th = clearSymbolType gt_type th		
		#! th = setTypeVarAttrs gt_type th
		
		#! (attributed_vars, (avs, th)) = mapSt get_attr gt_vars ([], th)
			with 
				get_attr tv=:{tv_info_ptr} (avs, th=:{th_vars})
					#! (TVI_Attribute attr, th_vars) = readPtr tv_info_ptr th_vars
					#! avs = (collect_attr_var attr) ++ avs
					#! th = {th & th_vars = th_vars}
					= (	{atv_attribute=attr, atv_variable=tv, atv_annotation=AN_None},
						(avs, th))
				collect_attr_var (TA_Var av)	= [av]
				collect_attr_var _ 				= []
					 
		= (attributed_vars, avs, th)

	build_attr_var_substs avs generic_avs kind th
 		= foldSt build_subst (determine_attr_vars kind avs generic_avs)  th
	where
		determine_attr_vars KindConst avs generic_avs
			= removeMembers avs generic_avs 
		determine_attr_vars kind avs generic_avs
			= avs
		build_subst av=:{av_info_ptr} th=:{th_attrs}
			= { th & th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr (TA_Var av))}
						 
	build_generic_var_substs [] class_var [] kind th
		= th
	build_generic_var_substs [gv:gvs] class_var [tvs:tvss] kind th
		#! th = build_generic_var_subst gv class_var tvs kind th
		#! th = build_generic_var_substs gvs class_var tvss kind th
		= th	

	build_generic_var_subst {atv_variable={tv_info_ptr}} class_var [] KindConst th=:{th_vars}
		#! th_vars = th_vars <:= (tv_info_ptr, TVI_Type (TV class_var))
		= {th & th_vars = th_vars}		
	build_generic_var_subst {atv_variable={tv_info_ptr}} class_var atvs (KindArrow ks) th=:{th_vars}
		#! arity = (length ks) - 1
		| arity <> length atvs = abort "sanity check: invalid number of type variables"

		#! type_args = [ makeAType (TV atv_variable) atv_attribute \\ {atv_variable, atv_attribute} <- atvs]
		#! type = (CV class_var) :@: type_args
		#! th_vars = th_vars <:= (tv_info_ptr, TVI_Type type)			
		= {th & th_vars = th_vars}
			
	build_args gen_type agvs KindConst th
		= ([], [], [], [], th)
	build_args gen_type agvs (KindArrow ks) th	
		#! arity = (length ks) - 1
		#! postfixes = ["_" +++ toString i \\ i <- [1..arity]]
		#! (ats, atvss, new_avs, ais, th) = build_generic_args gen_type agvs postfixes th
		= (ats, atvss, new_avs, ais, th)
	
 	build_generic_args :: !GenericType ![ATypeVar] ![String] !*TypeHeaps 
 		-> (![AType], ![[ATypeVar]], ![AttributeVar], ![AttrInequality], !*TypeHeaps)
	build_generic_args gen_type agvs [] th 
		= ([], [], [], [], th)	
	build_generic_args gen_type agvs [postfix:postfixes] th
		#! (at, atvs, new_avs, ais, th) = build_generic_arg gen_type agvs postfix th
		#! (ats, atvss, new_avs1, ais1, th) = build_generic_args gen_type agvs postfixes th
		= ([at:ats], [atvs:atvss], new_avs ++ new_avs1, ais ++ ais1, th)  	
 	
 	build_generic_arg :: !GenericType ![ATypeVar] !String !*TypeHeaps 
 		-> (!AType, ![ATypeVar], ![AttributeVar], ![AttrInequality], !*TypeHeaps)
	build_generic_arg {gt_type, gt_vars, gt_arity} agvs postfix th=:{th_vars, th_attrs}
		#! th = clearSymbolType gt_type th
		#! {th_vars, th_attrs} = th
		
		// replace all generic variables with fresh variables
		#! (tvs, th_vars) = mapSt build_subst gt_vars th_vars			
			with
				build_subst gv=:{tv_name,tv_info_ptr} th_vars					
					#! name = makeIdent (tv_name.id_name +++ postfix)
					#! (tv, th_vars) = freshTypeVar name th_vars 					
					#! th_vars = th_vars <:= (tv_info_ptr, TVI_Type (TV tv))	
					= (tv, th_vars)
		
		// leave all non-generic attribute variables intact
		#! th_attrs = foldSt build_subst gt_type.st_attr_vars th_attrs
			with
				build_subst av=:{av_info_ptr} th_attrs
					= th_attrs <:= (av_info_ptr, AVI_Attr (TA_Var av))

		// all attribute variables at generic arguments must be taken afresh
		#! (attrs, (instantiated_avs, th_attrs)) = mapSt build_subst agvs ([], th_attrs)
			with
				build_subst {atv_attribute=TA_Unique} st = (TA_Unique, st)
				build_subst {atv_attribute=TA_Multi} st = (TA_Multi, st)
				build_subst {atv_attribute=TA_Var {av_name, av_info_ptr}} (avs, th_attrs)
					#! (fresh_av, th_attrs) = freshAttrVar (makeIdent (av_name.id_name+++postfix)) th_attrs
					#! attr = TA_Var fresh_av					
					#! th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr attr)
					= (attr, ([fresh_av:avs], th_attrs))
		#! (st, th) = substituteInSymbolType gt_type {th & th_vars = th_vars, th_attrs = th_attrs}

		#! atvs = [{atv_attribute=attr, atv_variable=tv, atv_annotation=AN_None} \\
			attr 	<- attrs &
			tv 		<- tvs]
		
		#! (at, curry_avs, ais, th) = currySymbolType1 st ("arg"+++postfix) th		
		#! th = clearSymbolType gt_type th
		= (at, atvs, instantiated_avs ++ curry_avs, ais, th)

buildGenericRepType :: !Index !Index !*GenericState
	-> (AType, !*GenericState)
buildGenericRepType module_index td_index gs=:{gs_modules, gs_predefs, gs_error}
	# (type_def=:{td_name}, gs_modules) = getTypeDef module_index td_index gs_modules 
	# (common_defs, gs_modules) = gs_modules ! [module_index]		
	# (atype, gs_error) = build_type module_index type_def gs_predefs common_defs gs_error	
	= (atype, {gs & gs_modules = gs_modules, gs_error = gs_error})
where		 
	build_type td_module {td_rhs=(AlgType alts)} predefs common_defs error
		= (build_sum alts predefs common_defs.com_cons_defs, error)
	where
		build_sum :: ![DefinedSymbol] !PredefinedSymbols !{#ConsDef} -> !AType
		build_sum [] predefs cons_defs = abort "no alternatives in typedef"
		build_sum [{ds_index}] predefs cons_defs
			# cons_args = cons_defs.[ds_index].cons_type.st_args
			# atype = buildProductType cons_args predefs
			= case supportCons of
				True -> buildATypeCONS atype predefs
				False -> atype 
		build_sum alts predefs cons_defs 
			# (l,r) = splitAt ((length alts) / 2) alts 
			= buildATypeEITHER (build_sum l predefs cons_defs) (build_sum r predefs cons_defs) predefs
			
	build_type td_module {td_rhs=(RecordType {rt_constructor={ds_index}})} predefs common_defs error
		#! {cons_type={st_args}} = common_defs . com_cons_defs . [ds_index]
		#! atype = buildProductType st_args predefs
		#! atype = case supportCons of
					True -> buildATypeCONS atype predefs
					False -> atype 
		= (atype, error)
	
	build_type td_module {td_rhs=(SynType type)} predefs common_defs error
		= (type, error) // is that correct ???

	build_type 
			td_module td=:{td_rhs=(AbstractType _), td_name, td_arity, td_args, td_pos} 
			predefs common_defs error
		#! error = checkErrorWithIdentPos (newPosition td_name td_pos) "cannot build generic type repesentation for an abstract type" error
		= (makeAType TE TA_None, error)
			
buildIsoRecord :: !DefinedSymbol !Int !DefinedSymbol !DefinedSymbol !*GenericState
	-> (!FunDef, !*GenericState)
buildIsoRecord 
		def_sym group_index from_fun to_fun 
		gs=:{gs_heaps, gs_main_dcl_module_n, gs_predefs}
	# (from_expr, gs_heaps) 	= buildFunApp gs_main_dcl_module_n from_fun [] gs_heaps
	# (to_expr, gs_heaps) 		= buildFunApp gs_main_dcl_module_n to_fun [] gs_heaps	
	# (iso_expr, gs_heaps) 		= buildISO to_expr from_expr gs_predefs gs_heaps
	# fun_def = makeFunction def_sym group_index [] iso_expr No [] [from_fun.ds_index, to_fun.ds_index]	NoPos				
	= (fun_def, {gs & gs_heaps = gs_heaps})
where
	build_fun_expr mod_index fun_def heaps=:{hp_expression_heap}
		# (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap
		# global_index = {glob_module = mod_index/*gs_maindcl_module_n???*/, glob_object = fun_def.fun_index}
		# fun_symb = {
			symb_name = fun_def.fun_symb, 
			symb_kind = SK_Function global_index, 
			symb_arity = 0 //fun_def.fun_arity 
			}
		# fun_expr = App {app_symb = fun_symb, app_args = [], app_info_ptr = expr_info_ptr}	
		= (fun_expr, {heaps & hp_expression_heap = hp_expression_heap})

// convert a type to ot's generic representation
buildIsoTo :: !DefinedSymbol !Int !Int !CheckedTypeDef ![DefinedSymbol] !*GenericState
	-> (!FunDef, !*GenericState)
buildIsoTo 
		def_sym group_index type_def_mod 
		type_def=:{td_rhs, td_name, td_index, td_pos} 
		cons_infos
		gs=:{gs_heaps}
	# (arg_expr, arg_var, gs_heaps) = buildVarExpr "x" gs_heaps 
	# (body_expr, free_vars, gs=:{gs_error}) = 
		build_body type_def_mod td_index td_rhs cons_infos arg_expr {gs&gs_heaps = gs_heaps}	
	| not gs_error.ea_ok
		#! fun_def = makeFunction {def_sym&ds_arity=0} NoIndex [] EE No [] [] NoPos
		= (fun_def, {gs & gs_error = gs_error})	
	# fun_call_indexes = [] // [ds_index \\  {ds_index} <- cons_infos]		
	# fun_def = makeFunction def_sym group_index [arg_var] body_expr No free_vars fun_call_indexes NoPos	
	= (fun_def, {gs & gs_error = gs_error})
		//---> fun_def
where
	get_cons_infos module_index td_index gs=:{gs_gtd_infos}
		# (GTDI_Generic {gtr_cons_infos}, gs_gtd_infos) = gs_gtd_infos ! [module_index, td_index] 							 
 		= (gtr_cons_infos, {gs & gs_gtd_infos = gs_gtd_infos})

	build_body :: !Int !Int !TypeRhs ![DefinedSymbol] !Expression !*GenericState 
		-> (!Expression, ![FreeVar], !*GenericState)
 	build_body type_def_mod type_def_index (AlgType def_symbols) cons_infos arg_expr gs
		= build_body1 type_def_mod type_def_index def_symbols cons_infos arg_expr gs
	
	build_body type_def_mod type_def_index (RecordType {rt_constructor}) cons_infos arg_expr gs		
		= build_body1 type_def_mod type_def_index [rt_constructor] cons_infos arg_expr gs

	build_body type_def_mod type_def_index (AbstractType _) cons_infos arg_expr gs=:{gs_error}
		#! gs_error = checkErrorWithIdentPos (newPosition td_name td_pos) "cannot build isomorphisms for an abstract type" gs_error
		= (EE, [], {gs & gs_error = gs_error})
	build_body type_def_mod type_def_index (SynType _) cons_infos arg_expr gs=:{gs_error}
		#! gs_error = checkErrorWithIdentPos (newPosition td_name td_pos) "cannot build isomorphisms for a synonym type" gs_error
		= (EE, [], {gs & gs_error = gs_error})
	
	build_body1 type_def_mod type_def_index cons_def_syms cons_infos arg_expr gs
		# (case_alts, free_vars, gs=:{gs_heaps}) = 
			build_alts 0 (length cons_def_syms) type_def_mod cons_def_syms cons_infos gs
		# case_patterns = AlgebraicPatterns {glob_module = type_def_mod, glob_object = type_def_index} case_alts
		# (case_expr, gs_heaps) = buildCaseExpr arg_expr case_patterns gs_heaps
		= (case_expr, free_vars, {gs & gs_heaps = gs_heaps})	
			//---> (free_vars, case_expr)	
				
	build_alts :: !Int !Int !Int ![DefinedSymbol] ![DefinedSymbol] !*GenericState 
		-> ([AlgebraicPattern], [FreeVar], !*GenericState)
	build_alts i n type_def_mod [] [] gs = ([], [], gs) 
	build_alts i n type_def_mod [cons_def_sym:cons_def_syms] cons_infos gs	
		# (cons_info, cons_infos) = case supportCons of
			True -> (hd cons_infos, tl cons_infos)
			False -> (EmptyDefinedSymbol, [])	
		# (alt, fvs, gs) = build_alt i n type_def_mod cons_def_sym cons_info gs
		# (alts, free_vars, gs) =  build_alts (i+1) n type_def_mod cons_def_syms cons_infos gs 		
		= ([alt:alts], fvs ++ free_vars, gs)

	build_alt :: !Int !Int !Int !DefinedSymbol !DefinedSymbol !*GenericState 
		-> (AlgebraicPattern, [FreeVar], !*GenericState)
	build_alt 
			i n type_def_mod def_symbol=:{ds_ident, ds_arity} cons_info 
			gs=:{gs_heaps, gs_predefs, gs_main_dcl_module_n}		
		# names = ["x" +++ toString (i+1) +++ toString k \\ k <- [1..ds_arity]]
		# (var_exprs, vars, gs_heaps) = buildVarExprs names gs_heaps 
		# (expr, gs_heaps) = build_prod var_exprs gs_predefs gs_heaps		
		# (expr, gs_heaps) = case supportCons of
			True 
				//# (cons_info_expr, gs_heaps) = buildUndefFunApp [] gs_predefs gs_heaps
				# (cons_info_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n cons_info [] gs_heaps 	
				-> buildCONS cons_info_expr expr gs_predefs gs_heaps
			False 
				-> (expr, gs_heaps)				
		# (expr, gs_heaps) = build_sum i n expr gs_predefs gs_heaps
				
		# alg_pattern = {
			ap_symbol = {glob_module = type_def_mod, glob_object = def_symbol},
			ap_vars = vars,
			ap_expr = expr,
			ap_position = NoPos
			}
		= (alg_pattern, vars, {gs & gs_heaps = gs_heaps})

	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
			= buildLEFT expr predefs heaps
		| otherwise
			# (expr, heaps) = build_sum (i - (n/2)) (n - (n/2)) expr predefs heaps
			= buildRIGHT expr predefs heaps

	build_prod :: ![Expression] !PredefinedSymbols !*Heaps -> (!Expression, !*Heaps)
	build_prod [] predefs heaps = buildUNIT 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
		= buildPAIR lexpr rexpr predefs heaps

// convert from generic representation to type
buildIsoFrom :: !DefinedSymbol !Int !Int !CheckedTypeDef !*GenericState
	-> (!FunDef, !*GenericState)
buildIsoFrom 
		def_sym group_index type_def_mod 
		type_def=:{td_rhs, td_name, td_index, td_pos} 
		gs=:{gs_predefs, gs_heaps, gs_error}
	#! (body_expr, free_vars, gs_heaps, gs_error) = build_body type_def_mod td_rhs gs_predefs gs_heaps gs_error
	| not gs_error.ea_ok
		#! fun_def = makeFunction {def_sym&ds_arity=0} NoIndex [] EE No [] [] td_pos
		= (fun_def, {gs & gs_heaps = gs_heaps, gs_error = gs_error} )
	#! fun_def = makeFunction def_sym group_index [hd free_vars] body_expr No (tl free_vars) []	td_pos
	= (fun_def, {gs & gs_heaps = gs_heaps, gs_error = gs_error} )
		//---> fun_def
where	
	build_body :: !Int !TypeRhs !PredefinedSymbols !*Heaps !*ErrorAdmin
		-> (!Expression, ![FreeVar], !*Heaps, !*ErrorAdmin)
 	build_body type_def_mod (AlgType def_symbols) predefs heaps error
		= build_sum type_def_mod def_symbols predefs heaps error
	build_body type_def_mod (RecordType {rt_constructor}) predefs heaps error				
		= build_sum type_def_mod [rt_constructor] predefs heaps	error
	build_body type_def_mod (AbstractType _) predefs heaps error
		#! error = checkErrorWithIdentPos (newPosition td_name td_pos) "cannot build isomorphisms for an abstract type" error
		= (EE, [], heaps, error)
	build_body type_def_mod (SynType _) predefs heaps error
		#! error = checkErrorWithIdentPos (newPosition td_name td_pos) "cannot build isomorphisms for a synonym type" error
		= (EE, [], heaps, error)

	build_sum :: !Index [DefinedSymbol] !PredefinedSymbols !*Heaps !*ErrorAdmin
		-> (!Expression, ![FreeVar], !*Heaps, !*ErrorAdmin)
	build_sum type_def_mod [] predefs heaps error
		= abort "algebraic type with no constructors!\n"
	build_sum type_def_mod [def_symbol] predefs heaps error
		# (cons_app_expr, cons_args, heaps) = build_cons_app type_def_mod def_symbol heaps
		# (alt_expr, free_vars, heaps) = build_prod cons_app_expr cons_args predefs heaps 		
		=	case supportCons of
			True
				# (var_expr, var, heaps) = buildVarExpr "c" heaps
				# (info_var, heaps) = buildFreeVar0 "i" heaps
				# (alt_expr, heaps) = buildCaseCONSExpr var_expr info_var (hd free_vars) alt_expr predefs heaps   
				-> (alt_expr, [var, info_var : free_vars], heaps, error)										
			False
				-> (alt_expr, free_vars, heaps, error)
				
	build_sum type_def_mod def_symbols predefs heaps error
		# (var_expr, var, heaps) = buildVarExpr "e" heaps
		# (left_def_syms, right_def_syms) = splitAt ((length def_symbols) /2) def_symbols
	
		# (left_expr, left_vars, heaps, error) = build_sum type_def_mod left_def_syms predefs heaps error
		# (right_expr, right_vars, heaps, error) = build_sum type_def_mod right_def_syms predefs heaps error
	
		# (case_expr, heaps) = 
			buildCaseEITHERExpr var_expr (hd left_vars, left_expr) (hd right_vars, right_expr) predefs heaps
		# vars = [var : left_vars ++ right_vars]
		= (case_expr, vars, heaps, error)
		
	build_prod :: !Expression ![FreeVar] !PredefinedSymbols !*Heaps
		-> (!Expression, ![FreeVar], !*Heaps)
	build_prod expr [] predefs heaps
		# (var_expr, var, heaps) = buildVarExpr "x" heaps 
		# (case_expr, heaps) = buildCaseUNITExpr var_expr expr predefs heaps	
		= (case_expr, [var], heaps)
	build_prod expr [cons_arg_var] predefs heaps
		= (expr, [cons_arg_var], heaps)	
	build_prod expr cons_arg_vars predefs heaps
		# (var_expr, var, heaps) = buildVarExpr "p" heaps
		# (left_vars, right_vars) = splitAt ((length cons_arg_vars) /2) cons_arg_vars
		 
		# (expr, left_vars, heaps) = build_prod expr left_vars predefs heaps
		# (expr, right_vars, heaps) = build_prod expr right_vars predefs heaps
		
		# (case_expr, heaps) = buildCasePAIRExpr var_expr (hd left_vars) (hd right_vars) expr predefs heaps
		
		# vars = [var : left_vars ++ right_vars]	
		= (case_expr, vars, heaps) 
	
	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) 

buildIsomapFromTo :: !IsoDirection !DefinedSymbol !Int !Int !Int !*GenericState
	-> (!FunDef, !*GenericState)
buildIsomapFromTo 
		iso_dir def_sym group_index type_def_mod type_def_index 
		gs=:{gs_heaps, gs_modules}
	# (type_def=:{td_name, td_index, td_arity, td_pos}, gs_modules) 
		= getTypeDef type_def_mod type_def_index gs_modules
	# arg_names = [ "isomap" +++ toString n \\ n <- [1 .. td_arity]]
	# (isomap_arg_vars, gs_heaps) = buildFreeVars arg_names gs_heaps 
	# (arg_expr, arg_var, gs_heaps) = buildVarExpr "x" gs_heaps
	# gs = {gs & gs_heaps = gs_heaps, gs_modules = gs_modules}
	# (body_expr, free_vars, gs) = 
		build_body iso_dir type_def_mod td_index type_def arg_expr isomap_arg_vars gs	

	# (fun_type, gs) = build_type iso_dir type_def_mod type_def_index gs
	# fun_def = makeFunction def_sym group_index (isomap_arg_vars ++ [arg_var]) body_expr (Yes fun_type) free_vars [] td_pos	
	= (fun_def, gs)
where
	build_body :: !IsoDirection !Int !Int !CheckedTypeDef !Expression ![FreeVar] !*GenericState
		-> (Expression, [FreeVar], !*GenericState)
	build_body iso_dir type_def_mod type_def_index type_def=:{td_rhs=(AlgType def_symbols)} arg_expr isomap_arg_vars gs
		= build_body1 iso_dir type_def_mod type_def_index type_def def_symbols arg_expr isomap_arg_vars gs
		
	build_body iso_dir type_def_mod type_def_index type_def=:{td_rhs=(RecordType {rt_constructor})} arg_expr isomap_arg_vars gs
		= build_body1 iso_dir type_def_mod type_def_index type_def [rt_constructor] arg_expr isomap_arg_vars gs
	
	build_body 
			iso_dir type_def_mod type_def_index 
			type_def=:{td_rhs=(AbstractType _),td_name, td_pos} arg_expr isomap_arg_vars gs=:{gs_error}
		# gs_error = checkErrorWithIdentPos
				(newPosition td_name td_pos) 
				"cannot build map function for an abstract type" 
				gs_error
		= (EE, [], {gs & gs_error = gs_error})

	build_body 
			iso_dir type_def_mod type_def_index 
			type_def=:{td_rhs=(SynType _), td_name, td_pos} arg_expr isomap_arg_vars gs=:{gs_error}
		# gs_error = checkErrorWithIdentPos
				(newPosition td_name td_pos) 
				"cannot build map function for a synonym type" 
				gs_error
		= (EE, [], {gs & gs_error = gs_error})

	build_body1 iso_dir type_def_mod type_def_index type_def def_symbols arg_expr isomap_arg_vars gs
		# (case_alts, free_vars, gs=:{gs_heaps}) = 
			build_alts iso_dir 0 (length def_symbols) type_def_mod def_symbols isomap_arg_vars type_def gs
		# case_patterns = AlgebraicPatterns {glob_module = type_def_mod, glob_object = type_def_index} case_alts
		# (case_expr, gs_heaps) = buildCaseExpr arg_expr case_patterns gs_heaps
		= (case_expr, free_vars, {gs & gs_heaps = gs_heaps})

	build_alts :: !IsoDirection !Int !Int !Int ![DefinedSymbol] ![FreeVar] !CheckedTypeDef !*GenericState 
		-> ([AlgebraicPattern], [FreeVar], !*GenericState)
	build_alts iso_dir i n type_def_mod [] arg_vars type_def gs 
		= ([], [], gs) 
	build_alts iso_dir i n type_def_mod [def_symbol:def_symbols] arg_vars type_def gs
		# (alt, fvs, gs) = build_alt iso_dir i n type_def_mod def_symbol arg_vars type_def gs
		# (alts, free_vars, gs) = build_alts iso_dir (i+1) n type_def_mod def_symbols arg_vars type_def gs 		
		= ([alt:alts], fvs ++ free_vars, gs)

	build_alt :: !IsoDirection !Int !Int !Int !DefinedSymbol ![FreeVar] !CheckedTypeDef !*GenericState 
		-> (AlgebraicPattern, [FreeVar], !*GenericState)
	build_alt 
			iso_dir i n type_def_mod def_symbol=:{ds_ident, ds_arity, ds_index} 
			fun_arg_vars type_def gs=:{gs_heaps, gs_modules}		
		# names = ["x" +++ toString (i+1) +++ toString k \\ k <- [1..ds_arity]]
		# (cons_arg_vars, gs_heaps) = buildFreeVars names gs_heaps
		# (cons_def=:{cons_type}, gs_modules) = getConsDef type_def_mod ds_index gs_modules 				
		# gs = {gs & gs_heaps = gs_heaps, gs_modules = gs_modules}
		
		# (cons_arg_exprs, gs=:{gs_heaps}) = 
			build_cons_args iso_dir cons_type.st_args cons_arg_vars fun_arg_vars type_def gs 
		# (expr, gs_heaps) = buildConsApp type_def_mod def_symbol cons_arg_exprs gs_heaps				
		# alg_pattern = {
			ap_symbol = {glob_module = type_def_mod, glob_object = def_symbol},
			ap_vars = cons_arg_vars,
			ap_expr = expr,
			ap_position = NoPos
			}
		= (alg_pattern, cons_arg_vars, {gs & gs_heaps = gs_heaps})
	
	build_cons_args :: !IsoDirection ![AType] ![FreeVar] ![FreeVar] !CheckedTypeDef !*GenericState 
		-> ([!Expression], !*GenericState)
	build_cons_args iso_dir [] [] fun_arg_vars type_def gs = ([], gs) 	
	build_cons_args	iso_dir [arg_type:arg_types] [cons_arg_var:cons_arg_vars] fun_arg_vars type_def gs
		# (arg_expr, gs) = build_cons_arg iso_dir arg_type cons_arg_var fun_arg_vars type_def gs
		# (arg_exprs, gs) = build_cons_args iso_dir arg_types cons_arg_vars fun_arg_vars type_def gs 
		= ([arg_expr : arg_exprs], gs)
	
	build_cons_arg :: !IsoDirection !AType !FreeVar ![FreeVar] !CheckedTypeDef !*GenericState 
		-> (!Expression, !*GenericState)	
	build_cons_arg iso_dir type cons_arg_var fun_vars type_def gs
		# type_def_args = [atv_variable \\ {atv_variable} <- type_def.td_args]	
		# (iso_expr, gs) = buildIsomapExpr type type_def_args fun_vars gs
		# {gs_heaps, gs_predefs} = gs
		# sel_expr = case iso_dir of 
			IsoTo 	-> buildIsoToSelectionExpr iso_expr gs_predefs  
			IsoFrom -> buildIsoFromSelectionExpr iso_expr gs_predefs  
 		# (cons_var_expr, _, gs_heaps) = buildBoundVarExpr cons_arg_var gs_heaps
		= (sel_expr @ [cons_var_expr], {gs & gs_heaps = gs_heaps})

	build_type :: !IsoDirection !Int !Int !*GenericState
		-> (!SymbolType, !*GenericState)
	build_type 
			iso_dir module_index type_def_index 
			gs=:{gs_heaps, gs_modules, gs_predefs}
	
		#! ({td_arity, td_name}, gs_modules) = getTypeDef module_index type_def_index gs_modules 		
	
		# (tvs1, gs_heaps) = mapSt (\n->build_type_var ("a"+++toString n)) [1..td_arity] gs_heaps 
		# (tvs2, gs_heaps) = mapSt (\n->build_type_var ("b"+++toString n)) [1..td_arity] gs_heaps 
		# (iso_args) = [buildATypeISO t1 t2 gs_predefs \\ t1 <- tvs1 & t2 <- tvs2] 
	
		# type_symb_ident = {
			type_name = td_name,
			type_index = { glob_module = module_index, glob_object = type_def_index },
			type_arity = td_arity,
			type_prop = { 
				tsp_sign = {sc_pos_vect=cAllBitsClear, sc_neg_vect=cAllBitsClear},
				tsp_propagation = cAllBitsClear, 
				tsp_coercible = False
				}
			}
			
		# (av1, gs_heaps) = buildAttrVar "u1" gs_heaps
		# (av2, gs_heaps) = buildAttrVar "u2" gs_heaps							
		# type1 = makeAType (TA type_symb_ident tvs1) (TA_Var av1) 
		# type2 = makeAType (TA type_symb_ident tvs2) (TA_Var av2)
		# (arg_type, res_type) = case iso_dir of
			IsoTo 	-> (type1, type2)
			IsoFrom -> (type2, type1)
			 
		# symbol_type = {
			st_vars = 	
				[tv \\ {at_type=(TV tv)} <- tvs1] ++ 
				[tv \\ {at_type=(TV tv)} <- tvs2],
			st_args = iso_args ++ [arg_type],
			st_arity = td_arity + 1,
			st_result = res_type,
			st_context = [],
			st_attr_vars = 
				[av \\ {at_attribute=(TA_Var av)} <- tvs1] ++ 
				[av \\ {at_attribute=(TA_Var av)} <- tvs2] ++
				[av1, av2],
			st_attr_env = []
			}
		#! gs = {gs & gs_heaps = gs_heaps, gs_modules = gs_modules}
		= (symbol_type, gs)
			//---> ("isomap to/from type", symbol_type)
	
	build_type_var name heaps
		# (av, heaps) = buildAttrVar name heaps 
		# (tv, heaps) = buildTypeVar name heaps
		= (makeAType (TV tv) (TA_Var av), heaps)	

buildIsomapForTypeDef :: !DefinedSymbol !Int !Int !CheckedTypeDef !DefinedSymbol !DefinedSymbol !*GenericState
	-> (!FunDef, !*GenericState)
buildIsomapForTypeDef	
		fun_def_sym group_index type_def_mod 
		type_def=:{td_name, td_index, td_arity, td_pos}
		from_fun to_fun 
		gs=:{gs_main_dcl_module_n, gs_heaps, gs_predefs}	 
	# arg_names = [ "iso" +++ toString n \\ n <- [1 .. td_arity]]  
	# (arg_exprs, arg_vars, gs_heaps) = buildVarExprs arg_names gs_heaps
		
	# (from_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n from_fun arg_exprs gs_heaps
	# (to_expr, gs_heaps) 	= buildFunApp gs_main_dcl_module_n to_fun arg_exprs gs_heaps	
	# (iso_expr, gs_heaps) 	= buildISO to_expr from_expr gs_predefs gs_heaps
	# fun_def = makeFunction fun_def_sym group_index arg_vars iso_expr No [] [from_fun.ds_index, to_fun.ds_index] td_pos					
	= (fun_def, {gs & gs_heaps = gs_heaps})

buildIsomapForGeneric :: !DefinedSymbol !Int !GenericDef !*GenericState
	-> (!FunDef, !*GenericState)
buildIsomapForGeneric def_sym group_index {gen_type, gen_pos} gs=:{gs_heaps}
	#! arg_names = [ "iso" +++ toString n \\ n <- [1 .. gen_type.gt_arity]]
	#! (arg_vars, gs_heaps) = buildFreeVars arg_names gs_heaps
	#! curried_gt_type = curry_symbol_type gen_type.gt_type
	#! gs = {gs & gs_heaps = gs_heaps }
	#! (body_expr, gs) = buildIsomapExpr curried_gt_type gen_type.gt_vars arg_vars gs 	
	#! fun_def = makeFunction def_sym group_index arg_vars body_expr No [] [] gen_pos					
	= (fun_def, gs) 	
where
	// no uniqueness stuff is needed to build the
	// expression using the type
	curry_symbol_type {st_args, st_result}
		= foldr (\x y -> makeAType (x --> y) TA_Multi) st_result st_args 

// expression that does mapping of a type
buildIsomapExpr :: !AType ![TypeVar] ![FreeVar] !*GenericState
	-> (!Expression, !*GenericState)
buildIsomapExpr {at_type} arg_type_vars arg_vars gs
	= build_expr at_type arg_type_vars arg_vars gs	
where

	build_expr :: !Type ![TypeVar] ![FreeVar] !*GenericState
		-> (!Expression, !*GenericState)		
	build_expr (TA {type_arity=0} _) arg_type_vars arg_vars gs=:{gs_predefs, gs_heaps}
		// isomap for types with no arguments is identity
		# (expr, gs_heaps) = buildIsomapIdApp gs_predefs gs_heaps
		= (expr, {gs & gs_heaps = gs_heaps})

	build_expr (TA {type_index, type_name} args) arg_type_vars arg_vars gs
		# (arg_exprs, gs) = build_exprs args arg_type_vars arg_vars gs
		# {gs_heaps, gs_main_dcl_module_n, gs_gtd_infos} = gs			
		# (gtd_info, gs_gtd_infos) = gs_gtd_infos ! [type_index.glob_module, type_index.glob_object]		
		# gt = case gtd_info of
			(GTDI_Generic gt) -> gt
			_ -> abort ("type " +++ type_name.id_name +++ " does not have generic representation\n")
		# (expr, gs_heaps) = buildFunApp gs_main_dcl_module_n gt.gtr_isomap arg_exprs gs_heaps			
		= (expr, {gs & gs_heaps = gs_heaps, gs_gtd_infos = gs_gtd_infos})
	
	build_expr (arg --> res) arg_type_vars arg_vars gs
		# (arg_expr, gs) = buildIsomapExpr arg arg_type_vars arg_vars gs
		# (res_expr, gs) = buildIsomapExpr res arg_type_vars arg_vars gs				
		# {gs_heaps, gs_main_dcl_module_n, gs_predefs} = gs		
		# (expr, gs_heaps) = buildIsomapArrowApp arg_expr res_expr gs_predefs gs_heaps
		= (expr, {gs & gs_heaps = gs_heaps})

	build_expr ((CV type_var) :@: args) arg_type_vars arg_vars gs
		#! (arg_exprs, gs) = build_exprs args arg_type_vars arg_vars gs
		#! (cons_var_expr, gs) = build_expr_for_type_var type_var arg_type_vars arg_vars gs	
		= (cons_var_expr @ arg_exprs, gs)

	build_expr (TB baric_type) arg_type_vars arg_vars gs=:{gs_predefs, gs_heaps}		
		# (expr, gs_heaps) = buildIsomapIdApp gs_predefs gs_heaps
		= (expr, {gs & gs_heaps = gs_heaps})
						
	build_expr (TV type_var) arg_type_vars arg_vars gs
		= build_expr_for_type_var type_var arg_type_vars arg_vars gs
	build_expr (GTV type_var) arg_type_vars arg_vars gs
		= build_expr_for_type_var type_var arg_type_vars arg_vars gs 
	build_expr (TQV type_var) arg_type_vars arg_vars gs
		= build_expr_for_type_var type_var arg_type_vars arg_vars gs 
	build_expr (TLifted type_var) arg_type_vars arg_vars gs
		= build_expr_for_type_var type_var arg_type_vars arg_vars gs 
	build_expr _ arg_type_vars arg_vars gs
		= abort "type does not match\n"
	
	build_exprs [] arg_type_vars arg_vars gs 
		= ([], gs)
	build_exprs [type:types] arg_type_vars arg_vars gs
		# (expr, gs) = buildIsomapExpr type arg_type_vars arg_vars gs
		# (exprs, gs) = build_exprs types arg_type_vars arg_vars gs
		= ([expr:exprs], gs)
			 			
	build_expr_for_type_var type_var arg_type_vars arg_vars gs=:{gs_predefs, gs_heaps}
		# (var_expr, gs_heaps) = buildExprForTypeVar type_var arg_type_vars arg_vars gs_predefs gs_heaps 
		= (var_expr, {gs & gs_heaps = gs_heaps})
	
buildInstance :: !DefinedSymbol !Int !ClassInstance !GenericDef !*GenericState
	-> (!FunDef, !*GenericState)
buildInstance 
		def_sym group_index 
		instance_def=:{ins_type, ins_generic, ins_pos, ins_ident} 
		generic_def=:{gen_name, gen_type, gen_isomap} 
		gs=:{gs_heaps}	

	#! original_arity 	= gen_type.gt_type.st_arity
	#! generated_arity 	= def_sym.ds_arity - original_arity // arity of kind
	
	#! generated_arg_names = [ "f" +++ toString n \\ n <- [1 .. generated_arity]]
	#! (generated_arg_vars, gs_heaps) = buildFreeVars generated_arg_names gs_heaps	
	#! original_arg_names = 	[ "x" +++ toString n \\ n <- [1 .. original_arity]]  
	#! (original_arg_exprs, original_arg_vars, gs_heaps) = buildVarExprs original_arg_names gs_heaps	
	#! arg_vars = generated_arg_vars ++ original_arg_vars
	
	#! (gt=:{gtr_type, gtr_type_args, gtr_cons_infos}, gs) = get_generic_type ins_type {gs & gs_heaps = gs_heaps } 		
	#! gen_glob_def_sym = {
		glob_module = ins_generic.glob_module,
		glob_object = {
			ds_ident = gen_name,
			ds_index = ins_generic.glob_object,
			ds_arity = 0
			}
		} 
		
	#! (adaptor_expr, gs)	 = build_adaptor_expr gt gen_isomap gs  
		//---> ("generic type", gtr_type)
		
	#! (instance_expr, cons_infos, gs)	 = build_instance_expr gtr_type gtr_cons_infos gtr_type_args generated_arg_vars gen_glob_def_sym gs 
		//---> ("build_instance_expr", gtr_type_args, generated_arg_vars)		
		
	| supportConsInfo && (not (isEmpty cons_infos))
		= abort "not all cons infos consumed"	
		
	#! body_expr = if (isEmpty original_arg_exprs)
		(adaptor_expr @ [instance_expr]) 
		((adaptor_expr @ [instance_expr]) @ original_arg_exprs)

	#! fun_def = makeFunction def_sym group_index arg_vars body_expr No [] [] ins_pos					
	= (fun_def, gs) 	
where
	get_generic_type :: !InstanceType !*GenericState 
		-> (GenericTypeRep, !*GenericState)
	get_generic_type ins_type gs=:{gs_modules, gs_gtd_infos, gs_error}
		# instance_type = hd ins_type.it_types
		# {type_index} = case instance_type of 
			TA type_symb_ident _ 	-> type_symb_ident
			_ 						-> abort ("instance type is not a type application") 
				---> instance_type
		# (gtd_info, gs_gtd_infos) = gs_gtd_infos ! [type_index.glob_module, type_index.glob_object]
		//# (type_def, gs_modules) = getTypeDef type_index.glob_module type_index.glob_object gs_modules
		# (GTDI_Generic gt) = gtd_info 
		= (gt, {gs & gs_gtd_infos = gs_gtd_infos, gs_modules = gs_modules})
	
	build_adaptor_expr {gtr_iso, gtr_type} gen_isomap gs=:{gs_heaps, gs_main_dcl_module_n, gs_predefs}
		// create n iso applications 
		# (iso_exprs, gs_heaps) = build_iso_exprs gen_isomap.ds_arity gtr_iso gs_main_dcl_module_n gs_heaps		
		# (isomap_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n gen_isomap iso_exprs gs_heaps
		# sel_expr = buildIsoFromSelectionExpr isomap_expr gs_predefs 
		= (sel_expr, {gs & gs_heaps = gs_heaps})
		
	build_iso_exprs n iso gs_main_dcl_module_n gs_heaps
		| n == 0 = ([], gs_heaps)
		# (expr, gs_heaps) = buildFunApp gs_main_dcl_module_n iso [] gs_heaps	
		# (exprs, gs_heaps) = build_iso_exprs (n - 1) iso gs_main_dcl_module_n gs_heaps	
		= ([expr:exprs], gs_heaps)
	
	// e.g. for eq on lists: 
	// 		eqEITHER eqUNIT (eqPAIR eqElt (eqList eqElt))
	// with cons info:
	// 		eqEITHER 
	//			(eqCONS info_Nil eqUNIT) 
	//			(eqCONS info_Cons (eqPAIR eqElt (eqList eqElt)))
	build_instance_expr :: !AType ![DefinedSymbol] ![TypeVar] ![FreeVar] !(Global DefinedSymbol) !*GenericState 
		-> (Expression, ![DefinedSymbol], !*GenericState)
	build_instance_expr {at_type} cons_infos type_vars vars gen_sym gs 
		= build_instance_expr1 at_type cons_infos type_vars vars gen_sym gs
	
	build_instance_expr1 (TA {type_name, type_index, type_arity} type_args) cons_infos type_vars vars gen_sym gs	
		# (arg_exprs, cons_infos, gs=:{gs_heaps}) = build_args type_args cons_infos gs
			with
				build_args [] cons_infos gs = ([], cons_infos, gs)
				build_args [t:ts] cons_infos gs  
					# (e, cons_infos, gs) = build_instance_expr t cons_infos type_vars vars gen_sym gs
					# (es, cons_infos, gs) = build_args ts cons_infos gs
					= ([e:es], cons_infos, gs)
		
		# (is_cons, gs) = is_cons_instance type_index gs
		| supportConsInfo && is_cons 
			= build_cons_fun_app gen_sym arg_exprs cons_infos gs			

		| otherwise 	
			# (kind, gs) = get_kind_of_type_def type_index gs
			= build_generic_app gen_sym kind arg_exprs cons_infos gs		
			
	build_instance_expr1 (arg_type --> res_type) cons_infos  type_vars vars gen_sym gs=:{gs_error}	
		# gs_error = checkErrorWithIdentPos (newPosition ins_ident ins_pos) "arrow types are not yet supported" gs_error
		= (EE, cons_infos, {gs & gs_error = gs_error})
	build_instance_expr1 (type_cons_var :@: type_args) cons_infos  type_vars vars gen_sym gs=:{gs_error}	
		# gs_error = checkErrorWithIdentPos (newPosition ins_ident ins_pos) "application of type constructor variable is not supported" gs_error
		= (EE, cons_infos, {gs & gs_error = gs_error})				
	build_instance_expr1 (TB basic_type) cons_infos  type_vars vars gen_sym gs 	
		= build_generic_app gen_sym KindConst [] cons_infos gs
	build_instance_expr1 (TV type_var) cons_infos  type_vars vars gen_sym gs 
		= build_expr_for_type_var type_var type_vars vars cons_infos gs 
	build_instance_expr1 (GTV type_var) cons_infos  type_vars vars gen_sym gs 
		= build_expr_for_type_var type_var type_vars vars cons_infos gs 
	build_instance_expr1 (TQV type_var) cons_infos  type_vars vars gen_sym gs 
		= build_expr_for_type_var type_var type_vars vars cons_infos gs 
	build_instance_expr1 _ _ _ _ _ gs
		= abort "build_instance_expr1: type does not match\n" 
			
	build_expr_for_type_var type_var type_vars vars cons_infos gs=:{gs_predefs, gs_heaps}
		# (var_expr, gs_heaps) = buildExprForTypeVar type_var type_vars vars gs_predefs gs_heaps 
		= (var_expr, cons_infos, {gs & gs_heaps = gs_heaps})
		
	build_generic_app {glob_module, glob_object} kind arg_exprs cons_infos gs=:{gs_heaps}
		# (expr, gs_heaps) = buildGenericApp glob_module glob_object kind arg_exprs gs_heaps
		= (expr, cons_infos, {gs & gs_heaps = gs_heaps})	

	get_kind_of_type_def {glob_module, glob_object} gs=:{gs_td_infos}
		# (td_info, gs_td_infos) = gs_td_infos ! [glob_module, glob_object]
		= (make_kind td_info.tdi_kinds, {gs & gs_td_infos = gs_td_infos})
	where	
		make_kind [] = KindConst
		make_kind ks = KindArrow (ks ++ [KindConst])

	is_cons_instance {glob_module, glob_object} gs=:{gs_predefs}
		# {pds_def, pds_module} = gs_predefs.[PD_TypeCONS]
		= (pds_module == glob_module && pds_def == glob_object, gs)

	build_cons_fun_app 
			gen=:{glob_module, glob_object} 
			arg_exprs
			[cons_info:cons_infos]
			gs=:{	gs_heaps=gs_heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}},
					gs_main_dcl_module_n,
					gs_modules,  
					gs_error}

		#! (generic_def=:{gen_name, gen_pos, gen_cons_ptr}, gs_modules) 
			= getGenericDef glob_module glob_object.ds_index gs_modules 	
		#! (info, th_vars) = readPtr gen_cons_ptr th_vars			
		#! gs_heaps = { gs_heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars }}	
		
		# (cons_info_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n cons_info [] gs_heaps 	

		#! (fun_def_sym, gs_error) = case info of		
			TVI_ConsInstance fun_def_sym
				-> (fun_def_sym, gs_error)				
			TVI_Empty
				-> (EmptyDefinedSymbol, reportError gen_name gen_pos "no CONS instance provided" gs_error)
		
		#! (app_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n fun_def_sym [cons_info_expr:arg_exprs] gs_heaps 								
		= (app_expr, cons_infos, {gs & gs_heaps = gs_heaps, gs_modules = gs_modules, gs_error = gs_error})
			//---> ("build_cons_app", cons_info.ds_ident, fun_def_sym.ds_ident) 
			 			
buildExprForTypeVar :: TypeVar [TypeVar] [FreeVar] !PredefinedSymbols !*Heaps 
	-> (!Expression, !*Heaps)
buildExprForTypeVar type_var type_vars vars predefs heaps 
	| length type_vars <> length vars 
		= abort "buildExprForTypeVar: inconsistent arguments\n"
	# tv_info_ptrs = {tv_info_ptr \\ {tv_info_ptr} <- type_vars}
	# index = find_in_array 0 tv_info_ptrs type_var.tv_info_ptr
	| index == (-1)		
		= buildIsomapIdApp predefs heaps
		# (expr, var, heaps) = buildBoundVarExpr (vars !! index) heaps
		= (expr, heaps)

where
	find_in_array :: !Int !{#TypeVarInfoPtr} !TypeVarInfoPtr -> !Int 
	find_in_array index array el 
		| index == size array  	= -1 	
		| array.[index] == el 	= index
								= find_in_array (inc index) array el	


buildKindConstInstance :: !DefinedSymbol !Int !Index !DefinedSymbol !TypeKind !GenericState
	-> (!FunDef, !*GenericState)
buildKindConstInstance 
		def_sym group_index 
		generic_module generic_def_sym kind=:(KindArrow kinds) 
		gs=:{gs_heaps}
	#! arg_names = ["x" +++ toString i \\ i <- [1 .. def_sym.ds_arity]]
	#! (arg_exprs, arg_vars, gs_heaps) = buildVarExprs arg_names gs_heaps
	
	# (gen_exprs, gs_heaps) = mapSt build_gen_expr [1 .. (length kinds) - 1] gs_heaps
	  
	#! (body_expr, gs_heaps) = buildGenericApp generic_module generic_def_sym kind (gen_exprs ++ arg_exprs) gs_heaps
	#! fun_def = makeFunction def_sym group_index arg_vars body_expr No [] [] NoPos					
	= (fun_def, {gs & gs_heaps = gs_heaps})	
where
	build_gen_expr _ heaps
		= buildGenericApp generic_module generic_def_sym KindConst [] heaps
										
//===========================================
// access to common definitions
//===========================================

  	
getTypeDef :: !Index  !Index !u:{#CommonDefs} -> (!CheckedTypeDef, !u:{#CommonDefs})
getTypeDef mod_index type_index modules
	# (common_defs=:{com_type_defs}, modules) = modules![mod_index]
	# type_def = com_type_defs.[type_index]
	= (type_def, modules)

getConsDef :: !Index  !Index !u:{#CommonDefs} -> (!ConsDef, !u:{#CommonDefs})
getConsDef mod_index type_index modules
	# (common_defs=:{com_cons_defs}, modules) = modules![mod_index]
	# cons_def = com_cons_defs.[type_index]
	= (cons_def, modules)

getSelectorDef :: !Index  !Index !u:{#CommonDefs} -> (!SelectorDef, !u:{#CommonDefs})
getSelectorDef mod_index type_index modules
	# (common_defs=:{com_selector_defs}, modules) = modules![mod_index]
	# sel_def = com_selector_defs.[type_index]
	= (sel_def, modules)


getInstanceDef :: !Index !Index !u:{#CommonDefs} -> (!ClassInstance, !u:{#CommonDefs})
getInstanceDef mod_index ins_index modules
	# (common_defs=:{com_instance_defs}, modules) = modules![mod_index]
	# instance_def = com_instance_defs.[ins_index]
	= (instance_def, modules)
		 			
getGenericDef :: !Index !Index !u:{#CommonDefs} -> (!GenericDef, !u:{#CommonDefs})
getGenericDef module_index generic_index modules
	# (common_defs=:{com_generic_defs}, modules) = modules![module_index]
	# generic_def = com_generic_defs.[generic_index]
	= (generic_def, modules)

getClassDef :: !Index !Index !u:{#CommonDefs} -> (!ClassDef, !u:{#CommonDefs})
getClassDef module_index class_index modules
	#! (common_defs=:{com_class_defs}, modules) = modules![module_index]
	#! class_def = com_class_defs.[class_index]
	= (class_def, modules)

getMemberDef :: !Index !Index !u:{#CommonDefs} -> (!MemberDef, !u:{#CommonDefs})
getMemberDef module_index member_index modules
	# (common_defs=:{com_member_defs}, modules) = modules![module_index]
	# member_def = com_member_defs.[member_index]
	= (member_def, modules)
	
getGenericMember :: !(Global Index) !TypeKind !{#CommonDefs} -> (Bool, Global Index)
getGenericMember {glob_module, glob_object} kind modules
	# (generic_def, modules) = getGenericDef glob_module glob_object modules  
	# (ok, def_sym) = getGenericClassForKind generic_def kind
	| not ok = (False, undef)		
	# (class_def, modules) = getClassDef glob_module def_sym.ds_index modules
	# {ds_index} = class_def.class_members.[0]
	= (True, {glob_module = glob_module, glob_object = ds_index})

			
//===================================
// Types 
//===================================

makeAType :: !Type !TypeAttribute -> !AType
makeAType type attr = 
	{	at_attribute = attr
	, 	at_annotation = AN_None
	, 	at_type = type
	}

buildTypeVar name heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}
	# (tv, th_vars) = freshTypeVar {id_name=name,id_info=nilPtr} th_vars
	= (	tv, {heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars}})

buildAttrVar name heaps=:{hp_type_heaps=hp_type_heaps=:{th_attrs}}
	# (av, th_attrs) = freshAttrVar {id_name=name,id_info=nilPtr} th_attrs
	= (	av, {heaps & hp_type_heaps = {hp_type_heaps & th_attrs = th_attrs}})

freshTypeVar :: !Ident  !*TypeVarHeap -> (!TypeVar, !*TypeVarHeap) 
freshTypeVar name th_vars 
	# (info_ptr, th_vars) = newPtr TVI_Empty th_vars
	= ({tv_name = name, tv_info_ptr = info_ptr}, th_vars)

freshAttrVar :: !Ident !*AttrVarHeap -> (!AttributeVar, !*AttrVarHeap)
freshAttrVar name th_attrs
	# (info_ptr, th_attrs) = newPtr AVI_Empty th_attrs
	= ({av_name = name, av_info_ptr = info_ptr}, th_attrs)


freshSymbolType :: String !SymbolType !*TypeHeaps -> (!SymbolType, !*TypeHeaps) 
freshSymbolType postfix st type_heaps
	# {st_vars, st_args, st_result, st_context, st_attr_vars, st_attr_env} = st
	# (new_st_vars, type_heaps) = subst_type_vars postfix st_vars type_heaps
	# (new_st_attr_vars, type_heaps) = subst_attr_vars postfix st_attr_vars type_heaps

	# (_, new_st_args, type_heaps) = 		substitute st_args 		type_heaps
	# (_, new_st_result, type_heaps) = 		substitute st_result 	type_heaps
	# (_, new_st_context, type_heaps) = 	substitute st_context 	type_heaps
	# (_, new_st_attr_env, type_heaps) = 	substitute st_attr_env 	type_heaps

	# new_st = { st &	
			st_vars = new_st_vars
		,	st_args = new_st_args
		,	st_result = new_st_result
		,	st_context = new_st_context
		,	st_attr_vars = new_st_attr_vars
		,	st_attr_env = new_st_attr_env 
		}
	= (new_st, type_heaps)

where	 
	subst_type_var postfix tv=:{tv_name={id_name}, tv_info_ptr} th_vars
		# (tv, th_vars) = freshTypeVar {id_name=id_name+++postfix, id_info=nilPtr} th_vars  
		= (tv, writePtr tv_info_ptr (TVI_Type (TV tv)) th_vars)
	subst_type_vars postfix tvs type_heaps=:{th_vars}
		# (tvs, th_vars) = mapSt (subst_type_var postfix) tvs th_vars
		= (tvs, {type_heaps & th_vars = th_vars})
	
	subst_attr_var postfix av=:{av_name={id_name}, av_info_ptr} th_attrs
		# (av, th_attrs) = freshAttrVar {id_name=id_name+++postfix, id_info=nilPtr} th_attrs  
		= (av, writePtr av_info_ptr (AVI_Attr (TA_Var av)) th_attrs)
	subst_attr_vars postfix avs type_heaps=:{th_attrs}
		# (avs, th_attrs) = mapSt (subst_attr_var postfix) avs th_attrs
		= (avs, {type_heaps & th_attrs = th_attrs})

// all variables are taken afresh
freshGenericType :: !GenericType !*TypeHeaps
	-> (!GenericType, !*TypeHeaps)
freshGenericType gen_type=:{gt_type, gt_vars, gt_arity} type_heaps
	// set variables that have to be taken fresh, i.e. 
	// both generic variables and non-variables
	# {st_vars} = gt_type	
	# symbol_type = { gt_type & st_vars = gt_vars ++ st_vars } 
	# (fresh_symbol_type, type_heaps) = freshSymbolType "" symbol_type type_heaps
		
	// split fresh variables into generic and non-generic variables
	# (fresh_gt_vars, st_vars) = splitAt gt_arity fresh_symbol_type.st_vars
	# fresh_gen_type = { gen_type & 
		gt_vars = fresh_gt_vars, gt_type = {fresh_symbol_type & st_vars = st_vars}}
	= (fresh_gen_type, type_heaps) 

// Only generic variables are taken afresh
// Non generic variables are supposed to be shared by
// generic subtypes of a type
freshGenericSubtype :: !String !GenericType !*TypeHeaps
	-> (!GenericType, !*TypeHeaps)
freshGenericSubtype postfix gen_type=:{gt_vars, gt_type, gt_arity} type_heaps 
	// set variables that have to be taken afresh, i.e. generic variables
	#! {st_vars} = gt_type
	#! symbol_type = {gt_type & st_vars = gt_vars}

	#! (fresh_symbol_type, type_heaps) = freshSymbolType postfix symbol_type type_heaps
		
	// restore non-generic variables 
	#! fresh_gt_vars = fresh_symbol_type.st_vars
	#! fresh_gen_type = { gen_type & 
		gt_vars = fresh_gt_vars, gt_type = {fresh_symbol_type & st_vars = st_vars}}
	= (fresh_gen_type, type_heaps)


clearAType :: !AType !*TypeHeaps -> !*TypeHeaps 		
clearAType type th=:{th_vars, th_attrs}
	#! th_vars	 = performOnTypeVars initializeToTVI_Empty type th_vars
	#! th_attrs  = performOnAttrVars initializeToAVI_Empty type th_attrs
	= {th & th_vars = th_vars, th_attrs = th_attrs}			

clearSymbolType :: !SymbolType !*TypeHeaps -> !*TypeHeaps
clearSymbolType {st_args, st_result} th
	#! th = foldSt clearAType st_args th
	= clearAType st_result th

substituteInSymbolType :: !SymbolType !*TypeHeaps -> (!SymbolType, !*TypeHeaps)
substituteInSymbolType st=:{st_args, st_result, st_attr_env, st_context} th
	#! (_, st_args, th) 		= substitute st.st_args th
	#! (_, st_result, th) 		= substitute st.st_result th	
	#! (_, st_context, th) 	= substitute st.st_context th	
	#! (_, st_attr_env, th)	= substitute st.st_attr_env th		
	#! st = { st &
		st_args = st_args,
		st_result = st_result,
		st_context = st_context,
		st_attr_env = st_attr_env
		}
	= (st, th)	

// sets ATV_Attribute in all variables
setTypeVarAttrs :: !SymbolType !*TypeHeaps -> !*TypeHeaps
setTypeVarAttrs {st_args, st_result} th=:{th_vars}
	#! th_vars = foldSt set_in_atype st_args th_vars
	#! th_vars = set_in_atype st_result th_vars
	= {th & th_vars = th_vars}
where
	set_in_atype at th_vars
		= performOnTypeVars on_type_var at th_vars
	on_type_var ta tv=:{tv_info_ptr} th_vars
		= writePtr tv_info_ptr (TVI_Attribute ta) th_vars

buildTypeApp :: !Index !CheckedTypeDef [AType] -> AType
buildTypeApp  td_module {td_name, td_arity, td_index} args
	# global_index = {glob_module = td_module, glob_object = td_index}
	# type_symb = MakeTypeSymbIdent global_index td_name (length args) 	
 	= makeAType (TA type_symb args) TA_Multi
		
buildPredefTypeApp :: !Int [AType] !PredefinedSymbols -> !AType
buildPredefTypeApp predef_index args predefs
	# {pds_ident, pds_module, pds_def} = predefs.[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	

buildATypeISO	x y predefs = buildPredefTypeApp PD_TypeISO [x, y] predefs
buildATypeUNIT  predefs		= buildPredefTypeApp PD_TypeUNIT [] predefs
buildATypePAIR x y predefs 	= buildPredefTypeApp PD_TypePAIR [x, y] predefs
buildATypeEITHER x y predefs = buildPredefTypeApp PD_TypeEITHER [x, y] predefs
buildATypeARROW x y predefs = buildPredefTypeApp PD_TypeARROW [x, y] predefs
buildATypeCONS	x predefs 	= buildPredefTypeApp PD_TypeCONS [x] predefs

buildProductType :: ![AType] !PredefinedSymbols -> !AType 
buildProductType [] predefs = buildATypeUNIT predefs
buildProductType [type] predefs = type
buildProductType types predefs
	#  (l,r) = splitAt ((length types) / 2) types
	= buildATypePAIR (buildProductType l predefs) (buildProductType r predefs) predefs

//===================================
// Functions 
//===================================

makeFunction :: !DefinedSymbol !Index ![FreeVar] Expression !(Optional SymbolType) [FreeVar] [Index] Position
	-> FunDef
makeFunction {ds_index, ds_arity, ds_ident} group_index arg_vars body_expr opt_sym_type local_vars fun_call_indexes fun_pos
	| length arg_vars <> ds_arity 
		= abort "length arg_vars <> ds_arity\n"  
	= {
		fun_symb = ds_ident,
		fun_arity = ds_arity,
		fun_priority = NoPrio,
		fun_body = TransformedBody {
			tb_args = arg_vars,
			tb_rhs = body_expr
			},
		fun_type = opt_sym_type,
		fun_pos = fun_pos,
		fun_index = ds_index,
		fun_kind  = FK_ImpFunction cNameNotLocationDependent,
		fun_lifted = 0,
		fun_info = {	
			fi_calls = [{fc_level = NotALevel, fc_index = ind} \\ ind <- fun_call_indexes],	
			fi_group_index = group_index,
			fi_def_level = NotALevel,
			fi_free_vars =  [],
			fi_local_vars = local_vars,
			fi_dynamics = [],
// Sjaak	fi_is_macro_fun = False
			fi_properties = 0
			}	
		}

newGroupIndex gs=:{gs_last_group} = (gs_last_group, {gs & gs_last_group = gs_last_group + 1})
newFunIndex gs=:{gs_last_fun} = (gs_last_fun, {gs & gs_last_fun = gs_last_fun + 1})
newFunAndGroupIndex gs=:{gs_last_fun, gs_last_group} 
	= (gs_last_fun, gs_last_group, {gs & gs_last_fun = gs_last_fun + 1, gs_last_group = gs_last_group + 1})

addFunsAndGroups :: ![FunDef] ![Group] (!*GenericState) -> !*GenericState
addFunsAndGroups new_fun_defs new_groups 
		gs=:{gs_fun_defs, gs_groups, gs_first_fun, gs_last_fun, gs_first_group, gs_last_group}
	# gs_fun_defs = add_funs new_fun_defs gs_fun_defs gs_first_fun gs_last_fun
	# gs_groups = add_groups new_groups gs_groups gs_first_group gs_last_group
	# (gs_groups, gs_fun_defs) = check_groups gs_first_group gs_groups gs_fun_defs
	= {gs & gs_fun_defs = gs_fun_defs, gs_groups = gs_groups}
where
	add_funs new_fun_defs gs_fun_defs gs_first_fun gs_last_fun
		# n_gs_fun_defs = size gs_fun_defs
		# n_new_fun_defs = length new_fun_defs
		| n_new_fun_defs <> gs_last_fun - gs_first_fun
			= abort "error in number of fun_defs" 	
		# fun_defs = createArray (n_new_fun_defs + n_gs_fun_defs) 
			(makeFunction EmptyDefinedSymbol NoIndex [] EE No [] [] NoPos)
		#! fun_defs = { fun_defs & [i] = gs_fun_defs . [i] \\ i <- [0..(n_gs_fun_defs - 1)]}
		#! fun_defs = { fun_defs & [i] = check_fun fun_def i \\ 
			i <- [n_gs_fun_defs .. (n_gs_fun_defs + n_new_fun_defs - 1)] & 
			fun_def <- new_fun_defs }
		= fun_defs
						
	add_groups new_groups gs_groups gs_first_group gs_last_group 
		# n_gs_groups = size gs_groups
		# n_new_groups = length new_groups
		| n_new_groups <> gs_last_group - gs_first_group
			= abort "error in number of groups"
		# groups = createArray (n_gs_groups + n_new_groups) {group_members = []}
		#! groups = { groups & [i] = gs_groups . [i] \\ i <- [0..(n_gs_groups - 1)]}
		#! groups = { groups & [i] = group \\ 
			i <- [n_gs_groups .. (n_gs_groups + n_new_groups - 1)] & 		
			group <- new_groups }
		= groups
	
	check_fun fun_def index
		| fun_def.fun_index == index 
			= fun_def
			= abort ("conflicting fun_indexes of " +++ fun_def.fun_symb.id_name +++
				toString fun_def.fun_index +++ " and " +++ toString index) 
	
	check_groups group_index groups funs 
		| group_index == size groups = (groups, funs)
		# (group, groups) = groups ! [group_index]
			//---> ("check group " +++ toString group_index)
		# funs = check_group group_index group.group_members funs 				
		= check_groups (group_index + 1) groups funs
	
	check_group group_index [] funs = funs
	check_group group_index [fun_index:fun_indexes] funs
		# (fun, funs) = funs ! [fun_index]
		| fun.fun_info.fi_group_index == group_index
			= check_group group_index fun_indexes funs
			= abort ("inconsistent group " +++ toString group_index +++ ": " +++ 
				toString fun_index +++ " and " +++ toString fun.fun_info.fi_group_index)		 		

buildIdFunction :: !DefinedSymbol Int !Ident !PredefinedSymbols !*Heaps-> (!FunDef, !*Heaps)
buildIdFunction def_sym group_index name predefs heaps
	# (arg_expr, arg_var, heaps) = buildVarExpr "x" heaps 
	# fun_def = makeFunction def_sym group_index [arg_var] arg_expr No [] [] NoPos	
	= (fun_def, heaps)
	
buildUndefFunction :: !DefinedSymbol !Int !PredefinedSymbols !*Heaps-> (!FunDef, !*Heaps)
buildUndefFunction def_sym group_index predefs heaps
	# names = [ "x" +++ toString i \\ i <- [1 .. def_sym.ds_arity]]
	# (arg_vars, heaps) = mapSt build_free_var names heaps
	# (body_expr, heaps) = buildUndefFunApp [] predefs heaps
	//# (body_expr, heaps) = buildUNIT predefs heaps
	# fun_def = makeFunction def_sym group_index arg_vars body_expr No [] [] NoPos	
	= (fun_def, heaps)
where
	build_free_var :: !String !*Heaps -> (!FreeVar, !*Heaps)
	build_free_var name heaps=:{hp_var_heap}
		# (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap
		# var_name = { id_name = name, id_info = nilPtr }
		# free_var = { fv_def_level = NotALevel, fv_count = 0, fv_info_ptr = var_info_ptr, fv_name = var_name}
		= (free_var, {heaps & hp_var_heap = hp_var_heap})

//===================================
// Case patterns
//===================================

buildPredefConsPattern :: !Int ![FreeVar] !Expression !PredefinedSymbols
	-> AlgebraicPattern
buildPredefConsPattern predef_index vars expr predefs
	# {pds_ident, pds_module, pds_def} = predefs.[predef_index]
	# cons_def_symbol = {
		ds_ident = pds_ident,
		ds_arity = length vars,
		ds_index = pds_def
		}
	# pattern = {
		ap_symbol = {glob_module = pds_module, glob_object = cons_def_symbol},
		ap_vars = vars,
		ap_expr = expr,
		ap_position = NoPos		
		}
	= pattern

buildUNITPattern expr predefs :== buildPredefConsPattern PD_ConsUNIT [] expr predefs
buildLEFTPattern var expr predefs :== buildPredefConsPattern PD_ConsLEFT [var] expr predefs
buildRIGHTPattern var expr predefs :== buildPredefConsPattern PD_ConsRIGHT [var] expr predefs
buildPAIRPattern var1 var2 expr predefs :== buildPredefConsPattern PD_ConsPAIR [var1, var2] expr predefs
buildCONSPattern cons_info_var cons_arg_var expr predefs :== buildPredefConsPattern PD_ConsCONS [cons_info_var, cons_arg_var] expr predefs

//===================================
// Expressions 
//===================================

buildConsApp :: !Index DefinedSymbol ![Expression] !*Heaps 
	-> (!Expression, !*Heaps) 
buildConsApp cons_mod {ds_ident, ds_index, ds_arity} arg_exprs heaps=:{hp_expression_heap}
	# (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap
	# cons_glob = {glob_module = cons_mod, glob_object = ds_index}
	# expr = App {
		app_symb = {
			symb_name = ds_ident, 
			symb_kind = SK_Constructor cons_glob, 
			symb_arity = ds_arity }, 
		app_args = arg_exprs, 
		app_info_ptr = expr_info_ptr} 	
	# heaps = { heaps & hp_expression_heap = hp_expression_heap } 
	= (expr, heaps)	

buildFunApp :: !Index DefinedSymbol ![Expression] !*Heaps 
	-> (!Expression, !*Heaps) 
buildFunApp fun_mod {ds_ident, ds_index, ds_arity} arg_exprs heaps=:{hp_expression_heap}
	# (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap
	# fun_glob = {glob_module = fun_mod, glob_object = ds_index}
	# expr = App {
		app_symb = {
			symb_name = ds_ident, 
			symb_kind = SK_Function fun_glob, 
			symb_arity = length arg_exprs }, 
		app_args = arg_exprs, 
		app_info_ptr = expr_info_ptr} 	
	# heaps = { heaps & hp_expression_heap = hp_expression_heap } 
	= (expr, heaps)	

buildGenericApp :: !Index !DefinedSymbol !TypeKind ![Expression] !*Heaps
	-> (!Expression, !*Heaps)
buildGenericApp module_index {ds_ident, ds_index} kind arg_exprs heaps=:{hp_expression_heap}
	# (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap
	# glob_index = {glob_module = module_index, glob_object = ds_index}
	# expr = App {
		app_symb = {
			symb_name = ds_ident, 
			symb_kind = SK_Generic glob_index kind, 
			symb_arity = length arg_exprs }, 
		app_args = arg_exprs, 
		app_info_ptr = expr_info_ptr} 	
	# heaps = { heaps & hp_expression_heap = hp_expression_heap } 
	= (expr, heaps)	

buildCaseExpr :: Expression CasePatterns !*Heaps 
	-> (!Expression, !*Heaps)
buildCaseExpr case_arg case_alts heaps=:{hp_expression_heap}	
	# (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap
	# expr = Case {
		case_expr = case_arg,
		case_guards = case_alts,
		case_default = No,
		case_ident = No,
		case_info_ptr = expr_info_ptr,
		case_default_pos = NoPos 
		}
	# heaps = { heaps & hp_expression_heap = hp_expression_heap}	
	= (expr, heaps)

buildCaseUNITExpr :: !Expression !Expression !PredefinedSymbols !*Heaps 
	-> (!Expression, !*Heaps)
buildCaseUNITExpr arg_expr body_expr predefs heaps
	# unit_pat = buildUNITPattern body_expr predefs
	# {pds_module, pds_def} = predefs.[PD_TypeUNIT]
	# case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [unit_pat]
	= buildCaseExpr arg_expr case_patterns heaps

buildCaseEITHERExpr :: !Expression (!FreeVar, !Expression) (!FreeVar, !Expression) !PredefinedSymbols !*Heaps 
	-> (!Expression, !*Heaps)
buildCaseEITHERExpr arg_expr (left_var, left_expr) (right_var, right_expr) predefs heaps
	# left_pat = buildLEFTPattern left_var left_expr predefs
	# right_pat = buildRIGHTPattern 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]
	= buildCaseExpr arg_expr case_patterns heaps

buildCasePAIRExpr :: !Expression !FreeVar !FreeVar !Expression !PredefinedSymbols !*Heaps
	-> (!Expression, !*Heaps)
buildCasePAIRExpr arg_expr var1 var2 body_expr predefs heaps
	# pair_pat = buildPAIRPattern 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]	
	= buildCaseExpr arg_expr case_patterns heaps

buildCaseCONSExpr :: !Expression !FreeVar !FreeVar !Expression !PredefinedSymbols !*Heaps
	-> (!Expression, !*Heaps)
buildCaseCONSExpr arg_expr cons_info_var arg_var body_expr predefs heaps
	# cons_pat = buildCONSPattern cons_info_var arg_var body_expr predefs	
	# {pds_module, pds_def} = predefs.[PD_TypeCONS]
	# case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [cons_pat]	
	= buildCaseExpr arg_expr case_patterns heaps
	


buildPredefConsApp :: !Int [Expression] !PredefinedSymbols !*Heaps
	-> (!Expression, !*Heaps)
buildPredefConsApp predef_index args predefs heaps=:{hp_expression_heap}
	# {pds_ident, pds_module, pds_def} = predefs.[predef_index]
	# global_index = {glob_module = pds_module, glob_object = pds_def}
	# symb_ident = {
		symb_name = pds_ident, 
		symb_kind = SK_Constructor global_index, 
		symb_arity = length args 
		}
	# (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap
	# app = App {app_symb = symb_ident, app_args = args, app_info_ptr = expr_info_ptr} 
	= (app, {heaps & hp_expression_heap = hp_expression_heap})

buildISO to_expr from_expr predefs heaps :== buildPredefConsApp PD_ConsISO [to_expr, from_expr] predefs heaps
buildUNIT predefs heaps		:== buildPredefConsApp PD_ConsUNIT [] predefs heaps
buildPAIR x y predefs heaps	:== buildPredefConsApp PD_ConsPAIR [x, y] predefs heaps
buildLEFT x predefs heaps	:== buildPredefConsApp PD_ConsLEFT [x] predefs heaps
buildRIGHT x predefs heaps	:== buildPredefConsApp PD_ConsRIGHT [x] predefs heaps
buildARROW x y predefs heaps :== buildPredefConsApp PD_ConsARROW [x, y] predefs heaps
buildCONS cons_info arg predefs heaps :== buildPredefConsApp PD_ConsCONS [cons_info, arg] predefs heaps

buildPredefFunApp :: !Int [Expression] !PredefinedSymbols !*Heaps
	-> (!Expression, !*Heaps)
buildPredefFunApp predef_index args predefs heaps=:{hp_expression_heap}
	# {pds_ident, pds_module, pds_def} = predefs.[predef_index]
	# global_index = {glob_module = pds_module, glob_object = pds_def}
	# symb_ident = {
		symb_name = pds_ident, 
		symb_kind = SK_Function global_index, 
		symb_arity = length args 
		}
	# (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap
	# app = App {app_symb = symb_ident, app_args = args, app_info_ptr = expr_info_ptr} 
	= (app, {heaps & hp_expression_heap = hp_expression_heap})

buildUndefFunApp args predefs heaps :== buildPredefFunApp PD_undef args predefs heaps 
buildIsomapArrowApp x y predefs heaps :== buildPredefFunApp PD_isomap_ARROW_ [x,y] predefs heaps
buildIsomapIdApp predefs heaps :== buildPredefFunApp PD_isomap_ID [] predefs heaps
 	
buildIsoToSelectionExpr :: !Expression !PredefinedSymbols -> Expression
buildIsoToSelectionExpr record_expr predefs
	# {pds_module, pds_def, pds_ident} = predefs . [PD_iso_to]
	# selector = { 
		glob_module = pds_module, 
		glob_object = {ds_ident = pds_ident, ds_index = pds_def, ds_arity = 1}}
	= Selection No record_expr [RecordSelection selector 0]

buildIsoFromSelectionExpr :: !Expression !PredefinedSymbols -> Expression
buildIsoFromSelectionExpr record_expr predefs 
	# {pds_module, pds_def, pds_ident} = predefs . [PD_iso_from]
	# selector = { 
		glob_module = pds_module, 
		glob_object = {ds_ident = pds_ident, ds_index = pds_def, ds_arity = 1}}
	= Selection No record_expr [RecordSelection selector 1]

buildVarExpr :: !String !*Heaps	-> (!Expression, !FreeVar, !*Heaps)
buildVarExpr name heaps=:{hp_var_heap, hp_expression_heap} 
	# (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap
	# (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap
	# var_name = { id_name = name, id_info = nilPtr }
	# fv = { fv_def_level = NotALevel, fv_count = 1, fv_info_ptr = var_info_ptr, fv_name = var_name}
	# var = Var {var_name = var_name, var_expr_ptr = expr_info_ptr, var_info_ptr = var_info_ptr } 
	# hp_var_heap = writePtr var_info_ptr (VI_Expression var) hp_var_heap
	# heaps = { heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap } 
	= (var, fv, heaps)

buildVarExprs :: ![String] !*Heaps -> (![Expression], [!FreeVar], !*Heaps)	 		
buildVarExprs [] heaps = ([], [], heaps)
buildVarExprs [name:names] heaps 
	# (expr, var, heaps) = buildVarExpr name heaps
	# (exprs, vars, heaps) = buildVarExprs names heaps 
	= ([expr:exprs], [var:vars], heaps)

buildFreeVar :: !String !*Heaps -> (!FreeVar, !*Heaps)
buildFreeVar name heaps=:{hp_var_heap}
	# (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap
	# var_name = { id_name = name, id_info = nilPtr }
	# var = { fv_def_level = NotALevel, fv_count = 1, fv_info_ptr = var_info_ptr, fv_name = var_name}
	= (var, {heaps & hp_var_heap = hp_var_heap})


buildFreeVar0 :: !String !*Heaps -> (!FreeVar, !*Heaps)
buildFreeVar0 name heaps=:{hp_var_heap}
	# (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap
	# var_name = { id_name = name, id_info = nilPtr }
	# var = { fv_def_level = NotALevel, fv_count = 0, fv_info_ptr = var_info_ptr, fv_name = var_name}
	= (var, {heaps & hp_var_heap = hp_var_heap})

	

buildFreeVars :: ![String] !*Heaps -> (![FreeVar], !*Heaps)
buildFreeVars names heaps = mapSt buildFreeVar names heaps 	

// create expression from a variable  
buildBoundVarExpr :: !FreeVar !*Heaps -> (!Expression, !FreeVar, !*Heaps)
buildBoundVarExpr free_var=:{fv_info_ptr, fv_name, fv_count} heaps=:{hp_expression_heap, hp_var_heap} 
	# (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap
	# expr = Var {var_name = fv_name, var_expr_ptr = expr_info_ptr, var_info_ptr = fv_info_ptr } 
	# hp_var_heap = writePtr fv_info_ptr (VI_Expression expr) hp_var_heap
	# heaps = { heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap } 		
	= (expr, {free_var & fv_count = fv_count + 1}, heaps)

buildBoundVarExprs :: ![FreeVar] !*Heaps -> (![Expression], ![FreeVar], !*Heaps)
buildBoundVarExprs [] heaps = ([], [], heaps)
buildBoundVarExprs [free_var:free_vars] heaps
	# (expr, free_var, heaps) = buildBoundVarExpr free_var heaps
	# (exprs, free_vars, heaps) = buildBoundVarExprs free_vars heaps
	= ([expr:exprs], [free_var:free_vars], heaps)


copyVar :: FreeVar !*Heaps -> (!FreeVar, !*Heaps)
copyVar var heaps=:{hp_var_heap}
	# (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap
	= ({var & fv_info_ptr = var_info_ptr}, {heaps & hp_var_heap = hp_var_heap})
		//---> ("copyVar", var, ptrToInt var_info_ptr)
copyVars vars heaps = mapSt copyVar vars heaps 

setVarInfo var=:{fv_info_ptr} var_info heaps=:{hp_var_heap}
	# hp_var_heap = writePtr fv_info_ptr var_info hp_var_heap
	= {heaps & hp_var_heap = hp_var_heap}
setVarInfos vars var_infos heaps 
	= fold2St setVarInfo vars var_infos heaps
clearVarInfos vars heaps 
	= setVarInfos vars (repeatn (length vars) VI_Empty) heaps

copyExpr :: !Expression !*Heaps -> (!Expression, !*Heaps)
copyExpr expr heaps=:{hp_var_heap, hp_expression_heap}
	#! state = 
		{	us_var_heap	= hp_var_heap
		,	us_symbol_heap	= hp_expression_heap
		,	us_opt_type_heaps = No
		,	us_cleanup_info	= []
		,	us_local_macro_functions = No			
		}
	#! info = 
		{	ui_handle_aci_free_vars	= LeaveThem
		,	ui_convert_module_n = -1
		,	ui_conversion_table = No
		}
	#! (expr, {us_var_heap, us_symbol_heap}) = unfold expr info state
	= (expr, {heaps & hp_var_heap = us_var_heap, hp_expression_heap = us_symbol_heap})
		//---> ("copy Expr")

mapExprSt :: (Expression .st->(Expression, .st)) Expression .st -> (Expression, .st)
mapExprSt f (App app=:{app_args}) st
		# (app_args, st) = mapSt (mapExprSt f) app_args st
		= f (App { app & app_args = app_args }) st
				
mapExprSt f (Let lad=:{let_lazy_binds, let_strict_binds, let_expr}) st
	# (let_lazy_binds, st) = mapSt map_bind let_lazy_binds st
	# (let_strict_binds, st) = mapSt map_bind let_strict_binds st
	# (let_expr, st) = mapExprSt f let_expr st
	# lad =
		{ 	lad 
		& 	let_expr = let_expr
		, 	let_lazy_binds = let_lazy_binds
		, 	let_strict_binds = let_strict_binds
		}
	= f (Let lad) st
where
	map_bind b=:{lb_src} st
		# (lb_src, st) = mapExprSt f lb_src st
		= ({b & lb_src = lb_src}, st)

mapExprSt f (Selection a expr b) st
	# (expr, st) = mapExprSt f expr st
	= f (Selection a expr b) st
	
mapExprSt f (Update e1 x e2) st
	# (e1, st) = mapExprSt f e1 st
	# (e2, st) = mapExprSt f e2 st
	= f (Update e1 x e2) st

mapExprSt f (RecordUpdate x expr binds) st
	# (expr, st) = mapExprSt f expr st
	# (binds, st) = mapSt map_bind binds st
	= f (RecordUpdate x expr binds) st
where
	map_bind b=:{bind_src} st
		# (bind_dst, st) = mapExprSt f bind_src st
		= ({b & bind_src = bind_src}, st)	

mapExprSt f (TupleSelect x y expr) st
	# (expr, st) = mapExprSt f expr st
	= f (TupleSelect x y expr) st
	
mapExprSt f (Conditional cond=:{if_cond, if_then, if_else}) st
	# (if_cond, st) = mapExprSt f if_cond st
	# (if_then, st) = mapExprSt f if_then st
	# (if_else, st) = case if_else of
		(Yes x) 
			# (x, st) = mapExprSt f x st
			-> (Yes x, st)
		No  -> (No, st)	
	= f (Conditional {cond & if_cond = if_cond, if_then = if_then, if_else = if_else}) st
		
mapExprSt f (MatchExpr x y expr) st
	# (expr, st) = mapExprSt f expr st
	= f (MatchExpr x y expr) st

mapExprSt f (DynamicExpr dyn=:{dyn_expr}) st
	# (dyn_expr, st) = mapExprSt f dyn_expr st
	= f (DynamicExpr {dyn& dyn_expr = dyn_expr}) st 

mapExprSt f (Case c=:{case_expr, case_guards, case_default=case_default}) st
	# (case_expr, st) = mapExprSt f case_expr st
	# (case_guards, st) = map_patterns case_guards st
	# (case_default, st) = case case_default of 
		(Yes x) 
			# (x, st) = mapExprSt f x st
			-> (Yes x, st)
		No  -> (No, st)	
	# new_case = {c & case_expr=case_expr, case_guards=case_guards, case_default=case_default} 
	=  f (Case new_case) st 
where
	map_patterns (AlgebraicPatterns index pats) st
		# (pats, st) = mapSt map_alg_pattern pats st
		= (AlgebraicPatterns index pats, st) 
	map_patterns (BasicPatterns bt pats) st 
		# (pats, st) = mapSt map_basic_pattern pats st
		= (BasicPatterns bt pats, st)
	map_patterns (DynamicPatterns pats) st
		# (pats, st) = mapSt map_dyn_pattern pats st	
		= (DynamicPatterns pats, st) 
		
	map_alg_pattern pat=:{ap_expr} st 
		# (ap_expr, st) = mapExprSt f ap_expr st
		= ({pat & ap_expr = ap_expr}, st) 
	map_basic_pattern pat=:{bp_expr} st 
		# (bp_expr, st) = mapExprSt f bp_expr st
		= ({pat & bp_expr = bp_expr}, st) 
	map_dyn_pattern pat=:{dp_rhs} st 
		# (dp_rhs, st) = mapExprSt f dp_rhs	st
		= ({pat & dp_rhs = dp_rhs}, st) 

mapExprSt f expr st = f expr st		

				 
copyFunDef :: !FunDef !Index !Index !*Heaps -> (!FunDef, !*Heaps)
copyFunDef fun_def=:{fun_symb,fun_arity,fun_body,fun_info} fun_index group_index gs_heaps
	# (TransformedBody {tb_args, tb_rhs}) = fun_body

	#! (fresh_arg_vars, gs_heaps) = copy_vars tb_args gs_heaps			
	#! (copied_rhs, gs_heaps) = copyExpr tb_rhs gs_heaps
	
	#! (copied_rhs, fresh_arg_vars, fresh_local_vars, gs_heaps) = 
		collect_local_vars copied_rhs fresh_arg_vars gs_heaps
		
	#! gs_heaps = clearVarInfos tb_args gs_heaps
				
	#! fun_def = 
		{ 	fun_def
		& 	fun_index = fun_index
		//,	fun_symb = makeIdent "zzzzzzzzzzzz"
		,	fun_body = TransformedBody { tb_args = fresh_arg_vars, tb_rhs = copied_rhs }
		,	fun_info =
			{ 	fun_info
			& 	fi_group_index = group_index
			,	fi_local_vars = fresh_local_vars
			}			
		}
	= (fun_def, gs_heaps)
where
	copy_vars vars heaps
		#! (fresh_vars, heaps) = copyVars vars heaps
		#! infos = [VI_Variable fv_name fv_info_ptr\\ {fv_name,fv_info_ptr} <- fresh_vars]	 
		#! heaps = setVarInfos vars infos heaps
	 	= (fresh_vars, heaps)
	 	
	collect_local_vars body_expr fun_arg_vars heaps=:{hp_var_heap, hp_expression_heap} 	
		#! cs =
	  		{ cos_error = {ea_file = stderr, ea_ok = True, ea_loc=[]}
	  		, cos_var_heap = hp_var_heap
	  		, cos_symbol_heap = hp_expression_heap
	  		, cos_alias_dummy = {pds_ident=makeIdent "dummy", pds_module=NoIndex,pds_def=NoIndex}
// MV ...
			, cos_removed_dynamic_expr = abort "error, please report to Martijn or Artem"
// ... MV
	  		}
		#! (body_expr, fun_arg_vars, local_vars, {cos_symbol_heap, cos_var_heap}) = 
			determineVariablesAndRefCounts fun_arg_vars body_expr cs
		#! heaps = { heaps & hp_var_heap = cos_var_heap, hp_expression_heap = cos_symbol_heap }
		= (body_expr, fun_arg_vars, local_vars, heaps)
	
makeIdent :: String -> Ident
makeIdent str = {id_name = str, id_info = nilPtr} 

makeIntExpr :: Int -> Expression
makeIntExpr value = BasicExpr (BVI (toString value)) BT_Int

makeStringExpr :: String !PredefinedSymbols -> Expression
makeStringExpr str predefs
	#! {pds_ident, pds_module, pds_def} = predefs.[PD_StringType]
	#! type_symb = MakeTypeSymbIdent { glob_module = pds_module, glob_object = pds_def } pds_ident 0
	=  BasicExpr (BVS str) (BT_String (TA type_symb []))

makeListExpr :: [Expression] !PredefinedSymbols !*Heaps -> (Expression, !*Heaps)
makeListExpr [] predefs heaps
	= buildPredefConsApp PD_NilSymbol [] predefs heaps
makeListExpr [expr:exprs] predefs heaps 
	# (list_expr, heaps) = makeListExpr exprs predefs heaps 
	= buildPredefConsApp PD_ConsSymbol [expr, list_expr] predefs heaps

transpose []             = []
transpose [[] : xss]     = transpose xss
transpose [[x:xs] : xss] = 
	[[x : [hd l \\ l <- xss]] : transpose [xs : [ tl l \\  l <- xss]]]
 
reportError name pos msg error
	= checkErrorWithIdentPos (newPosition name pos) msg error