check.icl 155 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
Martin Wierich's avatar
Martin Wierich committed
6
import explicitimports, comparedefimp, checkFunctionBodies, containers, portToNewSyntax
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
7
8

cPredefinedModuleIndex 	:== 1
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
25
// AA..
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
26
		# (gen_def=:{gen_name, gen_type, gen_pos}, generic_defs) = generic_defs![gen_index]
27
28
		# position = newPosition gen_name gen_pos
		# cs_error = setErrorAdmin position cs_error
29
			//---> ("checkGenerics generic type 1", gen_type.gt_type)
30
31
32

		# cs = {cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }
		# type_heaps = {type_heaps & th_vars = th_vars}
33
34
35
36
		//# (gt_type, _, type_defs, class_defs, modules, type_heaps, cs) =
		//	checkSymbolType module_index gen_type.gt_type SP_None type_defs class_defs modules type_heaps cs
		# (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
37

38
39
40
41
42
43
44
		#! {cs_error} = cs
		#! (gt_vars, st_vars, cs_error) = split_vars gen_type.gt_vars  gt_type.st_vars cs_error
		#! cs = {cs & cs_error = cs_error}
		#! gt_type = {gt_type & st_vars = st_vars}

		# generic_defs = {generic_defs & [gen_index] . gen_type = { gen_type & gt_vars = gt_vars, gt_type = gt_type }}				
			//---> ("checkGenerics generic type 2", gt_type)
45
46
		= checkGenerics (inc gen_index) module_index generic_defs class_defs type_defs modules type_heaps cs
where	
47
48
49
50
51
52
53
54
55
56
57
58
59
60
	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)
				
61

62
checkTypeClasses :: !Index !Index !*{#ClassDef} !*{#MemberDef} !*{#CheckedTypeDef} !*{#DclModule} !*TypeHeaps !*CheckState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
63
	-> (!*{#ClassDef}, !*{#MemberDef}, !*{#CheckedTypeDef}, !*{#DclModule}, !*TypeHeaps, !*CheckState)
64
checkTypeClasses class_index module_index class_defs member_defs type_defs modules type_heaps cs=:{cs_symbol_table,cs_error}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
65
66
	| class_index == size class_defs
		= (class_defs, member_defs, type_defs, modules, type_heaps, cs)
67
		# (class_def=:{class_name,class_pos,class_args,class_context,class_members}, class_defs) = class_defs![class_index]
68
69
70
		  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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
71
72
		  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 
73
		= checkTypeClasses (inc class_index) module_index class_defs member_defs type_defs modules type_heaps cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
74
75
76
77
78
where
	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]
79
			# (member_def, member_defs) = member_defs![ds_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
80
81
82
83
84
			= 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)
Martin Wierich's avatar
Martin Wierich committed
85
	# (special_type, hp_type_heaps, error) = substitute_type ft_type subst heaps.hp_type_heaps error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
86
87
88
89
90
91
92
	  (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	
Martin Wierich's avatar
Martin Wierich committed
93
94
95
	substitute_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment type_heaps error
		# (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, _, type_heaps, Yes error)
			= instantiateTypes st_vars st_attr_vars [ st_result : st_args ] st_context st_attr_env environment [] type_heaps (Yes error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
96
		= ({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
97
			st_context = st_context, st_attr_env = st_attr_env }, type_heaps, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
98

99
100
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
101
102
103
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
104
105
	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
106
107
108
109
110
111
112
	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)
113
		  		= checkFunctionType module_index ft_type ft_specials type_defs class_defs modules heaps.hp_type_heaps cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
114
115
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
		  (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
147
148
	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
149
150
151
152
153
154
	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
155
		 	# (spec_types, all_spec_types) = all_spec_types![spec_member_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
		 	# 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 }
180
181
182
		  (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 ]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
183
184
185
		  (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)
186
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
187
188
189
190
::	InstanceSymbols =
	{	is_type_defs		:: !.{# CheckedTypeDef}
	,	is_class_defs		:: !.{# ClassDef}
	,	is_member_defs		:: !.{# MemberDef}
191
	, 	is_generic_defs		:: !.{# GenericDef} // AA
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
192
193
194
	,	is_modules			:: !.{# DclModule}
	}

195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
// 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)
			
	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 
222
223
224
				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
225
226
227
				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
228
229
230
				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
231
232
233
234
235
236
237
				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})
238
239
			class_by_module_index decl_index class_index is=:{is_modules}
 				# 	(dcl_mod, is_modules) = is_modules![decl_index]
240
241
242
243
244
					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})
245
246
			generic_by_module_index decl_index gen_index is=:{is_modules}	
 				# 	(dcl_mod, is_modules) = is_modules![decl_index]
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
					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
			= ( ins
			  , is
			  , type_heaps
			  , { 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
			= ( ins
			  , is
			  , type_heaps
			  , { 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 
			class_def module_index generic_index generic_module_index
			ins=:{
				ins_members,
				ins_class={glob_object = class_name =: {ds_ident = {id_name,id_info},ds_arity, ds_index} },
				ins_type,
				ins_specials,
				ins_pos,
				ins_ident, 
				ins_is_generic}
			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 }		 
			# ins = { ins & 
				ins_is_generic = True,
				ins_generic = {glob_module = module_index, glob_object = generic_index}, 
				ins_class = ins_class, 
				ins_type = ins_type, 
				ins_specials = ins_specials 
				}  
			= (ins, is, type_heaps, cs)
		// otherwise
			# cs_error = checkError id_name "arity of generic instance must be 1" cs_error 
			# cs = {cs & cs_error = cs_error}
			= (ins, is, type_heaps, cs)
						 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
308
309
checkInstances :: !Index !*CommonDefs !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
	-> (![(Index,SymbolType)], !*CommonDefs, !u:{# DclModule}, !*VarHeap , !*TypeHeaps, !*CheckState)
Martin Wierich's avatar
Martin Wierich committed
310
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
311
	| cs_error.ea_ok
Martin Wierich's avatar
Martin Wierich committed
312
313
314
		# (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
315
316
317
			 	modules, var_heap, type_heaps, cs)
		= ([], icl_common, modules, var_heap, type_heaps, cs)
where
Martin Wierich's avatar
Martin Wierich committed
318
	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
319
		!*VarHeap !*TypeHeaps !*CheckState
Martin Wierich's avatar
Martin Wierich committed
320
321
			-> (![(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
322
323
// AA..
		| inst_index < size instance_defs
Martin Wierich's avatar
Martin Wierich committed
324
325
			# (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) =
326
				(if ins_is_generic check_generic_instance check_class_instance)  
Martin Wierich's avatar
Martin Wierich committed
327
328
					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 
329
		// otherwise
Martin Wierich's avatar
Martin Wierich committed
330
			= (instance_types, instance_defs, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
331
													
Martin Wierich's avatar
Martin Wierich committed
332
	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
333
334
335
			# ({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
336
337
338
339
				# (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)
340
341
			// otherwise
				# cs = { cs & cs_error = checkError class_name "different number of members specified" cs.cs_error }
Martin Wierich's avatar
Martin Wierich committed
342
				= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
343
	
Martin Wierich's avatar
Martin Wierich committed
344
	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
345
346
			# ({gen_name, gen_member_name}, generic_defs, modules) = getGenericDef ins_class mod_index generic_defs modules		
			| ins_generate 
Martin Wierich's avatar
Martin Wierich committed
347
				= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)				
348
349
			| size ins_members <> 1 				
				# cs = { cs & cs_error = checkError gen_name "generic instance must have one memeber" cs.cs_error }
Martin Wierich's avatar
Martin Wierich committed
350
				= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
351
352
353
			# 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
354
				= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)				
355
			// otherwise
Martin Wierich's avatar
Martin Wierich committed
356
				= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
357
// ..AA
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
358

Martin Wierich's avatar
Martin Wierich committed
359
360
361
	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)
362

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
363
	check_member_instances module_index member_mod_index mem_offset class_size ins_members class_members
Martin Wierich's avatar
Martin Wierich committed
364
				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
365
		| mem_offset == class_size
Martin Wierich's avatar
Martin Wierich committed
366
			= (instance_types, member_defs, type_defs, modules, var_heap, type_heaps, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
367
368
369
			# ins_member = ins_members.[mem_offset]
			  class_member = class_members.[mem_offset]
			| ins_member.ds_ident <> class_member.ds_ident
Martin Wierich's avatar
Martin Wierich committed
370
371
				= 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
372
373
							{ 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
374
375
				= 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
376
377
							{ 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
Martin Wierich's avatar
Martin Wierich committed
378
379
				  (instance_type, _, type_heaps, Yes cs_error) = determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None type_heaps (Yes cs.cs_error)
				  (type_defs, modules, cs_error) = checkTopLevelKinds x_main_dcl_module_n True ins_pos class_name instance_type type_defs modules cs_error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
380
				  (st_context, var_heap) = initializeContextVariables instance_type.st_context var_heap
Martin Wierich's avatar
Martin Wierich committed
381
382
				= 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
383

384

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
385
386
387
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
388
		# (class_def, class_defs) = class_defs![ds_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
389
		= (class_def, class_defs, modules)
390
		# (dcl_mod, modules) = modules![glob_module]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
391
392
393
394
395
		= (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
396
		# (member_def,member_defs) = member_defs![mem_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
397
		= (member_def, member_defs, modules)
398
		# (dcl_mod,modules) = modules![mem_mod]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
399
400
		= (dcl_mod.dcl_common.com_member_defs.[mem_index], member_defs, modules)

401
402
403
404
405
406
407
408
409
410
// AA..
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)
// ..AA

Martin Wierich's avatar
Martin Wierich committed
411
412
413
instantiateTypes :: ![TypeVar] ![AttributeVar] !types ![TypeContext] ![AttrInequality] !SpecialSubstitution ![SpecialSubstitution] !*TypeHeaps !(Optional *ErrorAdmin)
	-> (![TypeVar], ![AttributeVar], !types , ![TypeContext], ![AttrInequality], ![SpecialSubstitution], !*TypeHeaps, !(Optional *ErrorAdmin)) | 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} opt_error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
414
415
416
417
418
419
	# 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 }
Martin Wierich's avatar
Martin Wierich committed
420
	  (ok1, new_ss_context, type_heaps) = substitute ss_context type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
421
422
423
424

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

Martin Wierich's avatar
Martin Wierich committed
425
426
427
	  (ok2, inst_types, type_heaps)		= substitute types { type_heaps & th_vars = th_vars, th_attrs = th_attrs }
	  (ok3, inst_contexts, type_heaps)	= substitute type_contexts type_heaps
	  (ok4, inst_attr_env, type_heaps)	= substitute attr_env type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
428
	  (special_subst_list, th_vars) =  mapSt adjust_special_subst special_subst_list type_heaps.th_vars
Martin Wierich's avatar
Martin Wierich committed
429
430
431
432
433
434
435
436
437
438
	
	  opt_error = case ok1 && ok2 && ok3 && ok4 of
	  				True -> opt_error
	  				_ -> case opt_error of
	  						No -> No
	  						Yes error_admin
	  							-> Yes (checkError "" "instance type incompatible with class type" 
	  										error_admin)
	  								// e.g.:class c a :: (a Int); instance c Real
	= (inst_vars, inst_attr_vars, inst_types, inst_contexts ++ new_ss_context, inst_attr_env, special_subst_list, { type_heaps & th_vars = th_vars }, opt_error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
439
440
441
442
443
444
445
446
447
448
449
450
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
451
		# (_, bind_src, type_heaps) = substitute bind_src type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
		= { 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)

Martin Wierich's avatar
Martin Wierich committed
472
473
474
475
476
substituteInstanceType :: !InstanceType !SpecialSubstitution !*TypeHeaps !*ErrorAdmin -> (!InstanceType,!*TypeHeaps,!.ErrorAdmin)
substituteInstanceType it=:{it_vars,it_attr_vars,it_types,it_context} environment type_heaps cs_error
	# (it_vars, it_attr_vars, it_types, it_context, _, _, type_heaps, Yes cs_error)
		= instantiateTypes it_vars it_attr_vars it_types it_context [] environment [] type_heaps (Yes cs_error)
	= ({it & it_vars = it_vars, it_types = it_types, it_attr_vars = it_attr_vars, it_context = it_context }, type_heaps, cs_error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
477
478
479
480
481
482
483
484

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

Martin Wierich's avatar
Martin Wierich committed
485
486
487
determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps !(Optional *ErrorAdmin)
		-> (!SymbolType, !Specials, !*TypeHeaps, !Optional *ErrorAdmin)
determineTypeOfMemberInstance mem_st class_vars {it_types,it_vars,it_attr_vars,it_context} specials type_heaps opt_error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
488
489
	# 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} 
Martin Wierich's avatar
Martin Wierich committed
490
491
492
	  (st, specials, type_heaps, opt_error)
	  		= determine_type_of_member_instance mem_st env specials type_heaps opt_error
	= (st, specials, type_heaps, opt_error)	 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
493
where
Martin Wierich's avatar
Martin Wierich committed
494
495
496
497
498
499
500
501
502
503
504
505
	determine_type_of_member_instance mem_st=:{st_context} env (SP_Substitutions substs) type_heaps opt_error
		# (mem_st, substs, type_heaps, opt_error) 
				= substitute_symbol_type { mem_st &  st_context = tl st_context } env substs type_heaps opt_error
		= (mem_st, SP_Substitutions substs, type_heaps, opt_error) 
	determine_type_of_member_instance mem_st=:{st_context} env SP_None type_heaps opt_error
		# (mem_st, _, type_heaps, opt_error)
				= substitute_symbol_type { mem_st &  st_context = tl st_context } env [] type_heaps opt_error
		= (mem_st, SP_None, type_heaps, opt_error)

	substitute_symbol_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment specials type_heaps opt_error
		# (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, specials, type_heaps, opt_error)
			= instantiateTypes st_vars st_attr_vars [ st_result : st_args ] st_context st_attr_env environment specials type_heaps opt_error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
506
		= ({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
507
			st_context = st_context, st_attr_env = st_attr_env }, specials, type_heaps, opt_error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
508

509
510
511
512
determineTypesOfInstances :: !Index !Index !*{#ClassInstance} !*{# ClassDef} !*{# MemberDef}
							 !*{#DclModule} !*TypeHeaps !*VarHeap !*CheckState
	-> (![FunType], !Index, ![ClassInstance], !*{#ClassInstance}, !*{# ClassDef}, !*{# MemberDef}, !*{#DclModule}, !*TypeHeaps, !*VarHeap, !*CheckState)
determineTypesOfInstances first_memb_inst_index mod_index com_instance_defs com_class_defs com_member_defs
Martin Wierich's avatar
Martin Wierich committed
513
		modules type_heaps var_heap cs=:{cs_error, cs_x={x_main_dcl_module_n}}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
514
515
516
	| 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)
Martin Wierich's avatar
Martin Wierich committed
517
				= 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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
518
						modules com_instance_defs type_heaps var_heap cs_error
519
520
521
		= (memb_inst_defs, next_mem_inst_index, all_class_specials, com_instance_defs, com_class_defs,
		   com_member_defs, modules, type_heaps, var_heap, { cs & cs_error = cs_error })
		= ([], first_memb_inst_index, [], com_instance_defs, com_class_defs, com_member_defs, modules, type_heaps, var_heap, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
522
523
where

Martin Wierich's avatar
Martin Wierich committed
524
	determine_types_of_instances :: !Index !Index !Index !Index !Index ![ClassInstance] !v:{#ClassDef} !w:{#MemberDef}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
525
526
		!x:{#DclModule} !*{#ClassInstance} !*TypeHeaps !*VarHeap !*ErrorAdmin
			-> (![FunType], !Index, ![ClassInstance], !v:{#ClassDef}, !w:{#MemberDef}, !x:{#DclModule}, !*{#ClassInstance}, !*TypeHeaps, !*VarHeap, !*ErrorAdmin)
Martin Wierich's avatar
Martin Wierich committed
527
	determine_types_of_instances x_main_dcl_module_n inst_index next_class_inst_index next_mem_inst_index mod_index all_class_specials
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
528
529
			class_defs member_defs modules instance_defs type_heaps var_heap error
		| inst_index < size instance_defs
530
			# (instance_def, instance_defs) = instance_defs![inst_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
531
			# {ins_class,ins_pos,ins_type,ins_specials} = instance_def
Martin Wierich's avatar
Martin Wierich committed
532
			  ({class_name, class_members}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
533
			  class_size = size class_members
Martin Wierich's avatar
Martin Wierich committed
534
535
536
			  (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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
537
538
539
540
			  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)
Martin Wierich's avatar
Martin Wierich committed
541
			  		= 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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
542
543
544
545
546
			  				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)

Martin Wierich's avatar
Martin Wierich committed
547
548
549
550
551
	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
552
		| mem_offset == class_size
Martin Wierich's avatar
Martin Wierich committed
553
			=  ([], [], member_defs, modules, type_heaps, var_heap, cs_error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
554
555
			# 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
Martin Wierich's avatar
Martin Wierich committed
556
557
			  (instance_type, new_ins_specials, type_heaps, Yes cs_error) = determineTypeOfMemberInstance me_type me_class_vars ins_type ins_specials type_heaps (Yes cs_error)
			  (_, modules, cs_error) = checkTopLevelKinds x_main_dcl_module_n False ins_pos class_name instance_type cDummyArray modules cs_error
558
			  (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
559
			  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
560
561
562
563
			  (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
564
565
566
567
568
569
570
571
572

	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
Martin Wierich's avatar
Martin Wierich committed
573
			# (special_type, type_heaps, error) = substituteInstanceType ins_type subst type_heaps error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
			  (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)


Martin Wierich's avatar
Martin Wierich committed
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
checkTopLevelKinds :: !Index !Bool !Position Ident !SymbolType n:{# CheckedTypeDef} !r:{# DclModule} !*ErrorAdmin
					-> (!n:{# CheckedTypeDef}, !r:{# DclModule}, !*ErrorAdmin)
checkTopLevelKinds x_main_dcl_module_n is_icl_module ins_pos class_ident st=:{st_args, st_result} type_defs modules cs_error
	#! ok = all (\{at_type} -> kind_is_ok x_main_dcl_module_n is_icl_module type_defs modules 0 at_type) [st_result:st_args]
	# cs_error
	  		= case ok of
	  			True
	  				-> cs_error
	  			_ 
	  				# cs_error
	  						= pushErrorAdmin (newPosition class_ident ins_pos) cs_error
	  				  cs_error
	  				  		= checkError "" "instance types have wrong kind" cs_error
	  				-> popErrorAdmin cs_error
	= (type_defs, modules, cs_error)
  where
	kind_is_ok x_main_dcl_module_n is_icl_module type_defs modules demanded_kind type=:(TA {type_index={glob_object,glob_module}} args)
		# {td_arity}
				= if (glob_module==x_main_dcl_module_n && is_icl_module) type_defs.[glob_object]
				     modules.[glob_module].dcl_common.com_type_defs.[glob_object]
		= demanded_kind == td_arity-length args
	kind_is_ok _ _ _ modules 0 (_ --> _)
		= True
	kind_is_ok _ _ _ modules _ (_ :@: _)
		= True
	kind_is_ok _ _ _ _ 0 (TB _)
		= True
	kind_is_ok _ _ _ _ _ (GTV _)
		= True
	kind_is_ok _ _ _ _ _ (TV _)
		= True
	kind_is_ok _ _ _ _ _ (TQV _)
		= True
	kind_is_ok _ _ _ _ _ _
		= False
		

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648

consOptional (Yes thing) things
	= [ thing : things]
consOptional No things
	= things



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)

checkFunction :: !Index !Index !Level !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef},!*ExpressionInfo, !*Heaps, !*CheckState);
checkFunction mod_index fun_index def_level fun_defs
649
			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}
650
	# (fun_def,fun_defs) = fun_defs![fun_index]
Martin Wierich's avatar
Martin Wierich committed
651
652
	# {fun_symb,fun_pos,fun_body,fun_type,fun_kind} = fun_def
	  cs = { cs & cs_error = push_error_admin_beautifully fun_symb fun_pos fun_kind cs_error }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
653
654
655
	  (fun_type, ef_type_defs, ef_class_defs, ef_modules, hp_var_heap, hp_type_heaps, cs)
			= check_function_type fun_type mod_index ef_type_defs ef_class_defs ef_modules hp_var_heap hp_type_heaps cs
	  e_info  = { e_info & ef_type_defs = ef_type_defs, ef_class_defs = ef_class_defs, ef_modules = ef_modules }
656
	  e_state = {   es_var_heap = hp_var_heap, es_expr_heap = hp_expression_heap, es_type_heaps = hp_type_heaps,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
657
658
659
660
	  				es_dynamics = [], es_calls = [], es_fun_defs = fun_defs }
	  e_input = { ei_expr_level = inc def_level, ei_fun_index = fun_index, ei_fun_level = inc def_level, ei_mod_index = mod_index }
	  (fun_body, free_vars, e_state, e_info, cs) = checkFunctionBodies fun_body e_input e_state e_info cs

661
662
663
	# {es_fun_defs,es_calls,es_var_heap,es_expr_heap,es_type_heaps,es_dynamics} = e_state
	  (ef_type_defs, ef_modules, es_type_heaps, es_expr_heap, cs) = 
	  	checkDynamicTypes mod_index es_dynamics fun_type e_info.ef_type_defs e_info.ef_modules es_type_heaps es_expr_heap cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
664
	  cs = { cs & cs_error = popErrorAdmin cs.cs_error }
665
	  fi_properties = (if ef_is_macro_fun FI_IsMacroFun 0) bitor (has_type fun_type)
666
	  fun_info = { fun_def.fun_info & fi_calls = es_calls, fi_def_level = def_level, fi_free_vars = free_vars, fi_dynamics = es_dynamics,
667
	  								  fi_properties = fi_properties }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
668
669
670
671
	  fun_defs = { es_fun_defs & [fun_index] = { fun_def & fun_body = fun_body, fun_index = fun_index, fun_info = fun_info, fun_type = fun_type}}
	  (fun_defs, cs_symbol_table) = remove_calls_from_symbol_table fun_index def_level es_calls fun_defs cs.cs_symbol_table
	= (fun_defs,
			{ e_info & ef_type_defs = ef_type_defs, ef_modules = ef_modules },
672
			{ heaps & hp_var_heap = es_var_heap, hp_expression_heap = es_expr_heap, hp_type_heaps = es_type_heaps }, 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
673
674
675
			{ cs & cs_symbol_table = cs_symbol_table })

where
676
677
678
	has_type (Yes _) 	= FI_HasTypeSpec
	has_type no 		= 0
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
679
	check_function_type (Yes ft) module_index type_defs class_defs modules var_heap type_heaps cs
680
		# (ft, _, type_defs, class_defs, modules, type_heaps, cs) = checkFunctionType module_index ft SP_None type_defs class_defs modules type_heaps cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
681
682
683
684
685
686
687
688
		  (st_context, var_heap) = initializeContextVariables ft.st_context var_heap
		= (Yes { ft & st_context = st_context } , type_defs,  class_defs, modules, var_heap, type_heaps, cs)

	check_function_type No module_index type_defs class_defs modules var_heap type_heaps cs
		= (No, type_defs,  class_defs, modules, var_heap, type_heaps, cs)

	remove_calls_from_symbol_table fun_index fun_level [{fc_index, fc_level} : fun_calls] fun_defs symbol_table
		| fc_level <= fun_level
689
690
			# ({fun_symb=fun_symb=:{id_info}}, fun_defs) = fun_defs![fc_index]
			# (entry, symbol_table) = readPtr id_info symbol_table
691
			# (c,cs) = get_calls entry.ste_kind 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
692
693
694
695
696
697
698
699
			| fun_index == c
				= remove_calls_from_symbol_table fun_index fun_level fun_calls fun_defs (symbol_table <:= (id_info,{ entry & ste_kind = STE_FunctionOrMacro cs}))
				= abort " Error in remove_calls_from_symbol_table"
			= remove_calls_from_symbol_table fun_index fun_level fun_calls fun_defs symbol_table
	remove_calls_from_symbol_table fun_index fun_level [] fun_defs symbol_table
		= (fun_defs, symbol_table)

	get_calls (STE_FunctionOrMacro [x:xs]) = (x,xs)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
700
	get_calls ste_kind = abort "get_calls (check.icl)" // <<- ste_kind
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
701

702
703
704
705
706
	push_error_admin_beautifully {id_name} fun_pos (FK_ImpFunction fun_name_is_location_dependent) cs_error
		| fun_name_is_location_dependent && size id_name>0
			# beautiful_name = if (id_name.[0]==backslash) "lambda" "comprehension"
			= pushErrorAdmin (newPosition { id_name=beautiful_name, id_info=nilPtr } fun_pos) cs_error
	push_error_admin_beautifully {id_name} fun_pos (FK_DefFunction fun_name_is_location_dependent) cs_error
Martin Wierich's avatar
Martin Wierich committed
707
708
709
710
711
712
		| fun_name_is_location_dependent && size id_name>0
			# beautiful_name = if (id_name.[0]==backslash) "lambda" "comprehension"
			= pushErrorAdmin (newPosition { id_name=beautiful_name, id_info=nilPtr } fun_pos) cs_error
	push_error_admin_beautifully fun_symb fun_pos _ cs_error
		= pushErrorAdmin (newPosition fun_symb fun_pos) cs_error

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
713
714
715
716
717
718
719
720
721
checkFunctions :: !Index !Level !Index !Index !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef}, !*ExpressionInfo, !*Heaps, !*CheckState)
checkFunctions mod_index level from_index to_index fun_defs e_info heaps cs
	| from_index == to_index
		= (fun_defs, e_info, heaps, cs)
		# (fun_defs, e_info, heaps, cs) = checkFunction mod_index from_index level fun_defs e_info heaps cs
		= checkFunctions mod_index level (inc from_index) to_index fun_defs e_info heaps cs

checkMacros ::  !Index !IndexRange !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState
	-> (!*{#FunDef}, !*ExpressionInfo, !*Heaps, !*CheckState);
722
checkMacros mod_index range fun_defs e_info=:{ef_is_macro_fun=ef_is_macro_fun_old} heaps cs
723
	# (fun_defs, e_info, heaps=:{hp_var_heap, hp_expression_heap}, cs=:{cs_symbol_table, cs_predef_symbols, cs_error})
724
725
			= checkFunctions mod_index cGlobalScope range.ir_from range.ir_to fun_defs { e_info & ef_is_macro_fun=True } heaps cs
	  (e_info=:{ef_modules}) = { e_info & ef_is_macro_fun=ef_is_macro_fun_old }
726
	  (pds_alias_dummy, cs_predef_symbols) = cs_predef_symbols![PD_DummyForStrictAliasFun]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
727
	  (fun_defs, ef_modules, hp_var_heap, hp_expression_heap, cs_symbol_table, cs_error)
728
	  		= partitionateMacros range mod_index pds_alias_dummy fun_defs ef_modules hp_var_heap hp_expression_heap cs_symbol_table cs_error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
729
	= (fun_defs, { e_info & ef_modules = ef_modules }, {heaps &  hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap},
730
			{ cs & cs_symbol_table = cs_symbol_table, cs_predef_symbols = cs_predef_symbols, cs_error = cs_error })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
731
732

checkInstanceBodies :: !IndexRange !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef},!*ExpressionInfo,!*Heaps, !*CheckState);
733
734
checkInstanceBodies {ir_from, ir_to} fun_defs e_info heaps cs=:{cs_x}
	= checkFunctions cs_x.x_main_dcl_module_n cGlobalScope ir_from ir_to fun_defs e_info heaps cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
735
736
737
738
739

instance < FunDef 
where
	(<) fd1 fd2 = fd1.fun_symb.id_name < fd2.fun_symb.id_name

740
createCommonDefinitions {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances, def_generics}
741
	=	{	com_type_defs		= { type \\ type <- def_types }
742
743
744
	
		,	com_unexpanded_type_defs = {}

745
746
		,	com_cons_defs		= { cons \\ cons <- def_constructors }
		,	com_selector_defs	= { sel \\ sel <- def_selectors }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
747
748
749
		,	com_class_defs		= { class_def \\ class_def <- def_classes }
		,	com_member_defs		= { member \\ member <- def_members }
		,	com_instance_defs	= { next_instance \\ next_instance <- def_instances }
750
		,	com_generic_defs	= { gen \\ gen <- def_generics }		
751
		}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
752

753
754
array_plus_list a [] = a
array_plus_list a l = arrayPlusList a l
755

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
756
757
758
checkCommonDefinitions :: !Bool !Index !*CommonDefs !*{# DclModule} !*TypeHeaps !*VarHeap !*CheckState
	-> (!*CommonDefs, !*{# DclModule}, !*TypeHeaps,  !*VarHeap, !*CheckState)
checkCommonDefinitions is_dcl module_index common modules type_heaps var_heap cs
759
	#! is_main_dcl_mod = is_dcl && module_index == cs.cs_x.x_main_dcl_module_n
760
	# (com_type_defs, com_cons_defs, com_selector_defs, modules, var_heap, type_heaps, cs)
Martin Wierich's avatar
Martin Wierich committed
761
			= checkTypeDefs is_dcl is_main_dcl_mod common.com_type_defs module_index
762
							common.com_cons_defs common.com_selector_defs modules var_heap type_heaps cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
763
764
765
766
	  (com_class_defs, com_member_defs, com_type_defs, modules, type_heaps, cs)
	  		= checkTypeClasses 0 module_index common.com_class_defs common.com_member_defs com_type_defs modules type_heaps cs
	  (com_member_defs, com_type_defs, com_class_defs, modules, type_heaps, var_heap, cs)
	  		= checkMemberTypes module_index com_member_defs com_type_defs com_class_defs modules type_heaps var_heap cs
767
768
769
770
771
772
773
// AA..
	  (com_generic_defs, com_class_defs, com_type_defs, modules, type_heaps, cs)
			= checkGenerics 0 module_index common.com_generic_defs com_class_defs com_type_defs modules type_heaps cs
// ..AA
	  (com_instance_defs, com_type_defs, com_class_defs, com_member_defs, /*AA*/com_generic_defs, modules, type_heaps, cs)
	  		= checkInstanceDefs module_index common.com_instance_defs com_type_defs com_class_defs com_member_defs /*AA*/com_generic_defs modules type_heaps cs
	
774
775
776
777
	  (size_com_type_defs,com_type_defs) = usize com_type_defs
	  (size_com_selector_defs,com_selector_defs) = usize com_selector_defs
	  (size_com_cons_defs,com_cons_defs) = usize com_cons_defs

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
778
	  (com_class_defs, modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, var_heap, cs)
779
780
781
782
783
784
785
	  	= createClassDictionaries module_index com_class_defs modules size_com_type_defs size_com_selector_defs size_com_cons_defs
	  		type_heaps.th_vars var_heap cs

	  com_type_defs = array_plus_list com_type_defs new_type_defs
	  com_selector_defs = array_plus_list com_selector_defs new_selector_defs
	  com_cons_defs = array_plus_list com_cons_defs new_cons_defs

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
786
	= ({common & com_type_defs = com_type_defs, com_cons_defs = com_cons_defs, com_selector_defs = com_selector_defs, com_class_defs = com_class_defs,
787
			com_member_defs = com_member_defs,  com_instance_defs = com_instance_defs, /* AA */ com_generic_defs = com_generic_defs }, modules, { type_heaps & th_vars = th_vars }, var_heap, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
788

789
collectCommonfinitions :: !(CollectedDefinitions ClassInstance a) -> (!*{# Int}, ![Declaration])
790
collectCommonfinitions {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances, def_generics} 
791
	// MW: the order in which the declarations appear in the returned list is essential (explicit imports)
792
	# sizes = createArray cConversionTableSize 0
793
	  (size, defs) = foldSt cons_def_to_dcl def_constructors (0, [])
794
795
796
	  sizes = { sizes & [cConstructorDefs] = size }
	  (size, defs) = foldSt selector_def_to_dcl def_selectors (0, defs)
	  sizes = { sizes & [cSelectorDefs] = size }
797
798
	  (size, defs) = foldSt type_def_to_dcl def_types (0, defs)
	  sizes = { sizes & [cTypeDefs] = size }
799
800
	  (size, defs) = foldSt member_def_to_dcl def_members (0, defs)
	  sizes = { sizes & [cMemberDefs] = size }
801
802
803
804
	  (size, defs) = foldSt class_def_to_dcl def_classes (0, defs)
	  sizes = { sizes & [cClassDefs] = size }
	  (size, defs) = foldSt instance_def_to_dcl def_instances (0, defs)
	  sizes = { sizes & [cInstanceDefs] = size }
805
806
807
808
// AA..
	  (size, defs) = foldSt generic_def_to_dcl def_generics (0, defs)
	  sizes = { sizes & [cGenericDefs] = size }
// ..AA
809
810
	= (sizes, defs)
where
811
812
813
814
815
816
817
818
819
820
821
822
	type_def_to_dcl {td_name, td_pos} (decl_index, decls)
		= (inc decl_index, [Declaration { decl_ident = td_name, decl_pos = td_pos, decl_kind = STE_Type, decl_index = decl_index } : decls]) 
	cons_def_to_dcl {cons_symb, cons_pos} (decl_index, decls)
		= (inc decl_index, [Declaration { decl_ident = cons_symb, decl_pos = cons_pos, decl_kind = STE_Constructor, decl_index = decl_index } : decls]) 
	selector_def_to_dcl {sd_symb, sd_field, sd_pos} (decl_index, decls)
		= (inc decl_index, [Declaration { decl_ident = sd_field, decl_pos = sd_pos, decl_kind = STE_Field sd_symb, decl_index = decl_index } : decls]) 
	class_def_to_dcl {class_name, class_pos} (decl_index, decls)
		= (inc decl_index, [Declaration { decl_ident = class_name, decl_pos = class_pos, decl_kind = STE_Class, decl_index = decl_index } : decls]) 
	member_def_to_dcl {me_symb, me_pos} (decl_index, decls)
		= (inc decl_index, [Declaration { decl_ident = me_symb, decl_pos = me_pos, decl_kind = STE_Member, decl_index = decl_index } : decls]) 
	instance_def_to_dcl {ins_class, ins_ident, ins_pos} (decl_index, decls)
		= (inc decl_index, [Declaration { decl_ident = ins_ident, decl_pos = ins_pos, decl_kind = STE_Instance ins_class.glob_object.ds_ident, decl_index = decl_index } : decls])
823
// AA..
824
825
826
827
	generic_def_to_dcl {gen_name, gen_member_name, gen_type, gen_pos} (decl_index, decls)
		# generic_decl = Declaration { decl_ident = gen_name, decl_pos = gen_pos, decl_kind = STE_Generic, decl_index = decl_index }
		# member_decl = Declaration { decl_ident = gen_member_name, decl_pos = gen_pos, decl_kind = STE_Generic, decl_index = decl_index }
		= (inc decl_index, [generic_decl, member_decl : decls]) 
828
829
// ..AA

830
831
832
833
834
835
836
collectMacros {ir_from,ir_to} macro_defs sizes_defs
	= collectGlobalFunctions cMacroDefs ir_from ir_to macro_defs sizes_defs

collectFunctionTypes fun_types (sizes, defs)
	# (size, defs) = foldSt fun_type_to_dcl fun_types (0, defs)
	= ({ sizes & [cFunctionDefs] = size }, defs)
where
837
838
	fun_type_to_dcl {ft_symb, ft_pos} (decl_index, decls) 
		= (inc decl_index, [Declaration { decl_ident = ft_symb, decl_pos = ft_pos, decl_kind = STE_DclFunction, decl_index = decl_index } : decls]) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
839

840
841
842
collectGlobalFunctions def_index from_index to_index fun_defs (sizes, defs)
	# (defs, fun_defs) = iFoldSt fun_def_to_dcl from_index to_index (defs, fun_defs)  
	= (fun_defs, ({ sizes & [def_index] = to_index - from_index }, defs))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
843
where
844
845
846
	fun_def_to_dcl decl_index (defs, fun_defs)
		# ({fun_symb, fun_pos}, fun_defs) = fun_defs![decl_index]
		= ([Declaration { decl_ident = fun_symb, decl_pos = fun_pos, decl_kind = STE_FunctionOrMacro [], decl_index = decl_index } : defs], fun_defs)
847

848
849
850
851
852
853
854
855
gimme_a_lazy_array_type :: !u:{.a} -> v:{.a}, [u<=v]
gimme_a_lazy_array_type a = a

gimme_a_strict_array_type :: !u:{!.a} -> v:{!.a}, [u<=v]
gimme_a_strict_array_type a = a

renumber_icl_definitions_as_dcl_definitions :: !ModuleKind ![Declaration] !*{#DclModule} !*CommonDefs !{#Int} !*CheckState
											-> (![Declaration], !.{#DclModule}, !.CommonDefs, !.CheckState)
856
857
858
859
860
861
renumber_icl_definitions_as_dcl_definitions MK_Main icl_decl_symbols modules cdefs icl_sizes cs
	= (icl_decl_symbols,modules,cdefs,cs)
renumber_icl_definitions_as_dcl_definitions _ icl_decl_symbols modules cdefs icl_sizes cs
	#! main_dcl_module_n=cs.cs_x.x_main_dcl_module_n
	# (dcl_mod,modules) = modules![main_dcl_module_n]
	# (Yes conversion_table) = dcl_mod.dcl_conversions
862
	# icl_to_dcl_index_table = gimme_a_lazy_array_type {create_icl_to_dcl_index_table_for_kind table_size dcl_to_icl_table \\ table_size <-: icl_sizes & dcl_to_icl_table <-: conversion_table }
863
		with
864
			create_icl_to_dcl_index_table_for_kind :: !Int !{#Int} -> {#Int}
865
			create_icl_to_dcl_index_table_for_kind table_size dcl_to_icl_table
866
				# icl_to_dcl_index_table_for_kind = {createArray table_size NoIndex & [dcl_to_icl_table.[decl_index]]=decl_index \\ decl_index<- [0..size dcl_to_icl_table-1]}
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
				#! max_index=size icl_to_dcl_index_table_for_kind-1
				# icl_to_dcl_index_table_for_kind = number_NoIndex_elements max_index max_index icl_to_dcl_index_table_for_kind
					with
						number_NoIndex_elements :: Int Int *{#Int} -> .{#Int};
						number_NoIndex_elements index free_position_index icl_to_dcl_index_table_for_kind
							| index>=0
								| icl_to_dcl_index_table_for_kind.[index]==NoIndex
									= number_NoIndex_elements (index-1) (free_position_index-1) {icl_to_dcl_index_table_for_kind & [index]=free_position_index}
									= number_NoIndex_elements (index-1) free_position_index icl_to_dcl_index_table_for_kind
								= icl_to_dcl_index_table_for_kind
				= icl_to_dcl_index_table_for_kind
	# modules = {modules & [main_dcl_module_n] = { dcl_mod & dcl_conversions = Yes conversion_table}}
	# (icl_decl_symbols,cdefs) = renumber_icl_decl_symbols icl_decl_symbols cdefs
		with
			renumber_icl_decl_symbols [] cdefs
				= ([],cdefs)
			renumber_icl_decl_symbols [icl_decl_symbol : icl_decl_symbols] cdefs
				# (icl_decl_symbol,cdefs) = renumber_icl_decl_symbol icl_decl_symbol cdefs
				# (icl_decl_symbols,cdefs) = renumber_icl_decl_symbols icl_decl_symbols cdefs
				= ([icl_decl_symbol : icl_decl_symbols],cdefs)
				where
888
889
					renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Type, decl_index}) cdefs
						# (type_def,cdefs) = cdefs!com_type_defs.[decl_index]
890
						# type_def = renumber_type_def type_def
891
892
						# cdefs={cdefs & com_type_defs.[decl_index]=type_def}
						= (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cTypeDefs,decl_index]},cdefs)
893
894
895
896
897
898
899
900
901
902
						where
							renumber_type_def td=:{td_rhs = AlgType conses}
								# conses = [{cons & ds_index=icl_to_dcl_index_table.[cConstructorDefs,cons.ds_index]} \\ cons <- conses]
								= { td & td_rhs = AlgType conses}
							renumber_type_def td=:{td_rhs = RecordType rt=:{rt_constructor,rt_fields}}
								# rt_constructor = {rt_constructor & ds_index=icl_to_dcl_index_table.[cConstructorDefs,rt_constructor.ds_index]}
								# rt_fields = {{field & fs_index=icl_to_dcl_index_table.[cSelectorDefs,field.fs_index]} \\ field <-: rt_fields}
								= {td & td_rhs=RecordType {rt_constructor=rt_constructor,rt_fields=rt_fields}}
							renumber_type_def td
								= td
903
904
905
906
907
908
909
910
					renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Constructor, decl_index}) cdefs
						= (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cConstructorDefs,decl_index]},cdefs)
					renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Field _, decl_index}) cdefs
						= (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cSelectorDefs,decl_index]},cdefs)
					renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Member, decl_index}) cdefs
						= (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cMemberDefs,decl_index]},cdefs)
					renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Class, decl_index}) cdefs
						# (class_def,cdefs) = cdefs!com_class_defs.[decl_index]
911
912
						# class_members = {{class_member & ds_index=icl_to_dcl_index_table.[cMemberDefs,class_member.ds_index]} \\ class_member <-: class_def.class_members}
						# class_def = {class_def & class_members=class_members}