check.icl 143 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
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
checkTypeClasses :: !Index !Index !*{#ClassDef} !*{#MemberDef} !*{#CheckedTypeDef} !*{#DclModule} !*TypeHeaps !*CheckState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
19
	-> (!*{#ClassDef}, !*{#MemberDef}, !*{#CheckedTypeDef}, !*{#DclModule}, !*TypeHeaps, !*CheckState)
20
checkTypeClasses class_index module_index class_defs member_defs type_defs modules type_heaps=:{th_vars} cs=:{cs_symbol_table,cs_error}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
21
22
	| class_index == size class_defs
		= (class_defs, member_defs, type_defs, modules, type_heaps, cs)
23
		# (class_def=:{class_name,class_pos,class_args,class_context,class_members}, class_defs) = class_defs![class_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
24
25
26
27
28
29
30
31
32
33
		  position = newPosition class_name class_pos
		  cs_error = setErrorAdmin position cs_error
		  (rev_class_args, cs_symbol_table, th_vars, cs_error)
		  		= add_variables_to_symbol_table cGlobalScope class_args [] cs_symbol_table th_vars cs_error
		  cs = {cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error }
		  (class_context, type_defs, class_defs, modules, type_heaps, cs)
		  		= checkTypeContexts class_context module_index type_defs class_defs modules { type_heaps & th_vars = th_vars } cs
		  (class_args, cs_symbol_table) = retrieve_variables_from_symbol_table rev_class_args [] cs.cs_symbol_table
		  class_defs = { class_defs & [class_index] = { class_def & class_context = class_context, class_args = class_args }}
		  member_defs = set_classes_in_member_defs 0 class_members {glob_object = class_index, glob_module = module_index} member_defs 
34
		= checkTypeClasses (inc class_index) module_index class_defs member_defs type_defs modules type_heaps { cs & cs_symbol_table = cs_symbol_table }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
35
36
37
38
39
40
where
	add_variables_to_symbol_table :: !Level ![TypeVar] ![TypeVar] !*SymbolTable !*TypeVarHeap !*ErrorAdmin
		-> (![TypeVar],!*SymbolTable,!*TypeVarHeap,!*ErrorAdmin)
	add_variables_to_symbol_table level [] rev_class_args symbol_table th_vars error
		= (rev_class_args, symbol_table, th_vars, error)
	add_variables_to_symbol_table level [var=:{tv_name={id_name,id_info}} : vars] rev_class_args symbol_table th_vars error
41
	  	# (entry, symbol_table) = readPtr id_info symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
42
43
44
45
46
47
		| entry.ste_kind == STE_Empty || entry.ste_def_level < level
			# (new_var_ptr, th_vars) = newPtr TVI_Empty th_vars
			# symbol_table = NewEntry symbol_table id_info (STE_TypeVariable new_var_ptr) NoIndex level entry
			= add_variables_to_symbol_table level vars [{ var & tv_info_ptr = new_var_ptr} : rev_class_args] symbol_table th_vars error
			= add_variables_to_symbol_table level  vars rev_class_args symbol_table th_vars (checkError id_name "(variable) already defined" error)

48
	retrieve_variables_from_symbol_table :: ![TypeVar] ![TypeVar] !*SymbolTable -> (![TypeVar],!*SymbolTable)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
49
	retrieve_variables_from_symbol_table [var=:{tv_name={id_name,id_info}} : vars] class_args symbol_table
50
		# (entry, symbol_table) = readPtr id_info symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
51
52
53
54
55
56
57
58
		= retrieve_variables_from_symbol_table vars [var : class_args] (symbol_table <:= (id_info,entry.ste_previous))
	retrieve_variables_from_symbol_table [] class_args symbol_table
		= (class_args, symbol_table)
	
	set_classes_in_member_defs mem_offset class_members glob_class_index member_defs
		| mem_offset == size class_members
			= member_defs
			# {ds_index} = class_members.[mem_offset]
59
			# (member_def, member_defs) = member_defs![ds_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
			= set_classes_in_member_defs (inc mem_offset) class_members glob_class_index { member_defs & [ds_index] = { member_def & me_class = glob_class_index }}

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

80
81
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
82
83
84
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
85
86
	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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
	check_dcl_functions module_index [] fun_index next_inst_index collected_funtypes collected_instances type_defs class_defs modules heaps cs
		= (next_inst_index, collected_funtypes, collected_instances, type_defs, class_defs, modules, heaps, cs)
	check_dcl_functions module_index [fun_type=:{ft_symb,ft_type,ft_pos,ft_specials} : fun_types] fun_index
			next_inst_index collected_funtypes collected_instances type_defs class_defs modules heaps cs
		# position = newPosition ft_symb ft_pos
		  cs = { cs & cs_error = setErrorAdmin position cs.cs_error }
		  (ft_type, ft_specials, type_defs,  class_defs, modules, hp_type_heaps, cs)
		  		= checkSymbolType module_index ft_type ft_specials type_defs class_defs modules heaps.hp_type_heaps cs
		  (spec_types, next_inst_index, collected_instances, heaps, cs_error)
		  		= check_specials module_index { fun_type & ft_type = ft_type } fun_index ft_specials next_inst_index collected_instances
		  				{ heaps & hp_type_heaps = hp_type_heaps } cs.cs_error
		  (new_info_ptr, hp_var_heap) = newPtr VI_Empty heaps.hp_var_heap
		= check_dcl_functions module_index fun_types (inc fun_index) next_inst_index [
				{ fun_type & ft_type = ft_type, ft_specials = spec_types, ft_type_ptr = new_info_ptr } : collected_funtypes]
					collected_instances type_defs class_defs modules { heaps & hp_var_heap = hp_var_heap } { cs & cs_error = cs_error }

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


checkSpecialsOfInstances :: !Index !Index ![ClassInstance] !Index ![ClassInstance] ![FunType] {# FunType} *{! [Special] } !*Heaps !*ErrorAdmin
		-> (!Index, ![ClassInstance], ![FunType], !*{! [Special]}, !*Heaps, !*ErrorAdmin)
checkSpecialsOfInstances mod_index first_mem_index [class_inst=:{ins_members,ins_specials} : class_insts] next_inst_index all_class_instances all_specials
		new_inst_defs all_spec_types heaps error
	= case ins_specials of
		SP_TypeOffset type_offset
			# (next_inst_index, rev_mem_specials, all_specials, all_spec_types, heaps, error)
				= check_and_build_members mod_index first_mem_index 0 ins_members type_offset next_inst_index [] all_specials new_inst_defs all_spec_types heaps error
			  class_inst = { class_inst & ins_members = { mem \\ mem <- reverse rev_mem_specials } }
			-> checkSpecialsOfInstances mod_index first_mem_index class_insts next_inst_index [class_inst : all_class_instances]
					all_specials new_inst_defs all_spec_types heaps error
		SP_None
			-> checkSpecialsOfInstances mod_index first_mem_index class_insts next_inst_index [class_inst : all_class_instances]
					all_specials new_inst_defs all_spec_types heaps error
where
128
129
	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
130
131
132
133
134
135
	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
136
		 	# (spec_types, all_spec_types) = all_spec_types![spec_member_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
		 	# mem_inst = inst_spec_defs.[spec_member_index]
		 	  (SP_Substitutions specials) = mem_inst.ft_specials
		 	  env = specials !! type_offset
			  member = { member & ds_index = next_inst_index }
			  (spec_type, (next_inst_index, all_specials, heaps, error))
			  		= checkSpecial mod_index mem_inst member_index env (next_inst_index, all_specials, heaps, error)
			  all_spec_types = { all_spec_types & [spec_member_index] = [ spec_type : spec_types] }
			= check_and_build_members mod_index first_mem_index (inc member_offset) ins_members type_offset next_inst_index [ member : rev_mem_specials ]
					all_specials inst_spec_defs all_spec_types heaps error
			= (next_inst_index, rev_mem_specials, all_specials, all_spec_types, heaps, error)

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

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

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

checkInstanceDefs :: !Index !*{#ClassInstance} !u:{#CheckedTypeDef} !u:{#ClassDef} !u:{#MemberDef} !u:{#DclModule} !*TypeHeaps !*CheckState
	-> (!.{#ClassInstance},!u:{#CheckedTypeDef},!u:{#ClassDef},!u:{#MemberDef},!u:{#DclModule},!.TypeHeaps,!.CheckState)
checkInstanceDefs mod_index instance_defs type_defs class_defs member_defs modules type_heaps cs
	# is = { is_type_defs = type_defs, is_class_defs = class_defs, is_member_defs = member_defs, is_modules = modules }
	  (instance_defs, is, type_heaps, cs) = check_instance_defs 0 mod_index instance_defs is type_heaps cs
	= (instance_defs, is.is_type_defs, is.is_class_defs, is.is_member_defs, is.is_modules, type_heaps, cs)
where	
	check_instance_defs :: !Index !Index !*{# ClassInstance} !u:InstanceSymbols !*TypeHeaps !*CheckState
		-> (!*{# ClassInstance},!u:InstanceSymbols,!*TypeHeaps,!*CheckState)
	check_instance_defs inst_index mod_index instance_defs is type_heaps cs
		| inst_index < size instance_defs
186
187
			# (instance_def, instance_defs) = instance_defs![inst_index]
			  (instance_def, is, type_heaps, cs) = check_instance mod_index instance_def is type_heaps cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
188
189
190
191
192
193
194
			= check_instance_defs (inc inst_index) mod_index { instance_defs & [inst_index] = instance_def } is type_heaps cs
			= (instance_defs, is, type_heaps, cs)

	check_instance :: !Index !ClassInstance !u:InstanceSymbols !*TypeHeaps !*CheckState -> (!ClassInstance, !u:InstanceSymbols, !*TypeHeaps, !*CheckState)
	check_instance module_index
			ins=:{ins_members,ins_class={glob_object = class_name =: {ds_ident = {id_name,id_info},ds_arity}},ins_type,ins_specials,ins_pos,ins_ident}
			is=:{is_class_defs,is_modules} type_heaps cs=:{cs_symbol_table}
195
		# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
196
197
		# (class_index, class_mod_index, class_def, is_class_defs, is_modules) = get_class_def entry module_index is_class_defs is_modules
		  is = { is & is_class_defs = is_class_defs, is_modules = is_modules }
198
		  cs = pushErrorAdmin (newPosition ins_ident ins_pos) { cs & cs_symbol_table = cs_symbol_table }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
199
200
		| class_index <> NotFound
			| class_def.class_arity == ds_arity
Martin Wierich's avatar
Martin Wierich committed
201
202
203
204
				# ins_class = { glob_object = { class_name & ds_index = class_index }, glob_module = class_mod_index}
				  (ins_type, ins_specials, is_type_defs, is_class_defs, is_modules, type_heaps, cs)
				  		= checkInstanceType module_index ins_class ins_type ins_specials
								is.is_type_defs is.is_class_defs is.is_modules type_heaps cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
205
206
207
208
209
210
211
212
213
214
215
				  is = { is & is_type_defs = is_type_defs, is_class_defs = is_class_defs, is_modules = is_modules }
				= ({ins & ins_class = ins_class, ins_type = ins_type, ins_specials = ins_specials}, is, type_heaps, popErrorAdmin cs)
				= ( ins
				  , is
				  , type_heaps
				  , popErrorAdmin { cs & cs_error = checkError id_name ("wrong arity: expected "+++toString class_def.class_arity+++" found "+++toString ds_arity) cs.cs_error }
				  )
			= (ins, is, type_heaps, popErrorAdmin { cs & cs_error = checkError id_name "class undefined" cs.cs_error })

	get_class_def :: !SymbolTableEntry !Index v:{# ClassDef} u:{# DclModule} -> (!Index,!Index,ClassDef,!v:{# ClassDef},!u:{# DclModule})
	get_class_def {ste_kind = STE_Class, ste_index} mod_index class_defs modules
216
		# (class_def, class_defs) = class_defs![ste_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
217
218
		= (ste_index, mod_index, class_def, class_defs, modules)
	get_class_def {ste_kind = STE_Imported STE_Class dcl_index, ste_index, ste_def_level} mod_index  class_defs modules
219
220
		# (dcl_mod, modules) = modules![dcl_index]
		# class_def = dcl_mod.dcl_common.com_class_defs.[ste_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
221
222
		= (ste_index, dcl_index, class_def, class_defs, modules)
	get_class_def _ mod_index class_defs modules
223
		= (NotFound, -1/*cIclModIndex*/, abort "no class definition", class_defs, modules)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
	
checkInstances :: !Index !*CommonDefs !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
	-> (![(Index,SymbolType)], !*CommonDefs, !u:{# DclModule}, !*VarHeap , !*TypeHeaps, !*CheckState)
checkInstances mod_index icl_common=:{com_instance_defs,com_class_defs,com_member_defs} modules var_heap type_heaps cs=:{cs_error}
	| cs_error.ea_ok
		# (instance_types, com_instance_defs, com_class_defs, com_member_defs, modules, var_heap, type_heaps, cs)
				= check_instances 0 mod_index [] com_instance_defs com_class_defs com_member_defs modules var_heap type_heaps cs
		= (instance_types, { icl_common & com_instance_defs = com_instance_defs,com_class_defs = com_class_defs,com_member_defs = com_member_defs },
			 	modules, var_heap, type_heaps, cs)
		= ([], icl_common, modules, var_heap, type_heaps, cs)
where
	check_instances :: !Index !Index ![(Index,SymbolType)] !x:{# ClassInstance} !w:{# ClassDef} !v:{# MemberDef} !u:{# DclModule}
		!*VarHeap !*TypeHeaps !*CheckState
			-> (![(Index,SymbolType)], !x:{# ClassInstance}, !w:{# ClassDef}, !v:{# MemberDef}, !u:{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState)
	check_instances inst_index mod_index instance_types instance_defs class_defs member_defs modules var_heap type_heaps cs
		| inst_index < size instance_defs
240
			# ({ins_class,ins_members,ins_type}, instance_defs) = instance_defs![inst_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
241
242
243
244
245
246
247
248
249
250
			# ({class_members,class_name}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules
			  class_size = size class_members
			| class_size == size ins_members
				# (instance_types, member_defs, modules, var_heap, type_heaps, cs) = check_member_instances mod_index ins_class.glob_module
			  	         0 class_size ins_members class_members ins_type instance_types member_defs modules var_heap type_heaps cs
				= check_instances (inc inst_index) mod_index instance_types instance_defs class_defs member_defs modules var_heap type_heaps cs
				= check_instances (inc inst_index) mod_index instance_types instance_defs class_defs member_defs modules var_heap type_heaps
						{ cs & cs_error = checkError class_name "different number of members specified" cs.cs_error }
			= (instance_types, instance_defs, class_defs, member_defs, modules, var_heap, type_heaps, cs)

251
252
253
	check_member_instances :: !Index !Index !Int !Int !{#DefinedSymbol} !{#DefinedSymbol} !InstanceType ![(Index,SymbolType)]
		!v:{# MemberDef} !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
			-> (![(Index,SymbolType)], !v:{# MemberDef}, !u:{# DclModule},!*VarHeap, !*TypeHeaps, !*CheckState)
254

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
	check_member_instances module_index member_mod_index mem_offset class_size ins_members class_members
				ins_type instance_types member_defs modules var_heap type_heaps cs
		| mem_offset == class_size
			= (instance_types, member_defs, modules, var_heap, type_heaps, cs)
			# ins_member = ins_members.[mem_offset]
			  class_member = class_members.[mem_offset]
			| ins_member.ds_ident <> class_member.ds_ident
				= check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members ins_type 
						instance_types member_defs modules var_heap type_heaps
							{ cs & cs_error = checkError class_member.ds_ident "instance of class member expected" cs.cs_error}
			| ins_member.ds_arity <> class_member.ds_arity
				= check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members ins_type
						instance_types member_defs modules var_heap type_heaps
							{ cs & cs_error = checkError class_member.ds_ident "used with wrong arity" cs.cs_error}
				# ({me_type,me_class_vars}, member_defs, modules) = getMemberDef member_mod_index class_member.ds_index module_index member_defs modules
				  (instance_type, _, type_heaps) = determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None type_heaps
				  (st_context, var_heap) = initializeContextVariables instance_type.st_context var_heap
				= check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members ins_type
						[ (ins_member.ds_index, { instance_type & st_context = st_context }) : instance_types ] member_defs modules var_heap type_heaps cs

getClassDef :: !(Global DefinedSymbol) !Int !u:{#ClassDef} !v:{#DclModule} -> (!ClassDef,!u:{#ClassDef},!v:{#DclModule})
getClassDef {glob_module, glob_object={ds_ident, ds_index}} mod_index class_defs modules
	| glob_module == mod_index
278
		# (class_def, class_defs) = class_defs![ds_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
279
		= (class_def, class_defs, modules)
280
		# (dcl_mod, modules) = modules![glob_module]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
281
282
283
284
285
		= (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
286
		# (member_def,member_defs) = member_defs![mem_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
287
		= (member_def, member_defs, modules)
288
		# (dcl_mod,modules) = modules![mem_mod]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
		= (dcl_mod.dcl_common.com_member_defs.[mem_index], member_defs, modules)

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

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

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

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

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

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

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

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

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

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

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

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

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

377
378
379
380
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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
381
382
383
384
385
386
		modules type_heaps var_heap cs=:{cs_error}
	| cs_error.ea_ok
		#! nr_of_class_instances = size com_instance_defs
		# (memb_inst_defs, next_mem_inst_index, all_class_specials, com_class_defs, com_member_defs, modules, com_instance_defs, type_heaps, var_heap, cs_error)
				= determine_types_of_instances 0 nr_of_class_instances first_memb_inst_index mod_index [] com_class_defs com_member_defs
						modules com_instance_defs type_heaps var_heap cs_error
387
388
389
		= (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
390
391
392
393
394
395
396
397
where

	determine_types_of_instances :: !Index !Index !Index !Index ![ClassInstance] !v:{#ClassDef} !w:{#MemberDef}
		!x:{#DclModule} !*{#ClassInstance} !*TypeHeaps !*VarHeap !*ErrorAdmin
			-> (![FunType], !Index, ![ClassInstance], !v:{#ClassDef}, !w:{#MemberDef}, !x:{#DclModule}, !*{#ClassInstance}, !*TypeHeaps, !*VarHeap, !*ErrorAdmin)
	determine_types_of_instances inst_index next_class_inst_index next_mem_inst_index mod_index all_class_specials
			class_defs member_defs modules instance_defs type_heaps var_heap error
		| inst_index < size instance_defs
398
			# (instance_def, instance_defs) = instance_defs![inst_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
			# {ins_class,ins_pos,ins_type,ins_specials} = instance_def
			  ({class_members}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules
			  class_size = size class_members
			  (ins_members, memb_inst_defs1, member_defs, modules, type_heaps, var_heap)
			  		= determine_instance_symbols_and_types next_mem_inst_index 0 mod_index ins_class.glob_module class_size class_members
			  				ins_type ins_specials ins_pos member_defs modules type_heaps var_heap
			  instance_def = { instance_def & ins_members = { member \\ member <- ins_members }}
			  (ins_specials, next_class_inst_index, all_class_specials, type_heaps, error)
					= check_instance_specials mod_index instance_def inst_index ins_specials next_class_inst_index all_class_specials type_heaps error
			  (memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, error)
			  		= determine_types_of_instances (inc inst_index) next_class_inst_index (next_mem_inst_index + class_size) mod_index all_class_specials
			  				class_defs member_defs modules { instance_defs & [inst_index] = { instance_def & ins_specials = ins_specials }} type_heaps var_heap error

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

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

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

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



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
479
			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}
480
	# (fun_def,fun_defs) = fun_defs![fun_index]
Martin Wierich's avatar
Martin Wierich committed
481
482
	# {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
483
484
485
	  (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 }
486
	  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
487
488
489
490
	  				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

491
492
493
	# {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
494
	  cs = { cs & cs_error = popErrorAdmin cs.cs_error }
495
496
	  fun_info = { fun_def.fun_info & fi_calls = es_calls, fi_def_level = def_level, fi_free_vars = free_vars, fi_dynamics = es_dynamics,
	  					fi_is_macro_fun = ef_is_macro_fun }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
497
498
499
500
	  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 },
501
			{ 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
502
503
504
505
506
507
508
509
510
511
512
513
514
			{ cs & cs_symbol_table = cs_symbol_table })

where
	check_function_type (Yes ft) module_index type_defs class_defs modules var_heap type_heaps cs
		# (ft, _, type_defs, class_defs, modules, type_heaps, cs) = checkSymbolType module_index ft SP_None type_defs class_defs modules type_heaps cs
		  (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
515
516
			# ({fun_symb=fun_symb=:{id_info}}, fun_defs) = fun_defs![fc_index]
			# (entry, symbol_table) = readPtr id_info symbol_table
517
			# (c,cs) = get_calls entry.ste_kind 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
518
519
520
521
522
523
524
525
			| 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
526
	get_calls ste_kind = abort "get_calls (check.icl)" // <<- ste_kind
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
527

528
529
530
531
532
	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
533
534
535
536
537
538
		| 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
539
540
541
542
543
544
545
546
547
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);
548
checkMacros mod_index range fun_defs e_info=:{ef_is_macro_fun=ef_is_macro_fun_old} heaps cs
549
	# (fun_defs, e_info, heaps=:{hp_var_heap, hp_expression_heap}, cs=:{cs_symbol_table, cs_predef_symbols, cs_error})
550
551
			= 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 }
552
	  (pds_alias_dummy, cs_predef_symbols) = cs_predef_symbols![PD_DummyForStrictAliasFun]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
553
	  (fun_defs, ef_modules, hp_var_heap, hp_expression_heap, cs_symbol_table, cs_error)
554
	  		= 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
555
	= (fun_defs, { e_info & ef_modules = ef_modules }, {heaps &  hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap},
556
			{ 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
557
558

checkInstanceBodies :: !IndexRange !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef},!*ExpressionInfo,!*Heaps, !*CheckState);
559
560
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
561
562
563
564
565

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

566
567
568
569
createCommonDefinitions {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances}
	=	{	com_type_defs		= { type \\ type <- def_types }
		,	com_cons_defs		= { cons \\ cons <- def_constructors }
		,	com_selector_defs	= { sel \\ sel <- def_selectors }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
570
571
572
		,	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 }
573
		}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
574

575
576
array_plus_list a [] = a
array_plus_list a l = arrayPlusList a l
577

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
578
579
580
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
581
	#! is_main_dcl_mod = is_dcl && module_index == cs.cs_x.x_main_dcl_module_n
582
	# (com_type_defs, com_cons_defs, com_selector_defs, modules, var_heap, type_heaps, cs)
583
			= checkTypeDefs is_main_dcl_mod common.com_type_defs module_index
584
							common.com_cons_defs common.com_selector_defs modules var_heap type_heaps cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
585
586
587
588
589
590
	  (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
	  (com_instance_defs, com_type_defs, com_class_defs, com_member_defs, modules, type_heaps, cs)
	  		= checkInstanceDefs module_index common.com_instance_defs com_type_defs com_class_defs com_member_defs modules type_heaps cs
591
592
593
594
595

	  (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
596
	  (com_class_defs, modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, var_heap, cs)
597
598
599
600
601
602
603
	  	= 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
604
605
606
	= ({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,
			com_member_defs = com_member_defs,  com_instance_defs = com_instance_defs }, modules, { type_heaps & th_vars = th_vars }, var_heap, cs)

607
608
collectCommonfinitions :: !(CollectedDefinitions ClassInstance a) -> (!*{# Int}, ![Declaration])
collectCommonfinitions {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances} 
609
	// MW: the order in which the declarations appear in the returned list is essential (explicit imports)
610
	# sizes = createArray cConversionTableSize 0
611
	  (size, defs) = foldSt cons_def_to_dcl def_constructors (0, [])
612
613
614
	  sizes = { sizes & [cConstructorDefs] = size }
	  (size, defs) = foldSt selector_def_to_dcl def_selectors (0, defs)
	  sizes = { sizes & [cSelectorDefs] = size }
615
616
	  (size, defs) = foldSt type_def_to_dcl def_types (0, defs)
	  sizes = { sizes & [cTypeDefs] = size }
617
618
	  (size, defs) = foldSt member_def_to_dcl def_members (0, defs)
	  sizes = { sizes & [cMemberDefs] = size }
619
620
621
622
623
624
	  (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 }
	= (sizes, defs)
where
625
	type_def_to_dcl {td_name, td_pos} (dcl_index, decls)
626
		= (inc dcl_index, [{ dcl_ident = td_name, dcl_pos = td_pos, dcl_kind = STE_Type, dcl_index = dcl_index } : decls]) 
627
	cons_def_to_dcl {cons_symb, cons_pos} (dcl_index, decls)
628
		= (inc dcl_index, [{ dcl_ident = cons_symb, dcl_pos = cons_pos, dcl_kind = STE_Constructor, dcl_index = dcl_index } : decls]) 
629
	selector_def_to_dcl {sd_symb, sd_field, sd_pos} (dcl_index, decls)
630
		= (inc dcl_index, [{ dcl_ident = sd_field, dcl_pos = sd_pos, dcl_kind = STE_Field sd_symb, dcl_index = dcl_index } : decls]) 
631
	class_def_to_dcl {class_name, class_pos} (dcl_index, decls)
632
		= (inc dcl_index, [{ dcl_ident = class_name, dcl_pos = class_pos, dcl_kind = STE_Class, dcl_index = dcl_index } : decls]) 
633
	member_def_to_dcl {me_symb, me_pos} (dcl_index, decls)
634
		= (inc dcl_index, [{ dcl_ident = me_symb, dcl_pos = me_pos, dcl_kind = STE_Member, dcl_index = dcl_index } : decls]) 
635
636
	instance_def_to_dcl {ins_class, ins_ident, ins_pos} (dcl_index, decls)
		= (inc dcl_index, [{ dcl_ident = ins_ident, dcl_pos = ins_pos, dcl_kind = STE_Instance ins_class.glob_object.ds_ident, dcl_index = dcl_index } : decls]) 
637
638
639
640
641
642
643
644
645
646

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
	fun_type_to_dcl {ft_symb, ft_pos} (dcl_index, decls) 
		= (inc dcl_index, [{ dcl_ident = ft_symb, dcl_pos = ft_pos, dcl_kind = STE_DclFunction, dcl_index = dcl_index } : decls]) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
647

648
649
650
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
651
where
652
653
654
655
	fun_def_to_dcl dcl_index (defs, fun_defs)
		# ({fun_symb, fun_pos}, fun_defs) = fun_defs![dcl_index]
		= ([{ dcl_ident = fun_symb, dcl_pos = fun_pos, dcl_kind = STE_FunctionOrMacro [], dcl_index = dcl_index } : defs], fun_defs)

656
657
658
659
660
661
662
663
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)
664
665
666
667
668
669
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
670
	# 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 }
671
		with
672
			create_icl_to_dcl_index_table_for_kind :: !Int !{#Int} -> {#Int}
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
			create_icl_to_dcl_index_table_for_kind table_size dcl_to_icl_table
				# icl_to_dcl_index_table_for_kind = {createArray table_size NoIndex & [dcl_to_icl_table.[dcl_index]]=dcl_index \\ dcl_index<- [0..size dcl_to_icl_table-1]}
				#! 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
					renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Type, dcl_index} cdefs
						# (type_def,cdefs) = cdefs!com_type_defs.[dcl_index]
						# type_def = renumber_type_def type_def
						# cdefs={cdefs & com_type_defs.[dcl_index]=type_def}
						= ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cTypeDefs,dcl_index]},cdefs)
						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
					renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Constructor, dcl_index} cdefs
						= ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cConstructorDefs,dcl_index]},cdefs)
					renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Field _, dcl_index} cdefs
						= ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cSelectorDefs,dcl_index]},cdefs)
					renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Member, dcl_index} cdefs
						= ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cMemberDefs,dcl_index]},cdefs)
					renumber_icl_decl_symbol icl_decl_symbol=:{dcl_kind = STE_Class, dcl_index} cdefs
						# (class_def,cdefs) = cdefs!com_class_defs.[dcl_index]
						# 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}
						# cdefs = {cdefs & com_class_defs.[dcl_index] =class_def}
						= ({icl_decl_symbol & dcl_index=icl_to_dcl_index_table.[cClassDefs,dcl_index]},cdefs)
					renumber_icl_decl_symbol icl_decl_symbol cdefs
						= (icl_decl_symbol,cdefs)
	# cdefs=reorder_common_definitions cdefs
		with
			reorder_common_definitions {com_type_defs,com_cons_defs,com_selector_defs,com_class_defs,com_member_defs,com_instance_defs}
				# com_type_defs=reorder_array com_type_defs icl_to_dcl_index_table.[cTypeDefs]
				# com_cons_defs=reorder_array com_cons_defs icl_to_dcl_index_table.[cConstructorDefs]
				# com_selector_defs=reorder_array com_selector_defs icl_to_dcl_index_table.[cSelectorDefs]
				# com_class_defs=reorder_array com_class_defs icl_to_dcl_index_table.[cClassDefs]
				# com_member_defs=reorder_array com_member_defs icl_to_dcl_index_table.[cMemberDefs]
				= {com_type_defs=com_type_defs,com_cons_defs=com_cons_defs,com_selector_defs=com_selector_defs,com_class_defs=com_class_defs,com_member_defs=com_member_defs,com_instance_defs=com_instance_defs}
					where
						reorder_array array index_array
							# new_array={e\\e<-:array}
							= {new_array & [index_array.[i]]=e \\ e<-:array & i<-[0..]}				
	# conversion_table = {if (kind_index<=cMemberDefs) {i\\i<-[0..size table-1]} table \\ table<-:conversion_table & kind_index<-[0..]}
	# modules = {modules & [main_dcl_module_n].dcl_conversions=Yes conversion_table}
	= (icl_decl_symbols,modules,cdefs,cs)

742
743
744


combineDclAndIclModule :: ModuleKind *{#.DclModule} [Declaration] (CollectedDefinitions a b) *{#.Int} *CheckState -> (!*{#DclModule},![Declaration],!CollectedDefinitions a b,!*{#Int},!.CheckState);
745
746
747
combineDclAndIclModule MK_Main modules icl_decl_symbols icl_definitions icl_sizes cs
	= (modules, icl_decl_symbols, icl_definitions, icl_sizes, cs)
combineDclAndIclModule _ modules icl_decl_symbols icl_definitions icl_sizes cs
748
749
	#! main_dcl_module_n=cs.cs_x.x_main_dcl_module_n
	# (dcl_mod=:{dcl_declared={dcls_local},dcl_macros, dcl_sizes, dcl_common}, modules) =  modules![main_dcl_module_n]
750
751
752

	  cs = addGlobalDefinitionsToSymbolTable icl_decl_symbols cs

753
	  (moved_dcl_defs, conversion_table, icl_sizes, icl_decl_symbols, cs)
754
			= foldSt (add_to_conversion_table dcl_macros.ir_from dcl_common) dcls_local ([], { createArray size NoIndex \\ size <-: dcl_sizes }, icl_sizes, icl_decl_symbols, cs)
755
            
756
757
	  (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
			= foldSt (add_dcl_definition dcl_common) moved_dcl_defs ([], [], [], [], [], cs)
758
759
	  cs_symbol_table
	  		= removeDeclarationsFromSymbolTable icl_decl_symbols cGlobalScope cs.cs_symbol_table
760

761
	=	( { modules & [main_dcl_module_n] = { dcl_mod & dcl_conversions = Yes conversion_table }}
762
763
		, icl_decl_symbols
		, { icl_definitions
764
765
766
767
768
				& def_types			= my_append icl_definitions.def_types new_type_defs
				, def_constructors	= my_append icl_definitions.def_constructors new_cons_defs
				, def_selectors		= my_append icl_definitions.def_selectors new_selector_defs
				, def_classes		= my_append icl_definitions.def_classes new_class_defs
				, def_members		= my_append icl_definitions.def_members new_member_defs
769
		  }
770
		,  icl_sizes
771
		, { cs & cs_symbol_table = cs_symbol_table }
772
		)
773
where
774
	add_to_conversion_table first_macro_index dcl_common decl=:{dcl_ident=dcl_ident=:{id_info},dcl_kind,dcl_index,dcl_pos}
775
776
777
778
			(moved_dcl_defs, conversion_table, icl_sizes, icl_defs, cs)
		# (entry=:{ste_kind,ste_index,ste_def_level}, cs_symbol_table) = readPtr id_info cs.cs_symbol_table
		| ste_kind == STE_Empty
			# def_index = toInt dcl_kind
779
 			| can_be_only_in_dcl def_index && not (def_index==cTypeDefs && is_abstract_type dcl_common.com_type_defs dcl_index)
780
781
782
783
784
785
786
787
788
789
				# (conversion_table, icl_sizes, icl_defs, cs_symbol_table)
					= add_dcl_declaration id_info entry decl def_index dcl_index (conversion_table, icl_sizes, icl_defs, cs_symbol_table)
				= ([ decl : moved_dcl_defs ], conversion_table, icl_sizes, icl_defs, { cs & cs_symbol_table = cs_symbol_table })
			| def_index == cMacroDefs
				# (conversion_table, icl_defs, cs_symbol_table)
					= add_macro_declaration id_info entry decl def_index (dcl_index - first_macro_index) dcl_index
								(conversion_table, icl_defs, cs_symbol_table)
				= ([ decl : moved_dcl_defs ], conversion_table, icl_sizes, icl_defs, { cs & cs_symbol_table = cs_symbol_table })
				# cs_error = checkError "definition module" "undefined in implementation module" (setErrorAdmin (newPosition dcl_ident dcl_pos) cs.cs_error)
				= (moved_dcl_defs, conversion_table, icl_sizes, icl_defs, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
790
791
792
		| ste_def_level == cGlobalScope && ste_kind == dcl_kind
			# def_index = toInt dcl_kind
			  dcl_index = if (def_index == cMacroDefs) (dcl_index - first_macro_index) dcl_index
793
			= (moved_dcl_defs, { conversion_table & [def_index].[dcl_index] = ste_index },  icl_sizes, icl_defs, { cs & cs_symbol_table = cs_symbol_table })
794
795
			# cs_error = checkError "definition module" "conflicting definition in implementation module"
					(setErrorAdmin (newPosition dcl_ident dcl_pos) cs.cs_error)
796
			= (moved_dcl_defs, conversion_table,  icl_sizes, icl_defs, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table })
797

798
799
800
801
/* To be done : cClassDefs and cMemberDefs */

	can_be_only_in_dcl def_kind
		=	def_kind == cTypeDefs	|| def_kind == cConstructorDefs || def_kind == cSelectorDefs
Martin Wierich's avatar
Martin Wierich committed
802
		||	def_kind == cClassDefs	|| def_kind == cMemberDefs
803

804
805
806
 	is_abstract_type com_type_defs dcl_index
 		= case com_type_defs.[dcl_index].td_rhs of (AbstractType _) -> True ; _ -> False
 
807
808
809
810
811
812
813
814
815
816
817
818
819
	add_dcl_declaration info_ptr entry dcl def_index dcl_index (conversion_table, icl_sizes, icl_defs, symbol_table)
		# (icl_index, icl_sizes) = icl_sizes![def_index]
		=	(	{ conversion_table & [def_index].[dcl_index] = icl_index }
			,	{ icl_sizes & [def_index] = inc icl_index }
			,	[ { dcl & dcl_index = icl_index } : icl_defs ]
			,	NewEntry symbol_table info_ptr dcl.dcl_kind icl_index cGlobalScope entry
			)

	add_macro_declaration info_ptr entry dcl def_index dcl_index icl_index (conversion_table, icl_defs, symbol_table)
		=	(	{ conversion_table & [def_index].[dcl_index] = icl_index }
			,	[ { dcl & dcl_index = icl_index } : icl_defs ]
			,	NewEntry symbol_table info_ptr dcl.dcl_kind icl_index cGlobalScope entry
			)
820
	
821
822
823
824
825
826
827
828
829
830
831
832
833
	add_dcl_definition {com_type_defs} dcl=:{dcl_kind = STE_Type, dcl_index}
			(new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
		# type_def = com_type_defs.[dcl_index]
		  (new_type_defs, cs) = add_type_def type_def new_type_defs cs
		= (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
	where
		add_type_def td=:{td_pos, td_rhs = AlgType conses} new_type_defs cs
			# (conses, cs) = mapSt (redirect_defined_symbol STE_Constructor td_pos) conses cs
			= ([ { td & td_rhs = AlgType conses} : new_type_defs ], cs)
		add_type_def td=:{td_pos, td_rhs = RecordType rt=:{rt_constructor,rt_fields}} new_type_defs cs
			# (rt_constructor, cs) = redirect_defined_symbol STE_Constructor td_pos rt_constructor cs
			  (rt_fields, cs) = redirect_field_symbols td_pos rt_fields cs
			= ([ { td & td_rhs =  RecordType { rt & rt_constructor = rt_constructor, rt_fields = rt_fields }} : new_type_defs ], cs)
Martin Wierich's avatar
Martin Wierich committed
834
		add_type_def td=:{td_name, td_pos, td_rhs = AbstractType _} new_type_defs cs
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
			# cs_error = checkError "definition module" "abstract type not defined in implementation module"
					(setErrorAdmin (newPosition td_name td_pos) cs.cs_error)
			= (new_type_defs, { cs & cs_error = cs_error })
		add_type_def td new_type_defs cs
			= ([td : new_type_defs], cs) 

		redirect_field_symbols pos fields cs
			# new_fields = { field \\ field <-: fields }
			= iFoldSt (redirect_field_symbol pos fields) 0 (size fields) (new_fields, cs)
		where
			redirect_field_symbol pos fields field_nr (new_fields, cs)
				# field = fields.[field_nr]
				  ({ste_kind,ste_index}, cs_symbol_table) = readPtr field.fs_name.id_info cs.cs_symbol_table
				| is_field ste_kind
					= ({ new_fields & [field_nr] = { field & fs_index = ste_index }}, { cs & cs_symbol_table = cs_symbol_table })
					# cs_error = checkError "definition module" "conflicting definition in implementation module"
									(setErrorAdmin (newPosition field.fs_name pos) cs.cs_error)
					= (new_fields, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table })

			is_field (STE_Field _)	= True
			is_field _				= False

	add_dcl_definition {com_cons_defs} dcl=:{dcl_kind = STE_Constructor, dcl_index} 
			(new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
		= (new_type_defs, new_class_defs, [ com_cons_defs.[dcl_index] : new_cons_defs ], new_selector_defs, new_member_defs, cs)
860
861
862
	add_dcl_definition {com_selector_defs} dcl=:{dcl_kind = STE_Field _, dcl_index} 
			(new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
		= (new_type_defs, new_class_defs, new_cons_defs, [ com_selector_defs.[dcl_index] : new_selector_defs ], new_member_defs, cs)
Martin Wierich's avatar
Martin Wierich committed
863
864
865
866
867
868
869
870
871
872
873
874
875
	add_dcl_definition {com_class_defs} dcl=:{dcl_kind = STE_Class, dcl_index, dcl_pos} 
			(new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
		# class_def = com_class_defs.[dcl_index]
		  (new_class_defs, cs) = add_class_def dcl_pos class_def new_class_defs cs
		= (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
	  where
		add_class_def dcl_pos cd=:{class_members} new_class_defs cs
			# (new_class_members, cs) = mapSt (redirect_defined_symbol STE_Member dcl_pos) [ cm \\ cm<-:class_members ] cs
			= ([{cd & class_members={cm \\ cm<-new_class_members}}:new_class_defs], cs)
	add_dcl_definition {com_member_defs} dcl=:{dcl_kind = STE_Member, dcl_index, dcl_pos} 
			(new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
		# member_def = com_member_defs.[dcl_index]
		= (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, [member_def:new_member_defs], cs)
876
877
878
	add_dcl_definition _ _ 
			(new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
		= (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
879

Martin Wierich's avatar
Martin Wierich committed
880
881
882
883
	redirect_defined_symbol req_kind pos ds=:{ds_ident} cs
		# ({ste_kind,ste_index}, cs_symbol_table) = readPtr ds_ident.id_info cs.cs_symbol_table
		| ste_kind == req_kind
			= ({ ds & ds_index = ste_index }, { cs & cs_symbol_table = cs_symbol_table })
Sjaak Smetsers's avatar
Sjaak Smetsers committed
884
			# cs_error = checkError "definition module" "conflicting definition in implementation module"
Martin Wierich's avatar
Martin Wierich committed
885
886
887
							(setErrorAdmin (newPosition ds_ident pos) cs.cs_error)
			= ({ ds & ds_index = ste_index }, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table })

888
	my_append front []
889
		= front
890
891
	my_append front back
		= front ++ back
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
892
893
894
895

(<=<) infixl 
(<=<) state fun :== fun state 

896
897
898
899
900
checkDclModules imports_of_icl_mod dcl_modules icl_functions heaps cs=:{cs_symbol_table}
	#! nr_of_dcl_modules
			= size dcl_modules
	# (bitvect, dependencies, dcl_modules, cs_symbol_table)
			= iFoldSt add_dependencies 0 nr_of_dcl_modules
901
					(bitvectCreate (nr_of_dcl_modules+1), gimme_a_strict_array_type (createArray (nr_of_dcl_modules+1) []),
902
903
904
905
906
907
908
909
910
911
912
						dcl_modules, cs_symbol_table)
	  index_of_icl_module
	  		= nr_of_dcl_modules
	  (dependencies_of_icl_mod, (_, cs_symbol_table))
			= mapFilterYesSt get_opt_dependency imports_of_icl_mod (bitvect, cs_symbol_table)
	  dependencies
	  		= { dependencies & [index_of_icl_module] = dependencies_of_icl_mod }
	  module_dag
	  		= { dag_nr_of_nodes = nr_of_dcl_modules+1, dag_get_children = select dependencies }
	  components
	  		= partitionateDAG module_dag [cs.cs_x.x_main_dcl_module_n,index_of_icl_module]
913
914
915
//	| False--->("biggest component:", maxList (map length components))
//		= undef
	# (nr_of_components, component_numbers)
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
	  		= getComponentNumbers components module_dag.dag_nr_of_nodes
	  reversed_dag1
	  		= reverseDAG module_dag
	  reversed_dag
			= { module_dag & dag_get_children = select reversed_dag1 }
	  super_components
	  		= groupify reversed_dag component_numbers nr_of_components
	  		// module i is imported by components with _component_ numbers super_components.[i]
	  components_array
	  		= gimme_a_strict_array_type { component \\ component <- components }
	  (expl_imp_symbols_and_indices_in_components, (dcl_modules, cs_symbol_table))
	   		= mapSt (get_expl_imp_symbols_of_component imports_of_icl_mod) components (dcl_modules, cs_symbol_table)
	  (expl_imp_symbols_in_components, expl_imp_indices)
	  		= unzip expl_imp_symbols_and_indices_in_components
	  expl_imp_infos
	  		= { { ExplImpInfo expl_imp_symbol ikhEmpty
	  			  \\ expl_imp_symbol <- expl_imp_symbols_in_component
	  			}
	  			\\ expl_imp_symbols_in_component<-expl_imp_symbols_in_components }
	  		// eii_declaring_modules will be updated later
	  cs
	  		= { cs & cs_symbol_table = cs_symbol_table } // --->("expl_imp_symbols_in_components", expl_imp_symbols_in_components)
	  nr_of_icl_component
	  		= component_numbers.[index_of_icl_module]
	  (_, expl_imp_infos, dcl_modules, icl_functions, heaps, cs)
941
	  		= unsafeFold2St (checkDclComponent components_array super_components) (reverse expl_imp_indices) (reverse components)
942
943
944
945
946
947
948
949
950
951
952
					(nr_of_components-1, expl_imp_infos, dcl_modules, icl_functions, heaps, cs)
//	# cs = cs--->"------------------------------------"
	= (nr_of_icl_component, hd expl_imp_indices!!nr_of_icl_component, expl_imp_infos,
		dcl_modules, icl_functions, heaps, cs)
  where
	add_dependencies mod_index (bitvect, dependencies, dcl_modules, cs_symbol_table)
		// all i: not bitvect.[i]
		| mod_index==cPredefinedModuleIndex
			= (bitvect, dependencies, dcl_modules, cs_symbol_table)
		# ({dcl_name}, dcl_modules)
				= dcl_modules![mod_index]
953
		  ({ste_kind, ste_index}, cs_symbol_table)
954
				= readPtr dcl_name.id_info cs_symbol_table
955
956
957
958
959
960
961
962
963
		= case ste_kind of
			STE_Module {mod_imports}
				# (dependencies_of_mod, (bitvect, cs_symbol_table))
						= mapFilterYesSt get_opt_dependency mod_imports (bitvect, cs_symbol_table)
				  (bitvect, cs_symbol_table)
				  		= foldSt set_to_false mod_imports (bitvect, cs_symbol_table)
				-> (bitvect, { dependencies & [mod_index] = dependencies_of_mod }, dcl_modules, cs_symbol_table)
			STE_ClosedModule
				-> (bitvect, { dependencies & [mod_index] = [] }, dcl_modules, cs_symbol_table)
964
965
966
967

	get_opt_dependency {import_module} (already_visited, cs_symbol_table)
		# ({ste_index}, cs_symbol_table)
				= readPtr import_module.id_info cs_symbol_table
968
		| bitvectSelect ste_index already_visited
969
			= (No, (already_visited, cs_symbol_table))
970
		= (Yes ste_index, (bitvectSet ste_index already_visited, cs_symbol_table))
971

972
	set_to_false :: (Import x) !(!*LargeBitvect, !u:SymbolTable) -> !(!.LargeBitvect, !u:SymbolTable)
973
974
975
	set_to_false {import_module} (bitvect, cs_symbol_table)
		#! ste_index
				= (sreadPtr import_module.id_info cs_symbol_table).ste_index
976
		= (bitvectReset ste_index bitvect, cs_symbol_table)
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999

	get_expl_imp_symbols_of_component imports_of_icl_mod component (dcl_modules, cs_symbol_table)
		# (expl_imp_symbols, _, expl_imp_indices, dcl_modules, cs_symbol_table)
				= foldSt (get_expl_imp_symbols_of_module imports_of_icl_mod) component ([], 0, [], dcl_modules, cs_symbol_table)
		  cs_symbol_table
				= foldSt restoreHeap expl_imp_symbols cs_symbol_table
		= ((reverse expl_imp_symbols, reverse expl_imp_indices), (dcl_modules, cs_symbol_table))
		
	get_expl_imp_symbols_of_module imports_of_icl_mod mod_index
					(expl_imp_symbols_accu, nr_of_expl_imp_symbols, expl_imp_indices_accu, dcl_modules, cs_symbol_table)
		#! siz
				= size dcl_modules
		# (mod_imports, dcl_modules, cs_symbol_table)
				= get_mod_imports (mod_index==siz) imports_of_icl_mod dcl_modules cs_symbol_table
		  (expl_imp_symbols_accu, nr_of_expl_imp_symbols, expl_imp_indices, cs_symbol_table)
				= foldSt get_expl_imp_symbols mod_imports
						(expl_imp_symbols_accu, nr_of_expl_imp_symbols, [], cs_symbol_table)
		= (expl_imp_symbols_accu, nr_of_expl_imp_symbols, [expl_imp_indices:expl_imp_indices_accu],
			dcl_modules, cs_symbol_table)
	  where
		get_mod_imports is_icl_mod=:False _ dcl_modules cs_symbol_table
			# ({dcl_name}, dcl_modules)
					=  dcl_modules![mod_index]
1000
			  ({ste_kind}, cs_symbol_table)
1001
					= readPtr dcl_name.id_info cs_symbol_table
1002
1003
1004
1005
1006
			= case ste_kind of
				STE_Module {mod_imports}
					-> (mod_imports, dcl_modules, cs_symbol_table)
				STE_ClosedModule
					-> ([], dcl_modules, cs_symbol_table)
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
		get_mod_imports _ imports_of_icl_mod dcl_modules cs_symbol_table
		 	= (imports_of_icl_mod, dcl_modules, cs_symbol_table)
			
	get_expl_imp_symbols {import_module, import_symbols, import_file_position}
			(expl_imp_symbols_accu, nr_of_expl_imp_symbols, expl_imp_indices_accu, cs_symbol_table)
		# (expl_imp_symbols_accu, nr_of_expl_imp_symbols, expl_imp_indices, cs_symbol_table)
				= foldSt get_expl_imp_symbol import_symbols
						(expl_imp_symbols_accu, nr_of_expl_imp_symbols, [], cs_symbol_table)
		  ({ste_index}, cs_symbol_table)
		  		= readPtr import_module.id_info cs_symbol_table
		= (expl_imp_symbols_accu, nr_of_expl_imp_symbols, 
			[(ste_index, import_file_position, expl_imp_indices):expl_imp_indices_accu], cs_symbol_table)

1020
1021
1022
1023
	get_expl_imp_symbol imp_decl=:(ID_OldSyntax idents) state
		= foldSt (get_symbol imp_decl) idents state
	get_expl_imp_symbol imp_decl state
		= get_symbol imp_decl (get_ident imp_decl) state
1024

1025
	get_symbol imp_decl ident=:{id_info} (expl_imp_symbols_accu, nr_of_expl_imp_symbols, expl_imp_indices_accu, cs_symbol_table)
1026
1027
1028
1029
1030
		# (ste, cs_symbol_table)
				= readPtr id_info cs_symbol_table
		= case