convertDynamics.icl 32.4 KB
Newer Older
1
/*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
2
	module owner: Ronny Wichers Schreur
3
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
4
5
implementation module convertDynamics

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
6
import syntax
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
7

8
from type_io_common import PredefinedModuleName
9
// Optional
10
extended_unify_and_coerce no yes :== no;	// change also _unify and _coerce in StdDynamic
Martijn Vervoort's avatar
Martijn Vervoort committed
11

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
12
import type_io;
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
13

14
15
16
17
:: TypeCodeVariableInfo = TCI_TypeVar !Expression
						| TCI_TypePatternVar !Expression
						| TCI_SelectionsTypePatternVar ![(Expression,[Selection])]

18
19
:: DynamicValueAliasInfo :== BoundVar

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
20
::	*ConversionState =
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
21
22
23
	{	ci_predef_symb		:: !*PredefinedSymbols
	,	ci_var_heap			:: !*VarHeap
	,	ci_expr_heap		:: !*ExpressionHeap
24
	,	ci_new_variables 	:: ![FreeVar]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
25
26

	,	ci_type_pattern_var_count	:: !Int	
27
	,	ci_type_var_count :: !Int
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
28
29
	}

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
30
31
32
33
34
35
:: DynamicRepresentation =
	{	dr_type_ident		:: SymbIdent
	,	dr_dynamic_type		:: Global Index
	,	dr_dynamic_symbol	:: Global DefinedSymbol
	}

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
36
::	ConversionInput =
37
	{	cinp_dynamic_representation	:: DynamicRepresentation
38
	,	cinp_st_args		:: ![FreeVar]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
39
	,	cinp_subst_var		:: !BoundVar
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
40
41
	}

42
43
44
fatal :: {#Char} {#Char} -> .a
fatal function_name message
	=	abort ("convertDynamics, " +++ function_name +++ ": " +++ message)
45

John van Groningen's avatar
John van Groningen committed
46
47
48
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
49
50
	# write_type_info_state2
		= { WriteTypeInfoState |
51
52
53
54
55
56
			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
57
	  	,	wtis_icl_generic_defs = icl_common.com_generic_defs
58
		};
59

60
	#! (tcl_file,write_type_info_state)
John van Groningen's avatar
John van Groningen committed
61
		= 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
62

63
64
	#! (tcl_file,write_type_info_state)
		= write_type_info directly_imported_dcl_modules tcl_file write_type_info_state
65

Martijn Vervoort's avatar
Martijn Vervoort committed
66
67
68
69
70
	#! (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
71
		 
Martijn Vervoort's avatar
Martijn Vervoort committed
72
73
	#! tcl_file
		= fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file
Martijn Vervoort's avatar
Martijn Vervoort committed
74
	#! tcl_file
75
76
77
78
	 	= 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
79
				
80
	= (True,tcl_file,type_heaps,predefined_symbols,imported_types,var_heap) 
81
where
82
83
	f write_type_info_state=:{wtis_type_heaps,wtis_type_defs,wtis_var_heap}
		= (wtis_type_heaps,wtis_type_defs,wtis_var_heap)
84

John van Groningen's avatar
John van Groningen committed
85
convertDynamicPatternsIntoUnifyAppls :: !{# CommonDefs} !Int  {#DclModule} !IclModule [String] !Int !Int
86
		!*{!Component} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap !(Optional *File)
John van Groningen's avatar
John van Groningen committed
87
	-> (!*{#{#CheckedTypeDef}},
88
		!*{!Component},!*{#FunDef},!*PredefinedSymbols,!*VarHeap,!*TypeHeaps,!*ExpressionHeap,!(Optional *File))
John van Groningen's avatar
John van Groningen committed
89
90
91
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
92
93
94
	#! (dynamic_representation,predefined_symbols)
		=	create_dynamic_and_selector_idents common_defs predefined_symbols

95
	# imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs }
96
97
	# (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
98
							ci_predef_symb = predefined_symbols, ci_var_heap = var_heap, ci_expr_heap = expr_heap,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
99
							ci_new_variables = [],
100
							ci_type_var_count = 0,
101
							ci_type_pattern_var_count = 0
102
103
104
							})
			
	// store type info			
105
	# (tcl_file,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
106
107
		= case tcl_file of
			No
108
				-> (No,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
109
			Yes tcl_file
110
				# (ok,tcl_file,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
John van Groningen's avatar
John van Groningen committed
111
112
113
					= 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
114
115
				| not ok
					-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
116
					-> (Yes tcl_file,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
117

John van Groningen's avatar
John van Groningen committed
118
	= (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
119
where
120
	convert_groups group_nr groups dynamic_representation fun_defs_and_ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
121
122
		| group_nr == size groups
			= (groups, fun_defs_and_ci)
123
			# (group, groups) = groups![group_nr]
124
125
126
127
128
129
130
131
			= 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
132

133
	convert_function group_nr dynamic_representation fun (fun_defs, ci)
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
134
135
136
137
		# (fun_def, fun_defs) = fun_defs![fun]
		  {fun_body, fun_type, fun_info} = fun_def
		| isEmpty fun_info.fi_dynamics
			= (fun_defs, ci)
138
139
140

			# (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
141
142
143
144

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

145
146
			= ({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
147
148
149
150
151
152
153
154
155

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
156
157
		# (x, ci) = convertDynamics cinp x ci
		= (Yes x, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
158
	convertDynamics _ No ci
159
		= (No, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
160
161
162

instance convertDynamics FunctionBody where
	convertDynamics cinp (TransformedBody body) ci
163
164
		# (body, ci) = convertDynamics cinp body ci
		= (TransformedBody body, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
165
166
167
168
169

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)
170
171
//		# ci_var_heap
//			=	foldSt mark_var tb_args ci_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
172
173
174
175
176
177
178
179
		# (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
180
181
182
//			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
183
184

			collect_global_type_pattern_var :: FreeVar ([LetBind], BoundVar, *ConversionState) -> ([LetBind], BoundVar, *ConversionState)
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
			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
216
217
218

			share_init_subst :: BoundVar [LetBind] Expression *ConversionState
					-> (Expression, *ConversionState)
219
			share_init_subst subst global_tpv_binds rhs ci=:{ci_type_pattern_var_count, ci_type_var_count}
220
				#  (initial_unifier_symb, ci)
221
					=	getSymbol PD_Dyn_initial_unification_environment SK_Function 2 ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
222
223
224

				# let_bind_initial_subst
					= { lb_src = App {	app_symb		= initial_unifier_symb,
225
226
										app_args 		=
												[	BasicExpr (BVInt ci_type_pattern_var_count)
227
												,	BasicExpr (BVInt ci_type_var_count)
228
												],
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
229
230
231
232
										app_info_ptr	= nilPtr }
					,	lb_dst =  varToFreeVar subst 1
					,	lb_position = NoPos
					}
233
234
235
				# 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
236
237
238
239
240
241
242
243
244
245
246
				# 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
247
248
		# (lb_src, ci) = convertDynamics cinp lb_src ci
		= ({binding &  lb_src = lb_src}, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
249
250
251

instance convertDynamics (Bind a b) | convertDynamics a where
	convertDynamics cinp binding=:{bind_src} ci
252
253
		# (bind_src, ci) = convertDynamics cinp bind_src ci
		= ({binding &  bind_src = bind_src}, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
254
255
256

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

instance convertDynamics App where
	convertDynamics cinp app=:{app_args} ci
315
		# (app_args,ci) = convertDynamics cinp app_args ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
316
317
318
		=	({app & app_args = app_args}, ci)

instance convertDynamics Let where
319
320
321
322
323
	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
324
325
326
327
		= (letje, ci)

instance convertDynamics Case where
	convertDynamics cinp kees=:{case_expr, case_guards, case_default} ci
328
329
330
		# (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
331
		= case case_guards of
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
332
333
			DynamicPatterns alts
				->	convertDynamicCase cinp kees ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
334
			_
335
				# (case_guards, ci) = convertDynamics cinp case_guards ci
336
				# kees = {kees & case_explicit=False, case_guards=case_guards}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
337
338
339
340
				->	(kees, ci)

instance convertDynamics CasePatterns where
	convertDynamics cinp (BasicPatterns type alts) ci
341
342
		# (alts, ci) = convertDynamics cinp alts ci
		= (BasicPatterns type alts, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
343
	convertDynamics cinp (AlgebraicPatterns type alts) ci
344
345
		# (alts, ci) = convertDynamics cinp alts ci
		= (AlgebraicPatterns type alts, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
346
	convertDynamics cinp (OverloadedListPatterns type decons alts) ci
347
348
		# (alts, ci) = convertDynamics cinp alts ci
		= (OverloadedListPatterns type decons alts, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
349
350
351

convertDynamic cinp=:{cinp_dynamic_representation={dr_type_ident}}
					{dyn_expr, dyn_type_code} ci
352
	# (dyn_expr, ci) = convertDynamics cinp dyn_expr ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
353
354
355
	# (dyn_type_code, ci)
		=	convertExprTypeCode cinp dyn_type_code ci
	=	(App {	app_symb		= dr_type_ident,
356
				app_args 		= [dyn_expr, dyn_type_code],
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
357
				app_info_ptr	= nilPtr }, ci)
358

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
359
360
convertDynamicCase cinp=:{cinp_dynamic_representation={dr_dynamic_symbol, dr_dynamic_type}}
			kees=:{case_guards=DynamicPatterns alts, case_info_ptr, case_default} ci
361
362
363
364
365
	# (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
366
367
368
369
370
371
372
373
374
375
	# (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
		}
376
	# (case_info_ptr, ci) = dummy_case_ptr result_type ci
377
378
	# kees = {kees & case_explicit=False, case_guards=AlgebraicPatterns dr_dynamic_type [match],
					 case_default=No, case_info_ptr=case_info_ptr}
379
	= (kees, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
380
381
382
383
384
385
386
387
388
389

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

390
	# 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
391
392

	// FIXME, more precise types (not all TEs)
393
394
395
396
397
398
399
400
	# (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
401
402
403
404

	# 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}

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

407
408
	# (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
409
	# (case_default, ci)
410
		=	convertDynamicAlts cinp kees type_var value_var result_type defoult alts ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
411

412
413
	# 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}
414

415
	# 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
416

417
	  (twotuple, ci) = getTupleSymbol 2 ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
418
419
420
421
422
423
424

	  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 },
425
								  	{ lb_src = TupleSelect twotuple 1 (Var unify_result_var),
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
426
427
428
429
430
431
		  							   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
			} 

432
	= (Yes (Let letje), ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447

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
448
		# (bp_expr, ci) = convertDynamics cinp bp_expr ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
449
450
451
452
		= ({alt & bp_expr=bp_expr}, ci)

instance convertDynamics AlgebraicPattern where
	convertDynamics cinp alt=:{ap_expr} ci
453
		# (ap_expr, ci) = convertDynamics cinp ap_expr ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
454
455
456
457
		=	({alt & ap_expr=ap_expr}, ci)

instance convertDynamics Selection where
	convertDynamics cinp selection=:(RecordSelection _ _) ci
458
		= (selection, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
459
	convertDynamics cinp (ArraySelection selector expr_ptr expr) ci
460
461
		# (expr, ci) = convertDynamics cinp expr ci
		= (ArraySelection selector expr_ptr expr, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
462
	convertDynamics cinp (DictionarySelection var selectors expr_ptr expr) ci
463
464
		# (expr, ci) = convertDynamics cinp expr ci
		= (DictionarySelection var selectors expr_ptr expr, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
465
466
467
468
469

convertExprTypeCode
	::	!ConversionInput !TypeCodeExpression !*ConversionState
	->	(!Expression, !*ConversionState)
convertExprTypeCode cinp tce ci
470
471
	# (type_code, (has_var, binds, ci))
		=	convertTypeCode False cinp tce (False, [], ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
472
473
474
475
	// sanity check ...
	| not (isEmpty binds)
		=	abort "unexpected binds in expression type code"
	// ... sanity check	
476
477
478
479
480
481
482
483
484
	| 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
485
486
487
488

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

492
convertTypeCode :: !Bool !ConversionInput !TypeCodeExpression (!Bool, ![LetBind], !*ConversionState)
493
											-> (!Expression, !(!Bool, ![LetBind], !*ConversionState))
494
convertTypeCode pattern _ (TCE_Var var_info_ptr) (has_var, binds, ci=:{ci_var_heap})
495
496
	# (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
497
	=	case var_info of
498
499
500
501
			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
502
			_
503
504
				# (expr, ci) = createTypePatternVariable ci
				# ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_TypePatternVar expr)) ci.ci_var_heap}
505
506
				->	(expr, (True, binds, ci))
convertTypeCode pattern _ (TCE_TypeTerm var_info_ptr) (has_var, binds, ci=:{ci_var_heap})
507
508
	# (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
509
	=	case var_info of
510
511
512
513
514
			VI_TypeCodeVariable (TCI_TypeVar tv)
				->	(tv, (has_var, binds, ci))
			VI_TypeCodeVariable (TCI_TypePatternVar tpv)
				->	(tpv, (True, binds, ci))
			_
515
516
				# (expr, ci) = createTypePatternVariable ci
				# ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_TypePatternVar expr)) ci.ci_var_heap}
517
518
519
				->	(expr, (True, binds, ci))

convertTypeCode pattern cinp (TCE_App t arg) (has_var, binds, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
520
521
	# (typeapp_symb, ci)
		=	getSymbol PD_Dyn_TypeApp SK_Constructor 2 ci
522
523
524
525
	# (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
526
	= (App {app_symb		= typeapp_symb,
527
528
			app_args 		= [typecode_t, typecode_arg],
			app_info_ptr	= nilPtr}, st)
529
convertTypeCode pattern cinp (TCE_Constructor cons []) (has_var, binds, ci)
530
531
532
	# (typecons_symb, ci)
		=	getSymbol PD_Dyn_TypeCons SK_Constructor 1 ci
	# (constructor, ci)
533
		=	typeConstructor cons ci
534
535
536
	= (App {app_symb		= typecons_symb,
			app_args 		= [constructor],
			app_info_ptr	= nilPtr}, (has_var, binds, ci))
537
where
538
539
540
	constructorExp :: Index ((Global Index) -> SymbKind) Int !*ConversionState
		-> (Expression, !*ConversionState)
	constructorExp index symb_kind arity ci
541
		# (cons_ident, ci)
542
			=	getSymbol index symb_kind arity ci
543
		=	(App {app_symb = cons_ident, app_args = [], app_info_ptr = nilPtr}, ci)
544
		
545
546
547
548
549
550
551
552
553
554
555
	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
556
	typeConstructor (GTT_Constructor fun_ident) ci
557
558
559
560
		# 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
561
		=	(App {app_symb = to_tc_symb, app_args = [type_fun], app_info_ptr = nilPtr}, ci)
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
	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
581
	
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
	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"
603
convertTypeCode pattern cinp (TCE_Constructor cons args) st
604
	# curried_type
605
		=	foldl TCE_App (TCE_Constructor cons []) args
606
607
	=	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
608
		# (tv_symb, ci)
609
			=	getSymbol (if pattern PD_Dyn__TypeFixedVar PD_Dyn_TypeVar) SK_Constructor 1 ci
610
		# init_count
611
			=	if pattern ci.ci_type_var_count ci.ci_type_pattern_var_count
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
612
		# (count, ci_var_heap)
613
			=	foldSt (mark_uni_var pattern (build_tv tv_symb)) uni_vars (init_count, ci.ci_var_heap)
614
		# ci
615
616
617
618
			=	{	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}
619
620
		# (type_code, (has_var, binds, ci))
	  		=	convertTypeCode pattern cinp type_code (has_var, binds, ci)
621
	  	| count > init_count
622
623
624
			# (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
625
626
							app_args = [BasicExpr (BVInt (count - init_count)), type_code],
							app_info_ptr = nilPtr }, (has_var || init_count <> 0, binds, ci))
627
628
629
630
631
632
		// 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
633
634
				# var_info
					=	VI_TypeCodeVariable (TCI_TypeVar (build_var_code count))
635
				=	(count + (if pattern -1 1), writePtr var_info_ptr var_info var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
636
637
638
639
640
641

			build_tv :: SymbIdent Int -> Expression
			build_tv tv_symb number
				=	App {	app_symb = tv_symb,
							app_args = [BasicExpr (BVInt number)],
							app_info_ptr = nilPtr }
642
643
644
645
646
647
648
649
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
650

651
convertTypeCode pattern cinp (TCE_Selector selections var_info_ptr) st
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
  #	(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
670
671
672
673

createTypePatternVariable :: !*ConversionState -> (!Expression, !*ConversionState)
createTypePatternVariable ci
	# (tpv_symb, ci)
674
675
//		=	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
676
677
678
679
	=	(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
680
681
682

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

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
683
newVariable :: String !VarInfo !*ConversionState -> *(!BoundVar,!*ConversionState)
684
newVariable var_ident var_info ci=:{ci_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
685
	# (var_info_ptr, ci_var_heap) = newPtr var_info ci_var_heap
686
	= ( { 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
687
688
689
	    { ci & ci_var_heap = ci_var_heap })	

varToFreeVar :: BoundVar Int -> FreeVar
690
691
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
692
693

freeVarToVar ::  FreeVar -> BoundVar
694
695
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
696
697


Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
698
getResultType :: ExprInfoPtr !*ConversionState -> (!AType, !*ConversionState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
699
700
701
702
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
703
getSymbol :: Index ((Global Index) -> SymbKind) Int !*ConversionState -> (SymbIdent, !*ConversionState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
704
getSymbol index symb_kind arity ci=:{ci_predef_symb}
705
706
	# ({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
707
	  ci = {ci & ci_predef_symb = ci_predef_symb}
708
	  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
709
710
711
	= (symbol, ci)

getTupleSymbol arity ci=:{ci_predef_symb}
712
713
	# ({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
714
715
716
    = ( {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
717

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
718
bool_case_ptr :: !AType !*ConversionState -> (ExprInfoPtr, !*ConversionState)
719
bool_case_ptr result_type ci=:{ci_expr_heap}
720
	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_CaseType {	ct_pattern_type = toAType (TB BT_Bool),
721
															ct_result_type = result_type, //empty_attributed_type,
722
723
724
															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
725
726
dummy_case_ptr :: !AType !*ConversionState -> (ExprInfoPtr, !*ConversionState)
dummy_case_ptr result_type ci=:{ci_expr_heap}
727
	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_CaseType {	ct_pattern_type = toAType TE,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
728
729
730
731
															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})

732

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
733
let_ptr :: !Int !*ConversionState -> (ExprInfoPtr, !*ConversionState)
734
let_ptr nr_of_binds ci=:{ci_expr_heap}
735
736
	= let_ptr2 (repeatn nr_of_binds empty_attributed_type) ci

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
737
738
739
typed_let_ptr :: TypeSymbIdent !*ConversionState -> (ExprInfoPtr, !*ConversionState)
typed_let_ptr type_id ci=:{ci_expr_heap}
	= let_ptr2 [toAType (TA type_id [])] ci
740

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
741
let_ptr2 :: [AType] !*ConversionState -> (ExprInfoPtr, !*ConversionState)
742
743
let_ptr2 let_types ci=:{ci_expr_heap}
	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_LetType let_types) ci_expr_heap
744
745
746
	= (expr_info_ptr, {ci &  ci_expr_heap = ci_expr_heap})

toAType :: Type -> AType
747
toAType type = { at_attribute = TA_Multi, at_type = type }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
748
749

empty_attributed_type :: AType
750
empty_attributed_type = toAType TE
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
751

752
instance <<< (Ptr a)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
753
754
755
where
	(<<<) file ptr = file <<< ptrToInt ptr  

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772

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 |
773
				symb_ident	= rt_constructor.ds_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
774
775
776
777
778
779
780
			,	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)