convertDynamics.icl 31.6 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

46
write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} icl_common_defs tcl_file directly_imported_dcl_modules type_heaps 
47
			   predefined_symbols imported_types var_heap common_defs icl_mod
48
49
	# write_type_info_state2
		= { WriteTypeInfoState |
50
51
52
53
54
55
			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
56
		};
57

58
	#! (tcl_file,write_type_info_state)
59
60
		= write_type_info icl_common_defs tcl_file write_type_info_state2

61
62
	#! (tcl_file,write_type_info_state)
		= write_type_info directly_imported_dcl_modules tcl_file write_type_info_state
63

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

83
convertDynamicPatternsIntoUnifyAppls :: !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap (Optional *File) {# DclModule} !IclModule [String]
84
			-> (!*{!Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{#CheckedTypeDef}}, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, !Optional *File)
85
convertDynamicPatternsIntoUnifyAppls common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap tcl_file dcl_mods icl_mod directly_imported_dcl_modules
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
86
87
88
	#! (dynamic_representation,predefined_symbols)
		=	create_dynamic_and_selector_idents common_defs predefined_symbols

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

111
	= (groups, fun_defs, ci_predef_symb, imported_types, ci_var_heap, type_heaps, ci_expr_heap, tcl_file)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
112
where
113
	convert_groups group_nr groups dynamic_representation fun_defs_and_ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
114
115
		| group_nr == size groups
			= (groups, fun_defs_and_ci)
116
			# (group, groups) = groups![group_nr]
117
			= convert_groups (inc group_nr) groups dynamic_representation (foldSt (convert_function group_nr dynamic_representation) group.group_members fun_defs_and_ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
118

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

			# (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
127
128
129
130

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

131
132
			= ({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
133
134
135
136
137
138
139
140
141

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

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

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

			collect_global_type_pattern_var :: FreeVar ([LetBind], BoundVar, *ConversionState) -> ([LetBind], BoundVar, *ConversionState)
171
172
173
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
			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
202
203
204

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

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

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

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

instance convertDynamics App where
	convertDynamics cinp app=:{app_args} ci
301
		# (app_args,ci) = convertDynamics cinp app_args ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
302
303
304
		=	({app & app_args = app_args}, ci)

instance convertDynamics Let where
305
306
307
308
309
	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
310
311
312
313
		= (letje, ci)

instance convertDynamics Case where
	convertDynamics cinp kees=:{case_expr, case_guards, case_default} ci
314
315
316
		# (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
317
		= case case_guards of
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
318
319
			DynamicPatterns alts
				->	convertDynamicCase cinp kees ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
320
			_
321
322
				# (case_guards, ci) = convertDynamics cinp case_guards ci
				# kees = {kees & case_guards=case_guards}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
323
324
325
326
				->	(kees, ci)

instance convertDynamics CasePatterns where
	convertDynamics cinp (BasicPatterns type alts) ci
327
328
		# (alts, ci) = convertDynamics cinp alts ci
		= (BasicPatterns type alts, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
329
	convertDynamics cinp (AlgebraicPatterns type alts) ci
330
331
		# (alts, ci) = convertDynamics cinp alts ci
		= (AlgebraicPatterns type alts, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
332
	convertDynamics cinp (OverloadedListPatterns type decons alts) ci
333
334
		# (alts, ci) = convertDynamics cinp alts ci
		= (OverloadedListPatterns type decons alts, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
335
336
337

convertDynamic cinp=:{cinp_dynamic_representation={dr_type_ident}}
					{dyn_expr, dyn_type_code} ci
338
	# (dyn_expr, ci) = convertDynamics cinp dyn_expr ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
339
340
341
	# (dyn_type_code, ci)
		=	convertExprTypeCode cinp dyn_type_code ci
	=	(App {	app_symb		= dr_type_ident,
342
				app_args 		= [dyn_expr, dyn_type_code],
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
343
				app_info_ptr	= nilPtr }, ci)
344

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
345
346
convertDynamicCase cinp=:{cinp_dynamic_representation={dr_dynamic_symbol, dr_dynamic_type}}
			kees=:{case_guards=DynamicPatterns alts, case_info_ptr, case_default} ci
347
348
349
350
351
	# (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
352
353
354
355
356
357
358
359
360
361
	# (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
		}
362
363
364
	# (case_info_ptr, ci) = dummy_case_ptr result_type ci
	# kees = {kees & case_guards=AlgebraicPatterns dr_dynamic_type [match], case_default=No, case_info_ptr = case_info_ptr}
	= (kees, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
365
366
367
368
369
370
371
372
373
374

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

375
	# 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
376
377

	// FIXME, more precise types (not all TEs)
378
379
380
381
382
383
384
385
	# (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
386
387
388
389

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

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

392
393
	# (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
394
	# (case_default, ci)
395
		=	convertDynamicAlts cinp kees type_var value_var result_type defoult alts ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
396

397
398
	# 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}
399

400
	# 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
401

402
	  (twotuple, ci) = getTupleSymbol 2 ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
403
404
405
406
407
408
409

	  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 },
410
								  	{ lb_src = TupleSelect twotuple 1 (Var unify_result_var),
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
411
412
413
414
415
416
		  							   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
			} 

417
	= (Yes (Let letje), ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432

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
433
		# (bp_expr, ci) = convertDynamics cinp bp_expr ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
434
435
436
437
		= ({alt & bp_expr=bp_expr}, ci)

instance convertDynamics AlgebraicPattern where
	convertDynamics cinp alt=:{ap_expr} ci
438
		# (ap_expr, ci) = convertDynamics cinp ap_expr ci
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
439
440
441
442
		=	({alt & ap_expr=ap_expr}, ci)

instance convertDynamics Selection where
	convertDynamics cinp selection=:(RecordSelection _ _) ci
443
		= (selection, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
444
	convertDynamics cinp (ArraySelection selector expr_ptr expr) ci
445
446
		# (expr, ci) = convertDynamics cinp expr ci
		= (ArraySelection selector expr_ptr expr, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
447
	convertDynamics cinp (DictionarySelection var selectors expr_ptr expr) ci
448
449
		# (expr, ci) = convertDynamics cinp expr ci
		= (DictionarySelection var selectors expr_ptr expr, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
450
451
452
453
454

convertExprTypeCode
	::	!ConversionInput !TypeCodeExpression !*ConversionState
	->	(!Expression, !*ConversionState)
convertExprTypeCode cinp tce ci
455
456
	# (type_code, (has_var, binds, ci))
		=	convertTypeCode False cinp tce (False, [], ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
457
458
459
460
	// sanity check ...
	| not (isEmpty binds)
		=	abort "unexpected binds in expression type code"
	// ... sanity check	
461
462
463
464
465
466
467
468
469
	| 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
470
471
472
473

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

477
convertTypeCode :: !Bool !ConversionInput !TypeCodeExpression (!Bool, ![LetBind], !*ConversionState)
478
											-> (!Expression, !(!Bool, ![LetBind], !*ConversionState))
479
convertTypeCode pattern _ (TCE_Var var_info_ptr) (has_var, binds, ci=:{ci_var_heap})
480
481
	# (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
482
	=	case var_info of
483
484
485
486
			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
487
			_
488
489
				# (expr, ci) = createTypePatternVariable ci
				# ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_TypePatternVar expr)) ci.ci_var_heap}
490
491
				->	(expr, (True, binds, ci))
convertTypeCode pattern _ (TCE_TypeTerm var_info_ptr) (has_var, binds, ci=:{ci_var_heap})
492
493
	# (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
494
	=	case var_info of
495
496
497
498
499
			VI_TypeCodeVariable (TCI_TypeVar tv)
				->	(tv, (has_var, binds, ci))
			VI_TypeCodeVariable (TCI_TypePatternVar tpv)
				->	(tpv, (True, binds, ci))
			_
500
501
				# (expr, ci) = createTypePatternVariable ci
				# ci = {ci & ci_var_heap = writePtr var_info_ptr (VI_TypeCodeVariable (TCI_TypePatternVar expr)) ci.ci_var_heap}
502
503
504
				->	(expr, (True, binds, ci))

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

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

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

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

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

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

varToFreeVar :: BoundVar Int -> FreeVar
675
676
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
677
678

freeVarToVar ::  FreeVar -> BoundVar
679
680
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
681
682


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

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

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

717

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
718
let_ptr :: !Int !*ConversionState -> (ExprInfoPtr, !*ConversionState)
719
let_ptr nr_of_binds ci=:{ci_expr_heap}
720
721
	= let_ptr2 (repeatn nr_of_binds empty_attributed_type) ci

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

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

toAType :: Type -> AType
732
toAType type = { at_attribute = TA_Multi, at_type = type }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
733
734

empty_attributed_type :: AType
735
empty_attributed_type = toAType TE
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
736

737
instance <<< (Ptr a)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
738
739
740
where
	(<<<) file ptr = file <<< ptrToInt ptr  

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757

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 |
758
				symb_ident	= rt_constructor.ds_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
759
760
761
762
763
764
765
			,	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)