checktypes.icl 91.5 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
3
implementation module checktypes

import StdEnv
Martin Wierich's avatar
Martin Wierich committed
4
import syntax, checksupport, check, typesupport, utilities,
5
		compilerSwitches // , RWSDebug
6
import genericsupport
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
7
8
9
10
11
12
13
14
15

::	TypeSymbols = 
	{	ts_type_defs		:: !.{# CheckedTypeDef}
	,	ts_cons_defs 		:: !.{# ConsDef}
	,	ts_selector_defs	:: !.{# SelectorDef}
	,	ts_modules			:: !.{# DclModule}
	}
	
::	TypeInfo =
16
17
	{	ti_var_heap			:: !.VarHeap
	,	ti_type_heaps		:: !.TypeHeaps
18
	,	ti_used_types		:: ![SymbolPtr]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
	}

::	CurrentTypeInfo =
	{	cti_module_index	:: !Index
	,	cti_type_index		:: !Index
	,	cti_lhs_attribute	:: !TypeAttribute
	}

class bindTypes type :: !CurrentTypeInfo !type !(!*TypeSymbols, !*TypeInfo, !*CheckState)
	-> (!type, !TypeAttribute, !(!*TypeSymbols, !*TypeInfo, !*CheckState))

instance bindTypes AType
where
	bindTypes cti atype=:{at_attribute,at_type} ts_ti_cs
		# (at_type, type_attr, (ts, ti, cs)) = bindTypes cti at_type ts_ti_cs
Martin Wierich's avatar
Martin Wierich committed
34
35
		  cs_error = check_attr_of_type_var at_attribute at_type cs.cs_error
		  (combined_attribute, cs_error) = check_type_attribute at_attribute type_attr cti.cti_lhs_attribute cs_error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
36
37
38
39
40
		= ({ atype & at_attribute = combined_attribute, at_type = at_type }, combined_attribute, (ts, ti, { cs & cs_error = cs_error }))
	where
		check_type_attribute :: !TypeAttribute !TypeAttribute !TypeAttribute !*ErrorAdmin -> (!TypeAttribute,!*ErrorAdmin)
		check_type_attribute TA_Anonymous type_attr root_attr error
			| try_to_combine_attributes type_attr root_attr
41
42
				= (to_root_attr root_attr, error)
//				= (root_attr, error)
Martin Wierich's avatar
Martin Wierich committed
43
				= (TA_Multi, checkError "conflicting attribution of type definition" "" error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
44
45
46
		check_type_attribute TA_Unique type_attr root_attr error
			| try_to_combine_attributes TA_Unique type_attr || try_to_combine_attributes TA_Unique root_attr
				= (TA_Unique, error)
Martin Wierich's avatar
Martin Wierich committed
47
				= (TA_Multi, checkError "conflicting attribution of type definition" "" error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
48
49
50
51
52
53
54
55
56
57
58
		check_type_attribute (TA_Var var) _ _ error
			= (TA_Multi, checkError var "attribute variable not allowed" error)
		check_type_attribute (TA_RootVar var) _ _ error
			= (TA_Multi, checkError var "attribute variable not allowed" error)
		check_type_attribute _ type_attr root_attr error
			= (type_attr, error)

		try_to_combine_attributes :: !TypeAttribute !TypeAttribute -> Bool
		try_to_combine_attributes TA_Multi _
			= True
		try_to_combine_attributes (TA_Var attr_var1) (TA_Var attr_var2)
59
			= attr_var1.av_ident == attr_var2.av_ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
60
61
62
63
64
65
		try_to_combine_attributes TA_Unique TA_Unique
			= True
		try_to_combine_attributes TA_Unique TA_Multi
			= True
		try_to_combine_attributes _ _
			= False
Martijn Vervoort's avatar
Martijn Vervoort committed
66

Martin Wierich's avatar
Martin Wierich committed
67
68
69
70
71
72
		check_attr_of_type_var :: !TypeAttribute !Type !*ErrorAdmin -> .ErrorAdmin 
		check_attr_of_type_var TA_Unique (TV var) error
			// the case "TA_Var" is catched by check_type_attribute
			= checkError var "uniqueness attribute not allowed" error
		check_attr_of_type_var attr _ error
			= error
73
74
75
76
77
78
	
		to_root_attr (TA_Var var)
			= TA_RootVar var
		to_root_attr attr
			= attr
					
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
79
80
instance bindTypes TypeVar
where
81
	bindTypes cti tv=:{tv_ident=var_id=:{id_info}} (ts, ti, cs=:{cs_symbol_table})
82
83
		# (var_def, cs_symbol_table) = readPtr id_info cs_symbol_table
		  cs = { cs & cs_symbol_table = cs_symbol_table }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
84
		= case var_def.ste_kind of
85
			STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
86
				# cs = { cs & cs_symbol_table = cs.cs_symbol_table <:= (id_info, { var_def & ste_kind = STE_BoundTypeVariable { bv & stv_count = inc stv_count }})}
87
				-> ({ tv & tv_info_ptr = stv_info_ptr}, stv_attribute, (ts, ti, cs))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
88
89
90
91
92
93
94
95
96
97
98
99
100
			_
				-> (tv, TA_Multi, (ts, ti, { cs & cs_error = checkError var_id "undefined" cs.cs_error }))

instance bindTypes [a] | bindTypes a
where
	bindTypes cti [] ts_ti_cs
		= ([], TA_Multi, ts_ti_cs)
	bindTypes cti [x : xs] ts_ti_cs
		# (x, _, ts_ti_cs) = bindTypes cti x ts_ti_cs
		  (xs, attr, ts_ti_cs) = bindTypes cti xs ts_ti_cs
		= ([x : xs], attr, ts_ti_cs)
	

101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
retrieveTypeDefinition :: SymbolPtr !Index !*SymbolTable ![SymbolPtr] -> ((!Index, !Index), !*SymbolTable, ![SymbolPtr])
retrieveTypeDefinition type_ptr mod_index symbol_table used_types
	# (entry, symbol_table)	= readPtr type_ptr symbol_table
	= case entry of
		({ste_kind = this_kind =: STE_Imported STE_Type decl_index, ste_def_level, ste_index})
			-> ((ste_index, decl_index), symbol_table <:= (type_ptr, { entry & ste_kind = STE_UsedType decl_index this_kind }), [type_ptr : used_types])
		({ste_kind = this_kind =: STE_Type, ste_def_level, ste_index})
			| ste_def_level == cGlobalScope
				-> ((ste_index, mod_index), symbol_table <:= (type_ptr, { entry & ste_kind = STE_UsedType mod_index this_kind }), [type_ptr : used_types])
				-> ((NotFound, mod_index), symbol_table, used_types)
		({ste_kind = STE_UsedType mod_index _, ste_def_level, ste_index})
			-> ((ste_index, mod_index), symbol_table, used_types)
		_
			-> ((NotFound, mod_index), symbol_table, used_types)

116
117
118
determine_type_attribute TA_Unique		= TA_Unique
determine_type_attribute _				= TA_Multi

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
119
120
121
122
123
instance bindTypes Type
where
	bindTypes cti (TV tv) ts_ti_cs
		# (tv, attr, ts_ti_cs) = bindTypes cti tv ts_ti_cs
		= (TV tv, attr, ts_ti_cs)
124
	bindTypes cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} type=:(TA type_cons=:{type_ident=type_ident=:{id_info}} types)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
125
					(ts=:{ts_type_defs,ts_modules}, ti, cs=:{cs_symbol_table})
126
127
128
		# ((type_index, type_module), cs_symbol_table, ti_used_types) = retrieveTypeDefinition id_info cti_module_index cs_symbol_table ti.ti_used_types
		  ti = { ti & ti_used_types = ti_used_types }
		# cs = { cs & cs_symbol_table = cs_symbol_table }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
129
		| type_index <> NotFound
130
			# ({td_arity,td_attribute,td_rhs},type_index,ts_type_defs,ts_modules) = getTypeDef type_index type_module cti_module_index ts_type_defs ts_modules
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
131
			  ts = { ts & ts_type_defs = ts_type_defs, ts_modules = ts_modules }
132
			| checkArityOfType type_cons.type_arity td_arity td_rhs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
133
134
135
136
137
				# (types, _, ts_ti_cs) = bindTypes cti types (ts, ti, cs)
				| type_module == cti_module_index && cti_type_index == type_index
					= (TA { type_cons & type_index = { glob_object = type_index, glob_module = type_module}} types, cti_lhs_attribute, ts_ti_cs)
					= (TA { type_cons & type_index = { glob_object = type_index, glob_module = type_module}} types,
								determine_type_attribute td_attribute, ts_ti_cs)
138
139
140
				= (TE, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_ident "used with wrong arity" cs.cs_error }))
			= (TE, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_ident "undefined" cs.cs_error}))
	bindTypes cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} type=:(TAS type_cons=:{type_ident=type_ident=:{id_info}} types strictness)
141
142
143
144
145
146
147
148
149
150
151
152
153
					(ts=:{ts_type_defs,ts_modules}, ti, cs=:{cs_symbol_table})
		# ((type_index, type_module), cs_symbol_table, ti_used_types) = retrieveTypeDefinition id_info cti_module_index cs_symbol_table ti.ti_used_types
		  ti = { ti & ti_used_types = ti_used_types }
		# cs = { cs & cs_symbol_table = cs_symbol_table }
		| type_index <> NotFound
			# ({td_arity,td_attribute,td_rhs},type_index,ts_type_defs,ts_modules) = getTypeDef type_index type_module cti_module_index ts_type_defs ts_modules
			  ts = { ts & ts_type_defs = ts_type_defs, ts_modules = ts_modules }
			| checkArityOfType type_cons.type_arity td_arity td_rhs
				# (types, _, ts_ti_cs) = bindTypes cti types (ts, ti, cs)
				| type_module == cti_module_index && cti_type_index == type_index
					= (TAS { type_cons & type_index = { glob_object = type_index, glob_module = type_module}} types strictness, cti_lhs_attribute, ts_ti_cs)
					= (TAS { type_cons & type_index = { glob_object = type_index, glob_module = type_module}} types strictness,
								determine_type_attribute td_attribute, ts_ti_cs)
154
155
				= (TE, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_ident "used with wrong arity" cs.cs_error }))
			= (TE, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_ident "undefined" cs.cs_error}))	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
156
157
158
159
	bindTypes cti (arg_type --> res_type) ts_ti_cs
		# (arg_type, _, ts_ti_cs) = bindTypes cti arg_type ts_ti_cs
		  (res_type, _, ts_ti_cs) = bindTypes cti res_type ts_ti_cs
		= (arg_type --> res_type, TA_Multi, ts_ti_cs)
160
161
162
163
164
//AA..
	bindTypes cti (TArrow1 type) ts_ti_cs
		# (type, _, ts_ti_cs) = bindTypes cti type ts_ti_cs
		= (TArrow1 type, TA_Multi, ts_ti_cs)	
//..AA		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
165
166
167
168
	bindTypes cti (CV tv :@: types) ts_ti_cs
		# (tv, type_attr, ts_ti_cs) = bindTypes cti tv ts_ti_cs
		  (types, _, ts_ti_cs) = bindTypes cti types ts_ti_cs
		= (CV tv :@: types, type_attr, ts_ti_cs)
169
170
171
172
173
174
175
// Sjaak 16-08-01
	bindTypes cti (TFA vars type) (ts, ti=:{ti_type_heaps}, cs)
		# (type_vars, (_, ti_type_heaps, cs)) = addTypeVariablesToSymbolTable cRankTwoScope vars [] ti_type_heaps cs
		  (type, _, (ts, ti, cs)) = bindTypes cti type (ts, {ti & ti_type_heaps = ti_type_heaps}, cs)
		  cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cRankTwoScope type_vars cs.cs_symbol_table
		= (TFA type_vars type, TA_Multi, (ts, ti, { cs & cs_symbol_table = cs_symbol_table }))
// ... Sjaak
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
	bindTypes cti type ts_ti_cs
		= (type, TA_Multi, ts_ti_cs)
	

addToAttributeEnviron :: !TypeAttribute !TypeAttribute ![AttrInequality] !*ErrorAdmin -> (![AttrInequality],!*ErrorAdmin)
addToAttributeEnviron TA_Multi _ attr_env error
	= (attr_env, error)
addToAttributeEnviron _ TA_Unique attr_env error
	= (attr_env, error)
addToAttributeEnviron (TA_Var attr_var) (TA_Var root_var) attr_env error
	| attr_var.av_info_ptr == root_var.av_info_ptr
		= (attr_env, error)
		= ([ { ai_demanded = attr_var, ai_offered = root_var } :  attr_env], error)
addToAttributeEnviron (TA_RootVar attr_var) root_attr attr_env error
	= (attr_env, error)
addToAttributeEnviron _ _ attr_env error
Martin Wierich's avatar
Martin Wierich committed
192
	= (attr_env, checkError "inconsistent attribution of type definition" "" error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
193

Martijn Vervoort's avatar
Martijn Vervoort committed
194
						
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
195
196
197

emptyIdent name :== { id_name = name, id_info = nilPtr }

198
199
checkTypeDef :: !Index !Index !*TypeSymbols !*TypeInfo !*CheckState -> (!*TypeSymbols, !*TypeInfo, !*CheckState);
checkTypeDef type_index module_index ts=:{ts_type_defs} ti=:{ti_type_heaps} cs=:{cs_error}
200
	# (type_def, ts_type_defs) = ts_type_defs![type_index]
201
	# {td_ident,td_pos,td_args,td_attribute,td_index} = type_def
202
	| td_index == NoIndex
203
		# position = newPosition td_ident td_pos
204
		  cs_error = pushErrorAdmin position cs_error
205
		  (td_attribute, attr_vars, th_attrs) = determine_root_attribute td_attribute td_ident.id_name ti_type_heaps.th_attrs
206
207
208
209
210
211
212
213
214
215
216
		  (type_vars, (attr_vars, ti_type_heaps, cs))
		  		= addTypeVariablesToSymbolTable cGlobalScope td_args attr_vars { ti_type_heaps & th_attrs = th_attrs } { cs & cs_error = cs_error }
		  type_def = {	type_def & td_args = type_vars, td_index = type_index, td_attrs = attr_vars, td_attribute = td_attribute }
		  (td_rhs, (ts, ti, cs)) = check_rhs_of_TypeDef type_def attr_vars
				{ cti_module_index = module_index, cti_type_index = type_index, cti_lhs_attribute = td_attribute }
					({ ts & ts_type_defs = ts_type_defs },{ ti & ti_type_heaps = ti_type_heaps}, cs)
		  (td_used_types, cs_symbol_table) = retrieve_used_types ti.ti_used_types cs.cs_symbol_table
		= ({ ts & ts_type_defs = { ts.ts_type_defs & [type_index] = { type_def & td_rhs = td_rhs, td_used_types = td_used_types }}}, { ti & ti_used_types = [] },
					{ cs &	cs_error = popErrorAdmin cs.cs_error,
							cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cGlobalScope type_vars cs_symbol_table})
		= ({ ts & ts_type_defs = ts_type_defs }, ti, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
217
218
219
where
	determine_root_attribute TA_None name attr_var_heap
		# (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap
220
		  new_var = { av_ident = emptyIdent name, av_info_ptr = attr_info_ptr}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
221
222
223
224
		= (TA_Var new_var, [new_var], attr_var_heap)
	determine_root_attribute TA_Unique name attr_var_heap
		= (TA_Unique, [], attr_var_heap)

225
226
227
228
	//
	check_rhs_of_TypeDef :: !CheckedTypeDef ![AttributeVar] !CurrentTypeInfo !(!*TypeSymbols, !*TypeInfo, !*CheckState)
		-> (!TypeRhs, !(!*TypeSymbols, !*TypeInfo, !*CheckState))
	//
229
	check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:AlgType conses} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs
230
		# type_lhs = { at_attribute = cti_lhs_attribute,
231
				  	   at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_ident td_arity)
232
									[{at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
233
234
		  ts_ti_cs = bind_types_of_constructors cti 0 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs conses ts_ti_cs
		= (td_rhs, ts_ti_cs)
235
	check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_constructor=rec_cons=:{ds_index}, rt_fields}}
236
			attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs
237
		# type_lhs = {	at_attribute = cti_lhs_attribute,
238
						at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_ident td_arity)
239
				[{ at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
		  (ts, ti, cs) = bind_types_of_constructors cti 0  [ atv_variable \\ {atv_variable} <- td_args]
		  						attr_vars type_lhs [rec_cons] ts_ti_cs
		# (rec_cons_def, ts) = ts!ts_cons_defs.[ds_index]
		# {cons_type = { st_vars,st_args,st_result,st_attr_vars }, cons_exi_vars} = rec_cons_def
		# (ts_selector_defs, ti_var_heap, cs_error) = check_selectors 0 rt_fields cti_type_index st_args st_result st_vars st_attr_vars cons_exi_vars
					ts.ts_selector_defs ti.ti_var_heap cs.cs_error
		= (td_rhs, ({ ts & ts_selector_defs = ts_selector_defs }, { ti & ti_var_heap = ti_var_heap }, { cs & cs_error = cs_error}))
	where
		check_selectors :: !Index !{# FieldSymbol} !Index ![AType] !AType ![TypeVar] ![AttributeVar] ![ATypeVar] !*{#SelectorDef} !*VarHeap !*ErrorAdmin
			-> (!*{#SelectorDef}, !*VarHeap, !*ErrorAdmin)
		check_selectors field_nr fields rec_type_index sel_types rec_type st_vars st_attr_vars exi_vars selector_defs var_heap error
			| field_nr < size fields
				# {fs_index} = fields.[field_nr]
				# (sel_def, selector_defs) = selector_defs![fs_index]
				  [sel_type : sel_types] = sel_types
				# (sel_type, (st_vars, st_attr_vars)) = lift_quantifier sel_type (st_vars, st_attr_vars)
				# (st_attr_env, error) = addToAttributeEnviron sel_type.at_attribute rec_type.at_attribute [] error
				# (new_type_ptr, var_heap) = newPtr VI_Empty var_heap
				  sd_type = { sel_def.sd_type &  st_arity = 1, st_args = [rec_type], st_result = sel_type, st_vars = st_vars,
				  				st_attr_vars = st_attr_vars, st_attr_env = st_attr_env }
				  selector_defs = { selector_defs & [fs_index] = { sel_def & sd_type = sd_type, sd_field_nr = field_nr, sd_type_index = rec_type_index,
				  									sd_type_ptr = new_type_ptr, sd_exi_vars = exi_vars  } }
				= check_selectors (inc field_nr) fields rec_type_index sel_types  rec_type st_vars st_attr_vars exi_vars selector_defs var_heap error
				= (selector_defs, var_heap, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
264
		where
265
266
267
268
			lift_quantifier at=:{at_type = TFA vars type} (type_vars, attr_vars)
				= ({ at & at_type = type}, foldSt add_var_and_attr vars (type_vars, attr_vars))
			lift_quantifier at (type_vars, attr_vars)
				= (at, (type_vars, attr_vars))
269
				
270
271
272
273
274
275
276
277
278
279
280
			add_var_and_attr {atv_variable, atv_attribute} (type_vars, attr_vars)
				= ([atv_variable : type_vars], add_attr_var atv_attribute attr_vars)
	
			add_attr_var (TA_Var av) attr_vars
				= [av : attr_vars]
			add_attr_var attr attr_vars
				= attr_vars
				
	check_rhs_of_TypeDef {td_rhs = SynType type} _ cti ts_ti_cs
		# (type, type_attr, ts_ti_cs) = bindTypes cti type ts_ti_cs
		= (SynType type, ts_ti_cs)
281
282
283
	check_rhs_of_TypeDef {td_rhs = AbstractSynType properties type} _ cti ts_ti_cs
		# (type, type_attr, ts_ti_cs) = bindTypes cti type ts_ti_cs
		= (AbstractSynType properties type, ts_ti_cs)
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
	check_rhs_of_TypeDef {td_rhs} _ _ ts_ti_cs
		= (td_rhs, ts_ti_cs)

	bind_types_of_constructors :: !CurrentTypeInfo !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymbol] !(!*TypeSymbols,!*TypeInfo,!*CheckState)
		-> (!*TypeSymbols, !*TypeInfo, !*CheckState)
	bind_types_of_constructors _ _ _ _ _ [] ts_ti_cs
		= ts_ti_cs
	bind_types_of_constructors cti=:{cti_lhs_attribute} cons_index free_vars free_attrs type_lhs [{ds_index}:conses] (ts=:{ts_cons_defs}, ti=:{ti_type_heaps}, cs)
		# (cons_def, ts_cons_defs) = ts_cons_defs![ds_index]
		# (exi_vars, (ti_type_heaps, cs))
		  		= addExistentionalTypeVariablesToSymbolTable cti_lhs_attribute cons_def.cons_exi_vars ti_type_heaps cs
		  (st_args, cons_arg_vars, st_attr_env, (ts, ti, cs))
		  		= bind_types_of_cons cons_def.cons_type.st_args cti free_vars []
		  				({ ts & ts_cons_defs = ts_cons_defs }, { ti  & ti_type_heaps = ti_type_heaps }, cs)
		  cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cGlobalScope /* cOuterMostLevel */ exi_vars cs.cs_symbol_table
		  (ts, ti, cs) = bind_types_of_constructors cti (inc cons_index) free_vars free_attrs type_lhs conses
								(ts, ti, { cs & cs_symbol_table = cs_symbol_table }) 
		  cons_type = { cons_def.cons_type & st_vars = free_vars, st_args = st_args, st_result = type_lhs, st_attr_vars = free_attrs, st_attr_env = st_attr_env }
		  (new_type_ptr, ti_var_heap) = newPtr VI_Empty ti.ti_var_heap
		= ({ ts & ts_cons_defs = { ts.ts_cons_defs & [ds_index] =
				{ cons_def & cons_type = cons_type, cons_index = cons_index, cons_type_index = cti.cti_type_index, cons_exi_vars = exi_vars,
						cons_type_ptr = new_type_ptr, cons_arg_vars = cons_arg_vars }}}, { ti & ti_var_heap = ti_var_heap }, cs)
306
//				---> ("bind_types_of_constructors", cons_def.cons_ident, exi_vars, cons_type)
307
	where
308
		bind_types_of_cons :: ![AType] !CurrentTypeInfo ![TypeVar] ![AttrInequality] !(!*TypeSymbols, !*TypeInfo, !*CheckState)
John van Groningen's avatar
John van Groningen committed
309
			-> (![AType], ![[ATypeVar]], ![AttrInequality], !(!*TypeSymbols, !*TypeInfo, !*CheckState))
310
311
312
313
314
315
316
317
318
319
		bind_types_of_cons [] cti free_vars attr_env ts_ti_cs
			= ([], [], attr_env, ts_ti_cs)
		bind_types_of_cons [type : types] cti free_vars attr_env ts_ti_cs
			# (types, local_vars_list, attr_env, ts_ti_cs)
					= bind_types_of_cons types cti free_vars attr_env ts_ti_cs
			  (type, type_attr, (ts, ti, cs)) = bindTypes cti type ts_ti_cs
			  (local_vars, cs_symbol_table) = foldSt retrieve_local_vars free_vars ([], cs.cs_symbol_table)
			  (attr_env, cs_error) = addToAttributeEnviron type_attr cti.cti_lhs_attribute attr_env cs.cs_error
			= ([type : types], [local_vars : local_vars_list], attr_env, (ts, ti , { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error }))
		where 
320
			retrieve_local_vars tv=:{tv_ident={id_info}} (local_vars, symbol_table)
321
322
323
324
				# (ste=:{ste_kind = STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count }}, symbol_table) = readPtr id_info symbol_table
				| stv_count == 0
					= (local_vars, symbol_table)
					
325
					= ([{ atv_variable = { tv & tv_info_ptr = stv_info_ptr}, atv_attribute = stv_attribute } : local_vars],
326
327
328
329
330
331
332
333
							symbol_table <:= (id_info, { ste & ste_kind = STE_BoundTypeVariable { bv & stv_count = 0}}))

	retrieve_used_types symb_ptrs symbol_table
		= foldSt retrieve_used_type symb_ptrs ([], symbol_table)
	where		
		retrieve_used_type symb_ptr (used_types, symbol_table)
			# (ste=:{ste_kind=STE_UsedType decl_index orig_kind,ste_index}, symbol_table) = readPtr symb_ptr symbol_table
			= ([{gi_module = decl_index, gi_index = ste_index} : used_types], symbol_table <:= (symb_ptr, { ste & ste_kind = orig_kind }))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
334
	
335
336
CS_Checked	:== 1
CS_Checking	:== 0
337

338
339
340
checkTypeDefs :: !Index !(Optional (CopiedDefinitions, Int)) !*{# CheckedTypeDef} !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*Heaps !*CheckState
	-> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*Heaps, !*CheckState)
checkTypeDefs module_index opt_icl_info type_defs cons_defs selector_defs modules heaps=:{hp_type_heaps,hp_var_heap} cs
341
	#! nr_of_types = size type_defs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
342
	#  ts = { ts_type_defs = type_defs, ts_cons_defs = cons_defs, ts_selector_defs = selector_defs, ts_modules = modules }
343
	   ti = { ti_type_heaps = hp_type_heaps, ti_var_heap = hp_var_heap, ti_used_types = [] }
344
345
	   ({ts_type_defs,ts_cons_defs, ts_selector_defs, ts_modules}, {ti_var_heap,ti_type_heaps}, cs)
	  		= iFoldSt (check_type_def module_index opt_icl_info) 0 nr_of_types (ts, ti, cs)
346
	= (ts_type_defs, ts_cons_defs, ts_selector_defs, ts_modules, {heaps& hp_var_heap=ti_var_heap, hp_type_heaps=ti_type_heaps}, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
347
where
348
349
350
351
352
353
354
355
356
357
	check_type_def module_index opt_icl_info type_index (ts, ti, cs)
		| has_to_be_checked module_index opt_icl_info type_index
			= checkTypeDef  type_index module_index ts ti cs
			= (ts, ti, cs)

	has_to_be_checked module_index No type_index
		= True
	has_to_be_checked module_index (Yes ({copied_type_defs}, n_cached_dcl_mods)) type_index
		= not (module_index < n_cached_dcl_mods && type_index < size copied_type_defs && copied_type_defs.[type_index])

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
358
359
360
361
362
363
364
365
366
367
368
369
370

::	OpenTypeInfo =
	{	oti_heaps		:: !.TypeHeaps
	,	oti_all_vars	:: ![TypeVar]
	,	oti_all_attrs	:: ![AttributeVar]
	,	oti_global_vars	:: ![TypeVar]
	}

::	OpenTypeSymbols =
	{	ots_type_defs	:: .{# CheckedTypeDef}
	,	ots_modules		:: .{# DclModule}
	}

371
determineAttributeVariable attr_var=:{av_ident=attr_name=:{id_info}} oti=:{oti_heaps,oti_all_attrs} symbol_table
372
	# (entry=:{ste_kind,ste_def_level}, symbol_table) = readPtr id_info symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
373
374
375
376
377
378
379
380
381
382
	| ste_kind == STE_Empty || ste_def_level == cModuleScope
		#! (new_attr_ptr, th_attrs) = newPtr AVI_Empty oti_heaps.th_attrs
		# symbol_table = symbol_table <:= (id_info,{	ste_index = NoIndex, ste_kind = STE_TypeAttribute new_attr_ptr,
														ste_def_level = cGlobalScope, ste_previous = entry })
		  new_attr = { attr_var & av_info_ptr = new_attr_ptr}
		= (new_attr, { oti & oti_heaps = { oti_heaps & th_attrs = th_attrs }, oti_all_attrs = [new_attr : oti_all_attrs] }, symbol_table)
		# (STE_TypeAttribute attr_ptr) = ste_kind
		= ({ attr_var & av_info_ptr = attr_ptr}, oti, symbol_table)

::	DemandedAttributeKind = DAK_Ignore | DAK_Unique | DAK_None
383
384
385
386
387
instance toString DemandedAttributeKind where
	toString DAK_Ignore = "DAK_Ignore"
	toString DAK_Unique = "DAK_Unique"
	toString DAK_None = "DAK_None"
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
388

389
newAttribute :: !DemandedAttributeKind {#Char} TypeAttribute !*OpenTypeInfo !*CheckState -> (!TypeAttribute, !*OpenTypeInfo, !*CheckState)
390
newAttribute DAK_Ignore var_ident attr oti cs
391
392
393
394
395
396
	= case attr of
		TA_Multi
			-> (TA_Multi, oti, cs)
		TA_None
			-> (TA_Multi, oti, cs)
		_
397
398
			-> (TA_Multi, oti, { cs & cs_error = checkError var_ident "attribute not allowed" cs.cs_error })
newAttribute DAK_Unique var_ident new_attr  oti cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
399
400
401
402
403
404
405
406
	= case new_attr of
		TA_Unique
			-> (TA_Unique, oti, cs)
		TA_Multi
			-> (TA_Unique, oti, cs)
		TA_None
			-> (TA_Unique, oti, cs)
		_
407
408
			-> (TA_Unique, oti, { cs & cs_error = checkError var_ident "inconsistently attributed (2)" cs.cs_error })
newAttribute DAK_None var_ident (TA_Var attr_var) oti cs=:{cs_symbol_table}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
409
410
	# (attr_var, oti, cs_symbol_table) = determineAttributeVariable attr_var oti cs_symbol_table
	= (TA_Var attr_var, oti, { cs & cs_symbol_table = cs_symbol_table })
411
newAttribute DAK_None var_ident TA_Anonymous oti=:{oti_heaps, oti_all_attrs} cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
412
	# (new_attr_ptr, th_attrs) = newPtr AVI_Empty oti_heaps.th_attrs
413
	  new_attr = { av_info_ptr = new_attr_ptr, av_ident = emptyIdent var_ident }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
414
	= (TA_Var new_attr, { oti & oti_heaps = { oti_heaps & th_attrs = th_attrs }, oti_all_attrs = [new_attr : oti_all_attrs] }, cs)
415
newAttribute DAK_None var_ident TA_Unique oti cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
416
	= (TA_Unique, oti, cs)
417
newAttribute DAK_None var_ident attr oti cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
418
419
420
421
422
423
	= (TA_Multi, oti, cs)
			

getTypeDef :: !Index !Index !Index !u:{# CheckedTypeDef} !v:{# DclModule} -> (!CheckedTypeDef, !Index , !u:{# CheckedTypeDef}, !v:{# DclModule})
getTypeDef type_index type_module module_index type_defs modules
	| type_module == module_index
424
		# (type_def, type_defs) = type_defs![type_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
425
		= (type_def, type_index, type_defs, modules)
426
		# ({dcl_common={com_type_defs}}, modules) = modules![type_module]
427
		  type_def = com_type_defs.[type_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
428
429
		= (type_def, type_index, type_defs, modules)

430
431
432
433
434
checkArityOfType act_arity form_arity (SynType _)
	= form_arity == act_arity
checkArityOfType act_arity form_arity _
	= form_arity >= act_arity

435
436
437
checkAbstractType type_index(AbstractType _)			= type_index <> cPredefinedModuleIndex 
checkAbstractType type_index (AbstractSynType _ _)		= type_index <> cPredefinedModuleIndex 
checkAbstractType _ _									= False
438

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
439
440
441
442
getClassDef :: !Index !Index !Index !u:{# ClassDef} !v:{# DclModule} -> (!ClassDef, !Index , !u:{# ClassDef}, !v:{# DclModule})
getClassDef class_index type_module module_index class_defs modules
	| type_module == module_index
		#! si = size class_defs
443
		# (class_def, class_defs) = class_defs![class_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
444
		= (class_def, class_index, class_defs, modules)
445
		# ({dcl_common={com_class_defs}}, modules) = modules![type_module]
446
		  class_def = com_class_defs.[class_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
447
448
		= (class_def, class_index, class_defs, modules)

449
450
451
452
453
454
getGenericDef :: !Index !Index !Index !u:{# GenericDef} !v:{# DclModule} -> (!GenericDef, !Index , !u:{# GenericDef}, !v:{# DclModule})
getGenericDef generic_index type_module module_index generic_defs modules
	| type_module == module_index
		#! si = size generic_defs
		# (generic_def, generic_defs) = generic_defs![generic_index]
		= (generic_def, generic_index, generic_defs, modules)
455
		# ({dcl_common={com_generic_defs}}, modules) = modules![type_module]
456
457
		  generic_def = com_generic_defs.[generic_index]
		= (generic_def, generic_index, generic_defs, modules)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
458

459
460
checkTypeVar :: !Level !DemandedAttributeKind !TypeVar !TypeAttribute !(!*OpenTypeInfo, !*CheckState)
					-> (! TypeVar, !TypeAttribute, !(!*OpenTypeInfo, !*CheckState))
461
checkTypeVar scope dem_attr tv=:{tv_ident=var_ident=:{id_name,id_info}} tv_attr (oti, cs=:{cs_symbol_table})
462
	# (entry=:{ste_kind,ste_def_level},cs_symbol_table) = readPtr id_info cs_symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
463
	| ste_kind == STE_Empty || ste_def_level == cModuleScope
464
		# (new_attr, oti=:{oti_heaps,oti_all_vars}, cs) = newAttribute dem_attr id_name tv_attr oti { cs & cs_symbol_table = cs_symbol_table }
465
		  (new_var_ptr, th_vars) = newPtr (TVI_AttrAndRefCount new_attr 1) oti_heaps.th_vars
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
466
		  new_var = { tv & tv_info_ptr = new_var_ptr }
467
		= (new_var, new_attr, ({ oti & oti_heaps = { oti_heaps & th_vars = th_vars }, oti_all_vars = [new_var : oti_all_vars]},
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
468
469
470
471
				{ cs & cs_symbol_table = cs.cs_symbol_table <:= (id_info, {ste_index = NoIndex, ste_kind = STE_TypeVariable new_var_ptr,
								ste_def_level = scope, ste_previous = entry })}))
		# (STE_TypeVariable tv_info_ptr) = ste_kind
		  {oti_heaps} = oti
472
473
474
		  (tv_info, th_vars) = readPtr tv_info_ptr oti_heaps.th_vars
		  th_vars = incr_ref_count tv_info_ptr tv_info th_vars	
		  (var_attr, oti, cs) = check_attribute id_name dem_attr tv_info tv_attr { oti & oti_heaps = { oti_heaps & th_vars = th_vars }}
475
476
		  								{ cs & cs_symbol_table = cs_symbol_table }
		= ({ tv & tv_info_ptr = tv_info_ptr }, var_attr, (oti, cs))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
477
where
478
479
480
481
482
	incr_ref_count tv_info_ptr (TVI_AttrAndRefCount prev_attr ref_count) th_vars
		= th_vars <:=	(tv_info_ptr, TVI_AttrAndRefCount prev_attr (inc ref_count))			
	incr_ref_count tv_info_ptr _ th_vars
		= th_vars

483
	check_attribute var_ident DAK_Ignore (TVI_AttrAndRefCount prev_attr ref_count) this_attr oti cs=:{cs_error}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
484
		= (TA_Multi, oti, cs)
485
486
	check_attribute var_ident dem_attr (TVI_AttrAndRefCount prev_attr ref_count) this_attr oti cs=:{cs_error}
		# (new_attr, cs_error) = determine_attribute var_ident dem_attr this_attr cs_error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
487
488
489
490
491
492
493
		= check_var_attribute prev_attr new_attr oti { cs & cs_error = cs_error }
	where					
		check_var_attribute (TA_Var old_var) (TA_Var new_var) oti cs=:{cs_symbol_table,cs_error}
			# (new_var, oti, cs_symbol_table) = determineAttributeVariable new_var oti cs_symbol_table
			| old_var.av_info_ptr == new_var.av_info_ptr
				= (TA_Var old_var, oti, { cs &  cs_symbol_table = cs_symbol_table })
				= (TA_Var old_var, oti, { cs &  cs_symbol_table = cs_symbol_table,
494
						cs_error = checkError new_var.av_ident "inconsistently attributed (3)" cs_error })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
495
496
497
498
499
500
501
		check_var_attribute var_attr=:(TA_Var old_var) TA_Anonymous oti cs
			= (var_attr, oti, cs)
		check_var_attribute TA_Unique new_attr oti cs
			= case new_attr of
				TA_Unique
					-> (TA_Unique, oti, cs)
				_
502
					-> (TA_Unique, oti, { cs & cs_error = checkError var_ident "inconsistently attributed (4)" cs.cs_error })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
503
504
505
506
507
508
509
		check_var_attribute TA_Multi new_attr oti cs
			= case new_attr of
				TA_Multi
					-> (TA_Multi, oti, cs)
				TA_None
					-> (TA_Multi, oti, cs)
				_
510
					-> (TA_Multi, oti, { cs & cs_error = checkError var_ident "inconsistently attributed (5)" cs.cs_error })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
511
		check_var_attribute var_attr new_attr oti cs
512
			= (var_attr, oti, { cs & cs_error = checkError var_ident "inconsistently attributed (6)" cs.cs_error })// ---> (var_attr, new_attr)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
513
514
		
		
515
		determine_attribute var_ident DAK_Unique new_attr error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
516
517
518
519
520
521
522
523
			= case new_attr of
				 TA_Multi
				 	-> (TA_Unique, error)
				 TA_None
				 	-> (TA_Unique, error)
				 TA_Unique
				 	-> (TA_Unique, error)
				 _
524
525
				 	-> (TA_Unique, checkError var_ident "inconsistently attributed (1)" error)
		determine_attribute var_ident dem_attr TA_None error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
526
			= (TA_Multi, error)
527
		determine_attribute var_ident dem_attr new_attr error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
528
529
			= (new_attr, error)

530
	check_attribute var_ident dem_attr _ this_attr oti cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
531
532
		= (TA_Multi, oti, cs)

533
534
535
536
537
538
539
540
541
542
543
544
545
546
check_args_of_type_cons :: !Index !Int !DemandedAttributeKind ![AType] ![ATypeVar] !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)
	-> (![AType], !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState))
check_args_of_type_cons mod_index scope dem_attr_kind [] _ cot_state
	= ([], cot_state)
check_args_of_type_cons mod_index scope dem_attr_kind [arg_type : arg_types] [ {atv_attribute} : td_args ] cot_state
	# (arg_type, cot_state) = checkOpenAType mod_index scope (new_demanded_attribute dem_attr_kind /* DAK_None */ atv_attribute) arg_type cot_state
	  (arg_types, cot_state) = check_args_of_type_cons mod_index scope dem_attr_kind arg_types td_args cot_state
	= ([arg_type : arg_types], cot_state)

new_demanded_attribute DAK_Ignore _
	= DAK_Ignore
new_demanded_attribute _ TA_Unique
	= DAK_Unique
new_demanded_attribute dem_attr_kind _
547
	= DAK_None /* dem_attr_kind */
548

549
550
checkOpenAType :: !Index !Int !DemandedAttributeKind !AType !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)
	-> (!AType, !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState))
551
checkOpenAType mod_index scope dem_attr type=:{at_type = TV tv, at_attribute} (ots, oti, cs)
552
	# (tv, at_attribute, (oti, cs)) = checkTypeVar scope dem_attr tv at_attribute (oti, cs) 
553
	= ({ type & at_type = TV tv, at_attribute = at_attribute }, (ots, oti, cs))
554
555
556
checkOpenAType mod_index scope dem_attr type=:{at_type = GTV var_id=:{tv_ident={id_info}}, at_attribute} (ots, oti, cs)
	# (new_attr, oti=:{oti_heaps,oti_global_vars}, cs=:{cs_symbol_table}) = newAttribute dem_attr "GTV" at_attribute oti cs
	  (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
557
	  (type_var, oti_global_vars, th_vars, entry) = retrieve_global_variable var_id entry oti_global_vars oti_heaps.th_vars
558
	= ({type & at_type = TV type_var, at_attribute = new_attr }, (ots, { oti & oti_heaps = { oti_heaps & th_vars = th_vars }, oti_global_vars = oti_global_vars },
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
								{ cs & cs_symbol_table = cs_symbol_table <:= (id_info, entry) }))
where
	retrieve_global_variable var entry=:{ste_kind = STE_Empty} global_vars var_heap
		# (new_var_ptr, var_heap) = newPtr TVI_Used var_heap
		  var = { var & tv_info_ptr = new_var_ptr }
		= (var, [var : global_vars], var_heap, 
				{ entry  & ste_kind = STE_TypeVariable new_var_ptr, ste_def_level = cModuleScope, ste_previous = entry }) 
	retrieve_global_variable var entry=:{ste_kind,ste_def_level, ste_previous} global_vars var_heap
		| ste_def_level == cModuleScope
			= case ste_kind of
				STE_TypeVariable glob_info_ptr
					# var = { var & tv_info_ptr = glob_info_ptr }
					  (var_info, var_heap) = readPtr glob_info_ptr var_heap
					-> case var_info of
						TVI_Empty
							-> (var, [var : global_vars], var_heap <:= (glob_info_ptr, TVI_Used), entry)
						TVI_Used
							-> (var, global_vars, var_heap, entry)
			# (var, global_vars, var_heap, ste_previous) = retrieve_global_variable var ste_previous global_vars var_heap
			= (var, global_vars, var_heap, { entry & ste_previous = ste_previous })
579
//
580
checkOpenAType mod_index scope dem_attr_kind type=:{ at_type=TA type_cons=:{type_ident=type_ident=:{id_name,id_info}} types, at_attribute}
581
		(ots=:{ots_type_defs,ots_modules}, oti, cs=:{cs_symbol_table,cs_x={x_check_dynamic_types}})
582
583
584
	# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
	  cs = { cs & cs_symbol_table = cs_symbol_table }
	  (type_index, type_module) = retrieveGlobalDefinition entry STE_Type mod_index
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
585
	| type_index <> NotFound
586
		# ({td_arity,td_args,td_attribute,td_rhs},type_index,ots_type_defs,ots_modules) = getTypeDef type_index type_module mod_index ots_type_defs ots_modules
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
587
		  ots = { ots & ots_type_defs = ots_type_defs, ots_modules = ots_modules }
588
		| x_check_dynamic_types && checkAbstractType type_module td_rhs
589
			= (type, (ots, oti, {cs & cs_error = checkError type_ident "(abstract type) not permitted in a dynamic type" cs.cs_error}))
590
591
592
593
594
595

			| checkArityOfType type_cons.type_arity td_arity td_rhs
				# type_cons = { type_cons & type_index = { glob_object = type_index, glob_module = type_module }}
				  (types, (ots, oti, cs)) = check_args_of_type_cons mod_index scope dem_attr_kind types td_args (ots, oti, cs)
				  (new_attr, oti, cs) = newAttribute (new_demanded_attribute dem_attr_kind td_attribute) id_name at_attribute oti cs
				= ({ type & at_type = TA type_cons types, at_attribute = new_attr } , (ots, oti, cs))
596
597
598
				= (type, (ots, oti, {cs & cs_error = checkError type_ident "used with wrong arity" cs.cs_error}))
		= (type, (ots, oti, {cs & cs_error = checkError type_ident "undefined" cs.cs_error}))
checkOpenAType mod_index scope dem_attr type=:{ at_type=TAS type_cons=:{type_ident=type_ident=:{id_name,id_info}} types strictness, at_attribute}
599
600
601
602
603
604
605
606
607
608
609
610
		(ots=:{ots_type_defs,ots_modules}, oti, cs=:{cs_symbol_table})
	# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
	  cs = { cs & cs_symbol_table = cs_symbol_table }
	  (type_index, type_module) = retrieveGlobalDefinition entry STE_Type mod_index
	| type_index <> NotFound
		# ({td_arity,td_args,td_attribute,td_rhs},type_index,ots_type_defs,ots_modules) = getTypeDef type_index type_module mod_index ots_type_defs ots_modules
		  ots = { ots & ots_type_defs = ots_type_defs, ots_modules = ots_modules }
		| checkArityOfType type_cons.type_arity td_arity td_rhs
			# type_cons = { type_cons & type_index = { glob_object = type_index, glob_module = type_module }}
			  (types, (ots, oti, cs)) = check_args_of_type_cons mod_index scope dem_attr types td_args (ots, oti, cs)
			  (new_attr, oti, cs) = newAttribute (new_demanded_attribute dem_attr td_attribute) id_name at_attribute oti cs
			= ({ type & at_type = TAS type_cons types strictness, at_attribute = new_attr} , (ots, oti, cs)) 
611
612
			= (type, (ots, oti, {cs & cs_error = checkError type_ident "used with wrong arity" cs.cs_error}))
		= (type, (ots, oti, {cs & cs_error = checkError type_ident "undefined" cs.cs_error}))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
613
614
615
616
617
checkOpenAType mod_index scope dem_attr type=:{at_type = arg_type --> result_type, at_attribute} cot_state
	# (arg_type, cot_state) = checkOpenAType mod_index scope DAK_None arg_type cot_state
	  (result_type, (ots, oti, cs)) = checkOpenAType mod_index scope DAK_None result_type cot_state
	  (new_attr, oti, cs) = newAttribute dem_attr "-->" at_attribute oti cs
	= ({ type & at_type = arg_type --> result_type, at_attribute = new_attr }, (ots, oti, cs))
618
619
620
621
622
623
//AA..
checkOpenAType mod_index scope dem_attr type=:{at_type = TArrow1 arg_type, at_attribute} cot_state
	# (arg_type, (ots, oti, cs)) = checkOpenAType mod_index scope DAK_None arg_type cot_state
	  (new_attr, oti, cs) = newAttribute dem_attr "TArrow1" at_attribute oti cs
	= ({ type & at_type = TArrow1 arg_type, at_attribute = new_attr }, (ots, oti, cs))
//..AA
624
/*
625
checkOpenAType mod_index scope dem_attr type=:{at_type = CV tv :@: types, at_attribute} (ots, oti, cs)
626
	# (cons_var, _, (oti, cs)) = checkTypeVar scope DAK_None tv TA_Multi (oti, cs)
627
	  (types, (ots, oti, cs)) = mapSt (checkOpenAType mod_index scope DAK_None) types (ots, oti, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
628
629
	  (new_attr, oti, cs) = newAttribute dem_attr ":@:" at_attribute oti cs
	= ({ type & at_type = CV cons_var :@: types, at_attribute = new_attr }, (ots, oti, cs))
630
631
632
633
634
*/
checkOpenAType mod_index scope dem_attr type=:{at_type = CV tv :@: types, at_attribute} (ots, oti, cs)
	# (cons_var, var_attr, (oti, cs)) = checkTypeVar scope dem_attr tv at_attribute (oti, cs)
	  (types, (ots, oti, cs)) = mapSt (checkOpenAType mod_index scope DAK_None) types (ots, oti, cs)
	= ({ type & at_type = CV cons_var :@: types, at_attribute = var_attr }, (ots, oti, cs))
635
636
637
638
639
640
checkOpenAType mod_index scope dem_attr atype=:{at_type = TFA vars type, at_attribute} (ots, oti, cs)
	# (vars, (oti, cs)) = mapSt add_universal_var vars  (oti, cs) 
	  (checked_type, (ots, oti, cs)) = checkOpenAType mod_index cRankTwoScope dem_attr { atype & at_type = type } (ots, oti, cs)
	  cs = { cs & cs_symbol_table = foldSt remove_universal_var vars cs.cs_symbol_table }
	= ( { checked_type & at_type = TFA vars checked_type.at_type }, (ots, oti, cs))
where
641
	add_universal_var atv=:{atv_variable = tv=:{tv_ident={id_name,id_info}}, atv_attribute} (oti, cs=:{cs_symbol_table,cs_error})
642
643
644
		# (entry=:{ste_kind,ste_def_level},cs_symbol_table) = readPtr id_info cs_symbol_table
		| ste_kind == STE_Empty || ste_def_level < cRankTwoScope
			# (new_attr, oti=:{oti_heaps}, cs) = newAttribute DAK_None id_name atv_attribute oti { cs & cs_symbol_table = cs_symbol_table }
645
			  (new_var_ptr, th_vars) = newPtr (TVI_AttrAndRefCount new_attr 1) oti_heaps.th_vars
646
647
648
649
650
651
			= ({atv & atv_variable = { tv & tv_info_ptr = new_var_ptr}, atv_attribute = new_attr }, 
					({ oti & oti_heaps = { oti_heaps & th_vars = th_vars }}, { cs & cs_symbol_table =
							cs.cs_symbol_table <:= (id_info, {ste_index = NoIndex, ste_kind = STE_TypeVariable new_var_ptr,
									ste_def_level = cRankTwoScope, ste_previous = entry })}))
			= (atv, (oti, { cs & cs_error = checkError id_name "type variable already undefined" cs_error, cs_symbol_table = cs_symbol_table }))

652
653
654
655
	remove_universal_var {atv_variable = {tv_ident}, atv_attribute = TA_Var {av_ident}} cs_symbol_table
		= removeDefinitionFromSymbolTable cGlobalScope av_ident (removeDefinitionFromSymbolTable cRankTwoScope tv_ident cs_symbol_table)
	remove_universal_var {atv_variable = {tv_ident}} cs_symbol_table
		= removeDefinitionFromSymbolTable cRankTwoScope tv_ident cs_symbol_table
656

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
657
658
659
660
661
662
663
664
checkOpenAType mod_index scope dem_attr type=:{at_attribute} (ots, oti, cs)
	# (new_attr, oti, cs) = newAttribute dem_attr "." at_attribute oti cs
	= ({ type & at_attribute = new_attr}, (ots, oti, cs))

checkOpenTypes mod_index scope dem_attr types cot_state
	= mapSt (checkOpenType mod_index scope dem_attr) types cot_state

checkOpenType mod_index scope dem_attr type cot_state
665
	# ({at_type}, cot_state) = checkOpenAType mod_index scope dem_attr { at_type = type, at_attribute = TA_Multi } cot_state
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
666
667
668
669
670
	= (at_type, cot_state)
	
checkOpenATypes mod_index scope types cot_state
	= mapSt (checkOpenAType mod_index scope DAK_None) types cot_state

Martin Wierich's avatar
Martin Wierich committed
671
checkInstanceType :: !Index !(Global DefinedSymbol) !InstanceType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
672
	-> (!InstanceType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
Martin Wierich's avatar
Martin Wierich committed
673
674
675
676
checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_defs class_defs modules heaps cs
	# cs_error
			= check_fully_polymorphity it_types it_context cs.cs_error
	  ots = { ots_type_defs = type_defs, ots_modules = modules }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
677
	  oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars= [] }
678
679
	  (it_types, (ots, oti=:{oti_all_vars = it_vars, oti_all_attrs = it_attr_vars}, cs))
	  	= checkOpenTypes mod_index cGlobalScope DAK_None it_types (ots, oti, { cs & cs_error = cs_error })
680
681
	  (heaps, cs) = check_linearity_of_type_vars it_vars oti.oti_heaps cs
	  oti = { oti &  oti_all_vars = [], oti_all_attrs = [], oti_heaps = heaps }
682
683
	  (it_context, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts it_context mod_index class_defs ots oti cs
	  cs_error = foldSt (compare_context_and_instance_types ins_class it_types) it_context cs.cs_error
Martin Wierich's avatar
Martin Wierich committed
684
	  (specials, cs) = checkSpecialTypeVars specials { cs & cs_error = cs_error }
685
686
	  cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope it_vars cs.cs_symbol_table
	  cs_symbol_table = removeAttributesFromSymbolTable it_attr_vars cs_symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
687
	  (specials, type_defs, modules, heaps, cs) = checkSpecialTypes mod_index specials type_defs modules heaps { cs & cs_symbol_table = cs_symbol_table }
688
	= ({it & it_vars = it_vars, it_types = it_types, it_attr_vars = it_attr_vars, it_context = it_context },
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
689
	    	specials, type_defs, class_defs, modules, heaps, cs)
Martin Wierich's avatar
Martin Wierich committed
690
691
692
  where
	check_fully_polymorphity it_types it_context cs_error
		| all is_type_var it_types && not (isEmpty it_context)
Martin Wierich's avatar
Martin Wierich committed
693
			= checkError "context restriction not allowed for fully polymorph instance" "" cs_error
Martin Wierich's avatar
Martin Wierich committed
694
695
696
697
		= cs_error
	  where
		is_type_var (TV _) = True
		is_type_var _ = False
698
	
699
700
701
702
	check_linearity_of_type_vars vars heaps=:{th_vars} cs=:{cs_error}
		# (th_vars, cs_error) = foldSt check_linearity vars (th_vars, cs_error)
		= ({heaps & th_vars = th_vars}, {cs & cs_error = cs_error})
	where
703
		check_linearity {tv_ident, tv_info_ptr} (th_vars, error)
704
705
			# (TVI_AttrAndRefCount prev_attr ref_count, th_vars) = readPtr tv_info_ptr th_vars
			| ref_count > 1
706
				= (th_vars, checkError tv_ident ": this type variable occurs more than once in an instance type" error)
707
708
709
710
				= (th_vars, error)
			
		
	
711
712
713
714
	compare_context_and_instance_types ins_class it_types {tc_class=TCGeneric _, tc_types} cs_error
		= cs_error
	compare_context_and_instance_types ins_class it_types {tc_class=TCClass clazz, tc_types} cs_error
		| ins_class<>clazz
Martin Wierich's avatar
Martin Wierich committed
715
716
717
718
719
720
721
722
723
			= cs_error
		# are_equal
				= fold2St compare_context_and_instance_type it_types tc_types True
		| are_equal
			= checkError ins_class.glob_object.ds_ident "context restriction equals instance type" cs_error
		= cs_error
	  where
		compare_context_and_instance_type (TA {type_index=ti1} _) (TA {type_index=ti2} _) are_equal_accu
			= ti1==ti2 && are_equal_accu
724
725
726
727
728
729
		compare_context_and_instance_type (TA {type_index=ti1} _) (TAS {type_index=ti2} _ _) are_equal_accu
			= ti1==ti2 && are_equal_accu
		compare_context_and_instance_type (TAS {type_index=ti1} _ _) (TA {type_index=ti2} _) are_equal_accu
			= ti1==ti2 && are_equal_accu
		compare_context_and_instance_type (TAS {type_index=ti1} _ _) (TAS {type_index=ti2} _ _) are_equal_accu
			= ti1==ti2 && are_equal_accu
Martin Wierich's avatar
Martin Wierich committed
730
731
		compare_context_and_instance_type (_ --> _) (_ --> _) are_equal_accu
			= are_equal_accu
732
733
734
735
736
737
//AA..
		compare_context_and_instance_type TArrow TArrow are_equal_accu
			= are_equal_accu	
		compare_context_and_instance_type (TArrow1 _) (TArrow1 _) are_equal_accu
			= are_equal_accu	
//..AA			
Martin Wierich's avatar
Martin Wierich committed
738
739
740
741
742
743
744
745
746
		compare_context_and_instance_type (CV tv1 :@: _) (CV tv2 :@: _) are_equal_accu
			= tv1==tv2 && are_equal_accu
		compare_context_and_instance_type (TB bt1) (TB bt2) are_equal_accu
			= bt1==bt2 && are_equal_accu
		compare_context_and_instance_type (TV tv1) (TV tv2) are_equal_accu
			= tv1==tv2 && are_equal_accu
		compare_context_and_instance_type _ _ are_equal_accu
			= False

747
748
749
750
751
752
753
754
755
756
757
checkFunctionType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
	-> (!SymbolType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkFunctionType mod_index st specials type_defs class_defs modules heaps cs
	= checkSymbolType True mod_index st specials type_defs class_defs modules heaps cs

checkMemberType :: !Index !SymbolType !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
	-> (!SymbolType, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkMemberType mod_index st type_defs class_defs modules heaps cs
	# (checked_st, specials, type_defs, class_defs, modules, heaps, cs) 
			= checkSymbolType False mod_index st SP_None type_defs class_defs modules heaps cs
	= (checked_st, type_defs, class_defs, modules, heaps, cs) 
Martin Wierich's avatar
Martin Wierich committed
758

759
checkSymbolType :: !Bool !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
760
	-> (!SymbolType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
761
checkSymbolType is_function mod_index st=:{st_args,st_result,st_context,st_attr_env} specials type_defs class_defs modules heaps cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
762
763
764
	# ots = { ots_type_defs = type_defs, ots_modules = modules }
	  oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars= [] }
	  (st_args, cot_state) = checkOpenATypes mod_index cGlobalScope st_args (ots, oti, cs)
765
//	   ---> ("checkSymbolType", st_args))
766
767
768
769
770
	  (st_result, (ots, oti=:{oti_all_vars = st_vars,oti_all_attrs = st_attr_vars}, cs))
	  	= checkOpenAType mod_index cGlobalScope DAK_None st_result cot_state
	  oti = { oti &  oti_all_vars = [], oti_all_attrs = [] }
	  (st_context, type_defs, class_defs, modules, heaps, cs) = check_type_contexts is_function st_context mod_index class_defs ots oti cs
	  (st_attr_env, cs) = mapSt check_attr_inequality st_attr_env cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
771
	  (specials, cs) = checkSpecialTypeVars specials cs 
772
773
	  cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope st_vars cs.cs_symbol_table
	  cs_symbol_table = removeAttributesFromSymbolTable st_attr_vars cs_symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
774
	  (specials, type_defs, modules, heaps, cs) = checkSpecialTypes mod_index specials type_defs modules heaps { cs & cs_symbol_table = cs_symbol_table }
775
776
	  checked_st = {st & st_vars = st_vars, st_args = st_args, st_result = st_result, st_context = st_context,
	    					st_attr_vars = st_attr_vars, st_attr_env = st_attr_env }
777
	= (checked_st, specials, type_defs, class_defs, modules, heaps, cs)
778
//			---> ("checkSymbolType", checked_st)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
779
where
780
	check_attr_inequality ineq=:{ai_demanded=ai_demanded=:{av_ident=dem_name},ai_offered=ai_offered=:{av_ident=off_name}} cs=:{cs_symbol_table,cs_error}
781
		# (dem_entry, cs_symbol_table) = readPtr dem_name.id_info cs_symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
782
783
		# (found_dem_attr, dem_attr_ptr) = retrieve_attribute dem_entry
		| found_dem_attr
784
		   	# (off_entry, cs_symbol_table) = readPtr off_name.id_info cs_symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
785
786
			# (found_off_attr, off_attr_ptr) = retrieve_attribute off_entry
			| found_off_attr
787
788
789
790
				= ({ai_demanded = { ai_demanded & av_info_ptr = dem_attr_ptr }, ai_offered = { ai_offered & av_info_ptr = off_attr_ptr }},
						{ cs & cs_symbol_table = cs_symbol_table })
				= (ineq, { cs & cs_error = checkError off_name "attribute variable undefined" cs_error, cs_symbol_table = cs_symbol_table })
			= (ineq, { cs & cs_error = checkError dem_name "attribute variable undefined" cs_error, cs_symbol_table = cs_symbol_table })
791
792
793
794
795
796
797
798
799
800
801
802
	where
		retrieve_attribute {ste_kind = STE_TypeAttribute attr_ptr, ste_def_level, ste_index}
			| ste_def_level == cGlobalScope
				= (True, attr_ptr)
		retrieve_attribute entry
			= (False, abort "no attribute")

	check_type_contexts is_function st_context mod_index class_defs ots oti cs
		| is_function
		 	= checkTypeContexts st_context mod_index class_defs ots oti cs
			= check_member_contexts st_context mod_index class_defs ots oti cs

803
804
805
806
// AA.. generic members do not have a context at the moment of checking
	check_member_contexts [] mod_index class_defs ots oti cs
		= checkTypeContexts [] mod_index class_defs ots oti cs
// ..AA
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
	check_member_contexts [tc : tcs] mod_index class_defs ots oti cs
		# (tc, (class_defs, ots, oti, cs)) = checkTypeContext mod_index tc  (class_defs, ots, oti, cs)
		  cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope [ tv \\ (TV tv) <- tc.tc_types] cs.cs_symbol_table
		  (tcs, type_defs, class_defs, modules, heaps, cs) =  checkTypeContexts tcs mod_index class_defs ots oti { cs & cs_symbol_table = cs_symbol_table }
		= ([tc : tcs], type_defs, class_defs, modules, heaps, cs)

NewEntry symbol_table symb_ptr def_kind def_index level previous :==
	 symbol_table <:= (symb_ptr,{  ste_kind = def_kind, ste_index = def_index, ste_def_level = level, ste_previous = previous })

checkSuperClasses :: ![TypeVar] ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
	-> (![TypeVar], ![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkSuperClasses class_args class_contexts mod_index type_defs class_defs modules heaps=:{th_vars} cs=:{cs_symbol_table,cs_error}
	# (rev_class_args, cs_symbol_table, th_vars, cs_error)
			= foldSt add_variable_to_symbol_table class_args ([], cs_symbol_table, th_vars, cs_error)
	  cs = {cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error }
	  ots = { ots_modules = modules, ots_type_defs = type_defs }
	  oti = { oti_heaps = { heaps & th_vars = th_vars }, oti_all_vars = [], oti_all_attrs = [], oti_global_vars = [] }
	  (class_contexts, type_defs, class_defs, modules, type_heaps, cs)
		  		= checkTypeContexts class_contexts mod_index class_defs ots oti cs
	  (class_args, cs_symbol_table) = retrieve_variables_from_symbol_table rev_class_args [] cs.cs_symbol_table
	= (class_args, class_contexts, type_defs, class_defs, modules, type_heaps, {cs & cs_symbol_table = cs_symbol_table})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
828
where
829
830
	add_variable_to_symbol_table :: !TypeVar !(![TypeVar], !*SymbolTable, !*TypeVarHeap, !*ErrorAdmin)
		-> (![TypeVar],!*SymbolTable,!*TypeVarHeap,!*ErrorAdmin)
831
	add_variable_to_symbol_table tv=:{tv_ident={id_name,id_info}} (rev_class_args, symbol_table, th_vars, error)
832
833
834
835
836
837
838
839
	  	# (entry, symbol_table) = readPtr id_info symbol_table
		| entry.ste_kind == STE_Empty || entry.ste_def_level < cGlobalScope
			# (new_var_ptr, th_vars) = newPtr TVI_Empty th_vars
			# symbol_table = NewEntry symbol_table id_info (STE_TypeVariable new_var_ptr) NoIndex cGlobalScope entry
			= ([{ tv & tv_info_ptr = new_var_ptr} : rev_class_args], symbol_table, th_vars, error)
			= (rev_class_args, symbol_table, th_vars, checkError id_name "(variable) already defined" error)

	retrieve_variables_from_symbol_table :: ![TypeVar] ![TypeVar] !*SymbolTable -> (![TypeVar],!*SymbolTable)
840
	retrieve_variables_from_symbol_table [var=:{tv_ident={id_name,id_info}} : vars] class_args symbol_table
841
842
843
844
845
846
847
		# (entry, symbol_table) = readPtr id_info symbol_table
		= retrieve_variables_from_symbol_table vars [var : class_args] (symbol_table <:= (id_info,entry.ste_previous))
	retrieve_variables_from_symbol_table [] class_args symbol_table
		= (class_args, symbol_table)

checkTypeContext ::  !Index !TypeContext !(!v:{# ClassDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)
	-> (!TypeContext,!(!v:{# ClassDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState))
848
849
850
851
852
853
854
checkTypeContext mod_index tc=:{tc_class, tc_types} (class_defs, ots, oti, cs)
	# (tc_class, (class_defs, ots, cs=:{cs_error})) = check_context_class tc_class (class_defs, ots, cs)
	| cs_error.ea_ok
		# (tc_types, (ots, oti, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs)
		# cs = check_context_types tc_class tc_types cs
		= ({tc & tc_class = tc_class, tc_types = tc_types}, (class_defs, ots, oti, cs))
		= ({tc & tc_types = []}, (class_defs, ots, oti, cs))
855
856
where

857
858
859
	check_context_class (TCClass cl) (class_defs, ots, cs) 
		# (entry, cs_symbol_table) = readPtr cl.glob_object.ds_ident.id_info cs.cs_symbol_table
	  	# cs = { cs & cs_symbol_table = cs_symbol_table }
860
861
862
		# (class_index, class_module) = retrieveGlobalDefinition entry STE_Class mod_index
		| class_index <> NotFound
			# (class_def, class_index, class_defs, ots_modules) = getClassDef class_index class_module mod_index class_defs ots.ots_modules
863
864
865
866
867
868
869
870
871
872
873
874
875
		  	# ots = { ots & ots_modules = ots_modules }
			| class_def.class_arity == cl.glob_object.ds_arity			
				# checked_class =  
					{ cl 
					& glob_module = class_module
					, glob_object = {cl.glob_object & ds_index = class_index}
					}			
				= (TCClass checked_class, (class_defs, ots, cs)) 
				# cs_error = checkError cl.glob_object.ds_ident	"class used with wrong arity" cs.cs_error
				= (TCClass cl, (class_defs, ots, {cs & cs_error = cs_error}))
			# cs_error = checkError cl.glob_object.ds_ident	"class undefined" cs.cs_error	
			= (TCClass cl, (class_defs, ots, {cs & cs_error = cs_error}))					 
	check_context_class (TCGeneric gtc=:{gtc_generic, gtc_kind}) (class_defs, ots, cs) 			
876
877
	  	# gen_ident = gtc_generic.glob_object.ds_ident	
		# (entry, cs_symbol_table) = readPtr gen_ident.id_info cs.cs_symbol_table
878
879
880
881
	  	# cs = { cs & cs_symbol_table = cs_symbol_table }
	  	# clazz = 
	  		{ glob_module = -1
	  		, glob_object = 
882
	  			{ ds_ident = genericIdentToClassIdent gen_ident gtc_kind
883
884
885
886
887
888
	  			, ds_arity = 1
	  			, ds_index = -1
	  			}
	  		}
	  		
		# (generic_index, generic_module) = retrieveGlobalDefinition entry STE_Generic mod_index
889