convertDynamics.icl 57.6 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
import syntax, transform, utilities, convertcases, compilerSwitches
7
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 type_io; 
13
//import pp;
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
14

Martijn Vervoort's avatar
Martijn Vervoort committed
15
/*2.0
16
from type_io_common import class toString (..),instance toString GlobalTCType;
Martijn Vervoort's avatar
Martijn Vervoort committed
17
18
0.2*/

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
19
20
21
22
::	*ConversionInfo =
	{	ci_predef_symb		:: !*PredefinedSymbols
	,	ci_var_heap			:: !*VarHeap
	,	ci_expr_heap		:: !*ExpressionHeap
23
	,	ci_new_variables 	:: ![FreeVar]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
24
25
26
	,	ci_new_functions 	:: ![FunctionInfoPtr]
	,	ci_fun_heap			:: !*FunctionHeap
	,	ci_next_fun_nr		:: !Index
Martijn Vervoort's avatar
Martijn Vervoort committed
27
28
	
	//	data needed to generate coercions
29
	,	ci_placeholders_and_tc_args				:: [(!BoundVar,Ptr VarInfo)]
30
31
	,	ci_generated_global_tc_placeholders		:: !Bool
	,	ci_used_tcs								:: [Ptr VarInfo]
32
33
34
35
	,	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
36
37
	,	ci_internal_type_id						:: Expression
	,	ci_module_id							:: Optional LetBind
38
	,	ci_type_id								:: !Optional !TypeSymbIdent
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
39
40
41
42
43
	}

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

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

:: DefaultExpression :== Optional (BoundVar, [IndirectionVar])   //DefaultRecord
53
54
55

::	BoundVariables :== [TypedVariable]

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
56
:: IndirectionVar    :== BoundVar
57

58
59
60

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

62
63
F :: !a .b -> .b
F a b = b
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
64

65
66

//write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File)
Martijn Vervoort's avatar
Martijn Vervoort committed
67
68
69
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]
70
71
	# write_type_info_state2
		= { WriteTypeInfoState |
Martijn Vervoort's avatar
Martijn Vervoort committed
72
73
74
			wtis_type_heaps				= type_heaps
		,	wtis_n_type_vars			= 0
		,	wtis_predefined_module_def	= pre_mod.pds_def
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
		};
	# (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
90
91
	#! tcl_file
		= fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file
Martijn Vervoort's avatar
Martijn Vervoort committed
92
93
	#! tcl_file
		= fwritei (size main_dcl_module.dcl_common.com_cons_defs) tcl_file
Martijn Vervoort's avatar
Martijn Vervoort committed
94
	= (True,tcl_file,type_heaps,predefined_symbols) 
95
96
97
98
	
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
99
//---> ("dcl",size main_dcl_module.dcl_common.com_type_defs, "icl", size common_defs.com_type_defs);
100

Martijn Vervoort's avatar
Martijn Vervoort committed
101
102
103
104
/*2.0
f (Yes tcl_file)
	= tcl_file;
0.2*/
105
			
106
107
108
convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap (Optional !*File) {# DclModule} !IclModule [String]
			-> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, (Optional !*File))
convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap tcl_file dcl_mods icl_mod directly_imported_dcl_modules
Martijn Vervoort's avatar
Martijn Vervoort committed
109
	# (tcl_file,type_heaps,predefined_symbols)
110
111
		= case tcl_file of
			No
Martijn Vervoort's avatar
Martijn Vervoort committed
112
113
114
115
116
117
				-> (No,type_heaps,predefined_symbols)
/*2.0
			_ 
				# tcl_file = f tcl_file;
0.2*/
//1.3
118
			(Yes tcl_file)
Martijn Vervoort's avatar
Martijn Vervoort committed
119
120
//3.1
				# (ok,tcl_file,type_heaps,predefined_symbols)
121
					= write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file directly_imported_dcl_modules type_heaps predefined_symbols
122
123
				| not ok
					-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
Martijn Vervoort's avatar
Martijn Vervoort committed
124
					-> (Yes tcl_file,type_heaps,predefined_symbols)
125
	# ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamic]
126
127
128
129
130
131
	#! (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)
			_	
				 
132
				-> case (USE_TUPLES True False) of
133
134
135
					True
						# arity = 2
						// get tuple arity 2 constructor
136
137
						# ({pds_module, pds_def}, predefined_symbols)	= predefined_symbols![GetTupleConsIndex arity]
						# pds_ident = predefined_idents.[GetTupleConsIndex arity]
138
						# twoTuple_symb	= { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def} }
139
140
						
						// get tuple, type and value selectors
141
142
						# ({pds_def}, predefined_symbols) = predefined_symbols![GetTupleConsIndex arity]
						# pds_ident = predefined_idents.[GetTupleConsIndex arity]
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
						# 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
169
												,	ds_index		= pds_def2 
170
												}
171
							,	glob_module		= pds_module2 
172
173
							}
						#! ci_sel_type_field
174
							= (\dynamic_expr -> Selection NormalSelector dynamic_expr [RecordSelection type_defined_symbol sd_field_nr])
175
							
176
177
178
179
180
181
182
183
184
185
						// 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
186
												,	ds_index		= pds_def3 
187
												}
188
							,	glob_module		= pds_module3
189
190
							}
						#! ci_sel_value_field
191
							= (\dynamic_expr -> Selection NormalSelector dynamic_expr [RecordSelection value_defined_symbol sd_field_nr3])
192
193
						-> (dynamic_temp_symb_ident, ci_sel_value_field, ci_sel_type_field,predefined_symbols)
						
194
195
	# (module_symb,module_id_app,predefined_symbols)
		= get_module_id_app predefined_symbols
196
197
198

	# ({pds_module=pds_type_id_module, pds_def=pds_type_id_def} , predefined_symbols) = predefined_symbols![PD_TypeID]
	# ci_type_id
199
200
201
202
203
204
205
206
207
208
209
210
211
		= case (pds_type_id_module == NoIndex || pds_type_id_def == NoIndex) of
			True
				-> No
			_
				# {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 }
					};
				-> Yes ci_type_id
212
						
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
213
	#! nr_of_funs = size fun_defs
214
	# imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
215
216
217
	# (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,
218
219
							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,
220
							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, 
221
222
							ci_module_id_symbol = App module_symb,
							ci_internal_type_id = module_id_app,
223
224
							ci_module_id		  = No,
							ci_type_id		      = ci_type_id })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
225
	  (groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap)
226
			= addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions main_dcl_module_n groups imported_types [] type_heaps ci_var_heap
227
	= (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
228
229
230
231
where
	convert_groups group_nr groups global_type_instances fun_defs_and_ci
		| group_nr == size groups
			= (groups, fun_defs_and_ci)
232
			# (group, groups) = groups![group_nr]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
233
234
			= convert_groups (inc group_nr) groups global_type_instances (foldSt (convert_function group_nr global_type_instances) group.group_members fun_defs_and_ci)

235
		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
236
	convert_function group_nr global_type_instances fun (fun_defs, ci)
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
237
238
239
240
		# (fun_def, fun_defs) = fun_defs![fun]
		  {fun_body, fun_type, fun_info} = fun_def
		| isEmpty fun_info.fi_dynamics
			= (fun_defs, ci)
241
			
242
243
244
245
246
247
			// 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
248
249
250
			# (tb_rhs,ci)
				= build_type_identification tb_rhs ci
			# fun_body
251
252
253
				= {fun_body & tb_rhs = tb_rhs}
			# fun_body
				= TransformedBody fun_body
254
			
255
			# ci 
256
				= { ci & ci_used_tcs = [], ci_generated_global_tc_placeholders = False }
257
258
259
260
			# (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
261
			
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
262
263
			= ({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 = [] })
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
		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}
288
				# (let_info_ptr,  ci)	= typed_let_ptr ci
289
290
291
292
293
294
295
296
297
298
				# 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)


299
300
	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
301
		  (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
302
303
304
305
		= (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'"

306
307
bindVarsToTypes2 st_context vars types typed_vars common_defs
	:== bindVarsToTypes vars (addTypesOfDictionaries common_defs st_context types) typed_vars
308
309
310
311
312
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
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329

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)

330
331
332
333
334
335
336
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
337
338
339
340
341
342
343
344
345
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
346
	# (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
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
	= ({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
369
	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
370
		# (let_types, ci) = determine_let_types let_info_ptr ci
371
		  bound_vars = bindVarsToTypes [ bind.lb_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars
Sjaak Smetsers's avatar
Sjaak Smetsers committed
372
373
374
375
		  (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
376
377
378
379
380
381
382
383
384
385
386
387
388
	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)
389
390
391
392
393
394
395
396
397
398
				| 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
399
					# (default_var, ci) = newVariable "s" (VI_BoundVar {at_attribute=TA_None,at_type=TE}) ci
400
401
402
403
404
405
406
407
408
409
410
411
412
					# 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
413
					# (let_info_ptr,  ci) = let_ptr 1 ci
414
415
416
417
418
419
420
421
422
423
424
425
426
					# 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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
427
428
429
			(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)
430
431
432
433
			(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
434
435
436
437
438
439
440
			(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'"
441
442
443
444
445
446
447
448
449
	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
			
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
450
451
452
453
454
455
456
457
458
459
460
461
462
463
	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)
464
465
	convertDynamics _ _ _ be=:(BasicExpr basicValue) ci
		= (be, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
466
467
468
469
	convertDynamics _ _ _ (AnyCodeExpr codeBinding1 codeBinding2 strings) ci
		= (AnyCodeExpr codeBinding1 codeBinding2 strings, ci)
	convertDynamics _ _ _ (ABCCodeExpr strings bool) ci
		= (ABCCodeExpr strings bool, ci)
470
	convertDynamics cinp bound_vars default_expr (MatchExpr symb expression) ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
471
		# (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci
472
		= (MatchExpr symb expression, ci)
473
474
	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
475
		   (_,dyn_type_code, _, _, ci)	= convertTypecode2 cinp dyn_type_code False PD_UV_Placeholder [] [] ci
476
477
478
		= (App {	app_symb		= ci_symb_ident,
					app_args 		= [dyn_expr, dyn_type_code],
					app_info_ptr	= nilPtr }, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
479
	convertDynamics cinp bound_vars default_expr (TypeCodeExpression type_code) ci
480
		= abort "convertDynamics cinp bound_vars default_expr (TypeCodeExpression" //convertTypecode cinp type_code ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
481
482
483
484
	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'"
485
	
Martijn Vervoort's avatar
Martijn Vervoort committed
486
487
488
489
490
/*
	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
	
491

Martijn Vervoort's avatar
Martijn Vervoort committed
492
*/
493

494
495
convertTypecode2 cinp (TCE_UniType uni_vars type_code) replace_tc_args uni_placeholder binds placeholders_and_tc_args ci
		# (let_binds,     ci) 	= createUniversalVariables uni_placeholder uni_vars [] ci
496
		  (let_info_ptr,  ci)	= let_ptr (length let_binds) ci
497
		  (e, type_code_expr, binds, placeholders_and_tc_args, ci)	= convertTypecode2 cinp type_code False uni_placeholder [] [] ci
498
499
500
501
502
503
		= (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) 

Martijn Vervoort's avatar
Martijn Vervoort committed
504
// ci_placeholders_and_tc_args
505
convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_Var var_info_ptr) replace_tc_args uni_placeholder binds placeholders_and_tc_args ci
506
507
508
509
510
511
512
513
514
515
516
517
518
519
	#! 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)

520
convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_TypeTerm var_info_ptr) replace_tc_args uni_placeholder binds placeholders_and_tc_args ci
Martijn Vervoort's avatar
Martijn Vervoort committed
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
	#! 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
536

537
convertTypecode2 cinp t replace_tc_args uni_placeholder binds placeholders_and_tc_args ci
538
539
540
541
	#! (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
542
543
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
544

545
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
546
547
	| 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
548

Martijn Vervoort's avatar
Martijn Vervoort committed
549
550
551
552
	// 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)
553
554
555
556
557
558
559
560
561
562
		// 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
563
		= (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args, ci)
564
565
566
567
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
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582

// 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

583
584
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
585
586
	  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
587
588
	# (ci_internal_type_id,ci)
		= get_module_id ci
589
	= (App {app_symb		= typecons_symb,
590
			app_args 		= USE_DummyModuleName [constructor , ci_internal_type_id, typecode_exprs] [constructor , typecode_exprs] ,
Martijn Vervoort's avatar
Martijn Vervoort committed
591
			app_info_ptr	= nilPtr},binds,placeholders_and_tc_args,ci)
592
593
594
595
where
	get_module_id ci=:{ci_module_id=Yes {lb_dst}}
		= (Var (freeVarToVar lb_dst),ci)

Martijn Vervoort's avatar
Martijn Vervoort committed
596
597
598
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
599
	= (Selection NormalSelector var selections,binds,placeholders_and_tc_args,ci)
600

Martijn Vervoort's avatar
Martijn Vervoort committed
601
602
//convertTypecodes :: !ConversionInput [TypeCodeExpression] !*ConversionInfo  -> (Expression,!*ConversionInfo)
convertTypecodes _ [] replace_tc_args binds placeholders_and_tc_args ci
603
604
605
	# (nil_symb, ci) = getSymbol PD_NilSymbol SK_Constructor 0 ci
	= (App {	app_symb		= nil_symb,
				app_args 		= [],
Martijn Vervoort's avatar
Martijn Vervoort committed
606
607
608
				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
609
	# (cons_symb, ci) = getSymbol PD_ConsSymbol SK_Constructor 2 ci
Martijn Vervoort's avatar
Martijn Vervoort committed
610
611
	# (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
612
613
	= (App {	app_symb		= cons_symb,
				app_args 		= [expr , exprs],
Martijn Vervoort's avatar
Martijn Vervoort committed
614
				app_info_ptr	= nilPtr}, binds,placeholders_and_tc_args, ci)
615

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
616
617
618
619
620
621
622
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
623
		 					THEN the default_expr remains default in the nested cases.
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
624
							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
625

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
626
***/
Martijn Vervoort's avatar
Martijn Vervoort committed
627
628
629
630



// the case itself has no default but it has a surrounding default
631
632
633
634
/*
	1st 	= default of current case
	2nd 	= directly surrounding default
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
635
determine_defaults No default_expr=:(Yes (var=:{var_info_ptr}, indirection_var_list)) ci=:{ci_var_heap}
636
	# (var_info, ci_var_heap) = readPtr var_info_ptr ci_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
637
	# (expression, ci) = toExpression default_expr {ci & ci_var_heap = ci_var_heap}
638
	# expression
Martijn Vervoort's avatar
Martijn Vervoort committed
639
		= expression// ---> expression
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
640
641
642
643
644
645
646
647
648
649
650
651
	= 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
652
	= 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
653
where
654
655
	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
656

657
open_dynamic :: Expression !*ConversionInfo -> (OpenedDynamic, LetBind, !*ConversionInfo)
658
open_dynamic dynamic_expr ci=:{ci_sel_type_field, ci_sel_value_field}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
659
660
	# (twotuple, ci) = getTupleSymbol 2 ci
	  (dynamicType_var, ci) = newVariable "dt" VI_Empty ci
661
	  dynamicType_fv = varToFreeVar dynamicType_var 1
662
663
	= (	{ opened_dynamic_expr = ci_sel_value_field dynamic_expr, opened_dynamic_type = Var dynamicType_var },
	  	{ lb_src = ci_sel_type_field dynamic_expr, lb_dst = dynamicType_fv, lb_position = NoPos },
664
	  	{ ci & ci_new_variables = [ dynamicType_fv : ci.ci_new_variables ]})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
665
666
667
668
669
670
671
/**************************************************************************************************/

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'"
672
673
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
674
	# (opened_dynamic, dt_bind, ci) = open_dynamic case_expr ci
675
	  (ind_0, ci) = newVariable "ind_0" (VI_Indirection 0) ci
676
	  (c_1,   ci) = newVariable "c_1!" (VI_Default 0) ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
677
678
      new_default = newDefault c_1 ind_0
      (result_type, ci) = getResultType case_info_ptr ci
679
    
680
    #! (tc_binds,(bound_vars,ci))
681
682
683
684
685
686
687
688
689
690
691
  	  	= 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))

	#

692
      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
693
      							  (addToBoundVars c_1 result_type (add_dynamic_bound_vars patterns bound_vars)))
694
695

																// c_1 ind_0
696
	  (binds, expr, ci) = convert_dynamic_pattern cinp bound_vars new_default 1 opened_dynamic result_type case_default patterns ci
697
698
699
700
	# ci
		= { ci & ci_placeholders_and_tc_args=old_ci_placeholders_and_tc_args}
	# (tc_binds,ci)
		= foldSt remove_non_used_arg tc_binds ([],ci) 
701
	  (let_info_ptr, ci) = let_ptr (length  binds + length tc_binds + 1) ci
702

703
704
	= (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)
705
where
706
707
	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})
708
709
710
		# (VI_Indirection ref_count, ci_var_heap) = readPtr fv_info_ptr ci_var_heap
		| ref_count > 0
			#! tc_bind
711
				= { tc_bind & lb_dst = { tc_bind.lb_dst & fv_count = ref_count} }
712
713
714
715
716
717
718
719
720
721
722
			= ([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
723
			= newVariable v_tc_placeholder v ci //---> st_arg
724
725
726
727
728
729
730
731
732
733
734
735
736
		#! (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
737
		create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo)
738
		create_variable var_name var_info_ptr ci
739
			# (placeholder_symb, ci) = getSymbol PD_PV_Placeholder SK_Constructor 2 ci
740
741
			  cyclic_var = {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}	
			  cyclic_fv = varToFreeVar cyclic_var 1	
742
743
744
745
746
			= ({ lb_src = App {	app_symb = placeholder_symb,
								app_args = [Var cyclic_var, Var cyclic_var],
								app_info_ptr = nilPtr },
				 lb_dst = varToFreeVar cyclic_var 1,
				 lb_position = NoPos
747
748
749
			   },
			   { ci & ci_new_variables = [ cyclic_fv : ci.ci_new_variables ]} /*ci*/)
			   
750
	add_coercions _ [] _ _ bound_vars dp_rhs ci
751
		= (bound_vars,dp_rhs,ci)
752
	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}
753
754
755
756
757
758
759
760
761
762
		// 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
		  
		#		
763
		  (coerce_symb, ci)		= getSymbol PD_coerce SK_Function (extended_unify_and_coerce 2 3) ci
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
		  (twotuple, ci) 		= getTupleSymbol 2 ci
		  (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)
787
			= add_coercions result_type rest (if (isNo this_default) No new_default2) q bound_vars dp_rhs ci 
788
789
790
		
		#! (opt_expr,ci)
			= toExpression this_default ci
791
792
			
		#! 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 ]
793
		# let_lazy_binds		= (if (isNo this_default) [] [ {lb_src = opt opt_expr, lb_dst = c_inc_i_fv, lb_position = NoPos }]) ++ [
794
										  { lb_src = App { app_symb = coerce_symb,  app_args = app_args2,  app_info_ptr = nilPtr },
795
										   lb_dst = coerce_result_fv, lb_position = NoPos }
796
										   ,
797
										 { lb_src = TupleSelect twotuple 0 (Var coerce_result_var),
798
										   lb_dst = coerce_bool_fv, lb_position = NoPos } : let_binds
799
800
										]
		  (let_info_ptr, ci) 	= let_ptr (length let_lazy_binds) ci
801
		  (case_info_ptr, ci)	= bool_case_ptr result_type ci
802
803
804
805
806
807
808

		# let_expr
			= Let {
					let_strict_binds	= []
				,	let_lazy_binds		= let_lazy_binds
				,	let_expr =
							 Case {			case_expr 		= Var coerce_bool_var,
809
810
811
812
											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,
813
											case_explicit	= False,
814
											case_default_pos= NoPos }
815
				,	let_info_ptr = let_info_ptr	
816
				,	let_expr_position = NoPos
817
818
819
820
821
822
823
				}
		
		// 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
			
824
	convert_dynamic_pattern :: !ConversionInput !BoundVariables DefaultExpression Int OpenedDynamic AType (Optional Expression) ![DynamicPattern] *ConversionInfo
825
		-> ([LetBind], Expression, *ConversionInfo)
826
	convert_dynamic_pattern cinp bound_vars this_default pattern_number opened_dynamic result_type last_default
827
																			[{ dp_var, dp_type_patterns_vars, dp_type_code, dp_rhs } : patterns] ci=:{ci_module_id_symbol}
Martijn Vervoort's avatar
Martijn Vervoort committed
828
		# /***  The last case may not have a default  ***/
829
830
831
832
833
834
835

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

836
		  (a_ij_binds, ci)		= createTypePatternVariables dp_type_patterns_vars [] ci
837
	 	  (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*/ PD_UPV_Placeholder [] [] ci //{ci & ci_module_id = No} // ci
838
839
840
841
842
843
844
845
	
	 	# (is_last_dynamic_pattern,dp_rhs) 
	 		= isLastDynamicPattern dp_rhs;
		# ci
			= foldSt add_tcs martijn ci
			
	 	#	
	 	  // walks through the patterns of the next alternative
846
	 	  (dp_rhs, ci)			= convertDynamics cinp bound_vars this_default dp_rhs ci
847
848
849
850
851
852
	 	  	 		
		#! (ci_old_used_tcs,ci)
			= ci!ci_used_tcs;
	 	# ci
	 		= { ci & ci_used_tcs = [] }
			 		
Martijn Vervoort's avatar
Martijn Vervoort committed
853
		  /***  recursively convert the other patterns in the other alternatives ***/
854

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

857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872

	 	# 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
					#! (bound_vars,dp_rhs,ci)
873
						= add_coercions result_type used_ci_placeholders_and_tc_args this_default binds bound_vars dp_rhs ci
874
875
876
877
	 				-> (dp_rhs,ci)
	 			False
	 				-> (dp_rhs,ci)
		#
878
		  /***  generate the expression  ***/
879
	 	  (unify_symb, ci) 		= getSymbol (if generate_coerce PD_coerce PD_unify ) SK_Function (extended_unify_and_coerce 2 3) /*3 was 2 */ ci
880
881
		  (twotuple, ci) 		= getTupleSymbol 2 ci
		  (default_expr, ci) 	= toExpression this_default ci
Martijn Vervoort's avatar
Martijn Vervoort committed
882
883
884
		  
		  // was coercions
		  
885
886
		  (unify_result_var, ci)	= newVariable "result" VI_Empty ci
		  unify_result_fv 			= varToFreeVar unify_result_var 1
887
		  (unify_bool_var, ci)		= newVariable (if generate_coerce "coerce_bool" "unify_bool") VI_Empty ci
888
889
		  unify_bool_fv 			= varToFreeVar unify_bool_var 1

Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
890
891
		  (let_binds, ci) 		= bind_indirection_var ind_var unify_result_var twotuple ci
		  a_ij_binds			= add_x_i_bind opened_dynamic.opened_dynamic_expr dp_var a_ij_binds
892

893
		  (let_info_ptr, ci) 	= let_ptr (2 + length let_binds) ci
894
		  (case_info_ptr, ci)	= bool_case_ptr result_type ci
895
896
897

		  app_args2 = extended_unify_and_coerce [opened_dynamic.opened_dynamic_type, type_code] [opened_dynamic.opened_dynamic_type, type_code, ci_module_id_symbol ]
		  
Sjaak Smetsers's avatar
Sjaak Smetsers committed
898
		  let_expr = Let {	let_strict_binds = [],
899
		  					let_lazy_binds = [{ lb_src = App { app_symb = unify_symb,  app_args = app_args2,  app_info_ptr = nilPtr },
900
		  								   lb_dst = unify_result_fv, lb_position = NoPos },
901
		  								 { lb_src = TupleSelect twotuple 0 (Var unify_result_var),
902
		  								   lb_dst = unify_bool_fv, lb_position = NoPos } : let_binds
903
904
		  								],
		  					let_expr = Case {	case_expr 		= Var unify_bool_var,
905
												case_guards		= BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs, bp_position = NoPos }],
906
907
												case_default	= default_expr,
												case_ident		= No,
908
												case_info_ptr	= case_info_ptr,
909
												case_explicit	= False,
910
												case_default_pos= NoPos },
911
912
		  					let_info_ptr = let_info_ptr,
		  					let_expr_position = NoPos }
Martijn Vervoort's avatar
Martijn Vervoort committed
913
		  					
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
914
		= (a_ij_binds ++ binds,  let_expr,  { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]})
915
	where
916
		add_x_i_bind lb_src lb_dst=:{fv_count} binds
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
917
			| fv_count > 0
918
				= [ { lb_src = lb_src, lb_dst = lb_dst, lb_position = NoPos } : binds ]
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
919
				= binds
920
921
922
923
924
925
926
927
928
929
930
				
		isLastDynamicPattern dp_rhs=:(Case keesje=:{case_guards=DynamicPatterns _})
			= (False,dp_rhs);
		
		isLastDynamicPattern dp_rhs
			= (True,dp_rhs); 
		
		add_tcs (_,tc) ci=:{ci_used_tcs}
			| isMember tc ci_used_tcs
				= ci;
				= {ci & ci_used_tcs = [tc:ci_used_tcs]}
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
931

Martijn Vervoort's avatar
Martijn Vervoort committed
932
	// other alternatives
933
	convert_other_patterns :: ConversionInput BoundVariables DefaultExpression Int OpenedDynamic AType !(Optional Expression) ![DynamicPattern] !*ConversionInfo
934
			-> ([LetBind], *ConversionInfo)
935
	convert_other_patterns _ _ _ _ _ _  No  []  ci
Martijn Vervoort's avatar
Martijn Vervoort committed
936
		// no default and no alternatives left
937
		= ([], ci)
938
939
		
//	The last_default is the default used when there are no pattern left
940
	convert_other_patterns cinp bound_vars this_default _ _ result_type (Yes last_default_expr) [] ci
Martijn Vervoort's avatar
Martijn Vervoort committed
941
		// default without alternatives left
942
		# c_i = getVariable1 this_default
943
944
		  (c_bind, ci) = generateBinding cinp bound_vars c_i last_default_expr result_type ci
		= ([c_bind], ci)
945

946
947
948
949
950
951
	convert_other_patterns cinp bound_vars this_default pattern_number opened_dynamic result_type last_default patterns ci
		# (ind_i,   ci) = newVariable ("ind_"+++toString (pattern_number)) (VI_Indirection 0) ci
		  (c_inc_i, ci) = newVariable ("c_"+++toString (inc pattern_number)) (VI_Default 0) ci
	      new_default = newDefault c_inc_i ind_i
	      bound_vars = addToBoundVars ind_i empty_attributed_type (addToBoundVars c_inc_i result_type bound_vars)
	 	  (binds, expr, ci) = convert_dynamic_pattern cinp bound_vars new_default (inc pattern_number) opened_dynamic result_type last_default patterns ci
952
		  c_i = getVariable2 this_default