generics1.icl 270 KB
Newer Older
1
2
3
4
5
6
//**************************************************************************************
// Generic programming features 
//**************************************************************************************

implementation module generics1

7
import StdEnv,compare_types
8
import check
9
from checktypes import createMoreClassDictionaries
10
11
12
13
14
15
16
17
18
from transform import ::Group
import genericsupport

// Data types

:: FunDefs :== {#FunDef}
:: Modules :== {#CommonDefs}
:: DclModules :== {#DclModule}
:: Groups :== {!Group}
19
:: *DclMacros :== *{#*{#FunDef}}
20
21
22
23
24

:: FunsAndGroups= ! {
		fg_fun_index :: !Index,
		fg_group_index :: !Index,
		fg_funs :: ![FunDef],
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
		fg_groups :: ![Group],
		fg_bimap_functions :: !BimapFunctions
	}

:: BimapFunctions = {
		bimap_id_function :: !FunctionIndexAndIdent,
		bimap_fromto_function :: !FunctionIndexAndIdent,
		bimap_tofrom_function :: !FunctionIndexAndIdent,
		bimap_to_function :: !FunctionIndexAndIdent,
		bimap_from_function :: !FunctionIndexAndIdent,
		bimap_arrow_function :: !FunctionIndexAndIdent,
		bimap_arrow_arg_id_function :: !FunctionIndexAndIdent,
		bimap_arrow_res_id_function :: !FunctionIndexAndIdent,
		bimap_from_Bimap_function :: !FunctionIndexAndIdent,
		bimap_PAIR_function :: !FunctionIndexAndIdent,
		bimap_EITHER_function :: !FunctionIndexAndIdent,
		bimap_OBJECT_function :: !FunctionIndexAndIdent,
		bimap_CONS_function :: !FunctionIndexAndIdent,
43
		bimap_RECORD_function :: !FunctionIndexAndIdent,
44
45
46
47
48
49
		bimap_FIELD_function :: !FunctionIndexAndIdent
	}

:: FunctionIndexAndIdent = {	
		fii_index :: !Index,
		fii_ident :: Ident
50
	}
51

52
53
54
55
56
57
OBJECT_NewType_Mask:==1;
CONS_NewType_Mask:==2;
RECORD_NewType_Mask:==4;
FIELD_NewType_Mask:==8;

:: PredefinedSymbolsData = !{psd_predefs_a :: !{#PredefinedSymbol}, psd_generic_newtypes::!Int}
58

59
60
61
62
63
64
65
66
67
68
69
70
71
72
:: *GenericState = 
	{ gs_modules :: !*Modules
	, gs_exprh :: !*ExpressionHeap
	, gs_genh :: !*GenericHeap
	, gs_varh :: !*VarHeap
	, gs_tvarh :: !*TypeVarHeap
	, gs_avarh :: !*AttrVarHeap 
	, gs_error :: !*ErrorAdmin
	, gs_symtab :: !*SymbolTable
	, gs_dcl_modules :: !*DclModules
	, gs_td_infos :: !*TypeDefInfos
	, gs_funs :: !*{#FunDef}
	, gs_groups :: {!Group}
	// non-unique, read only
73
	, gs_predefs :: !PredefinedSymbolsData
74
75
76
77
	, gs_main_module :: !Index
	, gs_used_modules :: !NumberSet
	}

78
79
80
81
82
83
84
85
86
87
88
89
90
// Exported functions

convertGenerics :: 
		!Int 					// index of the main dcl module
		!NumberSet				// set of used modules
		!{#CommonDefs} 			// common definitions of all modules
		!{!Group} 				// groups of functions
		!*{# FunDef} 			// functions
		!*TypeDefInfos 			// type definition information of all modules
		!*Heaps 				// all heaps
		!*HashTable 			// needed for what creating class dictionaries
		!*PredefinedSymbols 	// predefined symbols
		!u:{# DclModule}		// dcl modules
91
		!*{#*{#FunDef}}			// dcl macros
92
93
94
95
96
97
98
99
100
		!*ErrorAdmin 			// to report errors
	->  ( !{#CommonDefs}		// common definitions of all modules
		, !{!Group}				// groups of functions
		, !*{# FunDef}			// function definitions
		, !*TypeDefInfos		// type definition infos
		, !*Heaps				// all heaps
		, !*HashTable			// needed for creating class dictinaries
		, !*PredefinedSymbols	// predefined symbols	
		, !u:{# DclModule}		// dcl modules
101
		, !*{#*{#FunDef}}		// dcl macros
102
103
		, !*ErrorAdmin			// to report errors
		)
104
convertGenerics main_dcl_module_n used_module_numbers modules groups funs td_infos heaps hash_table u_predefs dcl_modules dcl_macros error
105
106
107
108
109
110
	#! modules = {x \\ x <-: modules} 			// unique copy
	#! dcl_modules = { x \\ x <-: dcl_modules } 	// unique copy
	#! size_predefs = size u_predefs
	#! (predefs, u_predefs) = arrayCopyBegin u_predefs size_predefs // non-unique copy

	#! td_infos = clearTypeDefInfos td_infos
111
112
	#! (modules, heaps) = clearGenericDefs modules heaps

113
114
	#! generic_newtypes = determine_generic_newtypes predefs modules

115
116
117
118
119
120
121
122
123
124
125
	# {hp_var_heap, hp_generic_heap, hp_type_heaps={th_vars, th_attrs}, hp_expression_heap} = heaps
	# gs = 
		{ gs_modules = modules
		, gs_symtab = hash_table.hte_symbol_heap
		, gs_dcl_modules = dcl_modules
		, gs_td_infos = td_infos
		, gs_exprh = hp_expression_heap	
		, gs_genh = hp_generic_heap	
		, gs_varh = hp_var_heap
		, gs_tvarh = th_vars
		, gs_avarh = th_attrs
126
		, gs_error = error
127
		, gs_funs = funs
128
		, gs_groups = groups
129
		, gs_predefs = {psd_predefs_a=predefs,psd_generic_newtypes=generic_newtypes}
130
131
132
133
		, gs_main_module = main_dcl_module_n
		, gs_used_modules = used_module_numbers
		} 

134
	# (dcl_macros, gs) = convert_generics dcl_macros gs
135
136
137
138
139
140
141
142
143
144
145
146

	#	{ 	gs_modules = modules, gs_symtab, gs_dcl_modules = dcl_modules, gs_td_infos = td_infos, 
			gs_genh = hp_generic_heap, gs_varh = hp_var_heap, gs_tvarh = th_vars, gs_avarh = th_attrs, 
			gs_exprh = hp_expression_heap,	
			gs_error = error, gs_funs = funs, gs_groups = groups,
			gs_predefs = predefs, gs_main_module = main_dcl_module_n, gs_used_modules = used_module_numbers} = gs
	#! hash_table = { hash_table & hte_symbol_heap = gs_symtab }
	#! heaps = 
		{ hp_expression_heap = hp_expression_heap
		, hp_var_heap = hp_var_heap
		, hp_generic_heap = hp_generic_heap
		, hp_type_heaps = { th_vars = th_vars, th_attrs = th_attrs }
147
		}
148
	= (modules, groups, funs, td_infos, heaps, hash_table, u_predefs, dcl_modules, dcl_macros, error)
149
where
150
151
152
153
	convert_generics :: !*DclMacros !*GenericState -> (!*DclMacros, !*GenericState)
	convert_generics dcl_macros gs
		# (bimap_functions, gs) = buildGenericRepresentations gs
		| not gs.gs_error.ea_ok = (dcl_macros, gs)
154

155
		# gs = buildClasses gs
156
		| not gs.gs_error.ea_ok = (dcl_macros, gs)
157

158
159
		# (dcl_macros, gs) = convertGenericCases bimap_functions dcl_macros gs
		| not gs.gs_error.ea_ok = (dcl_macros, gs)
160
161
162

		#! gs = convertGenericTypeContexts gs

163
		= (dcl_macros, gs)
164

165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
determine_generic_newtypes :: !{#PredefinedSymbol} !{#CommonDefs} -> Int
determine_generic_newtypes predefs_a modules_cd
	= add_if_generic_newtype PD_TypeOBJECT OBJECT_NewType_Mask
	 (add_if_generic_newtype PD_TypeCONS CONS_NewType_Mask
	 (add_if_generic_newtype PD_TypeRECORD RECORD_NewType_Mask
	 (add_if_generic_newtype PD_TypeFIELD FIELD_NewType_Mask 0)))
	where
		add_if_generic_newtype :: !Int !Int !Int -> Int
		add_if_generic_newtype generic_newtype_predef_index generic_newtype_mask generic_newtypes
			# {pds_module,pds_def} = predefs_a.[generic_newtype_predef_index]
			| pds_module>=0 && pds_module<size modules_cd && pds_def>=0 && pds_def<size modules_cd.[pds_module].com_type_defs
				= case modules_cd.[pds_module].com_type_defs.[pds_def].td_rhs of
					NewType _
						-> generic_newtypes bitor generic_newtype_mask
					_
						-> generic_newtypes
			= generic_newtypes

183
184
185
// clear stuff that might have been left over
// from compilation of other icl modules

186
clearTypeDefInfos :: !*{#*{#TypeDefInfo}} -> *{#*{#TypeDefInfo}}
187
188
189
190
191
192
clearTypeDefInfos td_infos
	= clear_modules 0 td_infos
where
	clear_modules n td_infos
		| n == size td_infos
			= td_infos
193
			#! (td_infos1, td_infos) = td_infos![n]
194
			#! td_infos1 = clear_td_infos 0 td_infos1
195
			#! td_infos = {td_infos & [n]=td_infos1}
196
197
198
199
200
201
202
203
204
			= clear_modules (inc n) td_infos 
			
	clear_td_infos n td_infos 			
		| n == size td_infos
			= td_infos
			#! (td_info, td_infos) = td_infos![n]
			#! td_infos = {td_infos & [n] = {td_info & tdi_gen_rep = No}}
			= clear_td_infos (inc n) td_infos 

205
clearGenericDefs :: !*{#CommonDefs} !*Heaps -> (!*{#CommonDefs},!*Heaps)
206
207
clearGenericDefs modules heaps
	= clear_module 0 modules  heaps
208
209
210
where
	initial_gen_classes
		= createArray 32 []
211
212
213
214
215
	initial_gen_rep_conses
		= createArray 7 {grc_module = -1, grc_index = GCB_None, grc_local_fun_index = -1, grc_generic_info = -1,
						 grc_generic_instance_deps = AllGenericInstanceDependencies,
						 grc_ident={id_name="",id_info=nilPtr},
						 grc_optional_fun_type=No}
216

217
218
219
220
221
222
223
	clear_module n modules heaps
		| n == size modules
			= (modules, heaps)
			#! ({com_generic_defs}, modules) = modules![n]
			#! (com_generic_defs, heaps) = updateArraySt clear_generic_def {x\\x<-:com_generic_defs} heaps 			
			#! modules = {modules & [n].com_generic_defs = com_generic_defs}
			= clear_module (inc n) modules heaps
224

225
	clear_generic_def generic_def=:{gen_info_ptr} heaps=:{hp_generic_heap}
226
		#! (gen_info, hp_generic_heap) = readPtr gen_info_ptr hp_generic_heap
227
		# gen_info & gen_classes = initial_gen_classes, gen_rep_conses = initial_gen_rep_conses
228
229
230
231
232
233
234
		#! hp_generic_heap = writePtr gen_info_ptr gen_info hp_generic_heap
		= (generic_def, {heaps & hp_generic_heap = hp_generic_heap})
		
//	generic type representation

// generic representation is built for each type argument of
// generic cases of the current module
235
buildGenericRepresentations :: !*GenericState -> (!BimapFunctions,!*GenericState)
236
237
238
buildGenericRepresentations gs=:{gs_main_module, gs_modules, gs_funs, gs_groups}
	#! (size_funs, gs_funs) = usize gs_funs
	#! size_groups = size gs_groups
239
	#! ({com_gencase_defs}, gs_modules) = gs_modules![gs_main_module]
240
	
241
	#! gs = { gs & gs_modules = gs_modules, gs_funs = gs_funs, gs_groups = gs_groups }
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
	
	# undefined_function_and_ident = {fii_index = -1,fii_ident = undef}
	  bimap_functions = {
				bimap_id_function = undefined_function_and_ident,
				bimap_fromto_function = undefined_function_and_ident,
				bimap_tofrom_function = undefined_function_and_ident,
				bimap_to_function = undefined_function_and_ident,
				bimap_from_function = undefined_function_and_ident,
		  		bimap_arrow_function = undefined_function_and_ident,
		  		bimap_arrow_arg_id_function = undefined_function_and_ident,
		  		bimap_arrow_res_id_function = undefined_function_and_ident,
		  		bimap_from_Bimap_function = undefined_function_and_ident,
		  		bimap_PAIR_function = undefined_function_and_ident,
		  		bimap_EITHER_function = undefined_function_and_ident,
		  		bimap_OBJECT_function = undefined_function_and_ident,
		  		bimap_CONS_function = undefined_function_and_ident,
258
		  		bimap_RECORD_function = undefined_function_and_ident,
259
260
		  		bimap_FIELD_function = undefined_function_and_ident
	  		}
261
	  funs_and_groups = {fg_fun_index=size_funs, fg_group_index=size_groups, fg_funs=[], fg_groups=[],fg_bimap_functions=bimap_functions}
262
	#! (funs_and_groups, gs)
263
		= foldArraySt build_generic_representation com_gencase_defs (funs_and_groups, gs)
264

265
	# {fg_funs=new_funs,fg_groups=new_groups,fg_bimap_functions} = funs_and_groups 
266
267
268
	# {gs_funs, gs_groups} = gs
	#! gs_funs = arrayPlusRevList gs_funs new_funs
	#! gs_groups = arrayPlusRevList gs_groups new_groups
269

270
	= (fg_bimap_functions, {gs & gs_funs = gs_funs, gs_groups = gs_groups})
271
where
272
	build_generic_representation
273
			{gc_type_cons=TypeConsSymb {type_index={glob_module,glob_object}, type_ident},gc_gcf,gc_pos} 
274
275
276
			(funs_and_groups, gs)
		# (type_def,gs) = gs!gs_modules.[glob_module].com_type_defs.[glob_object]
		# (td_info, gs) = gs!gs_td_infos.[glob_module,glob_object]
277
278
279
280
281
282
283
284
		= case gc_gcf of
			GCF gc_ident {gcf_body=GCB_FunIndex fun_index}
				-> case gs.gs_funs.[fun_index].fun_body of
					TransformedBody _ 
						// does not need a generic representation
						-> (funs_and_groups, gs)
					GeneratedBody	
						// needs a generic representation
285
286
287
288
289
290
291
292
293
						-> build_generic_type_rep type_def.td_rhs type_def.td_ident glob_module glob_object td_info gc_ident.id_name gc_pos funs_and_groups gs
			GCFS gcfs
				-> build_generic_type_rep type_def.td_rhs type_def.td_ident glob_module glob_object td_info "derive generic superclass" gc_pos funs_and_groups gs
	build_generic_representation _ st
		= st

	build_generic_type_rep td_rhs type_def_ident glob_module glob_object td_info g_ident_name gc_pos funs_and_groups gs
		= case td_rhs of
			SynType _
294
295
				#  gs_error = report_derive_error g_ident_name gc_pos "a synonym type " type_def_ident.id_name gs.gs_error
				-> (funs_and_groups, {gs & gs_error = gs_error})
296
			AbstractType _
297
298
299
300
301
302
303
304
				#  gs_error = report_derive_error g_ident_name gc_pos "an abstract type " type_def_ident.id_name gs.gs_error
				-> (funs_and_groups, {gs & gs_error = gs_error})
			ExtensibleAlgType _
				#  gs_error = report_derive_error g_ident_name gc_pos "an extensible algebraic type " type_def_ident.id_name gs.gs_error
				-> (funs_and_groups, {gs & gs_error = gs_error})
			AlgConses _ _
				#  gs_error = report_derive_error g_ident_name gc_pos "an extensible algebraic type " type_def_ident.id_name gs.gs_error
				-> (funs_and_groups, {gs & gs_error = gs_error})
305
306
307
308
309
310
311
312
313
314
315
			_
				-> case td_info.tdi_gen_rep of
					Yes _
						-> (funs_and_groups, gs)	// generic representation already built
					No
						# type_def_gi = {gi_module=glob_module,gi_index=glob_object}
						# (gen_type_rep, funs_and_groups, gs)
							= buildGenericTypeRep type_def_gi funs_and_groups gs
						# td_info = {td_info & tdi_gen_rep = Yes gen_type_rep}
						# gs = {gs & gs_td_infos.[glob_module,glob_object] = td_info}
						-> (funs_and_groups, gs)
316

317
318
319
	report_derive_error g_ident_name gc_pos kind_of_type_string type_def_ident_name gs_error
		= reportError g_ident_name gc_pos ("cannot derive a generic instance for "+++kind_of_type_string+++type_def_ident_name) gs_error

320
:: TypeInfos
321
322
	= AlgebraicInfo !DefinedSymbol !DefinedSymbol ![DefinedSymbol] ![DefinedSymbol]
	| RecordInfo !DefinedSymbol !DefinedSymbol !DefinedSymbol ![DefinedSymbol]
323

324
buildGenericTypeRep :: !GlobalIndex /*type def index*/ !FunsAndGroups !*GenericState ->	(!GenericTypeRep,!FunsAndGroups,!*GenericState)
325
buildGenericTypeRep type_index funs_and_groups
326
		gs=:{gs_modules, gs_predefs, gs_main_module, gs_error, gs_td_infos, gs_exprh, gs_varh, gs_genh, gs_avarh, gs_tvarh}
327
328
329
330
331
	# heaps = 
		{ hp_expression_heap = gs_exprh
		, hp_var_heap = gs_varh
		, hp_generic_heap = gs_genh
		, hp_type_heaps = { th_vars = gs_tvarh, th_attrs = gs_avarh }
John van Groningen's avatar
John van Groningen committed
332
333
		}

334
335
	# (type_def, gs_modules) = gs_modules![type_index.gi_module].com_type_defs.[type_index.gi_index]

336
337
	# (type_infos, funs_and_groups, gs_modules, heaps, gs_error)
		= buildTypeDefInfo type_def type_index.gi_module gs_main_module gs_predefs funs_and_groups gs_modules heaps gs_error
338

Artem Alimarine's avatar
Artem Alimarine committed
339
	# (atype, (gs_modules, gs_td_infos, heaps, gs_error)) 
340
		= buildStructType type_index type_infos gs_predefs (gs_modules, gs_td_infos, heaps, gs_error)
341
342
343
344
345
346
347
348
349
350
351
	
	# (from_fun_ds, funs_and_groups, heaps, gs_error)
		= buildConversionFrom type_index.gi_module type_def gs_main_module gs_predefs funs_and_groups heaps gs_error

	# (to_fun_ds, funs_and_groups, heaps, gs_error)
		= buildConversionTo type_index.gi_module type_def gs_main_module gs_predefs funs_and_groups heaps gs_error

	# (iso_fun_ds, funs_and_groups, heaps, gs_error)
		= buildConversionIso type_def from_fun_ds to_fun_ds gs_main_module gs_predefs funs_and_groups heaps gs_error

	# {hp_expression_heap, hp_var_heap, hp_generic_heap, hp_type_heaps={th_vars, th_attrs}} = heaps
352
353
354
355
356
357
358
359
360
	# gs = {gs	& gs_modules = gs_modules
				, gs_td_infos = gs_td_infos
				, gs_error = gs_error
				, gs_avarh = th_attrs
				, gs_tvarh = th_vars
				, gs_varh = hp_var_heap
				, gs_genh = hp_generic_heap
				, gs_exprh = hp_expression_heap
		   }
361
	= ({gtr_type=atype,gtr_iso=iso_fun_ds,gtr_to=to_fun_ds,gtr_from=from_fun_ds}, funs_and_groups, gs)
362
363
364
	
//	the structure type

365
366
convertATypeToGenTypeStruct :: !Ident !Position !PredefinedSymbolsData !AType (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin) 
														   -> (GenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
367
convertATypeToGenTypeStruct ident pos {psd_predefs_a} type st
368
	= convert type st
369
where	
Artem Alimarine's avatar
Artem Alimarine committed
370
371
372
373
	convert {at_type=TA type_symb args, at_attribute} st
		= convert_type_app type_symb at_attribute args st
	convert {at_type=TAS type_symb args _, at_attribute} st
		= convert_type_app type_symb at_attribute args st
374
375
	convert {at_type=(CV tv) :@: args} st
		#! (args, st) = mapSt convert args st
376
		= (GTSAppVar tv args, st)
377
378
379
	convert {at_type=x --> y} st
		#! (x, st) = convert x st
		#! (y, st) = convert y st
380
		= (GTSArrow x y, st)
381
382
383
384
	convert {at_type=TV tv} st
		= (GTSVar tv, st)  
	convert {at_type=TB _} st
		= (GTSAppCons KindConst [], st)  
385
	convert {at_type=type} (modules, td_infos, heaps, error)
386
		# error = reportError ident.id_name pos ("can not build generic representation for this type", type) error
Artem Alimarine's avatar
Artem Alimarine committed
387
388
389
390
391
392
393
394
395
		= (GTSE, (modules, td_infos, heaps, error))

	convert_type_app {type_index} attr args (modules, td_infos, heaps, error)	
		# (type_def, modules) = modules![type_index.glob_module].com_type_defs.[type_index.glob_object]
		= case type_def.td_rhs of 
			SynType atype
				# (expanded_type, th) = expandSynonymType type_def attr args heaps.hp_type_heaps 
				-> convert {at_type = expanded_type, at_attribute = attr} 
					(modules, td_infos, {heaps & hp_type_heaps = th}, error) 
396
			_
397
				#! {pds_module, pds_def} = psd_predefs_a.[PD_UnboxedArrayType]
398
399
400
401
				| 	type_index.glob_module == pds_module
					&& type_index.glob_object == pds_def
					&& (case args of [{at_type=TB _}] -> True; _ -> False)
					-> (GTSAppCons KindConst [], (modules, td_infos, heaps, error))
402
				| otherwise
403
404
405
406
					#! ({tdi_kinds}, td_infos) = td_infos ! [type_index.glob_module,type_index.glob_object]
					#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
					#! (args, st) = mapSt  convert args (modules, td_infos, heaps, error)
					-> (GTSAppCons kind args, st)  
Artem Alimarine's avatar
Artem Alimarine committed
407

408
409
convert_bimap_AType_to_GenTypeStruct :: !AType !Position !PredefinedSymbolsData (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin) 
															 -> (GenTypeStruct, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin))
410
convert_bimap_AType_to_GenTypeStruct type pos {psd_predefs_a} st
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
	= convert type st
where
	convert {at_type=TA type_symb args, at_attribute} st
		= convert_type_app type_symb at_attribute args st
	convert {at_type=TAS type_symb args _, at_attribute} st
		= convert_type_app type_symb at_attribute args st
	convert {at_type=(CV tv) :@: args} st
		#! (args, st) = mapSt convert args st
		= (GTSAppVar tv args, st)
	convert {at_type=x --> y} st
		#! (x, st) = convert x st
		#! (y, st) = convert y st
		= (GTSArrow x y, st)  
	convert {at_type=TV tv} st
		= (GTSVar tv, st)  
	convert {at_type=TB _} st
		= (GTSAppCons KindConst [], st)  
	convert {at_type=type} (modules, td_infos, heaps, error)
429
		# error = reportError predefined_idents.[PD_GenericBimap].id_name pos ("can not build generic representation for this type", type) error
430
431
		= (GTSE, (modules, td_infos, heaps, error))

432
433
	convert_type_app {type_index=type_index=:{glob_module,glob_object},type_arity} attr args (modules, td_infos, heaps, error)
		# (type_def, modules) = modules![glob_module].com_type_defs.[glob_object]
434
435
		= case type_def.td_rhs of 
			SynType atype
436
				# (expanded_type, th) = expandSynonymType type_def attr args heaps.hp_type_heaps
437
438
				-> convert {at_type = expanded_type, at_attribute = attr} 
					(modules, td_infos, {heaps & hp_type_heaps = th}, error) 
439
			AbstractType _
440
				#! {pds_module, pds_def} = psd_predefs_a.[PD_UnboxedArrayType]
441
				| glob_module == pds_module && glob_object == pds_def
442
443
					&& (case args of [{at_type=TB _}] -> True; _ -> False)
					-> (GTSAppCons KindConst [], (modules, td_infos, heaps, error))
444
			RecordType _
445
				# {pds_module, pds_def} = psd_predefs_a.[PD_TypeBimap]
446
				| glob_module == pds_module && glob_object == pds_def
447
					&& case args of [_,_] -> True; _ -> False
448
					#! (tdi_kinds,td_infos) = td_infos![glob_module,glob_object].tdi_kinds
449
					#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
450
					#! (args, st) = convert_args args (modules, td_infos, heaps, error)
451
					-> (GTSAppBimap kind args, st)
452
453
454
455
456
457
458
459
			AlgType alts
				# n_args = length args
				| n_args>0 && type_arity==n_args
					# (can_generate_bimap_to_or_from,modules,heaps)
						= can_generate_bimap_to_or_from_for_this_type type_def glob_module alts modules heaps
					| can_generate_bimap_to_or_from
						#! (tdi_kinds,td_infos) = td_infos![glob_module,glob_object].tdi_kinds			
						#! (args, st) = convert_args args (modules, td_infos, heaps, error)
460
						-> (GTSAppConsSimpleType {gi_module=type_index.glob_module,gi_index=type_index.glob_object} (KindArrow tdi_kinds) args, st)
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
						-> 	convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
			_
				-> 	convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
	where
		convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
			#! (tdi_kinds,td_infos) = td_infos![glob_module,glob_object].tdi_kinds
			#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
			#! (args, st) = convert_args args (modules, td_infos, heaps, error)
			= (GTSAppCons kind args, st)

	can_generate_bimap_to_or_from_for_this_type :: !CheckedTypeDef !Index ![DefinedSymbol] !*Modules !*Heaps -> (!Bool,!*Modules,!*Heaps)
	can_generate_bimap_to_or_from_for_this_type type_def=:{td_args} type_def_module_n alts modules heaps=:{hp_type_heaps}
		# th_vars = number_type_arguments td_args 0 hp_type_heaps.th_vars
		#! ok = check_constructors alts type_def_module_n modules th_vars
		# th_vars = remove_type_argument_numbers td_args th_vars
		# heaps = {heaps & hp_type_heaps={hp_type_heaps & th_vars=th_vars}}
		= (ok,modules,heaps)
	where
		check_constructors :: ![DefinedSymbol] !Index !Modules !TypeVarHeap -> Bool
		check_constructors [{ds_index}:constructors] type_def_module_n modules th_vars
			# {cons_type,cons_exi_vars} = modules.[type_def_module_n].com_cons_defs.[ds_index]
			= isEmpty cons_exi_vars &&
			  isEmpty cons_type.st_context &&
			  check_constructor cons_type.st_args 0 th_vars &&
			  check_constructors constructors type_def_module_n modules th_vars
		check_constructors [] type_def_module_n modules th_vars
			= True

		check_constructor :: ![AType] !Int !TypeVarHeap -> Bool
		check_constructor [{at_type=TV {tv_info_ptr}}:atypes] used_type_vars th_vars
			= case sreadPtr tv_info_ptr th_vars of
				TVI_GenTypeVarNumber arg_n
					# arg_mask = 1<<arg_n
					| used_type_vars bitand arg_mask<>0
						-> False
						# used_type_vars = used_type_vars bitor arg_mask
						-> check_constructor atypes used_type_vars th_vars
		check_constructor [_:_] used_type_vars th_vars
			= False
		check_constructor [] used_type_vars th_vars
			= True

	convert_args args st
		= mapSt convert args st
505
506

// the structure type of a generic type can often be simplified
Artem Alimarine's avatar
Artem Alimarine committed
507
// because bimaps for types not containing generic variables are indentity bimaps
508
509
simplify_bimap_GenTypeStruct :: ![TypeVar] !GenTypeStruct !*Heaps -> (!GenTypeStruct, !*Heaps)
simplify_bimap_GenTypeStruct gvars type heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}} 
510
511
512
513
	#! th_vars = foldSt mark_type_var gvars th_vars
	#! (type, th_vars) = simplify type th_vars
	#! th_vars = foldSt clear_type_var gvars th_vars 
	= (type, { heaps & hp_type_heaps = { hp_type_heaps & th_vars = th_vars}})
Artem Alimarine's avatar
Artem Alimarine committed
514
515
516
517
518
519
where
	simplify t=:(GTSAppCons KindConst [])  st
		= (t, st)
	simplify (GTSAppCons kind=:(KindArrow kinds) args) st
		# formal_arity = length kinds
		# actual_arity = length args
520
521
522
523
524
		# contains_gen_vars = occurs_list args st
		| formal_arity == actual_arity && not contains_gen_vars
			= (GTSAppConsBimapKindConst, st)
			# (args, st) = mapSt simplify args st
			= (GTSAppCons kind args, st)
525
526
527
528
529
530
	simplify (GTSAppConsSimpleType type_symbol_n kind args) st
		# contains_gen_vars = occurs_list args st
		| not contains_gen_vars
			= (GTSAppConsBimapKindConst, st)
			# (args, st) = mapSt simplify args st
			= (GTSAppConsSimpleType type_symbol_n kind args, st)
531
532
533
534
535
536
	simplify t=:(GTSAppBimap KindConst [])  st
		= (t, st)
	simplify (GTSAppBimap kind=:(KindArrow kinds) args) st
		# formal_arity = length kinds
		# actual_arity = length args
		# contains_gen_vars = occurs_list args st
Artem Alimarine's avatar
Artem Alimarine committed
537
		| formal_arity == actual_arity && not contains_gen_vars
538
			= (GTSAppConsBimapKindConst, st)
Artem Alimarine's avatar
Artem Alimarine committed
539
			# (args, st) = mapSt simplify args st
540
			= (GTSAppBimap kind args, st)
Artem Alimarine's avatar
Artem Alimarine committed
541
	simplify (GTSArrow x y) st
542
543
544
545
546
547
		# contains_gen_vars = occurs2 x y st
		| not contains_gen_vars
			= (GTSAppConsBimapKindConst, st)
			# (x, st) = simplify x st
			# (y, st) = simplify y st
			= (GTSArrow x y, st)
Artem Alimarine's avatar
Artem Alimarine committed
548
549
550
551
552
	simplify (GTSAppVar tv args) st
		# (args, st) = mapSt simplify args st
		= (GTSAppVar tv args, st)	
	simplify t=:(GTSVar tv) st
		= (t, st)
553
554
555
556
557
558
559
560
	simplify (GTSPair x y) st
		# (x, st) = simplify x st
		# (y, st) = simplify y st
		= (GTSPair x y, st)
	simplify (GTSEither x y) st
		# (x, st) = simplify x st
		# (y, st) = simplify y st
		= (GTSEither x y, st)
561
	simplify (GTSCons cons_info_ds cons_index type_info gen_type_ds x) st
562
		# (x, st) = simplify x st
563
564
		= (GTSCons cons_info_ds cons_index type_info gen_type_ds x, st)
	simplify (GTSRecord cons_info_ds type_index gen_type_ds field_list_ds x) st
565
		# (x, st) = simplify x st
566
567
		= (GTSRecord cons_info_ds type_index gen_type_ds field_list_ds x, st)
	simplify (GTSField field_info_ds field_index record_info_ds x) st
568
		# (x, st) = simplify x st
569
570
		= (GTSField field_info_ds field_index record_info_ds x, st)
	simplify (GTSObject type_info_ds type_index cons_desc_list_ds x) st
571
		# (x, st) = simplify x st
572
573
574
575
		= (GTSObject type_info_ds type_index cons_desc_list_ds x, st)
	simplify GTSUnit st
		= (GTSUnit, st)

Artem Alimarine's avatar
Artem Alimarine committed
576
	occurs (GTSAppCons _ args) st 	= occurs_list args st
577
	occurs (GTSAppConsSimpleType _ _ args) st 	= occurs_list args st
578
	occurs (GTSAppBimap _ args) st 	= occurs_list args st
579
	occurs (GTSAppVar tv args) st 	= type_var_occurs tv st || occurs_list args st		
Artem Alimarine's avatar
Artem Alimarine committed
580
	occurs (GTSVar tv) st			= type_var_occurs tv st
581
582
583
	occurs (GTSArrow x y) st 		= occurs2 x y st
	occurs (GTSPair x y) st			= occurs2 x y st
	occurs (GTSEither x y) st		= occurs2 x y st
584
585
586
587
588
	occurs (GTSCons _ _ _ _ arg) st = occurs arg st
	occurs (GTSRecord _ _ _ _ arg) st = occurs arg st
	occurs (GTSField _ _ _ arg) st	= occurs arg st	
	occurs (GTSObject _ _ _ arg) st	= occurs arg st	
	occurs GTSUnit st				= False
589
	occurs GTSE st 					= False
Artem Alimarine's avatar
Artem Alimarine committed
590

591
592
593
594
595
	occurs2 x y st
		= occurs x st || occurs y st

	occurs_list [] st
		= False
Artem Alimarine's avatar
Artem Alimarine committed
596
	occurs_list [x:xs] st 
597
		= occurs x st || occurs_list xs st
Artem Alimarine's avatar
Artem Alimarine committed
598
599

	type_var_occurs tv th_vars
600
601
602
		= case sreadPtr tv.tv_info_ptr th_vars of
			TVI_Empty = False
			TVI_Used = True
Artem Alimarine's avatar
Artem Alimarine committed
603
604
605
606
607
608

	mark_type_var tv=:{tv_info_ptr} th_vars 
		# (tv_info, th_vars) = readPtr tv_info_ptr th_vars
		= case tv_info of
			TVI_Empty = writePtr tv_info_ptr TVI_Used th_vars 
			_ = abort "type var is not empty"
609

Artem Alimarine's avatar
Artem Alimarine committed
610
611
	clear_type_var {tv_info_ptr} th_vars
		= writePtr tv_info_ptr TVI_Empty th_vars 
612
613

buildStructType ::
Artem Alimarine's avatar
Artem Alimarine committed
614
		!GlobalIndex				// type def global index
615
		!TypeInfos					// type, constructor and field info symbols
616
		!PredefinedSymbolsData
Artem Alimarine's avatar
Artem Alimarine committed
617
		(!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
618
	-> 	( !GenTypeStruct			// the structure type
Artem Alimarine's avatar
Artem Alimarine committed
619
		, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
620
		)
621
buildStructType {gi_module,gi_index} type_infos predefs (modules, td_infos, heaps, error)
622
	# (type_def=:{td_ident}, modules) = modules![gi_module].com_type_defs.[gi_index]	
623
	= build_type type_def type_infos (modules, td_infos, heaps, error)	
624
where
625
626
	build_type {td_rhs=AlgType alts, td_ident, td_pos} (AlgebraicInfo type_info cons_desc_list_ds gen_type_dss cons_infos) st
		# (cons_args, st) = zipWith3St (build_alt td_ident td_pos type_info) alts cons_infos gen_type_dss st
Artem Alimarine's avatar
Artem Alimarine committed
627
		# type = build_sum_type cons_args
628
		= (GTSObject type_info {gi_module=gi_module,gi_index=gi_index} cons_desc_list_ds type, st)
629
	build_type
630
631
			{td_rhs=RecordType {rt_constructor,rt_fields}, td_ident, td_pos} 
			(RecordInfo ci_record_info gen_type_ds field_list_ds ci_field_infos)
632
633
634
635
			(modules, td_infos, heaps, error)
		# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[rt_constructor.ds_index]
		| isEmpty cons_exi_vars
			# (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)		
636
			# args = [GTSField fi {gi_module=gi_module,gi_index=fs_index} ci_record_info arg \\ arg <- args & fi <- ci_field_infos & {fs_index}<-:rt_fields]
637
			# prod_type = build_prod_type args
638
			= (GTSRecord ci_record_info {gi_module=gi_module,gi_index=gi_index} gen_type_ds field_list_ds prod_type, st)
639
			# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
640
			= (GTSE, (modules, td_infos, heaps, error))
641
	build_type {td_rhs=SynType type,td_ident, td_pos} type_infos (modules, td_infos, heaps, error)
642
		# error = reportError td_ident.id_name td_pos "cannot build a generic representation of a synonym type" error
Artem Alimarine's avatar
Artem Alimarine committed
643
		= (GTSE, (modules, td_infos, heaps, error))
644
	build_type td=:{td_rhs=(AbstractType _),td_ident, td_arity, td_args, td_pos} type_infos (modules, td_infos, heaps, error)
645
		# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an abstract type" error
Artem Alimarine's avatar
Artem Alimarine committed
646
		= (GTSE, (modules, td_infos, heaps, error))
647

648
	build_alt td_ident td_pos type_info cons_def_sym=:{ds_index} cons_info gen_type_ds (modules, td_infos, heaps, error)
649
650
651
		# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[ds_index]
		| isEmpty cons_exi_vars
			# (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)	
652
			# prod_type = build_prod_type args
653
			= (GTSCons cons_info {gi_module=gi_module,gi_index=ds_index} type_info gen_type_ds prod_type, st)
654
			# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
655
			= (GTSE, (modules, td_infos, heaps, error))
656
657
658
659
660

	build_prod_type :: [GenTypeStruct] -> GenTypeStruct
	build_prod_type types 
		= listToBin build_pair build_unit types	
	where
661
		build_pair x y = GTSPair x y
662
		build_unit = GTSUnit // GTSAppCons KindConst []	
663

664
665
666
667
	build_sum_type :: [GenTypeStruct] -> GenTypeStruct
	build_sum_type types
		= listToBin build_either build_void types
	where
668
		build_either x y = GTSEither x y
669
		build_void = abort "sanity check: no alternatives in a type\n"		
John van Groningen's avatar
John van Groningen committed
670

671
672
673
674
675
676
677
678
// build a binary representation of a list
listToBin :: (a a -> a) a [a] -> a 
listToBin bin tip [] = tip
listToBin bin tip [x] = x
listToBin bin tip xs
	# (l,r) = splitAt ((length xs) / 2) xs
	= bin (listToBin bin tip l) (listToBin bin tip r)

679
680
681
//	build type infos
buildTypeDefInfo :: 
		!CheckedTypeDef		// the type definition
682
		!Index 				// type def module
683
		!Index				// icl module
684
		!PredefinedSymbolsData
685
		!FunsAndGroups !*Modules !*Heaps !*ErrorAdmin
686
687
688
689
690
691
	-> 	(!TypeInfos, !FunsAndGroups, !*Modules, !*Heaps, !*ErrorAdmin)
buildTypeDefInfo td=:{td_rhs = AlgType alts} td_module main_module_index predefs funs_and_groups modules heaps error
	= buildAlgebraicTypeDefInfo td alts td_module main_module_index predefs funs_and_groups modules heaps error
buildTypeDefInfo td=:{td_rhs = RecordType {rt_constructor, rt_fields}} td_module main_module_index predefs funs_and_groups modules heaps error
	= buildRecordTypeDefInfo td rt_constructor [x\\x<-:rt_fields] td_module main_module_index predefs funs_and_groups modules heaps error
buildTypeDefInfo td=:{td_rhs = SynType type, td_ident, td_pos} td_module main_module_index predefs funs_and_groups modules heaps error
692
	# error = reportError td_ident.id_name td_pos "cannot build constructor information for a synonym type" error
693
694
	= buildAlgebraicTypeDefInfo td [] td_module main_module_index predefs funs_and_groups modules heaps error
buildTypeDefInfo td=:{td_rhs = AbstractType _, td_ident, td_pos} td_module main_module_index predefs funs_and_groups modules heaps error
695
	# error = reportError td_ident.id_name td_pos "cannot build constructor information for an abstract type" error
696
	= buildAlgebraicTypeDefInfo td [] td_module main_module_index predefs funs_and_groups modules heaps error
697

698
buildAlgebraicTypeDefInfo {td_ident, td_pos, td_arity} alts td_module main_module_index predefs
699
				funs_and_groups=:{fg_fun_index=fun_index,fg_group_index=group_index,fg_funs=funs,fg_groups=groups} modules heaps error
700
701
702
703

	# num_conses = length alts
	# new_group_index = inc group_index

704
705
706
707
708
	# cons_desc_list_index = fun_index
	  type_def_dsc_index = cons_desc_list_index + 1
	  first_gen_type_index = type_def_dsc_index + 1
	  first_cons_dsc_index = first_gen_type_index + num_conses
	  new_fun_index = first_cons_dsc_index + num_conses
709
710
711

	# group = {group_members = [fun_index .. new_fun_index - 1]}
	# new_groups = [group:groups]
712

713
714
715
716
717
718
	# cons_desc_list_ds = {ds_arity=0, ds_ident=makeIdent ("cli_"+++td_ident.id_name), ds_index=cons_desc_list_index}
	  type_def_dsc_ds = {ds_arity=0, ds_ident=makeIdent ("tdi_"+++td_ident.id_name), ds_index=type_def_dsc_index}
	  gen_type_dss = [ {ds_arity=0, ds_ident=makeIdent ("gti_"+++ds_ident.id_name), ds_index=i} \\ 
		{ds_ident} <- alts & i <- [first_gen_type_index .. first_gen_type_index + num_conses - 1]]
	  cons_dsc_dss = [ {ds_arity=0, ds_ident=makeIdent ("cdi_"+++ds_ident.id_name), ds_index=i} \\ 
		{ds_ident} <- alts & i <- [first_cons_dsc_index .. first_cons_dsc_index + num_conses - 1]]
719

720
	# (cons_desc_list_fun, heaps) = build_cons_desc_list_function group_index cons_desc_list_ds cons_dsc_dss heaps	
721

722
	  (type_def_dsc_fun, heaps) = build_type_def_dsc group_index /*cons_dsc_dss*/ type_def_dsc_ds cons_desc_list_ds heaps	
Artem Alimarine's avatar
Artem Alimarine committed
723

724
	  (gen_type_dsc_funs, (modules, heaps)) = zipWithSt (build_gen_type_function group_index main_module_index td_module td_pos predefs) gen_type_dss alts (modules, heaps)
725

726
	  (cons_dsc_funs, (modules, heaps)) = zipWith3St (build_cons_dsc group_index type_def_dsc_ds) cons_dsc_dss gen_type_dss alts (modules, heaps)
727

728
729
730
731
	// NOTE: reverse order (new functions are added at the head) 
	# new_funs = reverse cons_dsc_funs ++ reverse gen_type_dsc_funs ++ [type_def_dsc_fun, cons_desc_list_fun : funs] 

	# funs_and_groups = {funs_and_groups & fg_fun_index=new_fun_index, fg_group_index=new_group_index, fg_funs=new_funs, fg_groups=new_groups}
732

733
	# cons_infos = AlgebraicInfo type_def_dsc_ds cons_desc_list_ds gen_type_dss cons_dsc_dss
734
735

	= (cons_infos, funs_and_groups, modules, heaps, error)
736
where
737
	build_cons_desc_list_function group_index {ds_ident} cons_info_dss heaps
738
		# (cons_info_exprs, heaps) = mapSt (\x st->buildFunApp main_module_index x [] st) cons_info_dss heaps
739
740
741
		# (gtd_conses_expr, heaps) = makeListExpr cons_info_exprs predefs heaps // gtd_conses
		# fun = makeFunction ds_ident group_index [] gtd_conses_expr No main_module_index td_pos
		= (fun, heaps)
742

743
	build_type_def_dsc group_index /*cons_info_dss*/ {ds_ident} cons_desc_list_ds heaps
744
745
746
747
748
749
750
		# td_name_expr = makeStringExpr td_ident.id_name // gtd_name
		# td_arity_expr = makeIntExpr td_arity // gtd_arity
		# num_conses_expr = makeIntExpr (length alts) // gtd_num_conses
		# (gtd_conses_expr, heaps) = buildFunApp main_module_index cons_desc_list_ds [] heaps // gtd_conses
		# (body_expr, heaps) = buildPredefConsApp PD_CGenericTypeDefDescriptor
			[td_name_expr, td_arity_expr, num_conses_expr, gtd_conses_expr] // TODO: module_name_expr
			predefs heaps
751
		# fun = makeFunction ds_ident group_index [] body_expr No main_module_index td_pos
752
753
		= (fun, heaps)

754
	build_cons_dsc group_index type_def_info_ds {ds_ident} gen_type_ds cons_ds (modules, heaps)
755
		# ({cons_ident,cons_type,cons_priority,cons_number,cons_exi_vars}, modules)
756
757
758
759
760
761
762
763
			= modules![td_module].com_cons_defs.[cons_ds.ds_index]
		# name_expr 			 = makeStringExpr cons_ident.id_name // gcd_name
		# arity_expr 			 = makeIntExpr cons_type.st_arity // gcd_arity
		# (prio_expr, heaps)	 = make_prio_expr cons_priority predefs heaps // gcd_prio
		# (type_def_expr, heaps) = buildFunApp main_module_index type_def_info_ds [] heaps // gcd_type_def
		# (type_expr, heaps)	 = buildFunApp main_module_index gen_type_ds [] heaps // gcd_type
		# cons_index_expr		 = makeIntExpr cons_number // gcd_index
		# (body_expr, heaps)
764
			= buildPredefConsApp PD_CGenericConsDescriptor 
765
				[name_expr, arity_expr, prio_expr, type_def_expr, type_expr, cons_index_expr]
766
				predefs heaps
767
		# fun = makeFunction ds_ident group_index [] body_expr No main_module_index td_pos		
768
		= (fun, (modules, heaps))
769

770
771
772
773
774
775
776
777
778
779
780
781
782
make_prio_expr NoPrio predefs heaps
	= buildPredefConsApp PD_CGenConsNoPrio [] predefs heaps
make_prio_expr (Prio assoc prio) predefs heaps
	# assoc_predef = case assoc of
		NoAssoc 	-> PD_CGenConsAssocNone 
		LeftAssoc 	-> PD_CGenConsAssocLeft
		RightAssoc 	-> PD_CGenConsAssocRight
	# (assoc_expr, heaps) = buildPredefConsApp assoc_predef [] predefs heaps 	
	# prio_expr = makeIntExpr prio
	= buildPredefConsApp PD_CGenConsPrio [assoc_expr, prio_expr] predefs heaps 

buildRecordTypeDefInfo {td_ident, td_pos, td_arity} alt fields td_module main_module_index predefs
				funs_and_groups=:{fg_fun_index=fun_index,fg_group_index=group_index,fg_funs=funs,fg_groups=groups} modules heaps error
783

784
785
	# num_fields = length fields
	# new_group_index = inc group_index
786

787
788
789
790
791
	# gen_type_index = fun_index
	  field_list_index = gen_type_index + 1
	  cons_dsc_index = field_list_index + 1
	  first_field_dsc_index = cons_dsc_index + 1
	  new_fun_index = first_field_dsc_index + num_fields
792

793
794
	# group = {group_members = [fun_index .. new_fun_index - 1]}
	# new_groups = [group:groups]
795

796
797
798
799
800
	# gen_type_ds = {ds_arity=0, ds_ident=makeIdent ("gti_"+++alt.ds_ident.id_name), ds_index=gen_type_index}
	  field_list_ds = {ds_arity=0, ds_ident=makeIdent ("fli_"+++alt.ds_ident.id_name), ds_index=field_list_index}
	  record_dsc_ds = {ds_arity=0, ds_ident=makeIdent ("rdi_"+++alt.ds_ident.id_name), ds_index=cons_dsc_index}
	  field_dsc_dss = [ {ds_arity=0, ds_ident=makeIdent ("fdi_"+++fs_ident.id_name), ds_index=i} \\ 
		{fs_ident} <- fields & i <- [first_field_dsc_index .. first_field_dsc_index + num_fields - 1]]
801

802
	# (gen_type_dsc_fun, (modules, heaps)) = build_gen_type_function group_index main_module_index td_module td_pos predefs gen_type_ds alt (modules, heaps)
803

804
	  (field_list_fun, (modules, heaps)) = build_field_list_function group_index field_list_ds (modules, heaps)
805

806
	  (record_dsc_fun, (modules, heaps)) = build_record_dsc group_index td_ident record_dsc_ds gen_type_ds field_list_ds alt (modules, heaps)
807

808
809
810
811
	  (field_dsc_funs, (modules, heaps)) = zipWithSt (build_field_dsc group_index record_dsc_ds) field_dsc_dss fields (modules, heaps)
	 
	// NOTE: reverse order (new functions are added at the head) 
	# new_funs = reverse field_dsc_funs ++ [record_dsc_fun, field_list_fun, gen_type_dsc_fun : funs]
812

813
	# funs_and_groups = {funs_and_groups & fg_fun_index=new_fun_index, fg_group_index=new_group_index, fg_funs=new_funs, fg_groups=new_groups}
Artem Alimarine's avatar
Artem Alimarine committed
814

815
	# cons_infos = RecordInfo record_dsc_ds gen_type_ds field_list_ds field_dsc_dss
Artem Alimarine's avatar
Artem Alimarine committed
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
	= (cons_infos, funs_and_groups, modules, heaps, error)
where
	build_field_list_function group_index field_list_ds (modules, heaps)
		# field_exprs		 	 = [makeStringExpr id_name \\ {fs_ident={id_name}}<-fields]
		# (fields_expr, heaps)   = makeListExpr field_exprs predefs heaps // grd_fields
		# fun = makeFunction field_list_ds.ds_ident group_index [] fields_expr No main_module_index td_pos		
		= (fun, (modules, heaps))

	build_record_dsc group_index td_ident cons_info_ds gen_type_ds field_list_ds cons_ds (modules, heaps)
		# ({cons_ident,cons_type,cons_priority,cons_number}, modules)
			= modules![td_module].com_cons_defs.[cons_ds.ds_index]
		# name_expr 			 = makeStringExpr td_ident.id_name /*cons_ident.id_name*/ // grd_name
		# arity_expr 			 = makeIntExpr cons_type.st_arity // grd_arity
		# td_arity_expr 		 = makeIntExpr td_arity // grd_type_arity
		# (type_expr, heaps)	 = buildFunApp main_module_index gen_type_ds [] heaps // grd_type
		# (fields_expr, heaps)	 = buildFunApp main_module_index field_list_ds [] heaps // grd_fields
		# (body_expr, heaps)
			= buildPredefConsApp PD_CGenericRecordDescriptor
				[name_expr, arity_expr, td_arity_expr, type_expr, fields_expr]
				predefs heaps
		# fun = makeFunction cons_info_ds.ds_ident group_index [] body_expr No main_module_index td_pos		
		= (fun, (modules, heaps))

	build_field_dsc group_index record_dsc_ds field_dsc_ds {fs_ident, fs_index} (modules, heaps)
		# ({sd_field_nr}, modules)
			= modules![td_module].com_selector_defs.[fs_index]
		# name_expr = makeStringExpr fs_ident.id_name // gfd_name
		# index_expr = makeIntExpr sd_field_nr // gfd_index
		# (cons_expr, heaps) = buildFunApp main_module_index record_dsc_ds [] heaps // gfd_cons
Artem Alimarine's avatar
Artem Alimarine committed
846
		# (body_expr, heaps) 
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
			= buildPredefConsApp PD_CGenericFieldDescriptor 
				[name_expr, index_expr, cons_expr]
				predefs heaps
		# fun = makeFunction field_dsc_ds.ds_ident group_index [] body_expr No main_module_index td_pos		
		= (fun, (modules, heaps))

build_gen_type_function group_index main_module_index td_module td_pos predefs cons_info_ds cons_ds (modules, heaps)
	# ({cons_type,cons_exi_vars}, modules) = modules![td_module].com_cons_defs.[cons_ds.ds_index]
	# (type_expr, heaps) 	 = make_type_expr cons_exi_vars cons_type heaps
	# fun = makeFunction cons_info_ds.ds_ident group_index [] type_expr No main_module_index td_pos		
	= (fun, (modules, heaps))
where
	make_type_expr [] {st_vars, st_args, st_result} heaps=:{hp_type_heaps=type_heaps=:{th_vars}}
		# (_,th_vars) = foldSt (\ {tv_info_ptr} (n, th_vars) -> (n+1, writePtr tv_info_ptr (TVI_GenTypeVarNumber n) th_vars)) st_vars (0,th_vars)
		# heaps = {heaps & hp_type_heaps={type_heaps & th_vars=th_vars}}
		# (arg_exprs, heaps) = mapSt make_expr1 st_args heaps
		# (result_expr, heaps) = make_expr1 st_result heaps
		# {hp_type_heaps=type_heaps=:{th_vars}} = heaps
		# th_vars = foldSt (\ {tv_info_ptr} th_vars -> writePtr tv_info_ptr TVI_Empty th_vars) st_vars th_vars
		# heaps = {heaps & hp_type_heaps={type_heaps & th_vars=th_vars}}
		= curry arg_exprs result_expr heaps
	where
		curry [] result_expr heaps 
			= (result_expr, heaps)
		curry [x:xs] result_expr heaps
			# (y, heaps) = curry xs result_expr heaps
			= make_arrow x y heaps

		make_expr1 :: !AType !*Heaps -> (!Expression, !*Heaps)
		make_expr1 {at_type} heaps = make_expr at_type heaps

		make_expr :: !Type !*Heaps -> (!Expression, !*Heaps)
		make_expr (TA type_symb arg_types) heaps
			# (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
			# (type_cons, heaps) = make_type_cons type_symb.type_ident.id_name heaps 
			= make_apps type_cons arg_exprs heaps
		make_expr (TAS type_symb arg_types _) heaps
			# (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
			# (type_cons, heaps) = make_type_cons type_symb.type_ident.id_name heaps 
			= make_apps type_cons arg_exprs heaps
		make_expr (x --> y) heaps
			# (x, heaps) = make_expr1 x heaps
			# (y, heaps) = make_expr1 y heaps				
			= make_arrow x y heaps
		make_expr TArrow heaps 
			= make_type_cons "(->)" heaps
		make_expr (TArrow1 type) heaps
			# (arg_expr, heaps) = make_expr1 type heaps 
			# (arrow_expr, heaps) = make_type_cons "(->)" heaps
			= make_app arrow_expr arg_expr heaps
		make_expr (CV {tv_info_ptr} :@: arg_types) heaps
			# (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
			# (tv_expr, heaps) = make_type_var tv_info_ptr heaps
			= make_apps tv_expr arg_exprs heaps
		make_expr (TB bt) heaps
			= make_type_cons (toString bt) heaps	
		make_expr (TV {tv_info_ptr}) heaps 
			= make_type_var tv_info_ptr heaps 
		make_expr (GTV {tv_info_ptr}) heaps
			= make_type_var tv_info_ptr heaps 
		make_expr TE heaps
			= make_error_type_cons heaps
		make_expr (TFA _ _) heaps
			// error is reported in convertATypeToGenTypeStruct
			= make_error_type_cons heaps
912
913
914
		make_expr (TFAC _ _ _) heaps
			// error is reported in convertATypeToGenTypeStruct
			= make_error_type_cons heaps
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
		make_expr _ heaps
			= abort "type does not match\n"

		make_apps x [] heaps 
			= (x, heaps)
		make_apps x [y:ys] heaps
			# (z, heaps) =