overloading.icl 98 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, convertDynamics 
6
import generics, compilerSwitches
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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

::	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 =
47
48
49
50
51
52
	{	si_next_array_member_index		:: !Index
	,	si_array_instances				:: ![ArrayInstance]
	,	si_list_instances				:: ![ArrayInstance]
	,	si_tail_strict_list_instances	:: ![ArrayInstance]
	,	si_next_TC_member_index			:: !Index
	,	si_TC_instances					:: ![GlobalTCInstance]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
53
	}
54

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
::	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
88
		compare_types (GTT_Constructor cons1 _) (GTT_Constructor cons2 _) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
89
90
91
92
93
			= cons1 =< cons2
		compare_types _ _
			= Equal
		
		
94
95
instanceError symbol types err
	# err = errorHeading "Overloading error" err
96
	  format = { form_properties = cNoProperties, form_attr_position = No }
97
98
	= { err & ea_file = err.ea_file <<< " \"" <<< symbol <<< "\" no instance available of type "
									<:: (format, types, Yes initialTypeVarBeautifulizer) <<< '\n' }
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 class_name type err
	# err = errorHeading ("Overloading error of "+++class_name+++" 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
overloadingError op_symb err
	# err = errorHeading "Overloading error" err
114
115
116
117
118
119
	  str = case optBeautifulizeIdent op_symb.id_name of
	  			No
	  				-> op_symb.id_name
	  			Yes (str, line_nr)
	  				-> str+++" [line "+++toString line_nr+++"]"
	= { err & ea_file = err.ea_file <<< " internal overloading of \"" <<< str <<< "\" could not be solved\n" }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
120
121
122
123
124
125
126

/*
	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
127
128
129
130
131
containsContext :: !TypeContext ![TypeContext] -> Bool
containsContext new_tc []
	= False
containsContext new_tc [tc : tcs]
	= new_tc == tc || containsContext new_tc tcs
Artem Alimarine's avatar
Artem Alimarine committed
132
		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
133
134
135
FoundObject object :== object.glob_module <> NotFound
ObjectNotFound 	:== { glob_module = NotFound, glob_object = NotFound }

136
reduceContexts :: ![TypeContext] !Int !{# CommonDefs} !ClassInstanceInfo ![TypeContext] !*SpecialInstances ![LocalTypePatternVariable]
137
	!(!*VarHeap, !*TypeHeaps) !*Coercions !*PredefinedSymbols !*ErrorAdmin !{# DclModule}
Sjaak Smetsers's avatar
Sjaak Smetsers committed
138
139
		-> *(![ClassApplication],  ![TypeContext], !*SpecialInstances, ![LocalTypePatternVariable],
				!(!*VarHeap, !*TypeHeaps), !*Coercions, !*PredefinedSymbols, !*ErrorAdmin)
140
reduceContexts [] main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error dcl_modules
Sjaak Smetsers's avatar
Sjaak Smetsers committed
141
	= ([], new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
142
reduceContexts [tc : tcs] main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error dcl_modules
Sjaak Smetsers's avatar
Sjaak Smetsers committed
143
144
145
	# (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)
146
	  		= reduceContexts tcs main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error dcl_modules
Sjaak Smetsers's avatar
Sjaak Smetsers committed
147
	= ([appl : appls], new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
148
149

where		
Sjaak Smetsers's avatar
Sjaak Smetsers committed
150
151
152
	try_to_reduce_context :: !TypeContext !{# CommonDefs} !ClassInstanceInfo ![TypeContext] !*SpecialInstances ![LocalTypePatternVariable]
		!(!*VarHeap, !*TypeHeaps) !*Coercions !*PredefinedSymbols !*ErrorAdmin
			-> *(!ClassApplication, ![TypeContext], !*SpecialInstances, ![LocalTypePatternVariable], !(!*VarHeap, !*TypeHeaps), !*Coercions, !*PredefinedSymbols, !*ErrorAdmin)
153
	try_to_reduce_context tc defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error
154
		| context_is_reducible tc predef_symbols
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
			= reduce_any_context tc defs instance_info 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, heaps, coercion_env, predef_symbols, error)
			# (var_heap, type_heaps) = heaps
			  (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_any_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
		| is_predefined_symbol glob_module ds_index PD_TypeCodeClass predef_symbols
			# (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
			= (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)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
173
174
175

	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
176
177
178
		# {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
179
			# ({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
180
181
182
183
			| (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
184
					# (rcs_class_context, special_instances, (predef_symbols, type_heaps), error)
185
186
187
188
189
190
191
192
193
194
195
196
						= check_unboxed_array_type glob_module ins_class ins_members tc_types class_members defs special_instances (predef_symbols, type_heaps) 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, error)

				| is_predefined_symbol ins_class.glob_module ins_class.glob_object.ds_index PD_UListClass predef_symbols
					# (rcs_class_context, special_instances, (predef_symbols, type_heaps), error)
						= check_unboxed_list_type glob_module ins_class ins_members tc_types class_members defs special_instances (predef_symbols, type_heaps) 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, error)
				| is_predefined_symbol ins_class.glob_module ins_class.glob_object.ds_index PD_UTSListClass predef_symbols
					# (rcs_class_context, special_instances, (predef_symbols, type_heaps), error)
						= check_unboxed_tail_strict_list_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
197
198
					= ({ 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)
199

Sjaak Smetsers's avatar
Sjaak Smetsers committed
200
					# (appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
201
							= reduceContexts contexts main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error dcl_modules
Sjaak Smetsers's avatar
Sjaak Smetsers committed
202
203
204
					  (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
205
					= ({ rcs_class_context = { rc_class = ins_class, rc_inst_module = glob_module, rc_inst_members = ins_members,
Sjaak Smetsers's avatar
Sjaak Smetsers committed
206
207
								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
208
209
				# 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
210
211
212
213
214
215
216
					= ({ 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
217
			= ({ 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
218
				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
219

Sjaak Smetsers's avatar
Sjaak Smetsers committed
220
221
222
223
	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
224
		# 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
225
226
		  (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
227
		  		= mapSt (reduce_context_in_constraint defs instance_info) instantiated_context
Sjaak Smetsers's avatar
Sjaak Smetsers committed
228
229
		  				(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
230
231

	where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
232
233
234
235
236
237
238
		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
239
		| FoundObject left_index
Sjaak Smetsers's avatar
Sjaak Smetsers committed
240
			= (left_index, types, uni_ok, (var_heap, type_heaps), coercion_env)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
241
242
243
			# {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
244
				# (subst_context, (var_heap, type_heaps)) = fresh_contexts it_context (var_heap, type_heaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
245
246
247
				  (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
248
249
250
251
252
					= (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
253
254
255
256
257
258
259
	
	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)

260
261
	adjust_type_attribute _ _ (TV _) state
		= state
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
262
263
	adjust_type_attribute defs (TA type_cons1 cons_args1) (TA type_cons2 cons_args2) (ok, coercion_env, type_heaps)
		| type_cons1 == type_cons2
264
			= adjust_attributes_and_subtypes defs cons_args1 cons_args2 (ok, coercion_env, type_heaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
265
266
267
			# (_, 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)
268
269
	adjust_type_attribute defs (arg_type1 --> res_type1) (arg_type2 --> res_type2) state
		= adjust_attributes_and_subtypes defs [arg_type1, res_type1] [arg_type2, res_type2] state
Artem Alimarine's avatar
Artem Alimarine committed
270
271
272
273
// AA..
	adjust_type_attribute defs (TArrow1 x) (TArrow1 y) state
		= adjust_attributes_and_subtypes defs [x] [y] state
// ..AA
274
275
276
277
278
279
280
281
282
283
284
285
286
	adjust_type_attribute defs (_ :@: types1) (_ :@: types2) state
		= adjust_attributes_and_subtypes defs types1 types2 state
	adjust_type_attribute _ (TA type_cons1 cons_args1) type2 (ok, coercion_env, type_heaps)
		# (expanded, type1, type_heaps) = tryToExpandTypeSyn defs type_cons1 cons_args1 type_heaps
		| expanded
			= adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps)
			= (ok, coercion_env, type_heaps)
	adjust_type_attribute _ type1 (TA type_cons2 cons_args2) (ok, coercion_env, type_heaps)
		# (expanded, type2, type_heaps) = tryToExpandTypeSyn defs type_cons2 cons_args2 type_heaps
		| expanded
			= adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps)
			= (ok, coercion_env, type_heaps)
	adjust_type_attribute _ _ _ state
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
287
288
		= state
	
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

	adjust_attributes_and_subtypes defs types1 types2 state
		= fold2St (adjust_attribute_and_subtypes defs) types1 types2 state
		
	adjust_attribute_and_subtypes defs atype1 atype2 (ok, coercion_env, type_heaps)
		# (ok, coercion_env) = adjust_attribute atype1.at_attribute atype2.at_attribute (ok, coercion_env)
		= adjust_type_attribute defs atype1.at_type atype2.at_type (ok, coercion_env, type_heaps)
	where
		adjust_attribute attr1 (TA_Var _) state
			= state
		adjust_attribute attr1 TA_Unique (ok, coercion_env)
			= case attr1 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)
	
		adjust_attribute attr1 attr (ok, coercion_env)
			= case attr1 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)
	
319
320
321
322
323
	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
324
		= False
325
	type_is_reducible (_ :@: _)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
326
		= False
327
328
329
330
331
332
333
334
	type_is_reducible _
		= True

	types_are_reducible [] _ _ _
		= True
	types_are_reducible [type : types] first_type tc_class predef_symbols
		= case type of
			TempV _
335
				->	is_lazy_or_strict_array_or_list_context
336
			_ :@: _
337
				->	is_lazy_or_strict_array_or_list_context
338
339
340
			_
				-> is_reducible types

341
342
343
344
345
346
347
348
349
350
351
	where
		is_lazy_or_strict_array_or_list_context
			=>	(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)
				||
				(is_predefined_symbol tc_class.glob_module tc_class.glob_object.ds_index PD_ListClass predef_symbols &&
				is_lazy_or_strict_list_type first_type predef_symbols)

		is_lazy_or_strict_array_type (TA {type_index={glob_module,glob_object}} _) predef_symbols
			= is_predefined_symbol glob_module glob_object PD_LazyArrayType predef_symbols ||
			  is_predefined_symbol glob_module glob_object PD_StrictArrayType predef_symbols
352
353
354
		is_lazy_or_strict_array_type _ _
			= False

355
356
357
358
359
360
361
362
363
364
		is_lazy_or_strict_list_type (TA {type_index={glob_module,glob_object}} _) predef_symbols
			= is_predefined_symbol glob_module glob_object PD_ListType predef_symbols ||
			  is_predefined_symbol glob_module glob_object PD_TailStrictListType predef_symbols ||
			  is_predefined_symbol glob_module glob_object PD_StrictListType predef_symbols ||
			  is_predefined_symbol glob_module glob_object PD_StrictTailStrictListType predef_symbols ||
			  is_predefined_symbol glob_module glob_object PD_UnboxedListType predef_symbols ||
			  is_predefined_symbol glob_module glob_object PD_UnboxedTailStrictListType predef_symbols
		is_lazy_or_strict_list_type _ _
			= False

365
366
367
368
	is_reducible []
		= True
	is_reducible [ type : types]
		= type_is_reducible type && is_reducible types
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
369

Sjaak Smetsers's avatar
Sjaak Smetsers committed
370
371
372
373
	fresh_contexts contexts heaps
		= mapSt fresh_context contexts heaps
	where
		fresh_context tc=:{tc_types} (var_heap, type_heaps)
Martin Wierich's avatar
Martin Wierich committed
374
			# (_, tc_types, type_heaps) = substitute tc_types type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
375
376
377
//			  (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
378
379
380
381
382
383
		
	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

384
	check_unboxed_array_type ins_module ins_class ins_members types=:[ _, elem_type :_] class_members defs special_instances predef_symbols_type_heaps error
Sjaak Smetsers's avatar
Sjaak Smetsers committed
385
		# (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
386
387
388
389
		| unboxable
			= case opt_record of
				Yes record
					# (ins_members, special_instances) = add_record_to_array_instances record class_members special_instances
390
					-> ({ rc_class = ins_class, rc_inst_module = main_dcl_module_n, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
Sjaak Smetsers's avatar
Sjaak Smetsers committed
391
							special_instances, predef_symbols_type_heaps, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
392
393
				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
394
							special_instances, predef_symbols_type_heaps, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
395
			= ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
396
					special_instances, predef_symbols_type_heaps, unboxError "Array" elem_type error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
397
398
399
	where
		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}
400
			# may_be_there = look_up_array_or_list_instance record si_array_instances
Sjaak Smetsers's avatar
Sjaak Smetsers committed
401
402
403
404
405
406
407
			= 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 ] })
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

	check_unboxed_list_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
		| unboxable
			= case opt_record of
				Yes record
					# (ins_members, special_instances) = add_record_to_list_instances record class_members special_instances
					-> ({ rc_class = ins_class, rc_inst_module = main_dcl_module_n, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
							special_instances, predef_symbols_type_heaps, error)
				No
					-> ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
							special_instances, predef_symbols_type_heaps, error)
			= ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
					special_instances, predef_symbols_type_heaps, unboxError "UList" elem_type error)
	where
		add_record_to_list_instances :: !TypeSymbIdent !{# DefinedSymbol} !*SpecialInstances -> (!{#DefinedSymbol},!*SpecialInstances)
		add_record_to_list_instances record members special_instances=:{si_next_array_member_index,si_list_instances}
			# may_be_there = look_up_array_or_list_instance record si_list_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_list_instances = [ inst : si_list_instances ] })

	check_unboxed_tail_strict_list_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
		| unboxable
			= case opt_record of
				Yes record
					# (ins_members, special_instances) = add_record_to_tail_strict_list_instances record class_members special_instances
					-> ({ rc_class = ins_class, rc_inst_module = main_dcl_module_n, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
							special_instances, predef_symbols_type_heaps, error)
				No
					-> ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
							special_instances, predef_symbols_type_heaps, error)
			= ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
					special_instances, predef_symbols_type_heaps, unboxError "UTSList" elem_type error)
	where
		add_record_to_tail_strict_list_instances :: !TypeSymbIdent !{# DefinedSymbol} !*SpecialInstances -> (!{#DefinedSymbol},!*SpecialInstances)
		add_record_to_tail_strict_list_instances record members special_instances=:{si_next_array_member_index,si_tail_strict_list_instances}
			# may_be_there = look_up_array_or_list_instance record si_tail_strict_list_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_tail_strict_list_instances = [ inst : si_tail_strict_list_instances ] })

	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)
		# {td_arity,td_rhs,td_args,td_attribute} = defs.[glob_module].com_type_defs.[glob_object]
		= case td_rhs of
			RecordType _
				-> (True, (Yes type_symb), (predef_symbols, type_heaps))
			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
				-> (unboxable, No, (predef_symbols, type_heaps))
			SynType {at_type}
473
				# (_, expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args at_type type_heaps
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
				-> try_to_unbox expanded_type defs (predef_symbols, type_heaps)
			_
				-> (False, No, (predef_symbols, type_heaps))				
	try_to_unbox type _ predef_symbols_type_heaps
		= (False, No, predef_symbols_type_heaps)

	is_predefined_symbol mod_index symb_index predef_index predef_symbols
		# {pds_def,pds_module} = predef_symbols.[predef_index]
		= mod_index == pds_module && symb_index == pds_def

	look_up_array_or_list_instance :: !TypeSymbIdent ![ArrayInstance] -> Optional ArrayInstance
	look_up_array_or_list_instance record []
		= No
	look_up_array_or_list_instance record [inst : insts]
		| record == inst.ai_record
			= Yes inst
			= look_up_array_or_list_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
496
				
497

Sjaak Smetsers's avatar
Sjaak Smetsers committed
498
499
	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
500
	where							
501
502
503
		reduce_tc_context type_code_class (TA cons_id=:{type_index={glob_module}} cons_args) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap)
			# defining_module_name
				= dcl_modules.[glob_module].dcl_name.id_name
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
504
			# (inst_index, (si_next_TC_member_index, si_TC_instances))
505
			  		= addGlobalTCInstance (GTT_Constructor cons_id defining_module_name) (si_next_TC_member_index, si_TC_instances)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
506
			  (rc_red_contexts, instances) = reduce_TC_contexts type_code_class cons_args
Sjaak Smetsers's avatar
Sjaak Smetsers committed
507
			  		 (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
508
			= (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = rc_red_contexts }, instances)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
509
		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
510
511
512
			# (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
513
514
					(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))
		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
515
516
517
			# (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
518
			  		 (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
519
			= (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = rc_red_contexts }, instances)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
520
		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
521
			# (inst_var, (type_pattern_vars, var_heap)) = addLocalTCInstance var_number (type_pattern_vars, var_heap)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
522
523
			= (CA_LocalTypeCode inst_var, (new_contexts, special_instances, type_pattern_vars, var_heap))
		reduce_tc_context type_code_class (TempV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap)
524
			# (tc_var, var_heap) = newPtr VI_Empty var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
525
526
527
528
			  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
529
530
531
532

		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
533
addLocalTCInstance var_number (instances=:[inst : insts], ltp_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
534
535
	# cmp = var_number =< inst.ltpv_var
	| cmp == Equal
Sjaak Smetsers's avatar
Sjaak Smetsers committed
536
		= (inst.ltpv_new_var, (instances, ltp_var_heap))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
537
538
	| cmp == Smaller
		# (ltpv_new_var, ltp_var_heap) = newPtr VI_Empty ltp_var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
539
540
541
542
		= (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
543
	# (ltpv_new_var, ltp_var_heap) = newPtr VI_Empty ltp_var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
544
	= (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
545
546
547
548
549
550
551
552
553
554
555
556
557

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
558
	# {td_name,td_rhs,td_args,td_attribute} = defs.[glob_module].com_type_defs.[glob_object]
Sjaak Smetsers's avatar
Sjaak Smetsers committed
559
560
	= case td_rhs of
		SynType {at_type}
561
			# (_, expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args at_type type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
562
563
564
			-> (True, expanded_type, type_heaps) 
		_
			-> (False, TA cons_id type_args, type_heaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
565
566
567
568
569
570
571
572
573
574
575
576
577
578

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
579
			# (succ1, type1, type_heaps) = tryToExpandTypeSyn defs cons_id1 cons_args1 type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
580
			# (succ2, type2, type_heaps) = tryToExpandTypeSyn defs cons_id2 cons_args2 type_heaps
581
582
583
			| succ1 || succ2
				= match defs type1 type2 type_heaps
/*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
584
			| succ2
585
			
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
586
587
588
589
590
591
592
				= 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)
593
594

*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
595
596
597
598
599
600
601
602
603
604
				= (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)
605
606
607
608
609
610
//AA..
	match defs TArrow TArrow type_heaps
		= (True, type_heaps)
	match defs (TArrow1 t1) (TArrow1 t2) type_heaps
		= match defs t1 t2 type_heaps
//..AA		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
	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
659
	try_specialized_instances :: [[Type]] [Special] *TypeVarHeap -> (!Global Index,!*TypeVarHeap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
660
661
	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
662
		  (equ, type_var_heap) = specialized_context_matches /*equalTypes*/ spec_types type_contexts_types type_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
663
664
665
666
667
668
		| 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)

669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
	specialized_context_matches :: [[Type]] ![[Type]] *TypeVarHeap -> (!.Bool,!.TypeVarHeap);
	specialized_context_matches [spec_context_types:spec_contexts_types] [type_context_types:type_contexts_types] type_var_heap
		# (equal,type_var_heap) = specialized_types_in_context_match spec_context_types type_context_types type_var_heap;
		|  equal
			= specialized_context_matches spec_contexts_types type_contexts_types type_var_heap
			= (False,type_var_heap);
	specialized_context_matches [] [] type_var_heap
		= (True,type_var_heap);
	specialized_context_matches _ _ type_var_heap
		= (False,type_var_heap);

	specialized_types_in_context_match :: [Type] ![Type] *TypeVarHeap -> (!.Bool,!.TypeVarHeap);
	specialized_types_in_context_match [TV _:spec_context_types] [_:type_context_types] type_var_heap
		// special case for type var in lazy or strict Array or List context
		// only these typevars are accepted by function checkAndCollectTypesOfContextsOfSpecials in check
		= specialized_types_in_context_match spec_context_types type_context_types type_var_heap
	specialized_types_in_context_match [spec_context_type:spec_context_types] [type_context_type:type_context_types] type_var_heap
		# (equal,type_var_heap) = equalTypes spec_context_type type_context_type type_var_heap;
		|  equal
			= specialized_types_in_context_match spec_context_types type_context_types type_var_heap
			= (False,type_var_heap);
	specialized_types_in_context_match [] [] type_var_heap
		= (True,type_var_heap);
	specialized_types_in_context_match _ _ type_var_heap
		= (False,type_var_heap);

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

697
tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !Int !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState !{# DclModule}
Sjaak Smetsers's avatar
Sjaak Smetsers committed
698
	-> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], DictionaryTypes, !*OverloadingState)
699
tryToSolveOverloading ocs main_dcl_module_n defs instance_info coercion_env os dcl_modules
700
701
702
	# (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)
703
		  (contexts, os_type_heaps) = remove_super_classes contexts os.os_type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
704
705
706
707
		  ({ 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
708
where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
709
	reduce_contexts defs instance_info (opt_spec_contexts, expr_ptrs, pos, index) rc_state
Sjaak Smetsers's avatar
Sjaak Smetsers committed
710
		= foldSt (reduce_contexts_of_application index defs instance_info) expr_ptrs rc_state
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
711

Sjaak Smetsers's avatar
Sjaak Smetsers committed
712
713
714
715
716
717
718
719
720
721
722
	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
723
724
725
726
	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
727
728
			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
729
730
731
732
		  (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
733
734
735
736
			= (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)
737
					= reduceContexts oc_context main_dcl_module_n defs instance_info new_contexts os_special_instances type_pattern_vars
738
							(os_var_heap, os_type_heaps) coercion_env os_predef_symbols os_error dcl_modules
Sjaak Smetsers's avatar
Sjaak Smetsers committed
739
			= ([ (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
740
741
742
					{ 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 })

743
744
745
746
747
748
	remove_super_classes contexts type_heaps
		# (super_classes, type_heaps) = foldSt generate_super_classes contexts ([], type_heaps)
		  sub_classes = foldSt (remove_doubles super_classes) contexts []
		= (sub_classes, type_heaps)
	
	generate_super_classes {tc_class={glob_object={ds_index},glob_module},tc_types} (super_classes, type_heaps)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
749
750
		# {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
751
		= foldSt subst_context_and_generate_super_classes class_context (super_classes, { type_heaps & th_vars = th_vars })
Sjaak Smetsers's avatar
Sjaak Smetsers committed
752
753
754
755
	where
		set_type {tv_info_ptr} type type_var_heap
			= type_var_heap <:= (tv_info_ptr, TVI_Type type)
		  
756
		subst_context_and_generate_super_classes class_context (super_classes, type_heaps)
Martin Wierich's avatar
Martin Wierich committed
757
			# (_, super_class, type_heaps) = substitute class_context type_heaps
758
759
760
			| containsContext super_class super_classes
				= (super_classes, type_heaps)
				= generate_super_classes super_class ([super_class : super_classes], type_heaps) 
Sjaak Smetsers's avatar
Sjaak Smetsers committed
761
762
763
764
765
766
		 
	remove_doubles sub_classes tc context
		| containsContext tc sub_classes
			= context
			= [tc : context]

Sjaak Smetsers's avatar
Sjaak Smetsers committed
767
768
769
770
771
772
773
774
775
776
777
778
779
	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
780
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
781
782
783
784
785
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 }}

786
getDictionaryTypeAndConstructor {glob_module, glob_object = {ds_ident,ds_index}} defs	  
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
787
788
	# {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
789
	= (class_dictionary, rt_constructor)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
790

Sjaak Smetsers's avatar
Sjaak Smetsers committed
791
792
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
793
	# mem_def = defs.[glob_module].com_member_defs.[glob_object]
Sjaak Smetsers's avatar
Sjaak Smetsers committed
794
795
796
	  (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
797
where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
798
	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
799
		# ({glob_module,glob_object}, red_contexts) = find_instance_of_member me_class me_offset red_contexts
Sjaak Smetsers's avatar
Sjaak Smetsers committed
800
		  (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts red_contexts heaps_and_ptrs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
801
		  class_exprs = exprs ++ class_exprs
Sjaak Smetsers's avatar
Sjaak Smetsers committed
802
		= (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
803
804
			 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)
805
		# (class_context, address, hp_type_heaps) = determineContextAddress contexts defs tc hp_type_heaps
806
		  {class_dictionary={ds_index,ds_ident}} = defs.[glob_module].com_class_defs.[glob_object]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
807
		  selector = selectFromDictionary glob_module ds_index me_offset defs
808
		= (EI_Selection (generateClassSelection address [RecordSelection selector me_offset]) class_context.tc_var class_exprs,
Sjaak Smetsers's avatar
Sjaak Smetsers committed
809
				({ heaps & hp_type_heaps = hp_type_heaps }, ptrs))
810

Sjaak Smetsers's avatar
Sjaak Smetsers committed
811
812
813
814
815
	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
816
817
818
819
820
821
822
823
824
825
	
	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"
826
827
828
829
830
831
832
// AA..			
convertOverloadedCall defs contexts symbol=:{symb_kind = SK_Generic gen_glob kind} expr_ptr class_appls heaps_and_ptrs
	# (found, member_glob) = getGenericMember gen_glob kind defs
	| not found
		= abort "convertOverloadedCall: no class for kind"	
 		=  convertOverloadedCall defs contexts {symbol & symb_kind = SK_OverloadedFunction member_glob} expr_ptr class_appls heaps_and_ptrs  				
// ..AA
833

Sjaak Smetsers's avatar
Sjaak Smetsers committed
834
835
836
837
838
839
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
840
841
842


expressionToTypeCodeExpression (TypeCodeExpression texpr) 			= texpr
843
expressionToTypeCodeExpression (ClassVariable var_info_ptr)			= TCE_TypeTerm var_info_ptr
844
expressionToTypeCodeExpression expr									= abort "expressionToTypeCodeExpression (overloading.icl)" // <<- expr)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
845
846
847

generateClassSelection address last_selectors
	= mapAppend (\(off_set,selector) -> RecordSelection selector off_set) address last_selectors
848
849
850

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

851
852
853
854
855
856
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"
857

Sjaak Smetsers's avatar
Sjaak Smetsers committed
858
859
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
860
where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
861
862
863
	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)
864
		# (class_context, context_address, hp_type_heaps) = determineContextAddress contexts defs tc hp_type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
865
		| isEmpty context_address
Sjaak Smetsers's avatar
Sjaak Smetsers committed
866
867
868
869
870
871
872
873
874
875
876
			= (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
877
878
	where
		convert_reduced_context_to_expression :: {#CommonDefs} [TypeContext] ReducedContext [Expression] *(*Heaps,[Ptr ExprInfo]) -> *(Expression,*(*Heaps,[Ptr ExprInfo]))
Sjaak Smetsers's avatar
Sjaak Smetsers committed
879
880
		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
881
			  context_size = length expressions
882
			| (size rc_inst_members > 2 && context_size > 0) || (size rc_inst_members==2 && (context_size>1 || not (is_small_context expressions)))
883
884
885
				# (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
886
				  (dict_expr, hp_expression_heap, class_ptrs) = build_dictionary rc_class rc_types dictionary_args defs hp_expression_heap class_ptrs
887
				| isEmpty let_binds
Sjaak Smetsers's avatar
Sjaak Smetsers committed
888
					= (dict_expr, ({ heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap }, class_ptrs))
889
					# (let_info_ptr, hp_expression_heap) = newPtr (EI_LetType let_types) hp_expression_heap
890
					= (Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = dict_expr, let_info_ptr = let_info_ptr, let_expr_position = NoPos },
Sjaak Smetsers's avatar
Sjaak Smetsers committed
891
						({ heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap }, [let_info_ptr : class_ptrs]))
892
				# 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
893
894
				  (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))
895

896
897
898
899
900
901
902
903
904
905
906
		is_small_context [] = True;
		is_small_context [App {app_args}] = contains_no_dictionaries app_args;
			where
				contains_no_dictionaries [] = True
				contains_no_dictionaries [App {app_args=[]}:args] = contains_no_dictionaries args
				contains_no_dictionaries [ClassVariable _:args] = contains_no_dictionaries args
				contains_no_dictionaries [Selection _ (ClassVariable _) _:args] = contains_no_dictionaries args
				contains_no_dictionaries l = False // <<- ("contains_no_dictionaries",l);
		is_small_context [ClassVariable _] = True;
		is_small_context l = False // <<- ("is_small_context",l);

907
908
909
910
911
912
913
914
915
916
917
918
919
		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
920
		build_dictionary class_symbol instance_types dictionary_args defs expr_heap ptrs
921
922
923
924
925
926
927
928
			# (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
929
			= (rc_record, expr_heap, [app_info_ptr : ptrs])
930
931
932
933
934
935

		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 }
936
937
			= ([{lb_src = dict, lb_dst = fv, lb_position = NoPos } : binds ], [ AttributedType class_type : types ],
				[Var var : rev_dicts], var_heap, expr_heap)
938
939
940
941
942
		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 }
943
			= ([{lb_src = dict, lb_dst = fv, lb_position = NoPos} : binds ], [ AttributedType class_type : types ], [Var var : rev_dicts], var_heap, expr_heap)
944
945
		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
946

Sjaak Smetsers's avatar
Sjaak Smetsers committed
947
948
949
950
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
951
where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
952
953
954
955
956
	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
957
958
		= case may_be_addres of
			Yes address
Sjaak Smetsers's avatar
Sjaak Smetsers committed
959
				-> (tc, address, type_heaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
960
			No
Sjaak Smetsers's avatar
Sjaak Smetsers committed
961
				-> look_up_context_and_address this_context tcs defs type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
962
963
964
965
966
967
968
969
970

	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
Martin Wierich's avatar
Martin Wierich committed
971
			  (_, super_instances, type_heaps) = substitute class_context { type_heaps & th_vars = th_vars } 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
972
			= 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
973
974
975
976
977
978
979
980
981
982
983
984
985
986
	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
987

Sjaak Smetsers's avatar
Sjaak Smetsers committed
988
989
990
991
992
993
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)
994
			# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
995
			-> (symb, new_info_ptr, var_heap <:= (var_info_ptr, VI_ClassVar symb new_info_ptr 1), overloadingError symb error)
Ronny Wichers Schreur's avatar