overloading.icl 97.4 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 genericsupport, compilerSwitches, type_io_common
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
7

8
9
10
11
::	LocalTypePatternVariable =
	{	ltpv_var			:: !Int
	,	ltpv_new_var		:: !VarInfoPtr
	}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
12
13
14
15
16
17
18
19
20
21
22

::	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
23
	,	rcs_constraints_contexts	:: ![ClassApplication]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
24
25
26
	}

::	TypeCodeInstance =
27
	{	tci_constructor		:: !GlobalTCType
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
28
29
30
31
32
33
34
35
36
37
38
	,	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 */



		
39
40
instanceError symbol types err
	# err = errorHeading "Overloading error" err
41
	  format = { form_properties = cNoProperties, form_attr_position = No }
42
43
	= { err & ea_file = err.ea_file <<< " \"" <<< symbol <<< "\" no instance available of type "
									<:: (format, types, Yes initialTypeVarBeautifulizer) <<< '\n' }
44
45
46

uniqueError symbol types err
	# err = errorHeading "Overloading/Uniqueness error" err
47
	  format = { form_properties = cAnnotated, form_attr_position = No }
48
	= { err & ea_file = err.ea_file <<< " \"" <<< symbol
49
50
			<<< "\" uniqueness specification of instance conflicts with current application "
			<:: (format, types, Yes initialTypeVarBeautifulizer) <<< '\n'}
51

52
53
unboxError class_ident type err
	# err = errorHeading ("Overloading error of "+++class_ident+++" class") err
54
	  format = { form_properties = cNoProperties, form_attr_position = No }
55
	= { err & ea_file = err.ea_file <<< ' ' <:: (format, type, Yes initialTypeVarBeautifulizer) <<< " instance cannot be unboxed\n"}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
56

Sjaak Smetsers's avatar
Sjaak Smetsers committed
57
58
overloadingError op_symb err
	# err = errorHeading "Overloading error" err
59
60
61
62
63
64
	  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" }
65

66
abstractTypeInDynamicError td_ident err=:{ea_ok}
67
	# err = errorHeading "Implementation restriction" err
68
	= { err & ea_file = err.ea_file <<< (" derived abstract type '" +++ toString td_ident +++ "' not permitted in a dynamic") <<< '\n' }
69
	
70
71
72
73
74
75
typeCodeInDynamicError err=:{ea_ok}
	# err = errorHeading "Overloading error (warning for now)" err
	  err = {err & ea_ok=ea_ok}
	= { err & ea_file = err.ea_file <<< "TC context not allowed in dynamic" <<< '\n' }


Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
76
77
78
79
80
81
/*
	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
82
83
84
85
86
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
87
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
88
89
90
FoundObject object :== object.glob_module <> NotFound
ObjectNotFound 	:== { glob_module = NotFound, glob_object = NotFound }

91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
:: ReduceState =
	{	rs_new_contexts :: ![TypeContext]
	,	rs_special_instances :: !.SpecialInstances
	,	rs_type_pattern_vars :: ![LocalTypePatternVariable]
	,	rs_var_heap :: !.VarHeap
	,	rs_type_heaps :: !.TypeHeaps
	,	rs_coercions :: !.Coercions
	,	rs_predef_symbols :: !.PredefinedSymbols
	,	rs_error :: !.ErrorAdmin
	}

:: ReduceInfo =
	{	ri_defs :: !{# CommonDefs}
	,	ri_instance_info :: !ClassInstanceInfo
	,	ri_main_dcl_module_n :: !Int
	}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
107

108
109
110
111
112
113
114
115
116
117
118
:: ReduceTCState =
	{	rtcs_new_contexts :: ![TypeContext]
	,	rtcs_type_pattern_vars :: ![LocalTypePatternVariable]
	,	rtcs_var_heap :: !.VarHeap
	,	rtcs_type_heaps :: !.TypeHeaps
	,	rtcs_error :: !.ErrorAdmin
	}

reduceContexts :: !ReduceInfo ![TypeContext] !*ReduceState -> (![ClassApplication], !*ReduceState)
reduceContexts info tcs rs_state
	=	mapSt (try_to_reduce_context info) tcs rs_state
119
where
120
121
122
123
	try_to_reduce_context :: !ReduceInfo !TypeContext !*ReduceState -> *(!ClassApplication, !*ReduceState)
	try_to_reduce_context info tc rs_state=:{rs_predef_symbols, rs_new_contexts}
		| context_is_reducible tc rs_predef_symbols
			= reduce_any_context info tc rs_state
124
//				---> ("try_to_reduce_context (Yes)", tc)
125
		| containsContext tc rs_new_contexts
126
//				---> ("try_to_reduce_context (No)", tc)
127
128
129
130
131
132
			= (CA_Context tc, rs_state)
			# {rs_var_heap, rs_new_contexts} = rs_state
			# (tc_var, rs_var_heap) = newPtr VI_Empty rs_var_heap
			# rs_new_contexts = [{ tc & tc_var = tc_var } : rs_new_contexts]
			= (CA_Context tc, {rs_state & rs_var_heap=rs_var_heap, rs_new_contexts=rs_new_contexts})

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
133
	reduce_any_context :: !ReduceInfo !TypeContext !*ReduceState -> *(!ClassApplication, !*ReduceState)
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
	reduce_any_context info tc=:{tc_class=class_symb=:(TCGeneric {gtc_class})} rs_state
		= reduce_any_context info {tc & tc_class = TCClass gtc_class} rs_state
	reduce_any_context info=:{ri_defs} tc=:{tc_class=class_symb=:(TCClass {glob_object={ds_index},glob_module}),tc_types} rs_state=:{rs_predef_symbols}
		| is_predefined_symbol glob_module ds_index PD_TypeCodeClass rs_predef_symbols
			# {rs_new_contexts, rs_type_pattern_vars,rs_var_heap, rs_type_heaps, rs_error} = rs_state
			# rtcs_state = {rtcs_new_contexts=rs_new_contexts, rtcs_type_pattern_vars=rs_type_pattern_vars,
									rtcs_var_heap=rs_var_heap, rtcs_type_heaps=rs_type_heaps, rtcs_error=rs_error}
			# (red_context, {rtcs_new_contexts, rtcs_type_pattern_vars,rtcs_var_heap, rtcs_type_heaps, rtcs_error})
						= reduce_TC_context ri_defs class_symb (hd tc_types) rtcs_state
			# rs_state = {rs_state & rs_new_contexts=rtcs_new_contexts, rs_type_pattern_vars=rtcs_type_pattern_vars,
									rs_var_heap=rtcs_var_heap, rs_type_heaps=rtcs_type_heaps, rs_error=rtcs_error}
			= (red_context, rs_state)
			# (class_appls, rs_state)
					= reduce_context info tc rs_state
			= (CA_Instance class_appls, rs_state)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
150
	reduce_context :: !ReduceInfo !TypeContext !*ReduceState -> *(!ReducedContexts, !*ReduceState)
151
152
153
154
155
	reduce_context info tc=:{tc_class=TCGeneric {gtc_class}} rs_state
		= reduce_context info {tc & tc_class = TCClass gtc_class} rs_state
	reduce_context info=:{ri_defs,ri_instance_info,ri_main_dcl_module_n} {tc_class=TCClass class_symb=:{glob_object={ds_index},glob_module},tc_types}
			rs_state
		# {class_members,class_context,class_args,class_ident} = ri_defs.[glob_module].com_class_defs.[ds_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
156
		| size class_members > 0
157
			# class_instances = ri_instance_info.[glob_module].[ds_index]
158
159
160
			# {rs_coercions, rs_type_heaps} = rs_state
			# ({glob_module,glob_object}, contexts, uni_ok, rs_type_heaps, rs_coercions) = find_instance tc_types class_instances ri_defs rs_type_heaps rs_coercions
			# rs_state = {rs_state & rs_coercions=rs_coercions, rs_type_heaps=rs_type_heaps}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
161
			| (glob_module <> NotFound) && uni_ok
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
				# {ins_members, ins_class} = ri_defs.[glob_module].com_instance_defs.[glob_object]
				| is_predefined_symbol ins_class.glob_module ins_class.glob_object.ds_index PD_ArrayClass rs_state.rs_predef_symbols &&
				  is_unboxed_array tc_types rs_state.rs_predef_symbols
					# {rs_predef_symbols, rs_error,rs_special_instances, rs_type_heaps}
						=	rs_state
					# (rcs_class_context, rs_special_instances, (rs_predef_symbols, rs_type_heaps), rs_error)
						= check_unboxed_array_type ri_main_dcl_module_n glob_module ins_class ins_members tc_types class_members ri_defs rs_special_instances (rs_predef_symbols, rs_type_heaps) rs_error
					# rs_state = {rs_state & rs_predef_symbols=rs_predef_symbols,
									rs_special_instances=rs_special_instances,rs_type_heaps=rs_type_heaps, rs_error=rs_error}
					= ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, rs_state)
				| is_predefined_symbol ins_class.glob_module ins_class.glob_object.ds_index PD_UListClass rs_state.rs_predef_symbols
					# {rs_predef_symbols, rs_error,rs_special_instances, rs_type_heaps}
						=	rs_state
					# (rcs_class_context, rs_special_instances, (rs_predef_symbols, rs_type_heaps), rs_error)
						= check_unboxed_list_type ri_main_dcl_module_n glob_module ins_class ins_members tc_types class_members ri_defs rs_special_instances (rs_predef_symbols, rs_type_heaps) rs_error
					# rs_state = {rs_state & rs_predef_symbols=rs_predef_symbols,
									rs_special_instances=rs_special_instances,rs_type_heaps=rs_type_heaps, rs_error=rs_error}
					= ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, rs_state)
				| is_predefined_symbol ins_class.glob_module ins_class.glob_object.ds_index PD_UTSListClass rs_state.rs_predef_symbols
					# {rs_predef_symbols, rs_error,rs_special_instances, rs_type_heaps}
						=	rs_state
					# (rcs_class_context, rs_special_instances, (rs_predef_symbols, rs_type_heaps), rs_error)
						= check_unboxed_tail_strict_list_type ri_main_dcl_module_n glob_module ins_class ins_members tc_types class_members ri_defs rs_special_instances (rs_predef_symbols, rs_type_heaps) rs_error
					# rs_state = {rs_state & rs_predef_symbols=rs_predef_symbols,
									rs_special_instances=rs_special_instances,rs_type_heaps=rs_type_heaps, rs_error=rs_error}
					= ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, rs_state)

					# (appls, rs_state)
							= reduceContexts info contexts rs_state
					  (constraints, rs_state)
					  		= reduce_contexts_in_constraints info tc_types class_args class_context rs_state
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
193
					= ({ rcs_class_context = { rc_class = ins_class, rc_inst_module = glob_module, rc_inst_members = ins_members,
194
								rc_types = tc_types, rc_red_contexts = appls }, rcs_constraints_contexts = constraints }, rs_state)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
195
196
				# rcs_class_context = { rc_class = class_symb, rc_inst_module = NoIndex, rc_inst_members = {}, rc_types = tc_types, rc_red_contexts = [] }
				| glob_module <> NotFound
197
198
199
200
201
202
					# rs_state = {rs_state & rs_error = uniqueError class_ident tc_types rs_state.rs_error}
					= ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, rs_state)
					# rs_state = {rs_state & rs_error = instanceError class_ident tc_types rs_state.rs_error}
					= ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, rs_state)
			# (constraints, rs_state)
				= reduce_contexts_in_constraints info tc_types class_args class_context rs_state
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
203
			= ({ rcs_class_context = { rc_class = class_symb, rc_inst_module = NoIndex, rc_inst_members = {}, rc_types = tc_types, rc_red_contexts = [] },
204
				rcs_constraints_contexts = constraints }, rs_state)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
205

206
207
	reduce_contexts_in_constraints :: !ReduceInfo ![Type] ![TypeVar] ![TypeContext] *ReduceState
		-> *([ClassApplication],*ReduceState)
208
	reduce_contexts_in_constraints info types class_args [] rs_state
209
		= ([],rs_state)
210
	reduce_contexts_in_constraints info types class_args class_context rs_state=:{rs_type_heaps=rs_type_heaps=:{th_vars}}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
211
		# th_vars = fold2St (\ type {tv_info_ptr} -> writePtr tv_info_ptr (TVI_Type type)) types class_args th_vars
212
213
		  (instantiated_context, rs_type_heaps) = fresh_contexts class_context { rs_type_heaps & th_vars = th_vars }
		# rs_state = {rs_state & rs_type_heaps=rs_type_heaps}
214
		= mapSt (reduce_any_context info) instantiated_context rs_state
Sjaak Smetsers's avatar
Sjaak Smetsers committed
215

216
217
218
	find_instance :: [Type] !InstanceTree {#CommonDefs} *TypeHeaps *Coercions -> *(Global Int,[TypeContext],Bool,*TypeHeaps,*Coercions)
	find_instance co_types (IT_Node this_inst_index=:{glob_object,glob_module} left right) defs type_heaps coercion_env
		# (left_index, types, uni_ok, type_heaps, coercion_env) = find_instance co_types left defs type_heaps coercion_env
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
219
		| FoundObject left_index
220
			= (left_index, types, uni_ok, type_heaps, coercion_env)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
221
222
223
			# {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
224
				# (subst_context, type_heaps) = fresh_contexts it_context type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
225
226
227
				  (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
228
229
230
					= (spec_inst, [], uni_ok, type_heaps, coercion_env)
					= (this_inst_index, subst_context, uni_ok, type_heaps, coercion_env)
				= find_instance co_types right defs type_heaps coercion_env
Sjaak Smetsers's avatar
Sjaak Smetsers committed
231
232
	find_instance co_types IT_Empty defs heaps coercion_env
		= (ObjectNotFound, [], True, heaps, coercion_env)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
233
234

	get_specials :: Specials -> [Special]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
235
236
237
	get_specials (SP_ContextTypes specials) = specials
	get_specials SP_None 					= []

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
238
	adjust_type_attributes :: !{#CommonDefs} ![Type] ![Type] !*Coercions !*TypeHeaps -> (Bool, !*Coercions, !*TypeHeaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
239
240
241
	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)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
242
	adjust_type_attribute :: !{#CommonDefs} !Type !Type !(Bool, !*Coercions, !*TypeHeaps) -> (Bool, !*Coercions, !*TypeHeaps)
243
244
	adjust_type_attribute _ _ (TV _) state
		= state
245
	adjust_type_attribute defs type1=:(TA type_cons1 cons_args1) type2=:(TA type_cons2 cons_args2) (ok, coercion_env, type_heaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
246
		| type_cons1 == type_cons2
247
			= adjust_attributes_and_subtypes defs cons_args1 cons_args2 (ok, coercion_env, type_heaps)
248
249
250
251
252
253
254
255
256
257
258
259
260
			= expand_types_and_adjust_type_attribute type_cons1 cons_args1 type_cons2 cons_args2 defs type1 type2 ok coercion_env type_heaps
	adjust_type_attribute defs type1=:(TA type_cons1 cons_args1) type2=:(TAS type_cons2 cons_args2 _) (ok, coercion_env, type_heaps)
		| type_cons1 == type_cons2
			= adjust_attributes_and_subtypes defs cons_args1 cons_args2 (ok, coercion_env, type_heaps)
			= expand_types_and_adjust_type_attribute type_cons1 cons_args1 type_cons2 cons_args2 defs type1 type2 ok coercion_env type_heaps
	adjust_type_attribute defs type1=:(TAS type_cons1 cons_args1 _) type2=:(TA type_cons2 cons_args2) (ok, coercion_env, type_heaps)
		| type_cons1 == type_cons2
			= adjust_attributes_and_subtypes defs cons_args1 cons_args2 (ok, coercion_env, type_heaps)
			= expand_types_and_adjust_type_attribute type_cons1 cons_args1 type_cons2 cons_args2 defs type1 type2 ok coercion_env type_heaps
	adjust_type_attribute defs type1=:(TAS type_cons1 cons_args1 _) type2=:(TAS type_cons2 cons_args2 _) (ok, coercion_env, type_heaps)
		| type_cons1 == type_cons2
			= adjust_attributes_and_subtypes defs cons_args1 cons_args2 (ok, coercion_env, type_heaps)
			= expand_types_and_adjust_type_attribute type_cons1 cons_args1 type_cons2 cons_args2 defs type1 type2 ok coercion_env type_heaps
261
262
	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
263
264
265
266
// AA..
	adjust_type_attribute defs (TArrow1 x) (TArrow1 y) state
		= adjust_attributes_and_subtypes defs [x] [y] state
// ..AA
267
268
	adjust_type_attribute defs (_ :@: types1) (_ :@: types2) state
		= adjust_attributes_and_subtypes defs types1 types2 state
269
	adjust_type_attribute defs type1=:(TA type_cons1 cons_args1) type2 (ok, coercion_env, type_heaps)
270
		# (expanded, type1, type_heaps) = tryToExpandTypeSyn defs type1 type_cons1 cons_args1 type_heaps
271
272
273
		| expanded
			= adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps)
			= (ok, coercion_env, type_heaps)
274
	adjust_type_attribute defs type1=:(TAS type_cons1 cons_args1 _) type2 (ok, coercion_env, type_heaps)
275
276
277
278
		# (expanded, type1, type_heaps) = tryToExpandTypeSyn defs type1 type_cons1 cons_args1 type_heaps
		| expanded
			= adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps)
			= (ok, coercion_env, type_heaps)
279
	adjust_type_attribute defs type1 type2=:(TA type_cons2 cons_args2) (ok, coercion_env, type_heaps)
280
281
282
283
		# (expanded, type2, type_heaps) = tryToExpandTypeSyn defs type2 type_cons2 cons_args2 type_heaps
		| expanded
			= adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps)
			= (ok, coercion_env, type_heaps)
284
	adjust_type_attribute defs type1 type2=:(TAS type_cons2 cons_args2 _) (ok, coercion_env, type_heaps)
285
		# (expanded, type2, type_heaps) = tryToExpandTypeSyn defs type2 type_cons2 cons_args2 type_heaps
286
287
288
289
		| 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
290
291
		= state
	
292
293
294
295
	expand_types_and_adjust_type_attribute type_cons1 cons_args1 type_cons2 cons_args2 defs type1 type2 ok coercion_env type_heaps
		# (_, type1, type_heaps) = tryToExpandTypeSyn defs type1 type_cons1 cons_args1 type_heaps
		  (_, type2, type_heaps) = tryToExpandTypeSyn defs type2 type_cons2 cons_args2 type_heaps
		= adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps)
296

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
297
	adjust_attributes_and_subtypes :: !{#CommonDefs} ![AType] ![AType] !(Bool, !*Coercions, !*TypeHeaps) -> (Bool, !*Coercions, !*TypeHeaps)
298
299
300
	adjust_attributes_and_subtypes defs types1 types2 state
		= fold2St (adjust_attribute_and_subtypes defs) types1 types2 state
		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
301
	adjust_attribute_and_subtypes :: !{#CommonDefs} !AType !AType !(Bool, !*Coercions, !*TypeHeaps) -> (Bool, !*Coercions, !*TypeHeaps)
302
303
304
305
	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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
306
		adjust_attribute :: !TypeAttribute !TypeAttribute !(Bool, !*Coercions) -> (Bool, !*Coercions)
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
		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)
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
329
	context_is_reducible :: TypeContext PredefinedSymbols -> Bool
330
	context_is_reducible {tc_class=TCClass class_symb,tc_types = [type : types]} predef_symbols
331
		= type_is_reducible type class_symb predef_symbols && types_are_reducible types type class_symb predef_symbols
332
	context_is_reducible tc=:{tc_class=TCGeneric {gtc_class}, tc_types = [type : types]} predef_symbols
333
		= type_is_reducible type gtc_class predef_symbols && types_are_reducible types type gtc_class predef_symbols
334

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
335
	type_is_reducible :: Type a PredefinedSymbols -> Bool
336
337
338
	type_is_reducible (TempV _) tc_class predef_symbols
		= False // is_predefined_symbol tc_class.glob_module tc_class.glob_object.ds_index PD_TypeCodeClass predef_symbols
	type_is_reducible (_ :@: _) tc_class predef_symbols
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
339
		= False
340
	type_is_reducible _ tc_class predef_symbols
341
342
		= True

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
343
	types_are_reducible :: [Type] Type (Global DefinedSymbol) PredefinedSymbols -> Bool
344
345
346
347
348
	types_are_reducible [] _ _ _
		= True
	types_are_reducible [type : types] first_type tc_class predef_symbols
		= case type of
			TempV _
349
				->	is_lazy_or_strict_array_or_list_context
350
			_ :@: _
351
				->	is_lazy_or_strict_array_or_list_context
352
			_
353
				-> is_reducible types tc_class predef_symbols
354
355
356
357
358
359
360
361
	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)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
362
		is_lazy_or_strict_array_type :: Type PredefinedSymbols -> Bool
363
364
365
		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
366
367
368
		is_lazy_or_strict_array_type _ _
			= False

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
369
		is_lazy_or_strict_list_type :: Type PredefinedSymbols -> Bool
370
371
372
373
374
375
376
377
378
379
		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

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
380
		is_reducible :: [Type] (Global DefinedSymbol) PredefinedSymbols -> Bool
381
382
383
384
385
		is_reducible [] tc_class predef_symbols
			= True
		is_reducible [ type : types] tc_class predef_symbols
			= type_is_reducible type tc_class predef_symbols && is_reducible types tc_class predef_symbols

386
387
388
	fresh_contexts :: ![TypeContext] !*TypeHeaps -> ([TypeContext],*TypeHeaps)
	fresh_contexts contexts type_heaps
		= mapSt fresh_context contexts type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
389
	where
390
391
		fresh_context :: !TypeContext !*TypeHeaps -> (TypeContext,*TypeHeaps)
		fresh_context tc=:{tc_types} type_heaps
392
			# (tc_types, type_heaps) = substitute tc_types type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
393
394
//			  (tc_var, var_heap) = newPtr VI_Empty var_heap
//			= ({ tc & tc_types = tc_types, tc_var = tc_var }, (var_heap, type_heaps))
395
			= ({ tc & tc_types = tc_types }, type_heaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
396
397

	is_unboxed_array:: [Type] PredefinedSymbols -> Bool
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
398
399
400
401
402
	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

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
403
404
	check_unboxed_array_type :: Int Int (Global DefinedSymbol) {#DefinedSymbol} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
		-> (ReducedContext,*SpecialInstances,(*PredefinedSymbols,*TypeHeaps), *ErrorAdmin)
405
	check_unboxed_array_type main_dcl_module_n 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
406
		# (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
407
408
409
410
		| unboxable
			= case opt_record of
				Yes record
					# (ins_members, special_instances) = add_record_to_array_instances record class_members special_instances
411
					-> ({ 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
412
							special_instances, predef_symbols_type_heaps, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
413
414
				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
415
							special_instances, predef_symbols_type_heaps, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
416
			= ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
417
					special_instances, predef_symbols_type_heaps, unboxError "Array" elem_type error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
418
419
420
	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}
421
			# may_be_there = look_up_array_or_list_instance record si_array_instances
Sjaak Smetsers's avatar
Sjaak Smetsers committed
422
423
424
425
426
427
428
			= 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 ] })
429

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
430
431
	check_unboxed_list_type :: Int Int (Global DefinedSymbol) {#DefinedSymbol} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
		-> (ReducedContext,*SpecialInstances,(*PredefinedSymbols,*TypeHeaps), *ErrorAdmin)
432
	check_unboxed_list_type main_dcl_module_n ins_module ins_class ins_members types=:[elem_type:_] class_members defs special_instances predef_symbols_type_heaps error
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
		# (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 ] })

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
457
458
	check_unboxed_tail_strict_list_type :: Int Int (Global DefinedSymbol) {#DefinedSymbol} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
		-> (ReducedContext,*SpecialInstances,(*PredefinedSymbols,*TypeHeaps), *ErrorAdmin)
459
	check_unboxed_tail_strict_list_type main_dcl_module_n ins_module ins_class ins_members types=:[elem_type:_] class_members defs special_instances predef_symbols_type_heaps error
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
		# (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 ] })

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
484
485

	try_to_unbox ::  Type !{#CommonDefs} (!*PredefinedSymbols, !*TypeHeaps) -> (!Bool, !Optional TypeSymbIdent, !(!*PredefinedSymbols, !*TypeHeaps))
486
487
488
489
490
491
492
493
494
495
496
497
498
499
	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}
500
				# (expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args at_type type_heaps
501
502
503
504
505
506
				-> 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)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
507
	is_predefined_symbol :: !Int !Int !Int !PredefinedSymbols -> Bool
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
	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
524
				
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
525
	disallow_abstract_types_in_dynamics :: {#CommonDefs} (Global Index) *ErrorAdmin ->  *ErrorAdmin
526
	disallow_abstract_types_in_dynamics defs type_index=:{glob_module,glob_object} error
527
528
529
		| cPredefinedModuleIndex == glob_module
			= error
			
530
		#! ({td_ident,td_rhs})
531
532
			= defs.[glob_module].com_type_defs.[glob_object]
		= case td_rhs of
533
534
				AbstractType _			-> abstractTypeInDynamicError td_ident error
				AbstractSynType _ _		-> abstractTypeInDynamicError td_ident error
535
				_						-> error
536

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
537
	reduce_TC_context :: {#CommonDefs} TCClass Type *ReduceTCState -> (ClassApplication, !*ReduceTCState)
538
539
	reduce_TC_context defs type_code_class tc_type rtcs_state
		= reduce_tc_context defs type_code_class tc_type rtcs_state
540
	where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
541
		reduce_tc_context :: {#CommonDefs} TCClass Type *ReduceTCState -> (ClassApplication, !*ReduceTCState)
542
543
544
		reduce_tc_context defs type_code_class type=:(TA cons_id=:{type_index} cons_args) rtcs_state=:{rtcs_error,rtcs_type_heaps}
			# rtcs_error
				= disallow_abstract_types_in_dynamics defs type_index rtcs_error
545
				
546
547
548
			# (expanded, type, rtcs_type_heaps)
				=	tryToExpandTypeSyn defs type cons_id cons_args rtcs_type_heaps
			# rtcs_state = {rtcs_state & rtcs_error=rtcs_error, rtcs_type_heaps=rtcs_type_heaps}
549
			| expanded
550
				=	reduce_tc_context defs type_code_class type rtcs_state
551
				
552
			# type_constructor = toTypeCodeConstructor type_index defs
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
			  (rc_red_contexts, rtcs_state) = reduce_TC_contexts defs type_code_class cons_args rtcs_state
			= (CA_GlobalTypeCode { tci_constructor = type_constructor, tci_contexts = rc_red_contexts }, rtcs_state)
		reduce_tc_context defs type_code_class (TAS cons_id cons_args _) rtcs_state
			=	reduce_tc_context defs type_code_class (TA cons_id cons_args) rtcs_state
		reduce_tc_context defs type_code_class (TB basic_type) rtcs_state
			= (CA_GlobalTypeCode { tci_constructor = GTT_Basic basic_type, tci_contexts = [] }, rtcs_state)
		reduce_tc_context defs type_code_class (arg_type --> result_type) rtcs_state
			#  (rc_red_contexts, rtcs_state) = reduce_TC_contexts defs type_code_class [arg_type, result_type] rtcs_state
			= (CA_GlobalTypeCode { tci_constructor = GTT_Function, tci_contexts = rc_red_contexts }, rtcs_state)
		reduce_tc_context defs type_code_class (TempQV var_number) rtcs_state=:{rtcs_type_pattern_vars, rtcs_var_heap}
			# (inst_var, (rtcs_type_pattern_vars, rtcs_var_heap)) = addLocalTCInstance var_number (rtcs_type_pattern_vars, rtcs_var_heap)
			# rtcs_state = {rtcs_state & rtcs_type_pattern_vars=rtcs_type_pattern_vars, rtcs_var_heap=rtcs_var_heap}
			= (CA_LocalTypeCode inst_var, rtcs_state)
		reduce_tc_context defs type_code_class (TempV var_number) rtcs_state=:{rtcs_var_heap, rtcs_new_contexts}
			# (tc_var, rtcs_var_heap) = newPtr VI_Empty rtcs_var_heap
			# rtcs_state={rtcs_state & rtcs_var_heap=rtcs_var_heap}
Sjaak Smetsers's avatar
Sjaak Smetsers committed
569
			  tc = { tc_class = type_code_class, tc_types = [TempV var_number], tc_var = tc_var }
570
571
572
			| containsContext tc rtcs_new_contexts
				= (CA_Context tc, rtcs_state)
				= (CA_Context tc, {rtcs_state & rtcs_new_contexts = [tc : rtcs_new_contexts]})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
573

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
574
		reduce_TC_contexts :: {#CommonDefs} TCClass [AType] *ReduceTCState -> ([ClassApplication], !*ReduceTCState)
575
576
		reduce_TC_contexts defs type_code_class cons_args rtcs_state
			= mapSt (\{at_type} -> reduce_tc_context defs type_code_class at_type) cons_args rtcs_state
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
577
		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
578
addLocalTCInstance :: Int (([LocalTypePatternVariable], *VarHeap)) -> (VarInfoPtr, ([LocalTypePatternVariable], *VarHeap))
Sjaak Smetsers's avatar
Sjaak Smetsers committed
579
addLocalTCInstance var_number (instances=:[inst : insts], ltp_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
580
581
	# cmp = var_number =< inst.ltpv_var
	| cmp == Equal
Sjaak Smetsers's avatar
Sjaak Smetsers committed
582
		= (inst.ltpv_new_var, (instances, ltp_var_heap))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
583
584
	| cmp == Smaller
		# (ltpv_new_var, ltp_var_heap) = newPtr VI_Empty ltp_var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
585
586
587
588
		= (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
589
	# (ltpv_new_var, ltp_var_heap) = newPtr VI_Empty ltp_var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
590
	= (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
591

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
592
tryToExpandTypeSyn :: {#CommonDefs} Type TypeSymbIdent [AType] *TypeHeaps -> (Bool, Type, *TypeHeaps)
593
594
tryToExpandTypeSyn defs type cons_id=:{type_ident,type_index={glob_object,glob_module}} type_args type_heaps
	# {td_ident,td_rhs,td_args,td_attribute} = defs.[glob_module].com_type_defs.[glob_object]
Sjaak Smetsers's avatar
Sjaak Smetsers committed
595
596
	= case td_rhs of
		SynType {at_type}
597
			# (expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args at_type type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
598
599
			-> (True, expanded_type, type_heaps) 
		_
600
			-> (False, type, type_heaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
601
602
603
604
605
606
607

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

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
608
expand_and_match :: TypeSymbIdent [AType] TypeSymbIdent [AType] {#CommonDefs} Type Type *TypeHeaps -> (Bool, *TypeHeaps)
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
expand_and_match cons_id1 cons_args1 cons_id2 cons_args2 defs type1 type2 type_heaps
	# (succ1, type1, type_heaps) = tryToExpandTypeSyn defs type1 cons_id1 cons_args1 type_heaps
	# (succ2, type2, type_heaps) = tryToExpandTypeSyn defs type2 cons_id2 cons_args2 type_heaps
	| succ1 || succ2
		= match defs type1 type2 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)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
628
629
630
631
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)})
632
	match defs type1=:(TA cons_id1 cons_args1) type2=:(TA cons_id2 cons_args2) type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
633
634
		| cons_id1 == cons_id2
			= match defs cons_args1 cons_args2 type_heaps
635
636
637
638
639
640
641
642
643
644
645
646
647
			= expand_and_match cons_id1 cons_args1 cons_id2 cons_args2 defs type1 type2 type_heaps
	match defs type1=:(TA cons_id1 cons_args1) type2=:(TAS cons_id2 cons_args2 _) type_heaps
		| cons_id1 == cons_id2
			= match defs cons_args1 cons_args2 type_heaps
			= expand_and_match cons_id1 cons_args1 cons_id2 cons_args2 defs type1 type2 type_heaps
	match defs type1=:(TAS cons_id1 cons_args1 _) type2=:(TA cons_id2 cons_args2) type_heaps
		| cons_id1 == cons_id2
			= match defs cons_args1 cons_args2 type_heaps
			= expand_and_match cons_id1 cons_args1 cons_id2 cons_args2 defs type1 type2 type_heaps
	match defs type1=:(TAS cons_id1 cons_args1 _) type2=:(TAS cons_id2 cons_args2 _) type_heaps
		| cons_id1 == cons_id2
			= match defs cons_args1 cons_args2 type_heaps
			= expand_and_match cons_id1 cons_args1 cons_id2 cons_args2 defs type1 type2 type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
648
649
650
651
652
653
654
655
656
	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)
657
658
659
660
661
	match defs (CV tv :@: types) (TAS 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)
662
663
664
665
666
667
//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
668
669
670
671
	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
672
673
674
*/
	match defs type1=:(TA cons_id cons_args) type2 type_heaps
		# (succ, type1, type_heaps) = tryToExpandTypeSyn defs type1 cons_id cons_args type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
675
676
677
		| succ
			= match defs type1 type2 type_heaps
			= (False, type_heaps)
678
679
680
681
682
683
684
685
686
687
688
689
	match defs type1=:(TAS cons_id cons_args _) type2 type_heaps
		# (succ, type1, type_heaps) = tryToExpandTypeSyn defs type1 cons_id cons_args type_heaps
		| succ
			= match defs type1 type2 type_heaps
			= (False, type_heaps)
	match defs type1 type2=:(TA cons_id cons_args) type_heaps
		# (succ, type2, type_heaps) = tryToExpandTypeSyn defs type2 cons_id cons_args type_heaps
		| succ
			= match defs type1 type2 type_heaps
			= (False, type_heaps)
	match defs type1 type2=:(TAS cons_id cons_args _) type_heaps
		# (succ, type2, type_heaps) = tryToExpandTypeSyn defs type2 cons_id cons_args type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
		| 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

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
721
trySpecializedInstances :: [TypeContext] [Special] *TypeHeaps -> (!Global Index,!*TypeHeaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
722
723
724
725
726
727
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
728
	try_specialized_instances :: [[Type]] [Special] *TypeVarHeap -> (!Global Index,!*TypeVarHeap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
729
730
	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
731
		  (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
732
733
734
735
736
737
		| 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)

738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
	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);

764
tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !Int !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState !{# DclModule}
Sjaak Smetsers's avatar
Sjaak Smetsers committed
765
	-> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], DictionaryTypes, !*OverloadingState)
766
tryToSolveOverloading ocs main_dcl_module_n defs instance_info coercion_env os dcl_modules
767
768
769
	# (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)
770
		  (contexts, os_type_heaps) = remove_super_classes contexts os.os_type_heaps
771
772
		  ({ hp_var_heap, hp_expression_heap, hp_type_heaps,hp_generic_heap}, dict_types, os_error)
		  	= foldSt (convert_dictionaries defs contexts) reduced_contexts
773
774
		  					({ hp_var_heap = os_var_heap, hp_expression_heap = os.os_symbol_heap, hp_type_heaps = os_type_heaps,hp_generic_heap=os.os_generic_heap}, [], os.os_error)
		= (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, os_generic_heap = hp_generic_heap, os_error = os_error} )
Sjaak Smetsers's avatar
Sjaak Smetsers committed
775
		= ([], coercion_env, type_pattern_vars, [], os)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
776
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
777
778
779
780
781
	reduce_contexts :: {#CommonDefs} ClassInstanceInfo (.a, [ExprInfoPtr], .b, Index)
		([(SymbIdent, Index, ExprInfoPtr,[ClassApplication])], ![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
		-> ([(SymbIdent, Index, ExprInfoPtr,[ClassApplication])], ![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
	reduce_contexts defs instance_info (opt_spec_contexts, expr_ptrs, pos, index) state
		= foldSt (reduce_contexts_of_application index defs instance_info) expr_ptrs state
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
782

Sjaak Smetsers's avatar
Sjaak Smetsers committed
783
784
785
786
787
788
789
790
791
792
793
	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
794
795
796
797
	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
798
799
			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
800
801
802
		  (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 =
803
									{ ds_ident =  oc_symbol.symb_ident, ds_arity = 0, ds_index = glob_fun.glob_object }} [])
Sjaak Smetsers's avatar
Sjaak Smetsers committed
804
805
			= (reduced_calls, new_contexts, coercion_env, type_pattern_vars, { os & os_type_heaps = os_type_heaps, os_symbol_heap = os_symbol_heap })
		| otherwise
806
807
808
809
810
811
812
813
814
815
816
817
818
			# rs_state 	= {rs_new_contexts=new_contexts, rs_special_instances = os_special_instances,
							rs_type_pattern_vars=type_pattern_vars,rs_var_heap=os_var_heap, 
							rs_type_heaps=os_type_heaps, rs_coercions=coercion_env,
							rs_predef_symbols=os_predef_symbols, rs_error=os_error}
			# info
				=	{ri_main_dcl_module_n=main_dcl_module_n, ri_defs=defs, ri_instance_info=instance_info}
			# (class_applications, rs_state)
					= reduceContexts info oc_context rs_state
			# {rs_new_contexts=new_contexts, rs_special_instances = os_special_instances,
							rs_type_pattern_vars=type_pattern_vars,rs_var_heap=os_var_heap, 
							rs_type_heaps=os_type_heaps, rs_coercions=coercion_env,
							rs_predef_symbols=os_predef_symbols, rs_error=os_error}
				= rs_state
Sjaak Smetsers's avatar
Sjaak Smetsers committed
819
			= ([ (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
820
821
822
					{ 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 })

823
824
825
826
827
	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)
	
828
829
830
831
	
	generate_super_classes tc=:{tc_class=TCGeneric {gtc_class}} st
		= generate_super_classes {tc & tc_class=TCClass gtc_class} st
	generate_super_classes {tc_class=TCClass {glob_object={ds_index},glob_module},tc_types} (super_classes, type_heaps)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
832
833
		# {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
834
		= foldSt subst_context_and_generate_super_classes class_context (super_classes, { type_heaps & th_vars = th_vars })
Sjaak Smetsers's avatar
Sjaak Smetsers committed
835
836
837
838
	where
		set_type {tv_info_ptr} type type_var_heap
			= type_var_heap <:= (tv_info_ptr, TVI_Type type)
		  
839
		subst_context_and_generate_super_classes class_context (super_classes, type_heaps)
840
			# (super_class, type_heaps) = substitute class_context type_heaps
841
842
843
			| 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
844
845
846
847
848
849
		 
	remove_doubles sub_classes tc context
		| containsContext tc sub_classes
			= context
			= [tc : context]

850
851
852
	convert_dictionaries :: !{# CommonDefs } ![TypeContext] !(!SymbIdent,!Index,!ExprInfoPtr,![ClassApplication]) !(!*Heaps,!DictionaryTypes, !*ErrorAdmin) -> (!*Heaps,!DictionaryTypes, !*ErrorAdmin)
	convert_dictionaries defs contexts (oc_symbol, index, over_info_ptr, class_applications) (heaps, dict_types, error)
		# (heaps, ptrs, error) = convertOverloadedCall defs contexts oc_symbol over_info_ptr class_applications (heaps, [], error)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
853
		| isEmpty ptrs
854
855
			= (heaps, dict_types, error)
			= (heaps, add_to_dict_types index ptrs dict_types, error)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
856
857
858
859
860
861
862
	
	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
863
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
864
865
selectFromDictionary  dict_mod dict_index member_index defs
	# (RecordType {rt_fields}) = defs.[dict_mod].com_type_defs.[dict_index].td_rhs
866
867
	  { fs_ident, fs_index } = rt_fields.[member_index]
	= { glob_module = dict_mod, glob_object = { ds_ident = fs_ident, ds_index = fs_index, ds_arity = 1 }}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
868

869
getDictionaryTypeAndConstructor {glob_module, glob_object = {ds_ident,ds_index}} defs	  
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
870
871
	# {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
872
	= (class_dictionary, rt_constructor)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
873

874
convertOverloadedCall :: !{#CommonDefs} ![TypeContext] !SymbIdent !ExprInfoPtr ![ClassApplication] !(!*Heaps, ![ExprInfoPtr],!*ErrorAdmin) -> (!*Heaps, ![ExprInfoPtr],!*ErrorAdmin)
875
convertOverloadedCall defs contexts {symb_ident,symb_kind = SK_OverloadedFunction {glob_module,glob_object}} expr_ptr [class_appl:class_appls] (heaps,ptrs,error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
876
	# mem_def = defs.[glob_module].com_member_defs.[glob_object]
877
	  (class_exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts class_appls (heaps, ptrs)
878
	  (inst_expr, (heaps, ptrs)) = adjust_member_application defs contexts  mem_def class_appl class_exprs heaps_and_ptrs
879
	= ({ heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_ptr, inst_expr)}, ptrs, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
880
where
881
	adjust_member_application defs contexts {me_ident,me_offset,me_class} (CA_Instance red_contexts) class_exprs heaps_and_ptrs
882
883
		# ({glob_module,glob_object}, red_contexts_appls) = find_instance_of_member me_class me_offset red_contexts
		  (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts red_contexts_appls heaps_and_ptrs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
884
		  class_exprs = exprs ++ class_exprs
885
		= (EI_Instance { glob_module = glob_module, glob_object = { ds_ident = me_ident, ds_arity = length class_exprs, ds_index = glob_object }} class_exprs,
Sjaak Smetsers's avatar
Sjaak Smetsers committed
886
			 heaps_and_ptrs)
887
	adjust_member_application  defs contexts  {me_ident,me_offset,me_class={glob_module,glob_object}} (CA_Context tc) class_exprs (heaps=:{hp_type_heaps}, ptrs)
888
		# (class_context, address, hp_type_heaps) = determineContextAddress contexts defs tc hp_type_heaps
889
		# {class_dictionary={ds_index,ds_ident}} = defs.[glob_module].com_class_defs.[glob_object]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
890
		  selector = selectFromDictionary glob_module ds_index me_offset defs
891
		= (EI_Selection (generateClassSelection address [RecordSelection selector me_offset]) class_context.tc_var class_exprs,
Sjaak Smetsers's avatar
Sjaak Smetsers committed
892
				({ heaps & hp_type_heaps = hp_type_heaps }, ptrs))
893
	adjust_member_application defs contexts  _ (CA_GlobalTypeCode {tci_constructor,tci_contexts}) _ heaps_and_ptrs
Sjaak Smetsers's avatar
Sjaak Smetsers committed
894
		# (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs
895
		= (EI_TypeCode (TCE_Constructor tci_constructor (map expressionToTypeCodeExpression exprs)), heaps_and_ptrs)
896
	adjust_member_application defs contexts _ (CA_LocalTypeCode new_var_ptr) _  heaps_and_ptrs
Sjaak Smetsers's avatar
Sjaak Smetsers committed
897
		= (EI_TypeCode (TCE_Var new_var_ptr), heaps_and_ptrs)
898
899

	find_instance_of_member :: (Global Int) Int ReducedContexts -> ((Global Int),[ClassApplication])
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
900
901
902
903
904
	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
905
		find_instance_of_member_in_constraints me_class me_offset [ CA_Instance rcs=:{rcs_constraints_contexts} : rcss ]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
906
			= find_instance_of_member me_class me_offset {rcs & rcs_constraints_contexts = rcs_constraints_contexts ++ rcss}
907
908
		find_instance_of_member_in_constraints me_class me_offset [ _ : rcss ]
			= find_instance_of_member_in_constraints me_class me_offset rcss
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
909
910
		find_instance_of_member_in_constraints me_class me_offset []
			= abort "Error in module overloading: find_instance_of_member_in_constraints\n"
911
convertOverloadedCall defs contexts symbol=:{symb_ident, symb_kind = SK_Generic gen_glob kind} expr_ptr class_appls (heaps, expr_info_ptrs, error)
912
913
914
915
	#! (opt_member_glob, hp_generic_heap) = getGenericMember gen_glob kind defs heaps.hp_generic_heap
	#! heaps = { heaps & hp_generic_heap = hp_generic_heap }
	= case opt_member_glob of		
		No 
916
			# error = checkError ("no generic instances of " +++ toString symb_ident +++ " for kind") kind error