convertDynamics.icl 32.6 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
// Optional
7
extended_unify_and_coerce no yes :== no;	// change also _unify and _coerce in StdDynamic
Martijn Vervoort's avatar
Martijn Vervoort committed
8

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

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

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

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

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
	#! (tcl_file,write_type_info_state)
59
		= write_type_info {# id_name \\ {dcl_name={id_name}} <-: dcl_mods } tcl_file write_type_info_state
60
		 
Martijn Vervoort's avatar
Martijn Vervoort committed
61
62
	#! tcl_file
		= fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file
Martijn Vervoort's avatar
Martijn Vervoort committed
63
	#! tcl_file
64
65
66
67
	 	= 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
68
				
69
	= (True,tcl_file,type_heaps,predefined_symbols,imported_types,var_heap) 
70
where
71
72
	f write_type_info_state=:{wtis_type_heaps,wtis_type_defs,wtis_var_heap}
		= (wtis_type_heaps,wtis_type_defs,wtis_var_heap)
73

John van Groningen's avatar
John van Groningen committed
74
convertDynamicPatternsIntoUnifyAppls :: !{# CommonDefs} !Int  {#DclModule} !IclModule [String] !Int !Int
75
		!*{!Component} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap !(Optional *File)
John van Groningen's avatar
John van Groningen committed
76
	-> (!*{#{#CheckedTypeDef}},
77
		!*{!Component},!*{#FunDef},!*PredefinedSymbols,!*VarHeap,!*TypeHeaps,!*ExpressionHeap,!(Optional *File))
John van Groningen's avatar
John van Groningen committed
78
79
80
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
81
82
83
	#! (dynamic_representation,predefined_symbols)
		=	create_dynamic_and_selector_idents common_defs predefined_symbols

84
	# imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs }
85
86
	# (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
87
							ci_predef_symb = predefined_symbols, ci_var_heap = var_heap, ci_expr_heap = expr_heap,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
88
							ci_new_variables = [],
89
							ci_type_var_count = 0,
90
							ci_type_pattern_var_count = 0
91
92
93
							})
			
	// store type info			
94
	# (tcl_file,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
95
96
		= case tcl_file of
			No
97
				-> (No,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
98
			Yes tcl_file
99
				# (ok,tcl_file,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
John van Groningen's avatar
John van Groningen committed
100
101
102
					= 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
103
104
				| not ok
					-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
105
					-> (Yes tcl_file,type_heaps,ci_predef_symb,imported_types,ci_var_heap)
106

John van Groningen's avatar
John van Groningen committed
107
	= (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
108
where
109
	convert_groups group_nr groups dynamic_representation fun_defs_and_ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
110
111
		| group_nr == size groups
			= (groups, fun_defs_and_ci)
112
			# (group, groups) = groups![group_nr]
113
114
115
116
117
118
119
120
			= 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
121

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

			# (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
130
131
132
133

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

134
135
			= ({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
136
137
138
139
140
141
142
143
144

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
145
146
		# (x, ci) = convertDynamics cinp x ci
		= (Yes x, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
147
	convertDynamics _ No ci
148
		= (No, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
149
150
151

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

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)
159
160
//		# ci_var_heap
//			=	foldSt mark_var tb_args ci_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
161
162
163
164
165
166
167
168
		# (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
169
170
171
//			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
172
173

			collect_global_type_pattern_var :: FreeVar ([LetBind], BoundVar, *ConversionState) -> ([LetBind], BoundVar, *ConversionState)
174
175
176
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
			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
205
206
207

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

				# let_bind_initial_subst
					= { lb_src = App {	app_symb		= initial_unifier_symb,
214
215
										app_args 		=
												[	BasicExpr (BVInt ci_type_pattern_var_count)
216
												,	BasicExpr (BVInt ci_type_var_count)
217
												],
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
218
219
220
221
										app_info_ptr	= nilPtr }
					,	lb_dst =  varToFreeVar subst 1
					,	lb_position = NoPos
					}
222
223
224
				# 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
225
226
227
228
229
230
231
232
233
234
235
				# 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
236
237
		# (lb_src, ci) = convertDynamics cinp lb_src ci
		= ({binding &  lb_src = lb_src}, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
238
239
240

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

instance convertDynamics Expression where
	convertDynamics cinp (TypeCodeExpression tce) ci
246
247
		# (dyn_type_code, ci) = convertExprTypeCode cinp tce ci
		= (dyn_type_code, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
248
249
250
	convertDynamics cinp (Var var) ci
		# (info, ci_var_heap)
			=	readPtr var.var_info_ptr ci.ci_var_heap
251
		# ci = {ci & ci_var_heap = ci_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
252
253
254
255
256
257
		=	case (info, ci) of
				(VI_DynamicValueAlias value_var, ci)
					->	(Var value_var, ci)
				(_, ci)
					->	(Var var, ci)
	convertDynamics cinp (App app) ci
258
259
		# (app, ci) = convertDynamics cinp app ci
		= (App app, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
260
	convertDynamics cinp (expr @ exprs) ci
261
262
263
		# (expr, ci) = convertDynamics cinp expr  ci
		  (exprs, ci) = convertDynamics cinp exprs ci
		= (expr @ exprs, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
264
	convertDynamics cinp (Let letje) ci
265
266
		# (letje, ci) = convertDynamics cinp letje  ci
		= (Let letje, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
267
	convertDynamics cinp (Case kees) ci
268
269
		# (kees,  ci) = convertDynamics cinp kees  ci
		= (Case kees, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
270
	convertDynamics cinp (Selection opt_symb expression selections) ci
271
272
		# (expression,ci) = convertDynamics cinp expression ci
		# (selections,ci) = convertDynamics cinp selections ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
273
274
		=	(Selection opt_symb expression selections, ci)
	convertDynamics cinp (Update expression1 selections expression2) ci
275
276
277
		# (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
278
279
		=	(Update expression1 selections expression2, ci)
	convertDynamics cinp (RecordUpdate cons_symbol expression expressions) ci
280
281
282
		# (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
283
	convertDynamics cinp (TupleSelect definedSymbol int expression) ci
284
285
		# (expression, ci) = convertDynamics cinp expression ci
		= (TupleSelect definedSymbol int expression, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
286
	convertDynamics _ be=:(BasicExpr _) ci
287
		= (be, ci)
288
289
290
291
292
293
	convertDynamics cinp (MatchExpr symb expression) ci
		# (expression, ci) = convertDynamics cinp expression ci
		= (MatchExpr symb expression, ci)
	convertDynamics cinp (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) ci
		# (expr, ci) = convertDynamics cinp expr ci
		= (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
294
	convertDynamics _ code_expr=:(AnyCodeExpr _ _ _) ci
295
		= (code_expr, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
296
	convertDynamics _ code_expr=:(ABCCodeExpr _ _) ci
297
		= (code_expr, 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)
304
305
306
	convertDynamics cinp (DictionariesFunction dictionaries expr expr_type) ci
		# (expr,ci) = convertDynamics cinp expr ci
		= (DictionariesFunction dictionaries expr expr_type,ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
307
308
309

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

instance convertDynamics Let where
314
315
316
317
318
	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
319
320
321
322
		= (letje, ci)

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

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

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

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

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

385
	# 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
386
387

	// FIXME, more precise types (not all TEs)
388
389
390
391
392
393
394
395
	# (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
396
397
398
399

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

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

402
403
	# (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
404
	# (case_default, ci)
405
		=	convertDynamicAlts cinp kees type_var value_var result_type defoult alts ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
406

407
408
	# 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}
409

410
	# 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
411

412
	  (twotuple, ci) = getTupleSymbol 2 ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
413
414
415
416
417
418
419

	  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 },
420
								  	{ lb_src = TupleSelect twotuple 1 (Var unify_result_var),
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
421
422
423
424
425
426
		  							   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
			} 

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

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
443
		# (bp_expr, ci) = convertDynamics cinp bp_expr ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
444
445
446
447
		= ({alt & bp_expr=bp_expr}, ci)

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

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

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

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

487
convertTypeCode :: !Bool !ConversionInput !TypeCodeExpression (!Bool, ![LetBind], !*ConversionState)
488
											-> (!Expression, !(!Bool, ![LetBind], !*ConversionState))
489
convertTypeCode pattern _ (TCE_Var var_info_ptr) (has_var, binds, ci=:{ci_var_heap})
490
491
	# (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
492
	=	case var_info of
493
494
495
496
			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
497
			_
498
499
				# (expr, ci) = createTypePatternVariable ci
				# ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_TypePatternVar expr)) ci.ci_var_heap}
500
501
				->	(expr, (True, binds, ci))
convertTypeCode pattern _ (TCE_TypeTerm var_info_ptr) (has_var, binds, ci=:{ci_var_heap})
502
503
	# (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
504
	=	case var_info of
505
506
507
508
509
			VI_TypeCodeVariable (TCI_TypeVar tv)
				->	(tv, (has_var, binds, ci))
			VI_TypeCodeVariable (TCI_TypePatternVar tpv)
				->	(tpv, (True, binds, ci))
			_
510
511
				# (expr, ci) = createTypePatternVariable ci
				# ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_TypePatternVar expr)) ci.ci_var_heap}
512
513
				->	(expr, (True, binds, ci))
convertTypeCode pattern cinp (TCE_App t arg) (has_var, binds, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
514
515
	# (typeapp_symb, ci)
		=	getSymbol PD_Dyn_TypeApp SK_Constructor 2 ci
516
517
518
519
	# (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
520
	= (App {app_symb		= typeapp_symb,
521
522
			app_args 		= [typecode_t, typecode_arg],
			app_info_ptr	= nilPtr}, st)
523
convertTypeCode pattern {cinp_dynamic_representation} (TCE_Constructor cons []) (has_var, binds, ci)
524
525
526
	# (typecons_symb, ci)
		=	getSymbol PD_Dyn_TypeCons SK_Constructor 1 ci
	# (constructor, ci)
527
		=	typeConstructor cons ci
528
529
530
	= (App {app_symb		= typecons_symb,
			app_args 		= [constructor],
			app_info_ptr	= nilPtr}, (has_var, binds, ci))
531
where
532
533
534
	constructorExp :: Index ((Global Index) -> SymbKind) Int !*ConversionState
		-> (Expression, !*ConversionState)
	constructorExp index symb_kind arity ci
535
		# (cons_ident, ci)
536
			=	getSymbol index symb_kind arity ci
537
		=	(App {app_symb = cons_ident, app_args = [], app_info_ptr = nilPtr}, ci)
538
		
539
540
	typeConstructor (GTT_PredefTypeConstructor {glob_object=type_index}) ci
		| PD_Arity2TupleTypeIndex <= type_index && type_index <= PD_Arity32TupleTypeIndex
541
			= type_code_constructor_expression (type_index + (PD_TC__Tuple2 - PD_Arity2TupleTypeIndex)) ci
542
		// otherwise
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
			# predef_type_index = type_index + FirstTypePredefinedSymbolIndex
			= case predef_type_index of
				PD_ListType
					-> type_code_constructor_expression PD_TC__List ci
				PD_StrictListType
					-> type_code_constructor_expression PD_TC__StrictList ci
				PD_UnboxedListType
					-> type_code_constructor_expression PD_TC__UnboxedList ci
				PD_TailStrictListType
					-> type_code_constructor_expression PD_TC__TailStrictList ci
				PD_StrictTailStrictListType
					-> type_code_constructor_expression PD_TC__StrictTailStrictList	ci
				PD_UnboxedTailStrictListType
					-> type_code_constructor_expression PD_TC__UnboxedTailStrictList ci
				PD_LazyArrayType
					-> type_code_constructor_expression PD_TC__LazyArray ci
				PD_StrictArrayType
					-> type_code_constructor_expression PD_TC__StrictArray ci
				PD_UnboxedArrayType
					-> type_code_constructor_expression PD_TC__UnboxedArray ci
563
	typeConstructor (GTT_Constructor fun_ident _) ci
564
565
		# type_fun
			=	App {app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr}
566
		= (App {app_symb = cinp_dynamic_representation.dr_type_code_constructor_symb_ident, app_args = [type_fun], app_info_ptr = nilPtr}, ci)
567

568
	typeConstructor (GTT_Basic basic_type) ci
569
570
571
572
573
574
575
576
577
578
		#! predefined_TC_basic_type
			= case basic_type of
				BT_Int -> PD_TC_Int
				BT_Char	-> PD_TC_Char
				BT_Real	-> PD_TC_Real
				BT_Bool	-> PD_TC_Bool
				BT_Dynamic -> PD_TC_Dynamic
				BT_File	-> PD_TC_File
				BT_World -> PD_TC_World
		= type_code_constructor_expression predefined_TC_basic_type ci
579
	typeConstructor GTT_Function ci
580
581
582
583
584
585
		=	type_code_constructor_expression PD_TC__Arrow ci

	type_code_constructor_expression predefined_TC_type ci
		# (cons_TC_Char, ci) = constructorExp predefined_TC_type SK_Constructor 0 ci
		= (App {app_symb = cinp_dynamic_representation.dr_type_code_constructor_symb_ident, app_args = [cons_TC_Char], app_info_ptr = nilPtr}, ci)

586
convertTypeCode pattern cinp (TCE_Constructor cons args) st
587
	# curried_type
588
		=	foldl TCE_App (TCE_Constructor cons []) args
589
590
	=	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
591
		# (tv_symb, ci)
592
			=	getSymbol (if pattern PD_Dyn__TypeFixedVar PD_Dyn_TypeVar) SK_Constructor 1 ci
593
		# init_count
594
			=	if pattern ci.ci_type_var_count ci.ci_type_pattern_var_count
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
595
		# (count, ci_var_heap)
596
			=	foldSt (mark_uni_var pattern (build_tv tv_symb)) uni_vars (init_count, ci.ci_var_heap)
597
		# ci
598
599
600
601
			=	{	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}
602
603
		# (type_code, (has_var, binds, ci))
	  		=	convertTypeCode pattern cinp type_code (has_var, binds, ci)
604
	  	| count > init_count
605
606
607
			# (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
608
609
							app_args = [BasicExpr (BVInt (count - init_count)), type_code],
							app_info_ptr = nilPtr }, (has_var || init_count <> 0, binds, ci))
610
611
612
613
614
615
		// 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
616
617
				# var_info
					=	VI_TypeCodeVariable (TCI_TypeVar (build_var_code count))
618
				=	(count + (if pattern -1 1), writePtr var_info_ptr var_info var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
619
620
621
622
623
624

			build_tv :: SymbIdent Int -> Expression
			build_tv tv_symb number
				=	App {	app_symb = tv_symb,
							app_args = [BasicExpr (BVInt number)],
							app_info_ptr = nilPtr }
625
626
627
628
629
630
631
632
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
633

634
convertTypeCode pattern cinp (TCE_Selector selections var_info_ptr) st
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
  #	(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
653
654
655
656

createTypePatternVariable :: !*ConversionState -> (!Expression, !*ConversionState)
createTypePatternVariable ci
	# (tpv_symb, ci)
657
658
//		=	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
659
660
661
662
	=	(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
663
664
665

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

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
666
newVariable :: String !VarInfo !*ConversionState -> *(!BoundVar,!*ConversionState)
667
newVariable var_ident var_info ci=:{ci_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
668
	# (var_info_ptr, ci_var_heap) = newPtr var_info ci_var_heap
669
	= ( { 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
670
671
672
	    { ci & ci_var_heap = ci_var_heap })	

varToFreeVar :: BoundVar Int -> FreeVar
673
674
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
675
676

freeVarToVar ::  FreeVar -> BoundVar
677
678
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
679
680


Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
681
getResultType :: ExprInfoPtr !*ConversionState -> (!AType, !*ConversionState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
682
683
684
685
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
686
getSymbol :: Index ((Global Index) -> SymbKind) Int !*ConversionState -> (SymbIdent, !*ConversionState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
687
getSymbol index symb_kind arity ci=:{ci_predef_symb}
688
689
	# ({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
690
	  ci = {ci & ci_predef_symb = ci_predef_symb}
691
	  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
692
693
694
	= (symbol, ci)

getTupleSymbol arity ci=:{ci_predef_symb}
695
696
	# ({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
697
698
699
    = ( {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
700

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
701
bool_case_ptr :: !AType !*ConversionState -> (ExprInfoPtr, !*ConversionState)
702
bool_case_ptr result_type ci=:{ci_expr_heap}
703
	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_CaseType {	ct_pattern_type = toAType (TB BT_Bool),
704
															ct_result_type = result_type, //empty_attributed_type,
705
706
707
															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
708
709
dummy_case_ptr :: !AType !*ConversionState -> (ExprInfoPtr, !*ConversionState)
dummy_case_ptr result_type ci=:{ci_expr_heap}
710
	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_CaseType {	ct_pattern_type = toAType TE,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
711
712
713
714
715
															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})

let_ptr :: !Int !*ConversionState -> (ExprInfoPtr, !*ConversionState)
716
let_ptr nr_of_binds ci=:{ci_expr_heap}
717
718
	= let_ptr2 (repeatn nr_of_binds empty_attributed_type) ci

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
719
720
721
typed_let_ptr :: TypeSymbIdent !*ConversionState -> (ExprInfoPtr, !*ConversionState)
typed_let_ptr type_id ci=:{ci_expr_heap}
	= let_ptr2 [toAType (TA type_id [])] ci
722

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
723
let_ptr2 :: [AType] !*ConversionState -> (ExprInfoPtr, !*ConversionState)
724
725
let_ptr2 let_types ci=:{ci_expr_heap}
	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_LetType let_types) ci_expr_heap
726
	= (expr_info_ptr, {ci & ci_expr_heap = ci_expr_heap})
727
728

toAType :: Type -> AType
729
toAType type = { at_attribute = TA_Multi, at_type = type }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
730
731

empty_attributed_type :: AType
732
empty_attributed_type = toAType TE
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
733

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
734
735
736
737
738
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
739
			,	dr_type_code_constructor_symb_ident = undef
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
740
			},predefined_symbols)
741
	// otherwise
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
742
		# ({pds_module=pds_module1, pds_def=pds_def1} , predefined_symbols) = predefined_symbols![PD_Dyn_DynamicTemp]
743
		# {td_rhs=RecordType {rt_constructor}} = common_defs.[pds_module1].com_type_defs.[pds_def1]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
744
745
		# dynamic_defined_symbol
			= {glob_module = pds_module1, glob_object = rt_constructor}
746
		# dynamic_type = {gi_module = pds_module1, gi_index = pds_def1}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
747
748
749

		# dynamic_temp_symb_ident
			= { SymbIdent |
750
				symb_ident	= rt_constructor.ds_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
751
752
			,	symb_kind 	= SK_Constructor {glob_module = pds_module1, glob_object = rt_constructor.ds_index} 
			}
753
754
755
756
		# ({pds_module=pds_module2, pds_def=pds_def2}, predefined_symbols) = predefined_symbols![PD_TypeCodeConstructor]
		# {td_rhs=RecordType {rt_constructor}} = common_defs.[pds_module2].com_type_defs.[pds_def2]
		# type_code_constructor_symb_ident
			= {symb_ident = rt_constructor.ds_ident, symb_kind = SK_Constructor {glob_module = pds_module2, glob_object = rt_constructor.ds_index}}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
757
758
759
		= ({	dr_type_ident		= dynamic_temp_symb_ident
			,	dr_dynamic_type		= dynamic_type
			,	dr_dynamic_symbol	= dynamic_defined_symbol
760
			,	dr_type_code_constructor_symb_ident = type_code_constructor_symb_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
761
			}, predefined_symbols)