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

import StdEnv

5
import syntax, check, type, typesupport, utilities, unitype, predef, checktypes, RWSDebug, convertDynamics
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92


::	InstanceTree = IT_Node !(Global Index) !InstanceTree !InstanceTree | IT_Empty 

::	ClassInstanceInfo :== {# {! .InstanceTree}}

::	ReducedContext = 
	{	rc_class			:: !Global DefinedSymbol
	,	rc_types			:: ![Type]
	,	rc_inst_module		:: !Index
	,	rc_inst_members		:: !{# DefinedSymbol}
	,	rc_red_contexts		:: ![ClassApplication]
	}

::	ReducedContexts = 
	{	rcs_class_context			:: !ReducedContext
	,	rcs_constraints_contexts	:: ![ReducedContexts]
	}

::	TypeCodeInstance =
	{	tci_index			:: !Index
	,	tci_contexts		:: ![ClassApplication]
	}


::	ClassApplication	= CA_Instance !ReducedContexts
						| CA_Context !TypeContext
						| CA_LocalTypeCode !VarInfoPtr			/* for (local) type pattern variables */
						| CA_GlobalTypeCode !TypeCodeInstance	/* for (global) type constructors */


::	ArrayInstance =
	{	ai_record		:: !TypeSymbIdent
	,	ai_members		:: !{# DefinedSymbol}
	}

::	GlobalTCInstance =
	{	gtci_type		:: !GlobalTCType
	,	gtci_index		:: !Index
	}

::	SpecialInstances =
	{	si_next_array_member_index			:: !Index
	,	si_array_instances					:: ![ArrayInstance]
	,	si_next_TC_member_index				:: !Index
	,	si_TC_instances						:: ![GlobalTCInstance]
	}
	
::	LocalTypePatternVariable =
	{	ltpv_var			:: !Int
	,	ltpv_new_var		:: !VarInfoPtr
	}

::	OverloadingState =
	{	os_type_heaps			:: !.TypeHeaps
	,	os_var_heap				:: !.VarHeap
	,	os_symbol_heap			:: !.ExpressionHeap
	,	os_predef_symbols		:: !.PredefinedSymbols
	,	os_special_instances	:: !.SpecialInstances
	,	os_error				:: !.ErrorAdmin				
	}

instance =< TypeSymbIdent
where	
	(=<) {type_index={glob_module=mod1,glob_object=index1}} {type_index={glob_module=mod2,glob_object=index2}}
		# cmp = mod1 =< mod2
		| cmp == Equal
			= index1 =< index2
			= cmp

instance =< GlobalTCType
where	
	(=<) globtype1 globtype2
		| equal_constructor globtype1 globtype2
			= compare_types  globtype1 globtype2
		| less_constructor globtype1 globtype2
			= Smaller
			= Greater
	where
		compare_types (GTT_Basic bt1) (GTT_Basic bt2)
			= bt1 =< bt2
		compare_types (GTT_Constructor cons1) (GTT_Constructor cons2) 
			= cons1 =< cons2
		compare_types _ _
			= Equal
		
		
93
94
instanceError symbol types err
	# err = errorHeading "Overloading error" err
95
	  format = { form_properties = cNoProperties, form_attr_position = No }
96
97
	= { err & ea_file = err.ea_file <<< " \"" <<< symbol <<< "\" no instance available of type "
									<:: (format, types, Yes initialTypeVarBeautifulizer) <<< '\n' }
98
99
100
101


uniqueError symbol types err
	# err = errorHeading "Overloading/Uniqueness error" err
102
	  format = { form_properties = cAnnotated, form_attr_position = No }
103
	= { err & ea_file = err.ea_file <<< " \"" <<< symbol
104
105
			<<< "\" uniqueness specification of instance conflicts with current application "
			<:: (format, types, Yes initialTypeVarBeautifulizer) <<< '\n'}
106
107
108

unboxError type err
	# err = errorHeading "Overloading error of Array class" err
109
	  format = { form_properties = cNoProperties, form_attr_position = No }
110
	= { err & ea_file = err.ea_file <<< ' ' <:: (format, type, Yes initialTypeVarBeautifulizer) <<< " instance cannot be unboxed\n"}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
111

Sjaak Smetsers's avatar
Sjaak Smetsers committed
112
113
114
overloadingError op_symb err
	# err = errorHeading "Overloading error" err
	= { err & ea_file = err.ea_file <<< " internal overloading of \"" <<< op_symb <<< "\" could not be solved\n" }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
115
116
117
118
119
120
121

/*
	As soon as all overloaded variables in an type context are instantiated, context reduction is carried out.
	This reduction yields a type class instance (here represented by a an index) and a list of
	ClassApplications.
*/

Sjaak Smetsers's avatar
Sjaak Smetsers committed
122
123
124
125
126
127
containsContext :: !TypeContext ![TypeContext] -> Bool
containsContext new_tc []
	= False
containsContext new_tc [tc : tcs]
	= new_tc == tc || containsContext new_tc tcs

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
128
129
130
131

FoundObject object :== object.glob_module <> NotFound
ObjectNotFound 	:== { glob_module = NotFound, glob_object = NotFound }

Sjaak Smetsers's avatar
Sjaak Smetsers committed
132
133
134
135
136
137
138
139
140
141
142
143
reduceContexts :: ![TypeContext] !{# CommonDefs} !ClassInstanceInfo ![TypeContext] !*SpecialInstances ![LocalTypePatternVariable]
	!(!*VarHeap, !*TypeHeaps) !*Coercions !*PredefinedSymbols !*ErrorAdmin
		-> *(![ClassApplication],  ![TypeContext], !*SpecialInstances, ![LocalTypePatternVariable],
				!(!*VarHeap, !*TypeHeaps), !*Coercions, !*PredefinedSymbols, !*ErrorAdmin)
reduceContexts [] defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error
	= ([], new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
reduceContexts [tc : tcs] defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error
	# (appl, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
			= try_to_reduce_context tc defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error
	  (appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
	  		= reduceContexts tcs defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error
	= ([appl : appls], new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
144
145

where		
Sjaak Smetsers's avatar
Sjaak Smetsers committed
146
147
148
149
150
	try_to_reduce_context :: !TypeContext !{# CommonDefs} !ClassInstanceInfo ![TypeContext] !*SpecialInstances ![LocalTypePatternVariable]
		!(!*VarHeap, !*TypeHeaps) !*Coercions !*PredefinedSymbols !*ErrorAdmin
			-> *(!ClassApplication, ![TypeContext], !*SpecialInstances, ![LocalTypePatternVariable], !(!*VarHeap, !*TypeHeaps), !*Coercions, !*PredefinedSymbols, !*ErrorAdmin)
	try_to_reduce_context tc=:{tc_class=class_symb=:{glob_object={ds_index},glob_module},tc_types} defs instance_info new_contexts
			special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error
151
		| context_is_reducible tc predef_symbols
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
152
			| is_predefined_symbol glob_module ds_index PD_TypeCodeClass predef_symbols
Sjaak Smetsers's avatar
Sjaak Smetsers committed
153
154
				# (red_context, (new_contexts, special_instances, type_pattern_vars, var_heap))
							= reduce_TC_context class_symb (hd tc_types) new_contexts special_instances type_pattern_vars var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
155
156
157
158
159
160
161
162
163
164
165
166
167
168
				= (red_context, new_contexts, special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error)
				# (class_appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
						= reduce_context tc defs instance_info new_contexts special_instances type_pattern_vars
								(var_heap, type_heaps) coercion_env predef_symbols error
				= (CA_Instance class_appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
			| containsContext tc new_contexts
				= (CA_Context tc, new_contexts, special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error)
				# (tc_var, var_heap) = newPtr VI_Empty var_heap
				= (CA_Context tc, [{ tc & tc_var = tc_var } : new_contexts], special_instances,
						type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error)


	reduce_context {tc_class=class_symb=:{glob_object={ds_index},glob_module},tc_types} defs
						instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
169
170
171
		# {class_members,class_context,class_args,class_name} = defs.[glob_module].com_class_defs.[ds_index]
		| size class_members > 0
			# class_instances = instance_info.[glob_module].[ds_index]
Sjaak Smetsers's avatar
Sjaak Smetsers committed
172
			# ({glob_module,glob_object}, contexts, uni_ok, (var_heap, type_heaps), coercion_env) = find_instance tc_types class_instances defs heaps coercion_env
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
173
174
175
176
			| (glob_module <> NotFound) && uni_ok
				# {ins_members, ins_class} = defs.[glob_module].com_instance_defs.[glob_object]
				| is_predefined_symbol ins_class.glob_module ins_class.glob_object.ds_index PD_ArrayClass predef_symbols &&
				  is_unboxed_array tc_types predef_symbols
Sjaak Smetsers's avatar
Sjaak Smetsers committed
177
178
					# (rcs_class_context, special_instances, (predef_symbols, type_heaps), error)
							= check_unboxed_type glob_module ins_class ins_members tc_types class_members defs special_instances (predef_symbols, type_heaps) error
Sjaak Smetsers's avatar
Sjaak Smetsers committed
179
180
181
182
183
184
185
					= ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, new_contexts,
									special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error)
					# (appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
							= reduceContexts contexts defs instance_info new_contexts special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error
					  (constraints, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
					  		= reduce_contexts_in_constraints tc_types class_args class_context defs instance_info new_contexts special_instances type_pattern_vars
					  				heaps coercion_env predef_symbols error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
186
					= ({ rcs_class_context = { rc_class = ins_class, rc_inst_module = glob_module, rc_inst_members = ins_members,
Sjaak Smetsers's avatar
Sjaak Smetsers committed
187
188
								rc_types = tc_types, rc_red_contexts = appls }, rcs_constraints_contexts = constraints }, new_contexts,
							special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
189
190
				# rcs_class_context = { rc_class = class_symb, rc_inst_module = NoIndex, rc_inst_members = {}, rc_types = tc_types, rc_red_contexts = [] }
				| glob_module <> NotFound
Sjaak Smetsers's avatar
Sjaak Smetsers committed
191
192
193
194
195
196
197
					= ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, new_contexts,
							special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, uniqueError class_name tc_types error)
					= ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, new_contexts,
							special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, instanceError class_name tc_types error)
			# (constraints, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
				= reduce_contexts_in_constraints tc_types class_args class_context defs instance_info new_contexts special_instances type_pattern_vars
								heaps coercion_env predef_symbols error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
198
			= ({ rcs_class_context = { rc_class = class_symb, rc_inst_module = NoIndex, rc_inst_members = {}, rc_types = tc_types, rc_red_contexts = [] },
Sjaak Smetsers's avatar
Sjaak Smetsers committed
199
				rcs_constraints_contexts = constraints },  new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
200

Sjaak Smetsers's avatar
Sjaak Smetsers committed
201
202
203
204
	reduce_contexts_in_constraints types class_args [] defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error
		= ([], new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
	reduce_contexts_in_constraints types class_args class_context defs instance_info new_contexts special_instances type_pattern_vars
			(var_heap, type_heaps=:{th_vars}) coercion_env predef_symbols error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
205
		# th_vars = fold2St (\ type {tv_info_ptr} -> writePtr tv_info_ptr (TVI_Type type)) types class_args th_vars
Sjaak Smetsers's avatar
Sjaak Smetsers committed
206
207
		  (instantiated_context, heaps) = fresh_contexts class_context (var_heap, { type_heaps & th_vars = th_vars })
		# (cappls, (new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
208
		  		= mapSt (reduce_context_in_constraint defs instance_info) instantiated_context
Sjaak Smetsers's avatar
Sjaak Smetsers committed
209
210
		  				(new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
		= (cappls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
211
212

	where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
213
214
215
216
217
218
219
		reduce_context_in_constraint defs instance_info tc (new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
		  	# (cappls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
				= reduce_context tc defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error
			= (cappls, (new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error))

	find_instance co_types (IT_Node this_inst_index=:{glob_object,glob_module} left right) defs heaps coercion_env
		# (left_index, types, uni_ok, (var_heap, type_heaps), coercion_env) = find_instance co_types left defs heaps coercion_env
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
220
		| FoundObject left_index
Sjaak Smetsers's avatar
Sjaak Smetsers committed
221
			= (left_index, types, uni_ok, (var_heap, type_heaps), coercion_env)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
222
223
224
			# {ins_type={it_types,it_context}, ins_specials} = defs.[glob_module].com_instance_defs.[glob_object]
			  (matched, type_heaps) = match defs it_types co_types type_heaps
			| matched
Sjaak Smetsers's avatar
Sjaak Smetsers committed
225
				# (subst_context, (var_heap, type_heaps)) = fresh_contexts it_context (var_heap, type_heaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
226
227
228
				  (uni_ok, coercion_env, type_heaps) = adjust_type_attributes defs co_types it_types coercion_env type_heaps
				  (spec_inst, type_heaps) = trySpecializedInstances subst_context (get_specials ins_specials) type_heaps
				| FoundObject spec_inst
Sjaak Smetsers's avatar
Sjaak Smetsers committed
229
230
231
232
233
					= (spec_inst, [], uni_ok, (var_heap, type_heaps), coercion_env)
					= (this_inst_index, subst_context, uni_ok, (var_heap, type_heaps), coercion_env)
				= find_instance co_types right defs (var_heap, type_heaps) coercion_env
	find_instance co_types IT_Empty defs heaps coercion_env
		= (ObjectNotFound, [], True, heaps, coercion_env)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
234
235
236
237
238
239
240
241
242
	
	get_specials (SP_ContextTypes specials) = specials
	get_specials SP_None 					= []

	adjust_type_attributes defs act_types form_types coercion_env type_heaps
		= fold2St (adjust_type_attribute defs) act_types form_types (True, coercion_env, type_heaps)

	adjust_type_attribute defs (TA type_cons1 cons_args1) (TA type_cons2 cons_args2) (ok, coercion_env, type_heaps)
		| type_cons1 == type_cons2
243
			# (ok, coercion_env) = fold2St (adjust_attribute type_cons1.type_name) cons_args1 cons_args2 (ok, coercion_env)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
244
245
246
247
248
249
250
			= (ok, coercion_env, type_heaps)
			# (_, type1, type_heaps) = tryToExpandTypeSyn defs type_cons1 cons_args1 type_heaps
			  (_, type2, type_heaps) = tryToExpandTypeSyn defs type_cons2 cons_args2 type_heaps
			= adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps)
	adjust_type_attribute _ _ _  state
		= state
	
251
	adjust_attribute _ {at_attribute} {at_attribute = TA_Var _} state
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
252
		= state
253
	adjust_attribute type_cons {at_attribute} {at_attribute = TA_Unique} (ok, coercion_env)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
254
255
256
257
258
259
260
261
		= case at_attribute of
			TA_Unique
				-> (ok, coercion_env)
			TA_TempVar av_number
				# (succ, coercion_env) = tryToMakeUnique av_number coercion_env
				-> (ok && succ, coercion_env)
			_
				-> (False, coercion_env)
262
	adjust_attribute type_cons {at_attribute} attr (ok, coercion_env)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
263
264
265
266
267
268
269
270
271
		= case at_attribute of
			TA_Multi
				-> (ok, coercion_env)
			TA_TempVar av_number
				# (succ, coercion_env) = tryToMakeNonUnique av_number coercion_env
				-> (ok && succ, coercion_env)
			_
				-> (False, coercion_env)
	
272
273
274
275
276
	context_is_reducible {tc_class,tc_types = [type : types]} predef_symbols
//		= type_is_reducible type && is_reducible types
		= type_is_reducible type && types_are_reducible types type tc_class predef_symbols

	type_is_reducible (TempV _)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
277
		= False
278
	type_is_reducible (_ :@: _)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
279
		= False
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
	type_is_reducible _
		= True

	types_are_reducible [] _ _ _
		= True
	types_are_reducible [type : types] first_type tc_class predef_symbols
		= case type of
			TempV _
				->	is_predefined_symbol tc_class.glob_module tc_class.glob_object.ds_index PD_ArrayClass predef_symbols &&
					is_lazy_or_strict_array_type first_type predef_symbols
			_ :@: _
				-> False
			_
				-> is_reducible types

	where				
		is_lazy_or_strict_array_type (TA {type_index} _) predef_symbols
			= is_predefined_symbol type_index.glob_module type_index.glob_object PD_LazyArrayType predef_symbols ||
			  is_predefined_symbol type_index.glob_module type_index.glob_object PD_StrictArrayType predef_symbols
		is_lazy_or_strict_array_type _ _
			= False

	is_reducible []
		= True
	is_reducible [ type : types]
		= type_is_reducible type && is_reducible types
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
306

Sjaak Smetsers's avatar
Sjaak Smetsers committed
307
308
309
310
311
312
313
314
315
	fresh_contexts contexts heaps
		= mapSt fresh_context contexts heaps
	where
		fresh_context tc=:{tc_types} (var_heap, type_heaps)
			# (tc_types, type_heaps) = substitute tc_types type_heaps
//			  (tc_var, var_heap) = newPtr VI_Empty var_heap
//			= ({ tc & tc_types = tc_types, tc_var = tc_var }, (var_heap, type_heaps))
			= ({ tc & tc_types = tc_types }, (var_heap, type_heaps))

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
316
317
318
319
320
321
322
323
324
	is_predefined_symbol mod_index symb_index predef_index predef_symbols
		# {pds_def,pds_module,pds_ident} = predef_symbols.[predef_index]
		= (mod_index == pds_module && symb_index == pds_def)
		
	is_unboxed_array [TA {type_index={glob_module,glob_object},type_arity} _ : _] predef_symbols
		= is_predefined_symbol glob_module glob_object PD_UnboxedArrayType predef_symbols
	is_unboxed_array _ predef_symbols
		= False

Sjaak Smetsers's avatar
Sjaak Smetsers committed
325
326
	check_unboxed_type ins_module ins_class ins_members types=:[ _, elem_type :_] class_members defs special_instances predef_symbols_type_heaps error
		# (unboxable, opt_record, predef_symbols_type_heaps) = try_to_unbox elem_type defs predef_symbols_type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
327
328
329
330
331
		| unboxable
			= case opt_record of
				Yes record
					# (ins_members, special_instances) = add_record_to_array_instances record class_members special_instances
					-> ({ rc_class = ins_class, rc_inst_module = cIclModIndex, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
Sjaak Smetsers's avatar
Sjaak Smetsers committed
332
							special_instances, predef_symbols_type_heaps, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
333
334
				No
					-> ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
Sjaak Smetsers's avatar
Sjaak Smetsers committed
335
							special_instances, predef_symbols_type_heaps, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
336
			= ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
Sjaak Smetsers's avatar
Sjaak Smetsers committed
337
					special_instances, predef_symbols_type_heaps, unboxError elem_type error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
338
	where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
339
340
341
		try_to_unbox (TB _) _ predef_symbols_type_heaps
			= (True, No, predef_symbols_type_heaps)
		try_to_unbox (TA type_symb=:{type_index={glob_module,glob_object},type_arity} type_args) defs (predef_symbols, type_heaps)
342
			# {td_arity,td_rhs,td_args,td_attribute} = defs.[glob_module].com_type_defs.[glob_object]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
343
344
			= case td_rhs of
				RecordType _
Sjaak Smetsers's avatar
Sjaak Smetsers committed
345
					-> (True, (Yes type_symb), (predef_symbols, type_heaps))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
346
347
348
349
350
				AbstractType _
					#! unboxable =
						   is_predefined_symbol glob_module glob_object PD_LazyArrayType predef_symbols ||
						   is_predefined_symbol glob_module glob_object PD_StrictArrayType predef_symbols ||
						   is_predefined_symbol glob_module glob_object PD_UnboxedArrayType predef_symbols
Sjaak Smetsers's avatar
Sjaak Smetsers committed
351
352
					-> (unboxable, No, (predef_symbols, type_heaps))
				SynType {at_type}
353
					# (expanded_type, type_heaps) = expandTypeSyn td_attribute td_args type_args at_type type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
354
					-> try_to_unbox expanded_type defs (predef_symbols, type_heaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
355
				_
Sjaak Smetsers's avatar
Sjaak Smetsers committed
356
357
358
					-> (False, No, (predef_symbols, type_heaps))				
		try_to_unbox type _ predef_symbols_type_heaps
			= (True, No, predef_symbols_type_heaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
359
360
361

		add_record_to_array_instances :: !TypeSymbIdent !{# DefinedSymbol} !*SpecialInstances -> (!{#DefinedSymbol},!*SpecialInstances)
		add_record_to_array_instances record members special_instances=:{si_next_array_member_index,si_array_instances}
Sjaak Smetsers's avatar
Sjaak Smetsers committed
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
			# may_be_there = look_up_array_instance record si_array_instances
			= case may_be_there of
				Yes inst
					-> (inst.ai_members, special_instances)
				No
					# inst = new_array_instance record members si_next_array_member_index
					-> (inst.ai_members, { special_instances &  si_next_array_member_index = si_next_array_member_index + size members,
																si_array_instances = [ inst : si_array_instances ] })
		where
			look_up_array_instance :: !TypeSymbIdent ![ArrayInstance] -> Optional ArrayInstance
			look_up_array_instance record []
				= No
			look_up_array_instance record [inst : insts]
				| record == inst.ai_record
					= Yes inst
					= look_up_array_instance record insts
			
			new_array_instance :: !TypeSymbIdent !{# DefinedSymbol} !Index -> ArrayInstance
			new_array_instance record members next_member_index
				= {	ai_members = { { class_member & ds_index = next_inst_index } \\ class_member <-: members & next_inst_index <- [next_member_index .. ]},
					ai_record = record }
				
				
Sjaak Smetsers's avatar
Sjaak Smetsers committed
385
386
	reduce_TC_context type_code_class tc_type new_contexts special_instances type_pattern_vars var_heap
		= reduce_tc_context type_code_class tc_type (new_contexts, special_instances, type_pattern_vars, var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
387
	where							
Sjaak Smetsers's avatar
Sjaak Smetsers committed
388
		reduce_tc_context type_code_class (TA cons_id cons_args) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
389
390
391
			# (inst_index, (si_next_TC_member_index, si_TC_instances))
			  		= addGlobalTCInstance (GTT_Constructor cons_id) (si_next_TC_member_index, si_TC_instances)
			  (rc_red_contexts, instances) = reduce_TC_contexts type_code_class cons_args
Sjaak Smetsers's avatar
Sjaak Smetsers committed
392
			  		 (new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
393
394
			= (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = rc_red_contexts }, instances)

Sjaak Smetsers's avatar
Sjaak Smetsers committed
395
		reduce_tc_context type_code_class (TB basic_type) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
396
397
398
			# (inst_index, (si_next_TC_member_index, si_TC_instances))
			  		= addGlobalTCInstance (GTT_Basic basic_type) (si_next_TC_member_index, si_TC_instances)
			= (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = [] },
Sjaak Smetsers's avatar
Sjaak Smetsers committed
399
					(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
400

Sjaak Smetsers's avatar
Sjaak Smetsers committed
401
		reduce_tc_context type_code_class (arg_type --> result_type) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
402
403
404
			# (inst_index, (si_next_TC_member_index, si_TC_instances))
			  		= addGlobalTCInstance GTT_Function (si_next_TC_member_index, si_TC_instances)
			  (rc_red_contexts, instances) = reduce_TC_contexts type_code_class [arg_type, result_type]
Sjaak Smetsers's avatar
Sjaak Smetsers committed
405
			  		 (new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
406
407
408
			= (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = rc_red_contexts }, instances)


Sjaak Smetsers's avatar
Sjaak Smetsers committed
409
		reduce_tc_context type_code_class (TempQV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
410
			# (inst_var, (type_pattern_vars, var_heap)) = addLocalTCInstance var_number (type_pattern_vars, var_heap)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
411
			= (CA_LocalTypeCode inst_var, (new_contexts, special_instances, type_pattern_vars, var_heap))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
412

Sjaak Smetsers's avatar
Sjaak Smetsers committed
413
414
415
416
417
418
		reduce_tc_context type_code_class (TempV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap)
			# (tc_var, var_heap) = newPtr VI_Empty var_heap
			  tc = { tc_class = type_code_class, tc_types = [TempV var_number], tc_var = tc_var }
			| containsContext tc new_contexts
				= (CA_Context tc, (new_contexts, special_instances, type_pattern_vars, var_heap))
				= (CA_Context tc, ([tc : new_contexts], special_instances, type_pattern_vars, var_heap))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
419
420
421
422

		reduce_TC_contexts type_code_class cons_args instances
			= mapSt (\{at_type} -> reduce_tc_context type_code_class at_type) cons_args instances
		
Sjaak Smetsers's avatar
Sjaak Smetsers committed
423
addLocalTCInstance var_number (instances=:[inst : insts], ltp_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
424
425
	# cmp = var_number =< inst.ltpv_var
	| cmp == Equal
Sjaak Smetsers's avatar
Sjaak Smetsers committed
426
		= (inst.ltpv_new_var, (instances, ltp_var_heap))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
427
428
	| cmp == Smaller
		# (ltpv_new_var, ltp_var_heap) = newPtr VI_Empty ltp_var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
429
430
431
432
		= (ltpv_new_var, ( [{ ltpv_new_var = ltpv_new_var, ltpv_var = var_number } : instances ], ltp_var_heap ))
		# (found_var, (insts, ltp_var_heap)) = addLocalTCInstance var_number (insts, ltp_var_heap)
		= (found_var, ([inst : insts ], ltp_var_heap))
addLocalTCInstance var_number ([], ltp_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
433
	# (ltpv_new_var, ltp_var_heap) = newPtr VI_Empty ltp_var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
434
	= (ltpv_new_var, ([{ ltpv_new_var = ltpv_new_var, ltpv_var = var_number }], ltp_var_heap))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
435
436
437
438
439
440
441
442
443
444
445
446
447

addGlobalTCInstance type_of_TC (next_member_index, instances=:[inst : insts])
	# cmp = type_of_TC =< inst.gtci_type
	| cmp == Equal
		= (inst.gtci_index, (next_member_index, instances))
	| cmp == Smaller
		= (next_member_index, (inc next_member_index, [{ gtci_index = next_member_index, gtci_type = type_of_TC } : instances ]))
		# (found_inst, (next_member_index, insts)) = addGlobalTCInstance type_of_TC (next_member_index, insts)
		= (found_inst, (next_member_index, [inst : insts]))
addGlobalTCInstance type_of_TC (next_member_index, [])
	= (next_member_index, (inc next_member_index, [{ gtci_index = next_member_index, gtci_type = type_of_TC }]))

tryToExpandTypeSyn defs cons_id=:{type_name,type_index={glob_object,glob_module}} type_args type_heaps
448
	# {td_name,td_rhs,td_args,td_attribute} = defs.[glob_module].com_type_defs.[glob_object]
Sjaak Smetsers's avatar
Sjaak Smetsers committed
449
450
	= case td_rhs of
		SynType {at_type}
451
			# (expanded_type, type_heaps) = expandTypeSyn td_attribute td_args type_args at_type type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
452
453
454
			-> (True, expanded_type, type_heaps) 
		_
			-> (False, TA cons_id type_args, type_heaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
455

456
457
expandTypeSyn td_attribute td_args type_args td_rhs type_heaps
	# type_heaps = bindTypeVarsAndAttributes td_attribute TA_Multi td_args type_args type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
458
	  (expanded_type, type_heaps) = substitute td_rhs type_heaps
459
460
	= (expanded_type, clearBindingsOfTypeVarsAndAttributes td_attribute td_args type_heaps)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
class match type ::  !{# CommonDefs} !type !type !*TypeHeaps -> (!Bool, !*TypeHeaps)

instance match AType
where
	match defs atype1 atype2 type_heaps = match defs atype1.at_type atype2.at_type type_heaps

instance match Type
where 
	match defs (TV {tv_info_ptr}) type type_heaps=:{th_vars}
		= (True, { type_heaps & th_vars = th_vars <:= (tv_info_ptr,TVI_Type type)})
	match defs (TA cons_id1 cons_args1) (TA cons_id2 cons_args2) type_heaps
		| cons_id1 == cons_id2
			= match defs cons_args1 cons_args2 type_heaps
//			# (succ1, type1, type_heaps) = tryToExpandTypeSyn defs cons_id1 cons_args1 type_heaps
			# (succ2, type2, type_heaps) = tryToExpandTypeSyn defs cons_id2 cons_args2 type_heaps
			| succ2
				= case type2 of
					TA cons_id2 cons_args2
						| cons_id1 == cons_id2
							-> match defs cons_args1 cons_args2 type_heaps
							-> (False, type_heaps)
					_
							-> (False, type_heaps)
				= (False, type_heaps)
	match defs (arg_type1 --> res_type1) (arg_type2 --> res_type2) type_heaps
		= match defs (arg_type1,res_type1) (arg_type2,res_type2) type_heaps
	match defs (type1 :@: types1) (type2 :@: types2) type_heaps
		= match defs (type1,types1) (type2,types2) type_heaps
	match defs (CV tv :@: types) (TA type_cons cons_args) type_heaps
		# diff = type_cons.type_arity - length types
		| diff >= 0
			= match defs (TV tv, types) (TA { type_cons & type_arity = diff } (take diff cons_args), drop diff cons_args) type_heaps
			= (False, type_heaps)
	match defs (TB tb1) (TB tb2) type_heaps
		= (tb1 == tb2, type_heaps)
/*	match defs type (TB (BT_String array_type)) type_heaps
		= match defs type array_type type_heaps
*/	match defs (TA cons_id cons_args) type2 type_heaps
		# (succ, type1, type_heaps) = tryToExpandTypeSyn defs cons_id cons_args type_heaps
		| succ
			= match defs type1 type2 type_heaps
			= (False, type_heaps)
	match defs type1 (TA cons_id cons_args) type_heaps
		# (succ, type2, type_heaps) = tryToExpandTypeSyn defs cons_id cons_args type_heaps
		| succ
			= match defs type1 type2 type_heaps
			= (False, type_heaps)
	match defs type1 type2 type_heaps
		= (False, type_heaps)

instance match (!a,!b) | match a & match b
where
	match defs (x1,y1) (x2,y2) type_heaps
		# (matched, type_heaps) = match defs x1 x2 type_heaps
		| matched
			= match defs y1 y2 type_heaps
			= (False, type_heaps)
			
instance match [a] | match a
where
	match defs [t1 : ts1] [t2 : ts2] type_heaps
		= match defs (t1,ts1) (t2,ts2) type_heaps
	match defs [] [] type_heaps
		= (True, type_heaps)

instance match ConsVariable
where
	match defs (CV {tv_info_ptr}) cons_var type_heaps=:{th_vars}
		= (True, { type_heaps & th_vars = th_vars <:= (tv_info_ptr,TVI_Type (consVariableToType cons_var))})

consVariableToType (TempCV temp_var_id)
	= TempV temp_var_id
consVariableToType (TempQCV temp_var_id)
	= TempQV temp_var_id

trySpecializedInstances type_contexts [] type_heaps
	= (ObjectNotFound, type_heaps)
trySpecializedInstances type_contexts specials type_heaps=:{th_vars}
	# (spec_index, th_vars) = try_specialized_instances (map (\{tc_types} -> tc_types) type_contexts) specials th_vars
	= (spec_index, { type_heaps & th_vars = th_vars })
where

	try_specialized_instances type_contexts_types [{spec_index,spec_vars,spec_types} : specials] type_var_heap
		# type_var_heap = foldSt (\tv -> writePtr tv.tv_info_ptr TVI_Empty) spec_vars type_var_heap
		  (equ, type_var_heap) = equalTypes spec_types type_contexts_types type_var_heap
		| equ
			= (spec_index, type_var_heap)
			= try_specialized_instances type_contexts_types specials type_var_heap
	try_specialized_instances type_contexts_types [] type_var_heap
		= (ObjectNotFound, type_var_heap)

Sjaak Smetsers's avatar
Sjaak Smetsers committed
552
553
::	DictionaryTypes :== [(Index, [ExprInfoPtr])]

554
tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState
Sjaak Smetsers's avatar
Sjaak Smetsers committed
555
	-> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], DictionaryTypes, !*OverloadingState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
556
tryToSolveOverloading ocs defs instance_info coercion_env os
557
558
559
560
	# (reduced_contexts, contexts, coercion_env, type_pattern_vars, os) = foldSt (reduce_contexts defs instance_info) ocs ([], [], coercion_env, [], os)
	| os.os_error.ea_ok
		# (contexts, os_var_heap) = foldSt add_spec_contexts ocs (contexts, os.os_var_heap)
		  (contexts, os_type_heaps) = remove_sub_classes contexts os.os_type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
561
562
563
564
		  ({ hp_var_heap, hp_expression_heap, hp_type_heaps}, dict_types) = foldSt (convert_dictionaries defs contexts) reduced_contexts
		  					({ hp_var_heap = os_var_heap, hp_expression_heap = os.os_symbol_heap, hp_type_heaps = os_type_heaps}, [])
		= (contexts, coercion_env, type_pattern_vars, dict_types, { os & os_type_heaps = hp_type_heaps, os_symbol_heap = hp_expression_heap, os_var_heap = hp_var_heap} )
		= ([], coercion_env, type_pattern_vars, [], os)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
565
where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
566
	reduce_contexts defs instance_info (opt_spec_contexts, expr_ptrs, pos, index) rc_state
Sjaak Smetsers's avatar
Sjaak Smetsers committed
567
		= foldSt (reduce_contexts_of_application index defs instance_info) expr_ptrs rc_state
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
568

Sjaak Smetsers's avatar
Sjaak Smetsers committed
569
570
571
572
573
574
575
576
577
578
579
	add_spec_contexts (Yes spec_context, expr_ptrs, pos, index) contexts_and_var_heap
		= foldSt add_spec_context spec_context contexts_and_var_heap
	where
		add_spec_context tc (contexts, var_heap)
			| containsContext tc contexts
				= (contexts, var_heap)
			  	# (tc_var, var_heap) = newPtr VI_Empty var_heap
				= ([{ tc & tc_var = tc_var } : contexts], var_heap)
	add_spec_contexts (No, expr_ptrs, pos, index) contexts_and_var_heap
		= contexts_and_var_heap

Sjaak Smetsers's avatar
Sjaak Smetsers committed
580
581
582
583
	reduce_contexts_of_application :: !Index !{# CommonDefs } !ClassInstanceInfo  !ExprInfoPtr
				([(SymbIdent, Index, ExprInfoPtr,[ClassApplication])], ![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
					 -> ([(SymbIdent, Index, ExprInfoPtr,[ClassApplication])], ![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
	reduce_contexts_of_application fun_index defs instance_info over_info_ptr (reduced_calls, new_contexts, coercion_env, type_pattern_vars,
Sjaak Smetsers's avatar
Sjaak Smetsers committed
584
585
			os=:{os_symbol_heap,os_type_heaps,os_var_heap,os_special_instances,os_error,os_predef_symbols})
		# (EI_Overloaded {oc_symbol, oc_context, oc_specials}, os_symbol_heap) = readPtr over_info_ptr os_symbol_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
586
587
588
589
		  (glob_fun, os_type_heaps) = trySpecializedInstances oc_context oc_specials os_type_heaps
		| FoundObject glob_fun
			# os_symbol_heap = os_symbol_heap <:= (over_info_ptr, EI_Instance {glob_module = glob_fun.glob_module, glob_object =
									{ ds_ident =  oc_symbol.symb_name, ds_arity = 0, ds_index = glob_fun.glob_object }} [])
Sjaak Smetsers's avatar
Sjaak Smetsers committed
590
591
592
593
594
595
			= (reduced_calls, new_contexts, coercion_env, type_pattern_vars, { os & os_type_heaps = os_type_heaps, os_symbol_heap = os_symbol_heap })
		| otherwise
			# (class_applications, new_contexts, os_special_instances, type_pattern_vars,
								(os_var_heap, os_type_heaps), coercion_env, os_predef_symbols, os_error)
					= reduceContexts oc_context defs instance_info new_contexts os_special_instances type_pattern_vars
							(os_var_heap, os_type_heaps) coercion_env os_predef_symbols os_error
Sjaak Smetsers's avatar
Sjaak Smetsers committed
596
			= ([ (oc_symbol, fun_index, over_info_ptr, class_applications) : reduced_calls ], new_contexts, coercion_env, type_pattern_vars, 
Sjaak Smetsers's avatar
Sjaak Smetsers committed
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
					{ os & os_type_heaps = os_type_heaps, os_symbol_heap = os_symbol_heap, os_var_heap = os_var_heap,
						   os_special_instances = os_special_instances, os_error = os_error, os_predef_symbols = os_predef_symbols })

	remove_sub_classes contexts type_heaps
		# (sub_classes, type_heaps) = foldSt generate_subclasses contexts ([], type_heaps)
		= (foldSt (remove_doubles sub_classes) contexts [], type_heaps)
		
	generate_subclasses {tc_class={glob_object={ds_index},glob_module},tc_types} (sub_classes, type_heaps)
		# {class_args,class_members,class_context,class_dictionary} = defs.[glob_module].com_class_defs.[ds_index]
		  th_vars = fold2St set_type class_args tc_types type_heaps.th_vars
		= foldSt subst_context class_context (sub_classes, { type_heaps & th_vars = th_vars })
	where
		set_type {tv_info_ptr} type type_var_heap
			= type_var_heap <:= (tv_info_ptr, TVI_Type type)
		  
		subst_context class_context (sub_classes, type_heaps)
			# (sub_class, type_heaps) = substitute class_context type_heaps
			= ([sub_class : sub_classes], type_heaps) 
		 
	remove_doubles sub_classes tc context
		| containsContext tc sub_classes
			= context
			= [tc : context]

Sjaak Smetsers's avatar
Sjaak Smetsers committed
621
622
623
624
625
626
627
628
629
630
631
632
633
	convert_dictionaries :: !{# CommonDefs } ![TypeContext] !(!SymbIdent,!Index,!ExprInfoPtr,![ClassApplication]) !(!*Heaps,!DictionaryTypes) -> (!*Heaps,!DictionaryTypes)
	convert_dictionaries defs contexts (oc_symbol, index, over_info_ptr, class_applications) (heaps, dict_types)
		# (heaps, ptrs) = convertOverloadedCall defs contexts oc_symbol over_info_ptr class_applications (heaps, [])
		| isEmpty ptrs
			= (heaps, dict_types)
			= (heaps, add_to_dict_types index ptrs dict_types)
	
	add_to_dict_types index ptrs []
		= [(index, ptrs)]
	add_to_dict_types new_index new_ptrs dt=:[(index, ptrs) : dict_types]
		| new_index == index
			= [(index, new_ptrs ++ ptrs) : dict_types]
			= [(new_index, new_ptrs) : dt]
Sjaak Smetsers's avatar
Sjaak Smetsers committed
634
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
635
636
637
638
639
selectFromDictionary  dict_mod dict_index member_index defs
	# (RecordType {rt_fields}) = defs.[dict_mod].com_type_defs.[dict_index].td_rhs
	  { fs_name, fs_index } = rt_fields.[member_index]
	= { glob_module = dict_mod, glob_object = { ds_ident = fs_name, ds_index = fs_index, ds_arity = 1 }}

640
getDictionaryTypeAndConstructor {glob_module, glob_object = {ds_ident,ds_index}} defs	  
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
641
642
	# {class_dictionary} = defs.[glob_module].com_class_defs.[ds_index]
	  (RecordType {rt_constructor}) = defs.[glob_module].com_type_defs.[class_dictionary.ds_index].td_rhs
643
	= (class_dictionary, rt_constructor)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
644

Sjaak Smetsers's avatar
Sjaak Smetsers committed
645
646
convertOverloadedCall :: !{#CommonDefs} ![TypeContext] !SymbIdent !ExprInfoPtr ![ClassApplication] !(!*Heaps, ![ExprInfoPtr]) -> (!*Heaps, ![ExprInfoPtr])
convertOverloadedCall defs contexts {symb_name,symb_kind = SK_OverloadedFunction {glob_module,glob_object}, symb_arity} expr_ptr [class_appl:class_appls] heaps_and_ptrs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
647
	# mem_def = defs.[glob_module].com_member_defs.[glob_object]
Sjaak Smetsers's avatar
Sjaak Smetsers committed
648
649
650
	  (class_exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts class_appls heaps_and_ptrs
	  (inst_expr, (heaps, ptrs)) = adjust_member_application defs contexts  mem_def symb_arity class_appl class_exprs heaps_and_ptrs
	= ({ heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_ptr, inst_expr)}, ptrs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
651
where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
652
	adjust_member_application defs contexts {me_symb,me_offset,me_class} symb_arity (CA_Instance red_contexts) class_exprs heaps_and_ptrs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
653
		# ({glob_module,glob_object}, red_contexts) = find_instance_of_member me_class me_offset red_contexts
Sjaak Smetsers's avatar
Sjaak Smetsers committed
654
		  (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts red_contexts heaps_and_ptrs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
655
		  class_exprs = exprs ++ class_exprs
Sjaak Smetsers's avatar
Sjaak Smetsers committed
656
		= (EI_Instance { glob_module = glob_module, glob_object = { ds_ident = me_symb, ds_arity = length class_exprs, ds_index = glob_object }} class_exprs,
Sjaak Smetsers's avatar
Sjaak Smetsers committed
657
658
			 heaps_and_ptrs)
	adjust_member_application  defs contexts  {me_symb,me_offset,me_class={glob_module,glob_object}} symb_arity (CA_Context tc) class_exprs (heaps=:{hp_type_heaps}, ptrs)
659
		# (class_context, address, hp_type_heaps) = determineContextAddress contexts defs tc hp_type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
660
661
		  {class_dictionary={ds_index}} = defs.[glob_module].com_class_defs.[glob_object]
		  selector = selectFromDictionary glob_module ds_index me_offset defs
662
		= (EI_Selection (generateClassSelection address [RecordSelection selector me_offset]) class_context.tc_var class_exprs,
Sjaak Smetsers's avatar
Sjaak Smetsers committed
663
664
665
666
667
668
				({ heaps & hp_type_heaps = hp_type_heaps }, ptrs))
	adjust_member_application defs contexts  _ _ (CA_GlobalTypeCode {tci_index,tci_contexts}) _ heaps_and_ptrs
		# (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs
		= (EI_TypeCode (TCE_Constructor tci_index (map expressionToTypeCodeExpression exprs)), heaps_and_ptrs)
	adjust_member_application defs contexts _ _ (CA_LocalTypeCode new_var_ptr) _  heaps_and_ptrs
		= (EI_TypeCode (TCE_Var new_var_ptr), heaps_and_ptrs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
669
670
671
672
673
674
675
676
677
678
	
	find_instance_of_member me_class me_offset { rcs_class_context = {rc_class, rc_inst_module, rc_inst_members, rc_red_contexts}, rcs_constraints_contexts}
		| rc_class.glob_module == me_class.glob_module && rc_class.glob_object.ds_index == me_class.glob_object
			= ({ glob_module = rc_inst_module, glob_object = rc_inst_members.[me_offset].ds_index }, rc_red_contexts)
			= find_instance_of_member_in_constraints me_class me_offset rcs_constraints_contexts
	where
		find_instance_of_member_in_constraints me_class me_offset [ rcs=:{rcs_constraints_contexts} : rcss ]
			= find_instance_of_member me_class me_offset {rcs & rcs_constraints_contexts = rcs_constraints_contexts ++ rcss}
		find_instance_of_member_in_constraints me_class me_offset []
			= abort "Error in module overloading: find_instance_of_member_in_constraints\n"
Sjaak Smetsers's avatar
Sjaak Smetsers committed
679
680
681
682
683
684
convertOverloadedCall defs contexts {symb_name,symb_kind = SK_TypeCode} expr_info_ptr class_appls heaps_and_ptrs
	# (class_expressions, (heaps, ptrs)) = convertClassApplsToExpressions defs contexts class_appls heaps_and_ptrs
	= ({ heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_TypeCodes (map expressionToTypeCodeExpression class_expressions))}, ptrs)
convertOverloadedCall defs contexts {symb_name} expr_info_ptr appls heaps_and_ptrs
	# (class_expressions, (heaps, ptrs)) = convertClassApplsToExpressions defs contexts appls heaps_and_ptrs
	= ({ heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_Context class_expressions)}, ptrs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
685
686
687


expressionToTypeCodeExpression (TypeCodeExpression texpr) 			= texpr
688
expressionToTypeCodeExpression (ClassVariable var_info_ptr)			= TCE_TypeTerm var_info_ptr // MV was TCE_Var var_info_ptr
Sjaak Smetsers's avatar
Sjaak Smetsers committed
689
/*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
690
expressionToTypeCodeExpression (Var {var_info_ptr})					= TCE_Var var_info_ptr
Sjaak Smetsers's avatar
Sjaak Smetsers committed
691
692
*/
expressionToTypeCodeExpression expr									= abort ("expressionToTypeCodeExpression (overloading.icl)" <<- expr)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
693
694
695

generateClassSelection address last_selectors
	= mapAppend (\(off_set,selector) -> RecordSelection selector off_set) address last_selectors
696
697
698
699


AttributedType type :== { at_attribute = TA_Multi, at_annotation = AN_None, at_type = type }

700
701
702
703
704
705
instance toString ClassApplication
where 
	toString (CA_Instance _)		= abort "CA_Instance"
	toString (CA_Context _)			= abort "CA_Context"
	toString (CA_LocalTypeCode _)	= abort "CA_LocalTypeCode"
	toString (CA_GlobalTypeCode _) 	= abort "CA_GlobalTypeCode"
706

Sjaak Smetsers's avatar
Sjaak Smetsers committed
707
708
convertClassApplsToExpressions defs contexts cl_appls heaps_and_ptrs
	= mapSt (convert_class_appl_to_expression defs contexts) cl_appls heaps_and_ptrs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
709
where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
710
711
712
	convert_class_appl_to_expression defs contexts (CA_Instance rcs) heaps_and_ptrs
		= convert_reduced_contexts_to_expression defs contexts rcs heaps_and_ptrs
	convert_class_appl_to_expression defs contexts (CA_Context tc) (heaps=:{hp_type_heaps}, ptrs)
713
		# (class_context, context_address, hp_type_heaps) = determineContextAddress contexts defs tc hp_type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
714
		| isEmpty context_address
Sjaak Smetsers's avatar
Sjaak Smetsers committed
715
716
717
718
719
720
721
722
723
724
725
			= (ClassVariable class_context.tc_var, ({ heaps & hp_type_heaps = hp_type_heaps }, ptrs))
			= (Selection No (ClassVariable class_context.tc_var) (generateClassSelection context_address []), ({ heaps & hp_type_heaps = hp_type_heaps }, ptrs))
	convert_class_appl_to_expression defs contexts (CA_LocalTypeCode new_var_ptr) heaps_and_ptrs
		= (TypeCodeExpression (TCE_Var new_var_ptr), heaps_and_ptrs)
	convert_class_appl_to_expression defs contexts (CA_GlobalTypeCode {tci_index,tci_contexts}) heaps_and_ptrs
		# (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs
		= (TypeCodeExpression (TCE_Constructor tci_index (map expressionToTypeCodeExpression exprs)), heaps_and_ptrs)

	convert_reduced_contexts_to_expression defs contexts {rcs_class_context,rcs_constraints_contexts} heaps_and_ptrs
		# (rcs_exprs, heaps_and_ptrs) = mapSt (convert_reduced_contexts_to_expression defs contexts) rcs_constraints_contexts heaps_and_ptrs
		= convert_reduced_context_to_expression defs contexts rcs_class_context rcs_exprs heaps_and_ptrs
726
	where	
Sjaak Smetsers's avatar
Sjaak Smetsers committed
727
728
		convert_reduced_context_to_expression defs contexts {rc_class, rc_inst_module, rc_inst_members, rc_red_contexts, rc_types} dictionary_args heaps_and_ptrs
			# (expressions, (heaps, class_ptrs)) = convertClassApplsToExpressions defs contexts rc_red_contexts heaps_and_ptrs
729
			  context_size = length expressions
730
			| size rc_inst_members > 1 && context_size > 0
731
732
733
				# (let_binds, let_types, rev_dicts, hp_var_heap, hp_expression_heap)
						= foldSt (bind_shared_dictionary (size rc_inst_members)) expressions ([], [], [], heaps.hp_var_heap, heaps.hp_expression_heap)
				  dictionary_args = build_class_members (size rc_inst_members) rc_inst_members rc_inst_module (reverse rev_dicts) context_size dictionary_args
Sjaak Smetsers's avatar
Sjaak Smetsers committed
734
				  (dict_expr, hp_expression_heap, class_ptrs) = build_dictionary rc_class rc_types dictionary_args defs hp_expression_heap class_ptrs
735
				| isEmpty let_binds
Sjaak Smetsers's avatar
Sjaak Smetsers committed
736
					= (dict_expr, ({ heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap }, class_ptrs))
737
738
					# (let_info_ptr, hp_expression_heap) = newPtr (EI_LetType let_types) hp_expression_heap
					= (Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = dict_expr, let_info_ptr = let_info_ptr },
Sjaak Smetsers's avatar
Sjaak Smetsers committed
739
						({ heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap }, [let_info_ptr : class_ptrs]))
740
				# dictionary_args = build_class_members (size rc_inst_members) rc_inst_members rc_inst_module expressions context_size dictionary_args
Sjaak Smetsers's avatar
Sjaak Smetsers committed
741
742
				  (dict_expr, hp_expression_heap, class_ptrs) = build_dictionary rc_class rc_types dictionary_args defs heaps.hp_expression_heap class_ptrs
				= (dict_expr, ({ heaps & hp_expression_heap = hp_expression_heap }, class_ptrs))
743
744
745
746
747
748
749
750
751
752
753
754
755
756

		build_class_members mem_offset ins_members mod_index class_arguments arity dictionary_args
			| mem_offset == 0
				= dictionary_args
				# mem_offset = dec mem_offset
				  {ds_ident,ds_index} = ins_members.[mem_offset]
				  mem_expr =  App { app_symb = {
				  							symb_name = ds_ident,
				  							symb_kind = SK_Function { glob_object = ds_index, glob_module = mod_index },
											symb_arity = arity },
									app_args = class_arguments,
									app_info_ptr = nilPtr }
				= build_class_members mem_offset ins_members mod_index class_arguments arity [ mem_expr : dictionary_args ]
		
Sjaak Smetsers's avatar
Sjaak Smetsers committed
757
		build_dictionary class_symbol instance_types dictionary_args defs expr_heap ptrs
758
759
760
761
762
763
764
765
			# (dict_type, dict_cons) = getDictionaryTypeAndConstructor class_symbol defs
			  record_symbol = { symb_name = dict_cons.ds_ident,		  
			  					symb_kind = SK_Constructor {glob_module = class_symbol.glob_module, glob_object = dict_cons.ds_index},
			  					symb_arity = dict_cons.ds_arity }
			  dict_type_symbol = MakeTypeSymbIdent {glob_module = class_symbol.glob_module, glob_object = dict_type.ds_index} dict_type.ds_ident dict_type.ds_arity
			  class_type = TA dict_type_symbol [ AttributedType type \\ type <- instance_types ]
			  (app_info_ptr, expr_heap) = newPtr (EI_DictionaryType class_type) expr_heap
			  rc_record = App { app_symb = record_symbol, app_args = dictionary_args, app_info_ptr = app_info_ptr }
Sjaak Smetsers's avatar
Sjaak Smetsers committed
766
			= (rc_record, expr_heap, [app_info_ptr : ptrs])
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781

		bind_shared_dictionary nr_of_members dict=:(Let {let_expr=App {app_symb={symb_name}, app_info_ptr}}) (binds, types, rev_dicts, var_heap, expr_heap)
			# (EI_DictionaryType class_type, expr_heap) = readPtr app_info_ptr expr_heap
		  	  (var_info_ptr, var_heap) = newPtr VI_Empty var_heap
		  	  fv = { fv_name = symb_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = nr_of_members }
		  	  var = { var_name = symb_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr }
			= ([{bind_src = dict, bind_dst = fv} : binds ], [ AttributedType class_type : types ], [Var var : rev_dicts], var_heap, expr_heap)
		bind_shared_dictionary nr_of_members dict=:(App {app_symb={symb_name}, app_info_ptr}) (binds, types, rev_dicts, var_heap, expr_heap)
			# (EI_DictionaryType class_type, expr_heap) = readPtr app_info_ptr expr_heap
		  	  (var_info_ptr, var_heap) = newPtr VI_Empty var_heap
		  	  fv = { fv_name = symb_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = nr_of_members }
		  	  var = { var_name = symb_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr }
			= ([{bind_src = dict, bind_dst = fv} : binds ], [ AttributedType class_type : types ], [Var var : rev_dicts], var_heap, expr_heap)
		bind_shared_dictionary nr_of_members dict (binds, types, rev_dicts, var_heap, expr_heap)
			= (binds, types, [dict : rev_dicts], var_heap, expr_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
782

Sjaak Smetsers's avatar
Sjaak Smetsers committed
783
784
785
786
determineContextAddress :: ![TypeContext] !{#CommonDefs} !TypeContext !*TypeHeaps
	-> (!TypeContext, ![(Int, Global DefinedSymbol)], !*TypeHeaps)
determineContextAddress contexts defs this_context type_heaps
	= look_up_context_and_address this_context contexts defs type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
787
where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
788
789
790
791
792
	look_up_context_and_address :: !TypeContext ![TypeContext] !{#CommonDefs} !*TypeHeaps -> (TypeContext, [(Int, Global DefinedSymbol)], !*TypeHeaps)
	look_up_context_and_address context []  defs type_heaps
		= abort "look_up_context_and_address (overloading.icl)"
	look_up_context_and_address this_context [tc : tcs] defs type_heaps 
		#! (may_be_addres, type_heaps) = determine_address this_context tc [] defs type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
793
794
		= case may_be_addres of
			Yes address
Sjaak Smetsers's avatar
Sjaak Smetsers committed
795
				-> (tc, address, type_heaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
796
			No
Sjaak Smetsers's avatar
Sjaak Smetsers committed
797
				-> look_up_context_and_address this_context tcs defs type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
798
799
800
801
802
803
804
805
806
807
808

	determine_address :: !TypeContext !TypeContext ![(Int, Global DefinedSymbol)] !{#CommonDefs} !*TypeHeaps
		-> (!Optional [(Int, Global DefinedSymbol)],!*TypeHeaps)
	determine_address tc1 tc2 address defs type_heaps=:{th_vars}
		| tc1 == tc2
			= (Yes address, type_heaps)
			# {tc_class={glob_object={ds_index},glob_module}} = tc2
			  {class_args,class_members,class_context,class_dictionary} = defs.[glob_module].com_class_defs.[ds_index]
			  th_vars = foldr2 (\{tv_info_ptr} type -> writePtr tv_info_ptr (TVI_Type type)) th_vars class_args tc2.tc_types
			  (super_instances, type_heaps) = substitute class_context { type_heaps & th_vars = th_vars } 
			= find_super_instance tc1 super_instances (size class_members) address glob_module class_dictionary.ds_index defs type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
809
810
811
812
813
814
815
816
817
818
819
820
821
822
	where
		find_super_instance :: !TypeContext ![TypeContext] !Index ![(Int, Global DefinedSymbol)] !Index !Index !{#CommonDefs} !*TypeHeaps
			-> (!Optional [(Int, Global DefinedSymbol)],!*TypeHeaps)
		find_super_instance context [] tc_index address dict_mod dict_index defs type_heaps
			= (No, type_heaps)
		find_super_instance context [tc : tcs] tc_index address dict_mod dict_index defs type_heaps
			#! (may_be_addres, type_heaps) = determine_address context tc address defs type_heaps
			= case may_be_addres of
				Yes address
					# selector = selectFromDictionary dict_mod dict_index tc_index defs
					-> (Yes [ (tc_index, selector) : address ], type_heaps)
				No
					-> find_super_instance context tcs (inc tc_index) address  dict_mod dict_index defs type_heaps
		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
823

Sjaak Smetsers's avatar
Sjaak Smetsers committed
824
825
826
827
828
829
830
getClassVariable :: !Ident !VarInfoPtr !*VarHeap !*ErrorAdmin -> (!Ident, !VarInfoPtr, !*VarHeap, !*ErrorAdmin)
getClassVariable symb var_info_ptr var_heap error
	= case (readPtr var_info_ptr var_heap) of
		(VI_ClassVar var_name new_info_ptr count, var_heap)
			-> (var_name, new_info_ptr, var_heap <:= (var_info_ptr, VI_ClassVar var_name new_info_ptr (inc count)), error)
		(_, var_heap)
			-> (symb, var_info_ptr, var_heap, overloadingError symb error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
831

Sjaak Smetsers's avatar
Sjaak Smetsers committed
832

833
834
835
updateDynamics :: ![Index] ![LocalTypePatternVariable] !*{#FunDef} !*{! FunctionType} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol}
	-> (!*{#FunDef}, !*{! FunctionType}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin, !*{#PredefinedSymbol})
updateDynamics funs type_pattern_vars fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
836
	| error.ea_ok
837
838
		= update_dynamics funs type_pattern_vars fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols
		= (fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error, predef_symbols)	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
839
where
840
841
842
	update_dynamics [] type_pattern_vars fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols
		= (fun_defs, fun_env, symbol_heap, type_code_info, var_heap,  error, predef_symbols)
	update_dynamics [fun:funs] type_pattern_vars fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
843
		#! fun_def = fun_defs.[fun]
844
845
		# {fun_body,fun_symb,fun_info/* MV ={fi_group_index, fi_dynamics}*/} = fun_def
		# {fi_group_index, fi_dynamics} = fun_info
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
846
		| isEmpty fi_dynamics
847
			= update_dynamics funs type_pattern_vars fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols
Sjaak Smetsers's avatar
Sjaak Smetsers committed
848
		  	# (type_code_info, symbol_heap, type_pattern_vars, var_heap, error)
849
		  			= convertDynamicTypes fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) /* MV */ []
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
850
		  	  (TransformedBody tb) = fun_body
851
		  	  (tb_rhs, {ui_instance_calls, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_error /* MV */, ui_type_code_info = type_code_info, ui_predef_symbols = predef_symbols /*, ui_new_variables */}) = updateExpression fi_group_index tb.tb_rhs
852
					{ ui_instance_calls = [], ui_symbol_heap = symbol_heap, ui_fun_defs = fun_defs, ui_local_vars = [],
853
854
855
856
857
858
859
860
861
862
863
864
					  ui_fun_env = fun_env, ui_var_heap = var_heap, ui_error = error 
					  /* MV */, ui_type_code_info = type_code_info, ui_predef_symbols = predef_symbols} //, ui_new_variables = [] }
		 	  fun_def = { fun_def & fun_body = TransformedBody {tb & tb_rhs = tb_rhs}
		 	  					}
//		 	  			/* MV */  , fun_info = { fun_info & fi_local_vars = ui_new_variables ++ fun_info.fi_local_vars }}
		 	  
		 	  
		 	  // 			= ({fun_defs & [fun] = { fun_def & fun_body = fun_body, fun_info = { fun_info & fi_local_vars = ci.ci_new_variables ++ fun_info.fi_local_vars }}},

		 	  
			= update_dynamics funs type_pattern_vars ({ ui_fun_defs & [fun] = fun_def })
				 ui_fun_env  ui_symbol_heap type_code_info ui_var_heap ui_error predef_symbols
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
865

Sjaak Smetsers's avatar
Sjaak Smetsers committed
866
removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !*{#FunDef} !*{! FunctionType} !*ExpressionHeap
867
868
869
	!*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol}
		-> (!*{#FunDef}, !*{! FunctionType}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin, !*{#PredefinedSymbol})
removeOverloadedFunctions group type_pattern_vars fun_defs fun_env symbol_heap type_code_info var_heap error predef_symbols
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
870
	| error.ea_ok
871
872
873
		# (fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error, predef_symbols)
			= foldSt (remove_overloaded_function type_pattern_vars) group (fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error, predef_symbols)
		= (fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error, predef_symbols)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
874
where
875
876
	remove_overloaded_function type_pattern_vars fun_index (fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error, predef_symbols)
		# (fun_def, fun_defs) = fun_defs![fun_index]  
Sjaak Smetsers's avatar
Sjaak Smetsers committed
877
878
		  (CheckedType {st_context}, fun_env) = fun_env![fun_index]
		  {fun_body = TransformedBody {tb_args,tb_rhs},fun_info,fun_arity,fun_symb,fun_pos} = fun_def
879
	
Sjaak Smetsers's avatar
Sjaak Smetsers committed
880
881
		  (rev_variables, var_heap) = foldSt determine_class_argument st_context ([], var_heap)
		  error = setErrorAdmin (newPosition fun_symb fun_pos) error
Sjaak Smetsers's avatar
Sjaak Smetsers committed
882
		  (type_code_info, symbol_heap, type_pattern_vars, var_heap, error)
883
884
885
		  		= convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) /* MV */ rev_variables
		 
		  (tb_rhs, {ui_instance_calls, ui_local_vars, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_error /* MV */, ui_type_code_info = type_code_info, ui_predef_symbols = predef_symbols}) //, ui_new_variables })
886
		  		= updateExpression fun_info.fi_group_index tb_rhs {  ui_instance_calls = [], ui_local_vars = fun_info.fi_local_vars, ui_symbol_heap = symbol_heap,
887
888
889
		  				ui_var_heap = var_heap, ui_fun_defs = fun_defs, ui_fun_env = fun_env, ui_error = error 
		  				/* MV */, ui_type_code_info = type_code_info, ui_predef_symbols = predef_symbols}
		  (tb_args, var_heap) = foldSt retrieve_class_argument rev_variables (tb_args, ui_var_heap) 
890
891
		  fun_def = { fun_def & fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, fun_arity = length tb_args,
		  						fun_info = { fun_info & fi_calls = fun_info.fi_calls ++ ui_instance_calls, fi_local_vars = ui_local_vars } }
892
		= ({ ui_fun_defs & [fun_index] = fun_def }, ui_fun_env, ui_symbol_heap, type_code_info, var_heap, ui_error, predef_symbols)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910

	determine_class_argument {tc_class={glob_object={ds_ident={id_name}}}, tc_var} (variables, var_heap)
		# (var_info, var_heap) = readPtr tc_var var_heap
		= case var_info of 
			VI_ForwardClassVar var_info_ptr
				# (var_info, var_heap) = readPtr var_info_ptr var_heap
//				  (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
//				-> ([var_info_ptr : variables], var_heap <:= (var_info_ptr, VI_ClassVar (build_var_name id_name) new_info_ptr 0 var_info))

				-> case var_info of
					VI_Empty
						# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
						-> ([var_info_ptr : variables], var_heap <:= (var_info_ptr, VI_ClassVar (build_var_name id_name) new_info_ptr 0))
					_
						-> abort "determine_class_argument (overloading.icl)"

			VI_Empty
				# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
911
				  var_heap	= var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
912
913
914
				-> ([tc_var : variables], var_heap <:= (tc_var, VI_ClassVar (build_var_name id_name) new_info_ptr 0))
			_
				-> abort "determine_class_argument (overloading.icl)"
Sjaak Smetsers's avatar
Sjaak Smetsers committed
915
916
917
918
919
920

	build_var_name id_name
		= { id_name = "_v" +++ id_name, id_info = nilPtr }

	retrieve_class_argument var_info_ptr (args, var_heap)
		# (VI_ClassVar var_name new_info_ptr count, var_heap) = readPtr var_info_ptr var_heap
921
		= ([{fv_name = var_name, fv_info_ptr = new_info_ptr, fv_def_level = NotALevel, fv_count = count } : args], var_heap <:= (var_info_ptr, VI_Empty)) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
922

923
convertDynamicTypes dyn_ptrs update_info rev_variables
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
924
925
	= foldSt update_dynamic dyn_ptrs update_info
where		
Sjaak Smetsers's avatar
Sjaak Smetsers committed
926
	update_dynamic dyn_ptr (type_code_info, expr_heap, type_pattern_vars, var_heap, error)
927
		# (dyn_info, expr_heap) = readPtr dyn_ptr expr_heap 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
928
		= case dyn_info of
929
			EI_TempDynamicType (Yes {dt_global_vars, dt_uni_vars, dt_type}) _ _ expr_ptr {symb_name}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
930
931
932
				# (expr_info, expr_heap) = readPtr expr_ptr expr_heap
				-> case expr_info of
					EI_TypeCodes type_codes
933
934
935
936
937
938
939
940
941
942
						// MV ..
						# (type_var_heap,var_heap,error) = fold2St (f symb_name)
														dt_global_vars type_codes (type_code_info.tci_type_var_heap,var_heap,error)
						// .. MV
						  (uni_vars, (type_var_heap, var_heap)) = new_type_variables dt_uni_vars (type_var_heap, var_heap)
						  (type_code_expr, (type_code_info,var_heap,error)) = toTypeCodeExpression symb_name rev_variables dt_type ({ type_code_info & tci_type_var_heap = type_var_heap },var_heap,error)
						-> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic uni_vars type_code_expr), type_pattern_vars, var_heap, error)
/*
ORIGINAL:

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
943
944
						# type_var_heap = fold2St (\{tv_info_ptr} type_code -> writePtr tv_info_ptr (TVI_TypeCode type_code))
														dt_global_vars type_codes type_code_info.tci_type_var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
945
						  (uni_vars, (type_var_heap, var_heap)) = new_type_variables dt_uni_vars (type_var_heap, var_heap)
946
						  (type_code_expr, (type_code_info, var_heap, error)) = toTypeCodeExpression dt_type { type_code_info & tci_type_var_heap = type_var_heap }
Sjaak Smetsers's avatar
Sjaak Smetsers committed
947
						-> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic uni_vars type_code_expr), type_pattern_vars, var_heap, error)
948
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
949
					EI_Empty
Sjaak Smetsers's avatar
Sjaak Smetsers committed
950
						# (uni_vars, (type_var_heap, var_heap)) = new_type_variables dt_uni_vars (type_code_info.tci_type_var_heap, var_heap)
951
						  (type_code_expr, (type_code_info,var_heap,error)) = toTypeCodeExpression symb_name rev_variables dt_type ({ type_code_info & tci_type_var_heap = type_var_heap },var_heap,error)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
952
953
						-> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic uni_vars type_code_expr), type_pattern_vars, var_heap, error)
			EI_TempDynamicType No _ _ expr_ptr {symb_name}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
954
955
956
				# (expr_info, expr_heap) = readPtr expr_ptr expr_heap
				-> case expr_info of
					EI_TypeCode type_expr
957
958
						# (type_expr, (free_vars, var_heap, rev_variables, error)) = retrieve_free_vars symb_name type_expr ([], var_heap, rev_variables, error)
						  var_heap = foldSt mark_free_var free_vars var_heap 
Sjaak Smetsers's avatar
Sjaak Smetsers committed
959
						-> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic free_vars type_expr), type_pattern_vars, var_heap, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
960
					EI_Selection selectors record_var _
Sjaak Smetsers's avatar
Sjaak Smetsers committed
961
						# (_, var_info_ptr, var_heap, error) = getClassVariable symb_name record_var var_heap error
962
963
						-> (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamic [] (convert_selectors selectors var_info_ptr /* MPM */ record_var)), type_pattern_vars, var_heap, error)
			EI_TempDynamicPattern type_vars {dt_global_vars, dt_type} loc_dynamics temp_local_vars _ _ expr_ptr {symb_name}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
964
965
966
				# (expr_info, expr_heap) = readPtr expr_ptr expr_heap
				-> case expr_info of
					EI_TypeCodes type_codes
967
968
969
970
971
//						# type_var_heap = fold2St (\{tv_info_ptr} type_code -> writePtr tv_info_ptr (TVI_TypeCode type_code)) dt_global_vars type_codes type_code_info.tci_type_var_heap
						// MV ..
						# (type_var_heap,var_heap,error) = fold2St (f symb_name)
														dt_global_vars type_codes (type_code_info.tci_type_var_heap,var_heap,error)
						// .. MV
Sjaak Smetsers's avatar
Sjaak Smetsers committed
972
						  (var_ptrs, (type_pattern_vars, var_heap)) = mapSt addLocalTCInstance temp_local_vars (type_pattern_vars, var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
973
						  type_var_heap = fold2St (\{tv_info_ptr} var_ptr -> writePtr tv_info_ptr (TVI_TypeCode (TCE_Var var_ptr))) type_vars var_ptrs type_var_heap
974
						  (type_code_expr, (type_code_info,var_heap,error)) = toTypeCodeExpression symb_name rev_variables dt_type ({ type_code_info & tci_type_var_heap = type_var_heap },var_heap,error)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
975
						-> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), type_pattern_vars, var_heap, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
976
					EI_Empty
Sjaak Smetsers's avatar
Sjaak Smetsers committed
977
						# (var_ptrs, (type_pattern_vars, var_heap)) = mapSt addLocalTCInstance temp_local_vars (type_pattern_vars, var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
978
						  type_var_heap = fold2St (\{tv_info_ptr} var_ptr -> writePtr tv_info_ptr (TVI_TypeCode (TCE_Var var_ptr))) type_vars var_ptrs type_code_info.tci_type_var_heap
979
						  (type_code_expr, (type_code_info,var_heap,error)) = toTypeCodeExpression symb_name rev_variables dt_type ({ type_code_info & tci_type_var_heap = type_var_heap },var_heap,error)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
980
						-> convert_loc