convertDynamics.icl 58.1 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
3
implementation module convertDynamics

import syntax, transform, utilities, convertcases
4
// Optional
5
6
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
7

8
//import pp;
Martijn Vervoort's avatar
Martijn Vervoort committed
9

10
11
APPEND_DEFINING_TYPE_MODULE_NAMES_TO_TYPE_NAMES yes no :== no
import type_io; 
12
//import RWSDebug;
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
13
14
15
16
17

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

::	ConversionInput =
	{	cinp_glob_type_inst	:: !{! GlobalTCType} 
	,	cinp_group_index	:: !Int
36
	,	cinp_st_args		:: ![FreeVar]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
37
38
39
40
41
42
43
44
	}

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

:: DefaultExpression :== Optional (BoundVar, [IndirectionVar])   //DefaultRecord
45
46
47

::	BoundVariables :== [TypedVariable]

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
48
:: IndirectionVar    :== BoundVar
49

50
51
52

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

54
55
F :: !a .b -> .b
F a b = b
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
56

57
58

//write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File)
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] !*TypeHeaps -> (.Bool,.File,!*TypeHeaps)
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
	# write_type_info_state2
		= { WriteTypeInfoState |
			wtis_type_heaps		= type_heaps
		,	wtis_n_type_vars		= 0
		};
	# (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
80
81
	#! tcl_file
		= fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file
Martijn Vervoort's avatar
Martijn Vervoort committed
82
83
	#! tcl_file
		= fwritei (size main_dcl_module.dcl_common.com_cons_defs) tcl_file
84
85
86
87
88
	= (True,tcl_file,type_heaps) 
	
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
89
//---> ("dcl",size main_dcl_module.dcl_common.com_type_defs, "icl", size common_defs.com_type_defs);
90

91
			
92
93
convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap /* TD */ (Optional !*File) {# DclModule} !IclModule /* TD */ [String]
			-> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, /* TD */ (Optional !*File))
Martijn Vervoort's avatar
Martijn Vervoort committed
94
convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap /* TD */ tcl_file dcl_mods icl_mod  /* TD */ directly_imported_dcl_modules
95
	// TD ...
96
	# (tcl_file,type_heaps)
97
98
		= case tcl_file of
			No
99
				-> (No,type_heaps)
100
			(Yes tcl_file)
101
102
				# (ok,tcl_file,type_heaps)
					= write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file /* TD */ directly_imported_dcl_modules type_heaps
103
104
				| not ok
					-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
105
					-> (Yes tcl_file,type_heaps)
106
107

				
108
	// ... TD
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
	# ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamics]
	#! (dynamic_temp_symb_ident,ci_sel_value_field,ci_sel_type_field,predefined_symbols)
		= case (pds_module == (-1) || pds_def == (-1)) of
			True
				-> (undef,undef,undef,predefined_symbols)
			_	
				 
				-> case (USE_TUPLES True False) /*(pds_module == (-1) || pds_def == (-1))*/ of
					True
						# arity = 2
						// get tuple arity 2 constructor
						# ({pds_module, pds_def, pds_ident}, predefined_symbols)	= predefined_symbols![GetTupleConsIndex arity]
						# twoTuple_symb	= { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def}, symb_arity = arity }
						
						// get tuple, type and value selectors
						# ({pds_def, pds_ident}, predefined_symbols) = predefined_symbols![GetTupleConsIndex arity]
						# 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} 
							,	symb_arity	= rt_constructor.ds_arity
							}
		
						// 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
152
												,	ds_index		= pds_def2 
153
												}
154
							,	glob_module		= pds_module2 
155
156
157
							}
						#! ci_sel_type_field
							= (\dynamic_expr -> Selection No dynamic_expr [RecordSelection type_defined_symbol sd_field_nr])
158
							
159
160
161
162
163
164
165
166
167
168
						// 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
169
												,	ds_index		= pds_def3 
170
												}
171
							,	glob_module		= pds_module3
172
173
174
							}
						#! ci_sel_value_field
							= (\dynamic_expr -> Selection No dynamic_expr [RecordSelection value_defined_symbol sd_field_nr3])
175
176
177
178
179
180
181
182
183
184
						-> (dynamic_temp_symb_ident, ci_sel_value_field, ci_sel_type_field,predefined_symbols)
						
	// get module id symbol
	# ({pds_module, pds_def, pds_ident}, predefined_symbols)	= predefined_symbols![PD_ModuleConsSymbol]
	# module_symb = 
		{	app_symb 		= { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def}, symb_arity = 0 }
		,	app_args 		= []
		,	app_info_ptr	= nilPtr
		}
						
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
185
	#! nr_of_funs = size fun_defs
186
	# imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
187
188
189
	# (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,
190
191
							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,
192
193
							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, 
							ci_module_id_symbol = App module_symb })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
194
	  (groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap)
195
			= addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions main_dcl_module_n groups imported_types [] type_heaps ci_var_heap
196
	= (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
197
198
199
200
where
	convert_groups group_nr groups global_type_instances fun_defs_and_ci
		| group_nr == size groups
			= (groups, fun_defs_and_ci)
201
			# (group, groups) = groups![group_nr]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
202
203
204
			= convert_groups (inc group_nr) groups global_type_instances (foldSt (convert_function group_nr global_type_instances) group.group_members fun_defs_and_ci)

	convert_function group_nr global_type_instances fun (fun_defs, ci)
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
205
206
207
208
		# (fun_def, fun_defs) = fun_defs![fun]
		  {fun_body, fun_type, fun_info} = fun_def
		| isEmpty fun_info.fi_dynamics
			= (fun_defs, ci)
209
210
			# ci 
				= { ci & ci_used_tcs = [], ci_generated_global_tc_placeholders = False }
211
			# (fun_body, 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
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
212
213
			= ({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 = [] })
214
215
216
217
// MV ..
	convert_dynamics_in_body global_type_instances (TransformedBody {tb_args,tb_rhs}) (Yes {st_context, st_args}) ci
		# vars_with_types = bindVarsToTypes2 st_context tb_args st_args [] common_defs
// .. MV
218
		  (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
219
220
221
222
		= (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'"

223
224
225
226
// MV ..
bindVarsToTypes2 st_context vars types typed_vars common_defs
	:== bindVarsToTypes vars (addTypesOfDictionaries common_defs st_context types) typed_vars
// .. MV
227
228
229
230
231
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
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248

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)

249
250
251
252
253
254
255
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
256
257
258
259
260
261
262
263
264
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
265
	# (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
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
	= ({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
288
	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
289
		# (let_types, ci) = determine_let_types let_info_ptr ci
290
291
// MW0		  bound_vars = bindVarsToTypes [ bind.bind_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars
		  bound_vars = bindVarsToTypes [ bind.lb_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars
Sjaak Smetsers's avatar
Sjaak Smetsers committed
292
293
294
295
		  (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
296
297
298
299
300
301
302
303
304
305
306
307
308
	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)
309
310
311
312
313
314
315
316
317
318
319
// MV DEFAULT ...
				| not (isNo this_case_default) && any (\algebraic_pattern -> is_case_without_default algebraic_pattern) algebraic_patterns
					// a default to be moved inwards and a root positioned case not having a default
					// 
					// Example:
					//	loadandrun2 :: ![(!Dynamic, !Dynamic)] !*World -> *World
					//	loadandrun2 [(f :: BatchProcess i o, input :: i)] world = abort "alt BatchProcess"
					//	loadandrun2 [(f :: InteractiveProcess i o, input :: i)] world = abort "alt InteractiveProcess" 
					//	loadandrun2 _ _ = abort "Loader: process and input do not match"
					//
					# (Yes old_case_default) = this_case_default
320
//					# (let_info_ptr,  ci) = let_ptr ci
321
322
323
324
325
326
327
328
329
330
331
332
333
334
					# (default_var, ci) = newVariable "s" (VI_BoundVar {at_attribute=TA_None,at_annotation=AN_None,at_type=TE}) ci
					# default_fv = varToFreeVar default_var 1
					# ci
						= { ci & ci_new_variables = [default_fv : ci.ci_new_variables]}
					# let_bind = {
							lb_src = old_case_default
						,	lb_dst = default_fv
						, lb_position = NoPos }					
					# (new_case_default, nested_case_default, ci) 
						= determine_defaults (Yes (Var default_var)) default_expr ci
					# algebraic_patterns			
						= map (patch_defaults new_case_default) algebraic_patterns
					#  (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default)
														(zip2 algebraic_patterns ct_cons_types) ci
335
336
/* Sjaak */
					# (let_info_ptr,  ci) = let_ptr 1 ci
337
338
339
340
341
342
343
344
345
346
347
348
349
350
					# letje
						= Let {
							let_strict_binds	= []
						,	let_lazy_binds		= [let_bind]
						,	let_expr			= Case {keesje &  case_expr = case_expr, case_guards = AlgebraicPatterns type algebraic_patterns, case_default = new_case_default }
						,	let_info_ptr		= let_info_ptr
						,	let_expr_position	= NoPos
						}		
					-> (letje,ci)
			
					#  (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default)
														(zip2 algebraic_patterns ct_cons_types) ci
					-> (Case {keesje &  case_expr = case_expr, case_guards = AlgebraicPatterns type algebraic_patterns, case_default = this_case_default}, ci)
// ... MV DEFAULT
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
351
352
353
354
355
356
357
358
359
360
			(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)
			(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'"
361
362
363
364
365
366
367
368
369
370
371
// MV DEFAULT ...
	where
		is_case_without_default {ap_expr=Case {case_default=No}}	= True
		is_case_without_default _									= False
	
		patch_defaults this_case_default ap=:{ap_expr=Case keesje=:{case_default=No}} 
			= { ap & ap_expr = Case {keesje & case_default = this_case_default} }
		patch_defaults _ expr
			= expr
// ... MV DEFAULT
			
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
	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)
	convertDynamics _ _ _ (BasicExpr basicValue basicType) ci
		= (BasicExpr basicValue basicType, ci)
	convertDynamics _ _ _ (AnyCodeExpr codeBinding1 codeBinding2 strings) ci
		= (AnyCodeExpr codeBinding1 codeBinding2 strings, ci)
	convertDynamics _ _ _ (ABCCodeExpr strings bool) ci
		= (ABCCodeExpr strings bool, ci)
	convertDynamics cinp bound_vars default_expr (MatchExpr opt_symb symb expression) ci
		# (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci
		= (MatchExpr opt_symb symb expression, ci)
395
396
397
398
399
400
401
402
403
404
/* Sjaak ... */
	convertDynamics cinp bound_vars default_expr  (DynamicExpr {dyn_expr, dyn_info_ptr, dyn_type_code}) ci=:{ci_symb_ident}
		#  (dyn_expr,      ci) 			= convertDynamics cinp bound_vars default_expr dyn_expr ci
		   (_,dyn_type_code, _, _, ci)	= convertTypecode2 cinp dyn_type_code False [] [] ci
		= (App {	app_symb		= ci_symb_ident,
					app_args 		= [dyn_expr, dyn_type_code],
					app_info_ptr	= nilPtr }, ci)

/* ... Sjaak  */
/* WAS ...
405
406
	convertDynamics cinp bound_vars default_expr  (DynamicExpr {dyn_expr, dyn_info_ptr, dyn_uni_vars, dyn_type_code}) ci=:{ci_symb_ident}
		# (let_binds,     ci) 	= createVariables dyn_uni_vars [] ci
407
		  (dyn_expr,      ci) 	= convertDynamics cinp bound_vars default_expr dyn_expr ci
408
		  (_,dyn_type_code,_,_,ci) = convertTypecode2 cinp dyn_type_code False [] [] ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
409
		= case let_binds of
410
			[]	-> (App {	app_symb		= ci_symb_ident, //USE_TUPLES twoTuple_symb ci_symb_ident, //twoTuple_symb,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
411
412
							app_args 		= [dyn_expr, dyn_type_code],
							app_info_ptr	= nilPtr }, ci)
413
414
/* Sjaak */
			_ 	#  (let_info_ptr,  ci) = let_ptr (length let_binds) ci
Sjaak Smetsers's avatar
Sjaak Smetsers committed
415
416
				-> ( Let {	let_strict_binds	= [],
							let_lazy_binds		= let_binds,
417
							let_expr			= App {	app_symb		= ci_symb_ident, //USE_TUPLES twoTuple_symb ci_symb_ident,
Sjaak Smetsers's avatar
Sjaak Smetsers committed
418
419
														app_args 		= [dyn_expr, dyn_type_code],
														app_info_ptr	= nilPtr },
420
							let_info_ptr		= let_info_ptr,
421
							let_expr_position	= NoPos}, ci) 
422
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
423
	convertDynamics cinp bound_vars default_expr (TypeCodeExpression type_code) ci
424
		= abort "convertDynamics cinp bound_vars default_expr (TypeCodeExpression" //convertTypecode cinp type_code ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
425
426
427
428
429
	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'"

Martijn Vervoort's avatar
Martijn Vervoort committed
430
431


432
//convertTypecode ::  !ConversionInput TypeCodeExpression !*ConversionInfo  -> (Expression,!*ConversionInfo)
Martijn Vervoort's avatar
Martijn Vervoort committed
433
434
435
436
437
/*
	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
	
438

Martijn Vervoort's avatar
Martijn Vervoort committed
439
*/
440
441
442
443

/* Sjaak ... */
convertTypecode2 cinp (TCE_UniType uni_vars type_code) replace_tc_args binds placeholders_and_tc_args ci
		# (let_binds,     ci) 	= createVariables uni_vars [] ci
444
		  (let_info_ptr,  ci)	= let_ptr (length let_binds) ci
445
446
447
448
449
450
451
452
		  (e, type_code_expr, binds, placeholders_and_tc_args, ci)	= convertTypecode2 cinp type_code False [] [] ci
		= (e, Let {	let_strict_binds	= [],
					let_lazy_binds		= let_binds,
					let_expr			= type_code_expr,
					let_info_ptr		= let_info_ptr,
					let_expr_position	= NoPos}, binds, placeholders_and_tc_args, ci) 
/* ... Sjaak */

Martijn Vervoort's avatar
Martijn Vervoort committed
453
// ci_placeholders_and_tc_args
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
	#! cinp_st_args
		= filter (\{fv_info_ptr} -> fv_info_ptr == var_info_ptr) cinp_st_args
	| isEmpty cinp_st_args
		#! (e,binds,placeholders_and_tc_args,ci)
			= convertTypecode cinp t replace_tc_args binds placeholders_and_tc_args ci
		= (False,e,binds,placeholders_and_tc_args,ci)
		
		/*
		** the TCE_VAR is a TC argument and it is not part of a larger type expression. It
		** later suffices to generate a coerce instead of an application. This is an 
		** optimization.
		*/
		= (True,Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args,ci)

convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_TypeTerm var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
Martijn Vervoort's avatar
Martijn Vervoort committed
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
	#! 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
485
486
487
488
489
490

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

Martijn Vervoort's avatar
Martijn Vervoort committed
491
492
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
493

494
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
495
496
	| 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
497

Martijn Vervoort's avatar
Martijn Vervoort committed
498
499
500
501
	// 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)
502
503
504
505
506
507
508
509
510
511
		// 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
512
		= (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args, ci)
513
514
515
516
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
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535

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

convertTypecode cinp (TCE_Constructor index typecode_exprs) replace_tc_args binds placeholders_and_tc_args ci
	# (typecons_symb,  ci) 									= getSymbol PD_TypeConsSymbol SK_Constructor 2 ci
	  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
536
537
	= (App {app_symb		= typecons_symb,
			app_args 		= [constructor , typecode_exprs],
Martijn Vervoort's avatar
Martijn Vervoort committed
538
			app_info_ptr	= nilPtr},binds,placeholders_and_tc_args,ci)
539

Martijn Vervoort's avatar
Martijn Vervoort committed
540
541
542
543
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
	= (Selection No var selections,binds,placeholders_and_tc_args,ci)
544

Martijn Vervoort's avatar
Martijn Vervoort committed
545
546
//convertTypecodes :: !ConversionInput [TypeCodeExpression] !*ConversionInfo  -> (Expression,!*ConversionInfo)
convertTypecodes _ [] replace_tc_args binds placeholders_and_tc_args ci
547
548
549
	# (nil_symb, ci) = getSymbol PD_NilSymbol SK_Constructor 0 ci
	= (App {	app_symb		= nil_symb,
				app_args 		= [],
Martijn Vervoort's avatar
Martijn Vervoort committed
550
551
552
				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
553
	# (cons_symb, ci) = getSymbol PD_ConsSymbol SK_Constructor 2 ci
Martijn Vervoort's avatar
Martijn Vervoort committed
554
555
	# (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
556
557
	= (App {	app_symb		= cons_symb,
				app_args 		= [expr , exprs],
Martijn Vervoort's avatar
Martijn Vervoort committed
558
				app_info_ptr	= nilPtr}, binds,placeholders_and_tc_args, ci)
559

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
560
561
562
563
564
565
566
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
567
		 					THEN the default_expr remains default in the nested cases.
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
568
							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
569

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
570
***/
Martijn Vervoort's avatar
Martijn Vervoort committed
571
572
573
574



// the case itself has no default but it has a surrounding default
575
576
577
578
/*
	1st 	= default of current case
	2nd 	= directly surrounding default
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
579
580
581
determine_defaults No default_expr=:(Yes (var=:{var_info_ptr}, indirection_var_list)) ci=:{ci_var_heap}
	#! var_info = sreadPtr var_info_ptr ci_var_heap
	# (expression, ci) = toExpression default_expr {ci & ci_var_heap = ci_var_heap}
582
	# expression
Martijn Vervoort's avatar
Martijn Vervoort committed
583
		= expression// ---> expression
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
584
585
586
587
588
589
590
591
592
593
594
595
	= 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
596
	= 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
597
where
598
599
	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
600

601
open_dynamic :: Expression !*ConversionInfo -> (OpenedDynamic, LetBind, !*ConversionInfo)
602
open_dynamic dynamic_expr ci=:{ci_sel_type_field, ci_sel_value_field}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
603
604
	# (twotuple, ci) = getTupleSymbol 2 ci
	  (dynamicType_var, ci) = newVariable "dt" VI_Empty ci
605
	  dynamicType_fv = varToFreeVar dynamicType_var 1
606
607
608
609
//	  sel_type = Selection No dynamic_expr [RecordSelection type_defined_symbol sd_type_field_nr]
//	  sel_value = Selection No dynamic_expr [RecordSelection value_defined_symbol sd_value_field_nr]
	= (	{ opened_dynamic_expr = ci_sel_value_field dynamic_expr /*USE_TUPLES (TupleSelect twotuple 0 dynamic_expr) sel_value*/, opened_dynamic_type = Var dynamicType_var },
//  RecordSelection !(Global DefinedSymbol) !Int
610
// MW0	  	{ bind_src = TupleSelect twotuple 1 dynamic_expr, bind_dst = dynamicType_fv },
611
	  	{ lb_src = ci_sel_type_field dynamic_expr /*USE_TUPLES (TupleSelect twotuple 1 dynamic_expr) sel_type*/, lb_dst = dynamicType_fv, lb_position = NoPos },
612
	  	{ ci & ci_new_variables = [ dynamicType_fv : ci.ci_new_variables ]})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
613
614
615
616
617
618
619
/**************************************************************************************************/

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'"
620
621
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
622
	# (opened_dynamic, dt_bind, ci) = open_dynamic case_expr ci
623
	  (ind_0, ci) = newVariable "ind_0" (VI_Indirection 0) ci
624
	  (c_1,   ci) = newVariable "c_1!" (VI_Default 0) ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
625
626
      new_default = newDefault c_1 ind_0
      (result_type, ci) = getResultType case_info_ptr ci
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
    
    #! // TC PLACEHOLDERS...
  	  (tc_binds,(bound_vars,ci))
  	  	= case ci_generated_global_tc_placeholders of
  	  		True	-> ([],(bound_vars,ci))
  	  		_		
  	  				#! (tc_binds,(bound_vars,ci))
  	  					= mapSt f cinp_st_args (bound_vars,ci)
  	  				#! ci
  	  					= { ci & ci_generated_global_tc_placeholders = True}
  	  				-> (tc_binds,(bound_vars,ci))
      // ...TC PLACEHOLDERS

	#

642
643
// MW0      bound_vars = addToBoundVars (freeVarToVar dt_bind.bind_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type
      bound_vars = addToBoundVars (freeVarToVar dt_bind.lb_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
644
      							  (addToBoundVars c_1 result_type (add_dynamic_bound_vars patterns bound_vars)))
645
646

																// c_1 ind_0
647
	  (binds, expr, ci) = convert_dynamic_pattern cinp bound_vars new_default 1 opened_dynamic result_type case_default patterns ci
648
649
650
651
	# ci
		= { ci & ci_placeholders_and_tc_args=old_ci_placeholders_and_tc_args}
	# (tc_binds,ci)
		= foldSt remove_non_used_arg tc_binds ([],ci) 
652
653
/* Sjaak */		
	  (let_info_ptr, ci) = let_ptr (length  binds + length tc_binds + 1) ci
654

655
656
657
// MW0	= (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr, let_info_ptr = let_info_ptr}, ci)
	= (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr,
			let_info_ptr = let_info_ptr, let_expr_position = NoPos }, ci)
658
where
659
660
661
// MW0	remove_non_used_arg :: (Bind Expression FreeVar) ([Bind Expression FreeVar],*ConversionInfo) -> ([Bind Expression FreeVar],*ConversionInfo)
	remove_non_used_arg :: LetBind ([LetBind],*ConversionInfo) -> ([LetBind],*ConversionInfo)
	remove_non_used_arg tc_bind=:{lb_dst={fv_info_ptr}} (l,ci=:{ci_var_heap})
662
663
664
		# (VI_Indirection ref_count, ci_var_heap) = readPtr fv_info_ptr ci_var_heap
		| ref_count > 0
			#! tc_bind
665
				= { tc_bind & lb_dst = { tc_bind.lb_dst & fv_count = ref_count} }
666
667
668
669
670
671
672
673
674
675
676
			= ([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
677
			= newVariable v_tc_placeholder v ci //---> st_arg
678
679
680
681
682
683
684
685
686
687
688
689
690
		#! (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
691
692
// MW0		create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo)
		create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo)
693
694
695
696
		create_variable var_name var_info_ptr ci
			# (placeholder_symb, ci) = getSymbol PD_variablePlaceholder SK_Constructor 3 ci
			  cyclic_var = {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}	
			  cyclic_fv = varToFreeVar cyclic_var 1	
697
698
699
700
701
702
703
// MW0			= ({ bind_src = App {	app_symb = placeholder_symb,
			= ({ lb_src = App {	app_symb = placeholder_symb,
								app_args = [Var cyclic_var, Var cyclic_var],
								app_info_ptr = nilPtr },
// MW0				 bind_dst = varToFreeVar cyclic_var 1
				 lb_dst = varToFreeVar cyclic_var 1,
				 lb_position = NoPos
704
705
706
707
708
			   },
			   { ci & ci_new_variables = [ cyclic_fv : ci.ci_new_variables ]} /*ci*/)
			   
	add_coercions [] _ _ bound_vars dp_rhs ci
		= (bound_vars,dp_rhs,ci)
709
	add_coercions [({var_info_ptr=a_ij},a_ij_tc):rest] this_default q bound_vars dp_rhs ci=:{ci_module_id_symbol}
710
711
712
713
714
715
716
717
718
719
		// 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
		  
		#		
720
		  (coerce_symb, ci)		= getSymbol PD_coerce SK_Function (extended_unify_and_coerce 2 3) ci
721
		  (twotuple, ci) 		= getTupleSymbol 2 ci
722
//Sjaak		  (case_info_ptr, ci)	= case_ptr ci
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
		
		  (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)
			= add_coercions rest (if (isNo this_default) No new_default2) q bound_vars dp_rhs ci 
		
		#! (opt_expr,ci)
			= toExpression this_default ci
750
751
			
		#! 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 ]
752
/* Sjaak ... */
753

754
		# let_lazy_binds		= (if (isNo this_default) [] [ {lb_src = opt opt_expr, lb_dst = c_inc_i_fv, lb_position = NoPos }]) ++ [
755
										  { lb_src = App { app_symb = coerce_symb,  app_args = app_args2,  app_info_ptr = nilPtr },
756
										   lb_dst = coerce_result_fv, lb_position = NoPos }
757
										   ,
758
										 { lb_src = /*USE_TUPLES (*/ TupleSelect twotuple 0 (Var coerce_result_var) /*) sel_type*/,
759
										   lb_dst = coerce_bool_fv, lb_position = NoPos } : let_binds
760
761
762
763
764
765
766
767
768
769
770
										]
		  (let_info_ptr, ci) 	= let_ptr (length let_lazy_binds) ci
		  (case_info_ptr, ci)	= bool_case_ptr ci
/* ... Sjaak */

		# let_expr
			= Let {
					let_strict_binds	= []
				,	let_lazy_binds		= let_lazy_binds
				,	let_expr =
							 Case {			case_expr 		= Var coerce_bool_var,
771
772
773
774
											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,
775
776
777
// RWS ...
											case_explicit	= False,
// ... RWS
778
779
											case_default_pos= NoPos } // MW4++
				,	let_info_ptr = let_info_ptr	
780
				,	let_expr_position = NoPos // MW0++
781
782
783
784
785
786
787
				}
		
		// 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
			
788
	convert_dynamic_pattern :: !ConversionInput !BoundVariables DefaultExpression Int OpenedDynamic AType (Optional Expression) ![DynamicPattern] *ConversionInfo
789
790
/// MW0		-> (Env Expression FreeVar, Expression, *ConversionInfo)
		-> ([LetBind], Expression, *ConversionInfo)
791
	convert_dynamic_pattern cinp bound_vars this_default pattern_number opened_dynamic result_type last_default
792
793
																			[{ dp_var, dp_type_patterns_vars, dp_type_code, dp_rhs } : patterns] ci=:{ci_module_id_symbol}
														
Martijn Vervoort's avatar
Martijn Vervoort committed
794
		# /***  The last case may not have a default  ***/
795
796
797
798
799
800
801

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

802
		  (a_ij_binds, ci)		= createVariables dp_type_patterns_vars [] ci
803
804
805
806
807
808
809
810
811
812
813
	 	  (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
	
		// collect ...
	 	# (is_last_dynamic_pattern,dp_rhs) 
	 		= isLastDynamicPattern dp_rhs;
		# ci
			= foldSt add_tcs martijn ci
		// ... collect
			
	 	#	
	 	  // walks through the patterns of the next alternative
814
	 	  (dp_rhs, ci)			= convertDynamics cinp bound_vars this_default dp_rhs ci
815
816
817
818
819
820
821
822
	 	  	 		
		// collect ...
		#! (ci_old_used_tcs,ci)
			= ci!ci_used_tcs;
	 	# ci
	 		= { ci & ci_used_tcs = [] }
		// ... collect
			 		
Martijn Vervoort's avatar
Martijn Vervoort committed
823
		  /***  recursively convert the other patterns in the other alternatives ***/
824

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

827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849

		// collect ...
	 	# ci
	 		= { ci & ci_used_tcs = ci_old_used_tcs }
		# ci_used_tcs
			= ci_old_used_tcs
	 	  
	 	#! (dp_rhs,ci)
	 		= case ((is_last_dynamic_pattern) /*&& (not generate_coerce)*/) of
	 			True
	 				// last dynamic pattern of the group of dynamic pattern so coercions must be generated.
	 				 #! (ci_placeholders_and_tc_args,ci)
	 					= ci!ci_placeholders_and_tc_args
	 				
	 				#! used_ci_placeholders_and_tc_args
	 					= filter (\(_,ci_placeholders_and_tc_arg) -> isMember ci_placeholders_and_tc_arg ci_used_tcs) ci_placeholders_and_tc_args
					#! (bound_vars,dp_rhs,ci)
						= add_coercions used_ci_placeholders_and_tc_args this_default binds bound_vars dp_rhs ci
	 				-> (dp_rhs,ci)
	 			False
	 				-> (dp_rhs,ci)
		// ... collect
		#
850
		  /***  generate the expression  ***/
851
	 	  (unify_symb, ci) 		= getSymbol (if generate_coerce PD_coerce PD_unify ) SK_Function (extended_unify_and_coerce 2 3) /*3 was 2 */ ci
852
		  (twotuple, ci) 		= getTupleSymbol 2 ci
853
//Sjaak		  (case_info_ptr, ci)	= case_ptr ci
854
		  (default_expr, ci) 	= toExpression this_default ci
Martijn Vervoort's avatar
Martijn Vervoort committed
855
856
857
		  
		  // was coercions
		  
858
859
		  (unify_result_var, ci)	= newVariable "result" VI_Empty ci
		  unify_result_fv 			= varToFreeVar unify_result_var 1
860
		  (unify_bool_var, ci)		= newVariable (if generate_coerce "coerce_bool" "unify_bool") VI_Empty ci
861
862
		  unify_bool_fv 			= varToFreeVar unify_bool_var 1

Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
863
864
		  (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
865
		  
Martijn Vervoort's avatar
Martijn Vervoort committed
866
//		  sel_type	= Selection No (Var unify_result_var) [RecordSelection type_defined_symbol sd_type_field_nr]
867

868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887

/*
// TIJDELIJK...

		# (ci=:{ci_predef_symb})
			= ci;
		# ({pds_module, pds_def, pds_ident}, ci_predef_symb)	= ci_predef_symb![PD_ModuleConsSymbol]
		# module_symb1	= { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def}, symb_arity = 0 }
		# ci
			= { ci & ci_predef_symb = ci_predef_symb };

		# module_symb = 
			{	app_symb 		= module_symb1
			,	app_args 		= []
			,	app_info_ptr	= nilPtr
			}
		# module_symb =
			App module_symb
		// ...TIJDELIJK
*/
888
889
890
891
/* Sjaak ... */
		  (let_info_ptr, ci) 	= let_ptr 2 ci
		  (case_info_ptr, ci)	= bool_case_ptr ci
/* ... Sjaak */
892
893
894

		  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
895
		  let_expr = Let {	let_strict_binds = [],
896
		  					let_lazy_binds = [{ lb_src = App { app_symb = unify_symb,  app_args = app_args2,  app_info_ptr = nilPtr },
897
		  								   lb_dst = unify_result_fv, lb_position = NoPos },
898
		  								 { lb_src = /*USE_TUPLES (*/ TupleSelect twotuple 0 (Var unify_result_var) /*) sel_type*/,
899
		  								   lb_dst = unify_bool_fv, lb_position = NoPos } : let_binds
900
901
		  								],
		  					let_expr = Case {	case_expr 		= Var unify_bool_var,
902
												case_guards		= BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs, bp_position = NoPos }],
903
904
												case_default	= default_expr,
												case_ident		= No,
905
												case_info_ptr	= case_info_ptr,
906
907
908
// RWS ...
												case_explicit	= False,
// ... RWS
909
												case_default_pos= NoPos }, // MW4++
910
911
		  					let_info_ptr = let_info_ptr,
		  					let_expr_position = NoPos }
Martijn Vervoort's avatar
Martijn Vervoort committed
912
		  					
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
913
		= (a_ij_binds ++ binds,  let_expr,  { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]})
914
	where
915
916
// MW0		add_x_i_bind bind_src bind_dst=:{fv_count} binds
		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
919
// MW0				= [ { bind_src = bind_src, bind_dst = bind_dst } : binds ]
				= [ { lb_src = lb_src, lb_dst = lb_dst, lb_position = NoPos } : binds ]
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
920
				= binds
921
922
923
924
925
926
927
928
929
930
931
				
		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
932

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

948
949
950
951
952
953
	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
954
		  c_i = getVariable2 this_default
Martijn Vervoort's avatar
Martijn Vervoort committed
955
		  (c_bind, ci) = generateBinding cinp bound_vars c_i expr result_type ci
956
957
	     = ([c_bind: binds], ci) 

Martijn Vervoort's avatar
Martijn Vervoort committed
958
959
960
961
bind_indirection_var var=:{var_info_ptr} unify_result_var twotuple ci=:{ci_var_heap,ci_new_variables}
	# (VI_Indirection ref_count, ci_var_heap) = readPtr var_info_ptr ci_var_heap
	| ref_count > 0
		# ind_fv = varToFreeVar var ref_count
962
// MW0  		= ([{ bind_src = TupleSelect twotuple 1 (Var unify_result_var), bind_dst = ind_fv }],
963
964
//		  sel_value = Selection No (Var unify_result_var) [RecordSelection value_defined_symbol sd_value_field_nr]
  		= ([{ lb_src = /*USE_TUPLES (*/TupleSelect twotuple 1 (Var unify_result_var) /*) sel_value*/, lb_dst = ind_fv, lb_position = NoPos }],
Martijn Vervoort's avatar
Martijn Vervoort committed
965
966
				{ ci & ci_var_heap = ci_var_heap, ci_new_variables = [ ind_fv : ci_new_variables ]})
		= ([], {ci & ci_var_heap = ci_var_heap})
967
		
Martijn Vervoort's avatar
Martijn Vervoort committed
968
/*
969
970
971
	As input an alternative c_i and its associated expression which together form the default expression. If the reference
	count is zero then there exists only one reference to that expression. In case of multiple references to the expression:
	it is converted into a function. The references are replaced by an appropriate function application.
Martijn Vervoort's avatar
Martijn Vervoort committed
972
973

*/
974
975
// MW0 generateBinding :: !ConversionInput BoundVariables BoundVar Expression AType !*ConversionInfo -> *(Bind Expression FreeVar, *ConversionInfo)
generateBinding :: !ConversionInput BoundVariables BoundVar Expression AType !*ConversionInfo -> *(LetBind, *ConversionInfo)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
976
977
978
generateBinding cinp bound_vars var bind_expr result_type ci
	# (ref_count, ci) = get_reference_count var ci
	| ref_count == 0
979
		# free_var = varToFreeVar var 1
980
981
// MW0		= ({ bind_src = bind_expr, bind_dst = free_var }, { ci & ci_new_variables = [ free_var : ci.ci_new_variables ]})
		= ({ lb_src = bind_expr, lb_dst = free_var, lb_position = NoPos }, { ci & ci_new_variables = [ free_var : ci.ci_new_variables ]})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
982
		# (saved_defaults, ci_var_heap) = foldSt save_default bound_vars ([], ci.ci_var_heap)
983
		  (act_args, free_typed_vars, local_free_vars, tb_rhs, ci_var_heap) = copyExpression bound_vars bind_expr ci_var_heap
984
		#
985
		  (ci_new_variables, ci_var_heap) = foldSt remove_local_var ci.ci_new_variables ([], ci_var_heap) //->> ("na copyExpression",local_free_vars,(InitPPState stderr) <#< bind_expr) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
986
		  ci_var_heap = foldSt restore_default saved_defaults ci_var_heap
987
988
		  tb_args = [ ftv.tv_free_var \\ ftv <- free_typed_vars ]
		  arg_types = [ ftv.tv_type \\ ftv <- free_typed_vars ]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
989
		  (fun_symb,  (ci_next_fun_nr, ci_new_functions, ci_fun_heap))
990
				= newFunction No (TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}) local_free_vars arg_types result_type cinp.cinp_group_index
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
991
						(ci.ci_next_fun_nr, ci.ci_new_functions, ci.ci_fun_heap)
992
		  free_var = varToFreeVar var (inc ref_count)
993
994
995
996
997
998
999
// MW0		= ({	bind_src = App {	app_symb 		= fun_symb,
		= ({	lb_src = App {	app_symb 		= fun_symb,
								app_args 		= act_args,
								app_info_ptr	= nilPtr },
// MW0				bind_dst = free_var },
				lb_dst = free_var,
				lb_position = NoPos },
1000
1001
		   { ci & ci_var_heap = ci_var_heap, ci_next_fun_nr = ci_next_fun_nr, ci_new_functions = ci_new_functions, ci_fun_heap = ci_fun_heap,
					 ci_new_variables = [ free_var : ci_new_variables ] })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1002
1003
1004
1005
1006
1007
1008
1009
	where
		get_reference_count {var_name,var_info_ptr} ci=:{ci_var_heap}
			# (info, ci_var_heap) = readPtr var_info_ptr ci_var_heap
			  ci = { ci & ci_var_heap = ci_var_heap }
			= case info of
				VI_Default ref_count	-> (ref_count, ci)
//				_						-> (0, ci) ---> ("get_reference_count", var_name)  /* A predicted variable always has a ref_count */ 
		
1010
		save_default {tv_free_var={fv_info_ptr}} (saved_defaults, ci_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1011
1012
			# (info, ci_var_heap) = readPtr fv_info_ptr ci_var_heap
			= case info of
1013
1014
1015
1016
				VI_Default ref_count
					-> ([(fv_info_ptr, info) : saved_defaults] , ci_var_heap)
				VI_Indirection ref_count
					-> ([(fv_info_ptr, info) : saved_defaults] , ci_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1017
1018
				_						-> (saved_defaults, ci_var_heap)
				
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
		restore_default (var_info_ptr,info) ci_var_heap
			= ci_var_heap <:= (var_info_ptr, info)

		remove_local_var fv=:{fv_info_ptr} (local_vars, var_heap)
			# (info, var_heap) = readPtr fv_info_ptr var_heap
			= case info of
				VI_LocalVar
					-> (local_vars, var_heap)
				_
					-> ([fv : local_vars], var_heap)
Ronny Wichers Schreur's avatar