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

3
import StdEnv,StdOverloadedList,compare_types
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
4

5
import syntax, type, expand_types, utilities, unitype, predef, checktypes
6
import genericsupport, 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

::	ReducedContext = 
John van Groningen's avatar
John van Groningen committed
14
	{	rc_class_index		:: !GlobalIndex
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
15 16
	,	rc_types			:: ![Type]
	,	rc_inst_module		:: !Index
17
	,	rc_inst_members		:: !{#ClassInstanceMember}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
18 19 20 21 22
	,	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
	,	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 */
35

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

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

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

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

63 64 65 66 67 68 69 70 71
sub_class_error op_symb err
	# err = errorHeading "Overloading error" err
	  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 could not be solved, because subclass of \"" <<< str <<< "\" used\n"}

72
abstractTypeInDynamicError td_ident err=:{ea_ok}
73
	# err = errorHeading "Implementation restriction" err
74
	= { err & ea_file = err.ea_file <<< (" derived abstract type '" +++ toString td_ident +++ "' not permitted in a dynamic") <<< '\n' }
John van Groningen's avatar
John van Groningen committed
75

76
typeCodeInDynamicError err=:{ea_ok}
77
	# err = errorHeading "Warning" err
78 79 80
	  err = {err & ea_ok=ea_ok}
	= { err & ea_file = err.ea_file <<< "TC context not allowed in dynamic" <<< '\n' }

John van Groningen's avatar
John van Groningen committed
81 82 83
cycleAfterRemovingNewTypeConstructorsError ident err
	# err = errorHeading "Error" err
	= { err & ea_file = err.ea_file <<< (" cycle in definition of '" +++ toString ident +++ "' after removing newtype constructors") <<< '\n' }
84

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
85 86 87 88 89 90
/*
	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
91 92 93 94 95
containsContext :: !TypeContext ![TypeContext] -> Bool
containsContext new_tc []
	= False
containsContext new_tc [tc : tcs]
	= new_tc == tc || containsContext new_tc tcs
96

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
97 98 99
FoundObject object :== object.glob_module <> NotFound
ObjectNotFound 	:== { glob_module = NotFound, glob_object = NotFound }

100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
:: 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
116

117 118 119 120 121 122 123 124
:: ReduceTCState =
	{	rtcs_new_contexts :: ![TypeContext]
	,	rtcs_type_pattern_vars :: ![LocalTypePatternVariable]
	,	rtcs_var_heap :: !.VarHeap
	,	rtcs_type_heaps :: !.TypeHeaps
	,	rtcs_error :: !.ErrorAdmin
	}

125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171
collect_variable_and_contexts :: [ClassApplication] [(Int,Int)] [TypeContext] -> [(Int,Int)]
collect_variable_and_contexts [CA_Context {tc_class,tc_types=[TempV type_var_n]}:constraints] variables_and_contexts class_context
	# context_index = determine_index_in_class_context tc_class class_context 0
	| context_index<0
		= collect_variable_and_contexts constraints variables_and_contexts class_context
		# variables_and_contexts = add_variable_and_context type_var_n (1<<context_index) variables_and_contexts
		= collect_variable_and_contexts constraints variables_and_contexts class_context
where
	determine_index_in_class_context :: !TCClass ![TypeContext] !Int -> Int
	determine_index_in_class_context tc_class [class_context:class_contexts] class_index
		| class_context.tc_class==tc_class
			= class_index
			= determine_index_in_class_context tc_class class_contexts (class_index+1)
	determine_index_in_class_context tc_class [] class_index
		= -1;

	add_variable_and_context :: !Int !Int ![(Int,Int)] -> [(Int,Int)]
	add_variable_and_context type_var_n tv_context [variable_and_context=:(variable,context):variables_and_contexts]
		| type_var_n==variable
			#! context=context bitor tv_context
			= [(variable,context) : variables_and_contexts]
			= [variable_and_context : add_variable_and_context type_var_n tv_context variables_and_contexts]
	add_variable_and_context type_var_n tv_context []
		= [(type_var_n,tv_context)]
collect_variable_and_contexts [CA_Instance {rcs_class_context={rc_red_contexts},rcs_constraints_contexts}:constraints] variables_and_contexts class_context
	# variables_and_contexts = collect_variable_and_contexts rc_red_contexts variables_and_contexts class_context
	# variables_and_contexts = collect_variable_and_contexts rcs_constraints_contexts variables_and_contexts class_context
	= collect_variable_and_contexts constraints variables_and_contexts class_context
collect_variable_and_contexts [CA_GlobalTypeCode {tci_contexts}:constraints] variables_and_contexts class_context
	# variables_and_contexts = collect_variable_and_contexts tci_contexts variables_and_contexts class_context
	= collect_variable_and_contexts constraints variables_and_contexts class_context
collect_variable_and_contexts [_:constraints] variables_and_contexts class_context
	= collect_variable_and_contexts constraints variables_and_contexts class_context
collect_variable_and_contexts [] variables_and_contexts class_context
	= variables_and_contexts

add_unexpanded_contexts :: ![Int] !TCClass !*ReduceState -> *ReduceState
add_unexpanded_contexts [variable:variables] tc_class rs_state=:{rs_new_contexts,rs_var_heap}
	# tc = {tc_class = tc_class, tc_types = [TempV variable], tc_var = nilPtr}
	| containsContext tc rs_new_contexts
		= add_unexpanded_contexts variables tc_class rs_state
		# (tc_var, rs_var_heap) = newPtr VI_Empty rs_var_heap
		# rs_new_contexts = [{tc & tc_var = tc_var} : rs_new_contexts]
		= add_unexpanded_contexts variables tc_class {rs_state & rs_new_contexts=rs_new_contexts, rs_var_heap=rs_var_heap}
add_unexpanded_contexts [] tc_class rs_state
	= rs_state 

172 173
reduceContexts :: !ReduceInfo ![TypeContext] !*ReduceState -> (![ClassApplication], !*ReduceState)
reduceContexts info tcs rs_state
174
	= mapSt (try_to_reduce_context info) tcs rs_state
175
where
176 177 178 179 180 181 182 183
	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
		| containsContext tc rs_new_contexts
			= (CA_Context tc, rs_state)
			# {rs_var_heap, rs_new_contexts} = rs_state
			# (tc_var, rs_var_heap) = newPtr VI_Empty rs_var_heap
John van Groningen's avatar
John van Groningen committed
184
			# rs_new_contexts = [{tc & tc_var = tc_var} : rs_new_contexts]
185 186
			= (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
187
	reduce_any_context :: !ReduceInfo !TypeContext !*ReduceState -> *(!ClassApplication, !*ReduceState)
188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203
	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
204
	reduce_context :: !ReduceInfo !TypeContext !*ReduceState -> *(!ReducedContexts, !*ReduceState)
205 206
	reduce_context info tc=:{tc_class=TCGeneric {gtc_class}} rs_state
		= reduce_context info {tc & tc_class = TCClass gtc_class} rs_state
207
	reduce_context info=:{ri_defs,ri_instance_info,ri_main_dcl_module_n} {tc_class=tc_class=:TCClass class_symb=:{glob_object={ds_index},glob_module},tc_types}
208 209
			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
210
		| size class_members > 0
211
			# class_instances = ri_instance_info.[glob_module].[ds_index]
212 213 214
			# {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
215
			| (glob_module <> NotFound) && uni_ok
John van Groningen's avatar
John van Groningen committed
216 217
				# {ins_members, ins_class_index} = ri_defs.[glob_module].com_instance_defs.[glob_object]
				| is_predefined_global_symbol ins_class_index PD_ArrayClass rs_state.rs_predef_symbols &&
218 219 220 221
				  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)
John van Groningen's avatar
John van Groningen committed
222
						= check_unboxed_array_type ri_main_dcl_module_n glob_module ins_class_index ins_members tc_types class_members ri_defs rs_special_instances (rs_predef_symbols, rs_type_heaps) rs_error
223 224 225
					# 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)
John van Groningen's avatar
John van Groningen committed
226
				| is_predefined_global_symbol ins_class_index PD_UListClass rs_state.rs_predef_symbols
227 228 229
					# {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)
John van Groningen's avatar
John van Groningen committed
230
						= check_unboxed_list_type ri_main_dcl_module_n glob_module ins_class_index ins_members tc_types class_members ri_defs rs_special_instances (rs_predef_symbols, rs_type_heaps) rs_error
231 232 233
					# 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)
John van Groningen's avatar
John van Groningen committed
234
				| is_predefined_global_symbol ins_class_index PD_UTSListClass rs_state.rs_predef_symbols
235 236 237
					# {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)
John van Groningen's avatar
John van Groningen committed
238
						= check_unboxed_tail_strict_list_type ri_main_dcl_module_n glob_module ins_class_index ins_members tc_types class_members ri_defs rs_special_instances (rs_predef_symbols, rs_type_heaps) rs_error
239 240 241 242 243 244 245 246
					# 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
John van Groningen's avatar
John van Groningen committed
247
					= ({ rcs_class_context = { rc_class_index = ins_class_index, rc_inst_module = glob_module, rc_inst_members = ins_members,
248
								rc_types = tc_types, rc_red_contexts = appls }, rcs_constraints_contexts = constraints }, rs_state)
John van Groningen's avatar
John van Groningen committed
249
				# rcs_class_context = { rc_class_index = {gi_module=glob_module,gi_index=ds_index}, rc_inst_module = NoIndex, rc_inst_members = {}, rc_types = tc_types, rc_red_contexts = [] }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
250
				| glob_module <> NotFound
251 252 253 254 255 256
					# 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
257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273

			| case tc_types of [_] -> False; _ -> True
			|| case class_context of [] -> True; [_] -> True; _ -> False 
				// not implemented for multiparameter type classes or fewer than 2 class constraints
				= ({ rcs_class_context = { rc_class_index = {gi_module=glob_module,gi_index=ds_index}, rc_inst_module = NoIndex, rc_inst_members = {}, rc_types = tc_types, rc_red_contexts = [] },
					rcs_constraints_contexts = constraints }, rs_state)

			// if a constraint of a class without members is reduced, and all classes in the constraint of that class appear
			// in the reduced constraints for a variable, add a constraint for the original class for that variable
			// (this causes removal of the other constraints later), to prevent functions with too many constraints
			# n_contexts = length class_context
			  required_used_contexts = (2<<(n_contexts-1))-1 // beware of 1<<32==0 on IA32
			  variables_and_contexts = collect_variable_and_contexts constraints [] class_context
			  variables = [variable \\ (variable,used_contexts)<-variables_and_contexts | used_contexts==required_used_contexts]		

			  rs_state = add_unexpanded_contexts variables tc_class rs_state
			
John van Groningen's avatar
John van Groningen committed
274
			= ({ rcs_class_context = { rc_class_index = {gi_module=glob_module,gi_index=ds_index}, rc_inst_module = NoIndex, rc_inst_members = {}, rc_types = tc_types, rc_red_contexts = [] },
275
				rcs_constraints_contexts = constraints }, rs_state)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
276

277 278
	reduce_contexts_in_constraints :: !ReduceInfo ![Type] ![TypeVar] ![TypeContext] *ReduceState
		-> *([ClassApplication],*ReduceState)
279
	reduce_contexts_in_constraints info types class_args [] rs_state
280
		= ([],rs_state)
281
	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
282
		# th_vars = fold2St (\ type {tv_info_ptr} -> writePtr tv_info_ptr (TVI_Type type)) types class_args th_vars
283 284
		  (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}
285
		= mapSt (reduce_any_context info) instantiated_context rs_state
Sjaak Smetsers's avatar
Sjaak Smetsers committed
286

287 288 289
	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
290
		| FoundObject left_index
291
			= (left_index, types, uni_ok, type_heaps, coercion_env)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
292 293 294
			# {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
295
				# (subst_context, type_heaps) = fresh_contexts it_context type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
296 297 298
				  (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
299 300 301
					= (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
302 303
	find_instance co_types IT_Empty defs heaps coercion_env
		= (ObjectNotFound, [], True, heaps, coercion_env)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
304 305

	get_specials :: Specials -> [Special]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
306 307 308
	get_specials (SP_ContextTypes specials) = specials
	get_specials SP_None 					= []

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
309
	adjust_type_attributes :: !{#CommonDefs} ![Type] ![Type] !*Coercions !*TypeHeaps -> (Bool, !*Coercions, !*TypeHeaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
310 311 312
	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
313
	adjust_type_attribute :: !{#CommonDefs} !Type !Type !(Bool, !*Coercions, !*TypeHeaps) -> (Bool, !*Coercions, !*TypeHeaps)
314 315
	adjust_type_attribute _ _ (TV _) state
		= state
316
	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
317
		| type_cons1 == type_cons2
318
			= adjust_attributes_and_subtypes defs cons_args1 cons_args2 (ok, coercion_env, type_heaps)
319 320 321 322 323
			= 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
324 325 326 327 328
	adjust_type_attribute defs type1=:(TA type_cons1 cons_args1) type2 (ok, coercion_env, type_heaps)
		# (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)
329 330 331 332 333 334 335 336
	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
337 338 339 340 341
	adjust_type_attribute defs type1=:(TAS type_cons1 cons_args1 _) type2 (ok, coercion_env, type_heaps)
		# (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)
342 343
	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
344 345
	adjust_type_attribute defs (TArrow1 x) (TArrow1 y) state
		= adjust_attributes_and_subtypes defs [x] [y] state
346 347
	adjust_type_attribute defs (_ :@: types1) (_ :@: types2) state
		= adjust_attributes_and_subtypes defs types1 types2 state
348
	adjust_type_attribute defs type1 type2=:(TA type_cons2 cons_args2) (ok, coercion_env, type_heaps)
349 350 351 352
		# (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)
353
	adjust_type_attribute defs type1 type2=:(TAS type_cons2 cons_args2 _) (ok, coercion_env, type_heaps)
354
		# (expanded, type2, type_heaps) = tryToExpandTypeSyn defs type2 type_cons2 cons_args2 type_heaps
355 356 357 358
		| 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
359 360
		= state
	
361 362 363 364
	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)
365

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
366
	adjust_attributes_and_subtypes :: !{#CommonDefs} ![AType] ![AType] !(Bool, !*Coercions, !*TypeHeaps) -> (Bool, !*Coercions, !*TypeHeaps)
367 368 369
	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
370
	adjust_attribute_and_subtypes :: !{#CommonDefs} !AType !AType !(Bool, !*Coercions, !*TypeHeaps) -> (Bool, !*Coercions, !*TypeHeaps)
371 372 373 374
	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
375
		adjust_attribute :: !TypeAttribute !TypeAttribute !(Bool, !*Coercions) -> (Bool, !*Coercions)
376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396
		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)
397

398 399 400
	fresh_contexts :: ![TypeContext] !*TypeHeaps -> ([TypeContext],*TypeHeaps)
	fresh_contexts contexts type_heaps
		= mapSt fresh_context contexts type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
401
	where
402 403
		fresh_context :: !TypeContext !*TypeHeaps -> (TypeContext,*TypeHeaps)
		fresh_context tc=:{tc_types} type_heaps
404 405 406 407
			# (changed_tc_types, tc_types, type_heaps) = substitute tc_types type_heaps
			| changed_tc_types
				= ({tc & tc_types = tc_types}, type_heaps)
				= (tc, type_heaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
408 409

	is_unboxed_array:: [Type] PredefinedSymbols -> Bool
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
410 411 412 413 414
	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

John van Groningen's avatar
John van Groningen committed
415
	check_unboxed_array_type :: Int Int GlobalIndex {#ClassInstanceMember} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
416
		-> (ReducedContext,*SpecialInstances,(*PredefinedSymbols,*TypeHeaps), *ErrorAdmin)
John van Groningen's avatar
John van Groningen committed
417
	check_unboxed_array_type main_dcl_module_n ins_module ins_class_index ins_members types=:[ _, elem_type :_] class_members defs special_instances predef_symbols_type_heaps error
Sjaak Smetsers's avatar
Sjaak Smetsers committed
418
		# (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
419 420 421 422
		| unboxable
			= case opt_record of
				Yes record
					# (ins_members, special_instances) = add_record_to_array_instances record class_members special_instances
John van Groningen's avatar
John van Groningen committed
423
					-> ({ rc_class_index = ins_class_index, 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
424
							special_instances, predef_symbols_type_heaps, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
425
				No
John van Groningen's avatar
John van Groningen committed
426
					-> ({ rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
Sjaak Smetsers's avatar
Sjaak Smetsers committed
427
							special_instances, predef_symbols_type_heaps, error)
John van Groningen's avatar
John van Groningen committed
428
			= ({ rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
429
					special_instances, predef_symbols_type_heaps, unboxError "Array" elem_type error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
430
	where
431
		add_record_to_array_instances :: !TypeSymbIdent !{#DefinedSymbol} !*SpecialInstances -> (!{#ClassInstanceMember},!*SpecialInstances)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
432
		add_record_to_array_instances record members special_instances=:{si_next_array_member_index,si_array_instances}
433
			# may_be_there = look_up_array_or_list_instance record si_array_instances
Sjaak Smetsers's avatar
Sjaak Smetsers committed
434 435 436 437 438 439 440
			= 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 ] })
441

John van Groningen's avatar
John van Groningen committed
442
	check_unboxed_list_type :: Int Int GlobalIndex {#ClassInstanceMember} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
443
		-> (ReducedContext,*SpecialInstances,(*PredefinedSymbols,*TypeHeaps), *ErrorAdmin)
John van Groningen's avatar
John van Groningen committed
444
	check_unboxed_list_type main_dcl_module_n ins_module ins_class_index ins_members types=:[elem_type:_] class_members defs special_instances predef_symbols_type_heaps error
445 446 447 448 449
		# (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
John van Groningen's avatar
John van Groningen committed
450
					-> ({ rc_class_index = ins_class_index, rc_inst_module = main_dcl_module_n, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
451 452
							special_instances, predef_symbols_type_heaps, error)
				No
John van Groningen's avatar
John van Groningen committed
453
					-> ({ rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
454
							special_instances, predef_symbols_type_heaps, error)
John van Groningen's avatar
John van Groningen committed
455
			= ({ rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
456 457
					special_instances, predef_symbols_type_heaps, unboxError "UList" elem_type error)
	where
John van Groningen's avatar
John van Groningen committed
458
		add_record_to_list_instances :: !TypeSymbIdent !{# DefinedSymbol} !*SpecialInstances -> (!{#ClassInstanceMember},!*SpecialInstances)
459 460 461 462 463 464 465 466 467 468
		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 ] })

John van Groningen's avatar
John van Groningen committed
469
	check_unboxed_tail_strict_list_type :: Int Int GlobalIndex {#ClassInstanceMember} ![Type] {#DefinedSymbol} {#CommonDefs} *SpecialInstances *(*PredefinedSymbols,*TypeHeaps) *ErrorAdmin
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
470
		-> (ReducedContext,*SpecialInstances,(*PredefinedSymbols,*TypeHeaps), *ErrorAdmin)
John van Groningen's avatar
John van Groningen committed
471
	check_unboxed_tail_strict_list_type main_dcl_module_n ins_module ins_class_index ins_members types=:[elem_type:_] class_members defs special_instances predef_symbols_type_heaps error
472 473 474 475 476
		# (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
John van Groningen's avatar
John van Groningen committed
477
					-> ({ rc_class_index = ins_class_index, rc_inst_module = main_dcl_module_n, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
478 479
							special_instances, predef_symbols_type_heaps, error)
				No
John van Groningen's avatar
John van Groningen committed
480
					-> ({ rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
481
							special_instances, predef_symbols_type_heaps, error)
John van Groningen's avatar
John van Groningen committed
482
			= ({ rc_class_index = ins_class_index, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types },
483 484
					special_instances, predef_symbols_type_heaps, unboxError "UTSList" elem_type error)
	where
485
		add_record_to_tail_strict_list_instances :: !TypeSymbIdent !{#DefinedSymbol} !*SpecialInstances -> (!{#ClassInstanceMember},!*SpecialInstances)
486 487 488 489 490 491 492 493 494 495
		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
496
	try_to_unbox ::  Type !{#CommonDefs} (!*PredefinedSymbols, !*TypeHeaps) -> (!Bool, !Optional TypeSymbIdent, !(!*PredefinedSymbols, !*TypeHeaps))
497 498 499 500 501 502 503 504 505 506 507 508 509 510
	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}
511
				# (expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args at_type type_heaps
512 513 514 515 516 517
				-> 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)

John van Groningen's avatar
John van Groningen committed
518 519 520 521 522
	is_predefined_global_symbol :: !GlobalIndex !Int !PredefinedSymbols -> Bool
	is_predefined_global_symbol {gi_module,gi_index} predef_index predef_symbols
		# {pds_def,pds_module} = predef_symbols.[predef_index]
		= gi_module == pds_module && gi_index == pds_def

523 524 525 526 527 528 529 530
	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
	
531
	new_array_instance :: !TypeSymbIdent !{#DefinedSymbol} !Index -> ArrayInstance
532
	new_array_instance record members next_member_index
533
		= {	ai_members = { {cim_ident=ds_ident,cim_arity=ds_arity,cim_index=next_inst_index} \\ {ds_ident,ds_arity} <-: members & next_inst_index <- [next_member_index .. ]},
534
			ai_record = record }
535

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
536
	disallow_abstract_types_in_dynamics :: {#CommonDefs} (Global Index) *ErrorAdmin ->  *ErrorAdmin
537
	disallow_abstract_types_in_dynamics defs type_index=:{glob_module,glob_object} error
538 539 540
		| cPredefinedModuleIndex == glob_module
			= error
			
541
		#! ({td_ident,td_rhs})
542 543
			= defs.[glob_module].com_type_defs.[glob_object]
		= case td_rhs of
544 545
				AbstractType _			-> abstractTypeInDynamicError td_ident error
				AbstractSynType _ _		-> abstractTypeInDynamicError td_ident error
546
				_						-> error
547

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
548
	reduce_TC_context :: {#CommonDefs} TCClass Type *ReduceTCState -> (ClassApplication, !*ReduceTCState)
549 550
	reduce_TC_context defs type_code_class tc_type rtcs_state
		= reduce_tc_context defs type_code_class tc_type rtcs_state
551
	where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
552
		reduce_tc_context :: {#CommonDefs} TCClass Type *ReduceTCState -> (ClassApplication, !*ReduceTCState)
553
		reduce_tc_context defs type_code_class type=:(TA cons_id=:{type_index} cons_args) rtcs_state=:{rtcs_error,rtcs_type_heaps}
554
			# rtcs_error = disallow_abstract_types_in_dynamics defs type_index rtcs_error
555 556 557
			# (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}
558
			| expanded
559
				=	reduce_tc_context defs type_code_class type rtcs_state
560
			# type_constructor = toTypeCodeConstructor type_index defs
561 562 563
			  (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
564
			= reduce_tc_context defs type_code_class (TA cons_id cons_args) rtcs_state
565 566 567 568 569
		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)
570 571 572 573 574 575 576 577
		reduce_tc_context defs type_code_class (TempQV 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}
			# tc = { tc_class = type_code_class, tc_types = [TempQV var_number], tc_var = tc_var }
			| containsContext tc rtcs_new_contexts
				= (CA_Context tc, rtcs_state)
				= (CA_Context tc, {rtcs_state & rtcs_new_contexts = [tc : rtcs_new_contexts]})
		reduce_tc_context defs type_code_class (TempQDV var_number) rtcs_state=:{rtcs_type_pattern_vars, rtcs_var_heap}
578 579
			# (inst_var, (rtcs_type_pattern_vars, rtcs_var_heap))
				= addLocalTCInstance var_number (rtcs_type_pattern_vars, rtcs_var_heap)
580 581 582 583 584
			# 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
585
			  tc = { tc_class = type_code_class, tc_types = [TempV var_number], tc_var = tc_var }
586
			| containsContext tc rtcs_new_contexts
587 588 589 590 591 592 593
				= (CA_Context tc, rtcs_state)
				= (CA_Context tc, {rtcs_state & rtcs_new_contexts = [tc : rtcs_new_contexts]})
		reduce_tc_context defs type_code_class type=:(TempCV _ :@: _) 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}
			  tc = { tc_class=type_code_class, tc_types=[type], tc_var=tc_var }
			| containsContext tc rtcs_new_contexts
594 595
				= (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
596

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
597
		reduce_TC_contexts :: {#CommonDefs} TCClass [AType] *ReduceTCState -> ([ClassApplication], !*ReduceTCState)
598 599
		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
600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615

context_is_reducible :: TypeContext PredefinedSymbols -> Bool
context_is_reducible {tc_class=TCClass class_symb,tc_types = [type : types]} predef_symbols
	= type_is_reducible type class_symb predef_symbols && types_are_reducible types type class_symb predef_symbols
context_is_reducible tc=:{tc_class=TCGeneric {gtc_class}, tc_types = [type : types]} predef_symbols
	= type_is_reducible type gtc_class predef_symbols && types_are_reducible types type gtc_class predef_symbols

types_are_reducible :: [Type] Type (Global DefinedSymbol) PredefinedSymbols -> Bool
types_are_reducible [] _ _ _
	= True
types_are_reducible [type : types] first_type tc_class predef_symbols
	= case type of
		TempV _
			->	is_lazy_or_strict_array_or_list_context
		_ :@: _
			->	is_lazy_or_strict_array_or_list_context
616 617 618 619
		TempQV _
			->	is_lazy_or_strict_array_or_list_context
		TempQDV _
			->	is_lazy_or_strict_array_or_list_context
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 659 660 661 662 663 664 665 666 667 668 669 670
		_
			-> is_reducible types tc_class predef_symbols
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 :: Type PredefinedSymbols -> Bool
	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
	is_lazy_or_strict_array_type _ _
		= False

	is_lazy_or_strict_list_type :: Type PredefinedSymbols -> Bool
	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

	is_reducible :: [Type] (Global DefinedSymbol) PredefinedSymbols -> Bool
	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

type_is_reducible :: Type (Global DefinedSymbol) PredefinedSymbols -> Bool
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
	= False
type_is_reducible (TempQV _) tc_class predef_symbols
	= False
type_is_reducible (TempQDV _) {glob_object={ds_index},glob_module} predef_symbols
	= is_predefined_symbol glob_module ds_index PD_TypeCodeClass predef_symbols
type_is_reducible _ tc_class predef_symbols
	= True

is_predefined_symbol :: !Int !Int !Int !PredefinedSymbols -> Bool
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

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
671
addLocalTCInstance :: Int (([LocalTypePatternVariable], *VarHeap)) -> (VarInfoPtr, ([LocalTypePatternVariable], *VarHeap))
Sjaak Smetsers's avatar
Sjaak Smetsers committed
672
addLocalTCInstance var_number (instances=:[inst : insts], ltp_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
673 674
	# cmp = var_number =< inst.ltpv_var
	| cmp == Equal
Sjaak Smetsers's avatar
Sjaak Smetsers committed
675
		= (inst.ltpv_new_var, (instances, ltp_var_heap))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
676 677
	| cmp == Smaller
		# (ltpv_new_var, ltp_var_heap) = newPtr VI_Empty ltp_var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
678 679 680 681
		= (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
682
	# (ltpv_new_var, ltp_var_heap) = newPtr VI_Empty ltp_var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
683
	= (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
684

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
685
tryToExpandTypeSyn :: {#CommonDefs} Type TypeSymbIdent [AType] *TypeHeaps -> (Bool, Type, *TypeHeaps)
686 687
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
688 689
	= case td_rhs of
		SynType {at_type}
690
			# (expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args at_type type_heaps
Sjaak Smetsers's avatar
Sjaak Smetsers committed
691 692
			-> (True, expanded_type, type_heaps) 
		_
693
			-> (False, type, type_heaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
694 695 696 697 698 699 700

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
701
expand_and_match :: TypeSymbIdent [AType] TypeSymbIdent [AType] {#CommonDefs} Type Type *TypeHeaps -> (Bool, *TypeHeaps)
702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720
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
721
instance match Type
722
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
723 724
	match defs (TV {tv_info_ptr}) type type_heaps=:{th_vars}
		= (True, { type_heaps & th_vars = th_vars <:= (tv_info_ptr,TVI_Type type)})
725
	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
726 727
		| cons_id1 == cons_id2
			= match defs cons_args1 cons_args2 type_heaps
728 729 730 731 732 733 734 735 736 737 738 739 740
			= 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
741 742 743 744 745 746 747 748 749
	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)
750 751 752 753 754
	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)
755 756
	match defs (TB tb1) (TB tb2) type_heaps
		= (tb1 == tb2, type_heaps)
757 758 759 760
	match defs TArrow TArrow type_heaps
		= (True, type_heaps)
	match defs (TArrow1 t1) (TArrow1 t2) type_heaps
		= match defs t1 t2 type_heaps
761 762
	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
763 764 765
		| succ
			= match defs type1 type2 type_heaps
			= (False, type_heaps)
766 767 768 769 770 771 772 773 774 775 776 777
	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
778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807
		| 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
808 809
consVariableToType (TempQCDV temp_var_id)
	= TempQDV temp_var_id
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
810

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
811
trySpecializedInstances :: [TypeContext] [Special] *TypeHeaps -> (!Global Index,!*TypeHeaps)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
812 813 814 815 816 817
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
818
	try_specialized_instances :: [[Type]] [Special] *TypeVarHeap -> (!Global Index,!*TypeVarHeap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
819 820
	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
821
		  (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
822 823 824 825 826 827
		| 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)

828 829 830