comparedefimp.icl 41.7 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
implementation module comparedefimp

/*	compare definition and implementation module

	Difficulty: The icl module's type definitions have been tranformed during checking while
	the dcl module's type definitions have not. When the root of the rhs of a (icl) type definition was
	originally an application of a synonym type then this type will have been expanded. The comparision
	algorithm performs expansion of _dcl_ synonym types 'on the fly' by binding lhs argument type variables
	to the types of the actual type application. e.g.
		
		dcl:						icl:
		
		:: T1 :== T2 Int			:: T1 :== Int  // previously expanded, was originally :: T1 :== T2 Int
		:: T2 x :== x				:: T2 y :== y
	
	causes x to be bound to Int while processing type T1.
	
	While T2 is processed x and y will be bound to a correspondence number to abstract from variable names
	(see type HeapWithNumber). The same happens with attribute variables and variables in macros/functions.
*/

22
import syntax, checksupport, compare_constructor, utilities, StdCompare
23
24
25
26
27
28
29
30
31
32
33
34
35
36

:: TypesCorrespondState =
		{	tc_type_vars
				:: !.HeapWithNumber TypeVarInfo
		,	tc_attr_vars
				:: !.HeapWithNumber AttrVarInfo
		,	tc_dcl_modules
				:: !.{#DclModule}
		,	tc_icl_type_defs
				:: !{CheckedTypeDef}
		,	tc_type_conversions
				:: !Conversions
		, 	tc_visited_syn_types	// to detect cycles in type synonyms
				:: !.{#Bool}
37
38
		,	tc_main_dcl_module_n
				:: !Int
39
40
41
		}

:: TypesCorrespondMonad
42
		:==	!*TypesCorrespondState -> *(!Bool, !*TypesCorrespondState)
43
44
45
46
47
48
49
50
51
52
53
54
55
56

:: ExpressionsCorrespondState =
		{	ec_correspondences	// ec_correspondences.[i]==j <=> (functions i and j are already compared 
				::	!.{# Int }	//									|| j==cNoCorrespondence)
		,	ec_var_heap
				::	!.HeapWithNumber VarInfo
		,	ec_expr_heap
				::	!.ExpressionHeap
		,	ec_icl_functions
				::	!.{# FunDef }
		,	ec_error_admin
				::	!.ErrorAdmin
		,	ec_tc_state
				::	!.TypesCorrespondState
57
		,	ec_untransformed
Martin Wierich's avatar
bugfix    
Martin Wierich committed
58
				::	!{! FunctionBody }
59
60
		,	ec_function_conversions
				::	!Conversions
61
62
63
64
65
66
67
68
69
70
71
72
73
74
		}
		
:: ExpressionsCorrespondMonad
		:== !*ExpressionsCorrespondState -> *ExpressionsCorrespondState

:: Conversions :== {#Index}

:: HeapWithNumber a
	=	{	hwn_heap
				::	!.Heap a
		,	hwn_number
				::	!Int
		}

Martin Wierich's avatar
Martin Wierich committed
75
76
77
:: OptionalCorrespondenceNumber = CorrespondenceNumber !Int | Bound | Unbound

class t_corresponds a :: !a !a -> *TypesCorrespondMonad
78
79
80
81
82
83
84
	// whether two types correspond
class e_corresponds a :: !a !a -> ExpressionsCorrespondMonad
	// check for correspondence of expressions

class getIdentPos a :: a -> IdentPos

class CorrespondenceNumber a where
Martin Wierich's avatar
Martin Wierich committed
85
	toCorrespondenceNumber :: .a -> OptionalCorrespondenceNumber
86
87
88
89
	fromCorrespondenceNumber :: Int -> .a

initial_hwn hwn_heap = { hwn_heap = hwn_heap, hwn_number = 0 }

90
compareDefImp :: !{#Int} !{!FunctionBody} !Int !*{# DclModule} !*IclModule !*Heaps !*ErrorAdmin 
Martin Wierich's avatar
Martin Wierich committed
91
				-> (!.{# DclModule}, !.IclModule,!.Heaps,!.ErrorAdmin)
92
compareDefImp size_uncopied_icl_defs untransformed main_dcl_module_n dcl_modules icl_module heaps error_admin
93
94
	// icl definitions with indices >= size_uncopied_icl_defs.[def_type] don't have to be compared,
	// because they are copies of definitions that appear exclusively in the dcl module
95
96
//	# (main_dcl_module, dcl_modules) = dcl_modules![cIclModIndex]
	# (main_dcl_module, dcl_modules) = dcl_modules![main_dcl_module_n]
97
98
99
100
101
102
103
104
105
106
107
108
	= case main_dcl_module.dcl_conversions of
		No	-> (dcl_modules, icl_module, heaps, error_admin)
		Yes conversion_table
			# {dcl_functions, dcl_macros, dcl_common, dcl_instances} = main_dcl_module
			  {icl_common, icl_functions}
					= icl_module
			  {hp_var_heap, hp_expression_heap, hp_type_heaps={th_vars, th_attrs}}
			  		= heaps
			  { com_type_defs=icl_com_type_defs, com_cons_defs=icl_com_cons_defs,
				com_selector_defs=icl_com_selector_defs, com_class_defs=icl_com_class_defs,
				com_member_defs=icl_com_member_defs, com_instance_defs = icl_com_instance_defs }
					= icl_common
109
			  (icl_type_defs, icl_com_type_defs) = memcpy icl_com_type_defs
110
111
112
113
114
115
116
			  tc_state
			  		=	{ tc_type_vars = initial_hwn th_vars
						, tc_attr_vars = initial_hwn th_attrs
						, tc_dcl_modules = dcl_modules
						, tc_icl_type_defs = icl_type_defs
						, tc_type_conversions = conversion_table.[cTypeDefs]
						, tc_visited_syn_types = createArray (size dcl_common.com_type_defs) False
117
						, tc_main_dcl_module_n = main_dcl_module_n
118
119
						}
			  (icl_com_type_defs, tc_state, error_admin)
120
121
					= compareWithConversions 
						size_uncopied_icl_defs.[cTypeDefs] conversion_table.[cTypeDefs]
122
123
						dcl_common.com_type_defs icl_com_type_defs tc_state error_admin
			  (icl_com_cons_defs, tc_state, error_admin)
124
125
					= compareWithConversions 
						size_uncopied_icl_defs.[cConstructorDefs] conversion_table.[cConstructorDefs]
126
127
						dcl_common.com_cons_defs icl_com_cons_defs tc_state error_admin
			  (icl_com_selector_defs, tc_state, error_admin)
128
129
					= compareWithConversions
						size_uncopied_icl_defs.[cSelectorDefs] conversion_table.[cSelectorDefs]
130
131
						dcl_common.com_selector_defs icl_com_selector_defs tc_state error_admin
			  (icl_com_class_defs, tc_state, error_admin)
132
133
					= compareWithConversions
						size_uncopied_icl_defs.[cClassDefs] conversion_table.[cClassDefs]
134
						dcl_common.com_class_defs icl_com_class_defs tc_state error_admin
Martin Wierich's avatar
Martin Wierich committed
135
			  (icl_com_member_defs, tc_state, error_admin)
136
137
					= compareWithConversions
						size_uncopied_icl_defs.[cMemberDefs] conversion_table.[cMemberDefs]
Martin Wierich's avatar
Martin Wierich committed
138
						dcl_common.com_member_defs icl_com_member_defs tc_state error_admin
139
			  (icl_com_instance_defs, tc_state, error_admin)
140
141
					= compareWithConversions
						size_uncopied_icl_defs.[cInstanceDefs] conversion_table.[cInstanceDefs]
142
143
						dcl_common.com_instance_defs icl_com_instance_defs tc_state error_admin
			  (icl_functions, hp_var_heap, hp_expression_heap, tc_state, error_admin)
144
145
					= compareMacrosWithConversion conversion_table.[cMacroDefs] conversion_table.[cFunctionDefs]
												 dcl_macros untransformed
146
147
148
149
150
151
152
153
154
155
156
157
158
159
								 				 icl_functions hp_var_heap hp_expression_heap tc_state error_admin
			  (icl_functions, tc_state, error_admin)
			  		= compareFunctionTypesWithConversions conversion_table.[cFunctionDefs]
			  			dcl_functions icl_functions tc_state error_admin
			  { tc_type_vars, tc_attr_vars, tc_dcl_modules }
			  		= tc_state
			  icl_common
			  		= { icl_common & com_type_defs=icl_com_type_defs, com_cons_defs=icl_com_cons_defs,
			  			com_selector_defs=icl_com_selector_defs, com_class_defs=icl_com_class_defs,
			  			com_member_defs=icl_com_member_defs, com_instance_defs = icl_com_instance_defs }
			  heaps
			  		= { hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap,
			  			hp_type_heaps = { th_vars = tc_type_vars.hwn_heap, th_attrs = tc_attr_vars.hwn_heap}}
			-> ( tc_dcl_modules, { icl_module & icl_common = icl_common, icl_functions = icl_functions },
Martin Wierich's avatar
Martin Wierich committed
160
					heaps, error_admin )
161
  where
162
163
	memcpy :: !*{#CheckedTypeDef} -> (!.{CheckedTypeDef}, !.{#CheckedTypeDef})
	memcpy original
164
165
		#! size = size original
		# new = createArray size (abort "don't make that array strict !")
166
		= iFoldSt (\i (dst, src=:{[i]=src_i}) -> ({ dst & [i] = src_i }, src)) 0 size (new, original)
167

168
169
170
compareWithConversions size_uncopied_icl_defs conversions dclDefs iclDefs tc_state error_admin 
	= iFoldSt (compareWithConversion size_uncopied_icl_defs conversions dclDefs) 0 (size conversions)
			(iclDefs, tc_state, error_admin)
171

172
compareWithConversion :: !Int !{#Int} !(b c) !Int !(!u:(b c), !*TypesCorrespondState, !*ErrorAdmin)
173
174
175
176
177
178
179
						-> (!v:(b c), !.TypesCorrespondState, !.ErrorAdmin)
//1.3
						| Array .b & getIdentPos , select_u , t_corresponds , uselect_u c, [u <= v]
//3.1
/*2.0
						| Array b c & t_corresponds, getIdentPos c, [u <= v]
0.2*/
180
181
182
183
184
compareWithConversion size_uncopied_icl_defs conversions dclDefs dclIndex (iclDefs, tc_state, error_admin)
	# icl_index = conversions.[dclIndex]
	| icl_index>=size_uncopied_icl_defs
		= (iclDefs, tc_state, error_admin)
	# (iclDef, iclDefs) = iclDefs![icl_index]
185
186
187
188
189
190
191
192
193
	  (corresponds, tc_state) = t_corresponds dclDefs.[dclIndex] iclDef tc_state
	| corresponds
		= (iclDefs, tc_state, error_admin)
	= generate_error error_message iclDef iclDefs tc_state error_admin

compareFunctionTypesWithConversions conversions	dcl_fun_types icl_functions tc_state error_admin
	= iFoldSt (compareTwoFunctionTypes conversions dcl_fun_types) 0 (size conversions)
				(icl_functions, tc_state, error_admin)

194
195
compareTwoFunctionTypes :: !{#Int} !{#FunType} !Int !*(!u:{#FunDef},!*TypesCorrespondState,!*ErrorAdmin) 
						-> (!v:{#FunDef},!.TypesCorrespondState,!.ErrorAdmin) , [u <= v]
196
197
198
199
200
201
202
203
compareTwoFunctionTypes conversions	dcl_fun_types dclIndex (icl_functions, tc_state, error_admin)
	# (fun_def=:{fun_type}, icl_functions) = icl_functions![conversions.[dclIndex]]
	= case fun_type of
		No	-> generate_error "type of exported function is missing" fun_def icl_functions tc_state error_admin
		Yes icl_symbol_type
			# dcl_symbol_type = dcl_fun_types.[dclIndex].ft_type
			  tc_state = init_attr_vars (dcl_symbol_type.st_attr_vars++icl_symbol_type.st_attr_vars)
			  							tc_state
Martin Wierich's avatar
Martin Wierich committed
204
			  tc_state = init_type_vars (dcl_symbol_type.st_vars++icl_symbol_type.st_vars) tc_state
205
			  (corresponds, tc_state)
Martin Wierich's avatar
bugfix    
Martin Wierich committed
206
					= t_corresponds dcl_symbol_type icl_symbol_type tc_state // --->("comparing:", dcl_symbol_type ,icl_symbol_type)
207
208
209
210
			| corresponds
				-> (icl_functions, tc_state, error_admin)
			-> generate_error error_message fun_def icl_functions tc_state error_admin

Martin Wierich's avatar
Martin Wierich committed
211
212
213
214
215
216
217
218
219
init_type_vars type_vars tc_state=:{tc_type_vars}
	# tc_type_vars = init_type_vars` type_vars tc_type_vars
	= { tc_state & tc_type_vars = tc_type_vars }
  where
	init_type_vars` type_vars tc_type_vars=:{hwn_heap}
		# hwn_heap = foldSt init_type_var type_vars hwn_heap
		= { tc_type_vars & hwn_heap = hwn_heap }
	init_type_var {tv_info_ptr} heap
		= writePtr tv_info_ptr TVI_Empty heap
220
221
222
223
224
225
226
	
generate_error message iclDef iclDefs tc_state error_admin
	# ident_pos = getIdentPos iclDef
	  error_admin = pushErrorAdmin ident_pos error_admin
	  error_admin = checkError ident_pos.ip_ident message error_admin
	= (iclDefs, tc_state, popErrorAdmin error_admin)

227
compareMacrosWithConversion conversions function_conversions macro_range untransformed icl_functions var_heap expr_heap tc_state error_admin
228
229
230
231
	#! nr_of_functions = size icl_functions
	# correspondences = createArray nr_of_functions cNoCorrespondence
	  ec_state = { ec_correspondences = correspondences, ec_var_heap = initial_hwn var_heap, 
	  				ec_expr_heap = expr_heap, ec_icl_functions = icl_functions,
232
	  				ec_error_admin = error_admin, ec_tc_state = tc_state,
233
234
	  				ec_untransformed = untransformed,
	  				ec_function_conversions = function_conversions }
235
236
237
238
239
240
241
242
	  ec_state = iFoldSt (compareMacroWithConversion conversions macro_range.ir_from) macro_range.ir_from macro_range.ir_to
	  						ec_state
	  {ec_icl_functions, ec_var_heap, ec_expr_heap, ec_error_admin, ec_tc_state} = ec_state
	= (ec_icl_functions, ec_var_heap.hwn_heap, ec_expr_heap, ec_tc_state, ec_error_admin)
	
compareMacroWithConversion conversions ir_from dclIndex ec_state
	= compareTwoMacroFuns dclIndex conversions.[dclIndex-ir_from] ec_state

Martin Wierich's avatar
Martin Wierich committed
243
compareTwoMacroFuns :: !.Int !.Int !*ExpressionsCorrespondState -> .ExpressionsCorrespondState;
244
compareTwoMacroFuns dclIndex iclIndex
245
246
247
					ec_state=:{ec_correspondences, ec_icl_functions, ec_untransformed}
	| dclIndex==iclIndex
		= ec_state
248
249
250
	# (dcl_function, ec_icl_functions) = ec_icl_functions![dclIndex]
	  (icl_function, ec_icl_functions) = ec_icl_functions![iclIndex]
	  ec_correspondences = { ec_correspondences & [dclIndex]=iclIndex, [iclIndex]=dclIndex }
251
252
253
254
255
256
257
258
259
	  ec_state = { ec_state & ec_correspondences = ec_correspondences, ec_icl_functions = ec_icl_functions }
	  need_to_be_compared
	  		= case (dcl_function.fun_body, icl_function.fun_body) of
	  			(TransformedBody _, CheckedBody _)
					// the macro definition in the icl module is not used, so we don't need to compare
	  				-> False
	  			_	-> True
	| not need_to_be_compared
		= ec_state
Martin Wierich's avatar
bugfix    
Martin Wierich committed
260
	# adjusted_icl_body
261
262
263
264
	  		= case (dcl_function.fun_body, icl_function.fun_body) of
	  			(CheckedBody _, TransformedBody _)
					// the macro definition in the icl module is has been transformed but not the dcl
					// module's definition: use the untransformed icl original for comparision
Martin Wierich's avatar
bugfix    
Martin Wierich committed
265
266
	  				-> ec_untransformed.[iclIndex]
	  			_	-> icl_function.fun_body
267
	  ident_pos = getIdentPos dcl_function
268
	  ec_error_admin = pushErrorAdmin ident_pos ec_state.ec_error_admin
Martin Wierich's avatar
bugfix    
Martin Wierich committed
269
	  ec_state = e_corresponds dcl_function.fun_body adjusted_icl_body { ec_state & ec_error_admin = ec_error_admin }
270
271
272
273
	= { ec_state & ec_error_admin = popErrorAdmin ec_state.ec_error_admin }

instance getIdentPos (TypeDef a) where
	getIdentPos {td_name, td_pos}
Martin Wierich's avatar
Martin Wierich committed
274
		= newPosition td_name td_pos
275
276
277

instance getIdentPos ConsDef where
	getIdentPos {cons_symb, cons_pos}
Martin Wierich's avatar
Martin Wierich committed
278
		= newPosition cons_symb cons_pos
279
280
281

instance getIdentPos SelectorDef where
	getIdentPos {sd_symb, sd_pos}
Martin Wierich's avatar
Martin Wierich committed
282
		= newPosition sd_symb sd_pos
283
284
285

instance getIdentPos ClassDef where
	getIdentPos {class_name, class_pos}
Martin Wierich's avatar
Martin Wierich committed
286
		= newPosition class_name class_pos
287
288
289

instance getIdentPos MemberDef where
	getIdentPos {me_symb, me_pos}
Martin Wierich's avatar
Martin Wierich committed
290
		= newPosition me_symb me_pos
291
292
293

instance getIdentPos ClassInstance where
	getIdentPos {ins_ident, ins_pos}
Martin Wierich's avatar
Martin Wierich committed
294
		= newPosition ins_ident ins_pos
295
296
297

instance getIdentPos FunDef where
	getIdentPos {fun_symb, fun_pos}
Martin Wierich's avatar
Martin Wierich committed
298
299
		= newPosition fun_symb fun_pos

300
301
instance CorrespondenceNumber VarInfo where
	toCorrespondenceNumber (VI_CorrespondenceNumber number)
Martin Wierich's avatar
Martin Wierich committed
302
		=	CorrespondenceNumber number
303
304
305
	toCorrespondenceNumber _
		// VarInfoPtrs are not initialized in this module. This doesnt harm because VI_CorrespondenceNumber should
		// not be used outside this module 
Martin Wierich's avatar
Martin Wierich committed
306
307
		=	Unbound
		
308
309
310
311
312
	fromCorrespondenceNumber number
		=	VI_CorrespondenceNumber number

instance CorrespondenceNumber TypeVarInfo where
	toCorrespondenceNumber (TVI_CorrespondenceNumber number)
Martin Wierich's avatar
Martin Wierich committed
313
314
315
316
317
		=	CorrespondenceNumber number
	toCorrespondenceNumber TVI_Empty
		=	Unbound
	toCorrespondenceNumber (TVI_AType _)
		=	Bound
318
319
320
321
322
323

	fromCorrespondenceNumber number
		=	TVI_CorrespondenceNumber number

instance CorrespondenceNumber AttrVarInfo where
	toCorrespondenceNumber (AVI_CorrespondenceNumber number)
Martin Wierich's avatar
Martin Wierich committed
324
325
326
		=	CorrespondenceNumber number
	toCorrespondenceNumber AVI_Empty
		=	Unbound
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342

	fromCorrespondenceNumber number
		=	AVI_CorrespondenceNumber number

assignCorrespondenceNumber ptr1 ptr2 {hwn_heap, hwn_number}
	=	let var_info = fromCorrespondenceNumber hwn_number
		in	{	hwn_heap
					=	writePtr ptr1 var_info (writePtr ptr2 var_info hwn_heap)
			,	hwn_number
					=	hwn_number + 1
			}

tryToUnifyVars ptr1 ptr2 heapWithNumber
	#! info1 = sreadPtr ptr1 heapWithNumber.hwn_heap
	   info2 = sreadPtr ptr2 heapWithNumber.hwn_heap
	=	case (toCorrespondenceNumber info1, toCorrespondenceNumber info2) of
Martin Wierich's avatar
Martin Wierich committed
343
			(CorrespondenceNumber number1, CorrespondenceNumber number2)
344
				->	(number1==number2, heapWithNumber)
Martin Wierich's avatar
Martin Wierich committed
345
			(Unbound, Unbound)
346
347
348
349
350
351
352
353
354
355
356
357
 				->	(True, assignCorrespondenceNumber ptr1 ptr2 heapWithNumber)
			_	->	(False, heapWithNumber)

instance t_corresponds [a] | t_corresponds a where 
	t_corresponds [] []
		=	return True
	t_corresponds [dclDef:dclDefs] [iclDef:iclDefs]
		=	t_corresponds dclDef iclDef
		&&&	t_corresponds dclDefs iclDefs
	t_corresponds _ _
		=	return False

358

359
360
361
362
/*2.0
instance t_corresponds {# a} | t_corresponds a & Array {#} a
0.2*/
//1.3
363
instance t_corresponds {# a} | ArrayElem , t_corresponds a
364
//3.1
365
where 
366
367
368
369
	t_corresponds dclArray iclArray
		# size_dclArray = size dclArray
		| size_dclArray<>size iclArray
			= return False
370
			= loop (size_dclArray-1) dclArray iclArray
371
	  where
372
373
374
375
376
377
/*2.0
		loop :: !Int !{# a} !{# a} -> *TypesCorrespondMonad | t_corresponds a & Array {#} a // 2.0
0.2*/
//1.3
		loop :: !Int !{# a} !{# a} -> *TypesCorrespondMonad | t_corresponds, select_u a
//3.1
378
379
380
		loop i dclArray iclArray
			| i<0
				= return True
381
				= t_corresponds dclArray.[i] iclArray.[i]
382
383
			&&& loop (i-1) dclArray iclArray
		
384

385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
instance t_corresponds (Optional a) | t_corresponds a where 
	t_corresponds No No
		= return True
	t_corresponds (Yes dclYes) (Yes iclYes)
		= t_corresponds dclYes iclYes
	t_corresponds _ _
		= return False

instance t_corresponds (Global DefinedSymbol) where
	t_corresponds dclDef iclDef
		=	t_corresponds dclDef.glob_object iclDef.glob_object
		&&&	equal dclDef.glob_module iclDef.glob_module

instance t_corresponds (TypeDef TypeRhs) where
	t_corresponds dclDef iclDef
		= t_corresponds_TypeDef dclDef iclDef
	  where
		t_corresponds_TypeDef dclDef iclDef tc_state
Martin Wierich's avatar
bugfix    
Martin Wierich committed
403
404
//			| False--->("comparing:", dclDef, iclDef)
//				= undef
405
			# tc_state = { tc_state & tc_visited_syn_types.[dclDef.td_index] = True }
Martin Wierich's avatar
Martin Wierich committed
406
407
408
409
			  tc_state = init_attr_vars dclDef.td_attrs tc_state 
			  tc_state = init_attr_vars iclDef.td_attrs tc_state 
			  tc_state = init_atype_vars dclDef.td_args tc_state
			  tc_state = init_atype_vars iclDef.td_args tc_state
410
411
412
			  (corresponds, tc_state) = t_corresponds dclDef.td_args iclDef.td_args tc_state
			| not corresponds
				= (corresponds, tc_state)
Martin Wierich's avatar
Martin Wierich committed
413
			# icl_root_has_anonymous_attr = root_has_anonymous_attr iclDef.td_attribute iclDef.td_rhs
414
415
416
417
418
419
420
421
422
423
424
			| icl_root_has_anonymous_attr<>root_has_anonymous_attr dclDef.td_attribute dclDef.td_rhs
			  && isnt_abstract dclDef.td_rhs
				= (False, tc_state)
			# coerced_icl_rhs = if icl_root_has_anonymous_attr (coerce iclDef.td_rhs) iclDef.td_rhs
			  (corresponds, tc_state) = t_corresponds dclDef.td_rhs coerced_icl_rhs tc_state
			  tc_state = { tc_state & tc_visited_syn_types.[dclDef.td_index] = False }
			| not corresponds
				= (corresponds, tc_state)
			# (corresponds, tc_state) = t_corresponds dclDef.td_context iclDef.td_context tc_state
			| not corresponds
				= (corresponds, tc_state)
Martin Wierich's avatar
bugfix    
Martin Wierich committed
425
426
			# attributes_correspond = (is_TA_Unique dclDef.td_attribute)==(is_TA_Unique iclDef.td_attribute)
			= (attributes_correspond, tc_state)
427
428
429
430
431
432
433
434
435
436
437
438

		root_has_anonymous_attr (TA_Var lhs_attr_var) syn_type=:(SynType a_type=:{at_attribute=TA_Var rhs_attr_var})
			= rhs_attr_var.av_info_ptr==lhs_attr_var.av_info_ptr
		root_has_anonymous_attr _ _
			= False
		
		coerce (SynType atype)
			= SynType { atype & at_attribute = TA_Anonymous }
		
		isnt_abstract (AbstractType _) = False
		isnt_abstract _ = True
		
Martin Wierich's avatar
bugfix    
Martin Wierich committed
439
440
441
		is_TA_Unique TA_Unique = True
		is_TA_Unique _ = False
		
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
instance t_corresponds TypeContext where
	t_corresponds dclDef iclDef
		=	t_corresponds dclDef.tc_class iclDef.tc_class
		&&& t_corresponds dclDef.tc_types iclDef.tc_types

instance t_corresponds DefinedSymbol where
	t_corresponds dclDef iclDef
		=	equal dclDef.ds_ident iclDef.ds_ident

instance t_corresponds ATypeVar where
	t_corresponds dclDef iclDef
		=	t_corresponds dclDef.atv_attribute iclDef.atv_attribute
		&&&	equal dclDef.atv_annotation iclDef.atv_annotation
		&&&	t_corresponds dclDef.atv_variable iclDef.atv_variable

instance t_corresponds AType where
	t_corresponds dclDef iclDef
		= t_corresponds_at_type dclDef iclDef
	  where
		t_corresponds_at_type dclDef iclDef tc_state
Martin Wierich's avatar
Martin Wierich committed
462
463
			| dclDef.at_annotation<>iclDef.at_annotation
				= (False, tc_state)
464
465
466
467
468
469
470
471
472
473
			# (corresponds, tc_state) = simple_corresponds dclDef iclDef tc_state
			| corresponds
				= (corresponds, tc_state)
			= case dclDef.at_type of
				TA dcl_type_symb dcl_args
					-> corresponds_with_expanded_syn_type dcl_type_symb.type_index dcl_args iclDef tc_state
				TV {tv_info_ptr}
					#! x = sreadPtr tv_info_ptr tc_state.tc_type_vars.hwn_heap
					-> case x of
						TVI_AType dcl_atype
Martin Wierich's avatar
Martin Wierich committed
474
							-> t_corresponds { dcl_atype & at_annotation = dclDef.at_annotation } iclDef tc_state
475
476
477
478
479
480
481
482
483
						_	-> (False, tc_state)
				_	-> (False, tc_state)
		  where
			simple_corresponds dclDef iclDef
				=	t_corresponds dclDef.at_attribute iclDef.at_attribute
				&&&	t_corresponds dclDef.at_type iclDef.at_type

			corresponds_with_expanded_syn_type {glob_module, glob_object} dclArgs icl_atype
												tc_state
484
485
//				# is_defined_in_main_dcl = glob_module==cIclModIndex
				# is_defined_in_main_dcl = glob_module==tc_state.tc_main_dcl_module_n
486
487
488
489
490
				| is_defined_in_main_dcl && tc_state.tc_visited_syn_types.[glob_object]
					= (False, tc_state) // cycle in synonym types in main dcl
				# ({dcl_common}, tc_state) = tc_state!tc_dcl_modules.[glob_module]
				  type_def = dcl_common.com_type_defs.[glob_object]
				= case type_def.td_rhs of
Martin Wierich's avatar
Martin Wierich committed
491
492
493
494
495
496
					SynType {at_type=TV type_var, at_attribute}
						// a "projection" type. attributes are treated in a special way
						# arg_pos = get_arg_pos type_var type_def.td_args 0
						  dcl_arg = dclArgs!!arg_pos
						  coerced_dcl_arg = { dcl_arg & at_attribute = determine_type_attribute type_def.td_attribute }
						-> t_corresponds coerced_dcl_arg icl_atype tc_state
497
498
499
500
501
502
503
					SynType atype
						# tc_state = { tc_state & tc_type_vars
						  							= bind_type_vars type_def.td_args dclArgs tc_state.tc_type_vars }
						  tc_state = init_attr_vars type_def.td_attrs tc_state
						  tc_state = opt_set_visited_bit is_defined_in_main_dcl glob_object True tc_state
						  atype = { atype & at_attribute = determine_type_attribute type_def.td_attribute }
						  (corresponds, tc_state) = t_corresponds atype icl_atype tc_state
Martin Wierich's avatar
Martin Wierich committed
504
						  tc_state = opt_set_visited_bit is_defined_in_main_dcl glob_object False tc_state
505
506
						-> (corresponds, tc_state) 
					AbstractType _
Martin Wierich's avatar
bugfix    
Martin Wierich committed
507
508
						| not is_defined_in_main_dcl
							-> (False, tc_state)
509
510
511
512
513
514
						#! icl_type_def = tc_state.tc_icl_type_defs.[tc_state.tc_type_conversions.[glob_object]]
						# tc_state = { tc_state & tc_type_vars
				  							= bind_type_vars icl_type_def.td_args dclArgs tc_state.tc_type_vars }
						  tc_state = init_attr_vars icl_type_def.td_attrs tc_state
						-> case icl_type_def.td_rhs of
							SynType atype
Martin Wierich's avatar
Martin Wierich committed
515
								# atype = { atype & at_attribute = determine_type_attribute type_def.td_attribute }
516
517
518
519
								-> t_corresponds atype icl_atype tc_state
							_	-> (False, tc_state)
					_	-> (False, tc_state)
			  where
Martin Wierich's avatar
Martin Wierich committed
520

521
				bind_type_vars formal_args actual_args tc_type_vars
Martin Wierich's avatar
Martin Wierich committed
522
					# hwn_heap = bind_type_vars` formal_args actual_args tc_type_vars.hwn_heap
523
524
525
					= { tc_type_vars & hwn_heap = hwn_heap }
			
				bind_type_vars` [{atv_variable}:formal_args] [actual_arg:actual_args] type_var_heap
Martin Wierich's avatar
Martin Wierich committed
526
					# (actual_arg, type_var_heap) = possibly_dereference actual_arg type_var_heap
527
528
					= bind_type_vars` formal_args actual_args
							(writePtr atv_variable.tv_info_ptr (TVI_AType actual_arg) type_var_heap)
529
							//	--->("binding", atv_variable.tv_name,"to",actual_arg)
530
				bind_type_vars` _ _ type_var_heap
Martin Wierich's avatar
Martin Wierich committed
531
532
533
534
535
536
537
538
539
540
					= type_var_heap
				
				possibly_dereference atype=:{at_type=TV {tv_info_ptr}} type_var_heap
					#! dereferenced = sreadPtr tv_info_ptr type_var_heap
					= case dereferenced of
						TVI_AType atype2
							-> (atype2, type_var_heap)
						_	-> (atype, type_var_heap)
				possibly_dereference atype type_var_heap
					= (atype, type_var_heap)
541
542
543
544
545
546
547
548
			
				opt_set_visited_bit True glob_object bit tc_state
					= { tc_state & tc_visited_syn_types.[glob_object] = bit }
				opt_set_visited_bit False _ _ tc_state
					= tc_state

				determine_type_attribute TA_Unique	= TA_Unique
				determine_type_attribute _			= TA_Multi
Martin Wierich's avatar
Martin Wierich committed
549
550
551
552
				
				get_arg_pos x [h:t] count
					| x==h.atv_variable	= count
										= get_arg_pos x t (inc count)
553
554
555
556
557
558
559
560

instance t_corresponds TypeAttribute where
	t_corresponds TA_Unique TA_Unique
		=	return True
	t_corresponds TA_Multi TA_Multi
		=	return True
	t_corresponds (TA_Var dclDef) (TA_Var iclDef)
		=	t_corresponds dclDef iclDef
Martin Wierich's avatar
Martin Wierich committed
561
	t_corresponds (TA_RootVar dclDef) (TA_RootVar iclDef)
562
		= PA_BUG (return True) (t_corresponds dclDef iclDef)
Martin Wierich's avatar
Martin Wierich committed
563
	t_corresponds _ TA_Anonymous
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
		=	return True
	t_corresponds TA_None icl
		= case icl of
			TA_Multi-> return True
			TA_None	-> return True
			_		-> return False
	t_corresponds TA_Multi icl
		= case icl of
			TA_Multi-> return True
			TA_None	-> return True
			_		-> return False
	t_corresponds _ _
		=	return False

instance t_corresponds AttributeVar where
	t_corresponds dclDef iclDef
		=	corresponds` dclDef iclDef
	  where
		corresponds` dclDef iclDef tc_state=:{tc_attr_vars}
			# (unifiable, tc_attr_vars) = tryToUnifyVars dclDef.av_info_ptr iclDef.av_info_ptr tc_attr_vars
			= (unifiable, { tc_state & tc_attr_vars = tc_attr_vars })

instance t_corresponds Type where
	t_corresponds (TA dclIdent dclArgs) icl_type=:(TA iclIdent iclArgs)
		=	equal dclIdent.type_name iclIdent.type_name
		&&& equal dclIdent.type_index.glob_module iclIdent.type_index.glob_module
		&&& t_corresponds dclArgs iclArgs
	t_corresponds (dclFun --> dclArg) (iclFun --> iclArg)
		=	t_corresponds dclFun iclFun
		&&&	t_corresponds dclArg iclArg
	t_corresponds (dclVar :@: dclArgs) (iclVar :@: iclArgs)
		=	t_corresponds dclVar iclVar
		&&&	t_corresponds dclArgs iclArgs
	t_corresponds (TB dclDef) (TB iclDef)
		=	equal dclDef iclDef
	t_corresponds (TV dclDef) (TV iclDef)
		=	t_corresponds dclDef iclDef
	t_corresponds (GTV dclDef) (GTV iclDef)
		=	t_corresponds dclDef iclDef
603
604
	t_corresponds _ _
		= return False
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
		
instance t_corresponds ConsVariable where
	t_corresponds (CV dclVar) (CV iclVar)
		=	t_corresponds dclVar iclVar
		
instance t_corresponds TypeVar where
	t_corresponds dclDef iclDef
		=	corresponds_TypeVar dclDef iclDef
	  where
		corresponds_TypeVar dclDef iclDef tc_state=:{tc_type_vars}
			# (unifiable, tc_type_vars) = tryToUnifyVars dclDef.tv_info_ptr iclDef.tv_info_ptr tc_type_vars
			= (unifiable, { tc_state & tc_type_vars = tc_type_vars })

instance t_corresponds TypeRhs where
	t_corresponds (AlgType dclConstructors) (AlgType iclConstructors)
		=	t_corresponds dclConstructors iclConstructors
	t_corresponds (SynType dclType) (SynType iclType)
		=	t_corresponds dclType iclType
	t_corresponds (RecordType dclRecord) (RecordType iclRecord)
		=	t_corresponds dclRecord iclRecord
	t_corresponds (AbstractType _) _
		=	return True
// sanity check ...
	t_corresponds UnknownType _
629
		=	undef // <<- "t_corresponds (TypeRhs): dclDef == UnknownType" 
630
	t_corresponds _ UnknownType
631
		=	undef // <<- "t_corresponds (TypeRhs): iclDef == UnknownType"
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
// ... sanity check
	t_corresponds _ _
		=	return False

instance t_corresponds RecordType where
	t_corresponds dclRecord iclRecord
		=	t_corresponds dclRecord.rt_constructor iclRecord.rt_constructor
		&&& t_corresponds dclRecord.rt_fields iclRecord.rt_fields

instance t_corresponds FieldSymbol where
	t_corresponds dclField iclField
		=	equal dclField.fs_name iclField.fs_name

instance t_corresponds ConsDef where
	t_corresponds dclDef iclDef
Martin Wierich's avatar
Martin Wierich committed
647
		=	do (init_atype_vars (dclDef.cons_exi_vars++iclDef.cons_exi_vars))
648
649
650
651
652
653
		&&&	t_corresponds dclDef.cons_type iclDef.cons_type
		&&& equal dclDef.cons_symb iclDef.cons_symb
		&&& equal dclDef.cons_priority iclDef.cons_priority

instance t_corresponds SelectorDef where
	t_corresponds dclDef iclDef
Martin Wierich's avatar
Martin Wierich committed
654
		=	do (init_atype_vars (dclDef.sd_exi_vars++iclDef.sd_exi_vars))
655
656
657
		&&&	t_corresponds dclDef.sd_type iclDef.sd_type
		&&& equal dclDef.sd_field_nr iclDef.sd_field_nr

Martin Wierich's avatar
Martin Wierich committed
658
659
660
661
662
663
664
init_atype_vars atype_vars
					tc_state=:{tc_type_vars}
	# type_heap = foldSt init_type_var atype_vars tc_type_vars.hwn_heap
	  tc_type_vars = { tc_type_vars & hwn_heap = type_heap }
	= { tc_state & tc_type_vars = tc_type_vars }
  where
	init_type_var {atv_variable} type_heap = writePtr atv_variable.tv_info_ptr TVI_Empty type_heap
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679

instance t_corresponds SymbolType where
	t_corresponds dclDef iclDef
		=	t_corresponds dclDef.st_args iclDef.st_args
		&&&	t_corresponds dclDef.st_result iclDef.st_result
		&&&	t_corresponds dclDef.st_context iclDef.st_context
		&&&	t_corresponds dclDef.st_attr_env iclDef.st_attr_env

instance t_corresponds AttrInequality where
	t_corresponds dclDef iclDef
		=	t_corresponds dclDef.ai_demanded iclDef.ai_demanded
		&&&	t_corresponds dclDef.ai_offered iclDef.ai_offered

instance t_corresponds ClassDef where
	t_corresponds dclDef iclDef
Martin Wierich's avatar
Martin Wierich committed
680
681
		=	do (init_type_vars (dclDef.class_args++iclDef.class_args))
		&&&	equal dclDef.class_name iclDef.class_name
682
683
684
685
686
687
		&&&	t_corresponds dclDef.class_args iclDef.class_args
		&&&	t_corresponds dclDef.class_context iclDef.class_context
		&&&	t_corresponds dclDef.class_members iclDef.class_members

instance t_corresponds MemberDef where
	t_corresponds dclDef iclDef
Martin Wierich's avatar
Martin Wierich committed
688
689
690
		=	do (init_type_vars (dclDef.me_type.st_vars++iclDef.me_type.st_vars))
		&&&	do (init_attr_vars (dclDef.me_type.st_attr_vars++iclDef.me_type.st_attr_vars))
		&&& equal dclDef.me_symb iclDef.me_symb
691
692
693
694
695
696
697
698
699
700
701
		&&&	equal dclDef.me_offset iclDef.me_offset
		&&&	equal dclDef.me_priority iclDef.me_priority
		&&&	t_corresponds dclDef.me_type iclDef.me_type

instance t_corresponds ClassInstance where
	t_corresponds dclDef iclDef
		= t_corresponds` dclDef.ins_type iclDef.ins_type
	  where
		t_corresponds` dclDef iclDef tc_state
			# tc_state
					= init_attr_vars (dclDef.it_attr_vars++iclDef.it_attr_vars) tc_state
Martin Wierich's avatar
Martin Wierich committed
702
703
			  tc_state
			  		= init_type_vars (dclDef.it_vars++iclDef.it_vars) tc_state
704
			  (corresponds, tc_state)
Martin Wierich's avatar
Martin Wierich committed
705
			  		=  t_corresponds dclDef.it_types iclDef.it_types tc_state
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
			| not corresponds
				= (corresponds, tc_state)
			=  t_corresponds dclDef.it_context iclDef.it_context tc_state

instance t_corresponds DynamicType where
	t_corresponds dclDef iclDef
		= t_corresponds dclDef.dt_type iclDef.dt_type

instance e_corresponds (Optional a) | e_corresponds a where 
	e_corresponds No No
		= do_nothing
	e_corresponds (Yes dclYes) (Yes iclYes)
		= e_corresponds dclYes iclYes
	e_corresponds _ _
		= give_error ""

instance e_corresponds (a, b) | e_corresponds a & e_corresponds b where 
	e_corresponds (a1, b1) (a2, b2)
		=	(e_corresponds a1 a2)
		o`	(e_corresponds b1 b2)

instance e_corresponds [a] | e_corresponds a where 
	e_corresponds [] []
		=	do_nothing
	e_corresponds [dclDef:dclDefs] [iclDef:iclDefs]
		=	e_corresponds dclDef iclDef
		o`	e_corresponds dclDefs iclDefs
	e_corresponds _ _
		=	give_error ""

instance e_corresponds (Global a) | e_corresponds a where
	e_corresponds dclDef iclDef
		=	equal2 dclDef.glob_module iclDef.glob_module
		o`	e_corresponds dclDef.glob_object iclDef.glob_object

instance e_corresponds DefinedSymbol where
	e_corresponds dclDef iclDef
		= equal2 dclDef.ds_ident iclDef.ds_ident

Martin Wierich's avatar
bugfix    
Martin Wierich committed
745
instance e_corresponds FunctionBody where
746
	// both bodies are either CheckedBodies or TransformedBodies
747
	e_corresponds dclDef iclDef
748
749
//		| False--->("e_corresponds", from_body dclDef, from_body iclDef)
//			= undef
Martin Wierich's avatar
bugfix    
Martin Wierich committed
750
		=	e_corresponds (from_body dclDef) (from_body iclDef)
751
	  where
752
		from_body (TransformedBody {tb_args, tb_rhs}) = (tb_args, [tb_rhs])
753
		from_body (CheckedBody {cb_args, cb_rhs}) = (cb_args, [ca_rhs \\ {ca_rhs} <- cb_rhs])
754
		
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
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
808
809
810
instance e_corresponds FreeVar where
	e_corresponds dclVar iclVar
		=	e_corresponds_VarInfoPtr iclVar.fv_name dclVar.fv_info_ptr iclVar.fv_info_ptr

instance e_corresponds Expression where
	// the following alternatives don't occur anymore: Lambda, Conditional, WildCard
	e_corresponds (Var dcl) (Var icl)
		= 	e_corresponds dcl icl
	e_corresponds (App dcl_app) (App icl_app)
		=	e_corresponds_app_symb dcl_app.app_symb icl_app.app_symb
		o`	e_corresponds dcl_app.app_args icl_app.app_args
	e_corresponds (dclFun @ dclArgs) (iclFun @ iclArgs)
		=	e_corresponds dclFun iclFun
		o`	e_corresponds dclArgs iclArgs
	e_corresponds (Let dcl) (Let icl)
		= 	e_corresponds dcl icl
	e_corresponds (Case dcl) (Case icl)
		= 	e_corresponds dcl icl
	e_corresponds (Selection dcl_is_unique dcl_expr dcl_selections) (Selection icl_is_unique icl_expr icl_selections)
		| not (equal_constructor dcl_is_unique icl_is_unique)
			= give_error "" 
		=	e_corresponds dcl_expr icl_expr
		o`	e_corresponds dcl_selections icl_selections
	e_corresponds (Update dcl_expr_1 dcl_selections dcl_expr_2) (Update icl_expr_1 icl_selections icl_expr_2)
		=	e_corresponds dcl_expr_1 icl_expr_1
		o`	e_corresponds dcl_selections icl_selections
		o`	e_corresponds dcl_expr_2 icl_expr_2
	e_corresponds (RecordUpdate dcl_type dcl_expr dcl_selections) (RecordUpdate icl_type icl_expr icl_selections)
		=	e_corresponds dcl_type icl_type
		o`	e_corresponds dcl_expr icl_expr
		o`	e_corresponds dcl_selections icl_selections
	e_corresponds (TupleSelect dcl_ds dcl_field_nr dcl_expr) (TupleSelect icl_ds icl_field_nr icl_expr)
		=	e_corresponds dcl_ds icl_ds
		o`	equal2 dcl_field_nr icl_field_nr
		o`	e_corresponds dcl_expr icl_expr
	e_corresponds (BasicExpr dcl_value dcl_type) (BasicExpr icl_value icl_type)
		=	equal2 dcl_value icl_value
		o`	equal2 dcl_type icl_type
	e_corresponds (AnyCodeExpr dcl_ins dcl_outs dcl_code_sequence) (AnyCodeExpr icl_ins icl_outs icl_code_sequence)
		=	e_corresponds dcl_ins icl_ins
		o`	e_corresponds dcl_outs icl_outs
		o`	equal2 dcl_code_sequence icl_code_sequence
	e_corresponds (ABCCodeExpr dcl_lines dcl_do_inline) (ABCCodeExpr icl_lines icl_do_inline)
		=	equal2 dcl_lines icl_lines
		o`	equal2 dcl_do_inline icl_do_inline
	e_corresponds (MatchExpr dcl_opt_tuple_type dcl_cons_symbol dcl_src_expr)
				 (MatchExpr icl_opt_tuple_type icl_cons_symbol icl_src_expr)
		= 	e_corresponds dcl_opt_tuple_type icl_opt_tuple_type
		o`	e_corresponds dcl_cons_symbol icl_cons_symbol
		o`	e_corresponds dcl_src_expr icl_src_expr
	e_corresponds (FreeVar dcl) (FreeVar icl)
		= e_corresponds dcl icl
	e_corresponds (DynamicExpr dcl) (DynamicExpr icl)
		= e_corresponds dcl icl
	e_corresponds (TypeCodeExpression dcl) (TypeCodeExpression icl)
		= e_corresponds dcl icl
811
812
	e_corresponds EE EE
		= do_nothing
813
814
	e_corresponds (NoBind _) (NoBind _)
		= do_nothing
815
816
817
818
819
820
821
822
823
824
	e_corresponds _ _
		= give_error ""


instance e_corresponds Let where
	e_corresponds dclLet iclLet
		=	e_corresponds dclLet.let_strict_binds iclLet.let_strict_binds
		o`	e_corresponds dclLet.let_lazy_binds iclLet.let_lazy_binds
		o`	e_corresponds dclLet.let_expr iclLet.let_expr

825
826
827
828
829
instance e_corresponds LetBind where
	e_corresponds dcl icl
		=	e_corresponds dcl.lb_src icl.lb_src
		o`	e_corresponds dcl.lb_dst icl.lb_dst

830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
instance e_corresponds (Bind a b) | e_corresponds a & e_corresponds b where
	e_corresponds dcl icl
		=	e_corresponds dcl.bind_src icl.bind_src
		o`	e_corresponds dcl.bind_dst icl.bind_dst

instance e_corresponds Case where
	e_corresponds dclCase iclCase
		=	e_corresponds dclCase.case_expr iclCase.case_expr
		o`	e_corresponds dclCase.case_guards iclCase.case_guards
		o`	e_corresponds dclCase.case_default iclCase.case_default

instance e_corresponds CasePatterns where
	e_corresponds (AlgebraicPatterns dcl_alg_type dcl_patterns) (AlgebraicPatterns icl_alg_type icl_patterns)
		=	e_corresponds dcl_patterns icl_patterns
	e_corresponds (BasicPatterns dcl_basic_type dcl_patterns) (BasicPatterns icl_basic_type icl_patterns)
		=	equal2 dcl_basic_type icl_basic_type
		o`	e_corresponds dcl_patterns icl_patterns
	e_corresponds (DynamicPatterns dcl_patterns) (DynamicPatterns icl_patterns)
		=	e_corresponds dcl_patterns icl_patterns
	e_corresponds NoPattern NoPattern
		=	do_nothing
	e_corresponds _ _
		=	give_error ""

instance e_corresponds AlgebraicPattern where
	e_corresponds dcl icl
		=	e_corresponds dcl.ap_symbol icl.ap_symbol
		o`	e_corresponds dcl.ap_vars icl.ap_vars
		o`	e_corresponds dcl.ap_expr icl.ap_expr

instance e_corresponds BasicPattern where
	e_corresponds dcl icl
		=	equal2 dcl.bp_value icl.bp_value
		o`	e_corresponds dcl.bp_expr icl.bp_expr

instance e_corresponds DynamicPattern where
	e_corresponds dcl icl
		=	e_corresponds dcl.dp_var icl.dp_var
		o`	e_corresponds dcl.dp_rhs icl.dp_rhs
		o`	e_corresponds_dp_type dcl.dp_type icl.dp_type
	  where
		e_corresponds_dp_type dcl_expr_ptr icl_expr_ptr ec_state=:{ec_expr_heap, ec_tc_state}
			#! dcl_type
					= sreadPtr dcl_expr_ptr ec_expr_heap
			   icl_type 
			   		= sreadPtr icl_expr_ptr ec_expr_heap
			# (EI_DynamicTypeWithVars _ dcl_dyn_type _)
					= dcl_type
			  (EI_DynamicTypeWithVars _ icl_dyn_type _)
			  		= icl_type
			  (corresponds, ec_tc_state) 
					= t_corresponds dcl_dyn_type icl_dyn_type ec_tc_state
			  ec_state
				  	= { ec_state & ec_tc_state = ec_tc_state }
			| corresponds
				= ec_state
			= give_error "" ec_state

instance e_corresponds Selection where
	e_corresponds (RecordSelection dcl_selector dcl_field_nr) (RecordSelection icl_selector icl_field_nr)
		=	e_corresponds dcl_selector icl_selector
		o`	equal2 dcl_field_nr icl_field_nr
	e_corresponds (ArraySelection dcl_selector _ dcl_index_expr) (ArraySelection icl_selector _ icl_index_expr)
		=	e_corresponds dcl_selector icl_selector
		o`	e_corresponds dcl_index_expr icl_index_expr
	e_corresponds (DictionarySelection dcl_dict_var dcl_selections _ dcl_index_expr)
				(DictionarySelection icl_dict_var icl_selections _ icl_index_expr)
		=	e_corresponds dcl_dict_var icl_dict_var
		o`	e_corresponds dcl_selections icl_selections
		o`	e_corresponds dcl_index_expr icl_index_expr
		
instance e_corresponds DynamicExpr where
	e_corresponds dcl icl
		=	e_corresponds_dyn_opt_type dcl.dyn_opt_type icl.dyn_opt_type
		o`	e_corresponds dcl.dyn_expr icl.dyn_expr
	  where		
		e_corresponds_dyn_opt_type dcl icl ec_state
			# (corresponds, ec_tc_state) = t_corresponds dcl icl ec_state.ec_tc_state
			  ec_state = { ec_state & ec_tc_state = ec_tc_state }
			| corresponds
				= ec_state
			= give_error "" ec_state

instance e_corresponds TypeCodeExpression where
	e_corresponds TCE_Empty TCE_Empty
		= do_nothing
	e_corresponds _ _
		= abort "comparedefimp:e_corresponds (TypeCodeExpression): currently only TCE_Empty can appear"
	
instance e_corresponds {#Char} where
	e_corresponds s1 s2
		= equal2 s1 s2

instance e_corresponds BoundVar where
	e_corresponds dcl icl
		= e_corresponds_VarInfoPtr icl.var_name dcl.var_info_ptr icl.var_info_ptr

instance e_corresponds FieldSymbol where
	e_corresponds dclField iclField
		= equal2 dclField.fs_name iclField.fs_name

e_corresponds_VarInfoPtr ident dclPtr iclPtr ec_state=:{ec_var_heap}
	# (unifiable, ec_var_heap) = tryToUnifyVars dclPtr iclPtr ec_var_heap
	  ec_state = { ec_state & ec_var_heap = ec_var_heap }
	| not unifiable
		= { ec_state & ec_error_admin = checkError ident error_message ec_state.ec_error_admin }
	= ec_state

/*	e_corresponds_app_symb checks correspondence of the function symbols in an App expression.
	The problem: also different symbols can correspond with each other, because for macros
	all local functions (also lambda functions) will be generated twice.
*/
942
e_corresponds_app_symb dcl_app_symb=:{symb_name, symb_kind=SK_Function dcl_glob_index} 
943
944
					icl_app_symb=:{symb_kind=SK_Function icl_glob_index}
					ec_state
945
946
947
948
949
	#! main_dcl_module_n = ec_state.ec_tc_state.tc_main_dcl_module_n
	| dcl_glob_index.glob_module==main_dcl_module_n && icl_glob_index.glob_module==main_dcl_module_n
		| ec_state.ec_function_conversions.[dcl_glob_index.glob_object]<>icl_glob_index.glob_object
			= give_error symb_name ec_state
		= ec_state
950
951
952
953
954
955
956
957
958
	| dcl_glob_index<>icl_glob_index
		= give_error symb_name ec_state
	= ec_state
e_corresponds_app_symb dcl_app_symb=:{symb_name, symb_kind=SK_OverloadedFunction dcl_glob_index} 
					icl_app_symb=:{symb_kind=SK_OverloadedFunction icl_glob_index}
					ec_state
	| dcl_glob_index<>icl_glob_index
		= give_error symb_name ec_state
	= ec_state
959
960
961
e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_LocalMacroFunction dcl_index} 
					icl_app_symb=:{symb_kind=SK_LocalMacroFunction icl_index}
					ec_state
962
963
	= continuation_for_possibly_twice_defined_macros
			dcl_app_symb dcl_index icl_app_symb icl_index ec_state
Martin Wierich's avatar
Martin Wierich committed
964
965
966
e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_Macro dcl_glob_index}
					icl_app_symb=:{symb_kind=SK_Macro icl_glob_index}
					ec_state
967
968
	= continuation_for_possibly_twice_defined_macros 
			dcl_app_symb dcl_glob_index.glob_object icl_app_symb icl_glob_index.glob_object ec_state
969
970
971
972
973
974
975
976
977
e_corresponds_app_symb {symb_name=dcl_symb_name, symb_kind=SK_Constructor dcl_glob_index}
						{symb_name=icl_symb_name, symb_kind=SK_Constructor icl_glob_index}
						ec_state
	| dcl_glob_index.glob_module==icl_glob_index.glob_module && dcl_symb_name.id_name==icl_symb_name.id_name
		= ec_state
	= give_error icl_symb_name ec_state
e_corresponds_app_symb {symb_name} _ ec_state
	= give_error symb_name ec_state

978
continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_index icl_app_symb icl_index
979
											ec_state
980
	| dcl_index==icl_index
981
		= ec_state
982
	// two different functions were referenced. In case of macro functions they still could correspond
983
984
985
986
987
988
989
990
991
992
993
994
	| not (names_are_compatible dcl_index icl_index ec_state.ec_icl_functions)
		= give_error icl_app_symb.symb_name ec_state
	| both_funs_have_not_been_checked_before dcl_index icl_index ec_state.ec_correspondences
		// going into recursion is save
		= compareTwoMacroFuns dcl_index icl_index ec_state
	| both_funs_correspond dcl_index icl_index ec_state.ec_correspondences
		= ec_state
	= give_error icl_app_symb.symb_name ec_state
  where
	names_are_compatible dcl_index icl_index icl_functions
		# dcl_function = icl_functions.[dcl_index]
		  icl_function = icl_functions.[icl_index]
995
996
997
998
999
		  dcl_name_is_loc_dependent = name_is_location_dependent dcl_function.fun_kind
		  icl_name_is_loc_dependent = name_is_location_dependent icl_function.fun_kind
		=	(dcl_name_is_loc_dependent==icl_name_is_loc_dependent)
		 && (implies (not dcl_name_is_loc_dependent) (dcl_function.fun_symb.id_name==icl_function.fun_symb.id_name))
		// functions that originate from e.g. lambda expressions can correspond although their names differ
1000
	  where
For faster browsing, not all history is shown. View entire blame