comparedefimp.icl 41.3 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
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.
*/

import syntax, checksupport, compare_constructor, utilities, StdCompare
import RWSDebug

:: 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}
		}

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

:: 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
56
		,	ec_untransformed
Martin Wierich's avatar
bugfix    
Martin Wierich committed
57
				::	!{! FunctionBody }
58
59
60
61
62
63
64
65
66
67
68
69
70
71
		}
		
:: ExpressionsCorrespondMonad
		:== !*ExpressionsCorrespondState -> *ExpressionsCorrespondState

:: Conversions :== {#Index}

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

Martin Wierich's avatar
Martin Wierich committed
72
73
74
:: OptionalCorrespondenceNumber = CorrespondenceNumber !Int | Bound | Unbound

class t_corresponds a :: !a !a -> *TypesCorrespondMonad
75
76
77
78
79
80
81
	// 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
82
	toCorrespondenceNumber :: .a -> OptionalCorrespondenceNumber
83
84
85
86
	fromCorrespondenceNumber :: Int -> .a

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

87
compareDefImp :: !{#Int} !{!FunctionBody} !*{# DclModule} !*IclModule !*Heaps !*ErrorAdmin 
Martin Wierich's avatar
Martin Wierich committed
88
				-> (!.{# DclModule}, !.IclModule,!.Heaps,!.ErrorAdmin)
89
90
91
compareDefImp size_uncopied_icl_defs untransformed dcl_modules icl_module heaps error_admin
	// 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
92
93
94
95
96
97
98
99
100
101
102
103
104
	# (main_dcl_module, dcl_modules) = dcl_modules![cIclModIndex]
	= 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
105
			  (icl_type_defs, icl_com_type_defs) = memcpy icl_com_type_defs
106
107
108
109
110
111
112
113
114
			  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
						}
			  (icl_com_type_defs, tc_state, error_admin)
115
116
					= compareWithConversions 
						size_uncopied_icl_defs.[cTypeDefs] conversion_table.[cTypeDefs]
117
118
						dcl_common.com_type_defs icl_com_type_defs tc_state error_admin
			  (icl_com_cons_defs, tc_state, error_admin)
119
120
					= compareWithConversions 
						size_uncopied_icl_defs.[cConstructorDefs] conversion_table.[cConstructorDefs]
121
122
						dcl_common.com_cons_defs icl_com_cons_defs tc_state error_admin
			  (icl_com_selector_defs, tc_state, error_admin)
123
124
					= compareWithConversions
						size_uncopied_icl_defs.[cSelectorDefs] conversion_table.[cSelectorDefs]
125
126
						dcl_common.com_selector_defs icl_com_selector_defs tc_state error_admin
			  (icl_com_class_defs, tc_state, error_admin)
127
128
					= compareWithConversions
						size_uncopied_icl_defs.[cClassDefs] conversion_table.[cClassDefs]
129
						dcl_common.com_class_defs icl_com_class_defs tc_state error_admin
Martin Wierich's avatar
Martin Wierich committed
130
			  (icl_com_member_defs, tc_state, error_admin)
131
132
					= compareWithConversions
						size_uncopied_icl_defs.[cMemberDefs] conversion_table.[cMemberDefs]
Martin Wierich's avatar
Martin Wierich committed
133
						dcl_common.com_member_defs icl_com_member_defs tc_state error_admin
134
			  (icl_com_instance_defs, tc_state, error_admin)
135
136
					= compareWithConversions
						size_uncopied_icl_defs.[cInstanceDefs] conversion_table.[cInstanceDefs]
137
138
						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)
139
					= compareMacrosWithConversion conversion_table.[cMacroDefs] dcl_macros untransformed
140
141
142
143
144
145
146
147
148
149
150
151
152
153
								 				 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
154
					heaps, error_admin )
155
  where
156
157
	memcpy :: !*{#CheckedTypeDef} -> (!.{CheckedTypeDef}, !.{#CheckedTypeDef})
	memcpy original
158
159
		#! size = size original
		# new = createArray size (abort "don't make that array strict !")
160
		= iFoldSt (\i (dst, src=:{[i]=src_i}) -> ({ dst & [i] = src_i }, src)) 0 size (new, original)
161

162
163
164
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)
165

166
compareWithConversion :: !Int !{#Int} !(b c) !Int !(!u:(b c), !*TypesCorrespondState, !*ErrorAdmin)
167
168
169
170
171
172
173
						-> (!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*/
174
175
176
177
178
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]
179
180
181
182
183
184
185
186
187
	  (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)

188
189
compareTwoFunctionTypes :: !{#Int} !{#FunType} !Int !*(!u:{#FunDef},!*TypesCorrespondState,!*ErrorAdmin) 
						-> (!v:{#FunDef},!.TypesCorrespondState,!.ErrorAdmin) , [u <= v]
190
191
192
193
194
195
196
197
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
198
			  tc_state = init_type_vars (dcl_symbol_type.st_vars++icl_symbol_type.st_vars) tc_state
199
			  (corresponds, tc_state)
Martin Wierich's avatar
bugfix    
Martin Wierich committed
200
					= t_corresponds dcl_symbol_type icl_symbol_type tc_state // --->("comparing:", dcl_symbol_type ,icl_symbol_type)
201
202
203
204
			| 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
205
206
207
208
209
210
211
212
213
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
214
215
216
217
218
219
220
	
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)

221
compareMacrosWithConversion conversions macro_range untransformed icl_functions var_heap expr_heap tc_state error_admin
222
223
224
225
	#! 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,
226
227
	  				ec_error_admin = error_admin, ec_tc_state = tc_state,
	  				ec_untransformed = untransformed }
228
229
230
231
232
233
234
235
	  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
236
compareTwoMacroFuns :: !.Int !.Int !*ExpressionsCorrespondState -> .ExpressionsCorrespondState;
237
compareTwoMacroFuns dclIndex iclIndex
238
239
240
					ec_state=:{ec_correspondences, ec_icl_functions, ec_untransformed}
	| dclIndex==iclIndex
		= ec_state
241
242
243
	# (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 }
244
245
246
247
248
249
250
251
252
	  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
253
	# adjusted_icl_body
254
255
256
257
	  		= 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
258
259
	  				-> ec_untransformed.[iclIndex]
	  			_	-> icl_function.fun_body
260
	  ident_pos = getIdentPos dcl_function
261
	  ec_error_admin = pushErrorAdmin ident_pos ec_state.ec_error_admin
Martin Wierich's avatar
bugfix    
Martin Wierich committed
262
	  ec_state = e_corresponds dcl_function.fun_body adjusted_icl_body { ec_state & ec_error_admin = ec_error_admin }
263
264
265
266
	= { 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
267
		= newPosition td_name td_pos
268
269
270

instance getIdentPos ConsDef where
	getIdentPos {cons_symb, cons_pos}
Martin Wierich's avatar
Martin Wierich committed
271
		= newPosition cons_symb cons_pos
272
273
274

instance getIdentPos SelectorDef where
	getIdentPos {sd_symb, sd_pos}
Martin Wierich's avatar
Martin Wierich committed
275
		= newPosition sd_symb sd_pos
276
277
278

instance getIdentPos ClassDef where
	getIdentPos {class_name, class_pos}
Martin Wierich's avatar
Martin Wierich committed
279
		= newPosition class_name class_pos
280
281
282

instance getIdentPos MemberDef where
	getIdentPos {me_symb, me_pos}
Martin Wierich's avatar
Martin Wierich committed
283
		= newPosition me_symb me_pos
284
285
286

instance getIdentPos ClassInstance where
	getIdentPos {ins_ident, ins_pos}
Martin Wierich's avatar
Martin Wierich committed
287
		= newPosition ins_ident ins_pos
288
289
290

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

293
294
instance CorrespondenceNumber VarInfo where
	toCorrespondenceNumber (VI_CorrespondenceNumber number)
Martin Wierich's avatar
Martin Wierich committed
295
		=	CorrespondenceNumber number
296
297
298
	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
299
300
		=	Unbound
		
301
302
303
304
305
	fromCorrespondenceNumber number
		=	VI_CorrespondenceNumber number

instance CorrespondenceNumber TypeVarInfo where
	toCorrespondenceNumber (TVI_CorrespondenceNumber number)
Martin Wierich's avatar
Martin Wierich committed
306
307
308
309
310
		=	CorrespondenceNumber number
	toCorrespondenceNumber TVI_Empty
		=	Unbound
	toCorrespondenceNumber (TVI_AType _)
		=	Bound
311
312
313
314
315
316

	fromCorrespondenceNumber number
		=	TVI_CorrespondenceNumber number

instance CorrespondenceNumber AttrVarInfo where
	toCorrespondenceNumber (AVI_CorrespondenceNumber number)
Martin Wierich's avatar
Martin Wierich committed
317
318
319
		=	CorrespondenceNumber number
	toCorrespondenceNumber AVI_Empty
		=	Unbound
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335

	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
336
			(CorrespondenceNumber number1, CorrespondenceNumber number2)
337
				->	(number1==number2, heapWithNumber)
Martin Wierich's avatar
Martin Wierich committed
338
			(Unbound, Unbound)
339
340
341
342
343
344
345
346
347
348
349
350
 				->	(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

351

352
353
354
355
/*2.0
instance t_corresponds {# a} | t_corresponds a & Array {#} a
0.2*/
//1.3
356
instance t_corresponds {# a} | ArrayElem , t_corresponds a
357
//3.1
358
where 
359
360
361
362
	t_corresponds dclArray iclArray
		# size_dclArray = size dclArray
		| size_dclArray<>size iclArray
			= return False
363
			= loop (size_dclArray-1) dclArray iclArray
364
	  where
365
366
367
368
369
370
/*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
371
372
373
		loop i dclArray iclArray
			| i<0
				= return True
374
				= t_corresponds dclArray.[i] iclArray.[i]
375
376
			&&& loop (i-1) dclArray iclArray
		
377

378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
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
396
397
//			| False--->("comparing:", dclDef, iclDef)
//				= undef
398
			# tc_state = { tc_state & tc_visited_syn_types.[dclDef.td_index] = True }
Martin Wierich's avatar
Martin Wierich committed
399
400
401
402
			  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
403
404
405
			  (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
406
			# icl_root_has_anonymous_attr = root_has_anonymous_attr iclDef.td_attribute iclDef.td_rhs
407
408
409
410
411
412
413
414
415
416
417
			| 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
418
419
			# attributes_correspond = (is_TA_Unique dclDef.td_attribute)==(is_TA_Unique iclDef.td_attribute)
			= (attributes_correspond, tc_state)
420
421
422
423
424
425
426
427
428
429
430
431

		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
432
433
434
		is_TA_Unique TA_Unique = True
		is_TA_Unique _ = False
		
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
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
455
456
			| dclDef.at_annotation<>iclDef.at_annotation
				= (False, tc_state)
457
458
459
460
461
462
463
464
465
466
			# (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
467
							-> t_corresponds { dcl_atype & at_annotation = dclDef.at_annotation } iclDef tc_state
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
						_	-> (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
				# is_defined_in_main_dcl = glob_module==cIclModIndex
				| 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
483
484
485
486
487
488
					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
489
490
491
492
493
494
495
					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
496
						  tc_state = opt_set_visited_bit is_defined_in_main_dcl glob_object False tc_state
497
498
						-> (corresponds, tc_state) 
					AbstractType _
Martin Wierich's avatar
bugfix    
Martin Wierich committed
499
500
						| not is_defined_in_main_dcl
							-> (False, tc_state)
501
502
503
504
505
506
						#! 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
507
								# atype = { atype & at_attribute = determine_type_attribute type_def.td_attribute }
508
509
510
511
								-> t_corresponds atype icl_atype tc_state
							_	-> (False, tc_state)
					_	-> (False, tc_state)
			  where
Martin Wierich's avatar
Martin Wierich committed
512

513
				bind_type_vars formal_args actual_args tc_type_vars
Martin Wierich's avatar
Martin Wierich committed
514
					# hwn_heap = bind_type_vars` formal_args actual_args tc_type_vars.hwn_heap
515
516
517
					= { 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
518
					# (actual_arg, type_var_heap) = possibly_dereference actual_arg type_var_heap
519
520
					= bind_type_vars` formal_args actual_args
							(writePtr atv_variable.tv_info_ptr (TVI_AType actual_arg) type_var_heap)
521
							//	--->("binding", atv_variable.tv_name,"to",actual_arg)
522
				bind_type_vars` _ _ type_var_heap
Martin Wierich's avatar
Martin Wierich committed
523
524
525
526
527
528
529
530
531
532
					= 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)
533
534
535
536
537
538
539
540
			
				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
541
542
543
544
				
				get_arg_pos x [h:t] count
					| x==h.atv_variable	= count
										= get_arg_pos x t (inc count)
545
546
547
548
549
550
551
552

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
553
	t_corresponds (TA_RootVar dclDef) (TA_RootVar iclDef)
554
		= PA_BUG (return True) (t_corresponds dclDef iclDef)
Martin Wierich's avatar
Martin Wierich committed
555
	t_corresponds _ TA_Anonymous
556
557
558
559
560
561
562
563
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
		=	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
595
596
	t_corresponds _ _
		= return False
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
		
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 _
		=	undef <<- "t_corresponds (TypeRhs): dclDef == UnknownType" 
	t_corresponds _ UnknownType
		=	undef <<- "t_corresponds (TypeRhs): iclDef == UnknownType"
// ... 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
639
		=	do (init_atype_vars (dclDef.cons_exi_vars++iclDef.cons_exi_vars))
640
641
642
643
644
645
		&&&	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
646
		=	do (init_atype_vars (dclDef.sd_exi_vars++iclDef.sd_exi_vars))
647
648
649
		&&&	t_corresponds dclDef.sd_type iclDef.sd_type
		&&& equal dclDef.sd_field_nr iclDef.sd_field_nr

Martin Wierich's avatar
Martin Wierich committed
650
651
652
653
654
655
656
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
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671

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
672
673
		=	do (init_type_vars (dclDef.class_args++iclDef.class_args))
		&&&	equal dclDef.class_name iclDef.class_name
674
675
676
677
678
679
		&&&	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
680
681
682
		=	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
683
684
685
686
687
688
689
690
691
692
693
		&&&	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
694
695
			  tc_state
			  		= init_type_vars (dclDef.it_vars++iclDef.it_vars) tc_state
696
			  (corresponds, tc_state)
Martin Wierich's avatar
Martin Wierich committed
697
			  		=  t_corresponds dclDef.it_types iclDef.it_types tc_state
698
699
700
701
702
703
704
705
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
			| 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
737
instance e_corresponds FunctionBody where
738
	// both bodies are either CheckedBodies or TransformedBodies
739
	e_corresponds dclDef iclDef
Martin Wierich's avatar
bugfix    
Martin Wierich committed
740
//		| False--->("compare", from_body dclDef, from_body iclDef)
741
//			= undef
Martin Wierich's avatar
bugfix    
Martin Wierich committed
742
		=	e_corresponds (from_body dclDef) (from_body iclDef)
743
	  where
744
		from_body (TransformedBody {tb_args, tb_rhs}) = (tb_args, [tb_rhs])
745
		from_body (CheckedBody {cb_args, cb_rhs}) = (cb_args, [ca_rhs \\ {ca_rhs} <- cb_rhs])
746
		
747
748
749
750
751
752
753
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
instance e_corresponds TransformedBody where
	e_corresponds dclDef iclDef
		=	e_corresponds dclDef.tb_args iclDef.tb_args
		o`	e_corresponds dclDef.tb_rhs iclDef.tb_rhs

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
808
809
	e_corresponds EE EE
		= do_nothing
810
811
	e_corresponds (NoBind _) (NoBind _)
		= do_nothing
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
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
942
943
	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

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.
*/
e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_Function dcl_glob_index} 
					icl_app_symb=:{symb_kind=SK_Function icl_glob_index}
					ec_state
	= continuation_for_possibly_twice_defined_funs dcl_app_symb dcl_glob_index icl_app_symb icl_glob_index
													ec_state
e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_OverloadedFunction dcl_glob_index}
					icl_app_symb=:{symb_kind=SK_OverloadedFunction icl_glob_index}
					ec_state
	= continuation_for_possibly_twice_defined_funs dcl_app_symb dcl_glob_index icl_app_symb icl_glob_index
													ec_state
Martin Wierich's avatar
Martin Wierich committed
944
945
946
947
948
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
	= continuation_for_possibly_twice_defined_funs dcl_app_symb dcl_glob_index icl_app_symb icl_glob_index
													ec_state
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
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

continuation_for_possibly_twice_defined_funs dcl_app_symb dcl_glob_index icl_app_symb icl_glob_index
											ec_state
	| dcl_glob_index==icl_glob_index
		= ec_state
	| dcl_glob_index.glob_module<>cIclModIndex || icl_glob_index.glob_module<>cIclModIndex
		= give_error icl_app_symb.symb_name ec_state
	// two different functions from the main module were referenced. Check their correspondence
	# dcl_index = dcl_glob_index.glob_object
	  icl_index = icl_glob_index.glob_object
	#! dcl_is_macro_fun = get_is_macro_fun dcl_index ec_state.ec_icl_functions
	   icl_is_macro_fun = get_is_macro_fun icl_index ec_state.ec_icl_functions
	| not dcl_is_macro_fun || not icl_is_macro_fun
		// at least one function was not locally defined in a macro.
		= give_error icl_app_symb.symb_name ec_state
	// two functions that are local to a macro definition were referencend.
	| 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]
		  dcl_is_lambda = get_is_lambda dcl_function.fun_kind
		  icl_is_lambda = get_is_lambda icl_function.fun_kind
		=	(dcl_is_lambda==icl_is_lambda)
		 && (implies (not dcl_is_lambda) (dcl_function.fun_symb.id_name==icl_function.fun_symb.id_name))
		// functions that originate from lambda expressions can correspond although their names differ
	  where
		get_is_lambda (FK_Function is_lambda)
			= is_lambda
		get_is_lambda _
		 	= False
		 	
	both_funs_have_not_been_checked_before dcl_index icl_index correspondences
		= correspondences.[dcl_index]==cNoCorrespondence && correspondences.[icl_index]==cNoCorrespondence

	both_funs_correspond dcl_index icl_index correspondences
		= correspondences.[dcl_index]==icl_index && correspondences.[icl_index]==dcl_index
For faster browsing, not all history is shown. View entire blame