convertDynamics.icl 60 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
30
31
32
33
34
35
36
37
38
39
	,	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
	,	ci_type_id										:: !Optional !TypeSymbIdent
	,	ci_type_constructor_used_in_dynamic_patterns	:: !*{#Bool}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
40
41
42
43
44
	}

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

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

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

::	BoundVariables :== [TypedVariable]

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

59
60
61

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

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

66
67

//write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File)
68
//write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] _ _ !*TypeHeaps !*PredefinedSymbols -> (.Bool,.File,!*TypeHeaps,!*PredefinedSymbols)
Martijn Vervoort's avatar
Martijn Vervoort committed
69
// write_tcl_file ({#},{!},{#},[{#Char}],CommonDefs,{#}) :: !.Int !{#y:DclModule} CommonDefs !*File [{#Char}] !{!x:GlobalTCType} {#w:Bool} !*TypeHeaps !{#v:PredefinedSymbol} -> (.Bool,.File,.TypeHeaps,{#PredefinedSymbol}), [u <= 
70
write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file directly_imported_dcl_modules global_type_instances ci_type_constructor_used_in_dynamic_patterns type_heaps predefined_symbols
Martijn Vervoort's avatar
Martijn Vervoort committed
71
	# (pre_mod, predefined_symbols) = predefined_symbols![PD_PredefinedModule]
72
73
	# write_type_info_state2
		= { WriteTypeInfoState |
Martijn Vervoort's avatar
Martijn Vervoort committed
74
75
			wtis_type_heaps				= type_heaps
		,	wtis_n_type_vars			= 0
76
		,	wtis_predefined_module_def	= pre_mod.pds_module
77
78
79
		};
	# (j,tcl_file)
		= fposition tcl_file
80

81
82
83
84
	#! (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
85
86
87
88
89
90

	// dynamic pattern matches
	#! type_constructors_in_dynamic_patterns
		= collect_type_constructors_in_dynamic_patterns 0 (size global_type_instances) []
	#! (tcl_file,write_type_info_state)
		= write_type_info type_constructors_in_dynamic_patterns tcl_file write_type_info_state
Martijn Vervoort's avatar
Martijn Vervoort committed
91
92
93
94
95
96

	#! (tcl_file,write_type_info_state)
		= write_type_info (help_20_compiler { dcl_name.id_name\\ {dcl_name} <-: dcl_mods }) tcl_file write_type_info_state
			with 
				help_20_compiler :: {#{#Char}} -> {#{#Char}}
				help_20_compiler l = l
97
98
		
	#! (type_heaps,_)
99
		= f write_type_info_state;	
100
		
Martijn Vervoort's avatar
Martijn Vervoort committed
101
102
	#! tcl_file
		= fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file
Martijn Vervoort's avatar
Martijn Vervoort committed
103
104
	#! tcl_file
		= fwritei (size main_dcl_module.dcl_common.com_cons_defs) tcl_file
Martijn Vervoort's avatar
Martijn Vervoort committed
105
				
Martijn Vervoort's avatar
Martijn Vervoort committed
106
	= (True,tcl_file,type_heaps,predefined_symbols) 
107
where
108
	collect_type_constructors_in_dynamic_patterns :: !Int !Int [TypeSymbIdent] -> [TypeSymbIdent]
109
110
111
112
113
114
115
116
	collect_type_constructors_in_dynamic_patterns i limit type_constructors_in_dynamic_patterns
		| i == limit
			= type_constructors_in_dynamic_patterns
			
			| isGTT_Constructor global_type_instances.[i]
				# (GTT_Constructor type_name=:{type_name={id_name}} module_name used_in_application_of_type_dependent_function)
					= global_type_instances.[i]
				| used_in_application_of_type_dependent_function || ci_type_constructor_used_in_dynamic_patterns.[i]
117
					= collect_type_constructors_in_dynamic_patterns (inc i) limit [type_name:type_constructors_in_dynamic_patterns]
118
119
120
121
122
123
					= collect_type_constructors_in_dynamic_patterns (inc i) limit type_constructors_in_dynamic_patterns
				= collect_type_constructors_in_dynamic_patterns (inc i) limit type_constructors_in_dynamic_patterns
	where
		isGTT_Constructor (GTT_Constructor _ _ _)	= True
		isGTT_Constructor _							= False
		
124
125
126
	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
127
128
129
130
/*2.0
f (Yes tcl_file)
	= tcl_file;
0.2*/
131
			
132
133
134
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
135
	# ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamic]
136
137
138
139
140
141
	#! (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)
			_	
				 
142
				-> case (USE_TUPLES True False) of
143
144
145
					True
						# arity = 2
						// get tuple arity 2 constructor
146
147
						# ({pds_module, pds_def}, predefined_symbols)	= predefined_symbols![GetTupleConsIndex arity]
						# pds_ident = predefined_idents.[GetTupleConsIndex arity]
148
						# twoTuple_symb	= { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def} }
149
150
						
						// get tuple, type and value selectors
151
152
						# ({pds_def}, predefined_symbols) = predefined_symbols![GetTupleConsIndex arity]
						# pds_ident = predefined_idents.[GetTupleConsIndex arity]
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
						# 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
179
												,	ds_index		= pds_def2 
180
												}
181
							,	glob_module		= pds_module2 
182
183
							}
						#! ci_sel_type_field
184
							= (\dynamic_expr -> Selection NormalSelector dynamic_expr [RecordSelection type_defined_symbol sd_field_nr])
185
							
186
187
188
189
190
191
192
193
194
195
						// 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
196
												,	ds_index		= pds_def3 
197
												}
198
							,	glob_module		= pds_module3
199
200
							}
						#! ci_sel_value_field
201
							= (\dynamic_expr -> Selection NormalSelector dynamic_expr [RecordSelection value_defined_symbol sd_field_nr3])
202
203
						-> (dynamic_temp_symb_ident, ci_sel_value_field, ci_sel_type_field,predefined_symbols)
						
204
205
	# (module_symb,module_id_app,predefined_symbols)
		= get_module_id_app predefined_symbols
206
207
208

	# ({pds_module=pds_type_id_module, pds_def=pds_type_id_def} , predefined_symbols) = predefined_symbols![PD_TypeID]
	# ci_type_id
209
210
211
212
213
214
215
216
217
218
219
220
221
		= 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
222
						
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
223
	#! nr_of_funs = size fun_defs
224
	#! s_global_type_instances = size global_type_instances
225
	# imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs }
226
	# (groups, (fun_defs, {ci_predef_symb, ci_var_heap, ci_expr_heap, ci_fun_heap, ci_new_functions, ci_type_constructor_used_in_dynamic_patterns}))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
227
228
			= convert_groups 0 groups global_type_instances (fun_defs, {	
							ci_predef_symb = predefined_symbols, ci_var_heap = var_heap, ci_expr_heap = expr_heap,
229
230
							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,
231
							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, 
232
233
							ci_module_id_symbol = App module_symb,
							ci_internal_type_id = module_id_app,
234
							ci_module_id		  = No,
235
236
237
							ci_type_id		      = ci_type_id,
							ci_type_constructor_used_in_dynamic_patterns	= createArray s_global_type_instances False
							})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
238
	  (groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap)
239
			= addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions main_dcl_module_n groups imported_types [] type_heaps ci_var_heap
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
			
	// store type info			
	# (tcl_file,type_heaps,ci_predef_symb)
		= case tcl_file of
			No
				-> (No,type_heaps,ci_predef_symb)
/*2.0
			_ 
				# tcl_file = f tcl_file;
0.2*/
//1.3
			(Yes tcl_file)
//3.1
				# (ok,tcl_file,type_heaps,ci_predef_symb)
					= write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file directly_imported_dcl_modules global_type_instances ci_type_constructor_used_in_dynamic_patterns type_heaps ci_predef_symb
				| not ok
					-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
					-> (Yes tcl_file,type_heaps,ci_predef_symb)

259
	= (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
260
261
262
263
where
	convert_groups group_nr groups global_type_instances fun_defs_and_ci
		| group_nr == size groups
			= (groups, fun_defs_and_ci)
264
			# (group, groups) = groups![group_nr]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
265
266
			= convert_groups (inc group_nr) groups global_type_instances (foldSt (convert_function group_nr global_type_instances) group.group_members fun_defs_and_ci)

267
		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
268
	convert_function group_nr global_type_instances fun (fun_defs, ci)
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
269
270
271
272
		# (fun_def, fun_defs) = fun_defs![fun]
		  {fun_body, fun_type, fun_info} = fun_def
		| isEmpty fun_info.fi_dynamics
			= (fun_defs, ci)
273
			
274
275
276
277
278
279
			// 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
280
281
282
			# (tb_rhs,ci)
				= build_type_identification tb_rhs ci
			# fun_body
283
284
285
				= {fun_body & tb_rhs = tb_rhs}
			# fun_body
				= TransformedBody fun_body
286
			
287
			# ci 
288
				= { ci & ci_used_tcs = [], ci_generated_global_tc_placeholders = False }
289
290
291
292
			# (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
293
			
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
294
295
			= ({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 = [] })
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
		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}
320
				# (let_info_ptr,  ci)	= typed_let_ptr ci
321
322
323
324
325
326
327
328
329
330
				# 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)


331
332
	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
333
		  (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
334
335
		= (TransformedBody {tb_args = tb_args,tb_rhs = tb_rhs}, ci)
	convert_dynamics_in_body global_type_instances other fun_type ci
336
		= abort "unexpected value in 'convert dynamics.convert_dynamics_in_body'"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
337

338
339
bindVarsToTypes2 st_context vars types typed_vars common_defs
	:== bindVarsToTypes vars (addTypesOfDictionaries common_defs st_context types) typed_vars
340
341
342
343
344
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
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361

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)

362
363
364
365
366
367
368
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
369
370
371
372
373
374
375
376
377
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
378
	# (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
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
	= ({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
401
	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
402
		# (let_types, ci) = determine_let_types let_info_ptr ci
403
		  bound_vars = bindVarsToTypes [ bind.lb_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars
Sjaak Smetsers's avatar
Sjaak Smetsers committed
404
405
406
407
		  (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
408
409
410
411
412
413
414
415
416
417
418
419
420
	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)
421
422
423
424
425
426
427
428
429
430
				| 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
431
					# (default_var, ci) = newVariable "s" (VI_BoundVar {at_attribute=TA_None,at_type=TE}) ci
432
433
434
435
436
437
438
439
440
441
442
443
444
					# 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
445
					# (let_info_ptr,  ci) = let_ptr 1 ci
446
447
448
449
450
451
452
453
454
455
456
457
458
					# 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
459
460
461
			(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)
462
463
464
465
			(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
466
467
468
469
470
471
472
			(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'"
473
474
475
476
477
478
479
480
481
	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
482
483
484
485
486
487
488
489
490
491
492
493
494
495
	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)
496
497
	convertDynamics _ _ _ be=:(BasicExpr basicValue) ci
		= (be, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
498
499
500
501
	convertDynamics _ _ _ (AnyCodeExpr codeBinding1 codeBinding2 strings) ci
		= (AnyCodeExpr codeBinding1 codeBinding2 strings, ci)
	convertDynamics _ _ _ (ABCCodeExpr strings bool) ci
		= (ABCCodeExpr strings bool, ci)
502
	convertDynamics cinp bound_vars default_expr (MatchExpr symb expression) ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
503
		# (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci
504
		= (MatchExpr symb expression, ci)
505
506
	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
507
		   (_,dyn_type_code, _, _, ci)	= convertTypecode2 cinp dyn_type_code False [] [] ci
508
509
510
		= (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
511
	convertDynamics cinp bound_vars default_expr (TypeCodeExpression type_code) ci
512
		= abort "convertDynamics cinp bound_vars default_expr (TypeCodeExpression" //convertTypecode cinp type_code ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
513
514
	convertDynamics cinp bound_vars default_expr EE ci
		= (EE, ci)
515
516
	convertDynamics cinp bound_vars default_expr expr=:(NoBind _) ci
		= (expr,ci)
517

Martijn Vervoort's avatar
Martijn Vervoort committed
518
519
/*
	
520
521
522
523
524
525
526
527
528
529
	is_dynamic_pattern (is_dynamic_pattern)
		True
			1) replace TC-references passed as an argument to the current function, in a type code expression by placeholders. A 
			   (placeholder,argument)-list is returned to generate the coercion later on.
			2) A PD_UPV_Placeholder is generated for each TCE_UniType-variable occuring in the type code expression.
			3) store type constructors in ci_type_constructor_used_in_dynamic_patterns
		False
			1) do *not* replace TC-reference
			2) A PD_UV_Placeholder is generated for each TCE_UniType-variable occuring in the type code expression.
			3) do *not* store type constructors
Martijn Vervoort's avatar
Martijn Vervoort committed
530
*/
531
532
convertTypecode2 cinp (TCE_UniType uni_vars type_code) is_dynamic_pattern binds placeholders_and_tc_args ci
		# (let_binds,     ci) 	= createUniversalVariables (if is_dynamic_pattern PD_UPV_Placeholder PD_UV_Placeholder) uni_vars [] ci
533
		  (let_info_ptr,  ci)	= let_ptr (length let_binds) ci
534
		  (e, type_code_expr, binds, placeholders_and_tc_args, ci)	= convertTypecode2 cinp type_code is_dynamic_pattern [] [] ci
535
536
537
538
539
540
		= (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) 

541
convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_Var var_info_ptr) is_dynamic_pattern binds placeholders_and_tc_args ci
542
543
544
545
	#! 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)
546
			= convertTypecode cinp t is_dynamic_pattern binds placeholders_and_tc_args ci
547
548
549
550
551
552
553
554
555
		= (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)

556
convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_TypeTerm var_info_ptr) is_dynamic_pattern binds placeholders_and_tc_args ci
Martijn Vervoort's avatar
Martijn Vervoort committed
557
558
559
560
	#! 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)
561
			= convertTypecode cinp t is_dynamic_pattern binds placeholders_and_tc_args ci
Martijn Vervoort's avatar
Martijn Vervoort committed
562
563
564
565
566
567
568
569
570
		= (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)

571
convertTypecode2 cinp t is_dynamic_pattern binds placeholders_and_tc_args ci
572
	#! (e,binds,placeholders_and_tc_args,ci)
573
		= convertTypecode cinp t is_dynamic_pattern binds placeholders_and_tc_args ci
574
575
	= (False,e,binds,placeholders_and_tc_args,ci)

576
convertTypecode cinp TCE_Empty is_dynamic_pattern binds placeholders_and_tc_args ci 
Martijn Vervoort's avatar
Martijn Vervoort committed
577
	= (EE,binds,placeholders_and_tc_args,ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
578

579
580
convertTypecode cinp=:{cinp_st_args} (TCE_Var var_info_ptr) is_dynamic_pattern binds placeholders_and_tc_args ci=:{ci_placeholders_and_tc_args,ci_var_heap}
	| not is_dynamic_pattern
Martijn Vervoort's avatar
Martijn Vervoort committed
581
		= (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
582

Martijn Vervoort's avatar
Martijn Vervoort committed
583
584
585
586
	// 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)
587
588
589
590
591
592
593
594
595
596
		// 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
597
		= (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args, ci)
598
599
600
601
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
602
603
604
605
606
607

// 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
608
convertTypecode cinp (TCE_TypeTerm var_info_ptr) is_dynamic_pattern binds placeholders_and_tc_args ci
Martijn Vervoort's avatar
Martijn Vervoort committed
609
610
611
612
613
614
	/*
	** 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. 
	*/
615
	= convertTypecode cinp (TCE_Var var_info_ptr) is_dynamic_pattern binds placeholders_and_tc_args ci
Martijn Vervoort's avatar
Martijn Vervoort committed
616

617
convertTypecode cinp (TCE_Constructor index typecode_exprs) is_dynamic_pattern binds placeholders_and_tc_args ci=:{ci_internal_type_id}
618
	# (typecons_symb,  ci) 									=  getSymbol PD_TypeConsSymbol SK_Constructor (USE_DummyModuleName 3 2) ci
619
620
	# (constructor,ci)										= get_constructor cinp.cinp_glob_type_inst index ci
	  (typecode_exprs,binds,placeholders_and_tc_args,ci)	= convertTypecodes cinp typecode_exprs is_dynamic_pattern binds placeholders_and_tc_args ci
621
622
	# (ci_internal_type_id,ci)
		= get_module_id ci
623
	= (App {app_symb		= typecons_symb,
624
			app_args 		= USE_DummyModuleName [constructor , ci_internal_type_id, typecode_exprs] [constructor , typecode_exprs] ,
Martijn Vervoort's avatar
Martijn Vervoort committed
625
			app_info_ptr	= nilPtr},binds,placeholders_and_tc_args,ci)
626
627
628
where
	get_module_id ci=:{ci_module_id=Yes {lb_dst}}
		= (Var (freeVarToVar lb_dst),ci)
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
		
	get_constructor :: !{!GlobalTCType} Index !*ConversionInfo -> (Expression,!*ConversionInfo)
	get_constructor glob_type_inst index ci=:{ci_type_constructor_used_in_dynamic_patterns}
		# ci 
			= case is_dynamic_pattern of
				True	-> { ci & ci_type_constructor_used_in_dynamic_patterns.[index] = True }
				_		-> ci
		= (BasicExpr (BVS ("\"" +++ toString  glob_type_inst.[index] +++ "\"")),ci)
		
	convertTypecodes _ [] is_dynamic_pattern binds placeholders_and_tc_args ci
		# (nil_symb, ci) = getSymbol PD_NilSymbol SK_Constructor 0 ci
		= (App {	app_symb		= nil_symb,
					app_args 		= [],
					app_info_ptr	= nilPtr},binds,placeholders_and_tc_args, ci)
	
	convertTypecodes cinp [typecode_expr : typecode_exprs] is_dynamic_pattern binds placeholders_and_tc_args ci
		# (cons_symb, ci) = getSymbol PD_ConsSymbol SK_Constructor 2 ci
		# (expr,binds,placeholders_and_tc_args, ci) = convertTypecode  cinp typecode_expr  is_dynamic_pattern binds placeholders_and_tc_args ci
		# (exprs,binds,placeholders_and_tc_args,ci) = convertTypecodes cinp typecode_exprs is_dynamic_pattern binds placeholders_and_tc_args ci
		= (App {	app_symb		= cons_symb,
					app_args 		= [expr , exprs],
					app_info_ptr	= nilPtr}, binds,placeholders_and_tc_args, ci)
651

652
653

convertTypecode cinp (TCE_Selector selections var_info_ptr) is_dynamic_pattern binds placeholders_and_tc_args ci
Martijn Vervoort's avatar
Martijn Vervoort committed
654
	#! (var,binds,placeholders_and_tc_args,ci)		
655
		= convertTypecode cinp (TCE_Var var_info_ptr) is_dynamic_pattern binds placeholders_and_tc_args ci
656
	= (Selection NormalSelector var selections,binds,placeholders_and_tc_args,ci)
657

Martijn Vervoort's avatar
Martijn Vervoort committed
658
//convertTypecodes :: !ConversionInput [TypeCodeExpression] !*ConversionInfo  -> (Expression,!*ConversionInfo)
659

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
660
661
662
663
664
665
666
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
667
		 					THEN the default_expr remains default in the nested cases.
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
668
							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
669

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
670
***/
Martijn Vervoort's avatar
Martijn Vervoort committed
671
672
673
674



// the case itself has no default but it has a surrounding default
675
676
677
678
/*
	1st 	= default of current case
	2nd 	= directly surrounding default
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
679
determine_defaults No default_expr=:(Yes (var=:{var_info_ptr}, indirection_var_list)) ci=:{ci_var_heap}
680
	# (var_info, ci_var_heap) = readPtr var_info_ptr ci_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
681
	# (expression, ci) = toExpression default_expr {ci & ci_var_heap = ci_var_heap}
682
	# expression
Martijn Vervoort's avatar
Martijn Vervoort committed
683
		= expression// ---> expression
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
684
685
686
687
688
689
690
691
692
693
694
695
	= 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
696
	= 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
697
where
698
699
	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
700

701
open_dynamic :: Expression !*ConversionInfo -> (OpenedDynamic, LetBind, !*ConversionInfo)
702
open_dynamic dynamic_expr ci=:{ci_sel_type_field, ci_sel_value_field}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
703
704
	# (twotuple, ci) = getTupleSymbol 2 ci
	  (dynamicType_var, ci) = newVariable "dt" VI_Empty ci
705
	  dynamicType_fv = varToFreeVar dynamicType_var 1
706
707
	= (	{ 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 },
708
	  	{ ci & ci_new_variables = [ dynamicType_fv : ci.ci_new_variables ]})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
709
710
711
712
713
714
715
/**************************************************************************************************/

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'"
716
717
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
718
	# (opened_dynamic, dt_bind, ci) = open_dynamic case_expr ci
719
	  (ind_0, ci) = newVariable "ind_0" (VI_Indirection 0) ci
720
	  (c_1,   ci) = newVariable "c_1!" (VI_Default 0) ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
721
722
      new_default = newDefault c_1 ind_0
      (result_type, ci) = getResultType case_info_ptr ci
723
    
724
    #! (tc_binds,(bound_vars,ci))
725
726
727
728
729
730
731
732
733
734
735
  	  	= 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))

	#

736
      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
737
      							  (addToBoundVars c_1 result_type (add_dynamic_bound_vars patterns bound_vars)))
738
739

																// c_1 ind_0
740
	  (binds, expr, ci) = convert_dynamic_pattern cinp bound_vars new_default 1 opened_dynamic result_type case_default patterns ci
741
742
743
744
	# ci
		= { ci & ci_placeholders_and_tc_args=old_ci_placeholders_and_tc_args}
	# (tc_binds,ci)
		= foldSt remove_non_used_arg tc_binds ([],ci) 
745
	  (let_info_ptr, ci) = let_ptr (length  binds + length tc_binds + 1) ci
746

747
748
	= (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)
749
where
750
751
	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})
752
753
754
		# (VI_Indirection ref_count, ci_var_heap) = readPtr fv_info_ptr ci_var_heap
		| ref_count > 0
			#! tc_bind
755
				= { tc_bind & lb_dst = { tc_bind.lb_dst & fv_count = ref_count} }
756
757
758
759
760
761
762
763
764
765
766
			= ([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
767
			= newVariable v_tc_placeholder v ci //---> st_arg
768
769
770
771
772
773
774
775
776
777
778
779
780
		#! (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
781
		create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo)
782
		create_variable var_name var_info_ptr ci
783
			# (placeholder_symb, ci) = getSymbol PD_PV_Placeholder SK_Constructor 2 ci
784
785
			  cyclic_var = {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}	
			  cyclic_fv = varToFreeVar cyclic_var 1	
786
787
788
789
790
			= ({ 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
791
792
793
			   },
			   { ci & ci_new_variables = [ cyclic_fv : ci.ci_new_variables ]} /*ci*/)
			   
794
	add_coercions _ [] _ _ bound_vars dp_rhs ci
795
		= (bound_vars,dp_rhs,ci)
796
	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}
797
798
799
800
801
802
803
804
805
806
		// 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
		  
		#		
807
		  (coerce_symb, ci)		= getSymbol PD_coerce SK_Function (extended_unify_and_coerce 2 3) ci
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
		  (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)
831
			= add_coercions result_type rest (if (isNo this_default) No new_default2) q bound_vars dp_rhs ci 
832
833
834
		
		#! (opt_expr,ci)
			= toExpression this_default ci
835
836
			
		#! 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 ]
837
		# let_lazy_binds		= (if (isNo this_default) [] [ {lb_src = opt opt_expr, lb_dst = c_inc_i_fv, lb_position = NoPos }]) ++ [
838
										  { lb_src = App { app_symb = coerce_symb,  app_args = app_args2,  app_info_ptr = nilPtr },
839
										   lb_dst = coerce_result_fv, lb_position = NoPos }
840
										   ,
841
										 { lb_src = TupleSelect twotuple 0 (Var coerce_result_var),
842
										   lb_dst = coerce_bool_fv, lb_position = NoPos } : let_binds
843
844
										]
		  (let_info_ptr, ci) 	= let_ptr (length let_lazy_binds) ci
845
		  (case_info_ptr, ci)	= bool_case_ptr result_type ci
846
847
848
849
850
851
852

		# let_expr
			= Let {
					let_strict_binds	= []
				,	let_lazy_binds		= let_lazy_binds
				,	let_expr =
							 Case {			case_expr 		= Var coerce_bool_var,
853
854
855
856
											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,
857
											case_explicit	= False,
858
											case_default_pos= NoPos }
859
				,	let_info_ptr = let_info_ptr	
860
				,	let_expr_position = NoPos
861
862
863
864
865
866
867
				}
		
		// 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
			
868
	convert_dynamic_pattern :: !ConversionInput !BoundVariables DefaultExpression Int OpenedDynamic AType (Optional Expression) ![DynamicPattern] *ConversionInfo
869
		-> ([LetBind], Expression, *ConversionInfo)
870
	convert_dynamic_pattern cinp bound_vars this_default pattern_number opened_dynamic result_type last_default
871
																			[{ dp_var, dp_type_patterns_vars, dp_type_code, dp_rhs } : patterns] ci=:{ci_module_id_symbol}
Martijn Vervoort's avatar
Martijn Vervoort committed
872
		# /***  The last case may not have a default  ***/
873
874
875
876
877
878
879

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

880
		  (a_ij_binds, ci)		= createTypePatternVariables dp_type_patterns_vars [] ci
881
	 	  (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
882
883
884
885
886
887
888
889
	
	 	# (is_last_dynamic_pattern,dp_rhs) 
	 		= isLastDynamicPattern dp_rhs;
		# ci
			= foldSt add_tcs martijn ci
			
	 	#	
	 	  // walks through the patterns of the next alternative
890
	 	  (dp_rhs, ci)			= convertDynamics cinp bound_vars this_default dp_rhs ci
891
892
893
894
895
896
	 	  	 		
		#! (ci_old_used_tcs,ci)
			= ci!ci_used_tcs;
	 	# ci
	 		= { ci & ci_used_tcs = [] }
			 		
Martijn Vervoort's avatar
Martijn Vervoort committed
897
		  /***  recursively convert the other patterns in the other alternatives ***/
898

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

901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916

	 	# 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)
917
						= add_coercions result_type used_ci_placeholders_and_tc_args this_default binds bound_vars dp_rhs ci
918
919
920
921
	 				-> (dp_rhs,ci)
	 			False
	 				-> (dp_rhs,ci)
		#
922
		  /***  generate the expression  ***/
923
	 	  (unify_symb, ci) 		= getSymbol (if generate_coerce PD_coerce PD_unify ) SK_Function (extended_unify_and_coerce 2 3) /*3 was 2 */ ci
924
925
		  (twotuple, ci) 		= getTupleSymbol 2 ci
		  (default_expr, ci) 	= toExpression this_default ci
Martijn Vervoort's avatar
Martijn Vervoort committed
926
927
928
		  
		  // was coercions
		  
929
930
		  (unify_result_var, ci)	= newVariable "result" VI_Empty ci
		  unify_result_fv 			= varToFreeVar unify_result_var 1
931
		  (unify_bool_var, ci)		= newVariable (if generate_coerce "coerce_bool" "unify_bool") VI_Empty ci
932
933
		  unify_bool_fv 			= varToFreeVar unify_bool_var 1

Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
934
935
		  (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
936

937
		  (let_info_ptr, ci) 	= let_ptr (2 + length let_binds) ci
938
		  (case_info_ptr, ci)	= bool_case_ptr result_type ci
939
940
941

		  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
942
		  let_expr = Let {	let_strict_binds = [],
943
		  					let_lazy_binds = [{ lb_src = App { app_symb = unify_symb,  app_args = app_args2,  app_info_ptr = nilPtr },
944
		  								   lb_dst = unify_result_fv, lb_position = NoPos },
945
		  								 { lb_src = TupleSelect twotuple 0 (Var unify_result_var),
946
		  								   lb_dst = unify_bool_fv, lb_position = NoPos } : let_binds
947
948
		  								],
		  					let_expr = Case {	case_expr 		= Var unify_bool_var,
949
												case_guards		= BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs, bp_position = NoPos }],
950
951
												case_default	= default_expr,
												case_ident		= No,
952
												case_info_ptr	= case_info_ptr,
953
												case_explicit	= False,
954
												case_default_pos= NoPos },
955
956
		  					let_info_ptr = let_info_ptr,
		  					let_expr_position = NoPos }
Martijn Vervoort's avatar
Martijn Vervoort committed
957
		  					
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
958
		= (a_ij_binds ++ binds,  let_expr,  { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]})