checkKindCorrectness.icl 14.2 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

8
checkKindCorrectness :: !Index !Index IndexRange !{#CommonDefs} !Int !u:{# FunDef} !*{#DclModule} !*TypeVarHeap !*TypeDefInfos !*ErrorAdmin
John van Groningen's avatar
John van Groningen committed
9
																						-> (!u:{# FunDef}, !*{#DclModule}, !*TypeVarHeap, !*TypeDefInfos, !*ErrorAdmin)
10
checkKindCorrectness main_dcl_module_n first_uncached_function icl_instances common_defs n_cached_dcl_modules fun_defs dcl_mods th_vars td_infos error_admin
John van Groningen's avatar
John van Groningen committed
11
12
13
	#! 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) first_uncached_function /* 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
		  				(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
123
//			---> ("get_expected_kinds", glob_module)
124
			/* the desired class is defined in a module which is a cached one 
125
				=> check_classes has not been called for all the classes
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
				   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

150
	possibly_check_type TVI_Empty _ _ state
151
152
		// This can happen for stooopid classes like StdClass::Ord, where the member type is ignored at all
		= state
153
154
155
	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
156
157
				{class_name, class_pos, class_context, class_members, class_args} 
				(bv_uninitialized_mods, th_vars, td_infos, error_admin)
158
159
160
		# error_admin
				= setErrorAdmin (newPosition class_name class_pos) error_admin
		  state
161
				= foldSt (check_context common_defs) class_context
162
						(bv_uninitialized_mods, th_vars, td_infos, error_admin)
163
		  state
164
		  		= foldlArraySt (check_member_context common_defs com_member_defs)
165
166
		  				class_members state
		= state
167
	check_member_context common_defs com_member_defs {ds_index}
168
				(bv_uninitialized_mods, th_vars, td_infos, error_admin)
169
170
171
172
		# {me_symb, me_pos, me_type}
				= com_member_defs.[ds_index]
		  error_admin
		  		= setErrorAdmin (newPosition me_symb me_pos) error_admin
173
		= foldSt (check_context common_defs) me_type.st_context 
174
				(bv_uninitialized_mods, th_vars, td_infos, error_admin)
175
176
	get_tvi {tv_info_ptr} th_vars
		= readPtr tv_info_ptr th_vars
177
178
179
180
181
182
183
184
	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)
185
	check_icl_function common_defs fun_n 
186
				(fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin)
187
188
189
		# (fun_def, fun_defs) = fun_defs![fun_n]
		= case fun_def.fun_type of
			No
190
				-> (fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin)
191
			Yes st
192
				# (bv_uninitialized_mods, th_vars, td_infos, error_admin)
193
						= check_symbol_type common_defs fun_def.fun_symb fun_def.fun_pos
194
195
								st (bv_uninitialized_mods, th_vars, td_infos, error_admin)
				-> (fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin)
196
	check_dcl_functions common_defs mod_index
197
198
199
200
201
202
203
204
			(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]
205
								    in check_symbol_type common_defs ft_symb ft_pos ft_type 
206
207
208
								    		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)
209
	check_symbol_type common_defs fun_symb fun_pos
210
211
			st=:{st_vars, st_args, st_result, st_context}
			(bv_uninitialized_mods, th_vars, td_infos, error_admin)
212
213
214
		# error_admin
				= setErrorAdmin (newPosition fun_symb fun_pos) error_admin
		  th_vars
215
				= init_type_vars st_vars th_vars
216
		  (th_vars, td_infos, error_admin)
217
		  		= unsafeFold2St (check_atype KindConst) 
218
		  				[0..] [st_result:st_args] (th_vars, td_infos, error_admin)
219
		  (bv_uninitialized_mods, th_vars, td_infos, error_admin)
220
		  		= foldSt (check_context common_defs) st_context 
221
222
		  				(bv_uninitialized_mods, th_vars, td_infos, error_admin)
		= (bv_uninitialized_mods, th_vars, td_infos, error_admin)
223
224
225
	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)
226
227
228
229
					(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)
230
		  		= unsafeFold2St (flip check_atype arg_nr) tdi_kinds args
231
232
233
234
235
236
237
238
239
240
		  				(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)
241
	check_type expected_kind _ (TV tv) (th_vars, td_infos, error_admin)
242
243
244
		# (th_vars, error_admin)
		  		= unify_var_kinds expected_kind tv th_vars error_admin
		= (th_vars, td_infos, error_admin)
245
	check_type expected_kind _ (GTV tv) (th_vars, td_infos, error_admin)
246
247
248
		# (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
249
					
250
	check_type expected_kind arg_nr (l --> r) state
251
		# state
252
				= check_atype KindConst arg_nr l state
253
		  (th_vars, td_infos, error_admin)
254
				= check_atype KindConst arg_nr r state
255
256
257
		  error_admin
		  		= check_equality_of_kinds arg_nr expected_kind KindConst error_admin
		= (th_vars, td_infos, error_admin)
258
259
260
261
262
263
264
265
266
267
268
269
//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
270
	check_type expected_kind arg_nr ((CV tv) :@: args) state
271
		# (th_vars, td_infos, error_admin)
272
				= foldSt (check_atype KindConst arg_nr) args state
273
274
275
276
277
278
279
		  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)
280
	check_type expected_kind arg_nr (TB _) (th_vars, td_infos, error_admin)
281
282
283
		# error_admin
		  		= check_equality_of_kinds arg_nr expected_kind KindConst error_admin
		= (th_vars, td_infos, error_admin)
284
285
286
287
288
// 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
289
	
290
	check_context common_defs {tc_class, tc_types} 
291
292
293
294
			(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)
295
		  		= unsafeFold3St possibly_check_type expected_kinds (descending (-1))
296
		  				tc_types (th_vars, td_infos, error_admin)
297
		= (bv_uninitialized_mods, th_vars, td_infos, error_admin)
298
299
300
	  where
		descending i = [i:descending (i-1)]
		  
301
302
303
304
305
	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)
306
		
307
	unify_var_kinds expected_kind tv=:{tv_name, tv_info_ptr} th_vars error_admin
308
309
310
311
312
		# (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)
313
			TVI_Kind kind			
314
315
316
317
318
319
320
				| 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
321
		= checkError "inconsistent kind in" (arg_nr_to_string arg_nr) error_admin
322
323
324
325
326
327
328
329
330

	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)
		

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

332