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

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

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

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

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

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

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

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

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

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

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

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

John van Groningen's avatar
John van Groningen committed
659
660
661
	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
662
				e_input=:{ei_expr_level,ei_mod_index} e_state=:{es_fun_defs,es_var_heap,es_dynamics=outer_dynamics} e_info cs
663
664
		# (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 } ([], [])
665
					{ps_var_heap = es_var_heap,ps_fun_defs = es_fun_defs} e_info cs
Sjaak Smetsers's avatar
Sjaak Smetsers committed
666
		  e_state = { e_state & es_var_heap = ps_var_heap, es_fun_defs = ps_fun_defs, es_dynamics = [] }
667
668
		  (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
669
		  (expr_with_array_selections, free_vars, e_state=:{es_dynamics = dynamics_in_rhs, es_expr_heap, es_var_heap}, e_info, cs)
670
671
672
				= 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
673
		  		= transform_pattern pattern patterns pattern_scheme pattern_variables defaul expr_with_array_selections case_name calt_position
Sjaak Smetsers's avatar
Sjaak Smetsers committed
674
		  									es_var_heap es_expr_heap dynamics_in_rhs { cs & cs_symbol_table = cs_symbol_table }
675
676
		  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)
677
678
679
680

	bind_pattern_variables [] pattern_expr expr_heap
		= (pattern_expr, [], expr_heap)
	bind_pattern_variables [{bind_src,bind_dst} : variables] this_pattern_expr expr_heap
681
		# free_var = { fv_ident = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }
682
683
684
685
		  (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)

686
checkExpression free_vars (PE_Selection selector_kind expr [PS_Array index_expr]) e_input e_state e_info cs	
687
	# (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs
688
689
690
691
	# (select_fun, selector_kind)
		= case selector_kind of
			ParsedNormalSelector
				-> (PD_ArraySelectFun, NormalSelector)
692
			ParsedUniqueSelector False
693
				-> (PD_UnqArraySelectFun, UniqueSingleArraySelector/*NormalSelector*/)
694
			ParsedUniqueSelector True
695
				-> (PD_UnqArraySelectFun, UniqueSingleArraySelectorUniqueElementResult)
696
697
698
699
	# (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	
700
701
	# (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
702
703
704
705
	= case selector_kind of
		ParsedNormalSelector
			-> (Selection NormalSelector expr selectors, free_vars, e_state, e_info, cs)
		ParsedUniqueSelector unique_element
706
			-> (Selection UniqueSelector expr selectors, free_vars, e_state, e_info, cs)
707
708
709
710
711
712
713
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
714
	  ({glob_object={ds_ident,ds_index},glob_module}, cs)
715
	  		= getPredefinedGlobalSymbol (GetTupleConsIndex arity) PD_PredefinedModule STE_Constructor arity cs
716
	= (App { app_symb = { symb_ident = ds_ident, symb_kind = SK_Constructor { glob_object = ds_index, glob_module = glob_module }},
717
718
719
720
721
722
723
724
725
726
727
728
729
			 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 (cons=:{glob_module, glob_object}, _, new_fields)
730
			# {ds_ident,ds_index} = glob_object
731
			  rec_cons = { symb_ident = ds_ident, symb_kind = SK_Constructor { glob_object = ds_index, glob_module = glob_module } }