checkKindCorrectness.icl 14.6 KB
Newer Older
1
2
3
implementation module checkKindCorrectness

import StdEnv
4
import syntax, containers, checksupport, utilities
5

John van Groningen's avatar
John van Groningen committed
6
//import RWSDebug
7

John van Groningen's avatar
John van Groningen committed
8
9
10
11
12
13
checkKindCorrectness :: !Index IndexRange !{#CommonDefs} !Int !u:{# FunDef} !*{#DclModule} !*TypeVarHeap !*TypeDefInfos !*ErrorAdmin
																						-> (!u:{# FunDef}, !*{#DclModule}, !*TypeVarHeap, !*TypeDefInfos, !*ErrorAdmin)
checkKindCorrectness main_dcl_module_n icl_instances common_defs n_cached_dcl_modules fun_defs dcl_mods th_vars td_infos error_admin
	#! n_fun_defs = size fun_defs
	   size_dcl_mods = size dcl_mods
	# (dcl_mods, th_vars, td_infos, error_admin)
14
			= iFoldSt (\mod_index state
John van Groningen's avatar
John van Groningen committed
15
						-> if (mod_index<n_cached_dcl_modules)
16
								state
17
								(check_classes mod_index state))
18
19
20
21
					0 size_dcl_mods (dcl_mods, th_vars, td_infos, error_admin)
	  icl_common_defs
	  		= common_defs.[main_dcl_module_n]
	  (_, th_vars, td_infos, error_admin)
22
	  		= foldrArraySt (check_class icl_common_defs.com_member_defs)
23
24
	  				icl_common_defs.com_class_defs
					([], th_vars, td_infos, error_admin)
John van Groningen's avatar
John van Groningen committed
25
	  bv_uninitialized_mods = bitvectSetFirstN n_cached_dcl_modules (bitvectCreate size_dcl_mods)
26
	  (bv_uninitialized_mods, th_vars, td_infos, error_admin)
27
			= iFoldSt (\mod_index state
John van Groningen's avatar
John van Groningen committed
28
						-> if (mod_index<n_cached_dcl_modules)
29
								state
30
								(check_instances_and_class_and_member_contexts
31
32
										common_defs common_defs.[mod_index] state))
					0 size_dcl_mods (bv_uninitialized_mods, th_vars, td_infos, error_admin)
33
	  // check_icl_function: don't check the types that were generated for instances
34
	  state
35
			= iFoldSt (check_icl_function common_defs) 0 icl_instances.ir_from
36
37
					(fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin)
	  (fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin)
38
			= iFoldSt (check_icl_function common_defs) icl_instances.ir_to n_fun_defs state
39
	  (dcl_mods, bv_uninitialized_mods, th_vars, td_infos, error_admin)
40
			= iFoldSt (\mod_index state
John van Groningen's avatar
John van Groningen committed
41
						-> if (mod_index<n_cached_dcl_modules || mod_index==main_dcl_module_n)
42
			    		      state
43
						   	  (check_dcl_functions common_defs mod_index state))
44
45
46
			  0 size_dcl_mods
			  (dcl_mods, bv_uninitialized_mods, th_vars, td_infos, error_admin)
	= (fun_defs, dcl_mods, th_vars, td_infos, error_admin)
47
  where
48
	check_classes mod_index (dcl_mods, th_vars, td_infos, error_admin)
49
50
51
52
53
		# (dcl_mod, dcl_mods)
				= dcl_mods![mod_index]
		  {com_class_defs, com_member_defs}
		  		= dcl_mod.dcl_common
		  (class_defs_with_cacheable_kind_info, th_vars, td_infos, error_admin)
54
		  		= foldrArraySt (check_class com_member_defs) com_class_defs
55
56
57
58
59
						([], th_vars, td_infos, error_admin)
		  dcl_mods
		  		= { dcl_mods & [mod_index].dcl_common.com_class_defs 
		  				= { el \\ el <- class_defs_with_cacheable_kind_info }}
		= (dcl_mods, th_vars, td_infos, error_admin)
60
	check_class com_member_defs class_def=:{class_name, class_args, class_members}
61
			(class_defs_accu, th_vars, td_infos, error_admin)
62
		# th_vars
63
				= init_type_vars class_args th_vars
64
65
		  (th_vars, td_infos, error_admin)
		  		= foldlArraySt (\{ds_index} state
66
									-> check_member_without_context class_args 
67
68
69
70
71
											com_member_defs.[ds_index] state)
							class_members (th_vars, td_infos, error_admin)
		  (derived_kinds, th_vars)
		  		= mapFilterYesSt get_opt_kind class_args th_vars
		= ([{ class_def & class_arg_kinds = derived_kinds }:class_defs_accu], th_vars, td_infos, error_admin)
72
	check_member_without_context class_args
73
74
75
76
77
				{me_symb, me_pos, me_class_vars, me_type=me_type=:{st_vars, st_args, st_result}}
				(th_vars, td_infos, error_admin)
		# error_admin
				= setErrorAdmin (newPosition me_symb me_pos) error_admin
		  th_vars
78
				= init_type_vars st_vars th_vars
79
80
81
		  th_vars
		  		= fold2St copy_TVI class_args me_class_vars th_vars
		  (th_vars, td_infos, error_admin)
82
		  		= unsafeFold2St (check_atype KindConst) 
83
84
85
86
87
88
89
90
91
		  				[0..] [st_result:st_args] (th_vars, td_infos, error_admin)
		  th_vars
		  		= fold2St copy_TVI me_class_vars class_args th_vars
		= (th_vars, td_infos, error_admin)
	  where
		copy_TVI src dst th_vars
			# (tvi, th_vars)
					= readPtr src.tv_info_ptr th_vars
			= writePtr dst.tv_info_ptr tvi th_vars
92
	check_instances_and_class_and_member_contexts common_defs 
93
94
			{com_instance_defs, com_class_defs, com_member_defs} state
		# state
95
				= foldlArraySt (check_instance common_defs) com_instance_defs state
96
97
		  state
				= foldlArraySt 
98
					(check_class_context_and_member_contexts common_defs com_member_defs)
99
100
					com_class_defs state
		= state
101
	check_instance common_defs {ins_is_generic, ins_class, ins_ident, ins_pos, ins_type}
102
				(bv_uninitialized_mods, th_vars, td_infos, error_admin)
103
		| ins_is_generic
104
			// kind correctness of user supplied generic instances
105
			// is checked during generic phase
106
107
108
109
110
111
			= (bv_uninitialized_mods, th_vars, td_infos, error_admin)
		# (expected_kinds, bv_uninitialized_mods, th_vars)
				= get_expected_kinds ins_class common_defs bv_uninitialized_mods th_vars
		  error_admin
		  		= setErrorAdmin (newPosition ins_ident ins_pos) error_admin
		  th_vars
112
		  		= init_type_vars ins_type.it_vars th_vars
113
		  (th_vars, td_infos, error_admin)
114
		  		= unsafeFold3St possibly_check_type expected_kinds [1..] 
115
116
		  				ins_type.it_types (th_vars, td_infos, error_admin)
		  state
117
		  		= foldSt (check_context common_defs) ins_type.it_context
118
119
120
121
122
123
		  				(bv_uninitialized_mods, th_vars, td_infos, error_admin)
		= state

	get_expected_kinds class_index=:{glob_module, glob_object} common_defs bv_uninitialized_mods th_vars
		| bitvectSelect glob_module bv_uninitialized_mods
			/* the desired class is defined in a module which is a cached one 
124
				=> check_classes has not been called for all the classes
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
				   within that module
				=> the kind information for the class args is not in the heap
				=> put it in the heap now
			*/
			# th_vars
					= foldlArraySt write_kind_info common_defs.[glob_module].com_class_defs th_vars
			= get_expected_kinds class_index common_defs (bitvectReset glob_module bv_uninitialized_mods)
					th_vars
		# {class_args, class_arg_kinds}
				= common_defs.[glob_module].com_class_defs.[glob_object.ds_index]
		  (expected_kinds, th_vars)
		  		= mapSt get_tvi class_args th_vars
		= (expected_kinds, bv_uninitialized_mods, th_vars)

	write_kind_info {class_name, class_args, class_arg_kinds} th_vars
		= write_ki class_args class_arg_kinds th_vars

	write_ki [{tv_info_ptr}:class_args] [class_arg_kind:class_arg_kinds] th_vars
		= write_ki class_args class_arg_kinds (writePtr tv_info_ptr (TVI_Kind class_arg_kind) th_vars)
	write_ki [{tv_info_ptr}:class_args] [] th_vars
		= write_ki class_args [] (writePtr tv_info_ptr TVI_Empty th_vars)
	write_ki [] [] th_vars
		= th_vars

149
	possibly_check_type TVI_Empty _ _ state
150
151
		// This can happen for stooopid classes like StdClass::Ord, where the member type is ignored at all
		= state
152
153
154
	possibly_check_type (TVI_Kind expected_kind) arg_nr type state
		= check_type expected_kind arg_nr type state
	check_class_context_and_member_contexts common_defs com_member_defs
155
156
				{class_name, class_pos, class_context, class_members, class_args} 
				(bv_uninitialized_mods, th_vars, td_infos, error_admin)
157
158
159
		# error_admin
				= setErrorAdmin (newPosition class_name class_pos) error_admin
		  state
160
				= foldSt (check_context common_defs) class_context
161
						(bv_uninitialized_mods, th_vars, td_infos, error_admin)
162
		  state
163
		  		= foldlArraySt (check_member_context common_defs com_member_defs)
164
165
		  				class_members state
		= state
166
	check_member_context common_defs com_member_defs {ds_index}
167
				(bv_uninitialized_mods, th_vars, td_infos, error_admin)
168
169
170
171
		# {me_symb, me_pos, me_type}
				= com_member_defs.[ds_index]
		  error_admin
		  		= setErrorAdmin (newPosition me_symb me_pos) error_admin
172
		= foldSt (check_context common_defs) me_type.st_context 
173
				(bv_uninitialized_mods, th_vars, td_infos, error_admin)
174
175
	get_tvi {tv_info_ptr} th_vars
		= readPtr tv_info_ptr th_vars
176
177
178
179
180
181
182
183
	get_opt_kind {tv_info_ptr} th_vars
		# (tvi, th_vars)
				= readPtr tv_info_ptr th_vars
		#! opt_kind
				= case tvi of
					TVI_Kind kind -> Yes kind
					_ -> No
		= (opt_kind, th_vars)
184
	check_icl_function common_defs fun_n 
185
				(fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin)
186
187
188
		# (fun_def, fun_defs) = fun_defs![fun_n]
		= case fun_def.fun_type of
			No
189
				-> (fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin)
190
			Yes st
191
				# (bv_uninitialized_mods, th_vars, td_infos, error_admin)
192
						= check_symbol_type common_defs fun_def.fun_symb fun_def.fun_pos
193
194
								st (bv_uninitialized_mods, th_vars, td_infos, error_admin)
				-> (fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin)
195
	check_dcl_functions common_defs mod_index
196
197
198
199
200
201
202
203
			(dcl_mods, bv_uninitialized_mods, th_vars, td_infos, error_admin)
		# ({dcl_functions, dcl_instances, dcl_macros}, dcl_mods)
				= dcl_mods![mod_index]
		  (bv_uninitialized_mods, th_vars, td_infos, error_admin)
		  		= iFoldSt (\i state
							-> if (in_index_range i dcl_instances || in_index_range i dcl_macros) // yawn
								  state
								  (let ({ft_symb, ft_pos, ft_type}) = dcl_functions.[i]
204
								    in check_symbol_type common_defs ft_symb ft_pos ft_type 
205
206
207
								    		state))
							0 (size dcl_functions) (bv_uninitialized_mods, th_vars, td_infos, error_admin)
		= (dcl_mods, bv_uninitialized_mods, th_vars, td_infos, error_admin)
208
	check_symbol_type common_defs fun_symb fun_pos
209
210
			st=:{st_vars, st_args, st_result, st_context}
			(bv_uninitialized_mods, th_vars, td_infos, error_admin)
211
212
213
		# error_admin
				= setErrorAdmin (newPosition fun_symb fun_pos) error_admin
		  th_vars
214
				= init_type_vars st_vars th_vars
215
		  (th_vars, td_infos, error_admin)
216
		  		= unsafeFold2St (check_atype KindConst) 
217
		  				[0..] [st_result:st_args] (th_vars, td_infos, error_admin)
218
		  (bv_uninitialized_mods, th_vars, td_infos, error_admin)
219
		  		= foldSt (check_context common_defs) st_context 
220
221
		  				(bv_uninitialized_mods, th_vars, td_infos, error_admin)
		= (bv_uninitialized_mods, th_vars, td_infos, error_admin)
222
223
224
	check_atype expected_kind arg_nr {at_type} state
		= check_type expected_kind arg_nr at_type state
	check_type expected_kind arg_nr (TA {type_name,type_index} args)
225
226
227
228
					(th_vars, td_infos, error_admin)
		# ({tdi_kinds}, td_infos)
				= td_infos![type_index.glob_module,type_index.glob_object]
		  (th_vars, td_infos, error_admin)
229
		  		= unsafeFold2St (flip check_atype arg_nr) tdi_kinds args
230
231
232
233
234
235
236
237
238
239
		  				(th_vars, td_infos, error_admin)
		  n_args
		  		= length args
		  kind_of_application
		  		= if (n_args==length tdi_kinds) 
		  			KindConst
		  			(KindArrow (drop n_args tdi_kinds))
		  error_admin
		  		= check_equality_of_kinds arg_nr expected_kind kind_of_application error_admin
		= (th_vars, td_infos, error_admin)
240
	check_type expected_kind _ (TV tv) (th_vars, td_infos, error_admin)
241
242
243
		# (th_vars, error_admin)
		  		= unify_var_kinds expected_kind tv th_vars error_admin
		= (th_vars, td_infos, error_admin)
244
	check_type expected_kind _ (GTV tv) (th_vars, td_infos, error_admin)
245
246
247
		# (th_vars, error_admin)
		  		= unify_var_kinds expected_kind tv th_vars error_admin
		= (th_vars, td_infos, error_admin)
Artem Alimarine's avatar
Artem Alimarine committed
248
					
249
	check_type expected_kind arg_nr (l --> r) state
250
		# state
251
				= check_atype KindConst arg_nr l state
252
		  (th_vars, td_infos, error_admin)
253
				= check_atype KindConst arg_nr r state
254
255
256
		  error_admin
		  		= check_equality_of_kinds arg_nr expected_kind KindConst error_admin
		= (th_vars, td_infos, error_admin)
257
258
259
260
261
262
263
264
265
266
267
268
//AA..
	check_type expected_kind arg_nr TArrow (th_vars, td_infos, error_admin)
		# error_admin
		  		= check_equality_of_kinds arg_nr expected_kind (KindArrow [KindConst,KindConst]) error_admin
		= (th_vars, td_infos, error_admin)

	check_type expected_kind arg_nr (TArrow1 arg) state
		# (th_vars, td_infos, error_admin) = check_atype KindConst arg_nr arg state
		# error_admin
		  		= check_equality_of_kinds arg_nr expected_kind (KindArrow [KindConst]) error_admin
		= (th_vars, td_infos, error_admin)
//..AA
269
	check_type expected_kind arg_nr ((CV tv) :@: args) state
270
		# (th_vars, td_infos, error_admin)
271
				= foldSt (check_atype KindConst arg_nr) args state
272
273
274
275
276
277
278
		  expected_kind_of_cons_var
		  		= KindArrow (repeatn (length args) KindConst)
		  (th_vars, error_admin)
		  		= unify_var_kinds expected_kind_of_cons_var tv th_vars error_admin
		  error_admin
		  		= check_equality_of_kinds arg_nr expected_kind KindConst error_admin
		= (th_vars, td_infos, error_admin)
279
	check_type expected_kind arg_nr (TB _) (th_vars, td_infos, error_admin)
280
281
282
		# error_admin
		  		= check_equality_of_kinds arg_nr expected_kind KindConst error_admin
		= (th_vars, td_infos, error_admin)
283
284
285
286
287
// Sjaak ... 170801
	check_type expected_kind arg_nr (TFA vars type) (th_vars, td_infos, error_admin)
		# th_vars = init_type_vars [ atv_variable \\ {atv_variable} <- vars ] th_vars
		= check_type expected_kind arg_nr type (th_vars, td_infos, error_admin)
// ... Sjaak 170801
288
	
289
	check_context common_defs {tc_class, tc_types} 
290
291
292
293
			(bv_uninitialized_mods, th_vars, td_infos, error_admin)
		# (expected_kinds, bv_uninitialized_mods, th_vars)
		  		= get_expected_kinds tc_class common_defs bv_uninitialized_mods th_vars
		  (th_vars, td_infos, error_admin)
294
		  		= unsafeFold3St possibly_check_type expected_kinds (descending (-1))
295
		  				tc_types (th_vars, td_infos, error_admin)
296
		= (bv_uninitialized_mods, th_vars, td_infos, error_admin)
297
298
299
	  where
		descending i = [i:descending (i-1)]
		  
300
301
302
303
304
	init_type_vars vars tv_heap
		= foldSt init_type_var vars tv_heap
	where
		init_type_var {tv_info_ptr} tv_heap
			= tv_heap <:= (tv_info_ptr, TVI_Empty)
305
		
306
	unify_var_kinds expected_kind tv=:{tv_name, tv_info_ptr} th_vars error_admin
307
308
309
310
311
		# (tvi, th_vars)
				= readPtr tv_info_ptr th_vars
		= case tvi of
			TVI_Empty
				-> (writePtr tv_info_ptr (TVI_Kind expected_kind) th_vars, error_admin)
312
			TVI_Kind kind			
313
314
315
316
317
318
319
				| expected_kind==kind
					-> (th_vars, error_admin)
				-> (th_vars, checkError "cannot consistently assign a kind to type variable"
										tv_name.id_name error_admin)
	check_equality_of_kinds arg_nr expected_kind kind error_admin
		| expected_kind==kind
			= error_admin
320
		= checkError "inconsistent kind in" (arg_nr_to_string arg_nr) error_admin
321
322
323
324
325
326
327

	arg_nr_to_string 0 = "result type"
	arg_nr_to_string i
		| i >0
			= "type of argument nr "+++toString i
		= "type context nr "+++toString (~i)
		
328
329
330
331
332
333
334
335
336
337
338
	get_common_defs dcl_mods
		#! size = size dcl_mods
		# ({dcl_common=arbitrary_value_for_initializing}, dcl_mods) = dcl_mods![0]
		= loop 0 (createArray size arbitrary_value_for_initializing) dcl_mods
	  where
		loop :: !Int !*{#CommonDefs} !u:{#DclModule} -> (!*{#CommonDefs}, !u:{#DclModule})
		loop i common_defs dcl_mods
			| i==size dcl_mods
				= (common_defs, dcl_mods)
			# ({dcl_common}, dcl_mods) = dcl_mods![i]
			= loop (i+1) { common_defs & [i] = dcl_common } dcl_mods
339
340

in_index_range test ir :== test>=ir.ir_from && test < ir.ir_to
341