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

import syntax, transform, utilities, convertcases
4
5
// Optional
USE_TUPLES tuple b :== b;		// change also StdDynamic.icl and recompile all applications
6
import type_io;
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
7
8
9
10
11

::	*ConversionInfo =
	{	ci_predef_symb		:: !*PredefinedSymbols
	,	ci_var_heap			:: !*VarHeap
	,	ci_expr_heap		:: !*ExpressionHeap
12
	,	ci_new_variables 	:: ![FreeVar]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
13
14
15
	,	ci_new_functions 	:: ![FunctionInfoPtr]
	,	ci_fun_heap			:: !*FunctionHeap
	,	ci_next_fun_nr		:: !Index
Martijn Vervoort's avatar
Martijn Vervoort committed
16
17
18
	
	//	data needed to generate coercions
	,	ci_placeholders_and_tc_args		:: [(!BoundVar,Ptr VarInfo)]
19
20
	,	ci_generated_global_tc_placeholders		:: !Bool
	,	ci_used_tcs								:: [Ptr VarInfo]
21
22
23
	,	ci_symb_ident		:: SymbIdent
	,	ci_sel_type_field	:: Expression -> Expression  //Optional (!Int,!(Global DefinedSymbol))
	,	ci_sel_value_field	:: Expression -> Expression  //Optional (!Int,!(Global DefinedSymbol))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
24
25
26
27
28
	}

::	ConversionInput =
	{	cinp_glob_type_inst	:: !{! GlobalTCType} 
	,	cinp_group_index	:: !Int
29
	,	cinp_st_args		:: ![FreeVar]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
30
31
32
33
34
35
36
37
	}

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

:: DefaultExpression :== Optional (BoundVar, [IndirectionVar])   //DefaultRecord
38
39
40

::	BoundVariables :== [TypedVariable]

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
41
:: IndirectionVar    :== BoundVar
42

43
44
45

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

47
48
F :: !a .b -> .b
F a b = b
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
49

Martijn Vervoort's avatar
Martijn Vervoort committed
50
51
write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File)
write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file directly_imported_dcl_modules
52
53
	#! tcl_file
		= write_type_info common_defs tcl_file
Martijn Vervoort's avatar
Martijn Vervoort committed
54
55
56
57
58
59
	#! tcl_file
		= write_type_info directly_imported_dcl_modules tcl_file
	#! tcl_file
		= fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file
	= (True,tcl_file) 
//---> ("dcl",size main_dcl_module.dcl_common.com_type_defs, "icl", size common_defs.com_type_defs);
60
			
Martijn Vervoort's avatar
Martijn Vervoort committed
61
convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap /* TD */!*File {# DclModule} !IclModule /* TD */ [String]
62
			-> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, /* TD */ !*File)
Martijn Vervoort's avatar
Martijn Vervoort committed
63
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
64
65
	// TD ...
	# (ok,tcl_file)
Martijn Vervoort's avatar
Martijn Vervoort committed
66
		= write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file /* TD */ directly_imported_dcl_modules
67
68
69
	| not ok
		= abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
	// ... TD
Martijn Vervoort's avatar
Martijn Vervoort committed
70
	
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
	# ({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
114
												,	ds_index		= pds_def2 
115
												}
116
							,	glob_module		= pds_module2 
117
118
119
							}
						#! ci_sel_type_field
							= (\dynamic_expr -> Selection No dynamic_expr [RecordSelection type_defined_symbol sd_field_nr])
120
							
121
122
123
124
125
126
127
128
129
130
						// 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
131
												,	ds_index		= pds_def3 
132
												}
133
							,	glob_module		= pds_module3
134
135
136
137
138
							}
						#! ci_sel_value_field
							= (\dynamic_expr -> Selection No dynamic_expr [RecordSelection value_defined_symbol sd_field_nr3])
						-> (dynamic_temp_symb_ident, ci_sel_value_field, ci_sel_type_field,predefined_symbols) 

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
139
	#! nr_of_funs = size fun_defs
140
	# imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
141
142
143
	# (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,
144
145
							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,
146
							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 })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
147
	  (groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap)
148
			= addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions main_dcl_module_n groups imported_types [] type_heaps ci_var_heap
149
	= (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
150
151
152
153
where
	convert_groups group_nr groups global_type_instances fun_defs_and_ci
		| group_nr == size groups
			= (groups, fun_defs_and_ci)
154
			# (group, groups) = groups![group_nr]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
155
156
157
			= 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
158
159
160
161
		# (fun_def, fun_defs) = fun_defs![fun]
		  {fun_body, fun_type, fun_info} = fun_def
		| isEmpty fun_info.fi_dynamics
			= (fun_defs, ci)
162
163
			# ci 
				= { ci & ci_used_tcs = [], ci_generated_global_tc_placeholders = False }
164
			# (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
165
166
			= ({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 = [] })
167
168
169
170
// 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
171
		  (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
172
173
174
175
		= (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'"

176
177
178
179
// MV ..
bindVarsToTypes2 st_context vars types typed_vars common_defs
	:== bindVarsToTypes vars (addTypesOfDictionaries common_defs st_context types) typed_vars
// .. MV
180
181
182
183
184
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
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201

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)

202
203
204
205
206
207
208
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
209
210
211
212
213
214
215
216
217
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
218
	# (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
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
	= ({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
241
	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
242
		# (let_types, ci) = determine_let_types let_info_ptr ci
243
244
// 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
245
246
247
248
		  (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
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
	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)
				#  (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)
			(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'"
	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)
298
299
300
	convertDynamics cinp bound_vars default_expr  (DynamicExpr {dyn_expr, dyn_info_ptr, dyn_uni_vars, dyn_type_code}) ci=:{ci_symb_ident}
//		# (twoTuple_symb, ci) 	= getSymbol (GetTupleConsIndex 2) SK_Constructor 2 ci
		# (let_binds,     ci) 	= createVariables dyn_uni_vars [] ci
301
		  (dyn_expr,      ci) 	= convertDynamics cinp bound_vars default_expr dyn_expr ci
302
		  (_,dyn_type_code,_,_,ci) = convertTypecode2 cinp dyn_type_code False [] [] ci
Martijn Vervoort's avatar
Martijn Vervoort committed
303
//		  (_,dyn_type_code, ci) = convertTypecode cinp dyn_type_code ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
304
		= case let_binds of
305
			[]	-> (App {	app_symb		= ci_symb_ident, //USE_TUPLES twoTuple_symb ci_symb_ident, //twoTuple_symb,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
306
307
308
							app_args 		= [dyn_expr, dyn_type_code],
							app_info_ptr	= nilPtr }, ci)
			_ 	#  (let_info_ptr,  ci) = let_ptr ci
Sjaak Smetsers's avatar
Sjaak Smetsers committed
309
310
				-> ( Let {	let_strict_binds	= [],
							let_lazy_binds		= let_binds,
311
							let_expr			= App {	app_symb		= ci_symb_ident, //USE_TUPLES twoTuple_symb ci_symb_ident,
Sjaak Smetsers's avatar
Sjaak Smetsers committed
312
313
														app_args 		= [dyn_expr, dyn_type_code],
														app_info_ptr	= nilPtr },
314
315
// MW0							let_info_ptr		= let_info_ptr,}, ci)
							let_info_ptr		= let_info_ptr,
316
							let_expr_position	= NoPos}, ci) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
317
	convertDynamics cinp bound_vars default_expr (TypeCodeExpression type_code) ci
318
		= abort "convertDynamics cinp bound_vars default_expr (TypeCodeExpression" //convertTypecode cinp type_code ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
319
320
321
322
323
	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
324
325


326
//convertTypecode ::  !ConversionInput TypeCodeExpression !*ConversionInfo  -> (Expression,!*ConversionInfo)
Martijn Vervoort's avatar
Martijn Vervoort committed
327
328
329
330
331
/*
	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
	
332

Martijn Vervoort's avatar
Martijn Vervoort committed
333
334
*/
// ci_placeholders_and_tc_args
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
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
		= convertTypecode2 cinp t replace_tc_args binds placeholders_and_tc_args ci

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
358
359
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
360

361
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
362
363
	| 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
364

Martijn Vervoort's avatar
Martijn Vervoort committed
365
366
367
368
	// 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)
369
370
371
372
373
374
375
376
377
378
		// 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
379
		= (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args, ci)
380
381
382
383
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
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402

// 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
403
404
	= (App {app_symb		= typecons_symb,
			app_args 		= [constructor , typecode_exprs],
Martijn Vervoort's avatar
Martijn Vervoort committed
405
			app_info_ptr	= nilPtr},binds,placeholders_and_tc_args,ci)
406

Martijn Vervoort's avatar
Martijn Vervoort committed
407
408
409
410
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)
411

Martijn Vervoort's avatar
Martijn Vervoort committed
412
413
//convertTypecodes :: !ConversionInput [TypeCodeExpression] !*ConversionInfo  -> (Expression,!*ConversionInfo)
convertTypecodes _ [] replace_tc_args binds placeholders_and_tc_args ci
414
415
416
	# (nil_symb, ci) = getSymbol PD_NilSymbol SK_Constructor 0 ci
	= (App {	app_symb		= nil_symb,
				app_args 		= [],
Martijn Vervoort's avatar
Martijn Vervoort committed
417
418
419
				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
420
	# (cons_symb, ci) = getSymbol PD_ConsSymbol SK_Constructor 2 ci
Martijn Vervoort's avatar
Martijn Vervoort committed
421
422
	# (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
423
424
	= (App {	app_symb		= cons_symb,
				app_args 		= [expr , exprs],
Martijn Vervoort's avatar
Martijn Vervoort committed
425
				app_info_ptr	= nilPtr}, binds,placeholders_and_tc_args, ci)
426

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
427
428
429
430
431
432
433
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
434
		 					THEN the default_expr remains default in the nested cases.
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
435
							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
436

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
437
***/
Martijn Vervoort's avatar
Martijn Vervoort committed
438
439
440
441



// the case itself has no default but it has a surrounding default
442
443
444
445
/*
	1st 	= default of current case
	2nd 	= directly surrounding default
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
446
447
448
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}
449
	# expression
Martijn Vervoort's avatar
Martijn Vervoort committed
450
		= expression// ---> expression
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
451
452
453
454
455
456
457
458
459
460
461
462
	= 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
463
	= 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
464
where
465
466
	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
467

468
open_dynamic :: Expression !*ConversionInfo -> (OpenedDynamic, LetBind, !*ConversionInfo)
469
open_dynamic dynamic_expr ci=:{ci_sel_type_field, ci_sel_value_field}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
470
471
	# (twotuple, ci) = getTupleSymbol 2 ci
	  (dynamicType_var, ci) = newVariable "dt" VI_Empty ci
472
	  dynamicType_fv = varToFreeVar dynamicType_var 1
473
474
475
476
//	  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
477
// MW0	  	{ bind_src = TupleSelect twotuple 1 dynamic_expr, bind_dst = dynamicType_fv },
478
	  	{ lb_src = ci_sel_type_field dynamic_expr /*USE_TUPLES (TupleSelect twotuple 1 dynamic_expr) sel_type*/, lb_dst = dynamicType_fv, lb_position = NoPos },
479
	  	{ ci & ci_new_variables = [ dynamicType_fv : ci.ci_new_variables ]})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
480
481
482
483
484
485
486
/**************************************************************************************************/

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'"
487
488
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
489
	# (opened_dynamic, dt_bind, ci) = open_dynamic case_expr ci
490
	  (ind_0, ci) = newVariable "ind_0" (VI_Indirection 0) ci
491
	  (c_1,   ci) = newVariable "c_1!" (VI_Default 0) ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
492
493
      new_default = newDefault c_1 ind_0
      (result_type, ci) = getResultType case_info_ptr ci
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
    
    #! // 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

	#

509
510
// 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
511
      							  (addToBoundVars c_1 result_type (add_dynamic_bound_vars patterns bound_vars)))
512
513

																// c_1 ind_0
514
	  (binds, expr, ci) = convert_dynamic_pattern cinp bound_vars new_default 1 opened_dynamic result_type case_default patterns ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
515
	  (let_info_ptr, ci) = let_ptr ci
516
517
518
519
520
521

	# ci
		= { ci & ci_placeholders_and_tc_args=old_ci_placeholders_and_tc_args}
	# (tc_binds,ci)
		= foldSt remove_non_used_arg tc_binds ([],ci) 

522
523
524
// 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)
525
where
526
527
528
// 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})
529
530
531
		# (VI_Indirection ref_count, ci_var_heap) = readPtr fv_info_ptr ci_var_heap
		| ref_count > 0
			#! tc_bind
532
				= { tc_bind & lb_dst = { tc_bind.lb_dst & fv_count = ref_count} }
533
534
535
536
537
538
539
540
541
542
543
			= ([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
544
			= newVariable v_tc_placeholder v ci //---> st_arg
545
546
547
548
549
550
551
552
553
554
555
556
557
		#! (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
558
559
// MW0		create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo)
		create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo)
560
561
562
563
		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	
564
565
566
567
568
569
570
// 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
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
			   },
			   { ci & ci_new_variables = [ cyclic_fv : ci.ci_new_variables ]} /*ci*/)
			   
	add_coercions [] _ _ bound_vars dp_rhs ci
		= (bound_vars,dp_rhs,ci)
	add_coercions [({var_info_ptr=a_ij},a_ij_tc):rest] this_default q bound_vars dp_rhs ci
		// 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
		  
		#		
		  (coerce_symb, ci)		= getSymbol PD_coerce SK_Function 2 ci
		  (twotuple, ci) 		= getTupleSymbol 2 ci
		  (let_info_ptr, ci) 	= let_ptr ci
		  (case_info_ptr, ci)	= case_ptr 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)
			= add_coercions rest (if (isNo this_default) No new_default2) q bound_vars dp_rhs ci 
		
		#! (opt_expr,ci)
			= toExpression this_default ci

		# let_expr
			= Let {
					let_strict_binds	= []
622
623
624
625
626
627
// MW0				,	let_lazy_binds		= (if (isNo this_default) [] [ {bind_src = opt opt_expr		,	bind_dst = c_inc_i_fv }]) ++ [
// MW0										  { bind_src = App { app_symb = coerce_symb,  app_args = [Var a_ij_var, Var a_ij_tc_var],  app_info_ptr = nilPtr },
// MW0										   bind_dst = coerce_result_fv }
				,	let_lazy_binds		= (if (isNo this_default) [] [ {lb_src = opt opt_expr, lb_dst = c_inc_i_fv, lb_position = NoPos }]) ++ [
										  { lb_src = App { app_symb = coerce_symb,  app_args = [Var a_ij_var, Var a_ij_tc_var],  app_info_ptr = nilPtr },
										   lb_dst = coerce_result_fv, lb_position = NoPos }
628
										   ,
629
630
// MW0										 { bind_src = TupleSelect twotuple 0 (Var coerce_result_var),
// MW0										   bind_dst = coerce_bool_fv } : let_binds
631
										 { lb_src = /*USE_TUPLES (*/ TupleSelect twotuple 0 (Var coerce_result_var) /*) sel_type*/,
632
										   lb_dst = coerce_bool_fv, lb_position = NoPos } : let_binds
633
634
635
636
637
638
639
640
641
642
										],
							let_expr =
							 Case {	case_expr 		= Var coerce_bool_var,
		// MW was:												case_guards		= BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs}],
											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,
											case_default_pos= NoPos } // MW4++
				,	let_info_ptr = let_info_ptr	
643
				,	let_expr_position = NoPos // MW0++
644
645
646
647
648
649
650
				}
		
		// 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
			
651
	convert_dynamic_pattern :: !ConversionInput !BoundVariables DefaultExpression Int OpenedDynamic AType (Optional Expression) ![DynamicPattern] *ConversionInfo
652
653
/// MW0		-> (Env Expression FreeVar, Expression, *ConversionInfo)
		-> ([LetBind], Expression, *ConversionInfo)
654
655
	convert_dynamic_pattern cinp bound_vars this_default pattern_number opened_dynamic result_type last_default
																			[{ dp_var, dp_type_patterns_vars, dp_type_code, dp_rhs } : patterns] ci
Martijn Vervoort's avatar
Martijn Vervoort committed
656
		# /***  The last case may not have a default  ***/
657
658
659
660
661
662
663

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

664
		  (a_ij_binds, ci)		= createVariables dp_type_patterns_vars [] ci
665
666
667
668
669
670
671
672
673
674
675
	 	  (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
676
	 	  (dp_rhs, ci)			= convertDynamics cinp bound_vars this_default dp_rhs ci
677
678
679
680
681
682
683
684
	 	  	 		
		// collect ...
		#! (ci_old_used_tcs,ci)
			= ci!ci_used_tcs;
	 	# ci
	 		= { ci & ci_used_tcs = [] }
		// ... collect
			 		
Martijn Vervoort's avatar
Martijn Vervoort committed
685
		  /***  recursively convert the other patterns in the other alternatives ***/
686

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

689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711

		// 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
		#
712
		  /***  generate the expression  ***/
713
	 	  (unify_symb, ci) 		= getSymbol (if generate_coerce PD_coerce PD_unify ) SK_Function 2 ci
714
715
716
717
		  (twotuple, ci) 		= getTupleSymbol 2 ci
		  (let_info_ptr, ci) 	= let_ptr ci
		  (case_info_ptr, ci)	= case_ptr ci
		  (default_expr, ci) 	= toExpression this_default ci
Martijn Vervoort's avatar
Martijn Vervoort committed
718
719
720
		  
		  // was coercions
		  
721
722
		  (unify_result_var, ci)	= newVariable "result" VI_Empty ci
		  unify_result_fv 			= varToFreeVar unify_result_var 1
723
		  (unify_bool_var, ci)		= newVariable (if generate_coerce "coerce_bool" "unify_bool") VI_Empty ci
724
725
		  unify_bool_fv 			= varToFreeVar unify_bool_var 1

Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
726
727
		  (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
728
		  
Martijn Vervoort's avatar
Martijn Vervoort committed
729
//		  sel_type	= Selection No (Var unify_result_var) [RecordSelection type_defined_symbol sd_type_field_nr]
730

Sjaak Smetsers's avatar
Sjaak Smetsers committed
731
		  let_expr = Let {	let_strict_binds = [],
732
733
734
735
736
737
// MW0		  					let_lazy_binds = [{ bind_src = App { app_symb = unify_symb,  app_args = [opened_dynamic.opened_dynamic_type, type_code],  app_info_ptr = nilPtr },
// MW0		  								   bind_dst = unify_result_fv },
// MW0		  								 { bind_src = TupleSelect twotuple 0 (Var unify_result_var),
// MW0		  								   bind_dst = unify_bool_fv } : let_binds
		  					let_lazy_binds = [{ lb_src = App { app_symb = unify_symb,  app_args = [opened_dynamic.opened_dynamic_type, type_code],  app_info_ptr = nilPtr },
		  								   lb_dst = unify_result_fv, lb_position = NoPos },
738
		  								 { lb_src = /*USE_TUPLES (*/ TupleSelect twotuple 0 (Var unify_result_var) /*) sel_type*/,
739
		  								   lb_dst = unify_bool_fv, lb_position = NoPos } : let_binds
740
741
		  								],
		  					let_expr = Case {	case_expr 		= Var unify_bool_var,
742
743
// MW was:												case_guards		= BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs}],
												case_guards		= BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs, bp_position = NoPos }],
744
745
												case_default	= default_expr,
												case_ident		= No,
746
747
												case_info_ptr	= case_info_ptr,
												case_default_pos= NoPos }, // MW4++
748
749
750
// MW0		  					let_info_ptr = let_info_ptr	}
		  					let_info_ptr = let_info_ptr,
		  					let_expr_position = NoPos }
Martijn Vervoort's avatar
Martijn Vervoort committed
751
		  					
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
752
		= (a_ij_binds ++ binds,  let_expr,  { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]})
753
	where
754
755
// 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
756
			| fv_count > 0
757
758
// 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
759
				= binds
760
761
762
763
764
765
766
767
768
769
770
				
		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
771

Martijn Vervoort's avatar
Martijn Vervoort committed
772
	// other alternatives
773
	convert_other_patterns :: ConversionInput BoundVariables DefaultExpression Int OpenedDynamic AType !(Optional Expression) ![DynamicPattern] !*ConversionInfo
774
775
// MW0			-> (Env Expression FreeVar, *ConversionInfo)
			-> ([LetBind], *ConversionInfo)
776
	convert_other_patterns _ _ _ _ _ _  No  []  ci
Martijn Vervoort's avatar
Martijn Vervoort committed
777
		// no default and no alternatives left
778
		= ([], ci)
779
780
		
//	The last_default is the default used when there are no pattern left
781
	convert_other_patterns cinp bound_vars this_default _ _ result_type (Yes last_default_expr) [] ci
Martijn Vervoort's avatar
Martijn Vervoort committed
782
		// default without alternatives left
783
		# c_i = getVariable1 this_default
784
785
		  (c_bind, ci) = generateBinding cinp bound_vars c_i last_default_expr result_type ci
		= ([c_bind], ci)
786

787
788
789
790
791
792
	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
793
		  c_i = getVariable2 this_default
Martijn Vervoort's avatar
Martijn Vervoort committed
794
		  (c_bind, ci) = generateBinding cinp bound_vars c_i expr result_type ci
795
796
	     = ([c_bind: binds], ci) 

Martijn Vervoort's avatar
Martijn Vervoort committed
797
798
799
800
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
801
// MW0  		= ([{ bind_src = TupleSelect twotuple 1 (Var unify_result_var), bind_dst = ind_fv }],
802
803
//		  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
804
805
				{ ci & ci_var_heap = ci_var_heap, ci_new_variables = [ ind_fv : ci_new_variables ]})
		= ([], {ci & ci_var_heap = ci_var_heap})
806
		
Martijn Vervoort's avatar
Martijn Vervoort committed
807
/*
808
809
810
	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
811
812

*/
813
814
// 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
815
816
817
generateBinding cinp bound_vars var bind_expr result_type ci
	# (ref_count, ci) = get_reference_count var ci
	| ref_count == 0
818
		# free_var = varToFreeVar var 1
819
820
// 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
821
		# (saved_defaults, ci_var_heap) = foldSt save_default bound_vars ([], ci.ci_var_heap)
822
		  (act_args, free_typed_vars, local_free_vars, tb_rhs, ci_var_heap) = copyExpression bound_vars bind_expr ci_var_heap
823
		#
824
		  (ci_new_variables, ci_var_heap) = foldSt remove_local_var ci.ci_new_variables ([], ci_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
825
		  ci_var_heap = foldSt restore_default saved_defaults ci_var_heap
826
827
		  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
828
		  (fun_symb,  (ci_next_fun_nr, ci_new_functions, ci_fun_heap))
829
				= 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
830
						(ci.ci_next_fun_nr, ci.ci_new_functions, ci.ci_fun_heap)
831
		  free_var = varToFreeVar var (inc ref_count)
832
833
834
835
836
837
838
// 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 },
839
840
		   { 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
841
842
843
844
845
846
847
848
	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 */ 
		
849
		save_default {tv_free_var={fv_info_ptr}} (saved_defaults, ci_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
850
851
			# (info, ci_var_heap) = readPtr fv_info_ptr ci_var_heap
			= case info of
852
853
854
855
				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
856
857
				_						-> (saved_defaults, ci_var_heap)
				
858
859
860
861
862
863
864
865
866
867
		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
Ronny Wichers Schreur committed
868
869
870

/**************************************************************************************************/

871
872
// MW0 createVariables :: [VarInfoPtr] !(Env Expression FreeVar) !*ConversionInfo -> (!Env Expression FreeVar, !*ConversionInfo)
createVariables :: [VarInfoPtr] ![LetBind] !*ConversionInfo -> (![LetBind], !*ConversionInfo)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
873
createVariables var_info_ptrs binds ci
Martijn Vervoort's avatar
Martijn Vervoort committed
874
875
	= mapAppendSt (create_variable a_ij_var_name) var_info_ptrs binds ci

876
877
// MW0create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo)
create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo)
Martijn Vervoort's avatar
Martijn Vervoort committed
878
879
880
881
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	
882
883
// MW0	= ({ bind_src = App {	app_symb = placeholder_symb,
	= ({ lb_src = App {	app_symb = placeholder_symb,
Martijn Vervoort's avatar
Martijn Vervoort committed
884
885
							app_args = [Var cyclic_var, Var cyclic_var],
							app_info_ptr = nilPtr },
886
887
888
// MW0		 bind_dst = varToFreeVar cyclic_var 1
		 lb_dst = varToFreeVar cyclic_var 1,
		 lb_position = NoPos
Martijn Vervoort's avatar
Martijn Vervoort committed
889
890
	   },
	   { ci & ci_new_variables = [ cyclic_fv : ci.ci_new_variables ]})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907

/**************************************************************************************************/

newVariable :: String !VarInfo !*ConversionInfo -> *(!BoundVar,!*ConversionInfo)
newVariable var_name var_info ci=:{ci_var_heap}
	# (var_info_ptr, ci_var_heap) = newPtr var_info ci_var_heap
	= ( { var_name = {id_name = var_name, id_info = nilPtr},  var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},
	    { ci & ci_var_heap = ci_var_heap })	


newDefault :: BoundVar IndirectionVar -> DefaultExpression
newDefault variable indirection_var = Yes (variable, [indirection_var])

getVariable :: DefaultExpression -> BoundVar
getVariable (Yes (variable, _)) = variable
getVariable No = abort "unexpected value in convertDynamics: 'getVariable'"

908
909
910
911
912
913
914
915
916
917
getVariable1 :: DefaultExpression -> BoundVar
getVariable1 (Yes (variable, _)) = variable
getVariable1 No = abort "unexpected value in convertDynamics: 'getVariable'"
getVariable2 :: DefaultExpression -> BoundVar
getVariable2 (Yes (variable, _)) = variable
getVariable2 No = abort "unexpected value in convertDynamics: 'getVariable'"
getVariable3 :: DefaultExpression -> BoundVar
getVariable3 (Yes (variable, _)) = variable
getVariable3 No = abort "unexpected value in convertDynamics: 'getVariable'"

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
918
919
920
921
922
923
getIndirectionVar (Yes (_, [ind_var:_])) = ind_var
getIndirectionVar No = abort "unexpected value in convertDynamics: 'getIndirectionVar'"

toExpression :: DefaultExpression !*ConversionInfo -> (Optional Expression, !*ConversionInfo)
toExpression No ci = (No, ci)
toExpression (Yes (variable, indirection_var_list)) ci
Martijn Vervoort's avatar
Martijn Vervoort committed
924
925
	| length indirection_var_list <> 1
		= abort "toExpression: meerdere indirectie variables"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
926
927
928
929
930
931
932
	# (expression, ci) = toExpression2 variable indirection_var_list ci
	= (Yes expression, ci)
where
	toExpression2 variable [] ci = (Var variable, ci)
	toExpression2 variable [indirection_var : indirection_vars] ci
		# (expression, ci) = toExpression2 variable indirection_vars ci
		  (undo_symb, ci) = getSymbol PD_undo_indirections SK_Function 2 ci
933
		  ci_var_heap = adjust_ref_count indirection_var ci.ci_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
934
935
		= (App {	app_symb = undo_symb,
					app_args = [expression, Var indirection_var],
936
937
938
939
940
					app_info_ptr = nilPtr }, { ci & ci_var_heap = ci_var_heap })

	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))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
941

942

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
943
944
945
946
947
948
949
950
951
952
953
varToFreeVar :: BoundVar Int -> FreeVar
varToFreeVar {var_name, var_info_ptr} count
	= {fv_def_level = NotALevel, fv_name = var_name, fv_info_ptr = var_info_ptr, fv_count = count}

freeVarToVar ::  FreeVar -> BoundVar
freeVarToVar {fv_name, fv_info_ptr}
	= { var_name = fv_name,  var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr}


addToBoundVars :: BoundVar AType BoundVariables -> BoundVariables
addToBoundVars var type bound_vars
954
	= [ { tv_free_var = varToFreeVar var 0, tv_type = type } : bound_vars ]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
955
956
957
958
959
960
961
962
963


get_constructor :: !{!GlobalTCType} Index -> Expression
get_constructor glob_type_inst index
	= BasicExpr (BVS ("\"" +++ toString  glob_type_inst.[index] +++ "\"")) (BT_String TE)


instance toString GlobalTCType
where
964
965
966
	toString (GTT_Basic basic_type)							= toString basic_type
	toString GTT_Function									= " -> "
	toString (GTT_Constructor type_symb_indent mod_name)	= type_symb_indent.type_name.id_name +++ "'" +++ mod_name
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008

instance toString BasicType
where
	toString BT_Int 		= "Int"
	toString BT_Char		= "Char"
	toString BT_Real		= "Real"
	toString BT_Bool		= "Bool"
	toString BT_Dynamic		= "Dynamic"
	toString BT_File		= "File"
	toString BT_World		= "World"
	toString (BT_String _)	= "String"


getResultType :: ExprInfoPtr !*ConversionInfo -> (!AType, !*ConversionInfo)
getResultType case_info_ptr ci=:{ci_expr_heap}
	# (EI_CaseType {ct_result_type}, ci_expr_heap) = readPtr case_info_ptr ci_expr_heap
	= (ct_result_type, {ci & ci_expr_heap = ci_expr_heap})

getSymbol :: Index ((Global Index) -> SymbKind) Int !*ConversionInfo -> (SymbIdent, !*ConversionInfo)
getSymbol index symb_kind arity ci=:{ci_predef_symb}
	# ({pds_module, pds_def, pds_ident}, ci_predef_symb) = ci_predef_symb![index]
	  ci = {ci & ci_predef_symb = ci_predef_symb}
	  symbol = { symb_name = pds_ident, symb_kind = symb_kind { glob_module = pds_module, glob_object = pds_def}, symb_arity = arity }
	= (symbol, ci)

getTupleSymbol arity ci=:{ci_predef_symb}
	# ({pds_def, pds_ident}, ci_predef_symb) = ci_predef_symb![GetTupleConsIndex arity]
    = ( {ds_ident = pds_ident, ds_arity = arity, ds_index = pds_def}, {ci & ci_predef_symb = ci_predef_symb })

getGlobalIndex :: Index !*ConversionInfo -> (Global Index, !*ConversionInfo)
getGlobalIndex index ci=:{ci_predef_symb}
	# ({pds_module, pds_def}, ci_predef_symb) = ci_predef_symb![index]
	= ( { glob_module = pds_module, glob_object = pds_def} , {ci & ci_predef_symb = ci_predef_symb} )

getConstructor :: Index Int !*ConversionInfo -> (Global DefinedSymbol, !*ConversionInfo)
getConstructor index arity ci=:{ci_predef_symb}
	# ({pds_module, pds_def, pds_ident}, ci_predef_symb) = ci_predef_symb![index]
	  defined_symbol = { ds_ident = pds_ident, ds_arity = arity, ds_index = pds_def}
	= (	{glob_object = defined_symbol, glob_module = pds_module} , {ci & ci_predef_symb = ci_predef_symb} )


a_ij_var_name :== { id_name = "a_ij", id_info = nilPtr }
1009
v_tc_name	  :== { id_name = "convertDynamicsvTC", id_info = nilPtr }
Martijn Vervoort's avatar
Martijn Vervoort committed
1010
v_tc_placeholder_ident	:== { id_name = v_tc_placeholder, id_info = nilPtr }
1011
1012
v_tc_placeholder_ident_global	:== { id_name = v_tc_placeholder +++ "GLOBAL", id_info = nilPtr }

Martijn Vervoort's avatar
Martijn Vervoort committed
1013
1014
1015
v_tc_placeholder		:== "tc_placeholder"

a_aij_tc_var_name 	:== { id_name = "a_ij_tc", id_info = nilPtr }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043

case_ptr :: !*ConversionInfo -> (ExprInfoPtr, !*ConversionInfo)
case_ptr ci=:{ci_expr_heap}
	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_CaseType {	ct_pattern_type = empty_attributed_type,
															ct_result_type = empty_attributed_type,
															ct_cons_types = repeat (repeat empty_attributed_type)}) ci_expr_heap
	= (expr_info_ptr, {ci &  ci_expr_heap = ci_expr_heap})

let_ptr :: !*ConversionInfo -> (ExprInfoPtr, !*ConversionInfo)
let_ptr ci=:{ci_expr_heap}
	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_LetType (repeat empty_attributed_type)) ci_expr_heap
	= (expr_info_ptr, {ci &  ci_expr_heap = ci_expr_heap})


empty_attributed_type :: AType
empty_attributed_type = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TE }


isNo :: (Optional a) -> Bool
isNo (Yes _) = False
isNo No = True

zipAppend2 :: [.a] [.b] u:[w:(.a,.b)] -> v:[x:(.a,.b)], [w <= x, u <= v]
zipAppend2   []       ys     zs = zs
zipAppend2   xs       []     zs = zs
zipAppend2 [x : xs] [y : ys] zs = [ (x,y)  :  zipAppend2 xs ys zs ]


1044
instance <<< (Ptr a)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1045
1046
1047
1048
1049
where
	(<<<) file ptr = file <<< ptrToInt ptr