generics1.icl 273 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
convertATypeToGenTypeStruct :: !Ident !Position !PredefinedSymbolsData !AType (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
366
														   -> (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
convert_bimap_AType_to_GenTypeStruct :: !AType !Position !PredefinedSymbolsData (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
409
															 -> (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
642
643
	build_type {td_rhs=NewType cons, td_ident, td_pos} (AlgebraicInfo type_info cons_desc_list_ds _ _) st
		# (type, st) = build_newtype_alt td_ident td_pos cons st
		= (GTSObject type_info {gi_module=gi_module,gi_index=gi_index} cons_desc_list_ds type, st)
644
	build_type {td_rhs=SynType type,td_ident, td_pos} type_infos (modules, td_infos, heaps, error)
645
		# 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
646
		= (GTSE, (modules, td_infos, heaps, error))
647
	build_type td=:{td_rhs=(AbstractType _),td_ident, td_arity, td_args, td_pos} type_infos (modules, td_infos, heaps, error)
648
		# 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
649
		= (GTSE, (modules, td_infos, heaps, error))
650

651
	build_alt td_ident td_pos type_info cons_def_sym=:{ds_index} cons_info gen_type_ds (modules, td_infos, heaps, error)
652
653
654
		# ({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)	
655
			# prod_type = build_prod_type args
656
			= (GTSCons cons_info {gi_module=gi_module,gi_index=ds_index} type_info gen_type_ds prod_type, st)
657
			# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
658
			= (GTSE, (modules, td_infos, heaps, error))
659

660
661
662
663
664
665
666
667
	build_newtype_alt td_ident td_pos cons_def_sym=:{ds_index} (modules, td_infos, heaps, error)
		# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[ds_index]
		| isEmpty cons_exi_vars
			# st_arg = case st_args of [st_arg] -> st_arg;
			= convertATypeToGenTypeStruct td_ident td_pos predefs st_arg (modules, td_infos, heaps, error)	
			# error = reportError td_ident.id_name td_pos "cannot build a generic representation of an existential type" error
			= (GTSE, (modules, td_infos, heaps, error))

668
669
670
671
	build_prod_type :: [GenTypeStruct] -> GenTypeStruct
	build_prod_type types 
		= listToBin build_pair build_unit types	
	where
672
		build_pair x y = GTSPair x y
673
		build_unit = GTSUnit // GTSAppCons KindConst []	
674

675
676
677
678
	build_sum_type :: [GenTypeStruct] -> GenTypeStruct
	build_sum_type types
		= listToBin build_either build_void types
	where
679
		build_either x y = GTSEither x y
680
		build_void = abort "sanity check: no alternatives in a type\n"		
John van Groningen's avatar
John van Groningen committed
681

682
683
684
685
686
687
688
689
// 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)

690
691
692
//	build type infos
buildTypeDefInfo :: 
		!CheckedTypeDef		// the type definition
693
		!Index 				// type def module
694
		!Index				// icl module
695
		!PredefinedSymbolsData
696
		!FunsAndGroups !*Modules !*Heaps !*ErrorAdmin
697
698
699
700
701
	-> 	(!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
702
703
buildTypeDefInfo td=:{td_rhs = NewType cons} td_module main_module_index predefs funs_and_groups modules heaps error
	= buildAlgebraicTypeDefInfo td [cons] td_module main_module_index predefs funs_and_groups modules heaps error
704
buildTypeDefInfo td=:{td_rhs = SynType type, td_ident, td_pos} td_module main_module_index predefs funs_and_groups modules heaps error
705
	# error = reportError td_ident.id_name td_pos "cannot build constructor information for a synonym type" error
706
707
	= 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
708
	# error = reportError td_ident.id_name td_pos "cannot build constructor information for an abstract type" error
709
	= buildAlgebraicTypeDefInfo td [] td_module main_module_index predefs funs_and_groups modules heaps error
710

711
buildAlgebraicTypeDefInfo {td_ident,td_pos,td_arity,td_rhs} alts td_module main_module_index predefs
712
				funs_and_groups=:{fg_fun_index=fun_index,fg_group_index=group_index,fg_funs=funs,fg_groups=groups} modules heaps error
713
714
715
716

	# num_conses = length alts
	# new_group_index = inc group_index

717
718
719
720
721
	# 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
722
723
724

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

726
727
728
729
730
731
	# 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]]
732

733
	# (cons_desc_list_fun, heaps) = build_cons_desc_list_function group_index cons_desc_list_ds cons_dsc_dss heaps	
734

735
	  (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
736

737
	  (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)
738

739
	  (cons_dsc_funs, (modules, heaps)) = zipWith3St (build_cons_dsc group_index type_def_dsc_ds) cons_dsc_dss gen_type_dss alts (modules, heaps)
740

741
742
743
744
	// 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}
745

746
	# cons_infos = AlgebraicInfo type_def_dsc_ds cons_desc_list_ds gen_type_dss cons_dsc_dss
747
748

	= (cons_infos, funs_and_groups, modules, heaps, error)
749
where
750
	build_cons_desc_list_function group_index {ds_ident} cons_info_dss heaps
751
		# (cons_info_exprs, heaps) = mapSt (\x st->buildFunApp main_module_index x [] st) cons_info_dss heaps
752
753
754
		# (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)
755

756
	build_type_def_dsc group_index /*cons_info_dss*/ {ds_ident} cons_desc_list_ds heaps
757
758
		# td_name_expr = makeStringExpr td_ident.id_name // gtd_name
		# td_arity_expr = makeIntExpr td_arity // gtd_arity
759
		# num_conses_expr = makeIntExpr (case td_rhs of AlgType alts -> length alts; _ -> 0) // gtd_num_conses
760
761
762
763
		# (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
764
		# fun = makeFunction ds_ident group_index [] body_expr No main_module_index td_pos
765
766
		= (fun, heaps)

767
	build_cons_dsc group_index type_def_info_ds {ds_ident} gen_type_ds cons_ds (modules, heaps)
768
		# ({cons_ident,cons_type,cons_priority,cons_number,cons_exi_vars}, modules)
769
770
771
772
773
774
775
776
			= 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)
777
			= buildPredefConsApp PD_CGenericConsDescriptor 
778
				[name_expr, arity_expr, prio_expr, type_def_expr, type_expr, cons_index_expr]
779
				predefs heaps
780
		# fun = makeFunction ds_ident group_index [] body_expr No main_module_index td_pos		
781
		= (fun, (modules, heaps))
782

783
784
785
786
787
788
789
790
791
792
793
794
795
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
796

797
798
	# num_fields = length fields
	# new_group_index = inc group_index
799

800
801
802
803
804
	# 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
805

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

809
810
811
812
813
	# 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]]
814

815
	# (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)
816

817
	  (field_list_fun, (modules, heaps)) = build_field_list_function group_index field_list_ds (modules, heaps)
818

819
	  (record_dsc_fun, (modules, heaps)) = build_record_dsc group_index td_ident record_dsc_ds gen_type_ds field_list_ds alt (modules, heaps)
820

821
822
823
824
	  (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]
825

826
	# 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
827

828
	# cons_infos = RecordInfo record_dsc_ds gen_type_ds field_list_ds field_dsc_dss
Artem Alimarine's avatar
Artem Alimarine committed
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
	= (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
859
		# (body_expr, heaps) 
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
			= 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