checkFunctionBodies.icl 197 KB
Newer Older
1
2
implementation module checkFunctionBodies

3
import StdEnv, compare_types
4
import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef
5
import explicitimports, comparedefimp
6
from check import checkFunctions,checkDclMacros
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
78
	  app_symb = {symb_ident=decons_u_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_u_index,glob_module=stdStrictLists_index}}
	# decons_expr = App {app_symb=app_symb,app_args=[],app_info_ptr=new_info_ptr}
79
80
	= (unboxed_list,decons_expr,expr_heap,cs)

81
82
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}
83
84
	# (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
85
	# (nil_uts_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_uts].pds_def
86
87
	# (decons_uts_symbol,cs_predef_symbols)=cs_predef_symbols![PD_decons_uts]
	# decons_uts_index=decons_uts_symbol.pds_def
88
	# cs={cs & cs_predef_symbols=cs_predef_symbols,cs_x.x_needed_modules=cs_x.x_needed_modules bitor cNeedStdStrictLists}
89
	= (stdStrictLists_index,cons_uts_index,decons_uts_index,nil_uts_index,predefined_idents.[PD_decons_uts],cs)
90
91

make_unboxed_tail_strict_list type_symbol expr_heap cs
92
	# (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
93
94
	# unboxed_list=UnboxedTailStrictList type_symbol stdStrictLists_index decons_uts_index nil_uts_index
	# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
95
96
	  app_symb = {symb_ident=decons_uts_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_uts_index,glob_module=stdStrictLists_index}}
	# decons_expr = App {app_symb=app_symb,app_args=[],app_info_ptr=new_info_ptr}
97
98
99
	= (unboxed_list,decons_expr,expr_heap,cs)

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

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
113
114
	  app_symb = {symb_ident=decons_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_index,glob_module=stdStrictLists_index}}
	# decons_expr = App {app_symb=app_symb,app_args=[],app_info_ptr=new_info_ptr}
115
116
	= (overloaded_list,decons_expr,expr_heap,cs)

117
make_case_guards cons_symbol global_type_index alg_patterns expr_heap cs
118
119
120
	| 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
121
			# (unboxed_list,decons_expr,expr_heap,cs) = make_unboxed_list global_type_index expr_heap cs
122
123
			= (OverloadedListPatterns unboxed_list decons_expr alg_patterns,expr_heap,cs)
		| pd_cons_index==PD_UnboxedTailStrictConsSymbol || pd_cons_index==PD_UnboxedTailStrictNilSymbol
124
			# (unboxed_tail_strict_list,decons_expr,expr_heap,cs) = make_unboxed_tail_strict_list global_type_index expr_heap cs
125
126
			= (OverloadedListPatterns unboxed_tail_strict_list decons_expr alg_patterns,expr_heap,cs)
		| pd_cons_index==PD_OverloadedConsSymbol || pd_cons_index==PD_OverloadedNilSymbol
127
			# (overloaded_list,decons_expr,expr_heap,cs) = make_overloaded_list global_type_index expr_heap cs
128
			= (OverloadedListPatterns overloaded_list decons_expr alg_patterns,expr_heap,cs)
129
130
			= (AlgebraicPatterns global_type_index alg_patterns,expr_heap,cs)
		= (AlgebraicPatterns global_type_index alg_patterns,expr_heap,cs)
131

Sjaak Smetsers's avatar
Sjaak Smetsers committed
132
checkFunctionBodies :: !FunctionBody !Ident !.ExpressionInput !*ExpressionState !*ExpressionInfo !*CheckState
133
							   -> (!FunctionBody, ![FreeVar], !*ExpressionState,!*ExpressionInfo,!*CheckState)
134
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}
135
		e_state=:{es_var_heap, es_fun_defs} e_info cs
136

137
138
	# cs = pushErrorAdmin (newPosition function_ident_for_errors pb_position) cs
	  (aux_patterns, (var_env, array_patterns), {ps_var_heap,ps_fun_defs}, e_info, cs)
139
			= check_patterns pb_args {pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False} ([], [])
140
141
				{ps_var_heap = es_var_heap, ps_fun_defs = es_fun_defs} e_info cs
	  cs = popErrorAdmin cs
142
143
	  (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
144
	  (expr_with_array_selections, free_vars, e_state=:{es_var_heap,es_dynamics=dynamics_in_rhs}, e_info, cs)
145
146
			= 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
147
	  cs = { cs & cs_symbol_table = cs_symbol_table }
148
	  (cb_args, es_var_heap) = mapSt determine_function_arg aux_patterns es_var_heap
149
	  (rhss, free_vars, e_state=:{es_dynamics,es_expr_heap,es_var_heap}, e_info, cs)
150
	  		= check_function_bodies free_vars cb_args bodies e_input { e_state & es_dynamics = [], es_var_heap = es_var_heap } e_info cs
151
152
153
154
155
156
157
158
159
160
161
162
163
164
	  (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
165
		= ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store)
166
	determine_function_arg (AP_Variable name var_info No) var_store
167
		= ({ fv_ident = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, var_store)
168
169
	determine_function_arg (AP_Algebraic _ _ _ opt_var) var_store
		# ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store
170
		= ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store)
171
172
	determine_function_arg (AP_Basic _ opt_var) var_store
		# ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store
173
		= ({ 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
174
175
176
	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)
177
178
	determine_function_arg (AP_Dynamic _ _ opt_var) var_store
		# ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store
179
		= ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store)
180
181
	determine_function_arg _ var_store
		# ({bind_src,bind_dst}, var_store) = determinePatternVariable No var_store
182
		= ({ fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store)
183

184
185
	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
186
		# cs = pushErrorAdmin (newPosition function_ident_for_errors pb_position) cs
187
		# (aux_patterns, (var_env, array_patterns), {ps_var_heap,ps_fun_defs}, e_info, cs)
188
				= check_patterns pb_args { pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False } ([], [])
189
					{ps_var_heap = es_var_heap,ps_fun_defs = es_fun_defs} e_info cs
190
		# cs = popErrorAdmin cs
191
		  e_state = { e_state & es_var_heap = ps_var_heap,es_fun_defs = ps_fun_defs}
192
193
194
195
196
197
198
199
200
201
202
		  (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,
203
						es_dynamics = dynamics_in_patterns ++ es_dynamics }, e_info, cs)
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
	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)
228
	transform_pattern_into_cases (AP_Variable name var_info opt_var) fun_arg=:{fv_info_ptr,fv_ident} result_expr pattern_position
229
230
231
232
233
234
235
									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= [
236
237
								{ 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 },
238
239
240
241
242
243
244
									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= [
245
246
								{ 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 },
247
									lb_position = NoPos },
248
249
								{ 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 },
250
251
252
253
254
255
256
257
258
									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=
259
260
									[{ 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 },
261
262
263
264
										 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)

265
	transform_pattern_into_cases (AP_Algebraic cons_symbol global_type_index args opt_var) fun_arg result_expr pattern_position
266
267
268
269
270
									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
	  	  (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
271
		# alg_patterns = [{ ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr, ap_position = pattern_position }]
272
		# (case_guards,expr_heap,cs) = make_case_guards cons_symbol global_type_index alg_patterns expr_heap cs
273
		= (Case { case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No,
274
				case_explicit = cCaseNotExplicit,
275
276
277
278
279
280
281
				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
282
283
		= (Case {	case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No,
					case_explicit = cCaseNotExplicit,
284
					case_info_ptr = case_expr_ptr, case_default_pos = NoPos },
John van Groningen's avatar
John van Groningen committed
285
286
287
288
289
			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
290
		  type_symbol = {gi_module = cons_symbol.glob_module, gi_index = type_index}
John van Groningen's avatar
John van Groningen committed
291
292
293
294
295
296
297
	  	  (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)
298
299
300
301
302
303
	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
304
	  	  type_case_patterns = [{ dp_var = var_arg, dp_type	= dynamic_info_ptr,	dp_rhs = result_expr,
305
	  	  							dp_type_code = TCE_Empty, dp_position = pattern_position }]
306
		= (buildTypeCase act_var type_case_patterns No type_case_info_ptr cCaseNotExplicit, NoPos, var_store, expr_heap, [dynamic_info_ptr], cs)	
307
308
	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)	
309
	transform_pattern_into_cases AP_Empty fun_arg result_expr pattern_position var_store expr_heap opt_dynamics cs
310
		= (EE, pattern_position, var_store, expr_heap, opt_dynamics, cs)
311

John van Groningen's avatar
John van Groningen committed
312
	transform_pattern_variable :: !FreeVar !(Optional (Bind Ident VarInfoPtr)) !Expression !*ExpressionHeap
313
		-> (!Expression, !Expression, !*ExpressionHeap)
314
	transform_pattern_variable {fv_info_ptr,fv_ident} (Yes {bind_src,bind_dst}) result_expr expr_heap
315
316
		| bind_dst == fv_info_ptr
			# (var_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_ptr }, result_expr, expr_heap)
318
319
320
			# (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
321
			= (Var { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr1 },
322
						Let { let_strict_binds = [], let_lazy_binds =
323
324
						 		[{ 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 },
325
326
									lb_position = NoPos }],
							  let_expr = result_expr, let_info_ptr = let_expr_ptr, let_expr_position = NoPos }, expr_heap)
327
	transform_pattern_variable {fv_info_ptr,fv_ident} No result_expr expr_heap
328
		# (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
329
		= (Var { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, result_expr, expr_heap)
330

331
332
333
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)
334
checkFunctionBodies  _ function_ident_for_errors e_input=:{ei_expr_level,ei_mod_index} e_state=:{es_var_heap, es_fun_defs} e_info cs
335
	= abort ("checkFunctionBodies " +++ toString function_ident_for_errors +++ "\n")
336
337
338
339
340
341
342
343
344
345
346
347

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
348
349
:: LetBinds :== [([LetBind],[LetBind])]

350
351
checkRhs :: [FreeVar] OptGuardedAlts LocalDefs ExpressionInput *ExpressionState  *ExpressionInfo  *CheckState
								  -> *(!Expression,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState);
352
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
353
	# ei_expr_level = inc ei_expr_level
354
	  (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
355
	  (es_fun_defs, e_info, heaps, cs)
356
	  		= checkLocalFunctions ei_mod_index ei_expr_level rhs_locals ei_local_functions_index_offset e_state.es_fun_defs e_info
357
	  			{ 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
358
	  (rhs_expr, _, free_vars, e_state, e_info, cs) 
359
360
	  		= 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,
361
					es_type_heaps = heaps.hp_type_heaps,es_generic_heap=heaps.hp_generic_heap } e_info cs
362
363
364
	  (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
365
366
	  (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 })
367
368
369
370
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
371
		  (default_expr, default_expr_position, free_vars, e_state, e_info, cs)
372
373
		  		= 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 }
374
375
	  	  (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)
376
377
378
379
	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
380
381
		# (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)
382
	check_default_expr free_vars No e_input e_state e_info cs
383
		= (No, NoPos, free_vars, e_state, e_info, cs)
John van Groningen's avatar
John van Groningen committed
384
385
386
387
388
389
390
391

	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
392
		# (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
393
		  basic_pattern = {bp_value = (BVB True), bp_expr = expr, bp_position = expr_position }
John van Groningen's avatar
John van Groningen committed
394
395
396
		  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 }
397
398
		= build_sequential_lets let_binds case_expr NoPos es_expr_heap
	
John van Groningen's avatar
John van Groningen committed
399
400
	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)
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
	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
416
417
		  (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 )
418

419
	check_unguarded_expression :: [FreeVar] ExprWithLocalDefs ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(!Expression,!Position,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState);
420
	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
421
422
		# this_expr_level = inc ei_expr_level
		  (loc_defs, (var_env, array_patterns), e_state, e_info, cs)
423
		 		= checkLhssOfLocalDefs this_expr_level ei_mod_index ewl_locals ei_local_functions_index_offset e_state e_info cs
424
425
426
427
428
429
430
		  (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 }
431
		  (seq_let_expr, expr_position, es_expr_heap) = build_sequential_lets binds expr ewl_position e_state.es_expr_heap
432
433
434
	  	  (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)
435
	  	  		= checkLocalFunctions ei_mod_index rhs_expr_level ewl_locals ei_local_functions_index_offset e_state.es_fun_defs e_info 
436
	  	  		{ 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
437
		  (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
438
	  	= (expr, expr_position, free_vars, {e_state & es_fun_defs = es_fun_defs, es_var_heap = heaps.hp_var_heap,
439
440
	  			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} )
441
442
443
444
445
446
	
	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)
	
447
	check_sequential_lets :: [FreeVar] [NodeDefWithLocals] u:[[Ident]] !ExpressionInput *ExpressionState  *ExpressionInfo  *CheckState
John van Groningen's avatar
John van Groningen committed
448
										   -> *(!LetBinds,!u:[[Ident]],!Int,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState);
449
	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
450
451
		# ei_expr_level = inc ei_expr_level
		  e_input = { e_input & ei_expr_level = ei_expr_level }
452
453
454
455
		  (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
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
	    | 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)
473
474
475
476
	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);
477
	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
478
		# cs = pushErrorAdmin (newPosition {id_name="<node definition>", id_info=nilPtr} ndwl_position) cs
479
		  (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
480
481
482
483
		  (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
484
		  (es_fun_defs, e_info, {hp_var_heap,hp_expression_heap,hp_type_heaps,hp_generic_heap}, cs)
485
				= checkLocalFunctions ei_mod_index ei_expr_level ndwl_locals ei_local_functions_index_offset e_state.es_fun_defs e_info
486
	  				{ 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
487
	  	  (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
488
489
		  (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 } ([], []) 
490
					{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 }
491
		  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 }
492
493
		= (src_expr, pattern, accus, free_vars, e_state, e_info, popErrorAdmin cs)
	
John van Groningen's avatar
John van Groningen committed
494
	build_sequential_lets :: !LetBinds !Expression !Position !*ExpressionHeap -> (!Expression, !Position, !*ExpressionHeap)
495
	build_sequential_lets [] expr let_expr_position expr_heap
496
		= (expr, let_expr_position, expr_heap)
497
	build_sequential_lets [(strict_binds, lazy_binds) : seq_lets] expr let_expr_position expr_heap
498
		# (let_expr, let_expr_position, expr_heap) = build_sequential_lets seq_lets expr let_expr_position expr_heap
499
	  	  (let_expr, expr_heap) = buildLetExpression strict_binds lazy_binds let_expr let_expr_position expr_heap
500
		= ( let_expr, if (isEmpty strict_binds && isEmpty lazy_binds) let_expr_position NoPos, expr_heap)
501

502
503
504
505
506
507
508
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
509
510
		# (e_info,heaps,cs) = checkDclMacros mod_index level ir_from ir_to e_info heaps cs
		= (fun_defs,e_info,heaps,cs)
511

512
checkExpression :: ![FreeVar] !ParsedExpr !ExpressionInput !*ExpressionState !*ExpressionInfo !*CheckState
513
							 -> *(!Expression, ![FreeVar], !*ExpressionState,!*ExpressionInfo,!*CheckState);
514
515
516
517
518
519
520
521
522
523
524
525
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)
526
527
528
			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)
529
530
531
532
533
534
535
536
537
 			_
				# (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
538
	build_expression [Constant symb _ (Prio _ _) , _: _] e_state cs_error
539
		= (EE, e_state, checkError symb.symb_ident first_argument_of_infix_operator_missing cs_error)
John van Groningen's avatar
John van Groningen committed
540
541
	build_expression [Constant symb arity _] e_state cs_error
		= buildApplicationWithoutArguments symb e_state cs_error
542
543
544
545
546
547
	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
548
			Yes (symb, arity, prio, right)
549
				-> case right of
John van Groningen's avatar
John van Groningen committed
550
					[Constant symb _ (Prio _ _):_]
551
						-> (EE, e_state, checkError symb.symb_ident first_argument_of_infix_operator_missing cs_error)
552
					_
John van Groningen's avatar
John van Groningen committed
553
						-> build_operator_expression [] left_expr (symb, arity, prio) right e_state cs_error
554
555
556
			No
				-> (left_expr, e_state, cs_error)
	where
John van Groningen's avatar
John van Groningen committed
557
558
		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
559
			= split_at_operator [appl_exp : left] exprs e_state cs_error
John van Groningen's avatar
John van Groningen committed
560
		split_at_operator left [Constant symb arity (Prio _ _)] e_state cs_error
561
			= (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
562
563
		split_at_operator left [Constant symb arity prio] e_state cs_error
			# (appl_exp, e_state, cs_error) = buildApplicationWithoutArguments symb e_state cs_error
564
			= (No, [appl_exp : left], e_state, cs_error)
John van Groningen's avatar
John van Groningen committed
565
566
		split_at_operator left [expr=:(Constant symb arity prio) : exprs] e_state cs_error
			= (Yes (symb, arity, prio, exprs), left, e_state, cs_error)
567
568
569
570
571
572
573
		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
574
575
				Constant symb form_arity _
					-> buildApplication symb form_arity arity args e_state cs_error
576
577
578
579
580
581
582
583
				_
					| 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
584
 		build_operator_expression left_appls left1 (symb1, arity1, prio1) [re : res] e_state cs_error
585
586
			# (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
587
				Yes (symb2, arity2, prio2, right)
588
589
590
591
592
					# 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
593
								  (new_left, e_state, cs_error) = buildApplication symb1 arity1 2 [left1,middle_exp] e_state cs_error
594
								  (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
595
								-> build_operator_expression left_appls new_left (symb2, arity2, prio2) right e_state cs_error
596
						  		# (middle_exp, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error
John van Groningen's avatar
John van Groningen committed
597
598
								-> build_operator_expression [(symb1, arity1, prio1, left1) : left_appls]
										middle_exp (symb2, arity2, prio2) right e_state cs_error
599
						No
600
							-> (EE, e_state, checkError symb1.symb_ident "conflicting priorities" cs_error)
601
602
				No
					# (right, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error
John van Groningen's avatar
John van Groningen committed
603
					  (result_expr, e_state, cs_error) = buildApplication symb1 arity1 2 [left1,right] e_state cs_error
604
605
606
607
					-> 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
608
		build_left_operand la=:[(symb, arity, priol, left) : left_appls] prior result_expr e_state cs_error
609
610
611
612
			# optional_prio = determinePriority priol prior
			= case optional_prio of
				Yes priority
					| priority
John van Groningen's avatar
John van Groningen committed
613
						# (result_expr, e_state, cs_error) = buildApplication symb arity 2 [left,result_expr] e_state cs_error
614
615
616
						-> build_left_operand left_appls prior result_expr e_state cs_error
						-> (la, result_expr, e_state, cs_error)
				No
617
					-> (la, EE, e_state, checkError symb.symb_ident "conflicting priorities" cs_error)
618
619
620
		
		build_final_expression [] result_expr e_state cs_error
			= (result_expr, e_state, cs_error)		
John van Groningen's avatar
John van Groningen committed
621
622
		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
623
624
			= build_final_expression left_appls result_expr e_state cs_error
					
625
checkExpression free_vars (PE_Let let_locals expr) e_input=:{ei_expr_level,ei_mod_index,ei_local_functions_index_offset} e_state e_info cs
626
627
	# ei_expr_level = inc ei_expr_level
	  (loc_defs, (var_env, array_patterns), e_state, e_info, cs)
628
	  		= checkLhssOfLocalDefs ei_expr_level ei_mod_index let_locals ei_local_functions_index_offset e_state e_info cs
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
631
	  (expr, free_vars, e_state, e_info, cs)
632
633
634
			= 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)
635
			= checkLocalFunctions ei_mod_index ei_expr_level let_locals ei_local_functions_index_offset e_state.es_fun_defs e_info
636
	  			{ 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
637
	  (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
638
639
	= (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,
640
641
			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 })
642
643
644

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
645
	  (guards, _, pattern_variables, defaul, free_vars, e_state, e_info, cs)
John van Groningen's avatar
John van Groningen committed
646
	  		= check_case_alts free_vars alts [] case_ident.id_name e_input e_state e_info cs
647
	  (pattern_expr, binds, es_expr_heap) = bind_pattern_variables pattern_variables pattern_expr e_state.es_expr_heap
648
	  (case_expr, es_var_heap, es_expr_heap) = build_and_share_case guards defaul pattern_expr case_ident cCaseExplicit e_state.es_var_heap es_expr_heap
649
	  (result_expr, es_expr_heap) = buildLetExpression [] binds case_expr NoPos es_expr_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
650
	= (result_expr, free_vars, { e_state & es_var_heap = es_var_heap,  es_expr_heap = es_expr_heap }, e_info, cs)
651
where
John van Groningen's avatar
John van Groningen committed
652
	check_case_alts free_vars [g] pattern_variables case_name e_input=:{ei_expr_level} e_state e_info cs
653
		# e_input = { e_input & ei_expr_level = inc ei_expr_level }
John van Groningen's avatar
John van Groningen committed
654
655
		= 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
656
657
		# 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
658
659
		  	= 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 
660

John van Groningen's avatar
John van Groningen committed
661
662
663
	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
664
				e_input=:{ei_expr_level,ei_mod_index} e_state=:{es_fun_defs,es_var_heap,es_dynamics=outer_dynamics} e_info cs
665
666
		# cs = pushErrorAdmin (newPosition {id_name="<case pattern>", id_info=nilPtr} calt_position) cs
		  (pattern, (var_env, array_patterns), {ps_fun_defs,ps_var_heap}, e_info, cs)
667
				= checkPattern calt_pattern No { pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False } ([], [])
668
					{ps_var_heap = es_var_heap,ps_fun_defs = es_fun_defs} e_info cs
669
		  cs = popErrorAdmin cs
Sjaak Smetsers's avatar
Sjaak Smetsers committed
670
		  e_state = { e_state & es_var_heap = ps_var_heap, es_fun_defs = ps_fun_defs, es_dynamics = [] }
671
672
		  (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
673
		  (expr_with_array_selections, free_vars, e_state=:{es_dynamics = dynamics_in_rhs, es_expr_heap, es_var_heap}, e_info, cs)
674
675
676
				= 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
677
		  		= transform_pattern pattern patterns pattern_scheme pattern_variables defaul expr_with_array_selections case_name calt_position
Sjaak Smetsers's avatar
Sjaak Smetsers committed
678
		  									es_var_heap es_expr_heap dynamics_in_rhs { cs & cs_symbol_table = cs_symbol_table }
679
680
		  e_state = { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap, es_dynamics = dynamics_in_patterns ++ outer_dynamics }
		= (guarded_expr, pattern_scheme, pattern_variables, defaul, free_vars, e_state, e_info, cs)
681
682
683
684

	bind_pattern_variables [] pattern_expr expr_heap
		= (pattern_expr, [], expr_heap)
	bind_pattern_variables [{bind_src,bind_dst} : variables] this_pattern_expr expr_heap
685
		# free_var = { fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }
686
687
688
689
		  (bound_var, expr_heap) = allocate_bound_var free_var expr_heap
		  (pattern_expr, binds, expr_heap) = bind_pattern_variables variables (Var bound_var) expr_heap
		= (pattern_expr, [{lb_src = this_pattern_expr, lb_dst = free_var, lb_position = NoPos } : binds], expr_heap)

690
checkExpression free_vars (PE_Selection selector_kind expr [PS_Array index_expr]) e_input e_state e_info cs	
691
	# (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs
692
693
694
695
	# (select_fun, selector_kind)
		= case selector_kind of
			ParsedNormalSelector
				-> (PD_ArraySelectFun, NormalSelector)
696
			ParsedUniqueSelector False
697
				-> (PD_UnqArraySelectFun, UniqueSingleArraySelector/*NormalSelector*/)
698
			ParsedUniqueSelector True
699
				-> (PD_UnqArraySelectFun, UniqueSingleArraySelectorUniqueElementResult)
700
701
702
703
	# (glob_select_symb, cs) = getPredefinedGlobalSymbol select_fun PD_StdArray STE_Member 2 cs
	  (selector, free_vars, e_state, e_info, cs) = checkArraySelection glob_select_symb free_vars index_expr e_input e_state e_info cs
	= (Selection selector_kind expr [selector], free_vars, e_state, e_info, cs)
checkExpression free_vars (PE_Selection selector_kind expr selectors) e_input e_state e_info cs	
704
705
	# (selectors, free_vars, e_state, e_info, cs) = checkSelectors cEndWithSelection free_vars selectors e_input e_state e_info cs
	  (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs
706
707
708
709
	= case selector_kind of
		ParsedNormalSelector
			-> (Selection NormalSelector expr selectors, free_vars, e_state, e_info, cs)
		ParsedUniqueSelector unique_element
710
			-> (Selection UniqueSelector expr selectors, free_vars, e_state, e_info, cs)
711
712
713
714
715
716
717
checkExpression free_vars (PE_Update expr1 selectors expr2) e_input e_state e_info cs	
	# (expr1, free_vars, e_state, e_info, cs) = checkExpression free_vars expr1 e_input e_state e_info cs
	  (selectors, free_vars, e_state, e_info, cs) = checkSelectors cEndWithUpdate free_vars selectors e_input e_state e_info cs
	  (expr2, free_vars, e_state, e_info, cs) = checkExpression free_vars expr2 e_input e_state e_info cs
	= (Update expr1 selectors expr2, free_vars, e_state, e_info, cs)
checkExpression free_vars (PE_Tuple exprs) e_input e_state e_info cs
	# (exprs, arity, free_vars, e_state, e_info, cs) = check_expression_list free_vars exprs e_input e_state e_info cs
718
	  ({glob_object={ds_ident,ds_index},glob_module}, cs)
719
	  		= getPredefinedGlobalSymbol (GetTupleConsIndex arity) PD_PredefinedModule STE_Constructor arity cs
720
	= (App { app_symb = { symb_ident = ds_ident, symb_kind = SK_Constructor { glob_object = ds_index, glob_module = glob_module }},
721
722
723
724
725
726
727
728
729
730
731
732
733
			 app_args = exprs, app_info_ptr = nilPtr }, free_vars, e_state, e_info, cs)
where
	check_expression_list free_vars [] e_input e_state e_info cs
		= ([], 0, free_vars, e_state, e_info, cs)
	check_expression_list free_vars [expr : exprs] e_input e_state e_info cs
		# (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs
		  (exprs, length, free_vars, e_state, e_info, cs) = check_expression_list free_vars exprs e_input e_state e_info cs
		= ([expr : exprs], inc length, free_vars, e_state, e_info, cs)

checkExpression free_vars rec=:(PE_Record record opt_type fields) e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
	# (opt_record_and_fields, e_info, cs) = checkFields ei_mod_index fields opt_type e_info cs
	= case opt_record_and_fields of
		Yes (c