ChangeDefinition.icl 38.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
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
/*
** Program: Clean Prover System
** Module:  ChangeDefinition (.icl)
** 
** Author:  Maarten de Mol
** Created: 23 August 2000
**
** Note: Operates under the assumption that no sharing is present.
*/

implementation module 
	ChangeDefinition

import
	StdEnv,
	CoreTypes,
	CoreAccess,
	Predefined
	, RWSDebug

// -------------------------------------------------------------------------------------------------------------------------------------------------
find2 :: !String ![(String, a)] -> (!Bool, !a) | DummyValue a
// -------------------------------------------------------------------------------------------------------------------------------------------------
find2 this_name [(name,key):modules]
	| this_name == name			= (True, key)
	= find2 this_name modules
find2 this_name []
	= (False, DummyValue)

// -------------------------------------------------------------------------------------------------------------------------------------------------
find :: !String ![ModuleName] ![ModulePtr] -> (!Bool, !ModulePtr)
// -------------------------------------------------------------------------------------------------------------------------------------------------
find this_name [name:names] [ptr:ptrs]
	| this_name == name			= (True, ptr)
	= find this_name names ptrs
find this_name [] []
	= (False, nilPtr)

// -------------------------------------------------------------------------------------------------------------------------------------------------
multiple_find :: !String ![String] ![ModuleName] ![ModulePtr] -> (!Bool, ![ModulePtr])
// -------------------------------------------------------------------------------------------------------------------------------------------------
multiple_find icl_name ["_predefined":names] offered_names offered_ptrs
	= multiple_find icl_name names offered_names offered_ptrs
multiple_find icl_name [name:names] offered_names offered_ptrs
	| name == icl_name			= multiple_find icl_name names offered_names offered_ptrs
	# (found, ptr)				= find name offered_names offered_ptrs
	| not found					= (False, [])
	# (found, ptrs)				= multiple_find icl_name names offered_names offered_ptrs
	| not found					= (False, [])
	= (True, [ptr:ptrs])
multiple_find icl_name [] offered_names offered_ptrs
	= (True, [])

// -------------------------------------------------------------------------------------------------------------------------------------------------
findConversions :: !(Maybe CompilerConversion) !String ![ModuleName] ![ModulePtr] !*CHeaps -> (!Bool, !CompilerConversion, !*CHeaps)
// -------------------------------------------------------------------------------------------------------------------------------------------------
findConversions (Just conversions) _ _ _ heaps
	= (True, conversions, heaps)
findConversions Nothing dcl_name all_names all_ptrs heaps
	# (found, ptr)				= find dcl_name all_names all_ptrs
	| not found					= (False, DummyValue, heaps)
	# (mod, heaps)				= readPointer ptr heaps
	= (True, mod.pmCompilerConversion, heaps)

// In case John shows up at your pc, HIDE the code beneath (or face the consequences)!
// -------------------------------------------------------------------------------------------------------------------------------------------------
bindPredefined :: !CName !CompilerDefinitionKind !Index !*CHeaps -> (!Error, !HeapPtr, !*CHeaps)
// -------------------------------------------------------------------------------------------------------------------------------------------------
bindPredefined name CheckedTypeDef index heaps
	= case name of
		"_List"					-> (OK, CListPtr, heaps)
		"_Array"				-> (OK, CNormalArrayPtr, heaps)
		"_!Array"				-> (OK, CStrictArrayPtr, heaps)
		"_#Array"				-> (OK, CUnboxedArrayPtr, heaps)
//		"{#}"					-> 
		"_Tuple2"				-> (OK, CTuplePtr 2, heaps)
		"_Tuple3"				-> (OK, CTuplePtr 3, heaps)
		"_Tuple4"				-> (OK, CTuplePtr 4, heaps)
		"_Tuple5"				-> (OK, CTuplePtr 5, heaps)
		"_Tuple6"				-> (OK, CTuplePtr 6, heaps)
		"_Tuple7"				-> (OK, CTuplePtr 7, heaps)
		"_Tuple8"				-> (OK, CTuplePtr 8, heaps)
		"_Tuple9"				-> (OK, CTuplePtr 9, heaps)
		"_Tuple10"				-> (OK, CTuplePtr 10, heaps)
		"_Tuple11"				-> (OK, CTuplePtr 11, heaps)
		"_Tuple12"				-> (OK, CTuplePtr 12, heaps)
		"_Tuple13"				-> (OK, CTuplePtr 13, heaps)
		"_Tuple14"				-> (OK, CTuplePtr 14, heaps)
		"_Tuple15"				-> (OK, CTuplePtr 15, heaps)
		"_Tuple16"				-> (OK, CTuplePtr 16, heaps)
		"_Tuple17"				-> (OK, CTuplePtr 17, heaps)
		"_Tuple18"				-> (OK, CTuplePtr 18, heaps)
		"_Tuple19"				-> (OK, CTuplePtr 19, heaps)
		"_Tuple20"				-> (OK, CTuplePtr 20, heaps)
		"_Tuple21"				-> (OK, CTuplePtr 21, heaps)
		"_Tuple22"				-> (OK, CTuplePtr 22, heaps)
		"_Tuple23"				-> (OK, CTuplePtr 23, heaps)
		"_Tuple24"				-> (OK, CTuplePtr 24, heaps)
		"_Tuple25"				-> (OK, CTuplePtr 25, heaps)
		"_Tuple26"				-> (OK, CTuplePtr 26, heaps)
		"_Tuple27"				-> (OK, CTuplePtr 27, heaps)
		"_Tuple28"				-> (OK, CTuplePtr 28, heaps)
		"_Tuple29"				-> (OK, CTuplePtr 29, heaps)
		"_Tuple30"				-> (OK, CTuplePtr 30, heaps)
		"_Tuple31"				-> (OK, CTuplePtr 31, heaps)
		"_Tuple32"				-> (OK, CTuplePtr 32, heaps)
		_						-> (pushError (X_Internal ("Unrecognized CheckedTypeDef ptr to _predefined (" +++ name +++ ", " +++ toString index +++ ")")) OK, DummyValue, heaps)
bindPredefined name ConsDef index heaps
	= case name of
		"_Cons"					-> (OK, CConsPtr, heaps)
		"_Nil"					-> (OK, CNilPtr, heaps)
		"_Tuple2"				-> (OK, CBuildTuplePtr 2, heaps)
		"_Tuple3"				-> (OK, CBuildTuplePtr 3, heaps)
		"_Tuple4"				-> (OK, CBuildTuplePtr 4, heaps)
		"_Tuple5"				-> (OK, CBuildTuplePtr 5, heaps)
		"_Tuple6"				-> (OK, CBuildTuplePtr 6, heaps)
		"_Tuple7"				-> (OK, CBuildTuplePtr 7, heaps)
		"_Tuple8"				-> (OK, CBuildTuplePtr 8, heaps)
		"_Tuple9"				-> (OK, CBuildTuplePtr 9, heaps)
		"_Tuple10"				-> (OK, CBuildTuplePtr 10, heaps)
		"_Tuple11"				-> (OK, CBuildTuplePtr 11, heaps)
		"_Tuple12"				-> (OK, CBuildTuplePtr 12, heaps)
		"_Tuple13"				-> (OK, CBuildTuplePtr 13, heaps)
		"_Tuple14"				-> (OK, CBuildTuplePtr 14, heaps)
		"_Tuple15"				-> (OK, CBuildTuplePtr 15, heaps)
		"_Tuple16"				-> (OK, CBuildTuplePtr 16, heaps)
		"_Tuple17"				-> (OK, CBuildTuplePtr 17, heaps)
		"_Tuple18"				-> (OK, CBuildTuplePtr 18, heaps)
		"_Tuple19"				-> (OK, CBuildTuplePtr 19, heaps)
		"_Tuple20"				-> (OK, CBuildTuplePtr 20, heaps)
		"_Tuple21"				-> (OK, CBuildTuplePtr 21, heaps)
		"_Tuple22"				-> (OK, CBuildTuplePtr 22, heaps)
		"_Tuple23"				-> (OK, CBuildTuplePtr 23, heaps)
		"_Tuple24"				-> (OK, CBuildTuplePtr 24, heaps)
		"_Tuple25"				-> (OK, CBuildTuplePtr 25, heaps)
		"_Tuple26"				-> (OK, CBuildTuplePtr 26, heaps)
		"_Tuple27"				-> (OK, CBuildTuplePtr 27, heaps)
		"_Tuple28"				-> (OK, CBuildTuplePtr 28, heaps)
		"_Tuple29"				-> (OK, CBuildTuplePtr 29, heaps)
		"_Tuple30"				-> (OK, CBuildTuplePtr 30, heaps)
		"_Tuple31"				-> (OK, CBuildTuplePtr 31, heaps)
		"_Tuple32"				-> (OK, CBuildTuplePtr 32, heaps)
		_						-> (pushError (X_Internal ("Unrecognized ConsDef ptr to _predefined (" +++ name +++ ", " +++ toString index +++ ")")) OK, DummyValue, heaps)
bindPredefined name other index heaps
	= (pushError (X_Internal ("Unrecognized ptr to _predefined. (" +++ (toString index) +++ ")")) OK, DummyValue, heaps)

// =================================================================================================================================================
// Exception: pointers to record-constructors for dictionaries are not included in the dcl_convtable
//            Solution: replace by pointer to the class, revert this change in 'Bind'
// -------------------------------------------------------------------------------------------------------------------------------------------------
bindDefinition :: !(Maybe CompilerConversion) ![ModuleName] ![ModulePtr] !IndexedPtr !*CHeaps -> (!Error, !HeapPtr, !*CHeaps)
// -------------------------------------------------------------------------------------------------------------------------------------------------
bindDefinition mb_conversions all_names all_ptrs (DclDefinitionPtr dcl_name def_name def_kind def_index) heaps
	| dcl_name == "_predefined"		= bindPredefined def_name def_kind def_index heaps
	# (ok, conversions, heaps)		= findConversions mb_conversions dcl_name all_names all_ptrs heaps
	| not ok						= (pushError (X_Internal ("Rule 'bindDefinition' does not match. (unknown dclmodule " +++ dcl_name +++ ")")) OK, DummyValue, heaps)
	# dcl_icl_table					= conversions.ccDclIclConversions
	| def_kind == FunDef
		# def_index					= if (size dcl_icl_table > 0) dcl_icl_table.[def_index] def_index
		= bindDefinition (Just conversions) all_names all_ptrs (IclDefinitionPtr dcl_name (-2) def_name def_kind def_index) heaps
	# conv_tables					= conversions.ccConversionTable
	# conv_index					= case def_kind of
										CheckedTypeDef		-> cTypeDefs
										ConsDef				-> cConstructorDefs
										SelectorDef			-> cSelectorDefs
										ClassDef			-> cClassDefs
										MemberDef			-> cMemberDefs
										ClassInstance		-> cInstanceDefs
	# conv_table					= conv_tables.[conv_index]
170
	| (def_kind <> ConsDef) && (def_index >= size conv_table)
171
172
173
		# dicts						= conversions.ccDictionaries
		# icl_ptr					= check_dictionary def_name def_kind dicts (IclDefinitionPtr dcl_name (-2) def_name def_kind def_index)
		= bindDefinition (Just conversions) all_names all_ptrs icl_ptr heaps
174
175
176
177
178
179
180
181
182
183
	# (nr_conses, heaps)			= find_nr_conses dcl_name all_names all_ptrs heaps
	| (def_kind == ConsDef) && (def_index >= nr_conses)
		// Constructor is a dictionary creator, which cannot be converted at this time.
		// Therefore, it is replaced by the class that the dictionary belongs to and is later converted back.
		# def_name					= remove_last_semicolon def_name
		# class_ptr					= (DclDefinitionPtr dcl_name def_name ClassDef (def_index-nr_conses))
		= bindDefinition (Just conversions) all_names all_ptrs class_ptr heaps
	# def_index						= case def_index >= size conv_table of
										True	-> def_index
										False	-> conv_table.[def_index]
184
185
186
187
188
189
190
191
192
	= bindDefinition (Just conversions) all_names all_ptrs (IclDefinitionPtr dcl_name (-2) def_name def_kind def_index) heaps
	where
		check_dictionary :: !String !CompilerDefinitionKind ![(CName, IndexedPtr)] !IndexedPtr -> !IndexedPtr
		check_dictionary defname CheckedTypeDef dicts oldptr
			# (found, newptr)			= find2 defname dicts
			| not found					= oldptr
			= newptr
		check_dictionary defname other dicts oldptr
			= oldptr
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
		
		// When temporary converting dictionary_creators (conses) to classes, its index has to be adjusted by the number of real conses in the dcl.
		// This number is stored in the module (and set by the function 'convertFrontEndSyntaxTree' in 'Conversion.icl'.
		find_nr_conses :: !String ![ModuleName] ![ModulePtr] !*CHeaps -> (!Int, !*CHeaps)
		find_nr_conses dcl_name [name:names] [ptr:ptrs] heaps
			| dcl_name <> name			= find_nr_conses dcl_name names ptrs heaps
			# (mod, heaps)				= readPointer ptr heaps
			= (mod.pmOriginalNrDclConses, heaps)
		find_nr_conses _ _ _ heaps
			= (0, heaps)
		
		// When temporary converting record-constructors to class pointers, the last ; has to be removed to get the proper class name.
		remove_last_semicolon :: !String -> String
		remove_last_semicolon name
			# size_name					= size name
			| size_name == 0			= name
			# last_char					= name.[size_name - 1]
			| last_char <> ';'			= name
			= name % (0, size name - 2)
212
213
214
215
216
217
218
219
220
221
222
bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_key _ CheckedTypeDef def_index) heaps
	# (ok, conversions, heaps)			= findConversions mb_conversions icl_name all_names all_ptrs heaps
	| not ok							= (pushError (X_Internal ("Rule 'bindDefinition' does not match. (unknown iclmodule " +++ icl_name +++ ")")) OK, DummyValue, heaps)
	= (OK, conversions.ccCheckedTypePtrs.[def_index], heaps)
bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_key _ ConsDef def_index) heaps
	# (ok, conversions, heaps)			= findConversions mb_conversions icl_name all_names all_ptrs heaps
	| not ok							= (pushError (X_Internal ("Rule 'bindDefinition' does not match. (unknown iclmodule " +++ icl_name +++ ")")) OK, DummyValue, heaps)
	= (OK, conversions.ccConsPtrs.[def_index], heaps)
bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_key _ ClassDef def_index) heaps
	# (ok, conversions, heaps)			= findConversions mb_conversions icl_name all_names all_ptrs heaps
	| not ok							= (pushError (X_Internal ("Rule 'bindDefinition' does not match. (unknown iclmodule " +++ icl_name +++ ")")) OK, DummyValue, heaps)
223
224
225
	
	| def_index >= size conversions.ccClassPtrs		= abort "HALLO! NIET DOEN!"
	
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
	= (OK, conversions.ccClassPtrs.[def_index], heaps)
bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr "_tupleselect" icl_key _ FunDef def_index) heaps
	= (OK, CTupleSelectPtr icl_key def_index, heaps)
bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_key _ FunDef def_index) heaps
	# (ok, conversions, heaps)			= findConversions mb_conversions icl_name all_names all_ptrs heaps
	| not ok							= (pushError (X_Internal ("Rule 'bindDefinition' does not match. (unknown iclmodule " +++ icl_name +++ ")")) OK, DummyValue, heaps)
	= (OK, conversions.ccFunPtrs.[def_index], heaps)
bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_key _ ClassInstance def_index) heaps
	# (ok, conversions, heaps)			= findConversions mb_conversions icl_name all_names all_ptrs heaps
	| not ok							= (pushError (X_Internal ("Rule 'bindDefinition' does not match. (unknown iclmodule " +++ icl_name +++ ")")) OK, DummyValue, heaps)
	= (OK, conversions.ccInstancePtrs.[def_index], heaps)
bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_key _ MemberDef def_index) heaps
	# (ok, conversions, heaps)			= findConversions mb_conversions icl_name all_names all_ptrs heaps
	| not ok							= (pushError (X_Internal ("Rule 'bindDefinition' does not match. (unknown iclmodule " +++ icl_name +++ ")")) OK, DummyValue, heaps)
	= (OK, conversions.ccMemberPtrs.[def_index], heaps)
bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_key _ SelectorDef def_index) heaps
	# (ok, conversions, heaps)			= findConversions mb_conversions icl_name all_names all_ptrs heaps
	| not ok							= (pushError (X_Internal ("Rule 'bindDefinition' does not match. (unknown iclmodule " +++ icl_name +++ ")")) OK, DummyValue, heaps)
	= (OK, conversions.ccSelectorPtrs.[def_index], heaps)

246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
// -------------------------------------------------------------------------------------------------------------------------------------------------   
bindDefinition2 :: !(Maybe CompilerConversion) ![ModuleName] ![ModulePtr] !IndexedPtr !*CHeaps -> (!Error, !HeapPtr, !*CHeaps)
// -------------------------------------------------------------------------------------------------------------------------------------------------   
bindDefinition2 mb_conversions all_names all_ptrs ptr1 heaps
	# (error, ptr2, heaps)				= bindDefinition mb_conversions all_names all_ptrs ptr1 heaps
	| isError error						= (error, ptr2, heaps)
	# kind_1							= get_kind ptr1
	# kind_2							= ptrKind ptr2
	= check kind_1 kind_2 error ptr1 ptr2 heaps
	where
		get_kind :: !IndexedPtr -> CompilerDefinitionKind
		get_kind (IclDefinitionPtr _ _ _ kind _)
			= kind
		get_kind (DclDefinitionPtr _ _ kind _)
			= kind
		
		check :: !CompilerDefinitionKind !DefinitionKind !Error !IndexedPtr !HeapPtr !*CHeaps -> (!Error, !HeapPtr, !*CHeaps)
		check CheckedTypeDef CRecordType error ptr1 ptr2 heaps
			= (error, ptr2, heaps)
		check kind1 CRecordType error ptr1 ptr2 heaps
//			#! heaps					= heaps --->> ptr1
			= (error, ptr2, heaps)
		check _ _ error ptr1 ptr2 heaps
			= (error, ptr2, heaps)
	

272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
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
595
596
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
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675











// -------------------------------------------------------------------------------------------------------------------------------------------------   
class changeDefinition c :: !(a -> *CHeaps -> (Error, b, *CHeaps)) !(c a) !*CHeaps -> (!Error, !(c b), !*CHeaps) | DummyValue a & DummyValue b
// -------------------------------------------------------------------------------------------------------------------------------------------------   

// -------------------------------------------------------------------------------------------------------------------------------------------------   
instance changeDefinition CAlgPattern
// -------------------------------------------------------------------------------------------------------------------------------------------------   
where
	changeDefinition f algpattern=:{atpDataCons, atpExprVarScope, atpResult} heaps
		# (error, fDataCons, heaps)		= f atpDataCons heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fResult, heaps)		= changeDefinition f atpResult heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, {atpDataCons = fDataCons, atpExprVarScope = atpExprVarScope, atpResult = fResult}, heaps)

// -------------------------------------------------------------------------------------------------------------------------------------------------   
instance changeDefinition CAlgTypeDef
// -------------------------------------------------------------------------------------------------------------------------------------------------   
where
	changeDefinition f at_def=:{atdConstructors} heaps
		# (error, fconses, heaps)		= umapError f atdConstructors heaps
		| isError error					= (error, DummyValue, heaps)
		= (error, {at_def & atdConstructors = fconses}, heaps)

// -------------------------------------------------------------------------------------------------------------------------------------------------   
instance changeDefinition CBasicPattern
// -------------------------------------------------------------------------------------------------------------------------------------------------   
where
	changeDefinition f basicpattern=:{bapBasicValue, bapResult} heaps
		# (error, fResult, heaps)		= changeDefinition f bapResult heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fValue, heaps)		= changeDefinition f bapBasicValue heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, {bapBasicValue = fValue, bapResult = fResult}, heaps)

// -------------------------------------------------------------------------------------------------------------------------------------------------
instance changeDefinition CBasicValue
// -------------------------------------------------------------------------------------------------------------------------------------------------
where
	changeDefinition f (CBasicCharacter c) heaps
		= (OK, CBasicCharacter c, heaps)
	changeDefinition f (CBasicInteger n) heaps
		= (OK, CBasicInteger n, heaps)
	changeDefinition f (CBasicRealNumber r) heaps
		= (OK, CBasicRealNumber r, heaps)
	changeDefinition f (CBasicBoolean b) heaps
		= (OK, CBasicBoolean b, heaps)
	changeDefinition f (CBasicString s) heaps
		= (OK, CBasicString s, heaps)
	changeDefinition f (CBasicArray list) heaps
		# (error, flist, heaps)			= umapError (changeDefinition f) list heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, CBasicArray flist, heaps)

// -------------------------------------------------------------------------------------------------------------------------------------------------
instance changeDefinition CCasePatterns
// -------------------------------------------------------------------------------------------------------------------------------------------------
where
	changeDefinition f (CAlgPatterns ptr algpatterns) heaps
		# (error, fptr, heaps)			= f ptr heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fpatterns, heaps)		= umapError (changeDefinition f) algpatterns heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, CAlgPatterns fptr fpatterns, heaps)
	changeDefinition f (CBasicPatterns type basicpatterns) heaps
		# (error, fpatterns, heaps)		= umapError (changeDefinition f) basicpatterns heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, CBasicPatterns type fpatterns, heaps)

// -------------------------------------------------------------------------------------------------------------------------------------------------
instance changeDefinition CClassDef
// -------------------------------------------------------------------------------------------------------------------------------------------------
where
	changeDefinition f classdef heaps
		# fscope						= classdef.cldTypeVarScope
		# (error, frestrictions, heaps)	= umapError (changeDefinition f) classdef.cldClassRestrictions heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fmembers, heaps)		= umapError f classdef.cldMembers heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fdictionary, heaps)	= f classdef.cldDictionary heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, finstances, heaps)	= umapError f classdef.cldInstances heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK,	{ cldName				= classdef.cldName
				, cldArity				= classdef.cldArity
				, cldTypeVarScope		= fscope
				, cldClassRestrictions	= frestrictions
				, cldMembers			= fmembers
				, cldDictionary			= fdictionary
				, cldInstances			= finstances
				}, heaps)

// -------------------------------------------------------------------------------------------------------------------------------------------------
instance changeDefinition CClassRestriction
// -------------------------------------------------------------------------------------------------------------------------------------------------
where
	changeDefinition f classr heaps
		# (error, fccrClass, heaps)		= f classr.ccrClass heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fccrTypes, heaps)		= umapError (changeDefinition f) classr.ccrTypes heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, {classr & ccrClass = fccrClass, ccrTypes = fccrTypes}, heaps)

// -------------------------------------------------------------------------------------------------------------------------------------------------
instance changeDefinition CDataConsDef
// -------------------------------------------------------------------------------------------------------------------------------------------------
where
	changeDefinition f dcd_def heaps
		# (error, falgtype, heaps)		= f dcd_def.dcdAlgType heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fsymboltype, heaps)	= changeDefinition f dcd_def.dcdSymbolType heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, {dcd_def & dcdAlgType = falgtype, dcdSymbolType = fsymboltype}, heaps)

// -------------------------------------------------------------------------------------------------------------------------------------------------
instance changeDefinition CExpr
// -------------------------------------------------------------------------------------------------------------------------------------------------
where
	changeDefinition f (CExprVar ptr) heaps
		= (OK, CExprVar ptr, heaps)
	changeDefinition f (CShared ptr) heaps
		= (OK, CShared ptr, heaps)
	changeDefinition f (expr @# exprs) heaps
		# (error, fexpr, heaps)			= changeDefinition f expr heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fexprs, heaps)		= umapError (changeDefinition f) exprs heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, fexpr @# fexprs, heaps)
	changeDefinition f (a @@# exprs) heaps
		# (error, fa, heaps)			= f a heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fexprs, heaps)		= umapError (changeDefinition f) exprs heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, fa @@# fexprs, heaps)
	changeDefinition f (CLet strict lets expr) heaps
		# (vars, exprs)					= unzip lets
		# (error, fexprs, heaps)		= umapError (changeDefinition f) exprs heaps
		| isError error					= (error, DummyValue, heaps)
		# flets							= zip2 vars fexprs
		# (error, fexpr, heaps)			= changeDefinition f expr heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, CLet strict flets fexpr, heaps)
	changeDefinition f (CCase expr patterns defaul) heaps
		# (error, fexpr, heaps)			= changeDefinition f expr heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fpatns, heaps)		= changeDefinition f patterns heaps
		| isError error					= (error, DummyValue, heaps)
		| isNothing defaul				= (OK, CCase fexpr fpatns Nothing, heaps)
		# (error, fdefault, heaps)		= changeDefinition f (fromJust defaul) heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, CCase fexpr fpatns (Just fdefault), heaps)
	changeDefinition f (CBasicValue basicvalue) heaps
		# (error, fbasicvalue, heaps)	= changeDefinition f basicvalue heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, CBasicValue fbasicvalue, heaps)      
	changeDefinition f (CCode codetype codetexts) heaps
		= (OK, CCode codetype codetexts, heaps)
	changeDefinition f CBottom heaps
		= (OK, CBottom, heaps)

// -------------------------------------------------------------------------------------------------------------------------------------------------
instance changeDefinition CFunDef
// -------------------------------------------------------------------------------------------------------------------------------------------------
where
	changeDefinition f fun_def heaps
		# (error, fsymboltype, heaps)	= changeDefinition f fun_def.fdSymbolType heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fbody, heaps)			= changeDefinition f fun_def.fdBody heaps
		| isError error					= (error, DummyValue, heaps)
		# ok1							= fun_def.fdIsRecordSelector
		# ok2							= fun_def.fdIsRecordUpdater
		| not ok1 && not ok2			= (OK, {fun_def & fdSymbolType = fsymboltype, fdBody = fbody, fdRecordFieldDef = DummyValue}, heaps)
		# (error, ffield, heaps)		= f fun_def.fdRecordFieldDef heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, {fun_def & fdSymbolType = fsymboltype, fdBody = fbody, fdRecordFieldDef = ffield}, heaps)

// -------------------------------------------------------------------------------------------------------------------------------------------------   
instance changeDefinition CInstanceDef
// -------------------------------------------------------------------------------------------------------------------------------------------------   
where
	changeDefinition f instancedef heaps
		# (error, fclass, heaps)		= f instancedef.indClass heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, ftypes, heaps)		= umapError (changeDefinition f) instancedef.indClassArguments heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, frestrictions, heaps)	= umapError (changeDefinition f) instancedef.indClassRestrictions heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fmemberfuns, heaps)	= umapError f instancedef.indMemberFunctions heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK,	{ instancedef &
				  indClass				= fclass
				, indClassArguments		= ftypes
				, indClassRestrictions	= frestrictions
				, indMemberFunctions	= fmemberfuns
				}, heaps)

// -------------------------------------------------------------------------------------------------------------------------------------------------   
instance changeDefinition CMemberDef
// -------------------------------------------------------------------------------------------------------------------------------------------------   
where
	changeDefinition f memberdef heaps
		# (error, fclass, heaps)		= f memberdef.mbdClass heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fsymboltype, heaps)	= changeDefinition f memberdef.mbdSymbolType heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK,	{ mbdName				= memberdef.mbdName
				, mbdClass				= fclass
				, mbdSymbolType			= fsymboltype
				, mbdInfix				= memberdef.mbdInfix
				}, heaps)

// -------------------------------------------------------------------------------------------------------------------------------------------------   
instance changeDefinition CRecordFieldDef
// -------------------------------------------------------------------------------------------------------------------------------------------------   
where
	changeDefinition f rcf_def heaps
		# (error, fsymboltype, heaps)	= changeDefinition f rcf_def.rfSymbolType heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fRtype, heaps)		= f rcf_def.rfRecordType heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, {rcf_def & rfSymbolType = fsymboltype, rfRecordType = fRtype, rfSelectorFun = DummyValue, rfUpdaterFun = DummyValue}, heaps)

// -------------------------------------------------------------------------------------------------------------------------------------------------   
instance changeDefinition CRecordTypeDef
// -------------------------------------------------------------------------------------------------------------------------------------------------   
where
	changeDefinition f rct_def heaps
		# (error, ffields, heaps)		= umapError f rct_def.rtdFields heaps
		| isError error					= (error, DummyValue, heaps)
		| not rct_def.rtdIsDictionary	= (OK, {rct_def & rtdFields = ffields, rtdRecordConstructor = DummyValue, rtdClassDef = DummyValue}, heaps)
		# (error, fclass, heaps)		= f rct_def.rtdClassDef heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, {rct_def & rtdFields = ffields, rtdRecordConstructor = DummyValue, rtdClassDef = fclass}, heaps)

// -------------------------------------------------------------------------------------------------------------------------------------------------
instance changeDefinition CSymbolType
// -------------------------------------------------------------------------------------------------------------------------------------------------
where
	changeDefinition f symboltype heaps
		# fscope						= symboltype.sytTypeVarScope
		# (error, farguments, heaps)	= umapError (changeDefinition f) symboltype.sytArguments heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, fresult, heaps)		= changeDefinition f symboltype.sytResult heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, frestrictions, heaps)	= umapError (changeDefinition f) symboltype.sytClassRestrictions heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK,	{ sytArguments			= farguments
				, sytTypeVarScope		= symboltype.sytTypeVarScope
				, sytResult				= fresult
				, sytClassRestrictions	= frestrictions
				}, heaps)
                                                          
// -------------------------------------------------------------------------------------------------------------------------------------------------   
instance changeDefinition CType
// -------------------------------------------------------------------------------------------------------------------------------------------------   
where
	changeDefinition f (CTypeVar ptr) heaps
		= (OK, CTypeVar ptr, heaps)
	changeDefinition f (type1 ==> type2) heaps
		# (error, ftype1, heaps)		= changeDefinition f type1 heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, ftype2, heaps)		= changeDefinition f type2 heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, ftype1 ==> ftype2, heaps)      
	changeDefinition f (type @^ types) heaps
		# (error, ftype, heaps)			= changeDefinition f type heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, ftypes, heaps)		= umapError (changeDefinition f) types heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, ftype @^ ftypes, heaps)
	changeDefinition f (def @@^ types) heaps
		# (error, fdef, heaps)			= f def heaps
		| isError error					= (error, DummyValue, heaps)
		# (error, ftypes, heaps)		= umapError (changeDefinition f) types heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, fdef @@^ ftypes, heaps) 
	changeDefinition f (CBasicType basictype) heaps
		= (OK, CBasicType basictype, heaps)
	changeDefinition f (CStrict type) heaps
		# (error, ftype, heaps)			= changeDefinition f type heaps
		| isError error					= (error, DummyValue, heaps)
		= (OK, CStrict ftype, heaps)
	changeDefinition f CUnTypable heaps
		= (OK, CUnTypable, heaps)






















// -------------------------------------------------------------------------------------------------------------------------------------------------   
bindModule :: ![ModuleName] ![ModulePtr] !ModulePtr !*CHeaps !*CProject -> (!Error, !CModule, !*CHeaps, !*CProject)
// -------------------------------------------------------------------------------------------------------------------------------------------------   
bindModule all_names all_ptrs mod_ptr heaps prj
	# (mod, heaps)						= readPointer mod_ptr heaps
	| isNothing mod.pmCompilerStore		= (pushError (X_Internal ("Cannot bind, no CompilerStore was found for module " +++ mod.pmName +++ ".")) OK, DummyValue, heaps, prj)
	# store								= fromJust mod.pmCompilerStore
	
	# alg_ptrs							= [ptr \\ ptr <-: mod.pmCompilerConversion.ccCheckedTypePtrs | ptr <> DummyValue && ptrKind ptr == CAlgType]
	# (error, heaps, prj)				= bindAlgTypes alg_ptrs store.csAlgTypeDefs heaps prj
	| isError error						= (error, DummyValue, heaps, prj)
	
	# class_ptrs						= [ptr \\ ptr <-: mod.pmCompilerConversion.ccClassPtrs | ptr <> DummyValue]
	# (error, heaps, prj)				= bindClasses class_ptrs store.csClassDefs heaps prj
	| isError error						= (error, DummyValue, heaps, prj)
	
	# cons_ptrs							= [ptr \\ ptr <-: mod.pmCompilerConversion.ccConsPtrs | ptr <> DummyValue]
	# (error, heaps, prj)				= bindDataConses cons_ptrs store.csDataConsDefs heaps prj
	| isError error						= (error, DummyValue, heaps, prj)
	
	# fun_ptrs							= [ptr \\ ptr <-: mod.pmCompilerConversion.ccFunPtrs | ptr <> DummyValue]
	# (error, heaps, prj)				= bindFuns fun_ptrs store.csFunDefs heaps prj
	| isError error						= (error, DummyValue, heaps, prj)
	
	# instance_ptrs						= [ptr \\ ptr <-: mod.pmCompilerConversion.ccInstancePtrs | ptr <> DummyValue]
	# (error, heaps, prj)				= bindInstances instance_ptrs store.csInstanceDefs heaps prj
	| isError error						= (error, DummyValue, heaps, prj)
	
	# member_ptrs						= [ptr \\ ptr <-: mod.pmCompilerConversion.ccMemberPtrs | ptr <> DummyValue]
	# (error, heaps, prj)				= bindMembers member_ptrs store.csMemberDefs heaps prj
	| isError error						= (error, DummyValue, heaps, prj)
	
	# field_ptrs						= [ptr \\ ptr <-: mod.pmCompilerConversion.ccSelectorPtrs | ptr <> DummyValue]
	# (error, heaps, prj)				= bindRecordFields field_ptrs store.csRecordFieldDefs heaps prj
	| isError error						= (error, DummyValue, heaps, prj)
	
	# rec_ptrs							= [ptr \\ ptr <-: mod.pmCompilerConversion.ccCheckedTypePtrs | ptr <> DummyValue && ptrKind ptr == CRecordType]
	# (error, heaps, prj)				= bindRecordTypes rec_ptrs store.csRecordTypeDefs heaps prj
	| isError error						= (error, DummyValue, heaps, prj)
	
	# (_, imports)						= multiple_find mod.pmName store.csImports all_names all_ptrs
	# mod								= {mod	& pmImportedModules		= imports
												, pmAlgTypePtrs			= alg_ptrs
												, pmClassPtrs			= class_ptrs
												, pmDataConsPtrs		= cons_ptrs
												, pmFunPtrs				= fun_ptrs
												, pmInstancePtrs		= instance_ptrs
												, pmMemberPtrs			= member_ptrs
												, pmRecordFieldPtrs		= field_ptrs
												, pmRecordTypePtrs		= rec_ptrs
												, pmCompilerStore		= Nothing
										  }
	# heaps								= writePointer mod_ptr mod heaps
	= (OK, mod, heaps, prj)
	where
		bindAlgTypes :: ![HeapPtr] ![CAlgTypeDefI] !*CHeaps !*CProject -> (!Error, !*CHeaps, !*CProject)
		bindAlgTypes [ptr:ptrs] [def:defs] heaps prj
			# (error, def, heaps)		= changeDefinition (bindDefinition Nothing all_names all_ptrs) def heaps
			| isError error				= (error, heaps, prj)
			# (error, prj)				= putAlgTypeDef ptr def prj
			| isError error				= (error, heaps, prj)
			= bindAlgTypes ptrs defs heaps prj
		bindAlgTypes _ _ heaps prj
			= (OK, heaps, prj)
		
		bindClasses :: ![HeapPtr] ![CClassDefI] !*CHeaps !*CProject -> (!Error, !*CHeaps, !*CProject)
		bindClasses [ptr:ptrs] [def:defs] heaps prj
			# (error, def, heaps)		= changeDefinition (bindDefinition Nothing all_names all_ptrs) def heaps
			| isError error				= (error, heaps, prj)
			# (error, prj)				= putClassDef ptr def prj
			| isError error				= (error, heaps, prj)
			= bindClasses ptrs defs heaps prj
		bindClasses _ _ heaps prj
			= (OK, heaps, prj)
		
		bindDataConses :: ![HeapPtr] ![CDataConsDefI] !*CHeaps !*CProject -> (!Error, !*CHeaps, !*CProject)
		bindDataConses [ptr:ptrs] [def:defs] heaps prj
			# (error, def, heaps)		= changeDefinition (bindDefinition Nothing all_names all_ptrs) def heaps
			| isError error				= (error, heaps, prj)
			# (error, prj)				= putDataConsDef ptr def prj
			| isError error				= (error, heaps, prj)
			= bindDataConses ptrs defs heaps prj
		bindDataConses _ _ heaps prj
			= (OK, heaps, prj)
		
		bindFuns :: ![HeapPtr] ![CFunDefI] !*CHeaps !*CProject -> (!Error, !*CHeaps, !*CProject)
		bindFuns [ptr:ptrs] [def:defs] heaps prj
676
			# (error, def, heaps)		= changeDefinition (bindDefinition2 Nothing all_names all_ptrs) def heaps
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
			| isError error				= (error, heaps, prj)
			# (error, prj)				= putFunDef ptr def prj
			| isError error				= (error, heaps, prj)
			= bindFuns ptrs defs heaps prj
		bindFuns _ _ heaps prj
			= (OK, heaps, prj)
		
		bindInstances :: ![HeapPtr] ![CInstanceDefI] !*CHeaps !*CProject -> (!Error, !*CHeaps, !*CProject)
		bindInstances [ptr:ptrs] [def:defs] heaps prj
			# (error, def, heaps)		= changeDefinition (bindDefinition Nothing all_names all_ptrs) def heaps
			| isError error				= (error, heaps, prj)
			# (error, prj)				= putInstanceDef ptr def prj
			| isError error				= (error, heaps, prj)
			= bindInstances ptrs defs heaps prj
		bindInstances _ _ heaps prj
			= (OK, heaps, prj)
		
		bindMembers :: ![HeapPtr] ![CMemberDefI] !*CHeaps !*CProject -> (!Error, !*CHeaps, !*CProject)
		bindMembers [ptr:ptrs] [def:defs] heaps prj
			# (error, def, heaps)		= changeDefinition (bindDefinition Nothing all_names all_ptrs) def heaps
			| isError error				= (error, heaps, prj)
			# (error, prj)				= putMemberDef ptr def prj
			| isError error				= (error, heaps, prj)
			= bindMembers ptrs defs heaps prj
		bindMembers _ _ heaps prj
			= (OK, heaps, prj)
		
		bindRecordFields :: ![HeapPtr] ![CRecordFieldDefI] !*CHeaps !*CProject -> (!Error, !*CHeaps, !*CProject)
		bindRecordFields [ptr:ptrs] [def:defs] heaps prj
			# (error, def, heaps)		= changeDefinition (bindDefinition Nothing all_names all_ptrs) def heaps
			| isError error				= (error, heaps, prj)
			# (error, prj)				= putRecordFieldDef ptr def prj
			| isError error				= (error, heaps, prj)
			= bindRecordFields ptrs defs heaps prj
		bindRecordFields _ _ heaps prj
			= (OK, heaps, prj)
		
		bindRecordTypes :: ![HeapPtr] ![CRecordTypeDefI] !*CHeaps !*CProject -> (!Error, !*CHeaps, !*CProject)
		bindRecordTypes [ptr:ptrs] [def:defs] heaps prj
			# (error, def, heaps)		= changeDefinition (bindDefinition Nothing all_names all_ptrs) def heaps
			| isError error				= (error, heaps, prj)
			# (error, prj)				= putRecordTypeDef ptr def prj
			| isError error				= (error, heaps, prj)
			= bindRecordTypes ptrs defs heaps prj
		bindRecordTypes _ _ heaps prj
			= (OK, heaps, prj)