check.icl

implementation module check

import StdEnv

import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef//, RWSDebug
import explicitimports, comparedefimp

cPredefinedModuleIndex 	:== 1

isMainModule :: ModuleKind -> Bool
isMainModule MK_Main	= True
isMainModule _ 			= False

convertIndex :: !Index !Index !(Optional ConversionTable) -> !Index
convertIndex index table_index (Yes tables)
	= tables.[table_index].[index]
convertIndex index table_index No
	= index
	
getPredefinedGlobalSymbol :: !Index !Index !STE_Kind !Int !*CheckState -> (!Global DefinedSymbol, !*CheckState)
getPredefinedGlobalSymbol symb_index module_index req_ste_kind arity cs=:{cs_predef_symbols,cs_symbol_table}
	# (pre_def_mod, cs_predef_symbols)	= cs_predef_symbols![module_index]
	# mod_id							= pre_def_mod.pds_ident
	# (mod_entry, cs_symbol_table)		= readPtr mod_id.id_info cs_symbol_table
	| mod_entry.ste_kind == STE_ClosedModule
		# (glob_object, cs) = get_predefined_symbol symb_index req_ste_kind arity mod_entry.ste_index
										{ cs & cs_predef_symbols = cs_predef_symbols, cs_symbol_table = cs_symbol_table}
		= ({ glob_object = glob_object, glob_module = mod_entry.ste_index }, cs)
		= ({ glob_object = { ds_ident = { id_name = "** ERRONEOUS **", id_info = nilPtr }, ds_index = NoIndex, ds_arity = arity }, glob_module = NoIndex},
				  		{ cs & cs_error = checkError mod_id "not imported" cs.cs_error, cs_predef_symbols = cs_predef_symbols, cs_symbol_table = cs_symbol_table })
where
	get_predefined_symbol :: !Index !STE_Kind !Int !Index !*CheckState -> (!DefinedSymbol,!*CheckState)
	get_predefined_symbol symb_index req_ste_kind arity mod_index cs=:{cs_predef_symbols,cs_symbol_table,cs_error}
		# (pre_def_symb, cs_predef_symbols)	= cs_predef_symbols![symb_index]
		  symb_id							= pre_def_symb.pds_ident
		  (symb_entry, cs_symbol_table) 	= readPtr symb_id.id_info cs_symbol_table
		  cs = { cs & cs_predef_symbols = cs_predef_symbols, cs_symbol_table = cs_symbol_table }
		| symb_entry.ste_kind == req_ste_kind
			= ({ ds_ident = symb_id, ds_index = symb_entry.ste_index, ds_arity = arity }, cs)
			= case symb_entry.ste_kind of
				STE_Imported kind module_index
					| mod_index == module_index && kind == req_ste_kind
						-> ({ ds_ident = symb_id, ds_index = symb_entry.ste_index, ds_arity = arity }, cs)
				_
					-> ({ ds_ident = symb_id, ds_index = NoIndex, ds_arity = arity }, { cs & cs_error = checkError symb_id "undefined" cs.cs_error })
		
checkTypeClasses :: !Index !Index !*{#ClassDef} !*{#MemberDef} !*{#CheckedTypeDef} !*{#DclModule} !*TypeHeaps !*CheckState
	-> (!*{#ClassDef}, !*{#MemberDef}, !*{#CheckedTypeDef}, !*{#DclModule}, !*TypeHeaps, !*CheckState)
checkTypeClasses class_index module_index class_defs member_defs type_defs modules type_heaps=:{th_vars} cs=:{cs_symbol_table,cs_error}
	| class_index == size class_defs
		= (class_defs, member_defs, type_defs, modules, type_heaps, cs)
		# (class_def=:{class_name,class_pos,class_args,class_context,class_members}, class_defs) = class_defs![class_index]
		  position = newPosition class_name class_pos
		  cs_error = setErrorAdmin position cs_error
		  (rev_class_args, cs_symbol_table, th_vars, cs_error)
		  		= add_variables_to_symbol_table cGlobalScope class_args [] cs_symbol_table th_vars cs_error
		  cs = {cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error }
		  (class_context, type_defs, class_defs, modules, type_heaps, cs)
		  		= checkTypeContexts class_context module_index type_defs class_defs modules { type_heaps & th_vars = th_vars } cs
		  (class_args, cs_symbol_table) = retrieve_variables_from_symbol_table rev_class_args [] cs.cs_symbol_table
		  class_defs = { class_defs & [class_index] = { class_def & class_context = class_context, class_args = class_args }}
		  member_defs = set_classes_in_member_defs 0 class_members {glob_object = class_index, glob_module = module_index} member_defs 
		= checkTypeClasses (inc class_index) module_index class_defs member_defs type_defs modules type_heaps { cs & cs_symbol_table = cs_symbol_table }
where
	add_variables_to_symbol_table :: !Level ![TypeVar] ![TypeVar] !*SymbolTable !*TypeVarHeap !*ErrorAdmin
		-> (![TypeVar],!*SymbolTable,!*TypeVarHeap,!*ErrorAdmin)
	add_variables_to_symbol_table level [] rev_class_args symbol_table th_vars error
		= (rev_class_args, symbol_table, th_vars, error)
	add_variables_to_symbol_table level [var=:{tv_name={id_name,id_info}} : vars] rev_class_args symbol_table th_vars error
	  	# (entry, symbol_table) = readPtr id_info symbol_table
		| entry.ste_kind == STE_Empty || entry.ste_def_level < level
			# (new_var_ptr, th_vars) = newPtr TVI_Empty th_vars
			# symbol_table = NewEntry symbol_table id_info (STE_TypeVariable new_var_ptr) NoIndex level entry
			= add_variables_to_symbol_table level vars [{ var & tv_info_ptr = new_var_ptr} : rev_class_args] symbol_table th_vars error
			= add_variables_to_symbol_table level  vars rev_class_args symbol_table th_vars (checkError id_name "(variable) already defined" error)

	retrieve_variables_from_symbol_table :: ![TypeVar] ![TypeVar] !*SymbolTable -> (![TypeVar],!*SymbolTable)
	retrieve_variables_from_symbol_table [var=:{tv_name={id_name,id_info}} : vars] class_args symbol_table
		# (entry, symbol_table) = readPtr id_info symbol_table
		= retrieve_variables_from_symbol_table vars [var : class_args] (symbol_table <:= (id_info,entry.ste_previous))
	retrieve_variables_from_symbol_table [] class_args symbol_table
		= (class_args, symbol_table)
	
	set_classes_in_member_defs mem_offset class_members glob_class_index member_defs
		| mem_offset == size class_members
			= member_defs
			# {ds_index} = class_members.[mem_offset]
			# (member_def, member_defs) = member_defs![ds_index]
			= set_classes_in_member_defs (inc mem_offset) class_members glob_class_index { member_defs & [ds_index] = { member_def & me_class = glob_class_index }}

	
checkSpecial :: !Index !FunType !Index !SpecialSubstitution (!Index, ![FunType], !*Heaps, !*ErrorAdmin)
	-> (!Special, (!Index, ![FunType], !*Heaps, !*ErrorAdmin))
checkSpecial mod_index fun_type=:{ft_type} fun_index subst (next_inst_index, special_types, heaps, error)
	# (special_type, hp_type_heaps) = substitute_type ft_type subst heaps.hp_type_heaps
	  (spec_types, error) = checkAndCollectTypesOfContexts special_type.st_context error
	  ft_type = { special_type & st_context = [] }
	  (new_info_ptr, hp_var_heap) = newPtr VI_Empty heaps.hp_var_heap
	= ( { spec_index = { glob_module = mod_index, glob_object = next_inst_index }, spec_types = spec_types, spec_vars = subst.ss_vars, spec_attrs = subst.ss_attrs },
			((inc next_inst_index), [{ fun_type & ft_type = ft_type, ft_specials = SP_FunIndex fun_index, ft_type_ptr = new_info_ptr} : special_types ],
					{ heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap }, error))
where	
	substitute_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment type_heaps
		# (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, _, type_heaps)
			= instantiateTypes st_vars st_attr_vars [ st_result : st_args ] st_context st_attr_env environment [] type_heaps
		= ({st & st_vars = st_vars, st_args = st_args, st_result = st_result, st_attr_vars = st_attr_vars,
			st_context = st_context, st_attr_env = st_attr_env }, type_heaps)

checkDclFunctions :: !Index !Index ![FunType] !v:{#CheckedTypeDef} !x:{#ClassDef} !v:{#.DclModule} !*Heaps !*CheckState
	-> (!Index, ![FunType], ![FunType], !v:{#CheckedTypeDef}, !x:{#ClassDef}, !v:{#DclModule}, !*Heaps, !*CheckState)
checkDclFunctions module_index first_inst_index fun_types type_defs class_defs modules heaps cs
	= check_dcl_functions module_index fun_types 0 first_inst_index [] [] type_defs class_defs modules heaps cs
where
	check_dcl_functions ::  !Index ![FunType]   !Index  !Index ![FunType] ![FunType] !v:{#CheckedTypeDef} !x:{#ClassDef} !v:{#DclModule} !*Heaps !*CheckState
		 -> (!Index, ![FunType], ![FunType],!v:{#CheckedTypeDef}, !x:{#ClassDef}, !v:{#DclModule}, !*Heaps, !*CheckState)
	check_dcl_functions module_index [] fun_index next_inst_index collected_funtypes collected_instances type_defs class_defs modules heaps cs
		= (next_inst_index, collected_funtypes, collected_instances, type_defs, class_defs, modules, heaps, cs)
	check_dcl_functions module_index [fun_type=:{ft_symb,ft_type,ft_pos,ft_specials} : fun_types] fun_index
			next_inst_index collected_funtypes collected_instances type_defs class_defs modules heaps cs
		# position = newPosition ft_symb ft_pos
		  cs = { cs & cs_error = setErrorAdmin position cs.cs_error }
		  (ft_type, ft_specials, type_defs,  class_defs, modules, hp_type_heaps, cs)
		  		= checkSymbolType module_index ft_type ft_specials type_defs class_defs modules heaps.hp_type_heaps cs
		  (spec_types, next_inst_index, collected_instances, heaps, cs_error)
		  		= check_specials module_index { fun_type & ft_type = ft_type } fun_index ft_specials next_inst_index collected_instances
		  				{ heaps & hp_type_heaps = hp_type_heaps } cs.cs_error
		  (new_info_ptr, hp_var_heap) = newPtr VI_Empty heaps.hp_var_heap
		= check_dcl_functions module_index fun_types (inc fun_index) next_inst_index [
				{ fun_type & ft_type = ft_type, ft_specials = spec_types, ft_type_ptr = new_info_ptr } : collected_funtypes]
					collected_instances type_defs class_defs modules { heaps & hp_var_heap = hp_var_heap } { cs & cs_error = cs_error }

	check_specials :: !Index !FunType !Index !Specials !Index ![FunType] !*Heaps !*ErrorAdmin
		-> (!Specials, !Index, ![FunType], !*Heaps, !*ErrorAdmin)
	check_specials mod_index fun_type fun_index (SP_Substitutions substs) next_inst_index all_instances heaps error
		# (list_of_specials, (next_inst_index, all_instances, heaps, cs_error))
				= mapSt (checkSpecial mod_index fun_type fun_index) substs (next_inst_index, all_instances, heaps, error)
		= (SP_ContextTypes list_of_specials, next_inst_index, all_instances, heaps, cs_error)
	check_specials mod_index fun_type fun_index SP_None next_inst_index all_instances heaps error
		= (SP_None, next_inst_index, all_instances, heaps, error)


checkSpecialsOfInstances :: !Index !Index ![ClassInstance] !Index ![ClassInstance] ![FunType] {# FunType} *{! [Special] } !*Heaps !*ErrorAdmin
		-> (!Index, ![ClassInstance], ![FunType], !*{! [Special]}, !*Heaps, !*ErrorAdmin)
checkSpecialsOfInstances mod_index first_mem_index [class_inst=:{ins_members,ins_specials} : class_insts] next_inst_index all_class_instances all_specials
		new_inst_defs all_spec_types heaps error
	= case ins_specials of
		SP_TypeOffset type_offset
			# (next_inst_index, rev_mem_specials, all_specials, all_spec_types, heaps, error)
				= check_and_build_members mod_index first_mem_index 0 ins_members type_offset next_inst_index [] all_specials new_inst_defs all_spec_types heaps error
			  class_inst = { class_inst & ins_members = { mem \\ mem <- reverse rev_mem_specials } }
			-> checkSpecialsOfInstances mod_index first_mem_index class_insts next_inst_index [class_inst : all_class_instances]
					all_specials new_inst_defs all_spec_types heaps error
		SP_None
			-> checkSpecialsOfInstances mod_index first_mem_index class_insts next_inst_index [class_inst : all_class_instances]
					all_specials new_inst_defs all_spec_types heaps error
where
	check_and_build_members :: !Index !Index !Int {# DefinedSymbol} !Int !Index ![DefinedSymbol] ![FunType] !{#FunType} !*{! [Special]} !*Heaps !*ErrorAdmin
		-> (!Index, ![DefinedSymbol], ![FunType], !*{! [Special]}, !*Heaps, !*ErrorAdmin)
	check_and_build_members mod_index first_mem_index member_offset ins_members type_offset next_inst_index rev_mem_specials all_specials inst_spec_defs
			all_spec_types heaps error
		| member_offset < size ins_members
			# member = ins_members.[member_offset]
			  member_index = member.ds_index
			  spec_member_index = member_index - first_mem_index
		 	# (spec_types, all_spec_types) = all_spec_types![spec_member_index]
		 	# mem_inst = inst_spec_defs.[spec_member_index]
		 	  (SP_Substitutions specials) = mem_inst.ft_specials
		 	  env = specials !! type_offset
			  member = { member & ds_index = next_inst_index }
			  (spec_type, (next_inst_index, all_specials, heaps, error))
			  		= checkSpecial mod_index mem_inst member_index env (next_inst_index, all_specials, heaps, error)
			  all_spec_types = { all_spec_types & [spec_member_index] = [ spec_type : spec_types] }
			= check_and_build_members mod_index first_mem_index (inc member_offset) ins_members type_offset next_inst_index [ member : rev_mem_specials ]
					all_specials inst_spec_defs all_spec_types heaps error
			= (next_inst_index, rev_mem_specials, all_specials, all_spec_types, heaps, error)

checkSpecialsOfInstances mod_index first_mem_index [] next_inst_index all_class_instances all_specials inst_spec_defs all_spec_types heaps error
	= (next_inst_index, all_class_instances, all_specials, all_spec_types, heaps, error)	

checkMemberTypes :: !Index !*{#MemberDef} !*{#CheckedTypeDef} !*{#ClassDef} !*{#DclModule} !*TypeHeaps !*VarHeap !*CheckState
	-> (!*{#MemberDef}, !*{#CheckedTypeDef}, !*{#ClassDef}, !*{#DclModule}, !*TypeHeaps,  !*VarHeap, !*CheckState)
checkMemberTypes module_index member_defs type_defs class_defs modules type_heaps var_heap cs
	#! nr_of_members = size member_defs
	= iFoldSt (check_class_member module_index) 0 nr_of_members (member_defs, type_defs, class_defs, modules, type_heaps, var_heap, cs)
where
	check_class_member module_index member_index (member_defs, type_defs, class_defs, modules, type_heaps, var_heap, cs)
		# (member_def=:{me_symb,me_type,me_pos}, member_defs) = member_defs![member_index]
		  position = newPosition me_symb me_pos
		  cs = { cs & cs_error = setErrorAdmin position cs.cs_error }
		  (me_type, _, type_defs, class_defs, modules, type_heaps, cs)
		   		= checkSymbolType module_index me_type SP_None type_defs class_defs modules type_heaps cs
		  me_class_vars = map (\(TV type_var) -> type_var) (hd me_type.st_context).tc_types
		  (me_type_ptr, var_heap) = newPtr VI_Empty var_heap		   
		= ({ member_defs & [member_index] = { member_def & me_type = me_type, me_class_vars = me_class_vars, me_type_ptr = me_type_ptr }},
				type_defs, class_defs, modules, type_heaps, var_heap, cs)

::	InstanceSymbols =
	{	is_type_defs		:: !.{# CheckedTypeDef}
	,	is_class_defs		:: !.{# ClassDef}
	,	is_member_defs		:: !.{# MemberDef}
	,	is_modules			:: !.{# DclModule}
	}

checkInstanceDefs :: !Index !*{#ClassInstance} !u:{#CheckedTypeDef} !u:{#ClassDef} !u:{#MemberDef} !u:{#DclModule} !*TypeHeaps !*CheckState
	-> (!.{#ClassInstance},!u:{#CheckedTypeDef},!u:{#ClassDef},!u:{#MemberDef},!u:{#DclModule},!.TypeHeaps,!.CheckState)
checkInstanceDefs mod_index instance_defs type_defs class_defs member_defs modules type_heaps cs
	# is = { is_type_defs = type_defs, is_class_defs = class_defs, is_member_defs = member_defs, is_modules = modules }
	  (instance_defs, is, type_heaps, cs) = check_instance_defs 0 mod_index instance_defs is type_heaps cs
	= (instance_defs, is.is_type_defs, is.is_class_defs, is.is_member_defs, is.is_modules, type_heaps, cs)
where	
	check_instance_defs :: !Index !Index !*{# ClassInstance} !u:InstanceSymbols !*TypeHeaps !*CheckState
		-> (!*{# ClassInstance},!u:InstanceSymbols,!*TypeHeaps,!*CheckState)
	check_instance_defs inst_index mod_index instance_defs is type_heaps cs
		| inst_index < size instance_defs
			# (instance_def, instance_defs) = instance_defs![inst_index]
			  (instance_def, is, type_heaps, cs) = check_instance mod_index instance_def is type_heaps cs
			= check_instance_defs (inc inst_index) mod_index { instance_defs & [inst_index] = instance_def } is type_heaps cs
			= (instance_defs, is, type_heaps, cs)

	check_instance :: !Index !ClassInstance !u:InstanceSymbols !*TypeHeaps !*CheckState -> (!ClassInstance, !u:InstanceSymbols, !*TypeHeaps, !*CheckState)
	check_instance module_index
			ins=:{ins_members,ins_class={glob_object = class_name =: {ds_ident = {id_name,id_info},ds_arity}},ins_type,ins_specials,ins_pos,ins_ident}
			is=:{is_class_defs,is_modules} type_heaps cs=:{cs_symbol_table}
		# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
		# (class_index, class_mod_index, class_def, is_class_defs, is_modules) = get_class_def entry module_index is_class_defs is_modules
		  is = { is & is_class_defs = is_class_defs, is_modules = is_modules }
		  cs = pushErrorAdmin (newPosition ins_ident ins_pos) { cs & cs_symbol_table = cs_symbol_table }
		| class_index <> NotFound
			| class_def.class_arity == ds_arity
				# (ins_type, ins_specials, is_type_defs, is_class_defs, is_modules, type_heaps, cs) = checkInstanceType module_index ins_type ins_specials
						is.is_type_defs is.is_class_defs is.is_modules type_heaps cs
				  ins_class = { glob_object = { class_name & ds_index = class_index }, glob_module = class_mod_index}
				  is = { is & is_type_defs = is_type_defs, is_class_defs = is_class_defs, is_modules = is_modules }
				= ({ins & ins_class = ins_class, ins_type = ins_type, ins_specials = ins_specials}, is, type_heaps, popErrorAdmin cs)
				= ( ins
				  , is
				  , type_heaps
				  , popErrorAdmin { cs & cs_error = checkError id_name ("wrong arity: expected "+++toString class_def.class_arity+++" found "+++toString ds_arity) cs.cs_error }
				  )
			= (ins, is, type_heaps, popErrorAdmin { cs & cs_error = checkError id_name "class undefined" cs.cs_error })

	get_class_def :: !SymbolTableEntry !Index v:{# ClassDef} u:{# DclModule} -> (!Index,!Index,ClassDef,!v:{# ClassDef},!u:{# DclModule})
	get_class_def {ste_kind = STE_Class, ste_index} mod_index class_defs modules
		# (class_def, class_defs) = class_defs![ste_index]
		= (ste_index, mod_index, class_def, class_defs, modules)
	get_class_def {ste_kind = STE_Imported STE_Class dcl_index, ste_index, ste_def_level} mod_index  class_defs modules
		# (dcl_mod, modules) = modules![dcl_index]
		# class_def = dcl_mod.dcl_common.com_class_defs.[ste_index]
		= (ste_index, dcl_index, class_def, class_defs, modules)
	get_class_def _ mod_index class_defs modules
		= (NotFound, cIclModIndex, abort "no class definition", class_defs, modules)
	
checkInstances :: !Index !*CommonDefs !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
	-> (![(Index,SymbolType)], !*CommonDefs, !u:{# DclModule}, !*VarHeap , !*TypeHeaps, !*CheckState)
checkInstances mod_index icl_common=:{com_instance_defs,com_class_defs,com_member_defs} modules var_heap type_heaps cs=:{cs_error}
	| cs_error.ea_ok
		# (instance_types, com_instance_defs, com_class_defs, com_member_defs, modules, var_heap, type_heaps, cs)
				= check_instances 0 mod_index [] com_instance_defs com_class_defs com_member_defs modules var_heap type_heaps cs
		= (instance_types, { icl_common & com_instance_defs = com_instance_defs,com_class_defs = com_class_defs,com_member_defs = com_member_defs },
			 	modules, var_heap, type_heaps, cs)
		= ([], icl_common, modules, var_heap, type_heaps, cs)
where
	check_instances :: !Index !Index ![(Index,SymbolType)] !x:{# ClassInstance} !w:{# ClassDef} !v:{# MemberDef} !u:{# DclModule}
		!*VarHeap !*TypeHeaps !*CheckState
			-> (![(Index,SymbolType)], !x:{# ClassInstance}, !w:{# ClassDef}, !v:{# MemberDef}, !u:{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState)
	check_instances inst_index mod_index instance_types instance_defs class_defs member_defs modules var_heap type_heaps cs
		| inst_index < size instance_defs
			# ({ins_class,ins_members,ins_type}, instance_defs) = instance_defs![inst_index]
			# ({class_members,class_name}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules
			  class_size = size class_members
			| class_size == size ins_members
				# (instance_types, member_defs, modules, var_heap, type_heaps, cs) = check_member_instances mod_index ins_class.glob_module
			  	         0 class_size ins_members class_members ins_type instance_types member_defs modules var_heap type_heaps cs
				= check_instances (inc inst_index) mod_index instance_types instance_defs class_defs member_defs modules var_heap type_heaps cs
				= check_instances (inc inst_index) mod_index instance_types instance_defs class_defs member_defs modules var_heap type_heaps
						{ cs & cs_error = checkError class_name "different number of members specified" cs.cs_error }
			= (instance_types, instance_defs, class_defs, member_defs, modules, var_heap, type_heaps, cs)

	check_member_instances :: !Index !Index !Int !Int !{#DefinedSymbol} !{#DefinedSymbol} !InstanceType ![(Index,SymbolType)]
		!v:{# MemberDef} !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
			-> (![(Index,SymbolType)], !v:{# MemberDef}, !u:{# DclModule},!*VarHeap, !*TypeHeaps, !*CheckState)
	check_member_instances module_index member_mod_index mem_offset class_size ins_members class_members
				ins_type instance_types member_defs modules var_heap type_heaps cs
		| mem_offset == class_size
			= (instance_types, member_defs, modules, var_heap, type_heaps, cs)
			# ins_member = ins_members.[mem_offset]
			  class_member = class_members.[mem_offset]
			| ins_member.ds_ident <> class_member.ds_ident
				= check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members ins_type 
						instance_types member_defs modules var_heap type_heaps
							{ cs & cs_error = checkError class_member.ds_ident "instance of class member expected" cs.cs_error}
			| ins_member.ds_arity <> class_member.ds_arity
				= check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members ins_type
						instance_types member_defs modules var_heap type_heaps
							{ cs & cs_error = checkError class_member.ds_ident "used with wrong arity" cs.cs_error}
				# ({me_type,me_class_vars}, member_defs, modules) = getMemberDef member_mod_index class_member.ds_index module_index member_defs modules
				  (instance_type, _, type_heaps) = determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None type_heaps
				  (st_context, var_heap) = initializeContextVariables instance_type.st_context var_heap
				= check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members ins_type
						[ (ins_member.ds_index, { instance_type & st_context = st_context }) : instance_types ] member_defs modules var_heap type_heaps cs

getClassDef :: !(Global DefinedSymbol) !Int !u:{#ClassDef} !v:{#DclModule} -> (!ClassDef,!u:{#ClassDef},!v:{#DclModule})
getClassDef {glob_module, glob_object={ds_ident, ds_index}} mod_index class_defs modules
	| glob_module == mod_index
		# (class_def, class_defs) = class_defs![ds_index]
		= (class_def, class_defs, modules)
		# (dcl_mod, modules) = modules![glob_module]
		= (dcl_mod.dcl_common.com_class_defs.[ds_index], class_defs, modules)
		
getMemberDef :: !Int Int !Int !u:{#MemberDef} !v:{#DclModule} -> (!MemberDef,!u:{#MemberDef},!v:{#DclModule})
getMemberDef mem_mod mem_index mod_index member_defs modules
	| mem_mod == mod_index
		# (member_def,member_defs) = member_defs![mem_index]
		= (member_def, member_defs, modules)
		# (dcl_mod,modules) = modules![mem_mod]
		= (dcl_mod.dcl_common.com_member_defs.[mem_index], member_defs, modules)

instantiateTypes :: ![TypeVar] ![AttributeVar] !types ![TypeContext] ![AttrInequality] !SpecialSubstitution ![SpecialSubstitution] !*TypeHeaps
	-> (![TypeVar], ![AttributeVar], !types , ![TypeContext], ![AttrInequality], ![SpecialSubstitution], !*TypeHeaps) | substitute types
instantiateTypes old_type_vars old_attr_vars types type_contexts attr_env {ss_environ, ss_vars, ss_attrs, ss_context} special_subst_list type_heaps=:{th_vars, th_attrs}
	# th_vars = clear_vars old_type_vars th_vars

	  (new_type_vars, th_vars) = foldSt build_var_subst ss_vars ([], th_vars)
	  (new_attr_vars, th_attrs) = foldSt build_attr_subst ss_attrs ([], th_attrs)

	  type_heaps = foldSt build_type_subst ss_environ { type_heaps & th_vars = th_vars, th_attrs = th_attrs }
	  (new_ss_context, type_heaps) = substitute ss_context type_heaps

	  (inst_vars, th_vars) =  foldSt determine_free_var old_type_vars (new_type_vars, type_heaps.th_vars) 
	  (inst_attr_vars, th_attrs) = foldSt build_attr_subst old_attr_vars (new_attr_vars, type_heaps.th_attrs)

	  (inst_types, type_heaps)		= substitute types { type_heaps & th_vars = th_vars, th_attrs = th_attrs }
	  (inst_contexts, type_heaps)	= substitute type_contexts type_heaps
	  (inst_attr_env, type_heaps)	= substitute attr_env type_heaps
	  
	  (special_subst_list, th_vars) =  mapSt adjust_special_subst special_subst_list type_heaps.th_vars

	= (inst_vars, inst_attr_vars, inst_types, inst_contexts ++ new_ss_context, inst_attr_env, special_subst_list, { type_heaps & th_vars = th_vars })
where
	clear_vars type_vars type_var_heap = foldSt (\tv -> writePtr tv.tv_info_ptr TVI_Empty) type_vars type_var_heap
	
	determine_free_var tv=:{tv_info_ptr} (free_vars, type_var_heap)
		# (type_var_info, type_var_heap) = readPtr tv_info_ptr type_var_heap
		= case type_var_info of
			TVI_Empty
				-> build_var_subst tv (free_vars, type_var_heap)
			_
				-> (free_vars, type_var_heap)

	build_type_subst {bind_src,bind_dst} type_heaps
		# (bind_src, type_heaps) = substitute bind_src type_heaps
		= { type_heaps & th_vars = writePtr bind_dst.tv_info_ptr (TVI_Type bind_src) type_heaps.th_vars}

	build_var_subst var (free_vars, type_var_heap)
		# (new_info_ptr, type_var_heap) = newPtr TVI_Empty type_var_heap
		  new_fv = { var & tv_info_ptr = new_info_ptr}
	  	= ([ new_fv : free_vars ], writePtr var.tv_info_ptr (TVI_Type (TV new_fv)) type_var_heap)

	build_attr_subst attr (free_attrs, attr_var_heap)
		# (new_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap
		  new_attr = { attr & av_info_ptr = new_info_ptr}
		= ([new_attr : free_attrs], writePtr attr.av_info_ptr (AVI_Attr (TA_Var new_attr)) attr_var_heap)
	
	adjust_special_subst special_subst=:{ss_environ} type_var_heap
		# (ss_environ, type_var_heap) = mapSt adjust_special_bind ss_environ type_var_heap
		= ({ special_subst & ss_environ = ss_environ }, type_var_heap)
		
	adjust_special_bind bind=:{bind_dst={tv_info_ptr}} type_var_heap
		# (TVI_Type (TV new_tv), type_var_heap) = readPtr tv_info_ptr type_var_heap
		= ({ bind & bind_dst = new_tv }, type_var_heap)

substituteInstanceType :: !InstanceType !SpecialSubstitution !*TypeHeaps -> (!InstanceType,!*TypeHeaps)
substituteInstanceType it=:{it_vars,it_attr_vars,it_types,it_context} environment type_heaps
	# (it_vars, it_attr_vars, it_types, it_context, _, _, type_heaps)
		= instantiateTypes it_vars it_attr_vars it_types it_context [] environment [] type_heaps
	= ({it & it_vars = it_vars, it_types = it_types, it_attr_vars = it_attr_vars, it_context = it_context }, type_heaps)

hasTypeVariables []
	= False
hasTypeVariables [TV tvar : types]
	= True
hasTypeVariables [ _ : types]
	= hasTypeVariables types

determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps -> (!SymbolType, !Specials, !*TypeHeaps)
determineTypeOfMemberInstance mem_st class_vars {it_types,it_vars,it_attr_vars,it_context} specials type_heaps
	# env = { ss_environ = foldl2 (\binds var type -> [ {bind_src = type, bind_dst = var} : binds]) [] class_vars it_types,
			  ss_context = it_context, ss_vars = it_vars, ss_attrs = it_attr_vars} 
	= determine_type_of_member_instance mem_st env specials type_heaps
where
	determine_type_of_member_instance mem_st=:{st_context} env (SP_Substitutions substs) type_heaps
		# (mem_st, substs, type_heaps) = substitute_symbol_type { mem_st &  st_context = tl st_context } env substs type_heaps
		= (mem_st, SP_Substitutions substs, type_heaps) 
	determine_type_of_member_instance mem_st=:{st_context} env SP_None type_heaps
		# (mem_st, _, type_heaps) = substitute_symbol_type { mem_st &  st_context = tl st_context } env [] type_heaps 
		= (mem_st, SP_None, type_heaps)

	substitute_symbol_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment specials type_heaps
		# (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, specials, type_heaps)
			= instantiateTypes st_vars st_attr_vars [ st_result : st_args ] st_context st_attr_env environment specials type_heaps
		= ({st & st_vars = st_vars, st_args = st_args, st_result = st_result, st_attr_vars = st_attr_vars,
			st_context = st_context, st_attr_env = st_attr_env }, specials, type_heaps)

determineTypesOfInstances :: !Index !Index !*CommonDefs !*{#DclModule} !*TypeHeaps !*VarHeap !*CheckState
	-> (![FunType], !Index, ![ClassInstance], !*CommonDefs, !*{#DclModule}, !*TypeHeaps, !*VarHeap, !*CheckState)
determineTypesOfInstances first_memb_inst_index mod_index dcl_common=:{com_instance_defs,com_class_defs,com_member_defs}
		modules type_heaps var_heap cs=:{cs_error}
	| cs_error.ea_ok
		#! nr_of_class_instances = size com_instance_defs
		# (memb_inst_defs, next_mem_inst_index, all_class_specials, com_class_defs, com_member_defs, modules, com_instance_defs, type_heaps, var_heap, cs_error)
				= determine_types_of_instances 0 nr_of_class_instances first_memb_inst_index mod_index [] com_class_defs com_member_defs
						modules com_instance_defs type_heaps var_heap cs_error
		= (memb_inst_defs, next_mem_inst_index, all_class_specials,
				{ dcl_common & com_instance_defs = com_instance_defs,com_class_defs = com_class_defs, com_member_defs = com_member_defs },
					 modules, type_heaps, var_heap, { cs & cs_error = cs_error })
		= ([], first_memb_inst_index, [], dcl_common, modules, type_heaps, var_heap, cs)
where

	determine_types_of_instances :: !Index !Index !Index !Index ![ClassInstance] !v:{#ClassDef} !w:{#MemberDef}
		!x:{#DclModule} !*{#ClassInstance} !*TypeHeaps !*VarHeap !*ErrorAdmin
			-> (![FunType], !Index, ![ClassInstance], !v:{#ClassDef}, !w:{#MemberDef}, !x:{#DclModule}, !*{#ClassInstance}, !*TypeHeaps, !*VarHeap, !*ErrorAdmin)
	determine_types_of_instances inst_index next_class_inst_index next_mem_inst_index mod_index all_class_specials
			class_defs member_defs modules instance_defs type_heaps var_heap error
		| inst_index < size instance_defs
			# (instance_def, instance_defs) = instance_defs![inst_index]
			# {ins_class,ins_pos,ins_type,ins_specials} = instance_def
			  ({class_members}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules
			  class_size = size class_members
			  (ins_members, memb_inst_defs1, member_defs, modules, type_heaps, var_heap)
			  		= determine_instance_symbols_and_types next_mem_inst_index 0 mod_index ins_class.glob_module class_size class_members
			  				ins_type ins_specials ins_pos member_defs modules type_heaps var_heap
			  instance_def = { instance_def & ins_members = { member \\ member <- ins_members }}
			  (ins_specials, next_class_inst_index, all_class_specials, type_heaps, error)
					= check_instance_specials mod_index instance_def inst_index ins_specials next_class_inst_index all_class_specials type_heaps error
			  (memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, error)
			  		= determine_types_of_instances (inc inst_index) next_class_inst_index (next_mem_inst_index + class_size) mod_index all_class_specials
			  				class_defs member_defs modules { instance_defs & [inst_index] = { instance_def & ins_specials = ins_specials }} type_heaps var_heap error

			= (memb_inst_defs1 ++ memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, error)
			= ([], next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, error)

	determine_instance_symbols_and_types :: !Index !Index !Index !Index !Int !{#DefinedSymbol} !InstanceType !Specials !Position
			!w:{#MemberDef} !u:{#DclModule} !*TypeHeaps !*VarHeap
					-> (![DefinedSymbol], ![FunType], !w:{#MemberDef}, !u:{#DclModule}, !*TypeHeaps, !*VarHeap)
	determine_instance_symbols_and_types first_inst_index mem_offset module_index member_mod_index class_size class_members
			ins_type ins_specials ins_pos member_defs modules type_heaps var_heap
		| mem_offset == class_size
			=  ([], [], member_defs, modules, type_heaps, var_heap)
			# class_member = class_members.[mem_offset]
			  ({me_symb,me_type,me_priority,me_class_vars}, member_defs, modules) = getMemberDef member_mod_index class_member.ds_index module_index member_defs modules
			  (instance_type, new_ins_specials, type_heaps) = determineTypeOfMemberInstance me_type me_class_vars ins_type ins_specials type_heaps
	  		  (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
			  inst_def = MakeNewFunctionType me_symb me_type.st_arity me_priority instance_type ins_pos new_ins_specials new_info_ptr
			  (inst_symbols, memb_inst_defs, member_defs, modules, type_heaps, var_heap)
			  		= determine_instance_symbols_and_types first_inst_index (inc mem_offset) module_index member_mod_index
			  				class_size class_members ins_type ins_specials ins_pos member_defs modules type_heaps var_heap
			= ([{ class_member & ds_index = first_inst_index +  mem_offset } : inst_symbols], [inst_def : memb_inst_defs], member_defs, modules, type_heaps, var_heap)

	check_instance_specials :: !Index !ClassInstance !Index !Specials !Index ![ClassInstance] !*TypeHeaps !*ErrorAdmin
		-> (!Specials, !Index, ![ClassInstance], !*TypeHeaps, !*ErrorAdmin)
	check_instance_specials mod_index inst_type inst_index (SP_Substitutions substs) next_inst_index all_instances type_heaps error
		# (list_of_specials, next_inst_index, all_instances, type_heaps, error)
			= check_specials mod_index inst_type 0 substs [] next_inst_index all_instances type_heaps error
		= (SP_ContextTypes list_of_specials, next_inst_index, all_instances, type_heaps, error)
	where
		check_specials mod_index inst=:{ins_type} type_offset [ subst : substs ] list_of_specials next_inst_index all_instances type_heaps error
			# (special_type, type_heaps) = substituteInstanceType ins_type subst type_heaps
			  (spec_types, error) = checkAndCollectTypesOfContexts special_type.it_context error
			  special = { spec_index = { glob_module = mod_index, glob_object = next_inst_index }, spec_types = spec_types,
			  				spec_vars = subst.ss_vars, spec_attrs = subst.ss_attrs }
			= check_specials mod_index inst (inc type_offset) substs [ special : list_of_specials ] (inc next_inst_index)
					[{ inst & ins_type = { special_type & it_context = [] }, ins_specials = SP_TypeOffset type_offset} : all_instances ] type_heaps error
		check_specials mod_index inst=:{ins_type} type_offset [] list_of_specials next_inst_index all_instances type_heaps error
			= (list_of_specials,  next_inst_index, all_instances, type_heaps, error)
	
	check_instance_specials mod_index fun_type fun_index SP_None next_inst_index all_instances type_heaps error
		= (SP_None, next_inst_index, all_instances, type_heaps, error)

checkAndCollectTypesOfContexts type_contexts error
	= mapSt check_and_collect_context_types type_contexts error
where	
	check_and_collect_context_types {tc_class={glob_object={ds_ident}},tc_types} error
		| hasTypeVariables tc_types
			= (tc_types, checkError ds_ident.id_name "illegal specialization" error)
			= (tc_types, error)

/*
retrieveSelectorIndexes mod_index {ste_kind = STE_Selector selector_list, ste_index, ste_previous }
	# imported_selectors = retrieveSelectorIndexes mod_index ste_previous
	= mapAppend (\ sel -> { sel & glob_module = mod_index }) selector_list [{glob_module = mod_index, glob_object = ste_index } : imported_selectors ]
retrieveSelectorIndexes mod_index {ste_kind = STE_Imported (STE_Selector selector_list) dcl_mod_index, ste_index }
	= [ { glob_object = ste_index, glob_module = dcl_mod_index } : selector_list ]
retrieveSelectorIndexes mod_index off_kind
	= []
*/

retrieveSelectorIndexes mod_index {ste_kind = STE_Selector selector_list, ste_index, ste_previous }
	= map (adjust_mod_index mod_index) selector_list
where
	adjust_mod_index mod_index selector=:{glob_module}
		| glob_module == NoIndex
			= { selector & glob_module = mod_index }
			= selector
retrieveSelectorIndexes mod_index off_kind
	= []

checkFields :: !Index ![FieldAssignment] !(Optional Ident) !u:ExpressionInfo !*CheckState
	-> (!Optional ((Global DefinedSymbol), Index, [Bind ParsedExpr (Global FieldSymbol)]), !u:ExpressionInfo, !*CheckState)
checkFields mod_index field_ass opt_type e_info=:{ef_selector_defs,ef_type_defs,ef_modules} cs
	# (ok, field_ass, cs) = check_fields field_ass cs
	| ok
		# (opt_type_def, ef_selector_defs, ef_type_defs, ef_modules, cs)
				= determine_record_type mod_index opt_type field_ass ef_selector_defs ef_type_defs ef_modules cs
		  e_info = { e_info & ef_selector_defs = ef_selector_defs, ef_type_defs = ef_type_defs, ef_modules = ef_modules}
		= case opt_type_def of
			Yes ({td_index,td_rhs = RecordType {rt_constructor,rt_fields}}, type_mod_index)
				# (field_exprs, cs_error) = check_and_rearrange_fields type_mod_index 0 rt_fields field_ass cs.cs_error
				-> (Yes ({ glob_object = rt_constructor, glob_module = type_mod_index }, td_index, field_exprs), e_info, { cs & cs_error = cs_error })
			No
				-> (No, e_info, cs)
		= (No, e_info, cs)
where

	check_fields [ bind=:{bind_dst} : field_ass ] cs=:{cs_symbol_table,cs_error}
		# (entry, cs_symbol_table) = readPtr bind_dst.id_info cs_symbol_table
		# fields = retrieveSelectorIndexes mod_index entry 
		| isEmpty fields
			= (False, [], { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError bind_dst "not defined as a record field" cs_error })
			# (ok, field_ass, cs) = check_fields field_ass { cs & cs_symbol_table = cs_symbol_table }
			= (ok, [{bind & bind_dst = (bind_dst, fields)} : field_ass], cs)
	check_fields [] cs
		= (True, [], cs)

	try_to_get_unique_field []
		= No
	try_to_get_unique_field [ {bind_dst = (field_id, [field])} : fields ]
		= Yes field
	try_to_get_unique_field [ _ : fields ]
		= try_to_get_unique_field fields
	
	determine_record_type mod_index (Yes type_id=:{id_info}) _ selector_defs type_defs modules cs=:{cs_symbol_table, cs_error}
		# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
		# (type_index, type_mod_index) = retrieveGlobalDefinition entry STE_Type mod_index
		| type_index <> NotFound
			| mod_index == type_mod_index
			 	# (type_def, type_defs) = type_defs![type_index]
			 	= (Yes (type_def, type_mod_index), selector_defs, type_defs, modules, { cs & cs_symbol_table = cs_symbol_table })
				# (type_def, modules) = modules![type_mod_index].dcl_common.com_type_defs.[type_index]
				= (Yes (type_def, type_mod_index), selector_defs, type_defs, modules, { cs & cs_symbol_table = cs_symbol_table })
			= (No, selector_defs, type_defs, modules, { cs & cs_error = checkError type_id " not defined" cs_error, cs_symbol_table = cs_symbol_table})
	determine_record_type mod_index No fields selector_defs type_defs modules cs=:{cs_error}
		# succ = try_to_get_unique_field fields
		= case succ of
			Yes {glob_module, glob_object}
				| glob_module == mod_index
					# (selector_def, selector_defs) = selector_defs![glob_object]
					  (type_def, type_defs) = type_defs![selector_def.sd_type_index]
					-> (Yes (type_def, glob_module), selector_defs, type_defs, modules, cs)
					# ({dcl_common={com_selector_defs,com_type_defs}}, modules) = modules![glob_module]
					# selector_def = com_selector_defs.[glob_object]
					  type_def = com_type_defs.[selector_def.sd_type_index]
					-> (Yes (type_def,glob_module), selector_defs, type_defs, modules, cs)
			No
				-> (No, selector_defs, type_defs, modules, { cs & cs_error = checkError "" " could not determine the type of this record" cs.cs_error })
			

	check_and_rearrange_fields mod_index field_index fields field_ass cs_error
		| field_index < size fields
			# (field_expr, field_ass) = look_up_field mod_index fields.[field_index] field_ass
		 	  (field_exprs, cs_error) = check_and_rearrange_fields mod_index (inc field_index) fields field_ass cs_error
			= ([field_expr : field_exprs], cs_error)
			| isEmpty field_ass
				= ([], cs_error)
				= ([], foldSt field_error field_ass cs_error)

	where			
		look_up_field mod_index field []
			= ({bind_src = PE_WildCard,  bind_dst = { glob_object = field, glob_module = mod_index }}, [])
		look_up_field mod_index field=:{fs_index} [ass=:{bind_src, bind_dst = (_, fields)} : field_ass]
			| field_list_contains_field mod_index fs_index fields
				= ({bind_src = bind_src, bind_dst = { glob_module = mod_index, glob_object = field}}, field_ass)
				# (field_expr, field_ass) = look_up_field mod_index field field_ass
				= (field_expr, [ass : field_ass])

		field_list_contains_field mod_index fs_index []
			= False
		field_list_contains_field mod_index fs_index [{glob_object,glob_module} : fields]
			= mod_index == glob_module && fs_index == glob_object || field_list_contains_field mod_index fs_index fields

		field_error {bind_dst=(field_id,_)} error
			= checkError field_id " field is either multiply used or not a part of this record" error

::	ExpressionInfo =
	{	ef_type_defs		:: !.{# CheckedTypeDef}
	,	ef_selector_defs	:: !.{# SelectorDef}
	,	ef_cons_defs		:: !.{# ConsDef}
	,	ef_member_defs		:: !.{# MemberDef}
	,	ef_class_defs		:: !.{# ClassDef}
	,	ef_modules			:: !.{# DclModule}
	,	ef_is_macro_fun		:: !Bool
	}

::	ExpressionState =
	{	es_expr_heap	:: !.ExpressionHeap
	,	es_var_heap			:: !.VarHeap
	,	es_type_heaps		:: !.TypeHeaps
	,	es_calls			:: ![FunCall]
	,	es_dynamics			:: ![ExprInfoPtr]
	,	es_fun_defs			:: !.{# FunDef}
	}
	
::	ExpressionInput =
	{	ei_expr_level	:: !Level
	,	ei_fun_index	:: !Index
	,	ei_fun_level	:: !Level
	,	ei_mod_index	:: !Index
//	,	ei_fun_kind		:: !FunKind
	}


cIsInExpressionList		:== True
cIsNotInExpressionList	:== False


::	UnfoldMacroState =
	{	ums_var_heap	:: !.VarHeap
	,	ums_modules		:: !.{# DclModule}
	,	ums_cons_defs	:: !.{# ConsDef}
	,	ums_error		:: !.ErrorAdmin
	}

unfoldPatternMacro mod_index macro_index macro_args opt_var ps=:{ps_var_heap, ps_fun_defs} modules cons_defs error
	# (macro, ps_fun_defs) = ps_fun_defs![macro_index]
	= case macro.fun_body of
		TransformedBody {tb_args,tb_rhs}
			| no_sharing tb_args
				# ums = { ums_var_heap = fold2St bind_var tb_args macro_args ps_var_heap, ums_modules = modules, ums_cons_defs = cons_defs, ums_error = error }
				  (pattern, {ums_var_heap,ums_modules,ums_cons_defs,ums_error}) = unfold_pattern_macro mod_index macro.fun_symb opt_var tb_rhs ums
				-> (pattern, { ps_fun_defs = ps_fun_defs, ps_var_heap = ums_var_heap}, ums_modules, ums_cons_defs, ums_error)
				-> (AP_Empty macro.fun_symb, { ps_fun_defs = ps_fun_defs, ps_var_heap = ps_var_heap},
						modules, cons_defs, checkError macro.fun_symb " sharing not allowed" error)
		_
			-> (AP_Empty macro.fun_symb, { ps_fun_defs = ps_fun_defs, ps_var_heap = ps_var_heap},
					modules, cons_defs, checkError macro.fun_symb " illegal macro in pattern" error)
	
where
	no_sharing [{fv_count} : args]
		= fv_count <= 1 && no_sharing args
	no_sharing []
		= True
	
	bind_var {fv_info_ptr} pattern ps_var_heap
		= ps_var_heap <:= (fv_info_ptr, VI_Pattern pattern)

	unfold_pattern_macro mod_index macro_ident _ (Var {var_name,var_info_ptr}) ums=:{ums_var_heap}
		# (VI_Pattern pattern, ums_var_heap) = readPtr var_info_ptr ums_var_heap
		= (pattern, { ums & ums_var_heap = ums_var_heap})
	unfold_pattern_macro mod_index macro_ident opt_var (App {app_symb,app_args}) ums
		= unfold_application  mod_index macro_ident opt_var app_symb app_args ums
	where
		unfold_application  mod_index macro_ident opt_var {symb_kind=SK_Constructor {glob_module,glob_object},symb_name,symb_arity} args 
										ums=:{ums_cons_defs, ums_modules,ums_error}
				# (cons_def, cons_index, ums_cons_defs, ums_modules) = get_cons_def mod_index glob_module glob_object ums_cons_defs ums_modules
				| cons_def.cons_type.st_arity == symb_arity
					# (patterns, ums) = mapSt (unfold_pattern_macro mod_index macro_ident No) app_args { ums & ums_cons_defs = ums_cons_defs, ums_modules = ums_modules }
					  cons_symbol = { glob_object = MakeDefinedSymbol symb_name cons_index symb_arity, glob_module = glob_module }	
					= (AP_Algebraic cons_symbol cons_def.cons_type_index patterns opt_var, ums)	
					= (AP_Empty cons_def.cons_symb, { ums & ums_cons_defs = ums_cons_defs, ums_modules = ums_modules,
							ums_error = checkError cons_def.cons_symb " missing argument(s)" ums_error })
		get_cons_def mod_index cons_mod cons_index cons_defs modules
			| mod_index == cons_mod
				# (cons_def, cons_defs) = cons_defs![cons_index]
				= (cons_def, cons_index, cons_defs, modules)
				# ({dcl_common,dcl_conversions}, modules) = modules![cons_mod]
				  cons_def = dcl_common.com_cons_defs.[cons_index]
				= (cons_def, convertIndex cons_index (toInt STE_Constructor) dcl_conversions, cons_defs, modules)

		get_cons_def mod_index cons_mod cons_index cons_defs modules
			# ({dcl_common,dcl_conversions}, modules) = modules![cons_mod]
			  cons_def = dcl_common.com_cons_defs.[cons_index]
			= (cons_def, convertIndex cons_index (toInt STE_Constructor) dcl_conversions, cons_defs, modules)

	unfold_pattern_macro mod_index macro_ident opt_var (BasicExpr bv bt) ums
		= (AP_Basic bv opt_var, ums)
	unfold_pattern_macro mod_index macro_ident opt_var expr ums=:{ums_error}
		= (AP_Empty macro_ident, { ums & ums_error = checkError macro_ident " illegal rhs for a pattern macro" ums_error })
	
	
			
checkPatternVariable :: !Level !SymbolTableEntry !Ident !VarInfoPtr !*CheckState -> !*CheckState
checkPatternVariable def_level entry=:{ste_def_level,ste_kind} ident=:{id_info} var_info cs=:{cs_symbol_table,cs_error}
	| ste_kind == STE_Empty || def_level > ste_def_level
		# entry = {ste_kind = STE_Variable var_info, ste_index = NoIndex, ste_def_level = def_level, ste_previous = entry }
		= { cs & cs_symbol_table = cs_symbol_table <:= (id_info,entry)}
		= { cs & cs_error = checkError ident "(pattern variable) already defined" cs_error }

checkPatternConstructor :: !Index !Bool !SymbolTableEntry !Ident !(Optional (Bind Ident VarInfoPtr)) !*PatternState !*ExpressionInfo !*CheckState
	-> (!AuxiliaryPattern, !*PatternState, !*ExpressionInfo, !*CheckState);
checkPatternConstructor _ _ {ste_kind = STE_Empty} ident _  ps e_info cs=:{cs_error}
	= (AP_Empty ident, ps, e_info, { cs & cs_error = checkError ident " not defined" cs_error })
checkPatternConstructor mod_index is_expr_list {ste_kind = STE_FunctionOrMacro _,ste_index} ident opt_var  ps=:{ps_fun_defs} e_info cs=:{cs_error}
	# ({fun_symb,fun_arity,fun_kind,fun_priority},ps_fun_defs) = ps_fun_defs![ste_index]
	  ps = { ps & ps_fun_defs = ps_fun_defs }
	| fun_kind == FK_Macro
		| is_expr_list
			# macro_symbol = { glob_object = MakeDefinedSymbol fun_symb ste_index fun_arity, glob_module = cIclModIndex }
	 		= (AP_Constant APK_Macro macro_symbol fun_priority, ps, e_info, cs)
		| fun_arity == 0
			# (pattern, ps, ef_modules, ef_cons_defs, cs_error)
					= unfoldPatternMacro mod_index ste_index [] opt_var ps e_info.ef_modules e_info.ef_cons_defs cs_error
			= (pattern, ps, { e_info & ef_modules = ef_modules, ef_cons_defs = ef_cons_defs }, { cs & cs_error = cs_error })
			= (AP_Empty ident, ps, e_info, { cs & cs_error = checkError ident " not defined" cs_error })
		= (AP_Empty ident, ps, e_info, { cs & cs_error = checkError fun_symb " not allowed in a pattern" cs_error })
checkPatternConstructor mod_index is_expr_list {ste_index, ste_kind} cons_symb opt_var ps
		e_info=:{ef_cons_defs,ef_modules} cs=:{cs_error}
	# (cons_index, cons_module, cons_arity, cons_priority, cons_type_index, ef_cons_defs, ef_modules, cs_error)
			= determine_pattern_symbol mod_index ste_index ste_kind cons_symb.id_name ef_cons_defs ef_modules cs_error
	  e_info = { e_info & ef_cons_defs = ef_cons_defs, ef_modules = ef_modules }
	  cons_symbol = { glob_object = MakeDefinedSymbol cons_symb cons_index cons_arity, glob_module = cons_module }
   	| is_expr_list
		= (AP_Constant (APK_Constructor cons_type_index) cons_symbol cons_priority, ps, e_info, { cs & cs_error = cs_error })
	| cons_arity == 0
		= (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = cs_error })
		= (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = checkError cons_symb " constructor arguments are missing" cs_error })
where
	determine_pattern_symbol mod_index id_index STE_Constructor id_name cons_defs modules error
		# ({cons_type={st_arity},cons_priority, cons_type_index}, cons_defs) = cons_defs![id_index]
		= (id_index, mod_index, st_arity, cons_priority, cons_type_index, cons_defs, modules, error)
	determine_pattern_symbol mod_index id_index (STE_Imported STE_Constructor import_mod_index) id_name cons_defs modules error
		# ({dcl_common,dcl_conversions},modules) = modules![import_mod_index]
		  {cons_type={st_arity},cons_priority, cons_type_index} = dcl_common.com_cons_defs.[id_index]
		  id_index = convertIndex id_index (toInt STE_Constructor) dcl_conversions
		= (id_index, import_mod_index, st_arity, cons_priority, cons_type_index, cons_defs, modules, error)
	determine_pattern_symbol mod_index id_index id_kind id_name cons_defs modules error
		= (id_index, NoIndex, 0, NoPrio, NoIndex, cons_defs, modules, checkError id_name " constructor expected" error)


checkIdentPattern :: !Bool !Ident !(Optional (Bind Ident VarInfoPtr)) !PatternInput !(![Ident], ![ArrayPattern]) !*PatternState !*ExpressionInfo !*CheckState
	-> (!AuxiliaryPattern, !(![Ident], ![ArrayPattern]), !*PatternState, !*ExpressionInfo, !*CheckState)
checkIdentPattern is_expr_list id=:{id_name,id_info} opt_var {pi_def_level, pi_mod_index} accus=:(var_env, array_patterns)
					ps e_info cs=:{cs_symbol_table}
	# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
	| isLowerCaseName id_name
		# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap
		  cs = checkPatternVariable pi_def_level entry id new_info_ptr { cs & cs_symbol_table = cs_symbol_table }
		= (AP_Variable id new_info_ptr opt_var, ([ id : var_env ], array_patterns), { ps & ps_var_heap = ps_var_heap}, e_info, cs)
		# (pattern, ps, e_info, cs) = checkPatternConstructor pi_mod_index is_expr_list entry id opt_var ps e_info { cs & cs_symbol_table = cs_symbol_table }
		= (pattern, accus, ps, e_info, cs)

::	PatternState =
	{	ps_var_heap :: !.VarHeap
	,	ps_fun_defs :: !.{# FunDef}
	}

::	PatternInput =
	{	pi_def_level		:: !Int
	,	pi_mod_index		:: !Index
	,	pi_is_node_pattern	:: !Bool
	}
	
::	ArrayPattern =
	{	ap_opt_var		:: !Optional (Bind Ident VarInfoPtr)
	,	ap_array_var	:: !FreeVar
	,	ap_selections	:: ![Bind FreeVar [ParsedExpr]]
	}

buildPattern mod_index (APK_Constructor type_index) cons_symb args opt_var ps e_info cs
	= (AP_Algebraic cons_symb type_index args opt_var, ps, e_info, cs)
buildPattern mod_index APK_Macro {glob_object} args opt_var ps e_info=:{ef_modules,ef_cons_defs} cs=:{cs_error}
	# (pattern, ps, ef_modules, ef_cons_defs, cs_error)
			= unfoldPatternMacro mod_index glob_object.ds_index args opt_var ps ef_modules ef_cons_defs cs_error
	= (pattern, ps, { e_info & ef_modules = ef_modules, ef_cons_defs = ef_cons_defs }, { cs & cs_error = cs_error })

checkPattern :: !ParsedExpr !(Optional (Bind Ident VarInfoPtr)) !PatternInput !(![Ident], ![ArrayPattern]) !*PatternState !*ExpressionInfo !*CheckState
									-> (!AuxiliaryPattern, !(![Ident], ![ArrayPattern]), !*PatternState, !*ExpressionInfo, !*CheckState)
checkPattern (PE_List [exp]) opt_var p_input accus ps e_info cs=:{cs_symbol_table}
	= case exp of
		PE_Ident ident
			-> checkIdentPattern cIsNotInExpressionList ident opt_var p_input accus ps e_info cs
		_
			-> checkPattern exp opt_var p_input accus ps e_info cs

checkPattern (PE_List [exp1, exp2 : exps]) opt_var p_input accus ps e_info cs
	# (exp_pat, accus, ps, e_info, cs) = check_pattern exp1 p_input accus ps e_info cs
	= check_patterns [exp_pat] exp2 exps opt_var p_input accus ps e_info cs
	where
		check_patterns left middle [] opt_var p_input=:{pi_mod_index} accus ps e_info cs
			# (mid_pat, accus, ps, e_info, cs) = checkPattern middle No p_input accus ps e_info cs
			  (pat, ps, e_info, cs) = combine_patterns pi_mod_index opt_var [mid_pat : left] [] 0 ps e_info cs
			= (pat, accus, ps, e_info, cs)
		check_patterns left middle [right:rest] opt_var p_input=:{pi_mod_index} accus ps e_info cs
			# (mid_pat, accus, ps, e_info, cs) = check_pattern middle p_input accus ps e_info cs
			= case mid_pat of
				AP_Constant kind constant=:{glob_object={ds_arity,ds_ident}} prio
					| ds_arity == 0
						# (pattern, ps, e_info, cs) = buildPattern pi_mod_index kind constant [] No ps e_info cs
						-> check_patterns [pattern: left] right rest opt_var p_input accus ps e_info cs
					| is_infix_constructor prio
						# (left_arg, ps, e_info, cs) = combine_patterns pi_mod_index No left [] 0 ps e_info cs
						  (right_pat, accus, ps, e_info, cs) = check_pattern right p_input accus ps e_info cs
						-> check_infix_pattern [] left_arg kind constant prio [right_pat] rest
									opt_var p_input accus ps e_info cs
						-> (AP_Empty ds_ident, accus, ps, e_info,
								{ cs & cs_error = checkError ds_ident "arguments of constructor are missing" cs.cs_error })
				_
					-> check_patterns [mid_pat : left] right rest opt_var p_input accus ps e_info cs

		check_pattern (PE_Ident id) p_input accus ps e_info cs
			= checkIdentPattern cIsInExpressionList id No p_input accus ps e_info cs
		check_pattern expr p_input accus ps e_info cs
			= checkPattern expr No p_input accus ps e_info cs
		
	 	check_infix_pattern left_args left kind cons prio middle [] opt_var p_input=:{pi_mod_index} accus ps e_info cs
			# (middle_pat, ps, e_info, cs) = combine_patterns pi_mod_index No middle [] 0 ps e_info cs
			  (pattern, ps, e_info, cs) = buildPattern pi_mod_index kind cons [left,middle_pat] opt_var ps e_info cs
			  (pattern, ps, e_info, cs) = build_final_pattern pi_mod_index left_args pattern ps e_info cs
			= (pattern, accus, ps, e_info, cs)
	 	check_infix_pattern left_args left kind cons prio middle [right] opt_var  p_input=:{pi_mod_index} accus ps e_info cs
			# (right_pat, accus, ps, e_info, cs) = checkPattern right No p_input accus ps e_info cs
			  (right_arg, ps, e_info, cs) = combine_patterns pi_mod_index No [right_pat : middle] [] 0 ps e_info cs
			  (pattern, ps, e_info, cs) = buildPattern pi_mod_index kind cons [left,right_arg] opt_var ps e_info cs
			  (pattern, ps, e_info, cs) = build_final_pattern pi_mod_index left_args pattern ps e_info cs
			= (pattern, accus, ps, e_info, cs)
	 	check_infix_pattern left_args left kind1 cons1 prio1 middle [inf_cons, arg : rest] opt_var p_input=:{pi_mod_index} accus ps e_info cs
			# (inf_cons_pat, accus, ps, e_info, cs) = check_pattern inf_cons p_input accus ps e_info cs
			= case inf_cons_pat of
				AP_Constant kind2 cons2=:{glob_object={ds_ident,ds_arity}} prio2
					| ds_arity == 0
						# (middle_pat, ps, e_info, cs) = combine_patterns pi_mod_index No middle [] 0 ps e_info cs
						  (pattern2, ps, e_info, cs) = buildPattern pi_mod_index kind2 cons2 [] No ps e_info cs
						  (pattern1, ps, e_info, cs) = buildPattern pi_mod_index kind1 cons1 [left,middle_pat] No ps e_info cs
						  (pattern1, ps, e_info, cs) = build_final_pattern pi_mod_index left_args pattern1 ps e_info cs
						-> check_patterns [pattern2,pattern1] arg rest opt_var p_input accus ps e_info cs
					| is_infix_constructor prio2
						# optional_prio = determinePriority prio1 prio2
						-> case optional_prio of
							Yes priority
								# (arg_pat, accus, ps, e_info, cs) = check_pattern arg p_input accus ps e_info cs
								| priority
									# (middle_pat, ps, e_info, cs) = combine_patterns pi_mod_index No middle [] 0 ps e_info cs
								      (pattern, ps, e_info, cs) = buildPattern pi_mod_index kind1 cons1 [left,middle_pat] No ps e_info cs
								      (left_args, pattern, ps, e_info, cs) = build_left_pattern pi_mod_index left_args prio2 pattern ps e_info cs
									-> check_infix_pattern left_args pattern kind2 cons2 prio2 [arg_pat] rest opt_var p_input accus ps e_info cs 
									# (middle_pat, ps, e_info, cs) = combine_patterns pi_mod_index No middle [] 0 ps e_info cs
									-> check_infix_pattern [(kind1, cons1, prio1, left) : left_args]
									  				middle_pat kind2 cons2 prio2 [arg_pat] rest No p_input accus ps e_info cs
							No
								-> (AP_Empty ds_ident, accus, ps, e_info, { cs & cs_error = checkError ds_ident "conflicting priorities" cs.cs_error })
						-> (AP_Empty ds_ident, accus, ps, e_info, { cs & cs_error = checkError ds_ident "arguments of constructor are missing" cs.cs_error })
				_
					-> check_infix_pattern left_args left kind1 cons1 prio1 [inf_cons_pat : middle] [arg : rest] opt_var p_input accus ps e_info cs 

		is_infix_constructor (Prio _ _) = True
		is_infix_constructor _ = False

		build_left_pattern mod_index [] _ result_pattern ps e_info cs
			= ([], result_pattern, ps, e_info, cs)		
		build_left_pattern mod_index la=:[(kind, cons, priol, left) : left_args] prior result_pattern ps e_info cs
			# optional_prio = determinePriority priol prior
			= case optional_prio of
				Yes priority
					| priority
						# (result_pattern,  ps, e_info, cs) = buildPattern mod_index kind cons [left,result_pattern] No ps e_info cs
						-> build_left_pattern mod_index left_args prior result_pattern ps e_info cs
						-> (la, result_pattern,  ps, e_info, cs)
				No
					-> (la, result_pattern,  ps, e_info,{ cs & cs_error = checkError cons.glob_object.ds_ident "conflicting priorities" cs.cs_error })

		build_final_pattern mod_index [] result_pattern ps e_info cs
			= (result_pattern,  ps, e_info, cs)		
		build_final_pattern mod_index [(kind, cons, priol, left) : left_appls] result_pattern ps e_info cs
			# (result_pattern, ps, e_info, cs) = buildPattern mod_index kind cons [left,result_pattern] No ps e_info cs
			= build_final_pattern mod_index left_appls result_pattern ps e_info cs

		combine_patterns mod_index opt_var [first_expr] args nr_of_args ps e_info cs
			= case first_expr of
				AP_Constant kind constant=:{glob_object={ds_ident,ds_arity}} _
					| ds_arity == nr_of_args
						# (pattern, ps, e_info, cs) = buildPattern mod_index kind constant args opt_var ps e_info cs
						-> (pattern, ps, e_info, cs)
						-> (AP_Empty ds_ident, ps, e_info, { cs & cs_error = checkError ds_ident "used with wrong arity" cs.cs_error})
				_
					| nr_of_args == 0
						-> (first_expr, ps, e_info, cs)
						-> (first_expr, ps, e_info, { cs & cs_error = checkError "<pattern>" "(curried) application not allowed " cs.cs_error })
		combine_patterns mod_index opt_var [rev_arg : rev_args] args arity ps e_info cs
			= combine_patterns mod_index opt_var rev_args [rev_arg : args] (inc arity) ps e_info cs
/*
		combine_optional_variables (Yes var1) (Yes var2) error
			= (Yes var1, checkError var2.bind_dst "pattern already bound" error)
		combine_optional_variables No opt_var error
			= (opt_var, error)
		combine_optional_variables opt_var _ error
			= (opt_var, error)
*/

checkPattern (PE_DynamicPattern pattern type) opt_var p_input accus ps e_info cs
	# (dyn_pat, accus, ps, e_info, cs) = checkPattern pattern No p_input accus ps e_info cs
	= (AP_Dynamic dyn_pat type opt_var, accus, ps, e_info, { cs & cs_needed_modules = cs.cs_needed_modules bitor cNeedStdDynamics })

checkPattern (PE_Basic basic_value) opt_var p_input accus ps e_info cs
	= (AP_Basic basic_value opt_var, accus, ps, e_info, cs)

checkPattern (PE_Tuple tuple_args) opt_var p_input accus ps e_info cs
	# (patterns, arity, accus, ps, e_info, cs) = check_tuple_patterns tuple_args p_input accus ps e_info cs
	  (tuple_symbol, cs) = getPredefinedGlobalSymbol (GetTupleConsIndex arity) PD_PredefinedModule STE_Constructor arity cs
	# ({cons_type_index}, e_info) = e_info!ef_modules.[tuple_symbol.glob_module].dcl_common.com_cons_defs.[tuple_symbol.glob_object.ds_index]
	= (AP_Algebraic tuple_symbol cons_type_index patterns opt_var, accus, ps, e_info, cs)
where
	check_tuple_patterns [] p_input accus ps e_info cs
		= ([], 0, accus, ps, e_info, cs)
	check_tuple_patterns [expr : exprs] p_input accus ps e_info cs
		# (pattern, accus, ps, e_info, cs) = checkPattern expr No p_input accus ps e_info cs
		  (patterns, length, accus, ps, e_info, cs) = check_tuple_patterns exprs p_input accus ps e_info cs
		= ([pattern : patterns], inc length, accus, ps, e_info, cs)
checkPattern (PE_Record record opt_type fields) opt_var p_input=:{pi_mod_index, pi_is_node_pattern} accus=:(var_env, array_patterns) ps e_info cs
	# (opt_record_and_fields, e_info, cs) = checkFields pi_mod_index fields opt_type e_info cs
	= case opt_record_and_fields of
		Yes (record_symbol, type_index, new_fields)
			# (patterns, (var_env, array_patterns, ps, e_info, cs)) = mapSt (check_field_pattern p_input) new_fields (var_env, array_patterns, ps, e_info, cs)
			  (patterns, ps_var_heap) = bind_opt_record_variable opt_var pi_is_node_pattern patterns new_fields ps.ps_var_heap
			-> (AP_Algebraic record_symbol type_index patterns opt_var, (var_env, array_patterns), { ps & ps_var_heap = ps_var_heap }, e_info, cs)
		No
			-> (AP_Empty (hd fields).bind_dst, accus, ps, e_info, cs)
where

	check_field_pattern p_input=:{pi_def_level} {bind_src = PE_Empty, bind_dst = {glob_object={fs_var}}} 
						(var_env, array_patterns, ps, e_info, cs)
		# (entry, cs_symbol_table) = readPtr fs_var.id_info cs.cs_symbol_table
		# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap
		  cs = checkPatternVariable pi_def_level entry fs_var new_info_ptr { cs & cs_symbol_table = cs_symbol_table }
		= (AP_Variable fs_var new_info_ptr No, ([ fs_var : var_env ], array_patterns, { ps & ps_var_heap = ps_var_heap }, e_info, cs))
	check_field_pattern p_input {bind_src = PE_WildCard, bind_dst={glob_object={fs_var}}} (var_env, array_patterns, ps, e_info, cs)
		# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap
		= (AP_WildCard (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), (var_env, array_patterns, { ps & ps_var_heap = ps_var_heap }, e_info, cs))
	check_field_pattern p_input {bind_src,bind_dst} (var_env, array_patterns, ps, e_info, cs)
		# (pattern, (var_env, array_patterns), ps, e_info, cs) = checkPattern bind_src No p_input (var_env, array_patterns) ps e_info cs
		= (pattern, (var_env, array_patterns, ps, e_info, cs))


	add_bound_variable (AP_Algebraic symbol index patterns No) {bind_dst = {glob_object={fs_var}}} ps_var_heap
		# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps_var_heap
		= (AP_Algebraic symbol index patterns (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), ps_var_heap)
	add_bound_variable (AP_Basic bas_val No) {bind_dst = {glob_object={fs_var}}} ps_var_heap
		# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps_var_heap
		= (AP_Basic bas_val (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), ps_var_heap)
	add_bound_variable (AP_Dynamic dynamic_pattern dynamic_type No) {bind_dst = {glob_object={fs_var}}} ps_var_heap
		# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps_var_heap
		= (AP_Dynamic dynamic_pattern dynamic_type (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), ps_var_heap)
	add_bound_variable pattern _ ps_var_heap
		= (pattern, ps_var_heap)

	add_bound_variables [] _ var_heap
		= ([] , var_heap)
	add_bound_variables [ap : aps] [field : fields] var_heap
		# (ap, var_heap) = add_bound_variable ap field var_heap
		  (aps, var_heap) = add_bound_variables aps fields var_heap
		= ([ap : aps], var_heap)

	bind_opt_record_variable (Yes {bind_dst}) False patterns fields var_heap
		# (patterns, var_heap) = add_bound_variables patterns fields var_heap
		= (patterns, var_heap <:= (bind_dst, VI_Record patterns))
	bind_opt_record_variable no is_node_pattern patterns _ var_heap
		= (patterns, var_heap)

checkPattern (PE_ArrayPattern selections) opt_var p_input (var_env, array_patterns) ps e_info cs
	# (var_env, ap_selections, ps_var_heap, cs)
			= foldSt (check_array_selection p_input.pi_def_level) selections (var_env, [], ps.ps_var_heap, cs)
	  array_var_ident = case opt_var of 
	  						Yes {bind_src}
	  							-> bind_src
	  						No
	  							-> { id_name = "_a", id_info = nilPtr }
	  (array_var, ps_var_heap) = allocate_free_var array_var_ident ps_var_heap
	= (AP_Variable array_var_ident array_var.fv_info_ptr No, 
		(var_env, [{ ap_opt_var = opt_var, ap_array_var = array_var, ap_selections = ap_selections } :array_patterns]),
		{ ps & ps_var_heap = ps_var_heap }, e_info, cs)
  where
	check_array_selection def_level bind=:{bind_dst} states
		= check_rhs def_level bind (foldSt check_index_expr bind_dst states)
		
	check_index_expr (PE_Ident {id_name}) states
		| isLowerCaseName id_name
			= states
		// further with next alternative
	check_index_expr (PE_Basic (BVI _)) states
			= states
	check_index_expr _ (var_env, ap_selections, var_heap, cs)
		= (var_env, ap_selections, var_heap, { cs & cs_error = checkError "" "variable or integer constant expected as index expression" cs.cs_error })

	check_rhs def_level {bind_src=PE_Ident ident, bind_dst} (var_env, ap_selections, var_heap, cs)
		| isLowerCaseName ident.id_name
			# (entry,cs_symbol_table) = readPtr ident.id_info cs.cs_symbol_table
			# (rhs_var, var_heap) = allocate_free_var ident var_heap
			  cs = checkPatternVariable def_level entry ident rhs_var.fv_info_ptr { cs & cs_symbol_table = cs_symbol_table }
			= ([ident : var_env], [ { bind_src = rhs_var, bind_dst = bind_dst } : ap_selections], var_heap, cs)
		// further with next alternative
	check_rhs _ _ (var_env, ap_selections, var_heap, cs)
		= (var_env, ap_selections, var_heap, 
			{ cs & cs_error = checkError "" "variable expected on right hand side of array pattern" cs.cs_error })

checkPattern (PE_Bound bind) opt_var p_input accus ps e_info cs
	= checkBoundPattern bind opt_var p_input accus ps e_info cs

checkPattern (PE_Ident id) opt_var p_input accus ps e_info cs
	= checkIdentPattern cIsNotInExpressionList id opt_var p_input accus ps e_info cs
checkPattern PE_WildCard opt_var p_input accus ps e_info cs
	= (AP_WildCard No, accus, ps, e_info, cs)
checkPattern expr opt_var p_input accus ps e_info cs
	= abort "checkPattern: do not know how to handle pattern" ---> expr

checkBoundPattern {bind_src,bind_dst} opt_var p_input (var_env, array_patterns) ps e_info cs=:{cs_symbol_table}
	| isLowerCaseName bind_dst.id_name
		# (entry, cs_symbol_table) = readPtr bind_dst.id_info cs_symbol_table