typereify.icl 23.1 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
/*
	module owner: Ronny Wichers Schreur
*/
implementation module typereify

import checksupport
import typesupport
// import StdDebug

typeFunName :: Ident -> {#Char}
typeFunName {id_name}
12
	=	"TD;" +++ id_name
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

class makeTypeFun a :: Ident Position SymbolType *VarHeap *SymbolTable
	-> (a, *VarHeap, *SymbolTable)

instance makeTypeFun FunDef where
	makeTypeFun ident position symbol_type var_heap symbol_table	
		=	(function, var_heap, symbol_table)
		where
			function =
				{	fun_ident = ident
				,	fun_arity = 1
				,	fun_priority = NoPrio
				,	fun_body = GeneratedBody
				,	fun_type = Yes symbol_type
				,	fun_pos = position
28
				,	fun_kind = FK_Function False
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
				,	fun_lifted = 0
				,	fun_info = EmptyFunInfo
				}

instance makeTypeFun FunType where
	makeTypeFun ident position symbol_type var_heap symbol_table
		# (entry, symbol_table)
			=	readPtr ident.id_info symbol_table
		# entry
			=	{ entry & ste_kind = STE_DclFunction}
		# symbol_table
			=	writePtr ident.id_info entry symbol_table
		# (ft_type_ptr, var_heap)
			=	newPtr VI_Empty var_heap
		=	({	ft_ident = ident
			,	ft_arity = 1
			,	ft_priority = NoPrio
			,	ft_type = symbol_type
			,	ft_pos = position
			,	ft_specials = SP_None
			,	ft_type_ptr	= ft_type_ptr
			}, var_heap, symbol_table)
			
class isTypeSynonym a :: a -> Bool

instance isTypeSynonym (TypeDef a) | isTypeSynonym a where
	isTypeSynonym {td_rhs}
		=	isTypeSynonym td_rhs

58
59
// Currently type functions are generated for all types, including type
// synonyms. This should be changed to only type synonyms that are abstract. 
60
61
62
63
64
65
66
67
instance isTypeSynonym TypeRhs where
	isTypeSynonym (AlgType _)
		=	False
	isTypeSynonym (RecordType _)
		=	False
	isTypeSynonym (AbstractType _)
		=	False
	isTypeSynonym (SynType _)
68
		=	False
69
	isTypeSynonym (AbstractSynType _ _)
70
		=	False
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210

add_dcl_type_fun_types :: TypeSymbIdent Int *{#DclModule} *VarHeap *SymbolTable
							-> (*{#DclModule}, *VarHeap, *SymbolTable)
add_dcl_type_fun_types ctTypeDefSymb add_dcl_type_fun_types dcl_mods var_heap symbols
	# (n, dcl_mods)
		=	usize dcl_mods
	=	add_type_fun_types add_dcl_type_fun_types n ctTypeDefSymb dcl_mods var_heap symbols
	where
		add_type_fun_types :: Int Int TypeSymbIdent *{#DclModule} *VarHeap *SymbolTable
									-> (*{#DclModule}, *VarHeap, *SymbolTable)
		add_type_fun_types i n ctTypeDefSymb dcl_mods var_heap symbols
			| i >= n
				=	(dcl_mods, var_heap, symbols)
			| i == cPredefinedModuleIndex
				=	add_type_fun_types (i+1) n ctTypeDefSymb dcl_mods var_heap symbols
			// otherwise
				# (dcl_mod, dcl_mods)
					=	dcl_mods![i]
				# (dcl_mod, var_heap, symbols)
					=	add_fun_types ctTypeDefSymb dcl_mod var_heap symbols
				# dcl_mods
					=	{dcl_mods & [i] = dcl_mod}
				=	add_type_fun_types (i+1) n ctTypeDefSymb dcl_mods var_heap symbols

add_fun_types :: TypeSymbIdent DclModule *VarHeap *SymbolTable
					-> (DclModule, *VarHeap, *SymbolTable)
add_fun_types ctTypeDefSymb
		dcl_mod=:{dcl_name, dcl_functions, dcl_common={com_type_defs}}
	 			var_heap symbols
	# n_functions
		=	size dcl_functions
	# (type_funs, com_type_defs, var_heap, symbols)
		=	addTypeFunctionsA dcl_name n_functions ctTypeDefSymb
						{def \\ def <-: com_type_defs} var_heap symbols
	# dcl_functions
		=	{function \\ function <- [e \\ e <-: dcl_functions] ++ type_funs}
	# dcl_type_funs
		=	{ir_from = n_functions, ir_to = size dcl_functions}
	# dcl_mod
		=	{	dcl_mod
			&	dcl_functions = dcl_functions
			,	dcl_common.com_type_defs = com_type_defs
			,	dcl_type_funs = dcl_type_funs
			}
	=	(dcl_mod, var_heap, symbols)

addTypeFunctions :: Ident Int *{#DclModule} *{#FunDef} *CommonDefs *PredefinedSymbols *VarHeap *SymbolTable
		-> (IndexRange, *{#DclModule}, *{#FunDef}, *CommonDefs, *PredefinedSymbols, *VarHeap, *SymbolTable)
addTypeFunctions mod_ident nr_cached_dcls dcl_modules icl_functions icl_common
		predefs var_heap symbols
	# (ctTypeDefSymb, predefs)
		=	getCTTypeDefSymb predefs
		with
			getCTTypeDefSymb predefs
				# ({pds_module, pds_def}, predefs)
					=	predefs![PD_CTTypeDef]
				# ident
					=	predefined_idents.[PD_CTTypeDef]
				# type_symb
					=	{	MakeNewTypeSymbIdent ident 0
						&	type_index.glob_module = pds_module
						,	type_index.glob_object = pds_def
						}
				= (type_symb, predefs)

	# (dcl_modules, var_heap, symbols)
		=	add_dcl_type_fun_types ctTypeDefSymb nr_cached_dcls dcl_modules var_heap symbols

	# (icl_type_fun_range, icl_functions, icl_common, var_heap, symbols)
		=	add_icl_type_functions icl_functions ctTypeDefSymb icl_common var_heap symbols
		with
			add_icl_type_functions :: *{#FunDef} TypeSymbIdent *CommonDefs *VarHeap *SymbolTable
				-> (IndexRange, *{#FunDef}, *CommonDefs, *VarHeap, *SymbolTable)
			add_icl_type_functions icl_functions ctTypeDefSymb icl_common=:{com_type_defs} var_heap symbols
				# (n_functions_before, icl_functions)
					=	usize icl_functions
				# (type_funs, com_type_defs, var_heap, symbols)
					=	addTypeFunctionsA mod_ident n_functions_before ctTypeDefSymb com_type_defs var_heap symbols
				# icl_common
					=	{icl_common & com_type_defs=com_type_defs}
				# icl_functions
					=	{function \\ function <- [e \\ e <-: icl_functions] ++ type_funs}
				# (n_functions_after, icl_functions)
					=	usize icl_functions
				# type_fun_range
					=	{ir_from=n_functions_before,ir_to=n_functions_after}
				=	(type_fun_range, icl_functions, icl_common, var_heap, symbols)
	# (nr_of_functions, icl_functions)
		=	usize icl_functions		
	=	(icl_type_fun_range, dcl_modules, icl_functions, icl_common, predefs, var_heap, symbols)

getSymbol :: Index ((Global Index) -> SymbKind) *PredefinedSymbols -> (SymbIdent, !*PredefinedSymbols)
getSymbol index symb_kind predef_symbols
	# ({pds_module, pds_def}, predef_symbols) = predef_symbols![index]
	# pds_ident = predefined_idents.[index]
	  symbol = { symb_ident = pds_ident, symb_kind = symb_kind { glob_module = pds_module, glob_object = pds_def} }
	= (symbol, predef_symbols)

predefFunction :: Index *PredefinedSymbols -> (SymbIdent, !*PredefinedSymbols)
predefFunction cons_index predefs
	=	getSymbol cons_index SK_Function predefs

predefConstructor :: Index *PredefinedSymbols -> (SymbIdent, !*PredefinedSymbols)
predefConstructor cons_index predefs
	=	getSymbol cons_index SK_Constructor predefs

predefRecordConstructor :: Index {#CommonDefs} *PredefinedSymbols -> (SymbIdent, !*PredefinedSymbols)
predefRecordConstructor record_type_index common_defs predefs
	# ({pds_module=pds_module1, pds_def=pds_def1}, predefs)
		=	predefs![record_type_index]
	# {td_rhs=RecordType {rt_constructor,rt_fields}} = common_defs.[pds_module1].com_type_defs.[pds_def1]
	# record_cons_symbol
		= {glob_module = pds_module1, glob_object = rt_constructor}
	# dynamic_type = {glob_module = pds_module1, glob_object = pds_def1}

	# record_cons_symb_ident
		= { SymbIdent |
			symb_ident	= rt_constructor.ds_ident
		,	symb_kind 	= SK_Constructor {glob_module = pds_module1, glob_object = rt_constructor.ds_index} 
		}
	=	(record_cons_symb_ident, predefs)

:: BuildTypeFunState =
	!{	bs_predefs :: !.PredefinedSymbols
	,	bs_type_heaps :: .TypeHeaps
	,	bs_var_heap :: .VarHeap
	}

buildTypeFunctions :: !Int !*{#FunDef} !{#CommonDefs}
	*PredefinedSymbols *VarHeap *TypeHeaps
	-> (*{#FunDef}, *PredefinedSymbols, *VarHeap, *TypeHeaps)
buildTypeFunctions main icl_functions common_defs predefs var_heap type_heaps
	# bs_state =
		{	bs_predefs = predefs
		,	bs_var_heap = var_heap
		,	bs_type_heaps = type_heaps
		}
	# type_defs
		=	common_defs.[main].com_type_defs
	# (type_funs, bs_state)
211
		=	build 0 (size type_defs) type_defs icl_functions bs_state 
212
213
	=	(type_funs, bs_state.bs_predefs, bs_state.bs_var_heap, 
			bs_state.bs_type_heaps)
214
	where
215
		build i n type_defs functions bs_state
216
			| i < n
217
218
219
220
221
				# info =
					{	ri_main = main
					,	ri_common_defs = common_defs
					,	ri_type_var_num = 0
					}
222
				# (functions, bs_state)
223
					=	buildTypeFunction type_defs.[i] functions info bs_state
224
				=	build (i+1) n type_defs functions bs_state
225
226
227
			// otherwise
				=	(functions, bs_state)

228
buildTypeFunction :: CheckedTypeDef *{#FunDef} Info *BuildTypeFunState
229
	-> (*{#FunDef}, *BuildTypeFunState)
230
buildTypeFunction type_def=:{td_fun_index, td_args} functions info bs_state
231
232
233
234
	| td_fun_index == NoIndex
		=	(functions, bs_state)
	// otherwise
		# (rhs, bs_state)
235
			=	numberTypeVarsBeforeRiefy td_args (reify type_def) info bs_state
236
237
238
239
240
241
242
243
244
245
246
247
248
249
		# (new_info_ptr, bs_var_heap) = newPtr VI_Empty bs_state.bs_var_heap
		# bs_state
			=	{bs_state & bs_var_heap=bs_var_heap}
	  	# var_id
	  		=	{id_name = "_x", id_info = nilPtr}
	  	  lhs_free_var
	  	  	=	{fv_def_level = NotALevel, fv_ident = var_id,
	  	  			fv_info_ptr = new_info_ptr, fv_count = 0}
		# body
			=	{tb_args = [lhs_free_var], tb_rhs = rhs}
		# functions
			=	{functions & [td_fun_index].fun_body=TransformedBody body}
		=	(functions, bs_state)

250
251
252
numberTypeVarsBeforeRiefy :: a Riefier Info *BuildTypeFunState
	-> (Expression, *BuildTypeFunState) | numberTypeVars a
numberTypeVarsBeforeRiefy vars riefier info bs_state
253
254
	# bs_type_heaps
		=	bs_state.bs_type_heaps
255
256
	# (ri_type_var_num, th_vars)
		=	numberTypeVars vars (info.ri_type_var_num, bs_type_heaps.th_vars)
257
258
	# bs_type_heaps
		=	{bs_type_heaps & th_vars = th_vars}
259
260
261
262
263
	# bs_state
		=	{bs_state & bs_type_heaps = bs_type_heaps}
	# (expr, bs_state)
		=	riefier {info & ri_type_var_num=ri_type_var_num} bs_state
	=	(expr, bs_state)
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
	
class numberTypeVars a :: a (!Int, !*TypeVarHeap) -> (!Int, !*TypeVarHeap)

instance numberTypeVars [a] | numberTypeVars a where
	numberTypeVars l h
		=	foldSt numberTypeVars l h

instance numberTypeVars ATypeVar where
	numberTypeVars {atv_variable} h
		=	numberTypeVars atv_variable h

instance numberTypeVars TypeVar where
	numberTypeVars {tv_info_ptr} (n, h)
		=	(n+1, writePtr tv_info_ptr (TVI_Reify n) h)

addTypeFunctionsA :: Ident Int TypeSymbIdent *{#CheckedTypeDef} *VarHeap *SymbolTable
	-> ([a], *{#CheckedTypeDef}, *VarHeap, *SymbolTable) | makeTypeFun a
addTypeFunctionsA mod first_td_fun_index ct_type_def type_defs var_heap symbol_table
	=	add_td_fun_defs first_td_fun_index ct_type_def type_defs var_heap symbol_table
	where
		add_td_fun_defs :: Int TypeSymbIdent *{#CheckedTypeDef} *VarHeap *SymbolTable
			-> ([a], *{#CheckedTypeDef}, *VarHeap, *SymbolTable) | makeTypeFun a
		add_td_fun_defs type_fun_index ct_type_def type_defs var_heap symbol_table
			# (n, type_defs)
				=	usize type_defs
			=	add_td_funs_acc 0 n type_fun_index ct_type_def type_defs [] var_heap symbol_table

		add_td_funs_acc :: Int Int Int TypeSymbIdent *{#CheckedTypeDef} [a] *VarHeap *SymbolTable
			 -> ([a], *{#CheckedTypeDef}, *VarHeap, *SymbolTable) | makeTypeFun a
		add_td_funs_acc i n index ct_type_def type_defs rev_type_fun_defs var_heap symbol_table
			| i >= n
				=	(reverse rev_type_fun_defs, type_defs, var_heap, symbol_table)
			// otherwise
				# (type_def, type_defs)
					=	type_defs![i]
				| isTypeSynonym type_def || is_dictionary type_def
					=	add_td_funs_acc (i+1) n index ct_type_def type_defs rev_type_fun_defs var_heap symbol_table
				// otherwise
					# (type_fun_def, var_heap, symbol_table)
						=	add_td_fun_def index ct_type_def type_def var_heap symbol_table
					# type_defs
						=	{type_defs & [i].td_fun_index = index}
					# rev_type_fun_defs
						=	[type_fun_def : rev_type_fun_defs]
					=	add_td_funs_acc (i+1) n (index+1) ct_type_def type_defs rev_type_fun_defs var_heap symbol_table

		is_dictionary {td_ident} // FIXME, fragile
			=	name.[size name - 1] == ';'
			where
				name
					=	td_ident.id_name

		add_td_fun_def :: Int TypeSymbIdent CheckedTypeDef *VarHeap *SymbolTable
			-> (a, *VarHeap, *SymbolTable) | makeTypeFun a
		add_td_fun_def index ct_type_def type_def=:{td_ident, td_pos} var_heap symbol_table
			#	entry
					=	{	ste_kind		= STE_Empty
						,	ste_index		= index
						,	ste_def_level	= -1
						,	ste_previous	= EmptySymbolTableEntry
						}
			# (fun_ident, symbol_table)
				=	newPtr entry symbol_table
			# type_fun_ident
				=	{id_name=typeFunName td_ident, id_info=fun_ident}

			# ident = predefined_idents.[PD_CTTypeDef]
			# type_symb	=	ct_type_def

			# result_type
				=	TA ct_type_def []
			# symbol_type =
					{	st_vars = []
					,	st_args = [{at_attribute= TA_None, at_type = TB BT_Bool}]
					,	st_args_strictness = NotStrict
					,	st_arity = 1
					,	st_result = {at_attribute = TA_None, at_type = result_type}
					,	st_context = []
					,	st_attr_vars = []
					,	st_attr_env = []
					}

			=	makeTypeFun type_fun_ident td_pos symbol_type var_heap symbol_table

:: ExpressionM :== BMonad Expression
:: BMonad a :== *BuildTypeFunState -> *(a, *BuildTypeFunState)

apply :: Expression Expression -> Expression
apply (App app=:{app_args}) a
	=	App {app & app_args = app_args ++ [a]}
apply f a
	=	f @ [a]

lift symb
	=	return (App {app_symb = symb, app_args = [], app_info_ptr = nilPtr})

360
cons :: Index Info *BuildTypeFunState
361
			-> *(Expression, *BuildTypeFunState)
362
cons cons_index info bs=:{bs_predefs}
363
364
365
366
	# (symbol, bs_predefs)
		=	getSymbol cons_index SK_Constructor bs_predefs
	=	lift symbol {bs & bs_predefs=bs_predefs}

367
record :: Index  Info *BuildTypeFunState
368
			-> *(Expression, *BuildTypeFunState)
369
record type_index info=:{ri_common_defs} bs=:{bs_predefs}
370
	# (symbol, bs_predefs)
371
		=	predefRecordConstructor type_index ri_common_defs bs_predefs
372
373
	=	lift symbol {bs & bs_predefs=bs_predefs}

374
375
376
377
quote :: {#Char} -> {#Char}
quote string
	=	"\"" +++ string +++ "\""

378
379
380
381
(o`) infixr  9
(o`) f g info x :== g info (f info x)

function :: Index Info  *BuildTypeFunState
382
			-> *(Expression, *BuildTypeFunState)
383
function fun_index info bs=:{bs_predefs}
384
385
386
387
388
	# (symbol, bs_predefs)
		=	getSymbol fun_index SK_Function bs_predefs
	=	lift symbol {bs & bs_predefs=bs_predefs}

(`) infixl 9
389
390
391
392
393
394
395
(`) f a info state
	# (rf, state)
		=	f info state
	# (ra, state)
		=	reify a info state
	=	(apply rf ra, state)

396
397
398
:: Info =
	{	ri_main :: !Int
	,	ri_common_defs :: !{#CommonDefs}
399
	,	ri_type_var_num :: !Int
400
401
	}

402
:: Riefier :== Info -> BMonad Expression
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
class reify a ::  a -> Riefier

instance reify [a] | reify a where
	reify []
		=	cons PD_NilSymbol
	reify [h:t]
		=	cons PD_ConsSymbol ` h ` t

instance reify Int where
	reify int
		=	basic (BVInt int)

instance reify Bool where
	reify bool
		=	basic (BVB bool)

instance reify {#Char} where
	reify string
		=	basic (BVS string)

instance reify CheckedTypeDef where
	reify {td_ident, td_arity, td_attribute, td_rhs}
425
426
		=	record PD_CTTypeDef ` quote td_ident.id_name ` td_arity
					` is_unq_attribute td_attribute ` td_rhs
427
428
429
430
431
432
433
434
435
436
	where
		is_unq_attribute (TA_Var _)
			=	False
		is_unq_attribute TA_Unique
			=	True

instance reify TypeRhs where
	reify (AlgType constructors)
		=	cons PD_CTAlgType ` get constructors
		where
437
			get constructors info=:{ri_main, ri_common_defs} state
438
				=	reify [(ds_index,common_defs.[ds_index]) \\ {ds_index} <- constructors] info state
439
440
				where
					common_defs
441
						=	ri_common_defs.[ri_main].com_cons_defs
442
443
444
445
446
	reify (RecordType record_type)
		=	reify record_type
	reify (SynType _)
		=	cons PD_CTSynType

447
instance reify (Int, ConsDef) where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
448
	reify (cons_index, {cons_ident, cons_type, cons_exi_vars})
449
450
		=	numberTypeVarsBeforeRiefy cons_exi_vars
			(record PD_CTConsDef
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
451
				` (function PD__CTToCons ` consSymbol cons_ident cons_index)
452
453
				` cons_type.st_args ` length cons_exi_vars)
		where
454
			consSymbol cons_ident cons_index info=:{ri_main} state
455
456
				# cons_symb =
					{	symb_ident = cons_ident
457
					,	symb_kind = SK_Constructor { glob_module = ri_main, glob_object = cons_index}
458
					}
459
				=	reify cons_symb info state
460
461
462
463
464
465
466
467
468

instance reify RecordType where
	reify {rt_fields} // +++ constructor ??? +++ is_boxed
		=	cons PD_CTRecordType ` [field \\ field <-: rt_fields]

instance reify FieldSymbol where
	reify {fs_index}
		=	selector fs_index
		where
469
			selector fs_index info=:{ri_main,ri_common_defs} st
470
471
				=	(numberTypeVarsBeforeRiefy vars
					(record PD_CTFieldDef
472
						` quote def.sd_ident.id_name
473
						` length (def.sd_exi_vars)
474
475
						` def.sd_type.st_result))
					info st
476
477
			where
				def
478
					=	ri_common_defs.[ri_main]
479
									.com_selector_defs.[fs_index]
480
481
482
				vars
					=	[atv_variable \\ {atv_variable} <- def.sd_exi_vars]
					++	def.sd_type.st_vars
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513

instance reify AType where
	reify {at_type}
		=	reify at_type

instance reify Riefier where
	reify x
		=	x

instance reify Type where
	reify type=:(TA symb args)
		=	reifyApp symb args
	reify type=:(TAS symb args _)
		=	reifyApp symb args
	reify (TV var)
		=	reify var
	reify (TQV var)
		=	reify var
	reify (a :@: args)
		=	foldl` reifyApply (reify a) args
	reify TArrow
		=	cons PD_Dyn_TypeCons ` function PD_Dyn_TypeCodeConstructor_Arrow
	reify (TArrow1 a)
		=	cons PD_Dyn_TypeApp `
				(cons PD_Dyn_TypeCons ` function PD_Dyn_TypeCodeConstructor_Arrow) ` a
	reify (a --> b)
		=	cons PD_Dyn_TypeApp ` (cons PD_Dyn_TypeApp `
				(cons PD_Dyn_TypeCons ` function PD_Dyn_TypeCodeConstructor_Arrow) ` a) ` b
	reify (TB basic_type)
		=	reify basic_type
	reify (TFA vars type)
514
		=	numberTypeVarsBeforeRiefy vars (reify type)
515
516
517
	reify t
		=	undef //  <<- ("reify", t)

518
519
reifyApp :: TypeSymbIdent [AType] Info *BuildTypeFunState
	-> (Expression, *BuildTypeFunState)
520
reifyApp symb args info=:{ri_common_defs} bs_state=:{bs_type_heaps}
521
	# (expanded, expanded_type, bs_type_heaps)
522
		=	expandTypeSynonym ri_common_defs symb args bs_type_heaps
523
524
525
	# bs_state
		=	{bs_state & bs_type_heaps=bs_type_heaps}
	| expanded
526
		=	reify expanded_type info bs_state
527
	// otherwise
528
		=	foldl` reifyApply (reify symb) args info bs_state
529

530
foldl` op r l = foldl r l // crashes if it's a macro
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
	where
		foldl r []		= r
		foldl r [a:x]	= foldl (op r a) x

reifyApply a h
	=	cons PD_Dyn_TypeApp ` a ` h

instance reify ConsVariable where
	reify (CV var)
		=	reify var

instance reify TypeVar where
	reify {tv_info_ptr, tv_ident}
		=	cons PD_Dyn_TypeVar ` typeVarNum tv_info_ptr
		where
546
			typeVarNum tv_info_ptr info bs=:{bs_type_heaps}
547
548
549
550
551
552
553
554
555
556
				# (tv_info, th_vars)
					=	readPtr tv_info_ptr bs_type_heaps.th_vars
				# tv_num
					=	case tv_info of
							TVI_Reify tv_num
								->	tv_num
							_
								->	abort "typeVar" // <<- (tv_ident.id_name, tv_info)
				# bs_type_heaps
					=	{bs_type_heaps & th_vars = th_vars}
557
				=	reify tv_num info {bs & bs_type_heaps = bs_type_heaps}
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585

instance reify BasicType where
	reify (BT_String string_type)
		=	reify string_type
	reify basic_type
		=	cons PD_Dyn_TypeCons ` function (predef basic_type)
		where
			predef BT_Int
				=	PD_Dyn_TypeCodeConstructorInt
			predef BT_Char
				=	PD_Dyn_TypeCodeConstructorInt
			predef BT_Real
				=	PD_Dyn_TypeCodeConstructorReal
			predef BT_Bool
				=	PD_Dyn_TypeCodeConstructorBool
			predef BT_Dynamic
				=	PD_Dyn_TypeCodeConstructorDynamic
			predef BT_File
				=	PD_Dyn_TypeCodeConstructorFile
			predef BT_World
				=	PD_Dyn_TypeCodeConstructorWorld

instance reify SymbIdent where
	reify symb
		=	reify {app_symb = symb, app_args = [], app_info_ptr = nilPtr}

instance reify TypeSymbIdent where
	reify symb
586
		=	cons PD_Dyn_TypeCons ` reifyTypeIdent symb
587
		where
588
589
			reifyTypeIdent {type_index} info=:{ri_common_defs} st
				=	reify (toTypeCodeConstructor type_index ri_common_defs) info st
590
591
592
593
594
595
596
597
598
599
600

instance reify GlobalTCType where
	reify (GTT_PredefTypeConstructor {glob_object=type_index})
		| PD_Arity2TupleTypeIndex <= type_index && type_index <= PD_Arity32TupleTypeIndex
			# arity
				=	type_index - PD_Arity2TupleTypeIndex + 2
			=	function PD_Dyn_TypeCodeConstructor_Tuple ` arity
		// otherwise
			# predef_type_index
				=	type_index + FirstTypePredefinedSymbolIndex
			=	function (predefinedTypeConstructor predef_type_index)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
601
602
	reify (GTT_Constructor type_fun)
		=	function PD_Dyn__to_TypeCodeConstructor ` type_fun
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631

predefinedTypeConstructor predef_type_index
	| predef_type_index == PD_ListType
		=	PD_Dyn_TypeCodeConstructor_List
	| predef_type_index == PD_StrictListType
		=	PD_Dyn_TypeCodeConstructor_StrictList
	| predef_type_index == PD_UnboxedListType
		=	PD_Dyn_TypeCodeConstructor_UnboxedList
	| predef_type_index == PD_TailStrictListType
		=	PD_Dyn_TypeCodeConstructor_TailStrictList
	| predef_type_index == PD_StrictTailStrictListType
		=	PD_Dyn_TypeCodeConstructor_StrictTailStrictList
	| predef_type_index == PD_UnboxedTailStrictListType
		=	PD_Dyn_TypeCodeConstructor_UnboxedTailStrictList
	| predef_type_index == PD_LazyArrayType
		=	PD_Dyn_TypeCodeConstructor_LazyArray
	| predef_type_index == PD_StrictArrayType
		=	PD_Dyn_TypeCodeConstructor_StrictArray
	| predef_type_index == PD_UnboxedArrayType
		=	PD_Dyn_TypeCodeConstructor_UnboxedArray
	// otherwise
		=	fatal "predefinedType" "TC code from predef"

instance reify App where
	reify app
		=	reify (App app)

instance reify Expression where
	reify expr
632
		=	\x -> return expr
633
634
635

basic :: BasicValue -> Riefier
basic value
636
	=	\x -> return (BasicExpr value)
637
638
639
640

// copied and adopted from overloading
toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} common_defs
	| module_index == cPredefinedModuleIndex
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
641
		= GTT_PredefTypeConstructor type
642
	// otherwise
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
643
644
		# type
			=	common_defs.[module_index].com_type_defs.[type_index]
645
		# td_fun_index
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
646
			=	type.td_fun_index
647
648
		// sanity check ...
		| td_fun_index == NoIndex
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
649
			=	fatal "toTypeCodeConstructor" ("no function (" +++ type.td_ident.id_name +++ ")")
650
651
		// ... sanity check
		# type_fun
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
652
			=	{	symb_ident = {type.td_ident & id_info = nilPtr} // this is wrong but let's give it a try
653
654
				,	symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index}
				}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
655
		= GTT_Constructor type_fun
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723

fatal :: {#Char} {#Char} -> .a
fatal function_name message
	=	abort ("typereflection, " +++ function_name +++ ": " +++ message)

expandTypeSynonym :: {#CommonDefs} TypeSymbIdent [AType] *TypeHeaps
	-> (Bool, Type, *TypeHeaps)
expandTypeSynonym defs cons_id type_args type_heaps
	# {type_ident,type_index={glob_object,glob_module}}
		=	cons_id
	# {td_ident,td_rhs,td_args,td_attribute}
		=	defs.[glob_module].com_type_defs.[glob_object]
	= case td_rhs of
		SynType {at_type}
			# (expanded_type, type_heaps)
				=	substituteType td_attribute TA_Multi td_args type_args
															at_type type_heaps
			-> (True, expanded_type, type_heaps)
		_
			-> (False, undef, type_heaps)

sanityCheckTypeFunctions :: !Int !CommonDefs !{#DclModule} !{#FunDef}
	->	Bool
sanityCheckTypeFunctions main_dcl icl_common dcl_mods fun_defs
	=	checkType {def.fun_ident.id_name \\ def <-: fun_defs} icl_common
	&&	all checkDcl [dcl \\ dcl <-: dcl_mods]
	&&	compareTypes icl_common dcl_mods.[main_dcl].dcl_common
	where
		checkDcl :: DclModule -> Bool
		checkDcl {dcl_functions, dcl_common}
			=	checkType {f.ft_ident.id_name \\ f <-: dcl_functions} dcl_common

class checkType a :: {{#Char}} a -> Bool

instance checkType CommonDefs where
	checkType names {com_type_defs}
		=	checkType names com_type_defs

instance checkType (a e) | Array a e & checkType e where
	checkType names a
		=	all (checkType names) [e \\ e <-: a]

instance checkType (TypeDef a) where
	checkType names {td_ident, td_fun_index}
		| td_fun_index == NoIndex
			=	True
		| names.[td_fun_index] == typeFunName td_ident
			=	True
		// otherwise
			=	False // ->> (names.[td_fun_index], "<>", typeFunName td_ident)

class compareTypes a :: a a -> Bool

instance compareTypes CommonDefs where
	compareTypes a b
		=	compareTypes a.com_type_defs b.com_type_defs

instance compareTypes (a e) | Array a e & compareTypes e where
	compareTypes a b
		=	and [compareTypes ea eb \\ ea <-: a & eb <-: b]

instance compareTypes (TypeDef a) where
	compareTypes a b
		| a.td_fun_index == b.td_fun_index
			=	True
		// otherwise
			=	False // ->> (a.td_ident.id_name, a.td_fun_index, "<>",
						// 		b.td_ident.id_name, b.td_fun_index)