checkFunctionBodies.icl 191 KB
Newer Older
1
2
3
implementation module checkFunctionBodies

import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef //, RWSDebug
4
import explicitimports, comparedefimp
5
from check import checkFunctions,checkDclMacros
6
import compilerSwitches
7
8
9
10
11
12
13

cIsInExpressionList		:== True
cIsNotInExpressionList	:== False

cEndWithUpdate			:== True
cEndWithSelection		:== False

14
15
16
cCaseExplicit		:== True
cCaseNotExplicit	:== False

Sjaak Smetsers's avatar
Sjaak Smetsers committed
17
18
::	Dynamics		:== [ExprInfoPtr]

19
20
::	ExpressionState =
	{	es_expr_heap	:: !.ExpressionHeap
21
22
23
24
25
26
	,	es_var_heap			:: !.VarHeap
	,	es_type_heaps		:: !.TypeHeaps
	,	es_generic_heap		:: !.GenericHeap
	,	es_calls			:: ![FunCall]
	,	es_dynamics			:: ![ExprInfoPtr]
	,	es_fun_defs			:: !.{# FunDef}
27
	}
28

29
30
::	ExpressionInput =
	{	ei_expr_level	:: !Level
31
	,	ei_fun_index	:: !FunctionOrMacroIndex
32
33
	,	ei_fun_level	:: !Level
	,	ei_mod_index	:: !Index
34
	,	ei_local_functions_index_offset :: !Int
35
36
37
38
	}

::	PatternState =
	{	ps_var_heap :: !.VarHeap
39
	,	ps_fun_defs :: !.{#FunDef}
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
	}

::	PatternInput =
	{	pi_def_level		:: !Int
	,	pi_mod_index		:: !Index
	,	pi_is_node_pattern	:: !Bool
	}
	
::	ArrayPattern =
	{	ap_opt_var		:: !Optional (Bind Ident VarInfoPtr)
	,	ap_array_var	:: !FreeVar
	,	ap_selections	:: ![Bind FreeVar [ParsedExpr]]
	}

::	UnfoldMacroState =
	{	ums_var_heap	:: !.VarHeap
	,	ums_modules		:: !.{# DclModule}
	,	ums_cons_defs	:: !.{# ConsDef}
	,	ums_error		:: !.ErrorAdmin
	}

61
::	RecordKind = RK_Constructor | RK_Update
62

63
get_unboxed_list_indices_and_decons_u_ident :: *CheckState -> (!Index,!Index,!Index,!Index,!Ident,!*CheckState);
64
get_unboxed_list_indices_and_decons_u_ident cs=:{cs_predef_symbols,cs_x}
65
66
	# (stdStrictLists_index,cs_predef_symbols)=cs_predef_symbols![PD_StdStrictLists].pds_def
	# (cons_u_index,cs_predef_symbols)=cs_predef_symbols![PD_cons_u].pds_def
67
	# (nil_u_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_u].pds_def
68
69
	# (decons_u_symbol,cs_predef_symbols)=cs_predef_symbols![PD_decons_u]
	# decons_u_index=decons_u_symbol.pds_def
70
	# cs={cs & cs_predef_symbols=cs_predef_symbols,cs_x.x_needed_modules=cs_x.x_needed_modules bitor cNeedStdStrictLists}
71
	= (stdStrictLists_index,cons_u_index,decons_u_index,nil_u_index,predefined_idents.[PD_decons_u],cs)
72
73
74
75
76

make_unboxed_list type_symbol expr_heap cs
	# (stdStrictLists_index,cons_u_index,decons_u_index,nil_u_index,decons_u_ident,cs) = get_unboxed_list_indices_and_decons_u_ident cs
	# unboxed_list=UnboxedList type_symbol stdStrictLists_index decons_u_index nil_u_index
	# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
77
	# decons_expr = App {app_symb={symb_ident=decons_u_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_u_index,glob_module=stdStrictLists_index}},app_args=[],app_info_ptr=new_info_ptr}
78
79
	= (unboxed_list,decons_expr,expr_heap,cs)

80
81
get_unboxed_tail_strict_list_indices_and_decons_uts_ident :: *CheckState -> (!Index,!Index,!Index,!Index,!Ident,!*CheckState);
get_unboxed_tail_strict_list_indices_and_decons_uts_ident cs=:{cs_predef_symbols,cs_x}
82
83
	# (stdStrictLists_index,cs_predef_symbols)=cs_predef_symbols![PD_StdStrictLists].pds_def
	# (cons_uts_index,cs_predef_symbols)=cs_predef_symbols![PD_cons_uts].pds_def
84
	# (nil_uts_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_uts].pds_def
85
86
	# (decons_uts_symbol,cs_predef_symbols)=cs_predef_symbols![PD_decons_uts]
	# decons_uts_index=decons_uts_symbol.pds_def
87
	# cs={cs & cs_predef_symbols=cs_predef_symbols,cs_x.x_needed_modules=cs_x.x_needed_modules bitor cNeedStdStrictLists}
88
	= (stdStrictLists_index,cons_uts_index,decons_uts_index,nil_uts_index,predefined_idents.[PD_decons_uts],cs)
89
90

make_unboxed_tail_strict_list type_symbol expr_heap cs
91
	# (stdStrictLists_index,cons_uts_index,decons_uts_index,nil_uts_index,decons_uts_ident,cs) = get_unboxed_tail_strict_list_indices_and_decons_uts_ident cs
92
93
	# unboxed_list=UnboxedTailStrictList type_symbol stdStrictLists_index decons_uts_index nil_uts_index
	# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
94
	# decons_expr = App {app_symb={symb_ident=decons_uts_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_uts_index,glob_module=stdStrictLists_index}},app_args=[],app_info_ptr=new_info_ptr}
95
96
97
	= (unboxed_list,decons_expr,expr_heap,cs)

get_overloaded_list_indices_and_decons_ident :: *CheckState -> (!Index,!Index,!Index,!Index,!Ident,!*CheckState);
98
get_overloaded_list_indices_and_decons_ident cs=:{cs_predef_symbols,cs_x}
99
100
	# (stdStrictLists_index,cs_predef_symbols)=cs_predef_symbols![PD_StdStrictLists].pds_def
	# (cons_index,cs_predef_symbols)=cs_predef_symbols![PD_cons].pds_def
101
	# (nil_index,cs_predef_symbols)=cs_predef_symbols![PD_nil].pds_def
102
103
	# (decons_symbol,cs_predef_symbols)=cs_predef_symbols![PD_decons]
	# decons_index=decons_symbol.pds_def
104
	# cs={cs & cs_predef_symbols=cs_predef_symbols,cs_x.x_needed_modules=cs_x.x_needed_modules bitor cNeedStdStrictLists}
105
	= (stdStrictLists_index,cons_index,decons_index,nil_index,predefined_idents.[PD_decons],cs)
106
107
108
109
110

make_overloaded_list type_symbol expr_heap cs
	# (stdStrictLists_index,cons_index,decons_index,nil_index,decons_ident,cs) = get_overloaded_list_indices_and_decons_ident cs
	# overloaded_list=OverloadedList type_symbol stdStrictLists_index decons_index nil_index
	# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
111
	# decons_expr = App {app_symb={symb_ident=decons_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_index,glob_module=stdStrictLists_index}},app_args=[],app_info_ptr=new_info_ptr}
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
	= (overloaded_list,decons_expr,expr_heap,cs)

make_case_guards cons_symbol type_symbol alg_patterns expr_heap cs
	| cons_symbol.glob_module==cPredefinedModuleIndex
		# pd_cons_index=cons_symbol.glob_object.ds_index+FirstConstructorPredefinedSymbolIndex
		| pd_cons_index==PD_UnboxedConsSymbol || pd_cons_index==PD_UnboxedNilSymbol
			# (unboxed_list,decons_expr,expr_heap,cs) = make_unboxed_list type_symbol expr_heap cs
			= (OverloadedListPatterns unboxed_list decons_expr alg_patterns,expr_heap,cs)
		| pd_cons_index==PD_UnboxedTailStrictConsSymbol || pd_cons_index==PD_UnboxedTailStrictNilSymbol
			# (unboxed_tail_strict_list,decons_expr,expr_heap,cs) = make_unboxed_tail_strict_list type_symbol expr_heap cs
			= (OverloadedListPatterns unboxed_tail_strict_list decons_expr alg_patterns,expr_heap,cs)
		| pd_cons_index==PD_OverloadedConsSymbol || pd_cons_index==PD_OverloadedNilSymbol
			# (overloaded_list,decons_expr,expr_heap,cs) = make_overloaded_list type_symbol expr_heap cs
			= (OverloadedListPatterns overloaded_list decons_expr alg_patterns,expr_heap,cs)
			= (AlgebraicPatterns type_symbol alg_patterns,expr_heap,cs)						
		= (AlgebraicPatterns type_symbol alg_patterns,expr_heap,cs)

Sjaak Smetsers's avatar
Sjaak Smetsers committed
129
130
checkFunctionBodies :: !FunctionBody !Ident !.ExpressionInput !*ExpressionState !*ExpressionInfo !*CheckState
	-> (!FunctionBody, ![FreeVar], !*ExpressionState, !*ExpressionInfo, !*CheckState)
131
checkFunctionBodies (ParsedBody [{pb_args,pb_rhs={rhs_alts,rhs_locals}, pb_position} : bodies]) function_ident_for_errors e_input=:{ei_expr_level,ei_mod_index}
132
		e_state=:{es_var_heap, es_fun_defs} e_info cs
133

134
	# (aux_patterns, (var_env, array_patterns), {ps_var_heap,ps_fun_defs}, e_info, cs)
135
			= check_patterns pb_args {pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False} ([], [])
136
							{ps_var_heap = es_var_heap, ps_fun_defs = es_fun_defs} e_info cs
137
138
	  (rhs_expr, free_vars, e_state, e_info, cs)
	  		= checkRhs [] rhs_alts rhs_locals e_input { e_state & es_var_heap = ps_var_heap, es_fun_defs = ps_fun_defs } e_info cs
Sjaak Smetsers's avatar
Sjaak Smetsers committed
139
	  (expr_with_array_selections, free_vars, e_state=:{es_var_heap,es_dynamics=dynamics_in_rhs}, e_info, cs)
140
141
			= addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs
	  cs_symbol_table = removeLocalIdentsFromSymbolTable ei_expr_level var_env cs.cs_symbol_table
142
	  cs = { cs & cs_symbol_table = cs_symbol_table }
John van Groningen's avatar
John van Groningen committed
143
	  (cb_args, es_var_heap) = mapSt determine_function_arg aux_patterns es_var_heap		
144
	  (rhss, free_vars, e_state=:{es_dynamics,es_expr_heap,es_var_heap}, e_info, cs)
145
	  		= check_function_bodies free_vars cb_args bodies e_input { e_state & es_dynamics = [], es_var_heap = es_var_heap } e_info cs
146
147
148
149
150
151
152
153
154
155
156
157
158
159
	  (rhs, position, es_var_heap, es_expr_heap, dynamics_in_patterns, cs)
	  		= transform_patterns_into_cases aux_patterns cb_args expr_with_array_selections pb_position es_var_heap es_expr_heap
	  										dynamics_in_rhs cs
	= (CheckedBody { cb_args = cb_args, cb_rhs = [{ ca_rhs = rhs, ca_position = position } : rhss] }, free_vars,
		{ e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap, es_dynamics = dynamics_in_patterns ++ es_dynamics }, e_info, cs)
where
	check_patterns [pattern : patterns] p_input accus var_store e_info cs
		# (aux_pat, accus, var_store, e_info, cs) = checkPattern pattern No p_input accus var_store e_info cs
		  (aux_pats, accus, var_store, e_info, cs) = check_patterns patterns p_input accus var_store e_info cs
		= ([aux_pat : aux_pats], accus, var_store, e_info, cs)
	check_patterns [] p_input accus var_store e_info cs
		= ([], accus, var_store, e_info, cs)

	determine_function_arg (AP_Variable name var_info (Yes {bind_src, bind_dst})) var_store
160
		= ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store)
161
	determine_function_arg (AP_Variable name var_info No) var_store
162
		= ({ fv_ident = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, var_store)
163
164
	determine_function_arg (AP_Algebraic _ _ _ opt_var) var_store
		# ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store
165
		= ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store)
166
167
	determine_function_arg (AP_Basic _ opt_var) var_store
		# ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store
168
		= ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store)
John van Groningen's avatar
John van Groningen committed
169
170
171
	determine_function_arg (AP_NewType _ _ _ opt_var) var_store
		# ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store
		= ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store)
172
173
	determine_function_arg (AP_Dynamic _ _ opt_var) var_store
		# ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store
174
		= ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store)
175
176
	determine_function_arg _ var_store
		# ({bind_src,bind_dst}, var_store) = determinePatternVariable No var_store
177
		= ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store)
178
179
180
	
	check_function_bodies free_vars fun_args [{pb_args,pb_rhs={rhs_alts,rhs_locals},pb_position} : bodies]
							e_input=:{ei_expr_level,ei_mod_index} e_state=:{es_var_heap,es_fun_defs} e_info cs
181
		# cs = pushErrorAdmin (newPosition function_ident_for_errors pb_position) cs
182
		# (aux_patterns, (var_env, array_patterns), {ps_var_heap,ps_fun_defs}, e_info, cs)
183
				= check_patterns pb_args { pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False } ([], [])
184
					{ps_var_heap = es_var_heap,ps_fun_defs = es_fun_defs} e_info cs
185
		# cs = popErrorAdmin cs
186
		  e_state = { e_state & es_var_heap = ps_var_heap,es_fun_defs = ps_fun_defs}
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
		  (rhs_expr, free_vars, e_state, e_info, cs) = checkRhs free_vars rhs_alts rhs_locals e_input e_state e_info cs
		  (rhs_expr, free_vars, e_state=:{es_dynamics=dynamics_in_rhs}, e_info, cs)
				= addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs
	 	  cs_symbol_table = removeLocalIdentsFromSymbolTable ei_expr_level var_env cs.cs_symbol_table
		  (rhs_exprs, free_vars, e_state=:{es_dynamics,es_expr_heap,es_var_heap}, e_info, cs)
		  		= check_function_bodies free_vars fun_args bodies e_input { e_state & es_dynamics = [] } e_info { cs & cs_symbol_table = cs_symbol_table }
		  (rhs_expr, position, es_var_heap, es_expr_heap, dynamics_in_patterns, cs)
		  		= transform_patterns_into_cases aux_patterns fun_args rhs_expr pb_position
		  										 es_var_heap es_expr_heap dynamics_in_rhs cs
		= ([{ ca_rhs = rhs_expr, ca_position = position } : rhs_exprs], free_vars,
			{ e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap,
			es_dynamics = dynamics_in_patterns ++ es_dynamics }, e_info, cs)
	check_function_bodies free_vars fun_args [] e_input e_state e_info cs
		= ([], free_vars, e_state, e_info, cs) 
		
	transform_patterns_into_cases [pattern : patterns] [fun_arg : fun_args] result_expr pattern_position
									var_store expr_heap opt_dynamics cs
		# (patterns_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs)
				= transform_succeeding_patterns_into_cases patterns fun_args result_expr pattern_position
															var_store expr_heap opt_dynamics cs
		= transform_pattern_into_cases pattern fun_arg patterns_expr pattern_position var_store expr_heap opt_dynamics cs
	where
		transform_succeeding_patterns_into_cases [] _ result_expr pattern_position var_store expr_heap opt_dynamics cs
			= (result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs)
		transform_succeeding_patterns_into_cases [pattern : patterns] [fun_arg : fun_args] result_expr pattern_position
												var_store expr_heap opt_dynamics cs
			# (patterns_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs)
				= transform_succeeding_patterns_into_cases patterns fun_args result_expr pattern_position
															var_store expr_heap opt_dynamics cs
			= transform_pattern_into_cases pattern fun_arg patterns_expr pattern_position var_store expr_heap opt_dynamics cs

	transform_patterns_into_cases [] _ result_expr pattern_position var_store expr_heap opt_dynamics cs
		= (result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs)

	transform_pattern_into_cases :: !AuxiliaryPattern !FreeVar !Expression !Position !*VarHeap !*ExpressionHeap ![DynamicPtr] !*CheckState
		-> (!Expression, !Position, !*VarHeap, !*ExpressionHeap, ![DynamicPtr], !*CheckState)
223
	transform_pattern_into_cases (AP_Variable name var_info opt_var) fun_arg=:{fv_info_ptr,fv_ident} result_expr pattern_position
224
225
226
227
228
229
230
									var_store expr_heap opt_dynamics cs
		= case opt_var of
			Yes {bind_src, bind_dst}
				| bind_dst == fv_info_ptr
					# (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
					  (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
					-> (Let { let_strict_binds = [], let_lazy_binds= [
231
232
								{ lb_src = Var { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr },
									lb_dst = { fv_ident = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 },
233
234
235
236
237
238
239
									lb_position = NoPos }],
							  let_expr = result_expr, let_info_ptr = let_expr_ptr, let_expr_position = NoPos }, 
						pattern_position, var_store, expr_heap, opt_dynamics, cs)
					# (var_expr_ptr1, expr_heap) = newPtr EI_Empty expr_heap
					  (var_expr_ptr2, expr_heap) = newPtr EI_Empty expr_heap
					  (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
					-> (Let { let_strict_binds = [], let_lazy_binds= [
240
241
								{ lb_src = Var { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr1 },
									lb_dst = { fv_ident = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 },
242
									lb_position = NoPos },
243
244
								{ lb_src = Var { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr2 },
									lb_dst = { fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 },
245
246
247
248
249
250
251
252
253
									lb_position = NoPos }],
							  let_expr = result_expr, let_info_ptr = let_expr_ptr, let_expr_position = NoPos }, 
						pattern_position, var_store, expr_heap, opt_dynamics, cs)
			No
				| var_info == fv_info_ptr
					-> (result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs)
					# (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
					  (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
					-> (Let { let_strict_binds = [], let_lazy_binds=
254
255
									[{ lb_src = Var { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr },
										 lb_dst = { fv_ident = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 },
256
257
258
259
260
261
262
263
264
265
266
										 lb_position = NoPos }],
							  let_expr = result_expr, let_info_ptr = let_expr_ptr, let_expr_position = NoPos },
						pattern_position, var_store, expr_heap, opt_dynamics, cs)

	transform_pattern_into_cases (AP_Algebraic cons_symbol type_index args opt_var) fun_arg result_expr pattern_position
									var_store expr_heap opt_dynamics cs
		# (var_args, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs)
				= convertSubPatterns args result_expr pattern_position var_store expr_heap opt_dynamics cs
		  type_symbol = {glob_module = cons_symbol.glob_module, glob_object = type_index}
	  	  (act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap
		  (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
267
268
		# alg_patterns = [{ ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr, ap_position = pattern_position }]
		# (case_guards,expr_heap,cs) = make_case_guards cons_symbol type_symbol alg_patterns expr_heap cs
269
		= (Case { case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No,
270
				case_explicit = cCaseNotExplicit,
271
272
273
274
275
276
277
				case_info_ptr = case_expr_ptr, case_default_pos = NoPos },
				NoPos, var_store, expr_heap, opt_dynamics, cs)	
	transform_pattern_into_cases (AP_Basic basic_val opt_var) fun_arg result_expr pattern_position var_store expr_heap opt_dynamics cs
		# (basic_type, cs) = typeOfBasicValue basic_val cs
	  	  (act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap
		  case_guards = BasicPatterns basic_type [{ bp_value = basic_val, bp_expr = result_expr, bp_position = pattern_position }]
		  (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
278
279
		= (Case {	case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No,
					case_explicit = cCaseNotExplicit,
280
					case_info_ptr = case_expr_ptr, case_default_pos = NoPos },
John van Groningen's avatar
John van Groningen committed
281
282
283
284
285
286
287
288
289
290
291
292
293
			NoPos, var_store, expr_heap, opt_dynamics, cs)
	transform_pattern_into_cases (AP_NewType cons_symbol type_index arg opt_var) fun_arg result_expr pattern_position
									var_store expr_heap opt_dynamics cs
		# (var_arg, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs)
				= convertSubPattern arg result_expr pattern_position var_store expr_heap opt_dynamics cs
		  type_symbol = {glob_module = cons_symbol.glob_module, glob_object = type_index}
	  	  (act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap
		  (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
		# alg_patterns = [{ ap_symbol = cons_symbol, ap_vars = [var_arg], ap_expr = result_expr, ap_position = pattern_position }]
		# case_guards = NewTypePatterns type_symbol alg_patterns
		= (Case { case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No,
				  case_explicit = cCaseNotExplicit, case_info_ptr = case_expr_ptr, case_default_pos = NoPos },
			NoPos, var_store, expr_heap, opt_dynamics, cs)
294
295
296
297
298
299
	transform_pattern_into_cases (AP_Dynamic pattern type opt_var) fun_arg result_expr pattern_position var_store expr_heap opt_dynamics cs
		# (var_arg, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs)
				= convertSubPattern pattern result_expr pattern_position var_store expr_heap opt_dynamics cs
		  (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap
		  (dynamic_info_ptr, expr_heap) = newPtr (EI_DynamicType type opt_dynamics) expr_heap
	  	  (act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap
300
	  	  type_case_patterns = [{ dp_var = var_arg, dp_type	= dynamic_info_ptr,	dp_rhs = result_expr,
301
	  	  							dp_type_code = TCE_Empty, dp_position = pattern_position }]
302
		= (buildTypeCase act_var type_case_patterns No type_case_info_ptr cCaseNotExplicit, NoPos, var_store, expr_heap, [dynamic_info_ptr], cs)	
303
304
	transform_pattern_into_cases (AP_WildCard _) fun_arg result_expr pattern_position var_store expr_heap opt_dynamics cs
		= (result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs)	
305
	transform_pattern_into_cases AP_Empty fun_arg result_expr pattern_position var_store expr_heap opt_dynamics cs
306
		= (EE, pattern_position, var_store, expr_heap, opt_dynamics, cs)
307

John van Groningen's avatar
John van Groningen committed
308
	transform_pattern_variable :: !FreeVar !(Optional (Bind Ident VarInfoPtr)) !Expression !*ExpressionHeap
309
		-> (!Expression, !Expression, !*ExpressionHeap)
310
	transform_pattern_variable {fv_info_ptr,fv_ident} (Yes {bind_src,bind_dst}) result_expr expr_heap
311
312
		| bind_dst == fv_info_ptr
			# (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
313
			= (Var { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, result_expr, expr_heap)
314
315
316
			# (var_expr_ptr1, expr_heap) = newPtr EI_Empty expr_heap
			  (var_expr_ptr2, expr_heap) = newPtr EI_Empty expr_heap
			  (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
317
			= (Var { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr1 },
318
						Let { let_strict_binds = [], let_lazy_binds =
319
320
						 		[{ lb_src = Var { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr2 },
									lb_dst = { fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 },
321
322
									lb_position = NoPos }],
							  let_expr = result_expr, let_info_ptr = let_expr_ptr, let_expr_position = NoPos }, expr_heap)
323
	transform_pattern_variable {fv_info_ptr,fv_ident} No result_expr expr_heap
324
		# (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
325
		= (Var { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, result_expr, expr_heap)
326

327
328
329
checkFunctionBodies  GeneratedBody function_ident_for_errors e_input e_state e_info cs
	= (GeneratedBody, [], e_state, e_info, cs)
		//---> ("checkFunctionBodies: function to derive ", function_ident_for_errors)
330
checkFunctionBodies  _ function_ident_for_errors e_input=:{ei_expr_level,ei_mod_index} e_state=:{es_var_heap, es_fun_defs} e_info cs
331
	= abort ("checkFunctionBodies " +++ toString function_ident_for_errors +++ "\n")
332
333
334
335
336
337
338
339
340
341
342
343
344


removeLocalsFromSymbolTable :: !Index !Level ![Ident] !LocalDefs !Int !*{#FunDef} !*{#*{#FunDef}} !*(Heap SymbolTableEntry)
																  -> (!.{#FunDef},!.{#.{#FunDef}},!.Heap SymbolTableEntry)
removeLocalsFromSymbolTable module_index level loc_vars (CollectedLocalDefs {loc_functions,loc_in_icl_module}) local_functions_index_offset fun_defs macro_defs symbol_table	
	# loc_functions={ir_from=loc_functions.ir_from+local_functions_index_offset,ir_to=loc_functions.ir_to+local_functions_index_offset}
	# symbol_table=removeLocalIdentsFromSymbolTable level loc_vars symbol_table
	| loc_in_icl_module
		# (fun_defs,symbol_table) = removeLocalFunctionsFromSymbolTable level loc_functions fun_defs symbol_table
		= (fun_defs,macro_defs,symbol_table)
		# (macro_defs,symbol_table) = removeLocalDclMacrosFromSymbolTable level module_index loc_functions macro_defs symbol_table
		= (fun_defs,macro_defs,symbol_table)

John van Groningen's avatar
John van Groningen committed
345
346
:: LetBinds :== [([LetBind],[LetBind])]

347
checkRhs :: [FreeVar] OptGuardedAlts LocalDefs ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(!Expression,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState);
348
checkRhs free_vars rhs_alts rhs_locals e_input=:{ei_expr_level,ei_mod_index,ei_local_functions_index_offset} e_state e_info cs
349
	# ei_expr_level = inc ei_expr_level
350
	  (loc_defs, (var_env, array_patterns), e_state, e_info, cs) = checkLhssOfLocalDefs ei_expr_level ei_mod_index rhs_locals ei_local_functions_index_offset e_state e_info cs
351
	  (es_fun_defs, e_info, heaps, cs)
352
	  		= checkLocalFunctions ei_mod_index ei_expr_level rhs_locals ei_local_functions_index_offset e_state.es_fun_defs e_info
353
	  			{ hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expr_heap, hp_type_heaps = e_state.es_type_heaps, hp_generic_heap = e_state.es_generic_heap } cs
354
	  (rhs_expr, _, free_vars, e_state, e_info, cs) 
355
356
	  		= check_opt_guarded_alts free_vars rhs_alts { e_input & ei_expr_level = ei_expr_level }
	  			{ e_state & es_fun_defs = es_fun_defs, es_var_heap = heaps.hp_var_heap, es_expr_heap = heaps.hp_expression_heap,
357
					es_type_heaps = heaps.hp_type_heaps,es_generic_heap=heaps.hp_generic_heap } e_info cs
358
359
360
	  (expr, free_vars, e_state, e_info, cs)
			= addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs
	  (expr, free_vars, e_state, e_info, cs) = checkRhssAndTransformLocalDefs free_vars loc_defs expr e_input e_state e_info cs
361
362
	  (es_fun_defs,macro_defs,cs_symbol_table) = removeLocalsFromSymbolTable ei_mod_index ei_expr_level var_env rhs_locals ei_local_functions_index_offset e_state.es_fun_defs e_info.ef_macro_defs cs.cs_symbol_table
	= (expr, free_vars, { e_state & es_fun_defs = es_fun_defs}, {e_info & ef_macro_defs=macro_defs}, { cs & cs_symbol_table = cs_symbol_table })
363
364
365
366
where
	check_opt_guarded_alts free_vars (GuardedAlts guarded_alts default_expr) e_input e_state e_info cs
		# (let_vars_list, rev_guarded_exprs, last_expr_level, free_vars, e_state, e_info, cs)
				= check_guarded_expressions free_vars guarded_alts [] [] e_input e_state e_info cs
367
		  (default_expr, default_expr_position, free_vars, e_state, e_info, cs)
368
369
		  		= check_default_expr free_vars default_expr { e_input & ei_expr_level = last_expr_level } e_state e_info cs
		  cs = { cs & cs_symbol_table = remove_seq_let_vars e_input.ei_expr_level let_vars_list cs.cs_symbol_table }
370
371
	  	  (result_expr, result_expr_position , es_expr_heap) = convert_guards_to_cases rev_guarded_exprs default_expr default_expr_position e_state.es_expr_heap
	  	= (result_expr, result_expr_position, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs)
372
373
374
375
	check_opt_guarded_alts free_vars (UnGuardedExpr unguarded_expr) e_input e_state e_info cs
		= check_unguarded_expression free_vars unguarded_expr e_input e_state e_info cs

	check_default_expr free_vars (Yes default_expr) e_input e_state e_info cs
376
377
		# (expr, expr_position, free_vars, e_state, e_info, cs) = check_unguarded_expression free_vars default_expr e_input e_state e_info cs
		= (Yes expr, expr_position, free_vars, e_state, e_info, cs)
378
	check_default_expr free_vars No e_input e_state e_info cs
379
		= (No, NoPos, free_vars, e_state, e_info, cs)
John van Groningen's avatar
John van Groningen committed
380
381
382
383
384
385
386
387

	convert_guards_to_cases [guard_expr] result_expr result_expr_position es_expr_heap
		= convert_guard_to_case guard_expr result_expr result_expr_position es_expr_heap
	convert_guards_to_cases [guard_expr : rev_guarded_exprs] result_expr result_expr_position es_expr_heap
		# (result_expr, result_expr_position, es_expr_heap) = convert_guard_to_case guard_expr result_expr result_expr_position es_expr_heap
		= convert_guards_to_cases rev_guarded_exprs (Yes result_expr) result_expr_position es_expr_heap

	convert_guard_to_case (let_binds, guard, expr, expr_position, guard_ident) result_expr result_expr_position es_expr_heap
388
		# (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
389
		  basic_pattern = {bp_value = (BVB True), bp_expr = expr, bp_position = expr_position }
John van Groningen's avatar
John van Groningen committed
390
391
392
		  case_expr = Case {case_expr = guard, case_guards = BasicPatterns BT_Bool [basic_pattern],
							case_default = result_expr, case_default_pos = result_expr_position,
							case_ident = Yes guard_ident, case_explicit = cCaseNotExplicit, case_info_ptr = case_expr_ptr }
393
394
		= build_sequential_lets let_binds case_expr NoPos es_expr_heap
	
John van Groningen's avatar
John van Groningen committed
395
396
	check_guarded_expressions :: [FreeVar] [GuardedExpr] [[Ident]] [(LetBinds,Expression,Expression,Position,Ident)] ExpressionInput *ExpressionState *ExpressionInfo *CheckState
													-> *([[Ident]],[(LetBinds,Expression,Expression,Position,Ident)],Int,[FreeVar],  *ExpressionState,*ExpressionInfo,*CheckState)
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
	check_guarded_expressions free_vars [gexpr : gexprs] let_vars_list rev_guarded_exprs e_input e_state e_info cs
		# (let_vars_list, rev_guarded_exprs, ei_expr_level, free_vars, e_state, e_info, cs)
				= check_guarded_expression free_vars gexpr let_vars_list rev_guarded_exprs e_input e_state e_info cs
		= check_guarded_expressions free_vars gexprs let_vars_list rev_guarded_exprs { e_input & ei_expr_level = ei_expr_level } e_state e_info cs
	check_guarded_expressions free_vars [] let_vars_list rev_guarded_exprs {ei_expr_level} e_state e_info cs
		= (let_vars_list, rev_guarded_exprs, ei_expr_level, free_vars, e_state, e_info, cs)

	check_guarded_expression free_vars {alt_nodes,alt_guard,alt_expr,alt_ident,alt_position}
			let_vars_list rev_guarded_exprs e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
		# (let_binds, let_vars_list, ei_expr_level, free_vars, e_state, e_info, cs) = check_sequential_lets free_vars alt_nodes let_vars_list
		  		{ e_input & ei_expr_level = inc ei_expr_level } e_state e_info cs
		  e_input = { e_input & ei_expr_level = ei_expr_level }
		  cs = pushErrorAdmin2 "guard" alt_position cs
	  	  (guard, free_vars, e_state, e_info, cs) = checkExpression free_vars alt_guard e_input e_state e_info cs
		  cs = popErrorAdmin cs
412
413
		  (expr, expr_position, free_vars, e_state, e_info, cs) = check_opt_guarded_alts free_vars alt_expr e_input e_state e_info cs
	  	= (let_vars_list, [(let_binds, guard, expr, expr_position, alt_ident) : rev_guarded_exprs], ei_expr_level, free_vars, e_state, e_info,  cs )
414

415
	check_unguarded_expression :: [FreeVar] ExprWithLocalDefs ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(!Expression,!Position,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState);
416
	check_unguarded_expression free_vars {ewl_nodes,ewl_expr,ewl_locals,ewl_position} e_input=:{ei_expr_level,ei_mod_index,ei_local_functions_index_offset} e_state e_info cs
417
418
		# this_expr_level = inc ei_expr_level
		  (loc_defs, (var_env, array_patterns), e_state, e_info, cs)
419
		 		= checkLhssOfLocalDefs this_expr_level ei_mod_index ewl_locals ei_local_functions_index_offset e_state e_info cs
420
421
422
423
424
425
426
		  (binds, let_vars_list, rhs_expr_level, free_vars, e_state, e_info, cs) = check_sequential_lets free_vars ewl_nodes [] { e_input & ei_expr_level = this_expr_level } e_state e_info cs
		  cs = pushErrorAdmin2 "" ewl_position cs
	  	  (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars ewl_expr { e_input & ei_expr_level = rhs_expr_level } e_state e_info cs
		  cs = popErrorAdmin cs
		  (expr, free_vars, e_state, e_info, cs)
				= addArraySelections array_patterns expr free_vars e_input e_state e_info cs
		  cs = { cs & cs_symbol_table = remove_seq_let_vars rhs_expr_level let_vars_list cs.cs_symbol_table }
427
		  (seq_let_expr, expr_position, es_expr_heap) = build_sequential_lets binds expr ewl_position e_state.es_expr_heap
428
429
430
	  	  (expr, free_vars, e_state, e_info, cs)
				= checkRhssAndTransformLocalDefs free_vars loc_defs seq_let_expr e_input { e_state & es_expr_heap = es_expr_heap} e_info cs
	  	  (es_fun_defs, e_info, heaps, cs)
431
	  	  		= checkLocalFunctions ei_mod_index rhs_expr_level ewl_locals ei_local_functions_index_offset e_state.es_fun_defs e_info 
432
	  	  		{ hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expr_heap, hp_type_heaps = e_state.es_type_heaps,hp_generic_heap=e_state.es_generic_heap } cs
433
		  (es_fun_defs,macro_defs,cs_symbol_table) = removeLocalsFromSymbolTable ei_mod_index this_expr_level var_env ewl_locals ei_local_functions_index_offset es_fun_defs e_info.ef_macro_defs cs.cs_symbol_table
434
	  	= (expr, expr_position, free_vars, {e_state & es_fun_defs = es_fun_defs, es_var_heap = heaps.hp_var_heap,
435
436
	  			es_expr_heap = heaps.hp_expression_heap, es_type_heaps = heaps.hp_type_heaps, es_generic_heap=heaps.hp_generic_heap},
	  		{e_info & ef_macro_defs=macro_defs}, { cs & cs_symbol_table = cs_symbol_table} )
437
438
439
440
441
442
	
	remove_seq_let_vars level [] symbol_table
		= symbol_table
	remove_seq_let_vars level [let_vars : let_vars_list] symbol_table
		= remove_seq_let_vars (dec level) let_vars_list (removeLocalIdentsFromSymbolTable level let_vars symbol_table)
	
John van Groningen's avatar
John van Groningen committed
443
444
	check_sequential_lets :: [FreeVar] [NodeDefWithLocals] u:[[Ident]] !ExpressionInput *ExpressionState  *ExpressionInfo  *CheckState 
										   -> *(!LetBinds,!u:[[Ident]],!Int,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState);
445
	check_sequential_lets free_vars [seq_let:seq_lets] let_vars_list e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
446
447
		# ei_expr_level = inc ei_expr_level
		  e_input = { e_input & ei_expr_level = ei_expr_level }
448
449
450
451
		  (src_expr, pattern_expr, (let_vars, array_patterns), free_vars, e_state, e_info, cs)
		  		= check_sequential_let free_vars seq_let e_input e_state e_info cs
	      (binds, loc_envs, max_expr_level, free_vars, e_state, e_info, cs)
	      		= check_sequential_lets free_vars seq_lets [let_vars : let_vars_list] e_input e_state e_info cs
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
	    | seq_let.ndwl_strict
		    # (lazy_let_binds,strict_let_bind,es_var_heap, es_expr_heap, e_info, cs)
					= transfromPatternIntoStrictBind ei_mod_index ei_expr_level pattern_expr src_expr seq_let.ndwl_position
							e_state.es_var_heap e_state.es_expr_heap e_info cs
			  e_state = { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap }
			  (strict_array_pattern_binds, lazy_array_pattern_binds, free_vars, e_state, e_info, cs)
					= buildArraySelections e_input array_patterns free_vars e_state e_info cs
			  all_binds = [ (strict_let_bind,lazy_let_binds), (strict_array_pattern_binds, lazy_array_pattern_binds) : binds]
		    = (all_binds, loc_envs, max_expr_level, free_vars, e_state, e_info, cs)
		    # (let_binds, es_var_heap, es_expr_heap, e_info, cs)
					= transfromPatternIntoBind ei_mod_index ei_expr_level pattern_expr src_expr seq_let.ndwl_position
							e_state.es_var_heap e_state.es_expr_heap e_info cs
			  e_state = { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap }
			  (strict_array_pattern_binds, lazy_array_pattern_binds, free_vars, e_state, e_info, cs)
					= buildArraySelections e_input array_patterns free_vars e_state e_info cs
			  all_binds = [([],let_binds), (strict_array_pattern_binds, lazy_array_pattern_binds) : binds]
		    = (all_binds, loc_envs, max_expr_level, free_vars, e_state, e_info, cs)
469
470
471
472
	check_sequential_lets free_vars [] let_vars_list e_input=:{ei_expr_level} e_state e_info cs
		= ([], let_vars_list, ei_expr_level, free_vars, e_state, e_info, cs)

	check_sequential_let :: [FreeVar] NodeDefWithLocals ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(!Expression,!AuxiliaryPattern,!(![Ident],![ArrayPattern]),![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState);
473
	check_sequential_let free_vars {ndwl_def={bind_src,bind_dst},ndwl_locals, ndwl_position} e_input=:{ei_expr_level,ei_mod_index,ei_local_functions_index_offset} e_state e_info cs
474
		# cs = pushErrorAdmin (newPosition {id_name="node definition", id_info=nilPtr} ndwl_position) cs
475
		  (loc_defs, (loc_env, loc_array_patterns), e_state, e_info, cs) = checkLhssOfLocalDefs ei_expr_level ei_mod_index ndwl_locals ei_local_functions_index_offset e_state e_info cs
476
477
478
479
		  (src_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars bind_src e_input e_state e_info cs
		  (src_expr, free_vars, e_state, e_info, cs)
				= addArraySelections loc_array_patterns src_expr free_vars e_input e_state e_info cs
		  (src_expr, free_vars, e_state, e_info, cs) = checkRhssAndTransformLocalDefs free_vars loc_defs src_expr e_input e_state e_info cs
480
		  (es_fun_defs, e_info, {hp_var_heap,hp_expression_heap,hp_type_heaps,hp_generic_heap}, cs)
481
				= checkLocalFunctions ei_mod_index ei_expr_level ndwl_locals ei_local_functions_index_offset e_state.es_fun_defs e_info
482
	  				{ hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expr_heap, hp_type_heaps = e_state.es_type_heaps,hp_generic_heap=e_state.es_generic_heap} cs
483
	  	  (es_fun_defs,macro_defs,cs_symbol_table) = removeLocalsFromSymbolTable ei_mod_index ei_expr_level loc_env ndwl_locals ei_local_functions_index_offset es_fun_defs e_info.ef_macro_defs cs.cs_symbol_table
484
485
		  (pattern, accus, {ps_fun_defs,ps_var_heap}, e_info, cs)
				= checkPattern bind_dst No { pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = True } ([], []) 
486
					{ps_var_heap = hp_var_heap,ps_fun_defs = es_fun_defs } {e_info & ef_macro_defs=macro_defs} { cs & cs_symbol_table = cs_symbol_table }
487
		  e_state = { e_state & es_var_heap = ps_var_heap, es_expr_heap = hp_expression_heap, es_type_heaps = hp_type_heaps,es_generic_heap=hp_generic_heap,es_fun_defs = ps_fun_defs }
488
489
		= (src_expr, pattern, accus, free_vars, e_state, e_info, popErrorAdmin cs)
	
John van Groningen's avatar
John van Groningen committed
490
	build_sequential_lets :: !LetBinds !Expression !Position !*ExpressionHeap -> (!Expression, !Position, !*ExpressionHeap)
491
	build_sequential_lets [] expr let_expr_position expr_heap
492
		= (expr, let_expr_position, expr_heap)
493
	build_sequential_lets [(strict_binds, lazy_binds) : seq_lets] expr let_expr_position expr_heap
494
		# (let_expr, let_expr_position, expr_heap) = build_sequential_lets seq_lets expr let_expr_position expr_heap
495
	  	  (let_expr, expr_heap) = buildLetExpression strict_binds lazy_binds let_expr let_expr_position expr_heap
496
		= ( let_expr, if (isEmpty strict_binds && isEmpty lazy_binds) let_expr_position NoPos, expr_heap)
497

498
499
500
501
502
503
504
checkLocalFunctions :: !Index !Level !LocalDefs !Int !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState
												 -> (!.{#FunDef},!.ExpressionInfo,!.Heaps,!.CheckState);
checkLocalFunctions mod_index level (CollectedLocalDefs {loc_functions={ir_from,ir_to},loc_in_icl_module}) local_functions_index_offset fun_defs e_info heaps cs
	# ir_from=ir_from+local_functions_index_offset
	# ir_to=ir_to+local_functions_index_offset
	| loc_in_icl_module
		= checkFunctions mod_index level ir_from ir_to local_functions_index_offset fun_defs e_info heaps cs
505
506
		# (e_info,heaps,cs) = checkDclMacros mod_index level ir_from ir_to e_info heaps cs
		= (fun_defs,e_info,heaps,cs)
507

508
509
510
511
512
513
514
515
516
517
518
519
520
521
checkExpression :: ![FreeVar] !ParsedExpr !ExpressionInput !*ExpressionState !*ExpressionInfo !*CheckState
	-> *(!Expression, ![FreeVar], !*ExpressionState, !*ExpressionInfo, !*CheckState);
checkExpression free_vars (PE_List exprs) e_input e_state e_info cs	
	# (exprs, free_vars, e_state, e_info, cs) = check_expressions free_vars exprs e_input e_state e_info cs
	  (expr, e_state, cs_error) = build_expression exprs e_state cs.cs_error
	= (expr, free_vars, e_state, e_info, { cs & cs_error = cs_error })

where
	check_expressions free_vars [expr : exprs] e_input e_state e_info cs
		# (exprs, free_vars, e_state, e_info, cs) = check_expressions free_vars exprs e_input e_state e_info cs
		= case expr of
			PE_Ident id
				# (expr, free_vars, e_state, e_info, cs) = checkIdentExpression cIsInExpressionList free_vars id e_input e_state e_info cs
 				-> ([expr : exprs], free_vars, e_state, e_info, cs)
522
523
524
			PE_QualifiedIdent module_id ident_name
				# (expr, free_vars, e_state, e_info, cs) = checkQualifiedIdentExpression free_vars module_id ident_name cIsInExpressionList e_input e_state e_info cs
 				-> ([expr : exprs], free_vars, e_state, e_info, cs)
525
526
527
528
529
530
531
532
533
 			_
				# (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs
 				-> ([expr : exprs], free_vars, e_state, e_info, cs)
 	check_expressions free_vars [] e_input e_state e_info cs
		= ([], free_vars, e_state, e_info, cs)

	first_argument_of_infix_operator_missing
		= "first argument of infix operator missing"

John van Groningen's avatar
John van Groningen committed
534
	build_expression [Constant symb _ (Prio _ _) , _: _] e_state cs_error
535
		= (EE, e_state, checkError symb.symb_ident first_argument_of_infix_operator_missing cs_error)
John van Groningen's avatar
John van Groningen committed
536
537
	build_expression [Constant symb arity _] e_state cs_error
		= buildApplicationWithoutArguments symb e_state cs_error
538
539
540
541
542
543
	build_expression [expr] e_state cs_error
		= (expr, e_state, cs_error)
	build_expression [expr : exprs] e_state cs_error
		# (opt_opr, left, e_state, cs_error) = split_at_operator [expr] exprs e_state cs_error
		  (left_expr, e_state, cs_error) = combine_expressions left [] 0 e_state cs_error
		= case opt_opr of
John van Groningen's avatar
John van Groningen committed
544
			Yes (symb, arity, prio, right)
545
				-> case right of
John van Groningen's avatar
John van Groningen committed
546
					[Constant symb _ (Prio _ _):_]
547
						-> (EE, e_state, checkError symb.symb_ident first_argument_of_infix_operator_missing cs_error)
548
					_
John van Groningen's avatar
John van Groningen committed
549
						-> build_operator_expression [] left_expr (symb, arity, prio) right e_state cs_error
550
551
552
			No
				-> (left_expr, e_state, cs_error)
	where
John van Groningen's avatar
John van Groningen committed
553
554
		split_at_operator left [Constant symb arity NoPrio : exprs] e_state cs_error
			# (appl_exp, e_state, cs_error) = buildApplicationWithoutArguments symb e_state cs_error
555
			= split_at_operator [appl_exp : left] exprs e_state cs_error
John van Groningen's avatar
John van Groningen committed
556
		split_at_operator left [Constant symb arity (Prio _ _)] e_state cs_error
557
			= (No, left, e_state, checkError symb.symb_ident "second argument of infix operator missing" cs_error)
John van Groningen's avatar
John van Groningen committed
558
559
		split_at_operator left [Constant symb arity prio] e_state cs_error
			# (appl_exp, e_state, cs_error) = buildApplicationWithoutArguments symb e_state cs_error
560
			= (No, [appl_exp : left], e_state, cs_error)
John van Groningen's avatar
John van Groningen committed
561
562
		split_at_operator left [expr=:(Constant symb arity prio) : exprs] e_state cs_error
			= (Yes (symb, arity, prio, exprs), left, e_state, cs_error)
563
564
565
566
567
568
569
		split_at_operator left [expr : exprs] e_state cs_error
			= split_at_operator [expr : left] exprs e_state cs_error
		split_at_operator exp [] e_state cs_error
			= (No, exp, e_state, cs_error)

		combine_expressions [first_expr] args arity e_state cs_error
			= case first_expr of
John van Groningen's avatar
John van Groningen committed
570
571
				Constant symb form_arity _
					-> buildApplication symb form_arity arity args e_state cs_error
572
573
574
575
576
577
578
579
				_
					| arity == 0
						-> (first_expr, e_state, cs_error)
						-> (first_expr @ args, e_state, cs_error)
		combine_expressions [rev_arg : rev_args] args arity e_state cs_error
			= combine_expressions rev_args [rev_arg : args] (inc arity) e_state cs_error
		

John van Groningen's avatar
John van Groningen committed
580
 		build_operator_expression left_appls left1 (symb1, arity1, prio1) [re : res] e_state cs_error
581
582
			# (opt_opr, left2, e_state, cs_error) = split_at_operator [re] res e_state cs_error
			= case opt_opr of
John van Groningen's avatar
John van Groningen committed
583
				Yes (symb2, arity2, prio2, right)
584
585
586
587
588
					# optional_prio = determinePriority prio1 prio2
					-> case optional_prio of
						Yes priority
							| priority
						  		# (middle_exp, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error
John van Groningen's avatar
John van Groningen committed
589
								  (new_left, e_state, cs_error) = buildApplication symb1 arity1 2 [left1,middle_exp] e_state cs_error
590
								  (left_appls, new_left, e_state, cs_error) = build_left_operand left_appls prio2 new_left e_state cs_error
John van Groningen's avatar
John van Groningen committed
591
								-> build_operator_expression left_appls new_left (symb2, arity2, prio2) right e_state cs_error
592
						  		# (middle_exp, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error
John van Groningen's avatar
John van Groningen committed
593
594
								-> build_operator_expression [(symb1, arity1, prio1, left1) : left_appls]
										middle_exp (symb2, arity2, prio2) right e_state cs_error
595
						No
596
							-> (EE, e_state, checkError symb1.symb_ident "conflicting priorities" cs_error)
597
598
				No
					# (right, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error
John van Groningen's avatar
John van Groningen committed
599
					  (result_expr, e_state, cs_error) = buildApplication symb1 arity1 2 [left1,right] e_state cs_error
600
601
602
603
					-> build_final_expression left_appls result_expr e_state cs_error

		build_left_operand [] _ result_expr e_state cs_error
			= ([], result_expr, e_state, cs_error)		
John van Groningen's avatar
John van Groningen committed
604
		build_left_operand la=:[(symb, arity, priol, left) : left_appls] prior result_expr e_state cs_error
605
606
607
608
			# optional_prio = determinePriority priol prior
			= case optional_prio of
				Yes priority
					| priority
John van Groningen's avatar
John van Groningen committed
609
						# (result_expr, e_state, cs_error) = buildApplication symb arity 2 [left,result_expr] e_state cs_error
610
611
612
						-> build_left_operand left_appls prior result_expr e_state cs_error
						-> (la, result_expr, e_state, cs_error)
				No
613
					-> (la, EE, e_state, checkError symb.symb_ident "conflicting priorities" cs_error)
614
615
616
		
		build_final_expression [] result_expr e_state cs_error
			= (result_expr, e_state, cs_error)		
John van Groningen's avatar
John van Groningen committed
617
618
		build_final_expression [(symb, arity, _, left) : left_appls] result_expr e_state cs_error
			# (result_expr, e_state, cs_error) = buildApplication symb arity 2 [left,result_expr] e_state cs_error
619
620
			= build_final_expression left_appls result_expr e_state cs_error
					
621
checkExpression free_vars (PE_Let strict let_locals expr) e_input=:{ei_expr_level,ei_mod_index,ei_local_functions_index_offset} e_state e_info cs
622
623
	# ei_expr_level = inc ei_expr_level
	  (loc_defs, (var_env, array_patterns), e_state, e_info, cs)
624
	  		= checkLhssOfLocalDefs ei_expr_level ei_mod_index let_locals ei_local_functions_index_offset e_state e_info cs
625
626
627
628
629
630
	  e_input = { e_input & ei_expr_level = ei_expr_level }
	  (let_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs
	  (expr, free_vars, e_state=:{es_dynamics,es_expr_heap,es_var_heap}, e_info, cs)
			= addArraySelections array_patterns let_expr free_vars e_input e_state e_info cs
	  (expr, free_vars, e_state, e_info, cs) = checkRhssAndTransformLocalDefs free_vars loc_defs expr e_input e_state e_info cs
	  (es_fun_defs, e_info, heaps, cs)
631
			= checkLocalFunctions ei_mod_index ei_expr_level let_locals ei_local_functions_index_offset e_state.es_fun_defs e_info
632
	  			{ hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expr_heap, hp_type_heaps = e_state.es_type_heaps, hp_generic_heap = e_state.es_generic_heap } cs
633
	  (es_fun_defs,macro_defs,cs_symbol_table) = removeLocalsFromSymbolTable ei_mod_index ei_expr_level var_env let_locals ei_local_functions_index_offset es_fun_defs e_info.ef_macro_defs cs.cs_symbol_table
634
635
	= (expr, free_vars,
		{ e_state & es_fun_defs = es_fun_defs, es_var_heap = heaps.hp_var_heap, es_expr_heap = heaps.hp_expression_heap,
636
637
			es_type_heaps = heaps.hp_type_heaps,es_generic_heap = heaps.hp_generic_heap }, 
		{e_info & ef_macro_defs=macro_defs}, { cs & cs_symbol_table = cs_symbol_table })
638
639
640

checkExpression free_vars (PE_Case case_ident expr alts) e_input e_state e_info cs
	# (pattern_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs
Sjaak Smetsers's avatar
Sjaak Smetsers committed
641
	  (guards, _, pattern_variables, defaul, free_vars, e_state, e_info, cs)
John van Groningen's avatar
John van Groningen committed
642
	  		= check_case_alts free_vars alts [] case_ident.id_name e_input e_state e_info cs
643
	  (pattern_expr, binds, es_expr_heap) = bind_pattern_variables pattern_variables pattern_expr e_state.es_expr_heap
644
	  (case_expr, es_var_heap, es_expr_heap, cs_error) = build_and_share_case guards defaul pattern_expr case_ident cCaseExplicit e_state.es_var_heap es_expr_heap cs.cs_error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
645
	  cs = {cs & cs_error = cs_error}
646
	  (result_expr, es_expr_heap) = buildLetExpression [] binds case_expr NoPos es_expr_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
647
	= (result_expr, free_vars, { e_state & es_var_heap = es_var_heap,  es_expr_heap = es_expr_heap }, e_info, cs)
648
where
John van Groningen's avatar
John van Groningen committed
649
	check_case_alts free_vars [g] pattern_variables case_name e_input=:{ei_expr_level} e_state e_info cs
650
		# e_input = { e_input & ei_expr_level = inc ei_expr_level }
John van Groningen's avatar
John van Groningen committed
651
652
		= check_case_alt free_vars g NoPattern NoPattern pattern_variables No case_name e_input e_state e_info cs 
	check_case_alts free_vars [g : gs] pattern_variables case_name e_input=:{ei_expr_level} e_state e_info cs
653
654
		# e_input = { e_input & ei_expr_level = inc ei_expr_level }
		  (gs, pattern_scheme, pattern_variables, defaul, free_vars, e_state, e_info, cs)
John van Groningen's avatar
John van Groningen committed
655
656
		  	= check_case_alts free_vars gs pattern_variables case_name e_input e_state e_info cs
		= check_case_alt free_vars g gs pattern_scheme pattern_variables defaul case_name e_input e_state e_info cs 
657

John van Groningen's avatar
John van Groningen committed
658
659
660
	check_case_alt :: [FreeVar] CaseAlt CasePatterns CasePatterns [(Bind Ident (Ptr VarInfo))] (Optional ((Optional FreeVar),Expression)) {#Char} ExpressionInput *ExpressionState *ExpressionInfo *CheckState
												 -> *(CasePatterns,CasePatterns,[(Bind Ident (Ptr VarInfo))],(Optional ((Optional FreeVar),Expression)),[FreeVar],*ExpressionState,*ExpressionInfo,*CheckState)
	check_case_alt free_vars {calt_pattern,calt_rhs={rhs_alts,rhs_locals},calt_position} patterns pattern_scheme pattern_variables defaul case_name 
Sjaak Smetsers's avatar
Sjaak Smetsers committed
661
				e_input=:{ei_expr_level,ei_mod_index} e_state=:{es_fun_defs,es_var_heap,es_dynamics=outer_dynamics} e_info cs
662
663
		# (pattern, (var_env, array_patterns), {ps_fun_defs,ps_var_heap}, e_info, cs)
				= checkPattern calt_pattern No { pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False } ([], [])
664
					{ps_var_heap = es_var_heap,ps_fun_defs = es_fun_defs} e_info cs
Sjaak Smetsers's avatar
Sjaak Smetsers committed
665
		  e_state = { e_state & es_var_heap = ps_var_heap, es_fun_defs = ps_fun_defs, es_dynamics = [] }
666
667
		  (rhs_expr, free_vars, e_state, e_info, cs)
		  		= checkRhs free_vars rhs_alts rhs_locals e_input e_state e_info cs
Sjaak Smetsers's avatar
Sjaak Smetsers committed
668
		  (expr_with_array_selections, free_vars, e_state=:{es_dynamics = dynamics_in_rhs, es_expr_heap, es_var_heap}, e_info, cs)
669
670
671
				= addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs
		  cs_symbol_table = removeLocalIdentsFromSymbolTable ei_expr_level var_env cs.cs_symbol_table
		  (guarded_expr, pattern_scheme, pattern_variables, defaul, es_var_heap, es_expr_heap, dynamics_in_patterns, cs)
John van Groningen's avatar
John van Groningen committed
672
		  		= transform_pattern pattern patterns pattern_scheme pattern_variables defaul expr_with_array_selections case_name calt_position
Sjaak Smetsers's avatar
Sjaak Smetsers committed
673
		  									es_var_heap es_expr_heap dynamics_in_rhs { cs & cs_symbol_table = cs_symbol_table }
674
		= (guarded_expr, pattern_scheme, pattern_variables, defaul, free_vars,
Sjaak Smetsers's avatar
Sjaak Smetsers committed
675
			{ e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap, es_dynamics = dynamics_in_patterns ++ outer_dynamics },
676
677
678
				e_info, cs)

	transform_pattern :: !AuxiliaryPattern !CasePatterns !CasePatterns !(Env Ident VarInfoPtr) !(Optional (!Optional FreeVar, !Expression)) !Expression
John van Groningen's avatar
John van Groningen committed
679
			!String !Position !*VarHeap !*ExpressionHeap !Dynamics !*CheckState
680
				-> (!CasePatterns, !CasePatterns, !Env Ident VarInfoPtr, !Optional (!Optional FreeVar,!Expression), !*VarHeap, !*ExpressionHeap, ![DynamicPtr], !*CheckState)
John van Groningen's avatar
John van Groningen committed
681
682
	transform_pattern (AP_Algebraic cons_symbol type_index args opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ pos var_store expr_heap opt_dynamics cs
		# (var_args, result_expr, _, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr pos var_store expr_heap opt_dynamics cs
683
684
		  type_symbol = { glob_module = cons_symbol.glob_module, glob_object = type_index}
		  pattern_variables = cons_optional opt_var pattern_variables
John van Groningen's avatar
John van Groningen committed
685
		# pattern = { ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr, ap_position = pos}
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
		| cons_symbol.glob_module==cPredefinedModuleIndex
			# pd_cons_index=cons_symbol.glob_object.ds_index+FirstConstructorPredefinedSymbolIndex
			| pd_cons_index==PD_UnboxedConsSymbol || pd_cons_index==PD_UnboxedNilSymbol
				# (unboxed_list,decons_expr,expr_heap,cs) = make_unboxed_list type_symbol expr_heap cs
				= case pattern_scheme of
					OverloadedListPatterns (UnboxedList _ _ _ _) _ _
						# alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns
						-> (OverloadedListPatterns unboxed_list decons_expr [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
					OverloadedListPatterns (OverloadedList _ _ _ _) _ _
						# alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns
						# (alg_patterns,cs) = replace_overloaded_symbols_in_patterns alg_patterns PD_UnboxedConsSymbol PD_UnboxedNilSymbol cs
						-> (OverloadedListPatterns unboxed_list decons_expr [pattern : alg_patterns], OverloadedListPatterns unboxed_list decons_expr [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
					NoPattern
						-> (OverloadedListPatterns unboxed_list decons_expr [pattern], OverloadedListPatterns unboxed_list decons_expr [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
					_
						-> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs)

			| pd_cons_index==PD_UnboxedTailStrictConsSymbol || pd_cons_index==PD_UnboxedTailStrictNilSymbol
				# (unboxed_tail_strict_list,decons_expr,expr_heap,cs) = make_unboxed_tail_strict_list type_symbol expr_heap cs
				= case pattern_scheme of
					OverloadedListPatterns (UnboxedTailStrictList _ _ _ _) _ _
						# alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns
						-> (OverloadedListPatterns unboxed_tail_strict_list decons_expr [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
					OverloadedListPatterns (OverloadedList _ _ _ _) _ _
						# alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns
						# (alg_patterns,cs) = replace_overloaded_symbols_in_patterns alg_patterns PD_UnboxedTailStrictConsSymbol PD_UnboxedTailStrictNilSymbol cs
						-> (OverloadedListPatterns unboxed_tail_strict_list decons_expr [pattern : alg_patterns], OverloadedListPatterns unboxed_tail_strict_list decons_expr [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
					NoPattern
						-> (OverloadedListPatterns unboxed_tail_strict_list decons_expr [pattern], OverloadedListPatterns unboxed_tail_strict_list decons_expr [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
					_
						-> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs)
			
			| pd_cons_index==PD_OverloadedConsSymbol || pd_cons_index==PD_OverloadedNilSymbol
				= case pattern_scheme of
					OverloadedListPatterns (OverloadedList _ _ _ _) _ _
						# (overloaded_list,decons_expr,expr_heap,cs) = make_overloaded_list type_symbol expr_heap cs
						# alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns
						-> (OverloadedListPatterns overloaded_list decons_expr [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
					OverloadedListPatterns (UnboxedList _ _ _ _) _ _
						# (unboxed_list,decons_expr,expr_heap,cs) = make_unboxed_list type_symbol expr_heap cs
						# alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns
						# (pattern,cs) = replace_overloaded_symbol_in_pattern pattern PD_UnboxedConsSymbol PD_UnboxedNilSymbol cs
						-> (OverloadedListPatterns unboxed_list decons_expr [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
					OverloadedListPatterns (UnboxedTailStrictList _ _ _ _) _ _
						# (unboxed_tail_strict_list,decons_expr,expr_heap,cs) = make_unboxed_tail_strict_list type_symbol expr_heap cs
						# alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns
						# (pattern,cs) = replace_overloaded_symbol_in_pattern pattern PD_UnboxedTailStrictConsSymbol PD_UnboxedTailStrictNilSymbol cs
						-> (OverloadedListPatterns unboxed_tail_strict_list decons_expr [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
					AlgebraicPatterns alg_type _

						| alg_type.glob_module==cPredefinedModuleIndex
							# index=alg_type.glob_object+FirstTypePredefinedSymbolIndex
							| index==PD_ListType
								# alg_patterns = alg_patterns_of_AlgebraicPatterns_or_NoPattern patterns
								# (pattern,cs) = replace_overloaded_symbol_in_pattern pattern PD_ConsSymbol PD_NilSymbol cs
								-> (AlgebraicPatterns alg_type [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
							| index==PD_StrictListType
								# alg_patterns = alg_patterns_of_AlgebraicPatterns_or_NoPattern patterns
								# (pattern,cs) = replace_overloaded_symbol_in_pattern pattern PD_StrictConsSymbol PD_StrictNilSymbol cs
								-> (AlgebraicPatterns alg_type [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
							| index==PD_TailStrictListType
								# alg_patterns = alg_patterns_of_AlgebraicPatterns_or_NoPattern patterns
								# (pattern,cs) = replace_overloaded_symbol_in_pattern pattern PD_TailStrictConsSymbol PD_TailStrictNilSymbol cs
								-> (AlgebraicPatterns alg_type [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
							| index==PD_StrictTailStrictListType
								# alg_patterns = alg_patterns_of_AlgebraicPatterns_or_NoPattern patterns
								# (pattern,cs) = replace_overloaded_symbol_in_pattern pattern PD_StrictTailStrictConsSymbol PD_StrictTailStrictNilSymbol cs
								-> (AlgebraicPatterns alg_type [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
								-> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs)
							-> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs)
					NoPattern
						# (overloaded_list,decons_expr,expr_heap,cs) = make_overloaded_list type_symbol expr_heap cs
						-> (OverloadedListPatterns overloaded_list decons_expr [pattern], OverloadedListPatterns overloaded_list decons_expr [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
					_
						-> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs)
				= case pattern_scheme of
					AlgebraicPatterns alg_type _
						| type_symbol == alg_type
							# alg_patterns = alg_patterns_of_AlgebraicPatterns_or_NoPattern patterns
							-> (AlgebraicPatterns type_symbol [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
							-> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,
										{ cs & cs_error = checkError cons_symbol.glob_object.ds_ident "incompatible types of patterns" cs.cs_error })
					OverloadedListPatterns (OverloadedList _ _ _ _) _ _
						| type_symbol.glob_module==cPredefinedModuleIndex
							# index=type_symbol.glob_object+FirstTypePredefinedSymbolIndex
							| index==PD_ListType
								# alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns
								# (alg_patterns,cs) = replace_overloaded_symbols_in_patterns alg_patterns PD_ConsSymbol PD_NilSymbol cs
								-> (AlgebraicPatterns type_symbol [pattern:alg_patterns], AlgebraicPatterns type_symbol [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
							| index==PD_StrictListType
								# alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns
								# (alg_patterns,cs) = replace_overloaded_symbols_in_patterns alg_patterns PD_StrictConsSymbol PD_StrictNilSymbol cs
								-> (AlgebraicPatterns type_symbol [pattern:alg_patterns], AlgebraicPatterns type_symbol [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
							| index==PD_TailStrictListType
								# alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns
								# (alg_patterns,cs) = replace_overloaded_symbols_in_patterns alg_patterns PD_TailStrictConsSymbol PD_TailStrictNilSymbol cs
								-> (AlgebraicPatterns type_symbol [pattern:alg_patterns], AlgebraicPatterns type_symbol [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
							| index==PD_StrictTailStrictListType
								# alg_patterns = alg_patterns_of_OverloadedListPatterns_or_NoPattern patterns
								# (alg_patterns,cs) = replace_overloaded_symbols_in_patterns alg_patterns PD_StrictTailStrictConsSymbol PD_StrictTailStrictNilSymbol cs
								-> (AlgebraicPatterns type_symbol [pattern:alg_patterns], AlgebraicPatterns type_symbol [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
								-> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs)
					NoPattern
						-> (AlgebraicPatterns type_symbol [pattern], AlgebraicPatterns type_symbol [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
					_
						-> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,illegal_combination_of_patterns_error cons_symbol cs)
			= case pattern_scheme of
				AlgebraicPatterns alg_type _
					| type_symbol == alg_type
						# alg_patterns = alg_patterns_of_AlgebraicPatterns_or_NoPattern patterns
						-> (AlgebraicPatterns type_symbol [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
						-> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,
									{ cs & cs_error = checkError cons_symbol.glob_object.ds_ident "incompatible types of patterns" cs.cs_error })
				NoPattern
					-> (AlgebraicPatterns type_symbol [pattern], AlgebraicPatterns type_symbol [], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
				_
					-> (patterns, pattern_scheme, pattern_variables