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

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

5
from type_io_common import PredefinedModuleName
6

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

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

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

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

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

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

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

John van Groningen's avatar
John van Groningen committed
39
40
41
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
42
43
	# write_type_info_state2
		= { WriteTypeInfoState |
44
45
46
47
48
49
			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
50
	  	,	wtis_icl_generic_defs = icl_common.com_generic_defs
51
		};
52

53
	#! (tcl_file,write_type_info_state)
John van Groningen's avatar
John van Groningen committed
54
		= 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
55

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

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

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

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

John van Groningen's avatar
John van Groningen committed
111
	= (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
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
118
119
120
121
122
123
124
			= 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
125

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

			# (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
134
135
136
137

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

138
139
			= ({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
140
141
142
143
144
145
146
147
148

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
149
150
		# (x, ci) = convertDynamics cinp x ci
		= (Yes x, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
151
	convertDynamics _ No ci
152
		= (No, ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
153
154
155

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

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

			collect_global_type_pattern_var :: FreeVar ([LetBind], BoundVar, *ConversionState) -> ([LetBind], BoundVar, *ConversionState)
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
			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
209
210
211

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

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

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

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

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

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

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

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

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

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

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

383
	# 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
384
385

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

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

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

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

405
406
	# 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}
407

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

varToFreeVar :: BoundVar Int -> FreeVar
670
671
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
672
673

freeVarToVar ::  FreeVar -> BoundVar
674
675
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
676
677


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

getTupleSymbol arity ci=:{ci_predef_symb}
692
693
	# ({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
694
695
696
    = ( {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
697

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

712

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
713
let_ptr :: !Int !*ConversionState -> (ExprInfoPtr, !*ConversionState)
714
let_ptr nr_of_binds ci=:{ci_expr_heap}
715
716
	= let_ptr2 (repeatn nr_of_binds empty_attributed_type) ci

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

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

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

empty_attributed_type :: AType
730
empty_attributed_type = toAType TE
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
731

732
instance <<< (Ptr a)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
733
734
735
where
	(<<<) file ptr = file <<< ptrToInt ptr  

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
736
737
738
739
740
741

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
742
			,	dr_type_code_constructor_symb_ident = undef
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
743
			},predefined_symbols)
744
	// otherwise
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
745
		# ({pds_module=pds_module1, pds_def=pds_def1} , predefined_symbols) = predefined_symbols![PD_Dyn_DynamicTemp]
746
		# {td_rhs=RecordType {rt_constructor}} = common_defs.[pds_module1].com_type_defs.[pds_def1]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
747
748
749
750
751
752
753
	
		# 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 |
754
				symb_ident	= rt_constructor.ds_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
755
756
			,	symb_kind 	= SK_Constructor {glob_module = pds_module1, glob_object = rt_constructor.ds_index} 
			}
757
758
759
760
		# ({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
761
762
763
		= ({	dr_type_ident		= dynamic_temp_symb_ident
			,	dr_dynamic_type		= dynamic_type
			,	dr_dynamic_symbol	= dynamic_defined_symbol
764
			,	dr_type_code_constructor_symb_ident = type_code_constructor_symb_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
765
766
			}, predefined_symbols)