convertDynamics.icl 63.7 KB
Newer Older
1
2
3
/*
	module owner: Martijn Vervoort
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
4
5
implementation module convertDynamics

6
7
import syntax, transform, utilities, convertcases /* MV ... */, compilerSwitches /* ... MV */
from type_io_common import PredefinedModuleName
8
// Optional
9
10
USE_TUPLES tuple b :== b;					// change also StdDynamic.icl and recompile all applications
extended_unify_and_coerce no yes :== no;	// change also _unify and _coerce in StdDynamic
Martijn Vervoort's avatar
Martijn Vervoort committed
11

12
//import pp;
Martijn Vervoort's avatar
Martijn Vervoort committed
13

14
import type_io; 
15
//import pp;
16
//import RWSDebug;
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
17

Martijn Vervoort's avatar
Martijn Vervoort committed
18
/*2.0
19
from type_io_common import class toString (..),instance toString GlobalTCType;
Martijn Vervoort's avatar
Martijn Vervoort committed
20
21
0.2*/

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
22
23
24
25
::	*ConversionInfo =
	{	ci_predef_symb		:: !*PredefinedSymbols
	,	ci_var_heap			:: !*VarHeap
	,	ci_expr_heap		:: !*ExpressionHeap
26
	,	ci_new_variables 	:: ![FreeVar]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
27
28
29
	,	ci_new_functions 	:: ![FunctionInfoPtr]
	,	ci_fun_heap			:: !*FunctionHeap
	,	ci_next_fun_nr		:: !Index
Martijn Vervoort's avatar
Martijn Vervoort committed
30
31
	
	//	data needed to generate coercions
32
	,	ci_placeholders_and_tc_args				:: [(!BoundVar,Ptr VarInfo)]
33
34
	,	ci_generated_global_tc_placeholders		:: !Bool
	,	ci_used_tcs								:: [Ptr VarInfo]
35
36
37
38
	,	ci_symb_ident							:: SymbIdent
	,	ci_sel_type_field						:: Expression -> Expression  //Optional (!Int,!(Global DefinedSymbol))
	,	ci_sel_value_field						:: Expression -> Expression  //Optional (!Int,!(Global DefinedSymbol))
	,	ci_module_id_symbol						:: Expression
39
40
	,	ci_internal_type_id						:: Expression
	,	ci_module_id							:: Optional LetBind
41
	,	ci_type_id								:: !TypeSymbIdent
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
42
43
44
45
46
	}

::	ConversionInput =
	{	cinp_glob_type_inst	:: !{! GlobalTCType} 
	,	cinp_group_index	:: !Int
47
	,	cinp_st_args		:: ![FreeVar]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
48
49
50
51
52
53
54
55
	}

:: OpenedDynamic =
	{	opened_dynamic_expr :: Expression
	, 	opened_dynamic_type :: Expression
	}

:: DefaultExpression :== Optional (BoundVar, [IndirectionVar])   //DefaultRecord
56
57
58

::	BoundVariables :== [TypedVariable]

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
59
:: IndirectionVar    :== BoundVar
60

61
62
63

pl [] = ""
pl [x:xs] = x +++ " , " +++ (pl xs)
64

65
66
F :: !a .b -> .b
F a b = b
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
67

68
69

//write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File)
Martijn Vervoort's avatar
Martijn Vervoort committed
70
71
72
write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] !*TypeHeaps !*PredefinedSymbols -> (.Bool,.File,!*TypeHeaps,!*PredefinedSymbols)
write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file directly_imported_dcl_modules type_heaps predefined_symbols
	# (pre_mod, predefined_symbols) = predefined_symbols![PD_PredefinedModule]
73
74
	# write_type_info_state2
		= { WriteTypeInfoState |
Martijn Vervoort's avatar
Martijn Vervoort committed
75
76
77
			wtis_type_heaps				= type_heaps
		,	wtis_n_type_vars			= 0
		,	wtis_predefined_module_def	= pre_mod.pds_def
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
		};
	# (j,tcl_file)
		= fposition tcl_file
//	| True
//		= abort ("TypeVar " +++ toString j)
				
	#! (tcl_file,write_type_info_state)
		= write_type_info common_defs tcl_file write_type_info_state2
	#! (tcl_file,write_type_info_state)
		= write_type_info directly_imported_dcl_modules tcl_file write_type_info_state
		
	#! (type_heaps,_)
		= f write_type_info_state //!type_heaps;
		
		
Martijn Vervoort's avatar
Martijn Vervoort committed
93
94
	#! tcl_file
		= fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file
Martijn Vervoort's avatar
Martijn Vervoort committed
95
96
	#! tcl_file
		= fwritei (size main_dcl_module.dcl_common.com_cons_defs) tcl_file
Martijn Vervoort's avatar
Martijn Vervoort committed
97
	= (True,tcl_file,type_heaps,predefined_symbols) 
98
99
100
101
	
where
	f write_type_info_state=:{wtis_type_heaps}
		= (wtis_type_heaps,{write_type_info_state & wtis_type_heaps = abort "convertDynamics.icl"});
Martijn Vervoort's avatar
Martijn Vervoort committed
102
//---> ("dcl",size main_dcl_module.dcl_common.com_type_defs, "icl", size common_defs.com_type_defs);
103

Martijn Vervoort's avatar
Martijn Vervoort committed
104
105
106
107
/*2.0
f (Yes tcl_file)
	= tcl_file;
0.2*/
108
			
109
110
convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap /* TD */ (Optional !*File) {# DclModule} !IclModule /* TD */ [String]
			-> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, /* TD */ (Optional !*File))
Martijn Vervoort's avatar
Martijn Vervoort committed
111
convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap /* TD */ tcl_file dcl_mods icl_mod  /* TD */ directly_imported_dcl_modules
112
	// TD ...
Martijn Vervoort's avatar
Martijn Vervoort committed
113
	# (tcl_file,type_heaps,predefined_symbols)
114
115
		= case tcl_file of
			No
Martijn Vervoort's avatar
Martijn Vervoort committed
116
117
118
119
120
121
				-> (No,type_heaps,predefined_symbols)
/*2.0
			_ 
				# tcl_file = f tcl_file;
0.2*/
//1.3
122
			(Yes tcl_file)
Martijn Vervoort's avatar
Martijn Vervoort committed
123
124
125
//3.1
				# (ok,tcl_file,type_heaps,predefined_symbols)
					= write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file /* TD */ directly_imported_dcl_modules type_heaps predefined_symbols
126
127
				| not ok
					-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
Martijn Vervoort's avatar
Martijn Vervoort committed
128
					-> (Yes tcl_file,type_heaps,predefined_symbols)
129
130

				
131
	// ... TD
132
	# ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamic]
133
134
135
136
137
138
139
140
141
142
	#! (dynamic_temp_symb_ident,ci_sel_value_field,ci_sel_type_field,predefined_symbols)
		= case (pds_module == (-1) || pds_def == (-1)) of
			True
				-> (undef,undef,undef,predefined_symbols)
			_	
				 
				-> case (USE_TUPLES True False) /*(pds_module == (-1) || pds_def == (-1))*/ of
					True
						# arity = 2
						// get tuple arity 2 constructor
143
144
						# ({pds_module, pds_def}, predefined_symbols)	= predefined_symbols![GetTupleConsIndex arity]
						# pds_ident = predefined_idents.[GetTupleConsIndex arity]
145
						# twoTuple_symb	= { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def} }
146
147
						
						// get tuple, type and value selectors
148
149
						# ({pds_def}, predefined_symbols) = predefined_symbols![GetTupleConsIndex arity]
						# pds_ident = predefined_idents.[GetTupleConsIndex arity]
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
						# twotuple = {ds_ident = pds_ident, ds_arity = arity, ds_index = pds_def}
						# type_selector	= TupleSelect twotuple 1
						# value_selector = TupleSelect twotuple 0
						-> (twoTuple_symb,value_selector,type_selector,predefined_symbols)
					False
					
						# arity = 2
						# ({pds_module=pds_module1, pds_def=pds_def1} , predefined_symbols) = predefined_symbols![PD_DynamicTemp]
						# {td_rhs=RecordType {rt_constructor,rt_fields}} = common_defs.[pds_module1].com_type_defs.[pds_def1]
							
						# dynamic_temp_symb_ident
							= { SymbIdent |
								symb_name	= rt_constructor.ds_ident
							,	symb_kind 	= SK_Constructor {glob_module = pds_module1, glob_object = rt_constructor.ds_index} 
							}
		
						// type field
						# ({pds_module=pds_module2, pds_def=pds_def2} , predefined_symbols) = predefined_symbols![PD_DynamicType]
						# {sd_field,sd_field_nr}
							= common_defs.[pds_module2].com_selector_defs.[pds_def2]
		
						#! type_defined_symbol
							= { Global |
								glob_object		= { DefinedSymbol |
													ds_ident		= sd_field
												,	ds_arity		= 0
176
												,	ds_index		= pds_def2 
177
												}
178
							,	glob_module		= pds_module2 
179
180
							}
						#! ci_sel_type_field
181
							= (\dynamic_expr -> Selection NormalSelector dynamic_expr [RecordSelection type_defined_symbol sd_field_nr])
182
							
183
184
185
186
187
188
189
190
191
192
						// value field
						# ({pds_module=pds_module3, pds_def=pds_def3} , predefined_symbols) = predefined_symbols![PD_DynamicValue]
						# {sd_field=sd_field3,sd_field_nr=sd_field_nr3}
							= common_defs.[pds_module3].com_selector_defs.[pds_def3]
											
						#! value_defined_symbol
							= { Global |
								glob_object		= { DefinedSymbol |
													ds_ident		= sd_field3
												,	ds_arity		= 0
193
												,	ds_index		= pds_def3 
194
												}
195
							,	glob_module		= pds_module3
196
197
							}
						#! ci_sel_value_field
198
							= (\dynamic_expr -> Selection NormalSelector dynamic_expr [RecordSelection value_defined_symbol sd_field_nr3])
199
200
						-> (dynamic_temp_symb_ident, ci_sel_value_field, ci_sel_type_field,predefined_symbols)
						
201
202
	# (module_symb,module_id_app,predefined_symbols)
		= get_module_id_app predefined_symbols
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277

// new...
	# ({pds_module=pds_type_id_module, pds_def=pds_type_id_def} , predefined_symbols) = predefined_symbols![PD_TypeID]
	# {td_name} = common_defs.[pds_type_id_module].com_type_defs.[pds_type_id_def]
	# ci_type_id
		= {
			type_name	= td_name
		,	type_arity	= 0
		,	type_index	= { glob_object = pds_type_id_def, glob_module = pds_type_id_module}
		,	type_prop	= { tsp_sign = BottomSignClass, tsp_propagation = NoPropClass, tsp_coercible = True }
		};	
	

// TE TA !TypeSymbIdent ![AType]
/*
MakeTypeSymbIdentMacro type_index name arity
	:== {	type_name = name, type_arity = arity, type_index = type_index,
			type_prop = { tsp_sign = BottomSignClass, tsp_propagation = NoPropClass, tsp_coercible = True }}

*/
/*
::	Global object =
	{	glob_object	:: !object
	,	glob_module	:: !Index
	}
::	Type	=	TA !TypeSymbIdent ![AType]

::	TypeSymbIdent =
	{	type_name		:: !Ident
	,	type_arity		:: !Int
	,	type_index		:: !Global Index
	,	type_prop		:: !TypeSymbProperties
	}
# ({pds_module=pds_module1, pds_def=pds_def1} , predefined_symbols) = predefined_symbols![PD_DynamicTemp]
# {td_rhs=RecordType {rt_constructor,rt_fields}} = common_defs.[pds_module1].com_type_defs.[pds_def1]

::	TypeDef type_rhs =
 	{	td_name			:: !Ident
	,	td_index		:: !Int
	,	td_arity		:: !Int
	,	td_args			:: ![ATypeVar]
	,	td_attrs		:: ![AttributeVar]
	,	td_context		:: ![TypeContext]
	,	td_rhs			:: !type_rhs
	,	td_attribute	:: !TypeAttribute
	,	td_pos			:: !Position
	,	td_used_types	:: ![GlobalIndex]
	}
	
::	*ConversionInfo =
	{	ci_predef_symb		:: !*PredefinedSymbols
	,	ci_var_heap			:: !*VarHeap
	,	ci_expr_heap		:: !*ExpressionHeap
	,	ci_new_variables 	:: ![FreeVar]
	,	ci_new_functions 	:: ![FunctionInfoPtr]
	,	ci_fun_heap			:: !*FunctionHeap
	,	ci_next_fun_nr		:: !Index
	
	//	data needed to generate coercions
	,	ci_placeholders_and_tc_args				:: [(!BoundVar,Ptr VarInfo)]
	,	ci_generated_global_tc_placeholders		:: !Bool
	,	ci_used_tcs								:: [Ptr VarInfo]
	,	ci_symb_ident							:: SymbIdent
	,	ci_sel_type_field						:: Expression -> Expression  //Optional (!Int,!(Global DefinedSymbol))
	,	ci_sel_value_field						:: Expression -> Expression  //Optional (!Int,!(Global DefinedSymbol))
	,	ci_module_id_symbol						:: Expression
	,	ci_internal_type_id						:: Expression
	,	ci_module_id							:: Optional LetBind
	}

*/


// ...new

278
						
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
279
	#! nr_of_funs = size fun_defs
280
	# imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
281
282
283
	# (groups, (fun_defs, {ci_predef_symb, ci_var_heap, ci_expr_heap, ci_fun_heap, ci_new_functions}))
			= convert_groups 0 groups global_type_instances (fun_defs, {	
							ci_predef_symb = predefined_symbols, ci_var_heap = var_heap, ci_expr_heap = expr_heap,
284
285
							ci_new_functions = [], ci_new_variables = [], ci_fun_heap = newHeap, ci_next_fun_nr = nr_of_funs, ci_placeholders_and_tc_args = [],
							ci_generated_global_tc_placeholders = False,
286
							ci_used_tcs = [],ci_symb_ident = dynamic_temp_symb_ident , ci_sel_type_field =  ci_sel_type_field, ci_sel_value_field = ci_sel_value_field, 
287
288
							ci_module_id_symbol = App module_symb,
							ci_internal_type_id = module_id_app,
289
290
							ci_module_id		  = No,
							ci_type_id		      = ci_type_id })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
291
	  (groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap)
292
			= addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions main_dcl_module_n groups imported_types [] type_heaps ci_var_heap
293
	= (groups, { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs }, ci_predef_symb, imported_types, imported_conses, ci_var_heap, type_heaps, ci_expr_heap, tcl_file)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
294
295
296
297
where
	convert_groups group_nr groups global_type_instances fun_defs_and_ci
		| group_nr == size groups
			= (groups, fun_defs_and_ci)
298
			# (group, groups) = groups![group_nr]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
299
300
			= convert_groups (inc group_nr) groups global_type_instances (foldSt (convert_function group_nr global_type_instances) group.group_members fun_defs_and_ci)

301
		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
302
	convert_function group_nr global_type_instances fun (fun_defs, ci)
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
303
304
305
306
		# (fun_def, fun_defs) = fun_defs![fun]
		  {fun_body, fun_type, fun_info} = fun_def
		| isEmpty fun_info.fi_dynamics
			= (fun_defs, ci)
307
			
308
309
310
311
312
313
			// For each function which uses dynamics, a module id is constructed regardless
			// of its use. In some very specific cases, the let generated here is superfluous.
			# (TransformedBody fun_body=:{tb_rhs})
				= fun_body
			# (_,ci)
				= get_module_idN ci
314
315
316
			# (tb_rhs,ci)
				= build_type_identification tb_rhs ci
			# fun_body
317
318
319
				= {fun_body & tb_rhs = tb_rhs}
			# fun_body
				= TransformedBody fun_body
320
			
321
322
323
324
325
326
			# ci 
				= { ci & ci_used_tcs = [], ci_generated_global_tc_placeholders = False } //, ci_module_id = No }
			# (TransformedBody fun_body=:{tb_rhs}, ci) = convert_dynamics_in_body {cinp_st_args = [], cinp_glob_type_inst = global_type_instances, cinp_group_index = group_nr} fun_body fun_type ci
			
			# fun_body
				= TransformedBody fun_body
327
			
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
328
329
			= ({fun_defs & [fun] = { fun_def & fun_body = fun_body, fun_info = { fun_info & fi_local_vars = ci.ci_new_variables ++ fun_info.fi_local_vars }}},
				{ ci & ci_new_variables = [] })
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
		where
			get_module_idN ci=:{ci_internal_type_id}
				# (dst=:{var_info_ptr},ci)
					= newVariable "module_id" VI_Empty ci
				# dst_fv
					= varToFreeVar dst 1
		
				# let_bind
					= { lb_src = ci_internal_type_id
					,	lb_dst = dst_fv
					,	lb_position = NoPos
					}
				# ci
					= { ci & 
						ci_new_variables	= [ dst_fv : ci.ci_new_variables ]
					,	ci_module_id		= Yes let_bind
					}
				= (Var dst,ci)
		
			// identification of types generated by the compiler. If there is no TypeConsSymbol, then
			// no identification is necessary.
			build_type_identification dyn_type_code ci=:{ci_module_id=No}
				= abort "no ptr"; //(dyn_type_code,ci)
			build_type_identification dyn_type_code ci=:{ci_module_id=Yes let_bind}
354
				# (let_info_ptr,  ci)	= typed_let_ptr ci
355
356
357
358
359
360
361
362
363
364
				# letje
					= Let {	let_strict_binds	= [],
							let_lazy_binds		= [let_bind],
							let_expr			= dyn_type_code,
							let_info_ptr		= let_info_ptr,
							let_expr_position	= NoPos
					}
				= (letje,ci)


365
366
367
368
// MV ..
	convert_dynamics_in_body global_type_instances (TransformedBody {tb_args,tb_rhs}) (Yes {st_context, st_args}) ci
		# vars_with_types = bindVarsToTypes2 st_context tb_args st_args [] common_defs
// .. MV
369
		  (tb_rhs, ci) = convertDynamics {global_type_instances & cinp_st_args = tb_args} vars_with_types No tb_rhs ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
370
371
372
373
		= (TransformedBody {tb_args = tb_args,tb_rhs = tb_rhs}, ci)
	convert_dynamics_in_body global_type_instances other fun_type ci
		= abort "unexpected value in 'convert dynamics.convert_dynamics_in_body'"

374
375
376
377
// MV ..
bindVarsToTypes2 st_context vars types typed_vars common_defs
	:== bindVarsToTypes vars (addTypesOfDictionaries common_defs st_context types) typed_vars
// .. MV
378
379
380
381
382
bindVarsToTypes vars types typed_vars
	= fold2St bind_var_to_type vars types typed_vars
where
	bind_var_to_type var type typed_vars
		= [{tv_free_var = var, tv_type = type } : typed_vars]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399

class convertDynamics a :: !ConversionInput !BoundVariables !DefaultExpression !a !*ConversionInfo -> (!a, !*ConversionInfo)

instance convertDynamics [a]  |  convertDynamics a
where
	convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression ![a] !*ConversionInfo -> (![a], !*ConversionInfo)  |  convertDynamics a
	convertDynamics cinp bound_vars default_expr xs ci = mapSt (convertDynamics cinp bound_vars default_expr) xs ci

instance convertDynamics (Optional a)  |  convertDynamics a
where
	convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !(Optional a) !*ConversionInfo -> (!Optional a, !*ConversionInfo)  |  convertDynamics a
	convertDynamics cinp bound_vars default_expr (Yes x)	ci
		# (x, ci) = convertDynamics cinp bound_vars default_expr x ci
		= (Yes x, ci)
	convertDynamics _ _ _ No ci
		= (No, ci)

400
401
402
403
404
405
406
instance convertDynamics LetBind
where
	convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !LetBind !*ConversionInfo -> (!LetBind, !*ConversionInfo)
	convertDynamics cinp bound_vars default_expr binding=:{lb_src} ci
		# (lb_src, ci) = convertDynamics cinp bound_vars default_expr lb_src ci
		= ({binding &  lb_src = lb_src}, ci)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
407
408
409
410
411
412
413
414
415
instance convertDynamics (Bind a b)  |  convertDynamics a
where
	convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !(Bind a b) !*ConversionInfo -> (!Bind a b, !*ConversionInfo)  |  convertDynamics a
	convertDynamics cinp bound_vars default_expr binding=:{bind_src} ci
		# (bind_src, ci) = convertDynamics cinp bound_vars default_expr bind_src ci
		= ({binding &  bind_src = bind_src}, ci)

convertDynamicsOfAlgebraicPattern :: !ConversionInput !BoundVariables !DefaultExpression !(!AlgebraicPattern,[AType]) !*ConversionInfo -> (!AlgebraicPattern,!*ConversionInfo)
convertDynamicsOfAlgebraicPattern cinp bound_vars default_expr (algebraic_pattern=:{ap_vars, ap_expr}, arg_types_of_conses) ci
416
	# (ap_expr, ci) = convertDynamics cinp (bindVarsToTypes ap_vars arg_types_of_conses bound_vars) default_expr ap_expr ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
	= ({algebraic_pattern &  ap_expr = ap_expr}, ci)

instance convertDynamics BasicPattern
where
	convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !BasicPattern !*ConversionInfo -> (!BasicPattern, !*ConversionInfo)
	convertDynamics cinp bound_vars default_expr basic_pattern=:{bp_expr} ci
		# (bp_expr, ci) = convertDynamics cinp bound_vars default_expr bp_expr ci
		= ({basic_pattern &  bp_expr = bp_expr}, ci)


instance convertDynamics Expression
where
	convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !Expression !*ConversionInfo -> (!Expression, !*ConversionInfo)
	convertDynamics cinp bound_vars default_expr (Var var) ci
		= (Var var, ci)
	convertDynamics cinp bound_vars default_expr (App appje=:{app_args}) ci
		# (app_args,ci) = convertDynamics cinp bound_vars default_expr app_args ci
		= (App {appje &  app_args = app_args}, ci)
	convertDynamics cinp bound_vars default_expr (expr @ exprs) ci
		# (expr,  ci) = convertDynamics cinp bound_vars default_expr expr  ci
		  (exprs, ci) = convertDynamics cinp bound_vars default_expr exprs ci
		= (expr @ exprs, ci)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
439
	convertDynamics cinp bound_vars default_expr (Let letje=:{let_strict_binds, let_lazy_binds, let_expr,let_info_ptr}) ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
440
		# (let_types, ci) = determine_let_types let_info_ptr ci
441
442
// MW0		  bound_vars = bindVarsToTypes [ bind.bind_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars
		  bound_vars = bindVarsToTypes [ bind.lb_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars
Sjaak Smetsers's avatar
Sjaak Smetsers committed
443
444
445
446
		  (let_strict_binds, ci)	= convertDynamics cinp bound_vars default_expr let_strict_binds ci
		  (let_lazy_binds, ci)		= convertDynamics cinp bound_vars default_expr let_lazy_binds ci
		  (let_expr,  ci) 			= convertDynamics cinp bound_vars default_expr let_expr  ci
		= (Let { letje &  let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr}, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
447
448
449
450
451
452
453
454
455
456
457
458
459
	where
		determine_let_types let_info_ptr ci=:{ci_expr_heap}
			# (EI_LetType let_types, ci_expr_heap) = readPtr let_info_ptr ci_expr_heap
			= (let_types, { ci & ci_expr_heap = ci_expr_heap })

	convertDynamics cinp bound_vars default_expr (Case keesje=:{case_expr, case_guards, case_default, case_info_ptr}) ci
		# (case_expr,    ci) = convertDynamics cinp bound_vars default_expr case_expr ci
		  (case_default, ci) = convertDynamics cinp bound_vars default_expr case_default ci
		  (this_case_default, nested_case_default, ci) = determine_defaults case_default default_expr ci
		  (EI_CaseType {ct_cons_types, ct_result_type}, ci_expr_heap) = readPtr case_info_ptr ci.ci_expr_heap
		  ci = { ci & ci_expr_heap = ci_expr_heap }
		= case case_guards of
			(AlgebraicPatterns type algebraic_patterns)
460
461
462
463
464
465
466
467
468
469
470
// MV DEFAULT ...
				| not (isNo this_case_default) && any (\algebraic_pattern -> is_case_without_default algebraic_pattern) algebraic_patterns
					// a default to be moved inwards and a root positioned case not having a default
					// 
					// Example:
					//	loadandrun2 :: ![(!Dynamic, !Dynamic)] !*World -> *World
					//	loadandrun2 [(f :: BatchProcess i o, input :: i)] world = abort "alt BatchProcess"
					//	loadandrun2 [(f :: InteractiveProcess i o, input :: i)] world = abort "alt InteractiveProcess" 
					//	loadandrun2 _ _ = abort "Loader: process and input do not match"
					//
					# (Yes old_case_default) = this_case_default
471
//					# (let_info_ptr,  ci) = let_ptr ci
472
473
474
475
476
477
478
479
480
481
482
483
484
485
					# (default_var, ci) = newVariable "s" (VI_BoundVar {at_attribute=TA_None,at_annotation=AN_None,at_type=TE}) ci
					# default_fv = varToFreeVar default_var 1
					# ci
						= { ci & ci_new_variables = [default_fv : ci.ci_new_variables]}
					# let_bind = {
							lb_src = old_case_default
						,	lb_dst = default_fv
						, lb_position = NoPos }					
					# (new_case_default, nested_case_default, ci) 
						= determine_defaults (Yes (Var default_var)) default_expr ci
					# algebraic_patterns			
						= map (patch_defaults new_case_default) algebraic_patterns
					#  (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default)
														(zip2 algebraic_patterns ct_cons_types) ci
486
487
/* Sjaak */
					# (let_info_ptr,  ci) = let_ptr 1 ci
488
489
490
491
492
493
494
495
496
497
498
499
500
501
					# letje
						= Let {
							let_strict_binds	= []
						,	let_lazy_binds		= [let_bind]
						,	let_expr			= Case {keesje &  case_expr = case_expr, case_guards = AlgebraicPatterns type algebraic_patterns, case_default = new_case_default }
						,	let_info_ptr		= let_info_ptr
						,	let_expr_position	= NoPos
						}		
					-> (letje,ci)
			
					#  (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default)
														(zip2 algebraic_patterns ct_cons_types) ci
					-> (Case {keesje &  case_expr = case_expr, case_guards = AlgebraicPatterns type algebraic_patterns, case_default = this_case_default}, ci)
// ... MV DEFAULT
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
502
503
504
			(BasicPatterns type basic_patterns)
				#  (basic_patterns, ci) = convertDynamics  cinp bound_vars nested_case_default basic_patterns ci
				-> (Case {keesje &  case_expr = case_expr, case_guards = BasicPatterns type basic_patterns, case_default = this_case_default}, ci)
505
506
507
508
			(OverloadedListPatterns type decons_expr algebraic_patterns)
				#  (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default)
													(zip2 algebraic_patterns ct_cons_types) ci
				-> (Case {keesje &  case_expr = case_expr, case_guards = OverloadedListPatterns type decons_expr algebraic_patterns, case_default = this_case_default}, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
509
510
511
512
513
514
515
			(DynamicPatterns dynamic_patterns)
				#  keesje = {keesje &  case_expr = case_expr, case_default = this_case_default}
				-> convertDynamicPatterns cinp bound_vars keesje ci
			NoPattern
				-> (Case {keesje &  case_expr = case_expr, case_guards = NoPattern, case_default = this_case_default}, ci)
			_
				-> abort "unexpected value in convertDynamics: 'convertDynamics.CasePatterns'"
516
517
518
519
520
521
522
523
524
525
526
// MV DEFAULT ...
	where
		is_case_without_default {ap_expr=Case {case_default=No}}	= True
		is_case_without_default _									= False
	
		patch_defaults this_case_default ap=:{ap_expr=Case keesje=:{case_default=No}} 
			= { ap & ap_expr = Case {keesje & case_default = this_case_default} }
		patch_defaults _ expr
			= expr
// ... MV DEFAULT
			
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
527
528
529
530
531
532
533
534
535
536
537
538
539
540
	convertDynamics cinp bound_vars default_expr (Selection opt_symb expression selections) ci
		# (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci
		= (Selection opt_symb expression selections, ci)
	convertDynamics cinp bound_vars default_expr (Update expression1 selections expression2) ci
		# (expression1,ci) = convertDynamics cinp bound_vars default_expr expression1 ci
		# (expression2,ci) = convertDynamics cinp bound_vars default_expr expression2 ci
		= (Update expression1 selections expression2, ci)
	convertDynamics cinp bound_vars default_expr (RecordUpdate cons_symbol expression expressions) ci
		# (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci
		# (expressions,ci) = convertDynamics cinp bound_vars default_expr expressions ci
		= (RecordUpdate cons_symbol expression expressions, ci)
	convertDynamics cinp bound_vars default_expr (TupleSelect definedSymbol int expression) ci
		# (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci
		= (TupleSelect definedSymbol int expression, ci)
541
542
	convertDynamics _ _ _ be=:(BasicExpr basicValue) ci
		= (be, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
543
544
545
546
	convertDynamics _ _ _ (AnyCodeExpr codeBinding1 codeBinding2 strings) ci
		= (AnyCodeExpr codeBinding1 codeBinding2 strings, ci)
	convertDynamics _ _ _ (ABCCodeExpr strings bool) ci
		= (ABCCodeExpr strings bool, ci)
547
	convertDynamics cinp bound_vars default_expr (MatchExpr symb expression) ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
548
		# (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci
549
		= (MatchExpr symb expression, ci)
550
551
552
/* Sjaak ... */
	convertDynamics cinp bound_vars default_expr  (DynamicExpr {dyn_expr, dyn_info_ptr, dyn_type_code}) ci=:{ci_symb_ident}
		#  (dyn_expr,      ci) 			= convertDynamics cinp bound_vars default_expr dyn_expr ci
553
		   (_,dyn_type_code, _, _, ci)	= convertTypecode2 cinp dyn_type_code False [] [] ci
554
555
556
557
558
559
		= (App {	app_symb		= ci_symb_ident,
					app_args 		= [dyn_expr, dyn_type_code],
					app_info_ptr	= nilPtr }, ci)

/* ... Sjaak  */
/* WAS ...
560
561
	convertDynamics cinp bound_vars default_expr  (DynamicExpr {dyn_expr, dyn_info_ptr, dyn_uni_vars, dyn_type_code}) ci=:{ci_symb_ident}
		# (let_binds,     ci) 	= createVariables dyn_uni_vars [] ci
562
		  (dyn_expr,      ci) 	= convertDynamics cinp bound_vars default_expr dyn_expr ci
563
		  (_,dyn_type_code,_,_,ci) = convertTypecode2 cinp dyn_type_code False [] [] ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
564
		= case let_binds of
565
			[]	-> (App {	app_symb		= ci_symb_ident, //USE_TUPLES twoTuple_symb ci_symb_ident, //twoTuple_symb,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
566
567
							app_args 		= [dyn_expr, dyn_type_code],
							app_info_ptr	= nilPtr }, ci)
568
569
/* Sjaak */
			_ 	#  (let_info_ptr,  ci) = let_ptr (length let_binds) ci
Sjaak Smetsers's avatar
Sjaak Smetsers committed
570
571
				-> ( Let {	let_strict_binds	= [],
							let_lazy_binds		= let_binds,
572
							let_expr			= App {	app_symb		= ci_symb_ident, //USE_TUPLES twoTuple_symb ci_symb_ident,
Sjaak Smetsers's avatar
Sjaak Smetsers committed
573
574
														app_args 		= [dyn_expr, dyn_type_code],
														app_info_ptr	= nilPtr },
575
							let_info_ptr		= let_info_ptr,
576
							let_expr_position	= NoPos}, ci) 
577
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
578
	convertDynamics cinp bound_vars default_expr (TypeCodeExpression type_code) ci
579
		= abort "convertDynamics cinp bound_vars default_expr (TypeCodeExpression" //convertTypecode cinp type_code ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
580
581
582
583
	convertDynamics cinp bound_vars default_expr EE ci
		= (EE, ci)
	convertDynamics cinp bound_vars default_expr expression ci
		= abort "unexpected value in convertDynamics: 'convertDynamics.Expression'"
584
	
585
//convertTypecode ::  !ConversionInput TypeCodeExpression !*ConversionInfo  -> (Expression,!*ConversionInfo)
Martijn Vervoort's avatar
Martijn Vervoort committed
586
587
588
589
590
/*
	replace all references in a type code expression which refer to an argument i.e. the argument contains a
	type to their placeholders. Return is a list of (placeholder,argument) list. Each tuple is used later as
	arguments to the coerce relation. This should be optional
	
591

Martijn Vervoort's avatar
Martijn Vervoort committed
592
*/
593
594
595
596

/* Sjaak ... */
convertTypecode2 cinp (TCE_UniType uni_vars type_code) replace_tc_args binds placeholders_and_tc_args ci
		# (let_binds,     ci) 	= createVariables uni_vars [] ci
597
		  (let_info_ptr,  ci)	= let_ptr (length let_binds) ci
598
599
600
601
602
603
604
605
		  (e, type_code_expr, binds, placeholders_and_tc_args, ci)	= convertTypecode2 cinp type_code False [] [] ci
		= (e, Let {	let_strict_binds	= [],
					let_lazy_binds		= let_binds,
					let_expr			= type_code_expr,
					let_info_ptr		= let_info_ptr,
					let_expr_position	= NoPos}, binds, placeholders_and_tc_args, ci) 
/* ... Sjaak */

Martijn Vervoort's avatar
Martijn Vervoort committed
606
// ci_placeholders_and_tc_args
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
	#! cinp_st_args
		= filter (\{fv_info_ptr} -> fv_info_ptr == var_info_ptr) cinp_st_args
	| isEmpty cinp_st_args
		#! (e,binds,placeholders_and_tc_args,ci)
			= convertTypecode cinp t replace_tc_args binds placeholders_and_tc_args ci
		= (False,e,binds,placeholders_and_tc_args,ci)
		
		/*
		** the TCE_VAR is a TC argument and it is not part of a larger type expression. It
		** later suffices to generate a coerce instead of an application. This is an 
		** optimization.
		*/
		= (True,Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args,ci)

convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_TypeTerm var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
Martijn Vervoort's avatar
Martijn Vervoort committed
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
	#! cinp_st_args
		= filter (\{fv_info_ptr} -> fv_info_ptr == var_info_ptr) cinp_st_args
	| isEmpty cinp_st_args
		#! (e,binds,placeholders_and_tc_args,ci)
			= convertTypecode cinp t replace_tc_args binds placeholders_and_tc_args ci
		= (False,e,binds,placeholders_and_tc_args,ci)
		
		/*
		** the TCE_VAR is a TC argument and it is not part of a larger type expression. It
		** later suffices to generate a coerce instead of an application. This is an 
		** optimization.
		*/
		= (True,Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args,ci)

//		= convertTypecode2 cinp t replace_tc_args binds placeholders_and_tc_args ci
638
639
640
641
642
643

convertTypecode2 cinp t replace_tc_args binds placeholders_and_tc_args ci
	#! (e,binds,placeholders_and_tc_args,ci)
		= convertTypecode cinp t replace_tc_args binds placeholders_and_tc_args ci
	= (False,e,binds,placeholders_and_tc_args,ci)

Martijn Vervoort's avatar
Martijn Vervoort committed
644
645
convertTypecode cinp TCE_Empty replace_tc_args binds placeholders_and_tc_args ci 
	= (EE,binds,placeholders_and_tc_args,ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
646

647
convertTypecode cinp=:{cinp_st_args} (TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci=:{ci_placeholders_and_tc_args,ci_var_heap}
Martijn Vervoort's avatar
Martijn Vervoort committed
648
649
	| not replace_tc_args
		= (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
650

Martijn Vervoort's avatar
Martijn Vervoort committed
651
652
653
654
	// check if tc_arg has already been replaced by a placeholder
	#! ci_placeholder_and_tc_arg
		= filter (\(_,tc_args_ptr) -> tc_args_ptr == var_info_ptr) ci_placeholders_and_tc_args
	| not (isEmpty ci_placeholder_and_tc_arg)
655
656
657
658
659
660
661
662
663
664
		// an tc-arg has been found, add to the list of indirections to be restored and replace it by its placeholder

		#! placeholder_var 
			= (fst (hd ci_placeholder_and_tc_arg));
		#! ci_var_heap
			= adjust_ref_count placeholder_var.var_info_ptr ci.ci_var_heap
		= (Var {var_name = v_tc_placeholder_ident, var_info_ptr = placeholder_var.var_info_ptr, var_expr_ptr = nilPtr},binds,
				[(placeholder_var/*.var_info_ptr*/,var_info_ptr):placeholders_and_tc_args],{ci & ci_var_heap = ci_var_heap} );
				//placeholders_and_tc_args, ci)
				
Martijn Vervoort's avatar
Martijn Vervoort committed
665
		= (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args, ci)
666
667
668
669
where
	adjust_ref_count var_info_ptr var_heap
		# (VI_Indirection ref_count, var_heap) = readPtr var_info_ptr var_heap
		= var_heap <:= (var_info_ptr, VI_Indirection (inc ref_count))
Martijn Vervoort's avatar
Martijn Vervoort committed
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684

// 1st component of tuple is true iff:
// 1. The type is a TCE_Var or TCE_TypeTerm
// 2. It is also a argument of the function
// Thus a tc argument variable.
// This forms a special case: instead of an unify, a coerce can be generated
convertTypecode cinp (TCE_TypeTerm var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
	/*
	** TCE_Var and TCE_TypeTerm are not equivalent. A TCE_TypeTerm is used for an argument which contains
	** a type representation. A TCE_Var is an existential quantified type variable. In previous phases no
	** clear distinction is made. It should be possible to generate the proper type code expression for
	** these two but it would involve changing a lot of small things. 
	*/
	= convertTypecode cinp (TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci

685
686
convertTypecode cinp (TCE_Constructor index typecode_exprs) replace_tc_args binds placeholders_and_tc_args ci=:{ci_internal_type_id}
	# (typecons_symb,  ci) 									=  getSymbol PD_TypeConsSymbol SK_Constructor (USE_DummyModuleName 3 2) ci
Martijn Vervoort's avatar
Martijn Vervoort committed
687
688
	  constructor											= get_constructor cinp.cinp_glob_type_inst index
	  (typecode_exprs,binds,placeholders_and_tc_args,ci)	= convertTypecodes cinp typecode_exprs replace_tc_args binds placeholders_and_tc_args ci
689
690
	# (ci_internal_type_id,ci)
		= get_module_id ci
691
	= (App {app_symb		= typecons_symb,
692
			app_args 		= USE_DummyModuleName [constructor , ci_internal_type_id, typecode_exprs] [constructor , typecode_exprs] ,
Martijn Vervoort's avatar
Martijn Vervoort committed
693
			app_info_ptr	= nilPtr},binds,placeholders_and_tc_args,ci)
694
695
696
697
where
	get_module_id ci=:{ci_module_id=Yes {lb_dst}}
		= (Var (freeVarToVar lb_dst),ci)

Martijn Vervoort's avatar
Martijn Vervoort committed
698
699
700
convertTypecode cinp (TCE_Selector selections var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
	#! (var,binds,placeholders_and_tc_args,ci)		
		= convertTypecode cinp (TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
701
	= (Selection NormalSelector var selections,binds,placeholders_and_tc_args,ci)
702

Martijn Vervoort's avatar
Martijn Vervoort committed
703
704
//convertTypecodes :: !ConversionInput [TypeCodeExpression] !*ConversionInfo  -> (Expression,!*ConversionInfo)
convertTypecodes _ [] replace_tc_args binds placeholders_and_tc_args ci
705
706
707
	# (nil_symb, ci) = getSymbol PD_NilSymbol SK_Constructor 0 ci
	= (App {	app_symb		= nil_symb,
				app_args 		= [],
Martijn Vervoort's avatar
Martijn Vervoort committed
708
709
710
				app_info_ptr	= nilPtr},binds,placeholders_and_tc_args, ci)

convertTypecodes cinp [typecode_expr : typecode_exprs] replace_tc_args binds placeholders_and_tc_args ci
711
	# (cons_symb, ci) = getSymbol PD_ConsSymbol SK_Constructor 2 ci
Martijn Vervoort's avatar
Martijn Vervoort committed
712
713
	# (expr,binds,placeholders_and_tc_args, ci) = convertTypecode  cinp typecode_expr  replace_tc_args binds placeholders_and_tc_args ci
	# (exprs,binds,placeholders_and_tc_args,ci) = convertTypecodes cinp typecode_exprs replace_tc_args binds placeholders_and_tc_args ci
714
715
	= (App {	app_symb		= cons_symb,
				app_args 		= [expr , exprs],
Martijn Vervoort's avatar
Martijn Vervoort committed
716
				app_info_ptr	= nilPtr}, binds,placeholders_and_tc_args, ci)
717

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
718
719
720
721
722
723
724
determine_defaults :: (Optional Expression) DefaultExpression !*ConversionInfo -> (Optional Expression, DefaultExpression, !*ConversionInfo)
/***
determine_defaults :: case_default default_expr varheap -> (this_case_default, nested_case_default, var_heap)
	this_case_default =	IF this case has no default, but there is a surrounding default
						THEN that is now the default and its reference count must be increased.
						ELSE it keeps this default
	nested_case_default  = 	IF this case has no default
Martijn Vervoort's avatar
Martijn Vervoort committed
725
		 					THEN the default_expr remains default in the nested cases.
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
726
							ELSE nested cases get this default. This is semantically already the case, so nothing has to be changed.
Martijn Vervoort's avatar
Martijn Vervoort committed
727

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
728
***/
Martijn Vervoort's avatar
Martijn Vervoort committed
729
730
731
732



// the case itself has no default but it has a surrounding default
733
734
735
736
/*
	1st 	= default of current case
	2nd 	= directly surrounding default
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
737
determine_defaults No default_expr=:(Yes (var=:{var_info_ptr}, indirection_var_list)) ci=:{ci_var_heap}
738
	# (var_info, ci_var_heap) = readPtr var_info_ptr ci_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
739
	# (expression, ci) = toExpression default_expr {ci & ci_var_heap = ci_var_heap}
740
	# expression
Martijn Vervoort's avatar
Martijn Vervoort committed
741
		= expression// ---> expression
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
742
743
744
745
746
747
748
749
750
751
752
753
	= case var_info of
		VI_Default ref_count
			-> (expression, default_expr, {ci & ci_var_heap = ci.ci_var_heap <:= (var_info_ptr, VI_Default (inc ref_count))} )
		_
			-> (expression, default_expr, ci )
determine_defaults case_default _ ci
	= (case_default, No, ci)


add_dynamic_bound_vars :: ![DynamicPattern] BoundVariables -> BoundVariables
add_dynamic_bound_vars [] bound_vars = bound_vars
add_dynamic_bound_vars [{dp_var, dp_type_patterns_vars} : patterns] bound_vars
754
	= add_dynamic_bound_vars patterns (foldSt bind_info_ptr dp_type_patterns_vars [ {tv_free_var = dp_var, tv_type = empty_attributed_type } : bound_vars ])
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
755
where
756
757
	bind_info_ptr var_info_ptr bound_vars
		= [{ tv_free_var = {fv_def_level = NotALevel, fv_name = a_ij_var_name, fv_info_ptr = var_info_ptr, fv_count = 0}, tv_type = empty_attributed_type } : bound_vars]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
758

759
open_dynamic :: Expression !*ConversionInfo -> (OpenedDynamic, LetBind, !*ConversionInfo)
760
open_dynamic dynamic_expr ci=:{ci_sel_type_field, ci_sel_value_field}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
761
762
	# (twotuple, ci) = getTupleSymbol 2 ci
	  (dynamicType_var, ci) = newVariable "dt" VI_Empty ci
763
	  dynamicType_fv = varToFreeVar dynamicType_var 1
764
765
766
767
//	  sel_type = Selection No dynamic_expr [RecordSelection type_defined_symbol sd_type_field_nr]
//	  sel_value = Selection No dynamic_expr [RecordSelection value_defined_symbol sd_value_field_nr]
	= (	{ opened_dynamic_expr = ci_sel_value_field dynamic_expr /*USE_TUPLES (TupleSelect twotuple 0 dynamic_expr) sel_value*/, opened_dynamic_type = Var dynamicType_var },
//  RecordSelection !(Global DefinedSymbol) !Int
768
// MW0	  	{ bind_src = TupleSelect twotuple 1 dynamic_expr, bind_dst = dynamicType_fv },
769
	  	{ lb_src = ci_sel_type_field dynamic_expr /*USE_TUPLES (TupleSelect twotuple 1 dynamic_expr) sel_type*/, lb_dst = dynamicType_fv, lb_position = NoPos },
770
	  	{ ci & ci_new_variables = [ dynamicType_fv : ci.ci_new_variables ]})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
771
772
773
774
775
776
777
/**************************************************************************************************/

convertDynamicPatterns :: !ConversionInput !BoundVariables !Case *ConversionInfo -> (Expression, *ConversionInfo)
convertDynamicPatterns cinp bound_vars {case_guards = DynamicPatterns [], case_default} ci
	= case case_default of
		(Yes expr)	-> (expr, ci)
		No			-> abort "unexpected value in convertDynamics: 'convertDynamicPatterns'"
778
779
convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards = DynamicPatterns patterns, case_default, case_info_ptr} 
			ci=:{ci_placeholders_and_tc_args=old_ci_placeholders_and_tc_args,ci_generated_global_tc_placeholders}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
780
	# (opened_dynamic, dt_bind, ci) = open_dynamic case_expr ci
781
	  (ind_0, ci) = newVariable "ind_0" (VI_Indirection 0) ci
782
	  (c_1,   ci) = newVariable "c_1!" (VI_Default 0) ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
783
784
      new_default = newDefault c_1 ind_0
      (result_type, ci) = getResultType case_info_ptr ci
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
    
    #! // TC PLACEHOLDERS...
  	  (tc_binds,(bound_vars,ci))
  	  	= case ci_generated_global_tc_placeholders of
  	  		True	-> ([],(bound_vars,ci))
  	  		_		
  	  				#! (tc_binds,(bound_vars,ci))
  	  					= mapSt f cinp_st_args (bound_vars,ci)
  	  				#! ci
  	  					= { ci & ci_generated_global_tc_placeholders = True}
  	  				-> (tc_binds,(bound_vars,ci))
      // ...TC PLACEHOLDERS

	#

800
801
// MW0      bound_vars = addToBoundVars (freeVarToVar dt_bind.bind_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type
      bound_vars = addToBoundVars (freeVarToVar dt_bind.lb_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
802
      							  (addToBoundVars c_1 result_type (add_dynamic_bound_vars patterns bound_vars)))
803
804

																// c_1 ind_0
805
	  (binds, expr, ci) = convert_dynamic_pattern cinp bound_vars new_default 1 opened_dynamic result_type case_default patterns ci
806
807
808
809
	# ci
		= { ci & ci_placeholders_and_tc_args=old_ci_placeholders_and_tc_args}
	# (tc_binds,ci)
		= foldSt remove_non_used_arg tc_binds ([],ci) 
810
811
/* Sjaak */		
	  (let_info_ptr, ci) = let_ptr (length  binds + length tc_binds + 1) ci
812

813
814
815
// MW0	= (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr, let_info_ptr = let_info_ptr}, ci)
	= (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr,
			let_info_ptr = let_info_ptr, let_expr_position = NoPos }, ci)
816
where
817
818
819
// MW0	remove_non_used_arg :: (Bind Expression FreeVar) ([Bind Expression FreeVar],*ConversionInfo) -> ([Bind Expression FreeVar],*ConversionInfo)
	remove_non_used_arg :: LetBind ([LetBind],*ConversionInfo) -> ([LetBind],*ConversionInfo)
	remove_non_used_arg tc_bind=:{lb_dst={fv_info_ptr}} (l,ci=:{ci_var_heap})
820
821
822
		# (VI_Indirection ref_count, ci_var_heap) = readPtr fv_info_ptr ci_var_heap
		| ref_count > 0
			#! tc_bind
823
				= { tc_bind & lb_dst = { tc_bind.lb_dst & fv_count = ref_count} }
824
825
826
827
828
829
830
831
832
833
834
			= ([tc_bind:l],{ci & ci_var_heap = ci_var_heap})
			
			= (l,{ci & ci_var_heap = ci_var_heap})

	// too many new variables are created because also non-tc args are included; should be improved in the future
	f st_arg (bound_vars,ci=:{ci_placeholders_and_tc_args})
		// create placeholder variable for arg
		#! v
			= VI_Indirection 0
							
  		#! (placeholder_var, ci) 
Martijn Vervoort's avatar
Martijn Vervoort committed
835
			= newVariable v_tc_placeholder v ci //---> st_arg
836
837
838
839
840
841
842
843
844
845
846
847
848
		#! (bind,ci)
			= create_variable v_tc_placeholder_ident_global placeholder_var.var_info_ptr ci
		
		// associate newly create placeholder variable with its tc
		#! ci
			= { ci & 
				ci_placeholders_and_tc_args = [(placeholder_var,st_arg.fv_info_ptr):ci_placeholders_and_tc_args]
			}
			
		#! bound_vars2
			= addToBoundVars placeholder_var empty_attributed_type bound_vars
		= (bind,(bound_vars2,ci));
	where
849
850
// MW0		create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo)
		create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo)
851
852
853
854
		create_variable var_name var_info_ptr ci
			# (placeholder_symb, ci) = getSymbol PD_variablePlaceholder SK_Constructor 3 ci
			  cyclic_var = {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}	
			  cyclic_fv = varToFreeVar cyclic_var 1	
855
856
857
858
859
860
861
// MW0			= ({ bind_src = App {	app_symb = placeholder_symb,
			= ({ lb_src = App {	app_symb = placeholder_symb,
								app_args = [Var cyclic_var, Var cyclic_var],
								app_info_ptr = nilPtr },
// MW0				 bind_dst = varToFreeVar cyclic_var 1
				 lb_dst = varToFreeVar cyclic_var 1,
				 lb_position = NoPos
862
863
864
			   },
			   { ci & ci_new_variables = [ cyclic_fv : ci.ci_new_variables ]} /*ci*/)
			   
865
	add_coercions _ [] _ _ bound_vars dp_rhs ci
866
		= (bound_vars,dp_rhs,ci)
867
	add_coercions result_type [({var_info_ptr=a_ij},a_ij_tc):rest] this_default q bound_vars dp_rhs ci=:{ci_module_id_symbol}
868
869
870
871
872
873
874
875
876
877
		// extra
		# a_ij_var = {var_name = a_ij_var_name, var_info_ptr = a_ij, var_expr_ptr = nilPtr}	
		# a_ij_tc_var = {var_name = a_aij_tc_var_name, var_info_ptr = a_ij_tc, var_expr_ptr = nilPtr}
		
		// indirections
		# (ind_i,   ci) = newVariable "ind_1" (VI_Indirection (if (isNo this_default) 0 1)) ci
		  (c_inc_i, ci) = newVariable "c_!" (VI_Indirection 1) ci
		  new_default = newDefault c_inc_i ind_i
		  
		#		
878
		  (coerce_symb, ci)		= getSymbol PD_coerce SK_Function (extended_unify_and_coerce 2 3) ci
879
		  (twotuple, ci) 		= getTupleSymbol 2 ci
880
//Sjaak		  (case_info_ptr, ci)	= case_ptr ci
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
		
		  (coerce_result_var, ci)	= newVariable "result" VI_Empty ci
		  coerce_result_fv 			= varToFreeVar coerce_result_var 1
		  (coerce_bool_var, ci)		= newVariable "coerce_bool" VI_Empty ci
		  coerce_bool_fv 			= varToFreeVar coerce_bool_var 1
		  
		# (let_binds, ci) 		= bind_indirection_var ind_i coerce_result_var twotuple ci
		
		  ind_i_fv = varToFreeVar ind_i 1
		  c_inc_i_fv = varToFreeVar c_inc_i 1
		  ci = { ci & ci_new_variables = [ c_inc_i_fv,ind_i_fv : ci.ci_new_variables ] }
		  		
		#! new_default2 = newDefault c_inc_i ind_i
		
		#  (default_expr, ci) 	
		  	= case (isNo this_default) of 
		  		False
		  			-> toExpression new_default2 ci
		  		True
		  			-> (No,ci)
		  			
		// extra
		# (bound_vars,new_dp_rhs,ci)
904
			= add_coercions result_type rest (if (isNo this_default) No new_default2) q bound_vars dp_rhs ci 
905
906
907
		
		#! (opt_expr,ci)
			= toExpression this_default ci
908
909
			
		#! app_args2 = extended_unify_and_coerce [Var a_ij_var, Var a_ij_tc_var] [Var a_ij_var, Var a_ij_tc_var, ci_module_id_symbol ]
910
/* Sjaak ... */
911

912
		# let_lazy_binds		= (if (isNo this_default) [] [ {lb_src = opt opt_expr, lb_dst = c_inc_i_fv, lb_position = NoPos }]) ++ [
913
										  { lb_src = App { app_symb = coerce_symb,  app_args = app_args2,  app_info_ptr = nilPtr },
914
										   lb_dst = coerce_result_fv, lb_position = NoPos }
915
										   ,
916
										 { lb_src = /*USE_TUPLES (*/ TupleSelect twotuple 0 (Var coerce_result_var) /*) sel_type*/,
917
										   lb_dst = coerce_bool_fv, lb_position = NoPos } : let_binds
918
919
										]
		  (let_info_ptr, ci) 	= let_ptr (length let_lazy_binds) ci
920
		  (case_info_ptr, ci)	= bool_case_ptr result_type ci
921
922
923
924
925
926
927
928
/* ... Sjaak */

		# let_expr
			= Let {
					let_strict_binds	= []
				,	let_lazy_binds		= let_lazy_binds
				,	let_expr =
							 Case {			case_expr 		= Var coerce_bool_var,
929
930
931
932
											case_guards		= BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = new_dp_rhs, bp_position = NoPos }],
											case_default	= default_expr,
											case_ident		= No,
											case_info_ptr	= case_info_ptr,
933
934
935
// RWS ...
											case_explicit	= False,
// ... RWS
936
937
											case_default_pos= NoPos } // MW4++
				,	let_info_ptr = let_info_ptr	
938
				,	let_expr_position = NoPos // MW0++
939
940
941
942
943
944
945
				}
		
		// dp_rhs
		= (bound_vars,let_expr,{ ci & ci_new_variables = [coerce_result_fv, coerce_bool_fv : ci.ci_new_variables]}) //let_expr,ci)	
	where 
		opt (Yes x)		= x
			
946
	convert_dynamic_pattern :: !ConversionInput !BoundVariables DefaultExpression Int OpenedDynamic AType (Optional Expression) ![DynamicPattern] *ConversionInfo
947
948
/// MW0		-> (Env Expression FreeVar, Expression, *ConversionInfo)
		-> ([LetBind], Expression, *ConversionInfo)
949
	convert_dynamic_pattern cinp bound_vars this_default pattern_number opened_dynamic result_type last_default
950
951
																			[{ dp_var, dp_type_patterns_vars, dp_type_code, dp_rhs } : patterns] ci=:{ci_module_id_symbol}
														
Martijn Vervoort's avatar
Martijn Vervoort committed
952
		# /***  The last case may not have a default  ***/
953
954
955
956
957
958
959

		  ind_var = getIndirectionVar this_default
	
	      this_default = if (isEmpty patterns && (isNo last_default)) No this_default
	
		  /***  convert the elements of this pattern  ***/

960
		  (a_ij_binds, ci)		= createVariables dp_type_patterns_vars [] ci
961
	 	  (generate_coerce,type_code,_,martijn, ci)	= convertTypecode2 cinp dp_type_code True /* should be changed to True for type dependent functions */  /* WAS: a_ij_binds*/ [] [] ci //{ci & ci_module_id = No} // ci
962
963
964
965
966
967
968
969
970
971
	
		// collect ...
	 	# (is_last_dynamic_pattern,dp_rhs) 
	 		= isLastDynamicPattern dp_rhs;
		# ci
			= foldSt add_tcs martijn ci
		// ... collect
			
	 	#	
	 	  // walks through the patterns of the next alternative
972
	 	  (dp_rhs, ci)			= convertDynamics cinp bound_vars this_default dp_rhs ci
973
974
975
976
977
978
979
980
	 	  	 		
		// collect ...
		#! (ci_old_used_tcs,ci)
			= ci!ci_used_tcs;
	 	# ci
	 		= { ci & ci_used_tcs = [] }
		// ... collect
			 		
Martijn Vervoort's avatar
Martijn Vervoort committed
981
		  /***  recursively convert the other patterns in the other alternatives ***/
982

983
	 	#!  (binds, ci)		= convert_other_patterns cinp bound_vars this_default pattern_number opened_dynamic result_type last_default patterns ci
984

985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000

		// collect ...
	 	# ci
	 		= { ci & ci_used_tcs = ci_old_used_tcs }
		# ci_used_tcs
			= ci_old_used_tcs
	 	  
	 	#! (dp_rhs,ci)
	 		= case ((is_last_dynamic_pattern) /*&& (not generate_coerce)*/) of
	 			True
	 				// last dynamic pattern of the group of dynamic pattern so coercions must be generated.
	 				 #! (ci_placeholders_and_tc_args,ci)
	 					= ci!ci_placeholders_and_tc_args
	 				
	 				#! used_ci_placeholders_and_tc_args
	 					= filter (\(_,ci_placeholders_and_tc_arg) -> isMember ci_placeholders_and_tc_arg ci_used_tcs) ci_placeholders_and_tc_args