check.icl 248 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
3
4
implementation module check

import StdEnv

5
import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef //, RWSDebug
6
import explicitimports, comparedefimp
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
7
8
9

cPredefinedModuleIndex 	:== 1

clean's avatar
clean committed
10
11
12
13
isMainModule :: ModuleKind -> Bool
isMainModule MK_Main	= True
isMainModule _ 			= False

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
14
15
16
17
18
convertIndex :: !Index !Index !(Optional ConversionTable) -> !Index
convertIndex index table_index (Yes tables)
	= tables.[table_index].[index]
convertIndex index table_index No
	= index
clean's avatar
clean committed
19
	
20
getPredefinedGlobalSymbol :: !Index !Index !STE_Kind !Int !*CheckState -> (!Global DefinedSymbol, !*CheckState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
21
getPredefinedGlobalSymbol symb_index module_index req_ste_kind arity cs=:{cs_predef_symbols,cs_symbol_table}
22
23
24
	# (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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
25
	| mod_entry.ste_kind == STE_ClosedModule
26
27
		# (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}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
28
29
		= ({ 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},
30
				  		{ cs & cs_error = checkError mod_id "not imported" cs.cs_error, cs_predef_symbols = cs_predef_symbols, cs_symbol_table = cs_symbol_table })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
31
where
32
	get_predefined_symbol :: !Index !STE_Kind !Int !Index !*CheckState -> (!DefinedSymbol,!*CheckState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
33
	get_predefined_symbol symb_index req_ste_kind arity mod_index cs=:{cs_predef_symbols,cs_symbol_table,cs_error}
34
35
36
37
		# (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 }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
38
39
40
41
42
43
44
45
46
		| 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 })
		
47
checkTypeClasses :: !Index !Index !*{#ClassDef} !*{#MemberDef} !*{#CheckedTypeDef} !*{#DclModule} !*TypeHeaps !*CheckState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
48
	-> (!*{#ClassDef}, !*{#MemberDef}, !*{#CheckedTypeDef}, !*{#DclModule}, !*TypeHeaps, !*CheckState)
49
checkTypeClasses class_index module_index class_defs member_defs type_defs modules type_heaps=:{th_vars} cs=:{cs_symbol_table,cs_error}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
50
51
	| class_index == size class_defs
		= (class_defs, member_defs, type_defs, modules, type_heaps, cs)
52
		# (class_def=:{class_name,class_pos,class_args,class_context,class_members}, class_defs) = class_defs![class_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
53
54
55
56
57
58
59
60
61
62
		  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 
63
		= checkTypeClasses (inc class_index) module_index class_defs member_defs type_defs modules type_heaps { cs & cs_symbol_table = cs_symbol_table }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
64
65
66
67
68
69
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
70
	  	# (entry, symbol_table) = readPtr id_info symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
71
72
73
74
75
76
		| 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)

77
	retrieve_variables_from_symbol_table :: ![TypeVar] ![TypeVar] !*SymbolTable -> (![TypeVar],!*SymbolTable)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
78
	retrieve_variables_from_symbol_table [var=:{tv_name={id_name,id_info}} : vars] class_args symbol_table
79
		# (entry, symbol_table) = readPtr id_info symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
80
81
82
83
84
85
86
87
		= 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]
88
			# (member_def, member_defs) = member_defs![ds_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
			= 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)

109
110
checkDclFunctions :: !Index !Index ![FunType] !v:{#CheckedTypeDef} !x:{#ClassDef} !v:{#.DclModule} !*Heaps !*CheckState
	-> (!Index, ![FunType], ![FunType], !v:{#CheckedTypeDef}, !x:{#ClassDef}, !v:{#DclModule}, !*Heaps, !*CheckState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
111
112
113
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
114
115
	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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
	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
157
158
	check_and_build_members :: !Index !Index !Int {# DefinedSymbol} !Int !Index ![DefinedSymbol] ![FunType] !{#FunType} !*{! [Special]} !*Heaps !*ErrorAdmin
		-> (!Index, ![DefinedSymbol], ![FunType], !*{! [Special]}, !*Heaps, !*ErrorAdmin)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
159
160
161
162
163
164
	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
165
		 	# (spec_types, all_spec_types) = all_spec_types![spec_member_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
		 	# 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
215
216
			# (instance_def, instance_defs) = instance_defs![inst_index]
			  (instance_def, is, type_heaps, cs) = check_instance mod_index instance_def is type_heaps cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
217
218
219
220
221
222
223
			= 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}
224
		# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
225
226
		# (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 }
227
		  cs = pushErrorAdmin (newPosition ins_ident ins_pos) { cs & cs_symbol_table = cs_symbol_table }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
228
229
		| class_index <> NotFound
			| class_def.class_arity == ds_arity
Martin Wierich's avatar
Martin Wierich committed
230
231
232
233
				# ins_class = { glob_object = { class_name & ds_index = class_index }, glob_module = class_mod_index}
				  (ins_type, ins_specials, is_type_defs, is_class_defs, is_modules, type_heaps, cs)
				  		= checkInstanceType module_index ins_class ins_type ins_specials
								is.is_type_defs is.is_class_defs is.is_modules type_heaps cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
234
235
236
237
238
239
240
241
242
243
244
				  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
245
		# (class_def, class_defs) = class_defs![ste_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
246
247
		= (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
248
249
		# (dcl_mod, modules) = modules![dcl_index]
		# class_def = dcl_mod.dcl_common.com_class_defs.[ste_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
250
251
		= (ste_index, dcl_index, class_def, class_defs, modules)
	get_class_def _ mod_index class_defs modules
252
		= (NotFound, -1/*cIclModIndex*/, abort "no class definition", class_defs, modules)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
	
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
269
			# ({ins_class,ins_members,ins_type}, instance_defs) = instance_defs![inst_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
270
271
272
273
274
275
276
277
278
279
			# ({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)

280
281
282
	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)
283

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
	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
307
		# (class_def, class_defs) = class_defs![ds_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
308
		= (class_def, class_defs, modules)
309
		# (dcl_mod, modules) = modules![glob_module]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
310
311
312
313
314
		= (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
315
		# (member_def,member_defs) = member_defs![mem_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
316
		= (member_def, member_defs, modules)
317
		# (dcl_mod,modules) = modules![mem_mod]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
		= (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
427
			# (instance_def, instance_defs) = instance_defs![inst_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
			# {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 })
521
522
523
			Yes _
				# (Yes type_ident) = opt_type
				-> (No, e_info, { cs & cs_error = checkError type_ident "not a record constructor" cs.cs_error })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
524
525
526
527
528
529
			No
				-> (No, e_info, cs)
		= (No, e_info, cs)
where

	check_fields [ bind=:{bind_dst} : field_ass ] cs=:{cs_symbol_table,cs_error}
530
		# (entry, cs_symbol_table) = readPtr bind_dst.id_info cs_symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
531
532
		# fields = retrieveSelectorIndexes mod_index entry 
		| isEmpty fields
533
534
			= (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 }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
535
536
537
538
539
540
541
542
543
544
545
546
			= (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}
547
548
		# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
		# (type_index, type_mod_index) = retrieveGlobalDefinition entry STE_Type mod_index
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
549
550
		| type_index <> NotFound
			| mod_index == type_mod_index
551
552
			 	# (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 })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
553
				# (type_def, modules) = modules![type_mod_index].dcl_common.com_type_defs.[type_index]
554
555
				= (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})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
556
557
558
559
560
	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
561
562
					# (selector_def, selector_defs) = selector_defs![glob_object]
					  (type_def, type_defs) = type_defs![selector_def.sd_type_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
563
					-> (Yes (type_def, glob_module), selector_defs, type_defs, modules, cs)
564
565
566
					# ({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]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
567
568
569
570
					-> (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 })

571
	check_and_rearrange_fields :: Int Int {#FieldSymbol} ![Bind ParsedExpr (Ident,[Global .Int])] *ErrorAdmin -> ([Bind ParsedExpr .(Global FieldSymbol)],!.ErrorAdmin);
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
572
573
574
575
576
	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)
577
578
579
		| isEmpty field_ass
			= ([], cs_error)
			= ([], foldSt field_error field_ass cs_error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604

	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}
605
	,	ef_is_macro_fun		:: !Bool
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
606
607
608
	}

::	ExpressionState =
609
	{	es_expr_heap	:: !.ExpressionHeap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
	,	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 })
673

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
674
675
676
677
		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)
678
679
				# ({dcl_common,dcl_conversions}, modules) = modules![cons_mod]
				  cons_def = dcl_common.com_cons_defs.[cons_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
680
				= (cons_def, convertIndex cons_index (toInt STE_Constructor) dcl_conversions, cons_defs, modules)
681
		get_cons_def mod_index cons_mod cons_index cons_defs modules
682
683
			# ({dcl_common,dcl_conversions}, modules) = modules![cons_mod]
			  cons_def = dcl_common.com_cons_defs.[cons_index]
684
			= (cons_def, convertIndex cons_index (toInt STE_Constructor) dcl_conversions, cons_defs, modules)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703

	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 })
704
checkPatternConstructor mod_index is_expr_list {ste_kind = STE_FunctionOrMacro _,ste_index} ident opt_var  ps=:{ps_fun_defs} e_info cs=:{cs_error,cs_x}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
705
706
	# ({fun_symb,fun_arity,fun_kind,fun_priority},ps_fun_defs) = ps_fun_defs![ste_index]
	  ps = { ps & ps_fun_defs = ps_fun_defs }
707
	| case fun_kind of FK_DefMacro->True ; FK_ImpMacro->True; _ -> False
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
708
		| is_expr_list
709
			# macro_symbol = { glob_object = MakeDefinedSymbol fun_symb ste_index fun_arity, glob_module = cs_x.x_main_dcl_module_n }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
	 		= (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
730
		# ({cons_type={st_arity},cons_priority, cons_type_index}, cons_defs) = cons_defs![id_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
731
732
		= (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
733
734
		# ({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]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
735
736
737
738
739
		  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)

740
741
742
743
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}
744
	# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
745
746
	| isLowerCaseName id_name
		# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap
747
		  cs = checkPatternVariable pi_def_level entry id new_info_ptr { cs & cs_symbol_table = cs_symbol_table }
748
		= (AP_Variable id new_info_ptr opt_var, ([ id : var_env ], array_patterns), { ps & ps_var_heap = ps_var_heap}, e_info, cs)
749
		# (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 }
750
		= (pattern, accus, ps, e_info, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
751
752
753
754
755

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

Martin Wierich's avatar
Martin Wierich committed
757
758
759
760
761
::	PatternInput =
	{	pi_def_level		:: !Int
	,	pi_mod_index		:: !Index
	,	pi_is_node_pattern	:: !Bool
	}
762
763
764
765
	
::	ArrayPattern =
	{	ap_opt_var		:: !Optional (Bind Ident VarInfoPtr)
	,	ap_array_var	:: !FreeVar
766
	,	ap_selections	:: ![Bind FreeVar [ParsedExpr]]
767
	}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
768
769
770
771
772
773
774
775

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 })

776
777
778
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}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
779
780
	= case exp of
		PE_Ident ident
781
			-> checkIdentPattern cIsNotInExpressionList ident opt_var p_input accus ps e_info cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
782
		_
783
			-> checkPattern exp opt_var p_input accus ps e_info cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
784

785
786
787
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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
788
	where
789
790
		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
791
			  (pat, ps, e_info, cs) = combine_patterns pi_mod_index opt_var [mid_pat : left] [] 0 ps e_info cs
792
793
794
			= (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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
795
796
797
			= case mid_pat of
				AP_Constant kind constant=:{glob_object={ds_arity,ds_ident}} prio
					| ds_arity == 0
Martin Wierich's avatar
Martin Wierich committed
798
						# (pattern, ps, e_info, cs) = buildPattern pi_mod_index kind constant [] No ps e_info cs
799
						-> check_patterns [pattern: left] right rest opt_var p_input accus ps e_info cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
800
					| is_infix_constructor prio
801
						# (left_arg, ps, e_info, cs) = combine_patterns pi_mod_index No left [] 0 ps e_info cs
802
						  (right_pat, accus, ps, e_info, cs) = check_pattern right p_input accus ps e_info cs
803
						-> check_infix_pattern [] left_arg kind constant prio [right_pat] rest
804
805
									opt_var p_input accus ps e_info cs
						-> (AP_Empty ds_ident, accus, ps, e_info,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
806
807
								{ cs & cs_error = checkError ds_ident "arguments of constructor are missing" cs.cs_error })
				_
808
					-> check_patterns [mid_pat : left] right rest opt_var p_input accus ps e_info cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
809

810
811
812
813
		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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
814
		
815
	 	check_infix_pattern left_args left kind cons prio middle [] opt_var p_input=:{pi_mod_index} accus ps e_info cs
816
817
			# (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
Martin Wierich's avatar
Martin Wierich committed
818
			  (pattern, ps, e_info, cs) = build_final_pattern pi_mod_index left_args pattern ps e_info cs
819
820
821
			= (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
822
			  (right_arg, ps, e_info, cs) = combine_patterns pi_mod_index No [right_pat : middle] [] 0 ps e_info cs
Martin Wierich's avatar
Martin Wierich committed
823
824
			  (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
825
826
827
			= (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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
828
829
830
			= case inf_cons_pat of
				AP_Constant kind2 cons2=:{glob_object={ds_ident,ds_arity}} prio2
					| ds_arity == 0
831
						# (middle_pat, ps, e_info, cs) = combine_patterns pi_mod_index No middle [] 0 ps e_info cs
Martin Wierich's avatar
Martin Wierich committed
832
						  (pattern2, ps, e_info, cs) = buildPattern pi_mod_index kind2 cons2 [] No ps e_info cs
833
						  (pattern1, ps, e_info, cs) = buildPattern pi_mod_index kind1 cons1 [left,middle_pat] No ps e_info cs
Martin Wierich's avatar
Martin Wierich committed
834
						  (pattern1, ps, e_info, cs) = build_final_pattern pi_mod_index left_args pattern1 ps e_info cs
835
						-> check_patterns [pattern2,pattern1] arg rest opt_var p_input accus ps e_info cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
836
					| is_infix_constructor prio2
837
838
839
						# optional_prio = determinePriority prio1 prio2
						-> case optional_prio of
							Yes priority
840
								# (arg_pat, accus, ps, e_info, cs) = check_pattern arg p_input accus ps e_info cs
841
								| priority
842
843
									# (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
Martin Wierich's avatar
Martin Wierich committed
844
								      (left_args, pattern, ps, e_info, cs) = build_left_pattern pi_mod_index left_args prio2 pattern ps e_info cs
845
									-> check_infix_pattern left_args pattern kind2 cons2 prio2 [arg_pat] rest opt_var p_input accus ps e_info cs 
846
847
									# (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]
848
									  				middle_pat kind2 cons2 prio2 [arg_pat] rest No p_input accus ps e_info cs
849
							No
850
851
								-> (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 })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
852
				_
853
					-> check_infix_pattern left_args left kind1 cons1 prio1 [inf_cons_pat : middle] [arg : rest] opt_var p_input accus ps e_info cs 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
854
855
856
857
858
859
860

		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
861
862
863
864
865
866
867
868
869
			# 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 })
Martin Wierich's avatar
Martin Wierich committed
870

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
871
872
873
874
875
876
		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

Martin Wierich's avatar
Martin Wierich committed
877
		combine_patterns mod_index opt_var [first_expr] args nr_of_args ps e_info cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
878
879
880
881
882
883
884
885
886
887
			= 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 })
Martin Wierich's avatar
Martin Wierich committed
888
889
		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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
890
891
892
893
894
895
896
897
898
/*
		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)
*/

899
checkPattern (PE_DynamicPattern pattern type) opt_var p_input accus ps e_info cs=:{cs_x}
900
	# (dyn_pat, accus, ps, e_info, cs) = checkPattern pattern No p_input accus ps e_info cs
901
	= (AP_Dynamic dyn_pat type opt_var, accus, ps, e_info, { cs & cs_x.x_needed_modules = cs_x.x_needed_modules bitor cNeedStdDynamics })
Martin Wierich's avatar
Martin Wierich committed
902

903
904
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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
905

906
907
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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
908
	  (tuple_symbol, cs) = getPredefinedGlobalSymbol (GetTupleConsIndex arity) PD_PredefinedModule STE_Constructor arity cs
909
	# ({cons_type_index}, e_info) = e_info!ef_modules.[tuple_symbol.glob_module].dcl_common.com_cons_defs.[tuple_symbol.glob_object.ds_index]
910
	= (AP_Algebraic tuple_symbol cons_type_index patterns opt_var, accus, ps, e_info, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
911
where
912
913
914
915
916
917
918
	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
Martin Wierich's avatar
Martin Wierich committed
919
	# (opt_record_and_fields, e_info, cs) = checkFields pi_mod_index fields opt_type e_info cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
920
921
	= case opt_record_and_fields of
		Yes (record_symbol, type_index, new_fields)
922
			# (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)
Martin Wierich's avatar
Martin Wierich committed
923
			  (patterns, ps_var_heap) = bind_opt_record_variable opt_var pi_is_node_pattern patterns new_fields ps.ps_var_heap
924
			-> (AP_Algebraic record_symbol type_index patterns opt_var, (var_env, array_patterns), { ps & ps_var_heap = ps_var_heap }, e_info, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
925
		No
926
			-> (AP_Empty (hd fields).bind_dst, accus, ps, e_info, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
927
928
where

929
930
	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)
931
		# (entry, cs_symbol_table) = readPtr fs_var.id_info cs.cs_symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
932
		# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap
933
		  cs = checkPatternVariable pi_def_level entry fs_var new_info_ptr { cs & cs_symbol_table = cs_symbol_table }
934
935
		= (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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
936
		# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap
937
938
939
940
		= (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))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
941
942
943
944
945
946
947
948


	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)
949
	add_bound_variable (AP_Dynamic dynamic_pattern dynamic_type No) {bind_dst = {glob_object={fs_var}}} ps_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
950
		# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps_var_heap
951
		= (AP_Dynamic dynamic_pattern dynamic_type (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), ps_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
952
953
954
955
956
957
958
959
960
961
	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)

Martin Wierich's avatar
Martin Wierich committed
962
	bind_opt_record_variable (Yes {bind_dst}) False patterns fields var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
963
964
		# (patterns, var_heap) = add_bound_variables patterns fields var_heap
		= (patterns, var_heap <:= (bind_dst, VI_Record patterns))
Martin Wierich's avatar
Martin Wierich committed
965
	bind_opt_record_variable no is_node_pattern patterns _ var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
966
967
		= (patterns, var_heap)

968
969
970
971
972
973
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)
974
975
976
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)
977
978
979
980
981
	  array_var_ident = case opt_var of 
	  						Yes {bind_src}
	  							-> bind_src
	  						No
	  							-> { id_name = "_a", id_info = nilPtr }
982
983
984
985
986
987
	  (array_var, ps_var_heap) = allo