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

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
3
import syntax
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
4

5
from type_io_common import PredefinedModuleName
6

7
// Optional
8
extended_unify_and_coerce no yes :== no;	// change also _unify and _coerce in StdDynamic
Martijn Vervoort's avatar
Martijn Vervoort committed
9

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
10
import type_io;
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
11

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
12
::	*ConversionState =
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
13
14
15
	{	ci_predef_symb		:: !*PredefinedSymbols
	,	ci_var_heap			:: !*VarHeap
	,	ci_expr_heap		:: !*ExpressionHeap
16
	,	ci_new_variables 	:: ![FreeVar]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
17
18

	,	ci_type_pattern_var_count	:: !Int	
19
	,	ci_type_var_count :: !Int
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
20
21
	}

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
22
23
24
25
26
27
:: DynamicRepresentation =
	{	dr_type_ident		:: SymbIdent
	,	dr_dynamic_type		:: Global Index
	,	dr_dynamic_symbol	:: Global DefinedSymbol
	}

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
28
::	ConversionInput =
29
	{	cinp_dynamic_representation	:: DynamicRepresentation
30
	,	cinp_st_args		:: ![FreeVar]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
31
	,	cinp_subst_var		:: !BoundVar
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
32
33
	}

34
35
36
fatal :: {#Char} {#Char} -> .a
fatal function_name message
	=	abort ("convertDynamics, " +++ function_name +++ ": " +++ message)
37

John van Groningen's avatar
John van Groningen committed
38
39
40
write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} directly_imported_dcl_modules common_defs icl_common
	n_types_with_type_functions n_constructors_with_type_functions
		tcl_file type_heaps predefined_symbols imported_types var_heap
41
42
	# write_type_info_state2
		= { WriteTypeInfoState |
43
44
45
46
47
48
			wtis_n_type_vars				= 0
		,	wtis_common_defs				= common_defs
		,	wtis_type_defs					= imported_types
	  	, 	wtis_type_heaps					= type_heaps
	  	, 	wtis_var_heap					= var_heap
	  	, 	wtis_main_dcl_module_n			= main_dcl_module_n
John van Groningen's avatar
John van Groningen committed
49
	  	,	wtis_icl_generic_defs = icl_common.com_generic_defs
50
		};
51

52
	#! (tcl_file,write_type_info_state)
John van Groningen's avatar
John van Groningen committed
53
		= write_type_info_of_types_and_constructors icl_common n_types_with_type_functions n_constructors_with_type_functions tcl_file write_type_info_state2
54

55
56
	#! (tcl_file,write_type_info_state)
		= write_type_info directly_imported_dcl_modules tcl_file write_type_info_state
57

Martijn Vervoort's avatar
Martijn Vervoort committed
58
59
60
61
62
	#! (tcl_file,write_type_info_state)
		= write_type_info (help_20_compiler { dcl_name.id_name\\ {dcl_name} <-: dcl_mods }) tcl_file write_type_info_state
			with 
				help_20_compiler :: {#{#Char}} -> {#{#Char}}
				help_20_compiler l = l
63
		 
Martijn Vervoort's avatar
Martijn Vervoort committed
64
65
	#! tcl_file
		= fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file
Martijn Vervoort's avatar
Martijn Vervoort committed
66
	#! tcl_file
67
68
69
70
	 	= fwritei (size main_dcl_module.dcl_common.com_cons_defs) tcl_file
	 
	#! (type_heaps,imported_types,var_heap)
		= f write_type_info_state;	
Martijn Vervoort's avatar
Martijn Vervoort committed
71
				
72
	= (True,tcl_file,type_heaps,predefined_symbols,imported_types,var_heap) 
73
where
74
75
	f write_type_info_state=:{wtis_type_heaps,wtis_type_defs,wtis_var_heap}
		= (wtis_type_heaps,wtis_type_defs,wtis_var_heap)
76

John van Groningen's avatar
John van Groningen committed
77
convertDynamicPatternsIntoUnifyAppls :: !{# CommonDefs} !Int  {#DclModule} !IclModule [String] !Int !Int
78
		!*{!Component} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap !(Optional *File)
John van Groningen's avatar
John van Groningen committed
79
	-> (!*{#{#CheckedTypeDef}},
80
		!*{!Component},!*{#FunDef},!*PredefinedSymbols,!*VarHeap,!*TypeHeaps,!*ExpressionHeap,!(Optional *File))
John van Groningen's avatar
John van Groningen committed
81
82
83
convertDynamicPatternsIntoUnifyAppls common_defs main_dcl_module_n dcl_mods icl_mod directly_imported_dcl_modules
		n_types_with_type_functions n_constructors_with_type_functions
		groups fun_defs predefined_symbols var_heap type_heaps expr_heap tcl_file
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
84
85
86
	#! (dynamic_representation,predefined_symbols)
		=	create_dynamic_and_selector_idents common_defs predefined_symbols

87
	# imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs }
88
89
	# (groups, (fun_defs, {ci_predef_symb, ci_var_heap, ci_expr_heap}))
			= convert_groups 0 groups dynamic_representation (fun_defs, {	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
90
							ci_predef_symb = predefined_symbols, ci_var_heap = var_heap, ci_expr_heap = expr_heap,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
91
							ci_new_variables = [],
92
							ci_type_var_count = 0,
93
							ci_type_pattern_var_count = 0
94
95
96
							})
			
	// store type info			
97
	# (tcl_file,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
98
99
		= case tcl_file of
			No
100
				-> (No,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
101
			Yes tcl_file
102
				# (ok,tcl_file,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
John van Groningen's avatar
John van Groningen committed
103
104
105
					= write_tcl_file main_dcl_module_n dcl_mods directly_imported_dcl_modules common_defs icl_mod.icl_common
						n_types_with_type_functions n_constructors_with_type_functions
							tcl_file type_heaps ci_predef_symb imported_types ci_var_heap
106
107
				| not ok
					-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
108
					-> (Yes tcl_file,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
109

John van Groningen's avatar
John van Groningen committed
110
	= (imported_types, groups, fun_defs, ci_predef_symb, ci_var_heap, type_heaps, ci_expr_heap, tcl_file)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
111
where
112
	convert_groups group_nr groups dynamic_representation fun_defs_and_ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
113
114
		| group_nr == size groups
			= (groups, fun_defs_and_ci)
115
			# (group, groups) = groups![group_nr]
116
117
118
119
120
121
122
123
			= convert_groups (inc group_nr) groups dynamic_representation
				(convert_functions group.component_members group_nr dynamic_representation fun_defs_and_ci)

	convert_functions (ComponentMember member members) group_nr dynamic_representation fun_defs_and_ci
		# fun_defs_and_ci = convert_function group_nr dynamic_representation member fun_defs_and_ci
		= convert_functions members group_nr dynamic_representation fun_defs_and_ci
	convert_functions NoComponentMembers group_nr dynamic_representation fun_defs_and_ci
		= fun_defs_and_ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
124

125
	convert_function group_nr dynamic_representation fun (fun_defs, ci)
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
126
127
128
129
		# (fun_def, fun_defs) = fun_defs![fun]
		  {fun_body, fun_type, fun_info} = fun_def
		| isEmpty fun_info.fi_dynamics
			= (fun_defs, ci)
130
131
132

			# (unify_subst_var, ci) = newVariable "unify_subst" VI_Empty ci
			# ci = {ci & ci_type_pattern_var_count = 0, ci_type_var_count = 0}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
133
134
135
136

			# (fun_body, ci) = convertDynamics {cinp_st_args = [], cinp_dynamic_representation = dynamic_representation,
					cinp_subst_var = unify_subst_var} fun_body ci

137
138
			= ({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 = []})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
139
140
141
142
143
144
145
146
147

class convertDynamics a :: !ConversionInput !a !*ConversionState -> (!a, !*ConversionState)

instance convertDynamics [a] | convertDynamics a where
	convertDynamics cinp xs ci
		=	mapSt (convertDynamics cinp) xs ci

instance convertDynamics (Optional a) | convertDynamics a where
	convertDynamics cinp (Yes x) ci
148
149
		# (x, ci) = convertDynamics cinp x ci
		= (Yes x, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
150
	convertDynamics _ No ci
151
		= (No, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
152
153
154

instance convertDynamics FunctionBody where
	convertDynamics cinp (TransformedBody body) ci
155
156
		# (body, ci) = convertDynamics cinp body ci
		= (TransformedBody body, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
157
158
159
160
161

instance convertDynamics TransformedBody where
	convertDynamics cinp body=:{tb_args,tb_rhs} ci=:{ci_var_heap}
		// this actually marks all arguments as type terms (also the regular arguments
		// and dictionaries)
162
163
//		# ci_var_heap
//			=	foldSt mark_var tb_args ci_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
164
165
166
167
168
169
170
171
		# (tb_rhs, ci)
			=	convertDynamics cinp tb_rhs {ci & ci_var_heap = ci_var_heap}
		# (global_tpvs, subst, ci)
			=	foldSt collect_global_type_pattern_var tb_args ([], cinp.cinp_subst_var, ci)
		# (tb_rhs, ci)
			=	share_init_subst subst global_tpvs tb_rhs ci
		=	({body & tb_rhs = tb_rhs}, ci)
		where
172
173
174
//			mark_var :: FreeVar *VarHeap -> *VarHeap
//			mark_var {fv_info_ptr} var_heap
//				=	writePtr fv_info_ptr (VI_TypeCodeVariable TCI_TypeTerm) var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
175
176

			collect_global_type_pattern_var :: FreeVar ([LetBind], BoundVar, *ConversionState) -> ([LetBind], BoundVar, *ConversionState)
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
			collect_global_type_pattern_var {fv_info_ptr} (let_binds, subst, ci)
			  #	(var_info, ci_var_heap) = readPtr fv_info_ptr ci.ci_var_heap
				ci = {ci & ci_var_heap = ci_var_heap}
			  =	case var_info of
					VI_TypeCodeVariable (TCI_TypePatternVar tpv)
						# type_code = Var {var_ident = a_ij_var_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr}
						-> bind_global_type_pattern_var tpv type_code let_binds subst ci
					VI_TypeCodeVariable (TCI_SelectionsTypePatternVar tc_selections)
						-> collect_global_type_pattern_var_selections tc_selections fv_info_ptr let_binds subst ci
					_
						-> (let_binds, subst, ci)
			where
				bind_global_type_pattern_var tpv type_code let_binds subst ci
				  #	(bind_global_tpv_symb, ci)
						= getSymbol PD_Dyn_bind_global_type_pattern_var SK_Function 3 ci
					(unify_subst_var, ci) = newVariable "gtpv_subst" VI_Empty ci
					let_bind
						= { lb_src = App {	app_symb		= bind_global_tpv_symb,
											app_args 		= [tpv, type_code, Var unify_subst_var],
											app_info_ptr	= nilPtr }
						,	lb_dst =  varToFreeVar subst 1
						,	lb_position = NoPos }
				  =	([let_bind:let_binds], unify_subst_var, ci)

				collect_global_type_pattern_var_selections [(tpv,selections):tc_selections] fv_info_ptr let_binds subst ci
				  #	dictionary = Var {var_ident = a_ij_var_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr}
					type_code = Selection NormalSelector dictionary selections
					(let_binds,subst,ci) = bind_global_type_pattern_var tpv type_code let_binds subst ci
				  =	collect_global_type_pattern_var_selections tc_selections fv_info_ptr let_binds subst ci
				collect_global_type_pattern_var_selections [] fv_info_ptr let_binds subst ci
				  =	(let_binds,subst,ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
208
209
210

			share_init_subst :: BoundVar [LetBind] Expression *ConversionState
					-> (Expression, *ConversionState)
211
			share_init_subst subst global_tpv_binds rhs ci=:{ci_type_pattern_var_count, ci_type_var_count}
212
				#  (initial_unifier_symb, ci)
213
					=	getSymbol PD_Dyn_initial_unification_environment SK_Function 2 ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
214
215
216

				# let_bind_initial_subst
					= { lb_src = App {	app_symb		= initial_unifier_symb,
217
218
										app_args 		=
												[	BasicExpr (BVInt ci_type_pattern_var_count)
219
												,	BasicExpr (BVInt ci_type_var_count)
220
												],
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
221
222
223
224
										app_info_ptr	= nilPtr }
					,	lb_dst =  varToFreeVar subst 1
					,	lb_position = NoPos
					}
225
226
227
				# let_binds = [let_bind_initial_subst : global_tpv_binds]
				# (let_info_ptr, ci) = let_ptr (length let_binds) ci
				# ci = { ci & ci_new_variables	= [lb_dst  \\ {lb_dst} <- let_binds] ++ ci.ci_new_variables}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
228
229
230
231
232
233
234
235
236
237
238
				# rhs
					= Let {	let_strict_binds	= [],
							let_lazy_binds		= let_binds,
							let_expr			= rhs,
							let_info_ptr		= let_info_ptr,
							let_expr_position	= NoPos
					}
				=	(rhs, ci)

instance convertDynamics LetBind where
	convertDynamics cinp binding=:{lb_src} ci
239
240
		# (lb_src, ci) = convertDynamics cinp lb_src ci
		= ({binding &  lb_src = lb_src}, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
241
242
243

instance convertDynamics (Bind a b) | convertDynamics a where
	convertDynamics cinp binding=:{bind_src} ci
244
245
		# (bind_src, ci) = convertDynamics cinp bind_src ci
		= ({binding &  bind_src = bind_src}, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
246
247
248

instance convertDynamics Expression where
	convertDynamics cinp (TypeCodeExpression tce) ci
249
250
		# (dyn_type_code, ci) = convertExprTypeCode cinp tce ci
		= (dyn_type_code, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
251
252
253
	convertDynamics cinp (Var var) ci
		# (info, ci_var_heap)
			=	readPtr var.var_info_ptr ci.ci_var_heap
254
		# ci = {ci & ci_var_heap = ci_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
255
256
257
258
259
260
		=	case (info, ci) of
				(VI_DynamicValueAlias value_var, ci)
					->	(Var value_var, ci)
				(_, ci)
					->	(Var var, ci)
	convertDynamics cinp (App app) ci
261
262
		# (app, ci) = convertDynamics cinp app ci
		= (App app, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
263
	convertDynamics cinp (expr @ exprs) ci
264
265
266
		# (expr, ci) = convertDynamics cinp expr  ci
		  (exprs, ci) = convertDynamics cinp exprs ci
		= (expr @ exprs, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
267
	convertDynamics cinp (Let letje) ci
268
269
		# (letje, ci) = convertDynamics cinp letje  ci
		= (Let letje, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
270
	convertDynamics cinp (Case kees) ci
271
272
		# (kees,  ci) = convertDynamics cinp kees  ci
		= (Case kees, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
273
	convertDynamics cinp (Selection opt_symb expression selections) ci
274
275
		# (expression,ci) = convertDynamics cinp expression ci
		# (selections,ci) = convertDynamics cinp selections ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
276
277
		=	(Selection opt_symb expression selections, ci)
	convertDynamics cinp (Update expression1 selections expression2) ci
278
279
280
		# (expression1, ci) = convertDynamics cinp expression1 ci
		# (selections, ci) = convertDynamics cinp selections ci
		# (expression2, ci) = convertDynamics cinp expression2 ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
281
282
		=	(Update expression1 selections expression2, ci)
	convertDynamics cinp (RecordUpdate cons_symbol expression expressions) ci
283
284
285
		# (expression, ci) = convertDynamics cinp expression ci
		# (expressions, ci) = convertDynamics cinp expressions ci
		= (RecordUpdate cons_symbol expression expressions, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
286
	convertDynamics cinp (TupleSelect definedSymbol int expression) ci
287
288
		# (expression, ci) = convertDynamics cinp expression ci
		= (TupleSelect definedSymbol int expression, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
289
	convertDynamics _ be=:(BasicExpr _) ci
290
		= (be, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
291
	convertDynamics _ code_expr=:(AnyCodeExpr _ _ _) ci
292
		= (code_expr, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
293
	convertDynamics _ code_expr=:(ABCCodeExpr _ _) ci
294
		= (code_expr, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
295
	convertDynamics cinp (MatchExpr symb expression) ci
296
297
		# (expression, ci) = convertDynamics cinp expression ci
		= (MatchExpr symb expression, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
298
	convertDynamics cinp (DynamicExpr dyno) ci
299
		= convertDynamic cinp dyno ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
300
	convertDynamics cinp EE ci
301
		= (EE, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
302
	convertDynamics cinp expr=:(NoBind _) ci
303
		= (expr,ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
304
305
306

instance convertDynamics App where
	convertDynamics cinp app=:{app_args} ci
307
		# (app_args,ci) = convertDynamics cinp app_args ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
308
309
310
		=	({app & app_args = app_args}, ci)

instance convertDynamics Let where
311
312
313
314
315
	convertDynamics cinp letje=:{let_strict_binds, let_lazy_binds, let_expr, let_info_ptr} ci
		# (let_strict_binds, ci) = convertDynamics cinp let_strict_binds ci
		  (let_lazy_binds, ci) = convertDynamics cinp let_lazy_binds ci
		  (let_expr,  ci) = convertDynamics cinp let_expr  ci
		  letje = {letje &  let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
316
317
318
319
		= (letje, ci)

instance convertDynamics Case where
	convertDynamics cinp kees=:{case_expr, case_guards, case_default} ci
320
321
322
		# (case_expr, ci) = convertDynamics cinp case_expr ci
		# (case_default, ci) = convertDynamics cinp case_default ci
		# kees = {kees & case_expr=case_expr, case_default=case_default}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
323
		= case case_guards of
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
324
325
			DynamicPatterns alts
				->	convertDynamicCase cinp kees ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
326
			_
327
				# (case_guards, ci) = convertDynamics cinp case_guards ci
328
				# kees = {kees & case_explicit=False, case_guards=case_guards}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
329
330
331
332
				->	(kees, ci)

instance convertDynamics CasePatterns where
	convertDynamics cinp (BasicPatterns type alts) ci
333
334
		# (alts, ci) = convertDynamics cinp alts ci
		= (BasicPatterns type alts, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
335
	convertDynamics cinp (AlgebraicPatterns type alts) ci
336
337
		# (alts, ci) = convertDynamics cinp alts ci
		= (AlgebraicPatterns type alts, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
338
	convertDynamics cinp (OverloadedListPatterns type decons alts) ci
339
340
		# (alts, ci) = convertDynamics cinp alts ci
		= (OverloadedListPatterns type decons alts, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
341
342
343

convertDynamic cinp=:{cinp_dynamic_representation={dr_type_ident}}
					{dyn_expr, dyn_type_code} ci
344
	# (dyn_expr, ci) = convertDynamics cinp dyn_expr ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
345
346
347
	# (dyn_type_code, ci)
		=	convertExprTypeCode cinp dyn_type_code ci
	=	(App {	app_symb		= dr_type_ident,
348
				app_args 		= [dyn_expr, dyn_type_code],
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
349
				app_info_ptr	= nilPtr }, ci)
350

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
351
352
convertDynamicCase cinp=:{cinp_dynamic_representation={dr_dynamic_symbol, dr_dynamic_type}}
			kees=:{case_guards=DynamicPatterns alts, case_info_ptr, case_default} ci
353
354
355
356
357
	# (value_var, ci) = newVariable "value" VI_Empty ci
	# (type_var, ci) = newVariable "type" VI_Empty ci
	# ci = {ci & ci_new_variables = [varToFreeVar value_var 1, varToFreeVar type_var 1 : ci.ci_new_variables ]}

	# (result_type, ci) = getResultType case_info_ptr ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
358
359
360
361
362
363
364
365
366
367
	# (matches, ci)
		=	case convertDynamicAlts cinp kees type_var value_var result_type case_default alts ci of
				(Yes matches, ci) -> (matches, ci)
				_ -> abort "where are those converted dynamics?"
	# match =
		{	ap_symbol	= dr_dynamic_symbol
		,	ap_vars		= [varToFreeVar value_var 1, varToFreeVar type_var 1]
		,	ap_expr		= matches
		,	ap_position	= position alts
		}
368
	# (case_info_ptr, ci) = dummy_case_ptr result_type ci
369
370
	# kees = {kees & case_explicit=False, case_guards=AlgebraicPatterns dr_dynamic_type [match],
					 case_default=No, case_info_ptr=case_info_ptr}
371
	= (kees, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
372
373
374
375
376
377
378
379
380
381

convertDynamicAlts _ _ _ _ _ defoult [] ci
	=	(defoult, ci)
convertDynamicAlts cinp kees type_var value_var result_type defoult [{dp_rhs, dp_position, dp_type_code, dp_var}:alts] ci
	# (type_code, binds, ci)
		=	convertPatternTypeCode cinp dp_type_code ci

	#  (unify_symb, ci) 
		=	getSymbol PD_Dyn_unify SK_Function (extended_unify_and_coerce 3 4) /*3 was 2 */ ci

382
	# unify_call = App {app_symb = unify_symb, app_args = [Var cinp.cinp_subst_var,Var type_var,type_code], app_info_ptr = nilPtr}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
383
384

	// FIXME, more precise types (not all TEs)
385
386
387
388
389
390
391
392
	# (let_info_ptr, ci) = let_ptr (/* 4 */ 3+length binds) ci

	  (unify_result_var, ci) = newVariable "result" VI_Empty ci
	  unify_result_fv = varToFreeVar unify_result_var 1
	  (unify_bool_var, ci) = newVariable "unify_bool" VI_Empty ci
	  unify_bool_fv = varToFreeVar unify_bool_var 1
	  (unify_subst_var, ci) = newVariable "unify_subst" VI_Empty ci
	  unify_subst_fv = varToFreeVar unify_subst_var 1
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
393
394
395
396

	# ci_var_heap = writePtr dp_var.fv_info_ptr (VI_DynamicValueAlias value_var) ci.ci_var_heap
	# ci = {ci & ci_var_heap = ci_var_heap}

397
	# (dp_rhs, ci) = convertDynamics {cinp & cinp_subst_var=unify_subst_var} dp_rhs ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
398

399
400
	# (case_info_ptr, ci) = bool_case_ptr result_type ci
	# case_guards =	BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs, bp_position = dp_position}]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
401
	# (case_default, ci)
402
		=	convertDynamicAlts cinp kees type_var value_var result_type defoult alts ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
403

404
405
	# kees = {kees & case_info_ptr=case_info_ptr, case_guards=case_guards,
					 case_default=case_default, case_explicit=False, case_expr=Var unify_bool_var}
406

407
	# ci = {ci & ci_new_variables = [unify_result_fv, unify_bool_fv, unify_subst_fv : ci.ci_new_variables ]}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
408

409
	  (twotuple, ci) = getTupleSymbol 2 ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
410
411
412
413
414
415
416

	  letje
		=	{	let_strict_binds = [{ lb_src =  unify_call,
		  							   lb_dst = unify_result_fv, lb_position = NoPos },
		  							{ lb_src =  TupleSelect twotuple 0 (Var unify_result_var),
		  							   lb_dst = unify_bool_fv, lb_position = NoPos }]
		  	,	let_lazy_binds = [ // { lb_src = Var value_var, lb_dst = dp_var, lb_position = NoPos },
417
								  	{ lb_src = TupleSelect twotuple 1 (Var unify_result_var),
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
418
419
420
421
422
423
		  							   lb_dst = unify_subst_fv, lb_position = NoPos }] ++ binds
			,	let_info_ptr = let_info_ptr
			,	let_expr = Case kees
			,	let_expr_position = NoPos // FIXME, add correct position
			} 

424
	= (Yes (Let letje), ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439

class position a :: a -> Position

instance position [a] | position a where
	position []
		=	NoPos
	position [h:_]
		=	position h

instance position DynamicPattern where
	position {dp_position}
		=	dp_position

instance convertDynamics BasicPattern where
	convertDynamics cinp alt=:{bp_expr} ci
440
		# (bp_expr, ci) = convertDynamics cinp bp_expr ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
441
442
443
444
		= ({alt & bp_expr=bp_expr}, ci)

instance convertDynamics AlgebraicPattern where
	convertDynamics cinp alt=:{ap_expr} ci
445
		# (ap_expr, ci) = convertDynamics cinp ap_expr ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
446
447
448
449
		=	({alt & ap_expr=ap_expr}, ci)

instance convertDynamics Selection where
	convertDynamics cinp selection=:(RecordSelection _ _) ci
450
		= (selection, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
451
	convertDynamics cinp (ArraySelection selector expr_ptr expr) ci
452
453
		# (expr, ci) = convertDynamics cinp expr ci
		= (ArraySelection selector expr_ptr expr, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
454
	convertDynamics cinp (DictionarySelection var selectors expr_ptr expr) ci
455
456
		# (expr, ci) = convertDynamics cinp expr ci
		= (DictionarySelection var selectors expr_ptr expr, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
457
458
459
460
461

convertExprTypeCode
	::	!ConversionInput !TypeCodeExpression !*ConversionState
	->	(!Expression, !*ConversionState)
convertExprTypeCode cinp tce ci
462
463
	# (type_code, (has_var, binds, ci))
		=	convertTypeCode False cinp tce (False, [], ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
464
465
466
467
	// sanity check ...
	| not (isEmpty binds)
		=	abort "unexpected binds in expression type code"
	// ... sanity check	
468
469
470
471
472
473
474
475
476
	| has_var
		# (normalise_symb, ci) 
			=	getSymbol PD_Dyn_normalise SK_Function 2 ci
		# type_code
			=	App { app_symb = normalise_symb,
					app_args = [ Var cinp.cinp_subst_var, type_code],  app_info_ptr = nilPtr }
		=	(type_code, ci)
	// otherwise
		=	(type_code, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
477
478
479
480

convertPatternTypeCode :: !ConversionInput !TypeCodeExpression !*ConversionState
										-> (!Expression, ![LetBind], !*ConversionState)
convertPatternTypeCode cinp tce ci
481
	# (type_code, (_, binds, ci)) = convertTypeCode True cinp tce (False, [], ci)
482
	=	(type_code, binds, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
483

484
convertTypeCode :: !Bool !ConversionInput !TypeCodeExpression (!Bool, ![LetBind], !*ConversionState)
485
											-> (!Expression, !(!Bool, ![LetBind], !*ConversionState))
486
convertTypeCode pattern _ (TCE_Var var_info_ptr) (has_var, binds, ci=:{ci_var_heap})
487
488
	# (var_info, ci_var_heap) = readPtr var_info_ptr ci_var_heap
	  ci =  {ci & ci_var_heap = ci_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
489
	=	case var_info of
490
491
492
493
			VI_TypeCodeVariable (TCI_TypeVar tv)
				->	(tv, (has_var, binds, ci))
			VI_TypeCodeVariable (TCI_TypePatternVar tpv)
				->	(tpv, (True, binds, ci))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
494
			_
495
496
				# (expr, ci) = createTypePatternVariable ci
				# ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_TypePatternVar expr)) ci.ci_var_heap}
497
498
				->	(expr, (True, binds, ci))
convertTypeCode pattern _ (TCE_TypeTerm var_info_ptr) (has_var, binds, ci=:{ci_var_heap})
499
500
	# (var_info, ci_var_heap) = readPtr var_info_ptr ci_var_heap
	  ci = {ci & ci_var_heap = ci_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
501
	=	case var_info of
502
503
504
505
506
			VI_TypeCodeVariable (TCI_TypeVar tv)
				->	(tv, (has_var, binds, ci))
			VI_TypeCodeVariable (TCI_TypePatternVar tpv)
				->	(tpv, (True, binds, ci))
			_
507
508
				# (expr, ci) = createTypePatternVariable ci
				# ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_TypePatternVar expr)) ci.ci_var_heap}
509
510
511
				->	(expr, (True, binds, ci))

convertTypeCode pattern cinp (TCE_App t arg) (has_var, binds, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
512
513
	# (typeapp_symb, ci)
		=	getSymbol PD_Dyn_TypeApp SK_Constructor 2 ci
514
515
516
517
	# (typecode_t, st)
	  	=	convertTypeCode pattern cinp t (has_var, binds, ci)
	# (typecode_arg, st)
	  	=	convertTypeCode pattern cinp arg st
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
518
	= (App {app_symb		= typeapp_symb,
519
520
			app_args 		= [typecode_t, typecode_arg],
			app_info_ptr	= nilPtr}, st)
521
convertTypeCode pattern cinp (TCE_Constructor cons []) (has_var, binds, ci)
522
523
524
	# (typecons_symb, ci)
		=	getSymbol PD_Dyn_TypeCons SK_Constructor 1 ci
	# (constructor, ci)
525
		=	typeConstructor cons ci
526
527
528
	= (App {app_symb		= typecons_symb,
			app_args 		= [constructor],
			app_info_ptr	= nilPtr}, (has_var, binds, ci))
529
where
530
531
532
	constructorExp :: Index ((Global Index) -> SymbKind) Int !*ConversionState
		-> (Expression, !*ConversionState)
	constructorExp index symb_kind arity ci
533
		# (cons_ident, ci)
534
			=	getSymbol index symb_kind arity ci
535
		=	(App {app_symb = cons_ident, app_args = [], app_info_ptr = nilPtr}, ci)
536
		
537
538
539
540
541
542
543
544
545
546
547
	typeConstructor (GTT_PredefTypeConstructor {glob_object=type_index}) ci
		| PD_Arity2TupleTypeIndex <= type_index && type_index <= PD_Arity32TupleTypeIndex
			# arity
				=	type_index - PD_Arity2TupleTypeIndex + 2
			# (tuple_symb, ci)
				=	getSymbol PD_Dyn_TypeCodeConstructor_Tuple SK_Function 1 ci 
			=	(App {app_symb = tuple_symb, app_args = [BasicExpr (BVInt arity)], app_info_ptr = nilPtr}, ci)
		// otherwise
			# predef_type_index
				=	type_index + FirstTypePredefinedSymbolIndex
			=	constructorExp (predefinedTypeConstructor predef_type_index) SK_Function 0 ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
548
	typeConstructor (GTT_Constructor fun_ident) ci
549
550
551
552
		# type_fun
			=	App {app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr}
		# (to_tc_symb, ci)
			=	getSymbol PD_Dyn__to_TypeCodeConstructor SK_Function 2 ci 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
553
		=	(App {app_symb = to_tc_symb, app_args = [type_fun], app_info_ptr = nilPtr}, ci)
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
	typeConstructor (GTT_Basic basic_type) ci
		=	constructorExp (basicTypeConstructor basic_type) SK_Function 0 ci
	typeConstructor GTT_Function ci
		=	constructorExp PD_Dyn_TypeCodeConstructor_Arrow SK_Function 0 ci

	basicTypeConstructor BT_Int
		=	PD_Dyn_TypeCodeConstructorInt
	basicTypeConstructor BT_Char	
		=	PD_Dyn_TypeCodeConstructorChar
	basicTypeConstructor BT_Real	
		=	PD_Dyn_TypeCodeConstructorReal
	basicTypeConstructor BT_Bool	
		=	PD_Dyn_TypeCodeConstructorBool
	basicTypeConstructor BT_Dynamic	
		=	PD_Dyn_TypeCodeConstructorDynamic
	basicTypeConstructor BT_File	
		=	PD_Dyn_TypeCodeConstructorFile
	basicTypeConstructor BT_World	
		=	PD_Dyn_TypeCodeConstructorWorld
573
	
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
	predefinedTypeConstructor predef_type_index
		| predef_type_index == PD_ListType
			=	PD_Dyn_TypeCodeConstructor_List
		| predef_type_index == PD_StrictListType
			=	PD_Dyn_TypeCodeConstructor_StrictList
		| predef_type_index == PD_UnboxedListType
			=	PD_Dyn_TypeCodeConstructor_UnboxedList
		| predef_type_index == PD_TailStrictListType
			=	PD_Dyn_TypeCodeConstructor_TailStrictList
		| predef_type_index == PD_StrictTailStrictListType
			=	PD_Dyn_TypeCodeConstructor_StrictTailStrictList
		| predef_type_index == PD_UnboxedTailStrictListType
			=	PD_Dyn_TypeCodeConstructor_UnboxedTailStrictList
		| predef_type_index == PD_LazyArrayType
			=	PD_Dyn_TypeCodeConstructor_LazyArray
		| predef_type_index == PD_StrictArrayType
			=	PD_Dyn_TypeCodeConstructor_StrictArray
		| predef_type_index == PD_UnboxedArrayType
			=	PD_Dyn_TypeCodeConstructor_UnboxedArray
		// otherwise
			=	fatal "predefinedType" "TC code from predef"
595
convertTypeCode pattern cinp (TCE_Constructor cons args) st
596
	# curried_type
597
		=	foldl TCE_App (TCE_Constructor cons []) args
598
599
	=	convertTypeCode pattern cinp curried_type st
convertTypeCode pattern cinp (TCE_UniType uni_vars type_code) (has_var, binds, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
600
		# (tv_symb, ci)
601
			=	getSymbol (if pattern PD_Dyn__TypeFixedVar PD_Dyn_TypeVar) SK_Constructor 1 ci
602
		# init_count
603
			=	if pattern ci.ci_type_var_count ci.ci_type_pattern_var_count
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
604
		# (count, ci_var_heap)
605
			=	foldSt (mark_uni_var pattern (build_tv tv_symb)) uni_vars (init_count, ci.ci_var_heap)
606
		# ci
607
608
609
610
			=	{	ci
				&	ci_type_var_count = if pattern count ci.ci_type_var_count
				,	ci_type_pattern_var_count = if pattern ci.ci_type_pattern_var_count count
				,	ci_var_heap = ci_var_heap}
611
612
		# (type_code, (has_var, binds, ci))
	  		=	convertTypeCode pattern cinp type_code (has_var, binds, ci)
613
	  	| count > init_count
614
615
616
			# (type_scheme_sym, ci)
				=	getSymbol PD_Dyn_TypeScheme SK_Constructor 2 ci
			=	(App {	app_symb = type_scheme_sym,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
617
618
							app_args = [BasicExpr (BVInt (count - init_count)), type_code],
							app_info_ptr = nilPtr }, (has_var || init_count <> 0, binds, ci))
619
620
621
622
623
624
		// otherwise
			=	(type_code, (has_var, binds, ci))

		where
			mark_uni_var :: Bool (Int -> Expression) VarInfoPtr (Int, *VarHeap) -> (Int, *VarHeap)
			mark_uni_var pattern build_var_code var_info_ptr (count, var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
625
626
				# var_info
					=	VI_TypeCodeVariable (TCI_TypeVar (build_var_code count))
627
				=	(count + (if pattern -1 1), writePtr var_info_ptr var_info var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
628
629
630
631
632
633

			build_tv :: SymbIdent Int -> Expression
			build_tv tv_symb number
				=	App {	app_symb = tv_symb,
							app_args = [BasicExpr (BVInt number)],
							app_info_ptr = nilPtr }
634
635
636
637
638
639
640
641
convertTypeCode pattern cinp (TCE_UnqType type) (has_var, binds, ci)
	# (typeunique_symb, ci)
		=	getSymbol PD_Dyn_TypeUnique SK_Constructor 1 ci
	# (type, (has_var, binds, ci))
		=	convertTypeCode pattern cinp type (has_var, binds, ci)
	= (App {app_symb		= typeunique_symb,
			app_args 		= [type],
			app_info_ptr	= nilPtr}, (has_var, binds, ci))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
642

643
convertTypeCode pattern cinp (TCE_Selector selections var_info_ptr) st
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
  #	(has_var, binds, ci) = st
	(var_info, ci_var_heap) = readPtr var_info_ptr ci.ci_var_heap
	ci = {ci & ci_var_heap = ci_var_heap}
  =	case var_info of
		VI_TypeCodeVariable (TCI_TypeVar tv)
			-> abort "convertTypeCode TCE_Selector"
		VI_TypeCodeVariable (TCI_TypePatternVar tpv)
			-> abort "convertTypeCode TCE_Selector"
		VI_TypeCodeVariable (TCI_SelectionsTypePatternVar tc_selections)
			# (var, ci) = createTypePatternVariable ci
			  tc_selections = [(var,selections):tc_selections]
			  ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_SelectionsTypePatternVar tc_selections)) ci.ci_var_heap}
		  	-> (var, (True, binds, ci))
		_
			# (var, ci) = createTypePatternVariable ci
			  tc_selections = [(var,selections)]
			  ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_SelectionsTypePatternVar tc_selections)) ci.ci_var_heap}
			-> (var, (True, binds, ci))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
662
663
664
665

createTypePatternVariable :: !*ConversionState -> (!Expression, !*ConversionState)
createTypePatternVariable ci
	# (tpv_symb, ci)
666
667
//		=	getSymbol PD_Dyn_TypePatternVar SK_Constructor 1 ci
		=	getSymbol PD_Dyn_TypeVar SK_Constructor 1 ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
668
669
670
671
	=	(App {	app_symb = tpv_symb,
						app_args = [BasicExpr (BVInt ci.ci_type_pattern_var_count)],
						app_info_ptr = nilPtr },
		{ci & ci_type_pattern_var_count = ci.ci_type_pattern_var_count + 1})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
672
673
674

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

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
675
newVariable :: String !VarInfo !*ConversionState -> *(!BoundVar,!*ConversionState)
676
newVariable var_ident var_info ci=:{ci_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
677
	# (var_info_ptr, ci_var_heap) = newPtr var_info ci_var_heap
678
	= ( { var_ident = {id_name = var_ident, id_info = nilPtr},  var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
679
680
681
	    { ci & ci_var_heap = ci_var_heap })	

varToFreeVar :: BoundVar Int -> FreeVar
682
683
varToFreeVar {var_ident, var_info_ptr} count
	= {fv_def_level = NotALevel, fv_ident = var_ident, fv_info_ptr = var_info_ptr, fv_count = count}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
684
685

freeVarToVar ::  FreeVar -> BoundVar
686
687
freeVarToVar {fv_ident, fv_info_ptr}
	= { var_ident = fv_ident,  var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
688
689


Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
690
getResultType :: ExprInfoPtr !*ConversionState -> (!AType, !*ConversionState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
691
692
693
694
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})

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
695
getSymbol :: Index ((Global Index) -> SymbKind) Int !*ConversionState -> (SymbIdent, !*ConversionState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
696
getSymbol index symb_kind arity ci=:{ci_predef_symb}
697
698
	# ({pds_module, pds_def}, ci_predef_symb) = ci_predef_symb![index]
	# pds_ident = predefined_idents.[index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
699
	  ci = {ci & ci_predef_symb = ci_predef_symb}
700
	  symbol = { symb_ident = pds_ident, symb_kind = symb_kind { glob_module = pds_module, glob_object = pds_def} }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
701
702
703
	= (symbol, ci)

getTupleSymbol arity ci=:{ci_predef_symb}
704
705
	# ({pds_def}, ci_predef_symb) = ci_predef_symb![GetTupleConsIndex arity]
	# pds_ident = predefined_idents.[GetTupleConsIndex arity]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
706
707
708
    = ( {ds_ident = pds_ident, ds_arity = arity, ds_index = pds_def}, {ci & ci_predef_symb = ci_predef_symb })

a_ij_var_name :== { id_name = "a_ij", id_info = nilPtr }
Martijn Vervoort's avatar
Martijn Vervoort committed
709

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
710
bool_case_ptr :: !AType !*ConversionState -> (ExprInfoPtr, !*ConversionState)
711
bool_case_ptr result_type ci=:{ci_expr_heap}
712
	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_CaseType {	ct_pattern_type = toAType (TB BT_Bool),
713
															ct_result_type = result_type, //empty_attributed_type,
714
715
716
															ct_cons_types = [[toAType (TB BT_Bool)]]}) ci_expr_heap
	= (expr_info_ptr, {ci &  ci_expr_heap = ci_expr_heap})

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
717
718
dummy_case_ptr :: !AType !*ConversionState -> (ExprInfoPtr, !*ConversionState)
dummy_case_ptr result_type ci=:{ci_expr_heap}
719
	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_CaseType {	ct_pattern_type = toAType TE,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
720
721
722
723
															ct_result_type = result_type, //empty_attributed_type,
															ct_cons_types = [[empty_attributed_type, empty_attributed_type]]}) ci_expr_heap
	= (expr_info_ptr, {ci &  ci_expr_heap = ci_expr_heap})

724

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
725
let_ptr :: !Int !*ConversionState -> (ExprInfoPtr, !*ConversionState)
726
let_ptr nr_of_binds ci=:{ci_expr_heap}
727
728
	= let_ptr2 (repeatn nr_of_binds empty_attributed_type) ci

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
729
730
731
typed_let_ptr :: TypeSymbIdent !*ConversionState -> (ExprInfoPtr, !*ConversionState)
typed_let_ptr type_id ci=:{ci_expr_heap}
	= let_ptr2 [toAType (TA type_id [])] ci
732

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
733
let_ptr2 :: [AType] !*ConversionState -> (ExprInfoPtr, !*ConversionState)
734
735
let_ptr2 let_types ci=:{ci_expr_heap}
	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_LetType let_types) ci_expr_heap
736
737
738
	= (expr_info_ptr, {ci &  ci_expr_heap = ci_expr_heap})

toAType :: Type -> AType
739
toAType type = { at_attribute = TA_Multi, at_type = type }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
740
741

empty_attributed_type :: AType
742
empty_attributed_type = toAType TE
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
743

744
instance <<< (Ptr a)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
745
746
747
where
	(<<<) file ptr = file <<< ptrToInt ptr  

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764

create_dynamic_and_selector_idents common_defs predefined_symbols 
	| predefined_symbols.[PD_StdDynamic].pds_module == NoIndex
		=	({	dr_type_ident		= undef
			,	dr_dynamic_type		= undef
			,	dr_dynamic_symbol	= undef
			},predefined_symbols)
	// otherwise	
		# ({pds_module=pds_module1, pds_def=pds_def1} , predefined_symbols) = predefined_symbols![PD_Dyn_DynamicTemp]
		# {td_rhs=RecordType {rt_constructor,rt_fields}} = common_defs.[pds_module1].com_type_defs.[pds_def1]
	
		# dynamic_defined_symbol
			= {glob_module = pds_module1, glob_object = rt_constructor}
		# dynamic_type = {glob_module = pds_module1, glob_object = pds_def1}

		# dynamic_temp_symb_ident
			= { SymbIdent |
765
				symb_ident	= rt_constructor.ds_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
766
767
768
769
770
771
772
			,	symb_kind 	= SK_Constructor {glob_module = pds_module1, glob_object = rt_constructor.ds_index} 
			}
		= ({	dr_type_ident		= dynamic_temp_symb_ident
			,	dr_dynamic_type		= dynamic_type
			,	dr_dynamic_symbol	= dynamic_defined_symbol
			}, predefined_symbols)