check.icl 198 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
6
import explicitimports, comparedefimp, checkFunctionBodies, containers, portToNewSyntax, compilerSwitches
7
// import RWSDebug
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
8

9
10
cUndef :== (-1)
cDummyArray :== {}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
11

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

16
17
18
19
20
21
22
23
24
checkGenerics :: !Index !Index !*{#GenericDef} !*{#ClassDef} !*{#CheckedTypeDef} !*{#DclModule} !*TypeHeaps !*CheckState
	-> (!*{#GenericDef}, !*{#ClassDef}, !*{#CheckedTypeDef}, !*{#DclModule}, !*TypeHeaps, !*CheckState)
checkGenerics 
		gen_index module_index generic_defs class_defs type_defs modules 
		type_heaps=:{th_vars} 
		cs=:{cs_symbol_table, cs_error}
	| gen_index == size generic_defs
		= (generic_defs, class_defs, type_defs, modules, type_heaps, cs)
	// otherwise
25
		# (generic_def=:{gen_name, gen_type, gen_pos}, generic_defs) = generic_defs![gen_index]
26
27
28
		# position = newPosition gen_name gen_pos
		# cs_error = setErrorAdmin position cs_error

29
30
31
		// add * for kind-star instances and *->* for arrays
		# kinds = 
			[	KindConst
32
			, 	KindArrow [KindConst]
33
34
			]
		# (kinds_ptr, th_vars) = newPtr (TVI_Kinds kinds) th_vars
35
		# (cons_ptr, th_vars) = newPtr (TVI_Empty) th_vars
36

37
38
		# cs = {cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }
		# type_heaps = {type_heaps & th_vars = th_vars}
39

40
41
		# (gt_type, type_defs, class_defs, modules, type_heaps, cs) =
			checkMemberType module_index gen_type.gt_type type_defs class_defs modules type_heaps cs
42

43
44
		#! {cs_error} = cs
		#! (gt_vars, st_vars, cs_error) = split_vars gen_type.gt_vars  gt_type.st_vars cs_error
45

Artem Alimarine's avatar
Artem Alimarine committed
46
/*
47
48
49
		#! cs_error = case gt_type.st_context of
			[] -> cs_error 
			_  -> checkError "" "class contexts are not supported in generic types" cs_error   
Artem Alimarine's avatar
Artem Alimarine committed
50
*/
51

52
53
54
		#! cs = {cs & cs_error = cs_error}
		#! gt_type = {gt_type & st_vars = st_vars}

55
56
57
58
		# generic_def =
			{	generic_def &
				gen_type = { gen_type & gt_vars = gt_vars, gt_type = gt_type }
			,	gen_kinds_ptr = kinds_ptr
59
			, 	gen_cons_ptr = cons_ptr
60
61
62
			}

		# generic_defs = {generic_defs & [gen_index] = generic_def}				
63
64
		= checkGenerics (inc gen_index) module_index generic_defs class_defs type_defs modules type_heaps cs
where	
65
66
67
68
69
70
71
72
73
74
75
76
77
78
	split_vars [] st_vars error
		= ([], st_vars, error)
	split_vars [gv:gvs] st_vars error
		# (gv, st_vars, error) = find gv st_vars error
		# (gvs, st_vars, error) = split_vars gvs st_vars error
		= ([gv:gvs], st_vars, error) 
	where
		find gv [] error = (gv, [], checkError gv.tv_name.id_name "generic variable not used" error)
		find gv	[st_var:st_vars] error
			| st_var.tv_name.id_name == gv.tv_name.id_name
				= (st_var, st_vars, error)
				# (gv, st_vars, error) = find gv st_vars error 
				= (gv, [st_var:st_vars], error)
				
79
checkTypeClasses :: !Index !(Optional (CopiedDefinitions, Int)) !*{#ClassDef} !*{#MemberDef} !*{#CheckedTypeDef} !*{#DclModule} !*TypeHeaps !*CheckState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
80
	-> (!*{#ClassDef}, !*{#MemberDef}, !*{#CheckedTypeDef}, !*{#DclModule}, !*TypeHeaps, !*CheckState)
81
82
83
checkTypeClasses module_index opt_icl_info class_defs member_defs type_defs modules type_heaps cs
	#! n_classes = size class_defs
	= iFoldSt (check_type_class module_index opt_icl_info) 0 n_classes (class_defs, member_defs, type_defs, modules, type_heaps, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
84
where
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
	check_type_class module_index opt_icl_info class_index (class_defs, member_defs, type_defs, modules, type_heaps, cs=:{cs_symbol_table,cs_error})
		| has_to_be_checked module_index opt_icl_info class_index
			# (class_def=:{class_name,class_pos,class_args,class_context,class_members}, class_defs) = class_defs![class_index]
			  cs = {cs & cs_error = setErrorAdmin (newPosition class_name class_pos) cs_error }
			  (class_args, class_context, type_defs, class_defs, modules, type_heaps, cs)
			  		= checkSuperClasses class_args class_context module_index type_defs class_defs modules type_heaps cs
			  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 
			= (class_defs, member_defs, type_defs, modules, type_heaps, cs)
			= (class_defs, member_defs, type_defs, modules, type_heaps, cs)

	has_to_be_checked module_index No class_index
		= True
	has_to_be_checked module_index (Yes ({copied_class_defs}, n_cached_dcl_mods)) class_index
		= not (module_index < n_cached_dcl_mods && class_index < size copied_class_defs && copied_class_defs.[class_index])

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
101
102
103
104
	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]
105
			# (member_def, member_defs) = member_defs![ds_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
106
107
			= set_classes_in_member_defs (inc mem_offset) class_members glob_class_index { member_defs & [ds_index] = { member_def & me_class = glob_class_index }}

108
109
110
checkSpecial :: !Index !FunType !Index !SpecialSubstitution !(!Index, ![FunType], !*Heaps,!*PredefinedSymbols,!*ErrorAdmin)
	-> (!Special, !(!Index, ![FunType], !*Heaps,!*PredefinedSymbols, !*ErrorAdmin))
checkSpecial mod_index fun_type=:{ft_type} fun_index subst (next_inst_index, special_types, heaps, predef_symbols,error)
Martin Wierich's avatar
Martin Wierich committed
111
	# (special_type, hp_type_heaps, error) = substitute_type ft_type subst heaps.hp_type_heaps error
112
	  (spec_types, predef_symbols, error) = checkAndCollectTypesOfContextsOfSpecials special_type.st_context predef_symbols error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
113
114
115
116
	  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 ],
117
					{ heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap }, predef_symbols, error))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
118
where	
Martin Wierich's avatar
Martin Wierich committed
119
	substitute_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment type_heaps error
120
121
		# (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, _, type_heaps, error)
			= instantiateTypes st_vars st_attr_vars [ st_result : st_args ] st_context st_attr_env environment [] type_heaps error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
122
		= ({st & st_vars = st_vars, st_args = st_args, st_result = st_result, st_attr_vars = st_attr_vars,
Martin Wierich's avatar
Martin Wierich committed
123
			st_context = st_context, st_attr_env = st_attr_env }, type_heaps, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
124

125
126
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
127
128
129
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
130
131
	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
132
133
134
135
136
137
138
	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)
139
		  		= checkFunctionType module_index ft_type ft_specials type_defs class_defs modules heaps.hp_type_heaps cs
140
		  (spec_types, next_inst_index, collected_instances, heaps, cs_predef_symbols,cs_error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
141
		  		= check_specials module_index { fun_type & ft_type = ft_type } fun_index ft_specials next_inst_index collected_instances
142
		  				{ heaps & hp_type_heaps = hp_type_heaps } cs.cs_predef_symbols cs.cs_error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
143
144
145
		  (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]
146
147
148
149
150
151
152
153
154
155
156
157
158
					collected_instances type_defs class_defs modules { heaps & hp_var_heap = hp_var_heap } { cs & cs_predef_symbols=cs_predef_symbols,cs_error = cs_error }

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

checkSpecialsOfInstances :: !Index !Index ![ClassInstance] !Index ![ClassInstance] ![FunType] {# FunType} *{! [Special] } !*Heaps !*PredefinedSymbols !*ErrorAdmin
		-> (!Index, ![ClassInstance], ![FunType], !*{! [Special]}, !*Heaps, !*PredefinedSymbols,!*ErrorAdmin)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
159
checkSpecialsOfInstances mod_index first_mem_index [class_inst=:{ins_members,ins_specials} : class_insts] next_inst_index all_class_instances all_specials
160
		new_inst_defs all_spec_types heaps predef_symbols error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
161
162
	= case ins_specials of
		SP_TypeOffset type_offset
163
164
			# (next_inst_index, rev_mem_specials, all_specials, all_spec_types, heaps,predef_symbols, 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 predef_symbols error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
165
166
			  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]
167
					all_specials new_inst_defs all_spec_types heaps predef_symbols error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
168
169
		SP_None
			-> checkSpecialsOfInstances mod_index first_mem_index class_insts next_inst_index [class_inst : all_class_instances]
170
					all_specials new_inst_defs all_spec_types heaps predef_symbols error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
171
where
172
173
	check_and_build_members :: !Index !Index !Int {# DefinedSymbol} !Int !Index ![DefinedSymbol] ![FunType] !{#FunType} !*{! [Special]} !*Heaps !*PredefinedSymbols !*ErrorAdmin
		-> (!Index, ![DefinedSymbol], ![FunType], !*{! [Special]}, !*Heaps, !*PredefinedSymbols,!*ErrorAdmin)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
174
	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
175
			all_spec_types heaps predef_symbols error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
176
177
178
179
		| member_offset < size ins_members
			# member = ins_members.[member_offset]
			  member_index = member.ds_index
			  spec_member_index = member_index - first_mem_index
180
		 	# (spec_types, all_spec_types) = all_spec_types![spec_member_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
181
182
183
184
		 	# 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 }
185
186
			  (spec_type, (next_inst_index, all_specials, heaps, predef_symbols,error))
			  		= checkSpecial mod_index mem_inst member_index env (next_inst_index, all_specials, heaps, predef_symbols,error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
187
188
			  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 ]
189
190
191
192
					all_specials inst_spec_defs all_spec_types heaps predef_symbols error
			= (next_inst_index, rev_mem_specials, all_specials, all_spec_types, heaps, predef_symbols,error)
checkSpecialsOfInstances mod_index first_mem_index [] next_inst_index all_class_instances all_specials inst_spec_defs all_spec_types heaps predef_symbols error
	= (next_inst_index, all_class_instances, all_specials, all_spec_types, heaps, predef_symbols,error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
193

194
checkMemberTypes :: !Index !(Optional (CopiedDefinitions, Int)) !*{#MemberDef} !*{#CheckedTypeDef} !*{#ClassDef} !*{#DclModule} !*TypeHeaps !*VarHeap !*CheckState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
195
	-> (!*{#MemberDef}, !*{#CheckedTypeDef}, !*{#ClassDef}, !*{#DclModule}, !*TypeHeaps,  !*VarHeap, !*CheckState)
196
checkMemberTypes module_index opt_icl_info member_defs type_defs class_defs modules type_heaps var_heap cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
197
	#! nr_of_members = size member_defs
198
	= iFoldSt (check_class_member module_index opt_icl_info) 0 nr_of_members (member_defs, type_defs, class_defs, modules, type_heaps, var_heap, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
199
where
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
	check_class_member module_index opt_icl_info member_index (member_defs, type_defs, class_defs, modules, type_heaps, var_heap, cs)
		# (member_def=:{me_symb,me_type,me_pos,me_class}, member_defs) = member_defs![member_index]
		| has_to_be_checked opt_icl_info me_class
			# 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)
			   		= checkMemberType module_index me_type type_defs class_defs modules type_heaps cs
			  me_class_vars = [ type_var \\ (TV 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)
			= (member_defs, type_defs, class_defs, modules, type_heaps, var_heap, cs)

	has_to_be_checked No glob_class_index
		= True
	has_to_be_checked (Yes ({copied_class_defs}, n_cached_dcl_mods)) {glob_module,glob_object}
		= not (glob_module < n_cached_dcl_mods && glob_object < size copied_class_defs && copied_class_defs.[glob_object])
217

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
218
219
220
221
::	InstanceSymbols =
	{	is_type_defs		:: !.{# CheckedTypeDef}
	,	is_class_defs		:: !.{# ClassDef}
	,	is_member_defs		:: !.{# MemberDef}
222
	, 	is_generic_defs		:: !.{# GenericDef} // AA
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
223
224
225
	,	is_modules			:: !.{# DclModule}
	}

226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
// AA..
checkInstanceDefs :: !Index !*{#ClassInstance} !u:{#CheckedTypeDef} !u:{#ClassDef} !u:{#MemberDef} /*AA*/!u:{#GenericDef} !u:{#DclModule} !*TypeHeaps !*CheckState
	-> (!.{#ClassInstance},!u:{#CheckedTypeDef},!u:{#ClassDef},!u:{#MemberDef}, /*AA*/!u:{#GenericDef}, !u:{#DclModule},!.TypeHeaps,!.CheckState)
checkInstanceDefs mod_index instance_defs type_defs class_defs member_defs generic_defs modules type_heaps cs
	# is = { is_type_defs = type_defs, is_class_defs = class_defs, is_member_defs = member_defs, /*AA*/is_generic_defs = generic_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, /*AA*/is.is_generic_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)
242

243
244
245
246
247
248
249
250
251
252
	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_generic_defs, is_modules} type_heaps cs=:{cs_symbol_table}
		#  	(entry, cs_symbol_table) = readPtr id_info cs_symbol_table
		# 	cs = pushErrorAdmin (newPosition ins_ident ins_pos) { cs & cs_symbol_table = cs_symbol_table }
		#   (ins, is, type_heaps, cs) = case entry.ste_kind of
				STE_Class				
					# (class_def, is) = class_by_index entry.ste_index is
					-> check_class_instance	class_def module_index entry.ste_index module_index ins is type_heaps cs 
253
254
255
				STE_Imported STE_Class decl_index	
					# (class_def, is) = class_by_module_index decl_index entry.ste_index is
					-> check_class_instance class_def module_index entry.ste_index decl_index ins is type_heaps cs
256
257
258
				STE_Generic 
					# (generic_def, is) = generic_by_index entry.ste_index is
					-> check_generic_instance generic_def module_index entry.ste_index module_index ins is type_heaps cs
259
260
261
				STE_Imported STE_Generic decl_index	
					# (gen_def, is) = generic_by_module_index decl_index entry.ste_index is
					-> check_generic_instance gen_def module_index entry.ste_index decl_index ins is type_heaps cs
262
263
264
265
266
267
268
				ste -> (ins, is, type_heaps, { cs & cs_error = checkError id_name "class or generic undefined" cs.cs_error })
		= (ins, is, type_heaps, popErrorAdmin cs)

	where
			class_by_index class_index is=:{is_class_defs}
				#	(class_def, is_class_defs) = is_class_defs![class_index]
 				= (class_def, {is & is_class_defs = is_class_defs})
269
270
			class_by_module_index decl_index class_index is=:{is_modules}
 				# 	(dcl_mod, is_modules) = is_modules![decl_index]
271
272
273
274
275
					class_def = dcl_mod.dcl_common.com_class_defs.[class_index]
				= (class_def, {is & is_modules = is_modules })
			generic_by_index gen_index is=:{is_generic_defs}
				# 	(gen_def, is_generic_defs) = is_generic_defs![gen_index]
				= (gen_def, {is & is_generic_defs = is_generic_defs})
276
277
			generic_by_module_index decl_index gen_index is=:{is_modules}	
 				# 	(dcl_mod, is_modules) = is_modules![decl_index]
278
279
280
281
282
283
284
285
286
					gen_def = dcl_mod.dcl_common.com_generic_defs.[gen_index]
				= (gen_def, {is & is_modules = is_modules })
				
	check_class_instance :: ClassDef !Index !Index !Index !ClassInstance !u:InstanceSymbols !*TypeHeaps !*CheckState 
		-> (!ClassInstance, !u:InstanceSymbols, !*TypeHeaps, !*CheckState)
	check_class_instance class_def module_index class_index class_mod_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,ins_generate}
			is=:{is_class_defs,is_modules} type_heaps cs=:{cs_symbol_table}	
		| ins_generate
287
			= ( ins, is, type_heaps
288
289
290
291
292
293
294
295
296
297
			  , { cs & cs_error = checkError id_name "cannot generate class instance" cs.cs_error }
			  )
		| class_def.class_arity == ds_arity
			# 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
			  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, cs)
		// otherwise
298
			= ( ins, is, type_heaps
299
300
301
302
			  , { cs & cs_error = checkError id_name ("wrong arity: expected "+++toString class_def.class_arity+++" found "+++toString ds_arity) cs.cs_error }
			  )
	check_generic_instance :: GenericDef !Index !Index !Index !ClassInstance !u:InstanceSymbols !*TypeHeaps !*CheckState -> (!ClassInstance, !u:InstanceSymbols, !*TypeHeaps, !*CheckState)
	check_generic_instance 
303
304
			{gen_member_name} 
			module_index generic_index generic_module_index
305
306
			ins=:{
				ins_class={glob_object = class_name =: {ds_ident = {id_name,id_info},ds_arity, ds_index} },
307
				ins_members, ins_type, ins_specials, ins_pos, ins_ident, ins_is_generic, ins_generate
308
				}
309
310
311
312
313
314
315
316
317
318
			is=:{is_class_defs,is_modules} 
			type_heaps 
			cs=:{cs_symbol_table, cs_error}
		# class_name = {class_name & ds_index = generic_index}	
		# ins_class = { glob_object = class_name, glob_module = generic_module_index}
		| ds_arity == 1
			# (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
			# is = { is & is_type_defs = is_type_defs, is_class_defs = is_class_defs, is_modules = is_modules }		 
319
320
321
322
323
324
325
326
327
328
			# ins = 
				{ ins 
				& ins_is_generic = True
				, ins_generic = {glob_module = generic_module_index, glob_object = generic_index}
				, ins_class = ins_class
				, ins_type = ins_type 
				, ins_specials = ins_specials
				, ins_members = if ins_generate 
					{{ds_arity = 0, ds_index = NoIndex, ds_ident = gen_member_name}}
					ins_members	
329
330
331
				}  
			= (ins, is, type_heaps, cs)
		// otherwise
332
			# cs_error = checkError id_name "arity of a generic instance must be 1" cs_error 
333
334
			# cs = {cs & cs_error = cs_error}
			= (ins, is, type_heaps, cs)
335

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
336
337
checkInstances :: !Index !*CommonDefs !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
	-> (![(Index,SymbolType)], !*CommonDefs, !u:{# DclModule}, !*VarHeap , !*TypeHeaps, !*CheckState)
Martin Wierich's avatar
Martin Wierich committed
338
checkInstances mod_index icl_common=:{com_instance_defs,com_class_defs,com_member_defs,com_generic_defs,com_type_defs} modules var_heap type_heaps cs=:{cs_error}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
339
	| cs_error.ea_ok
Martin Wierich's avatar
Martin Wierich committed
340
341
342
		# (instance_types, com_instance_defs, com_class_defs, com_member_defs, com_generic_defs, com_type_defs, modules, var_heap, type_heaps, cs)
				= check_instances 0 mod_index [] com_instance_defs com_class_defs com_member_defs /*AA*/com_generic_defs com_type_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, /*AA*/com_generic_defs = com_generic_defs, com_type_defs = com_type_defs },
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
343
344
345
			 	modules, var_heap, type_heaps, cs)
		= ([], icl_common, modules, var_heap, type_heaps, cs)
where
Martin Wierich's avatar
Martin Wierich committed
346
	check_instances :: !Index !Index ![(Index,SymbolType)] !x:{# ClassInstance} !w:{# ClassDef} !v:{# MemberDef} /*AA*/!w:{# GenericDef} !nerd:{# CheckedTypeDef} !u:{# DclModule}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
347
		!*VarHeap !*TypeHeaps !*CheckState
Martin Wierich's avatar
Martin Wierich committed
348
349
			-> (![(Index,SymbolType)], !x:{# ClassInstance}, !w:{# ClassDef}, !v:{# MemberDef}, /*AA*/!w:{# GenericDef}, !nerd:{# CheckedTypeDef}, !u:{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState)
	check_instances inst_index mod_index instance_types instance_defs class_defs member_defs generic_defs type_defs modules var_heap type_heaps cs
350
		| inst_index < size instance_defs
Martin Wierich's avatar
Martin Wierich committed
351
352
			# (instance_def=:{ins_ident,ins_is_generic, ins_pos}, instance_defs) = instance_defs![inst_index]
			# (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs) =
353
				(if ins_is_generic check_generic_instance check_class_instance)  
Martin Wierich's avatar
Martin Wierich committed
354
355
					instance_def mod_index instance_types class_defs member_defs generic_defs type_defs modules var_heap type_heaps cs				 
			= check_instances (inc inst_index) mod_index instance_types instance_defs class_defs member_defs generic_defs type_defs modules var_heap type_heaps cs 
356
		// otherwise
Martin Wierich's avatar
Martin Wierich committed
357
			= (instance_types, instance_defs, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
358

Martin Wierich's avatar
Martin Wierich committed
359
	check_class_instance {ins_pos,ins_class,ins_members,ins_type} mod_index instance_types class_defs member_defs generic_defs type_defs modules var_heap type_heaps cs
360
361
362
			# ({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
Martin Wierich's avatar
Martin Wierich committed
363
364
365
366
				# (instance_types, member_defs, type_defs, modules, var_heap, type_heaps, cs) 
						= check_member_instances mod_index ins_class.glob_module
			  	        	 0 class_size ins_members class_members class_name ins_pos ins_type instance_types member_defs type_defs modules var_heap type_heaps cs
				= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
367
368
			// otherwise
				# cs = { cs & cs_error = checkError class_name "different number of members specified" cs.cs_error }
Martin Wierich's avatar
Martin Wierich committed
369
				= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
370

Martin Wierich's avatar
Martin Wierich committed
371
	check_generic_instance {ins_class, ins_members, ins_generate} mod_index instance_types class_defs member_defs generic_defs type_defs modules var_heap type_heaps cs
372
			# ({gen_name, gen_member_name}, generic_defs, modules) = getGenericDef ins_class mod_index generic_defs modules		
373
374
			//| ins_generate 
			//	= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
375
			| size ins_members <> 1 				
376
				# cs = { cs & cs_error = checkError gen_name "generic instance must have one member" cs.cs_error }
Martin Wierich's avatar
Martin Wierich committed
377
				= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
378
379
380
			# member_name = ins_members.[0].ds_ident
			| member_name <> gen_member_name
				# cs = { cs & cs_error = checkError member_name "wrong member name" cs.cs_error }
Martin Wierich's avatar
Martin Wierich committed
381
				= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)				
382
			// otherwise
Martin Wierich's avatar
Martin Wierich committed
383
				= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
384

Martin Wierich's avatar
Martin Wierich committed
385
386
387
	check_member_instances :: !Index !Index !Int !Int !{#DefinedSymbol} !{#DefinedSymbol} Ident !Position !InstanceType ![(Index,SymbolType)]
		!v:{# MemberDef} !blah:{# CheckedTypeDef} !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
			-> (![(Index,SymbolType)], !v:{# MemberDef}, !blah:{# CheckedTypeDef}, !u:{# DclModule},!*VarHeap, !*TypeHeaps, !*CheckState)
388

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
389
	check_member_instances module_index member_mod_index mem_offset class_size ins_members class_members
Martin Wierich's avatar
Martin Wierich committed
390
				class_name ins_pos ins_type instance_types member_defs type_defs modules var_heap type_heaps cs=:{cs_x={x_main_dcl_module_n}}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
391
		| mem_offset == class_size
Martin Wierich's avatar
Martin Wierich committed
392
			= (instance_types, member_defs, type_defs, modules, var_heap, type_heaps, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
393
394
			# ins_member = ins_members.[mem_offset]
			  class_member = class_members.[mem_offset]
395
			  cs = setErrorAdmin (newPosition class_name ins_pos) cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
396
			| ins_member.ds_ident <> class_member.ds_ident
Martin Wierich's avatar
Martin Wierich committed
397
398
				= check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members class_name ins_pos ins_type 
						instance_types member_defs type_defs modules var_heap type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
399
400
							{ cs & cs_error = checkError class_member.ds_ident "instance of class member expected" cs.cs_error}
			| ins_member.ds_arity <> class_member.ds_arity
Martin Wierich's avatar
Martin Wierich committed
401
402
				= check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members class_name ins_pos ins_type
						instance_types member_defs type_defs modules var_heap type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
403
							{ cs & cs_error = checkError class_member.ds_ident "used with wrong arity" cs.cs_error}
404
				# ({me_symb, me_type,me_class_vars,me_pos}, member_defs, modules) = getMemberDef member_mod_index class_member.ds_index module_index member_defs modules
405
406
				  (instance_type, _, type_heaps, Yes (modules, type_defs), cs_error)
				  		= determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None type_heaps (Yes (modules, type_defs, x_main_dcl_module_n)) cs.cs_error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
407
				  (st_context, var_heap) = initializeContextVariables instance_type.st_context var_heap
Martin Wierich's avatar
Martin Wierich committed
408
409
				= check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members class_name ins_pos ins_type
						[ (ins_member.ds_index, { instance_type & st_context = st_context }) : instance_types ] member_defs type_defs modules var_heap type_heaps { cs & cs_error = cs_error }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
410

411

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
412
413
414
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
415
		# (class_def, class_defs) = class_defs![ds_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
416
		= (class_def, class_defs, modules)
417
		# (dcl_mod, modules) = modules![glob_module]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
418
419
420
421
422
		= (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
423
		# (member_def,member_defs) = member_defs![mem_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
424
		= (member_def, member_defs, modules)
425
		# (dcl_mod,modules) = modules![mem_mod]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
426
427
		= (dcl_mod.dcl_common.com_member_defs.[mem_index], member_defs, modules)

428
429
430
431
432
433
434
435
getGenericDef :: !(Global DefinedSymbol) !Int !u:{#GenericDef} !v:{#DclModule} -> (!GenericDef,!u:{#GenericDef},!v:{#DclModule})
getGenericDef {glob_module, glob_object={ds_ident, ds_index}} mod_index generic_defs modules
	| glob_module == mod_index
		# (generic_def, generic_defs) = generic_defs![ds_index]
		= (generic_def, generic_defs, modules)
		# (dcl_mod, modules) = modules![glob_module]
		= (dcl_mod.dcl_common.com_generic_defs.[ds_index], generic_defs, modules)

436
437
438
instantiateTypes :: ![TypeVar] ![AttributeVar] ![AType] ![TypeContext] ![AttrInequality] !SpecialSubstitution ![SpecialSubstitution] !*TypeHeaps !*ErrorAdmin
	-> (![TypeVar], ![AttributeVar], ![AType], ![TypeContext], ![AttrInequality], ![SpecialSubstitution], !*TypeHeaps, !*ErrorAdmin)
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} error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
439
440
441
	# th_vars = clear_vars old_type_vars th_vars

	  (new_type_vars, th_vars) = foldSt build_var_subst ss_vars ([], th_vars)
442
	  (new_attr_vars, th_attrs) = foldSt build_attr_var_subst ss_attrs ([], th_attrs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
443
444

	  type_heaps = foldSt build_type_subst ss_environ { type_heaps & th_vars = th_vars, th_attrs = th_attrs }
Martin Wierich's avatar
Martin Wierich committed
445
	  (ok1, new_ss_context, type_heaps) = substitute ss_context type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
446

447
448
	  (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_var_subst old_attr_vars (new_attr_vars, type_heaps.th_attrs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
449

450
451
	  (inst_types, (ok2, type_heaps))	= mapSt substitue_arg_type types (True, { type_heaps & th_vars = th_vars, th_attrs = th_attrs })
//	  (ok2, inst_types, type_heaps)		= substitute types { type_heaps & th_vars = th_vars, th_attrs = th_attrs }
Martin Wierich's avatar
Martin Wierich committed
452
453
	  (ok3, inst_contexts, type_heaps)	= substitute type_contexts type_heaps
	  (ok4, inst_attr_env, type_heaps)	= substitute attr_env type_heaps
454
455
456
457
458
459
460
	  (special_subst_list, th_vars) 	= mapSt adjust_special_subst special_subst_list type_heaps.th_vars
	  error = case ok1 && ok2 && ok3 && ok4 of
	  				True
	  					-> error
	  				False
	  					-> checkError "instance type incompatible with class type" "" error

461
	= (inst_vars, inst_attr_vars, inst_types, new_ss_context ++ inst_contexts, inst_attr_env, special_subst_list, { type_heaps & th_vars = th_vars }, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
462
463
464
465
466
467
468
469
470
471
472
473
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
Martin Wierich's avatar
Martin Wierich committed
474
		# (_, bind_src, type_heaps) = substitute bind_src type_heaps
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
// RWS ...
/*
	FIXME: this is a patch for the following incorrect function type (in a dcl module)


    f :: a | c a b special
        a=[], b = Int
        a=T, b = Char

   The type variable b doesn't occur in f's type, but this is checked in a later
   phase. Probably it's a better solution to change the order of checking.

*/
		| isNilPtr bind_dst.tv_info_ptr
			= type_heaps
// ... RWS
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
491
492
		= { type_heaps & th_vars = writePtr bind_dst.tv_info_ptr (TVI_Type bind_src) type_heaps.th_vars}

493
494
495
496
497
498
499
500
	substitue_arg_type at=:{at_type = TFA type_vars type} (was_ok, type_heaps)
		# (fresh_type_vars, type_heaps) = foldSt build_avar_subst type_vars ([], type_heaps)
		  (ok, new_at, type_heaps) = substitute {at & at_type = type} type_heaps
		= ({ new_at & at_type = TFA fresh_type_vars new_at.at_type}, (was_ok && ok, type_heaps))
	substitue_arg_type type (was_ok, type_heaps)
		# (ok, type, type_heaps) = substitute type type_heaps
		= (type, (was_ok && ok, type_heaps))
		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
501
502
503
504
505
	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)

506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
	build_avar_subst atv=:{atv_variable,atv_attribute} (free_vars, type_heaps)
		# (new_info_ptr, th_vars) = newPtr TVI_Empty type_heaps.th_vars
		  new_fv = { atv_variable & tv_info_ptr = new_info_ptr}
		  th_vars = th_vars <:= (atv_variable.tv_info_ptr, TVI_Type (TV new_fv))
		  (new_attr, th_attrs) = build_attr_subst atv_attribute type_heaps.th_attrs
		= ([ { atv & atv_variable = new_fv, atv_attribute = new_attr } : free_vars], { type_heaps & th_vars = th_vars, th_attrs = th_attrs })
	where		  
		 build_attr_subst (TA_Var avar) attr_var_heap
			# (new_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap
			  new_attr = { avar & av_info_ptr = new_info_ptr}
			= (TA_Var new_attr, attr_var_heap <:= (avar.av_info_ptr, AVI_Attr (TA_Var new_attr)))
		 build_attr_subst attr attr_var_heap
			= (attr, attr_var_heap)

	build_attr_var_subst attr (free_attrs, attr_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
521
522
523
524
525
526
527
528
529
530
531
532
		# (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)

533
534
535
determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !*ErrorAdmin
		-> (!SymbolType, !Specials, !*TypeHeaps, !u:Optional (v:{#DclModule}, w:{#CheckedTypeDef}), !*ErrorAdmin)
determineTypeOfMemberInstance mem_st class_vars {it_types,it_vars,it_attr_vars,it_context} specials type_heaps opt_modules error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
536
537
	# 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} 
538
539
540
541
542
	  (st, specials, type_heaps, error)
	  		= determine_type_of_member_instance mem_st env specials type_heaps error
	  (type_heaps, opt_modules, error)
	  		= check_attribution_consistency mem_st type_heaps opt_modules error
	= (st, specials, type_heaps, opt_modules, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
543
where
544
545
546
547
548
549
550
551
552
553
554
555
	determine_type_of_member_instance mem_st=:{st_context} env (SP_Substitutions substs) type_heaps error
		# (mem_st, substs, type_heaps, error) 
				= substitute_symbol_type { mem_st &  st_context = tl st_context } env substs type_heaps error
		= (mem_st, SP_Substitutions substs, type_heaps, error) 
	determine_type_of_member_instance mem_st=:{st_context} env SP_None type_heaps error
		# (mem_st, _, type_heaps, error)
				= substitute_symbol_type { mem_st &  st_context = tl st_context } env [] type_heaps error
		= (mem_st, SP_None, type_heaps, error)

	substitute_symbol_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment specials type_heaps error
		# (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, specials, type_heaps, error)
			= instantiateTypes st_vars st_attr_vars [ st_result : st_args ] st_context st_attr_env environment specials type_heaps error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
556
		= ({st & st_vars = st_vars, st_args = st_args, st_result = st_result, st_attr_vars = st_attr_vars,
557
			st_context = st_context, st_attr_env = st_attr_env }, specials, type_heaps, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
558

559
560
561
	check_attribution_consistency {st_args, st_result} type_heaps No error
		= (type_heaps, No, error)
	check_attribution_consistency {st_args, st_result} type_heaps=:{th_vars} (Yes (modules, type_defs, x_main_dcl_module_n)) error
562
563
564
565
566
		// it is assumed that all type vars bindings done in instantiateTypes are still valid
		# (_, th_vars, modules, type_defs, error)
				= foldSt (foldATypeSt (check_it x_main_dcl_module_n) (\_ st -> st))
						[st_result:st_args]
						(False, th_vars, modules, type_defs, error)
567
		= ({ type_heaps & th_vars = th_vars }, Yes (modules, type_defs), error)
568
569
570
571
572
573
574
575
576
577
578
579
580
	
	check_it _ {at_attribute} (error_already_given, th_vars, modules, type_defs, error)
		| at_attribute==TA_Unique || error_already_given
			= (error_already_given, th_vars, modules, type_defs, error)
		// otherwise GOTO next alternative
	check_it x_main_dcl_module_n {at_type=TV tv} (_, th_vars, modules, type_defs, error)
  		= must_not_be_essentially_unique x_main_dcl_module_n tv th_vars modules type_defs error
	check_it x_main_dcl_module_n {at_type= (CV tv) :@: _} (_, th_vars, modules, type_defs, error)
  		= must_not_be_essentially_unique x_main_dcl_module_n tv th_vars modules type_defs error
	check_it _ _ state
		= state
		
	must_not_be_essentially_unique x_main_dcl_module_n {tv_name, tv_info_ptr} th_vars modules type_defs error
581
		# (TVI_Type type, th_vars) = readPtr tv_info_ptr th_vars
582
583
		= case type of
			TA {type_name, type_index} _
584
585
586
587
588
589
590
				-> must_not_be_essentially_unique_for_TA type_name type_index th_vars
			TAS {type_name, type_index} _ _
				-> must_not_be_essentially_unique_for_TA type_name type_index th_vars
			_
				-> (False, th_vars, modules, type_defs, error)
		where
			must_not_be_essentially_unique_for_TA type_name type_index th_vars
591
592
				# (type_def, type_defs, modules)
						= getTypeDef x_main_dcl_module_n type_index type_defs modules
593
				= case type_def.td_attribute of
594
595
596
597
598
599
600
601
602
603
					TA_Unique
						-> (True, th_vars, modules, type_defs,
							checkError type_name 
								(   "is unique but instanciates class variable "
								 +++tv_name.id_name
								 +++" that is non uniquely used in a member type"
								) error
						   )
					_
						-> (False, th_vars, modules, type_defs, error)
604
		
605
606
607
608
609
610
611
612
613
614
615
getTypeDef :: !Index !(Global Index) !v:{#CheckedTypeDef} !w:{#DclModule}
		-> (!CheckedTypeDef, !v:{#CheckedTypeDef}, !w:{#DclModule})
getTypeDef x_main_dcl_module_n {glob_module,glob_object} type_defs modules
	| glob_module==x_main_dcl_module_n
		# (type_def, type_defs)
				= type_defs![glob_object]
		= (type_def, type_defs, modules)
	# (type_def, modules)
			= modules![glob_module].dcl_common.com_type_defs.[glob_object]
	= (type_def, type_defs, modules)
		
616
determineTypesOfInstances :: !Index !Index !*{#ClassInstance} !*{# ClassDef} !*{# MemberDef} !*{#GenericDef}
617
							 !*{#DclModule} !*TypeHeaps !*VarHeap !*CheckState
618
619
	-> (![FunType], !Index, ![ClassInstance], !*{#ClassInstance}, !*{# ClassDef}, !*{# MemberDef}, !*{#GenericDef}, !*{#DclModule}, !*TypeHeaps, !*VarHeap, !*CheckState)
determineTypesOfInstances first_memb_inst_index mod_index com_instance_defs com_class_defs com_member_defs com_generic_defs
620
		modules type_heaps var_heap cs=:{cs_error,cs_predef_symbols,cs_x={x_main_dcl_module_n}}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
621
622
	| cs_error.ea_ok
		#! nr_of_class_instances = size com_instance_defs
623
		# (memb_inst_defs, next_mem_inst_index, all_class_specials, com_class_defs, com_member_defs, com_generic_defs, modules, com_instance_defs, type_heaps, var_heap, cs_predef_symbols,cs_error)
624
				= determine_types_of_instances x_main_dcl_module_n 0 nr_of_class_instances first_memb_inst_index mod_index [] com_class_defs com_member_defs com_generic_defs
625
						modules com_instance_defs type_heaps var_heap cs_predef_symbols cs_error
626
		= (memb_inst_defs, next_mem_inst_index, all_class_specials, com_instance_defs, com_class_defs,
627
		   com_member_defs, com_generic_defs, modules, type_heaps, var_heap, { cs & cs_predef_symbols=cs_predef_symbols,cs_error = cs_error })
628
		= ([], first_memb_inst_index, [], com_instance_defs, com_class_defs, com_member_defs, com_generic_defs, modules, type_heaps, var_heap, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
629
where
630
	determine_types_of_instances :: !Index !Index !Index !Index !Index ![ClassInstance] !v:{#ClassDef} !w:{#MemberDef} !y:{#GenericDef}
631
632
		!x:{#DclModule} !*{#ClassInstance} !*TypeHeaps !*VarHeap !*PredefinedSymbols !*ErrorAdmin
			-> (![FunType], !Index, ![ClassInstance], !v:{#ClassDef}, !w:{#MemberDef}, !y:{#GenericDef}, !x:{#DclModule}, !*{#ClassInstance}, !*TypeHeaps, !*VarHeap, !*PredefinedSymbols,!*ErrorAdmin)
Martin Wierich's avatar
Martin Wierich committed
633
	determine_types_of_instances x_main_dcl_module_n inst_index next_class_inst_index next_mem_inst_index mod_index all_class_specials
634
			class_defs member_defs generic_defs modules instance_defs type_heaps var_heap predef_symbols error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
635
		| inst_index < size instance_defs
636
			# (instance_def, instance_defs) = instance_defs![inst_index]
637
638
639
640
641
642
643
644
645
646
			# {ins_class,ins_pos,ins_type,ins_specials, ins_is_generic} = instance_def
			| ins_is_generic			
				# ({gen_member_name}, generic_defs, modules) = getGenericDef ins_class mod_index generic_defs modules
				# ins_member = {ds_ident=gen_member_name, ds_arity= -1, ds_index = next_mem_inst_index} 
				# instance_def = { instance_def & ins_members = {ins_member}}
				# class_size = 1
				# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap 
				# empty_st = 
					{	st_vars = []
					,	st_args = []
647
					,	st_args_strictness=NotStrict
648
					,	st_arity = -1
649
					,	st_result = {at_type=TE, at_attribute=TA_None}
650
651
652
653
654
655
					,	st_context = []
					,	st_attr_vars = []
					,	st_attr_env = []
					}				
				# memb_inst_def = MakeNewFunctionType gen_member_name 0 NoPrio empty_st ins_pos SP_None new_info_ptr
				# memb_inst_defs1 = [memb_inst_def]
656
657
658
659
660
			  	# (memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, generic_defs, modules, instance_defs, type_heaps, var_heap, predef_symbols,error)
			  		= determine_types_of_instances x_main_dcl_module_n (inc inst_index) next_class_inst_index 
			  				(next_mem_inst_index + class_size) mod_index all_class_specials class_defs member_defs generic_defs modules 
			  				{ instance_defs & [inst_index] = { instance_def & ins_specials = ins_specials }} type_heaps var_heap predef_symbols error
				= 	(memb_inst_defs1 ++ memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, generic_defs, modules, instance_defs, type_heaps, var_heap ,predef_symbols,error)
661
662
663
664
665
666
				# ({class_name, 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, error)
				  		= determine_instance_symbols_and_types x_main_dcl_module_n next_mem_inst_index 0 mod_index ins_class.glob_module class_size class_members
				  				ins_type ins_specials class_name ins_pos member_defs modules type_heaps var_heap error
				  instance_def = { instance_def & ins_members = { member \\ member <- ins_members }}
667
668
669
				  (ins_specials, next_class_inst_index, all_class_specials, type_heaps, predef_symbols,error)
						= check_instance_specials mod_index instance_def inst_index ins_specials next_class_inst_index all_class_specials type_heaps predef_symbols error
				  (memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, generic_defs, modules, instance_defs, type_heaps, var_heap, predef_symbols,error)
670
				  		= determine_types_of_instances x_main_dcl_module_n (inc inst_index) next_class_inst_index (next_mem_inst_index + class_size) mod_index all_class_specials
671
				  				class_defs member_defs generic_defs modules { instance_defs & [inst_index] = { instance_def & ins_specials = ins_specials }} type_heaps var_heap predef_symbols error
672
	
673
674
				= (memb_inst_defs1 ++ memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, generic_defs, modules, instance_defs, type_heaps, var_heap, predef_symbols,error)
			= ([], next_mem_inst_index, all_class_specials, class_defs, member_defs, generic_defs, modules, instance_defs, type_heaps, var_heap, predef_symbols,error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
675

Martin Wierich's avatar
Martin Wierich committed
676
677
678
679
680
	determine_instance_symbols_and_types :: !Index !Index !Index !Index !Index !Int !{#DefinedSymbol} !InstanceType !Specials Ident !Position
			!w:{#MemberDef} !u:{#DclModule} !*TypeHeaps !*VarHeap !*ErrorAdmin
					-> (![DefinedSymbol], ![FunType], !w:{#MemberDef}, !u:{#DclModule}, !*TypeHeaps, !*VarHeap, !.ErrorAdmin)
	determine_instance_symbols_and_types x_main_dcl_module_n first_inst_index mem_offset module_index member_mod_index class_size class_members
			ins_type ins_specials class_name ins_pos member_defs modules type_heaps var_heap cs_error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
681
		| mem_offset == class_size
Martin Wierich's avatar
Martin Wierich committed
682
			=  ([], [], member_defs, modules, type_heaps, var_heap, cs_error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
683
684
			# 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
685
686
			  cs_error
			  		= pushErrorAdmin (newPosition class_name ins_pos) cs_error
687
688
			  (instance_type, new_ins_specials, type_heaps, Yes (modules, _), cs_error)
			  		= determineTypeOfMemberInstance me_type me_class_vars ins_type ins_specials type_heaps (Yes (modules, {}, cUndef)) cs_error
689
690
			  cs_error
			  		= popErrorAdmin cs_error
691
			  (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
692
			  inst_def = MakeNewFunctionType me_symb me_type.st_arity me_priority instance_type ins_pos new_ins_specials new_info_ptr
Martin Wierich's avatar
Martin Wierich committed
693
694
695
696
			  (inst_symbols, memb_inst_defs, member_defs, modules, type_heaps, var_heap, cs_error)
			  		= determine_instance_symbols_and_types x_main_dcl_module_n first_inst_index (inc mem_offset) module_index member_mod_index
			  				class_size class_members ins_type ins_specials class_name ins_pos member_defs modules type_heaps var_heap cs_error
			= ([{ class_member & ds_index = first_inst_index +  mem_offset } : inst_symbols], [inst_def : memb_inst_defs], member_defs, modules, type_heaps, var_heap, cs_error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
697

698
699
700
701
702
703
	check_instance_specials :: !Index !ClassInstance !Index !Specials !Index ![ClassInstance] !*TypeHeaps !*PredefinedSymbols !*ErrorAdmin
		-> (!Specials, !Index, ![ClassInstance], !*TypeHeaps, !*PredefinedSymbols,!*ErrorAdmin)
	check_instance_specials mod_index inst_type inst_index (SP_Substitutions substs) next_inst_index all_instances type_heaps predef_symbols error
		# (list_of_specials, next_inst_index, all_instances, type_heaps, predef_symbols,error)
			= check_specials mod_index inst_type 0 substs [] next_inst_index all_instances type_heaps predef_symbols error
		= (SP_ContextTypes list_of_specials, next_inst_index, all_instances, type_heaps, predef_symbols, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
704
	where
705
		check_specials mod_index inst=:{ins_type} type_offset [ subst : substs ] list_of_specials next_inst_index all_instances type_heaps predef_symbols error
706
			# (special_type, type_heaps, error) = substitute_instance_type ins_type subst type_heaps error
707
			  (spec_types, predef_symbols,error) = checkAndCollectTypesOfContextsOfSpecials special_type.it_context predef_symbols error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
708
709
710
			  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)
711
					[{ inst & ins_type = { special_type & it_context = [] }, ins_specials = SP_TypeOffset type_offset} : all_instances ] type_heaps predef_symbols error
712
713
714
715
716
717
718
719
		where
			substitute_instance_type :: !InstanceType !SpecialSubstitution !*TypeHeaps !*ErrorAdmin -> (!InstanceType,!*TypeHeaps,!.ErrorAdmin)
			substitute_instance_type it=:{it_vars,it_attr_vars,it_types,it_context} environment type_heaps cs_error
				# (it_vars, it_attr_vars, it_atypes, it_context, _, _, type_heaps, cs_error)	
					= instantiateTypes it_vars it_attr_vars [MakeAttributedType type \\ type <- it_types] it_context [] environment [] type_heaps cs_error
				= ({it & it_vars = it_vars, it_types = [ at_type \\ {at_type} <- it_atypes ], it_attr_vars = it_attr_vars, it_context = it_context }, type_heaps, cs_error)

			
720
721
722
723
		check_specials mod_index inst=:{ins_type} type_offset [] list_of_specials next_inst_index all_instances type_heaps predef_symbols error
			= (list_of_specials,  next_inst_index, all_instances, type_heaps, predef_symbols, error)
	check_instance_specials mod_index fun_type fun_index SP_None next_inst_index all_instances type_heaps predef_symbols error
		= (SP_None, next_inst_index, all_instances, type_heaps, predef_symbols,error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
724

725
726
727
728
729
730
731
732
733
734
735
736
737
738
mapSt2 f l s1 s2 :== map_st2 l s1 s2
where
	map_st2 [x : xs] s1 s2
	 	# (x, s1,s2) = f x s1 s2
		  (xs, s1,s2) = map_st2 xs s1 s2
		#! s1 = s1
		#! s2 = s2
		= ([x : xs], s1,s2)
	map_st2 [] s1 s2
	 	= ([], s1,s2)
	
checkAndCollectTypesOfContextsOfSpecials :: [TypeContext] *PredefinedSymbols *ErrorAdmin -> (![[Type]],!*PredefinedSymbols,!*ErrorAdmin);
checkAndCollectTypesOfContextsOfSpecials type_contexts predef_symbols error
	= mapSt2 check_and_collect_context_types_of_special type_contexts predef_symbols error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
739
where	
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
	check_and_collect_context_types_of_special {tc_class={glob_object={ds_ident,ds_index},glob_module},tc_types} predef_symbols error
		| hasNoTypeVariables tc_types
			= (tc_types, predef_symbols,error)
		# {pds_def,pds_module} = predef_symbols.[PD_ArrayClass]
		| glob_module==pds_module && ds_index==pds_def && is_lazy_or_strict_array tc_types predef_symbols
			= (tc_types, predef_symbols,error)
		# {pds_def,pds_module} = predef_symbols.[PD_ListClass]
		| glob_module==pds_module && ds_index==pds_def && is_lazy_or_strict_list tc_types predef_symbols
			= (tc_types, predef_symbols,error)
			= (tc_types, predef_symbols,checkError ds_ident.id_name "illegal specialization" error)

	hasNoTypeVariables []
		= True
	hasNoTypeVariables [TV tvar : types]
		= False
	hasNoTypeVariables [ _ : types]
		= hasNoTypeVariables types
	
	is_lazy_or_strict_array [TA {type_index={glob_module,glob_object}} [],TV var] predef_symbols
		# {pds_def,pds_module} = predef_symbols.[PD_LazyArrayType]
		| glob_module==pds_module && glob_object==pds_def
			= True
		# {pds_def,pds_module} = predef_symbols.[PD_StrictArrayType]
		| glob_module==pds_module && glob_object==pds_def
			= True
			= False
766
767
	is_lazy_or_strict_array _ predef_symbols
		= False
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782

	is_lazy_or_strict_list [TA {type_index={glob_module,glob_object}} [],TV var] predef_symbols
		# {pds_def,pds_module} = predef_symbols.[PD_ListType]
		| glob_module==pds_module && glob_object==pds_def
			= True
		# {pds_def,pds_module} = predef_symbols.[PD_StrictListType]
		| glob_module==pds_module && glob_object==pds_def
			= True
		# {pds_def,pds_module} = predef_symbols.[PD_TailStrictListType]
		| glob_module==pds_module && glob_object==pds_def
			= True
		# {pds_def,pds_module} = predef_symbols.[PD_StrictTailStrictListType]
		| glob_module==pds_module && glob_object==pds_def
			= True
			= False
783
784
	is_lazy_or_strict_list _ predef_symbols
		= False
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
785
786
787
788
789
790
791
792
793

initializeContextVariables :: ![TypeContext] !*VarHeap ->  (![TypeContext], !*VarHeap)
initializeContextVariables contexts var_heap
	= mapSt add_variable_to_context contexts var_heap
where
	add_variable_to_context context var_heap
		# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
		= ({ context & tc_var = new_info_ptr}, var_heap)

794
795
ident_for_errors_from_fun_symb_and_fun_kind :: Ident FunKind -> Ident;
ident_for_errors_from_fun_symb_and_fun_kind {id_name} (FK_Function fun_name_is_location_dependent)
796
797
798
799
800
801
	| fun_name_is_location_dependent && size id_name>0
		# beautiful_name = if (id_name.[0]==backslash) "lambda" "comprehension"
		= { id_name=beautiful_name, id_info=nilPtr }
ident_for_errors_from_fun_symb_and_fun_kind fun_symb _
	= fun_symb

802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
// check that there are no strict lets, mark top-level cases as explicit
class checkMacro a :: !Bool !a !*ErrorAdmin -> (!a, !*ErrorAdmin)

instance checkMacro [a] | checkMacro a where
	checkMacro topLevel l ea
		=	mapSt (checkMacro topLevel) l ea

instance checkMacro FunctionBody where
	checkMacro topLevel (CheckedBody body) ea
		# (body, ea)
			=	checkMacro topLevel body ea
		= (CheckedBody body, ea)

instance checkMacro CheckedBody where
	checkMacro topLevel body=:{cb_rhs} ea
		# (cb_rhs, ea)
			=	checkMacro topLevel cb_rhs ea
		= ({body & cb_rhs = cb_rhs}, ea)

instance checkMacro CheckedAlternative where
	checkMacro topLevel alt=:{ca_rhs} ea
		# (ca_rhs, ea)
			=	checkMacro topLevel ca_rhs ea
		= ({alt & ca_rhs = ca_rhs}, ea)

instance checkMacro Expression where
	checkMacro topLevel (Let lad) ea
		# (lad, ea)
			=	checkMacro topLevel lad ea
		=	(Let lad, ea)
	checkMacro topLevel (Case kees) ea
		# (kees, ea)
			=	checkMacro topLevel kees ea
		=	(Case kees, ea)
	checkMacro _ expr ea
		=	(expr, ea)

instance checkMacro Let where
	checkMacro topLevel lad=:{let_strict_binds, let_expr} ea
		# ea
			=	check_strict_binds let_strict_binds ea
		# (let_expr, ea)
			=	checkMacro topLevel let_expr ea
		= ({lad & let_expr = let_expr}, ea)
		where
			check_strict_binds [] ea
				=	ea
			check_strict_binds _ ea
				=	checkError "#! not allowed in macros" "" ea

instance checkMacro Case where
	checkMacro topLevel kees=:{case_guards, case_explicit} ea
		# (case_guards, ea)
			=	checkMacro False case_guards ea
		= ({kees & case_guards = case_guards,case_explicit = topLevel || case_explicit}, ea)

instance checkMacro CasePatterns where
	checkMacro topLevel (AlgebraicPatterns type patterns) ea
		# (patterns, ea)
			=	checkMacro topLevel patterns ea	
		=	(AlgebraicPatterns type patterns, ea)
	checkMacro topLevel (BasicPatterns type patterns) ea
		# (patterns, ea)
			=	checkMacro topLevel patterns ea	
		=	(BasicPatterns type patterns, ea)
	checkMacro topLevel (DynamicPatterns patterns) ea
		# (patterns, ea)
			=	checkMacro topLevel patterns ea	
		=	(DynamicPatterns patterns, ea)
	checkMacro topLevel (OverloadedListPatterns type decons patterns) ea
		# (patterns, ea)
			=	checkMacro topLevel patterns ea	
		=	(OverloadedListPatterns type decons patterns, ea)
	checkMacro _ NoPattern ea
		=	(NoPattern, ea)

instance checkMacro AlgebraicPattern where
	checkMacro topLevel pattern=:{ap_expr} ea
		# (ap_expr, ea)
			=	checkMacro topLevel ap_expr ea	
		=	({pattern & ap_expr = ap_expr}, ea)

instance checkMacro BasicPattern where
	checkMacro topLevel pattern=:{bp_expr} ea
		# (bp_expr, ea)
			=	checkMacro topLevel bp_expr ea	
		=	({pattern & bp_expr = bp_expr}, ea)

instance checkMacro DynamicPattern where
	checkMacro topLevel pattern=:{dp_rhs} ea
		# (dp_rhs, ea)
			=	checkMacro topLevel dp_rhs ea	
		=	({pattern & dp_rhs = dp_rhs}, ea)

checkFunctionBodyIfMacro :: !FunKind !FunctionBody !*ErrorAdmin -> (!FunctionBody, !*ErrorAdmin)
checkFunctionBodyIfMacro FK_Macro def ea
	=	checkMacro True def ea
checkFunctionBodyIfMacro _ def ea
	=	(def, ea)

902
903
904
checkFunction :: !FunDef !Index !FunctionOrMacroIndex !Level !Int !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState
													  -> (!FunDef,!*{#FunDef},!*ExpressionInfo,!*Heaps,!*CheckState);
checkFunction fun_def=:{fun_symb,fun_pos,fun_body,fun_type,fun_kind} mod_index fun_index def_level local_functions_index_offset
905
			fun_defs e_info=:{ef_type_defs,ef_modules,ef_class_defs,ef_is_macro_fun} heaps=:{hp_var_heap,hp_expression_heap,hp_type_heaps} cs=:{cs_error}			
906
907
908
	# function_ident_for_errors = ident_for_errors_from_fun_symb_and_fun_kind fun_symb fun_kind
	# cs = {cs & cs_error = pushErrorAdmin (newPosition function_ident_for_errors fun_pos) cs_error}

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
909
	  (fun_type, ef_type_defs, ef_class_defs, ef_modules, hp_var_heap, hp_type_heaps, cs)
910
			= check_function_type fun_type mod_index (fun_kind == FK_Caf) ef_type_defs ef_class_defs