checktypes.icl 86 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
5
import syntax, checksupport, check, typesupport, utilities,
		compilerSwitches //, RWSDebug
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
6
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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
	}

::	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
33
34
		  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
35
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
				= (root_attr, error)
Martin Wierich's avatar
Martin Wierich committed
41
				= (TA_Multi, checkError "conflicting attribution of type definition" "" error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
42
43
44
		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
45
				= (TA_Multi, checkError "conflicting attribution of type definition" "" error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
		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)
			= attr_var1.av_name == attr_var2.av_name
		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
64

Martin Wierich's avatar
Martin Wierich committed
65
66
67
68
69
70
71
		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
		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
72
73
instance bindTypes TypeVar
where
Martijn Vervoort's avatar
Martijn Vervoort committed
74
	bindTypes cti tv=:{tv_name=var_id=:{id_info}} (ts, ti, cs=:{cs_symbol_table /* TD ... */, cs_x={x_type_var_position,x_is_dcl_module} /* ... TD */ })
75
76
		# (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
77
		= case var_def.ste_kind of
Martijn Vervoort's avatar
Martijn Vervoort committed
78
			STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count /* TD */, stv_position}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
79
				# cs = { cs & cs_symbol_table = cs.cs_symbol_table <:= (id_info, { var_def & ste_kind = STE_BoundTypeVariable { bv & stv_count = inc stv_count }})}
Martijn Vervoort's avatar
Martijn Vervoort committed
80
				-> ({ tv & tv_info_ptr = stv_info_ptr /* TD ... */, tv_name = if x_is_dcl_module tv.tv_name { tv.tv_name & id_name = toString stv_position } /* ... TD */ }, stv_attribute, (ts, ti, cs))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
81
82
83
84
85
86
87
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)
	

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)
	bindTypes cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} type=:(TA type_cons=:{type_name=type_name=:{id_info}} types)
					(ts=:{ts_type_defs,ts_modules}, ti, cs=:{cs_symbol_table})
101
102
103
		# (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 cti_module_index
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
104
		| type_index <> NotFound
105
			# ({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
106
			  ts = { ts & ts_type_defs = ts_type_defs, ts_modules = ts_modules }
107
			| checkArityOfType type_cons.type_arity td_arity td_rhs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
108
109
110
111
112
				# (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)
Martin Wierich's avatar
Martin Wierich committed
113
114
				= (TE /* JVG was: type */, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name "used with wrong arity" cs.cs_error }))
			= (TE /* JVG was: type */, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name "undefined" cs.cs_error}))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
115
116
117
118
119
120
121
122
	where
		determine_type_attribute TA_Unique		= TA_Unique
		determine_type_attribute _				= TA_Multi
	
	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)
123
124
125
126
127
//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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
	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)
	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
148
	= (attr_env, checkError "inconsistent attribution of type definition" "" error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
149

150
151
bindTypesOfConstructors :: !CurrentTypeInfo !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymbol] !(!*TypeSymbols,!*TypeInfo,!*CheckState)
	-> (!*TypeSymbols, !*TypeInfo, !*CheckState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
152
153
bindTypesOfConstructors _ _ _ _ _ [] ts_ti_cs
	= ts_ti_cs
154
bindTypesOfConstructors cti=:{cti_lhs_attribute} cons_index free_vars free_attrs type_lhs [{ds_index}:conses] (ts=:{ts_cons_defs}, ti=:{ti_type_heaps}, cs)
155
	# (cons_def, ts_cons_defs) = ts_cons_defs![ds_index]
156
157
	# (exi_vars, (ti_type_heaps, cs))
	  		= addExistentionalTypeVariablesToSymbolTable cti_lhs_attribute cons_def.cons_exi_vars ti_type_heaps cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
158
	  (st_args, cons_arg_vars, st_attr_env, (ts, ti, cs))
159
160
	  		= 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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
161
162
163
164
	  cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cOuterMostLevel exi_vars cs.cs_symbol_table
	  (ts, ti, cs) = bindTypesOfConstructors 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 }
165
	  (new_type_ptr, ti_var_heap) = newPtr VI_Empty ti.ti_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
166
167
	= ({ 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,
168
					cons_type_ptr = new_type_ptr, cons_arg_vars = cons_arg_vars }}}, { ti & ti_var_heap = ti_var_heap }, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
169
where
170
171
	bind_types_of_cons :: ![AType] !CurrentTypeInfo ![TypeVar] ![AttrInequality] !(!*TypeSymbols, !*TypeInfo, !*CheckState)
		-> !(![AType], ![[ATypeVar]], ![AttrInequality], !(!*TypeSymbols, !*TypeInfo, !*CheckState))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
172
173
174
175
176
177
	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
Martijn Vervoort's avatar
Martijn Vervoort committed
178
		  (local_vars, cs_symbol_table /* TD ... */, _ /* ... TD */ ) = foldSt retrieve_local_vars free_vars ([], cs.cs_symbol_table /* TD ...*/, cs.cs_x /* ... TD */ )
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
179
180
181
		  (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 
Martijn Vervoort's avatar
Martijn Vervoort committed
182
183
		retrieve_local_vars tv=:{tv_name={id_info}} (local_vars, symbol_table /* TD ... */, cs_x=:{x_is_dcl_module} /* ... TD */ )
			# (ste=:{ste_kind = STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count /* TD ... */,stv_position  /* ... TD */ }}, symbol_table) = readPtr id_info symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
184
			| stv_count == 0
Martijn Vervoort's avatar
Martijn Vervoort committed
185
186
187
188
189
				= (local_vars, symbol_table /* TD ... */, cs_x /* ... TD */)
				
				= ([{ atv_variable = { tv & tv_info_ptr = stv_info_ptr /* TD ... */, tv_name = if x_is_dcl_module tv.tv_name { tv.tv_name & id_name = toString stv_position } /* ... TD */ }, atv_attribute = stv_attribute, atv_annotation = AN_None } : local_vars],
						symbol_table <:= (id_info, { ste & ste_kind = STE_BoundTypeVariable { bv & stv_count = 0}})/* TD ... */, cs_x /* ... TD */)
						
190
191
192
193
//
checkRhsOfTypeDef :: !CheckedTypeDef ![AttributeVar] !CurrentTypeInfo !(!*TypeSymbols, !*TypeInfo, !*CheckState)
	-> (!TypeRhs, !(!*TypeSymbols, !*TypeInfo, !*CheckState))
//
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
194
195
196
197
198
199
200
201
202
203
204
205
206
checkRhsOfTypeDef {td_name,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
	# type_lhs = { at_annotation = AN_None, at_attribute = cti_lhs_attribute,
			  	   at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_name td_arity)
								[{at_annotation = AN_None, at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
	  ts_ti_cs = bindTypesOfConstructors cti 0 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs conses ts_ti_cs
	= (td_rhs, ts_ti_cs)
checkRhsOfTypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_constructor=rec_cons=:{ds_index}, rt_fields}}
		attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs
	# type_lhs = {	at_annotation = AN_None, at_attribute = cti_lhs_attribute,
					at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_name td_arity)
			[{at_annotation = AN_None, at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
	  (ts, ti, cs) = bindTypesOfConstructors cti 0  [ atv_variable \\ {atv_variable} <- td_args]
	  						attr_vars type_lhs [rec_cons] ts_ti_cs
207
	# (rec_cons_def, ts) = ts!ts_cons_defs.[ds_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
208
	# {cons_type = { st_vars,st_args,st_result,st_attr_vars }, cons_exi_vars} = rec_cons_def
209
210
211
212
213

	| size rt_fields<>length st_args
		= abort ("checkRhsOfTypeDef "+++rt_fields.[0].fs_name.id_name+++" "+++rec_cons_def.cons_symb.id_name+++toString ds_index)

	# (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
214
215
				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}))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
216
where
217
218
219
	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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
220
221
		| field_nr < size fields
			# {fs_index} = fields.[field_nr]
222
			# (sel_def, selector_defs) = selector_defs![fs_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
223
224
			# [sel_type:sel_types] = sel_types
			# (st_attr_env, error) = addToAttributeEnviron sel_type.at_attribute rec_type.at_attribute [] error
225
			# (new_type_ptr, var_heap) = newPtr VI_Empty var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
226
227
228
			  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,
229
230
231
			  									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
232
233
234
235
236
237
238
239
240
241
242
243
checkRhsOfTypeDef {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)
checkRhsOfTypeDef {td_rhs} _ _ ts_ti_cs
	= (td_rhs, ts_ti_cs)

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

isATopConsVar cv		:== cv < 0
encodeTopConsVar cv		:== dec (~cv)
decodeTopConsVar cv		:== ~(inc cv)

Martijn Vervoort's avatar
Martijn Vervoort committed
244
245
checkTypeDef :: /* TD */ !Bool !Index !Index !*TypeSymbols !*TypeInfo !*CheckState -> (!*TypeSymbols, !*TypeInfo, !*CheckState);
checkTypeDef /* TD */ is_dcl_module type_index module_index ts=:{ts_type_defs} ti=:{ti_type_heaps} cs=:{cs_error}
246
	# (type_def, ts_type_defs) = ts_type_defs![type_index]
247
	# {td_name,td_pos,td_args,td_attribute} = type_def
Martijn Vervoort's avatar
Martijn Vervoort committed
248
249
250
251
252
	
	// TD ...
	// in case of an icl-module, the arguments i.e. the type variables of type constructors are normalized which makes
	// comparison by the static linker easier.
	# (cs=:{cs_error})
Martijn Vervoort's avatar
Martijn Vervoort committed
253
		= { cs & cs_x = { cs.cs_x & x_is_dcl_module = /*is_dcl_module*/ True, x_type_var_position = 0 } }
Martijn Vervoort's avatar
Martijn Vervoort committed
254
255
256
257
// 	| FB (not is_dcl_module)  ("checkTypeDef: " +++ td_name.id_name) True
	#
 	// ... TD
 	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
258
259
	  position = newPosition td_name td_pos
	  cs_error = pushErrorAdmin position cs_error
260
261
262
	  (td_attribute, attr_vars, th_attrs) = determine_root_attribute td_attribute td_name.id_name ti_type_heaps.th_attrs
	  (type_vars, (attr_vars, ti_type_heaps, cs))
	  		= addTypeVariablesToSymbolTable td_args attr_vars { ti_type_heaps & th_attrs = th_attrs } { cs & cs_error = cs_error }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
263
264
	  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)) = checkRhsOfTypeDef type_def attr_vars
265
266
			{ 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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
267
268
	= ({ ts & ts_type_defs = { ts.ts_type_defs & [type_index] = { type_def & td_rhs = td_rhs }}}, ti,
				{ cs &	cs_error = popErrorAdmin cs.cs_error,
Martijn Vervoort's avatar
Martijn Vervoort committed
269
270
271
272
						cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cOuterMostLevel type_vars cs.cs_symbol_table
	// TD ...
						, cs_x = { cs.cs_x & x_is_dcl_module = False}      })
	// ... TD 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
273
274
275
276
277
278
279
280
281
282
283
where
	determine_root_attribute TA_None name attr_var_heap
		# (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap
		  new_var = { av_name = emptyIdent name, av_info_ptr = attr_info_ptr}
		= (TA_Var new_var, [new_var], attr_var_heap)
	determine_root_attribute TA_Unique name attr_var_heap
		= (TA_Unique, [], attr_var_heap)

CS_Checked	:== 1
CS_Checking	:== 0

284
285
286
287
288
289
::	ExpandState =
	{	exp_type_defs	::!.{# CheckedTypeDef}
	,	exp_modules		::!.{# DclModule}
	,	exp_marks		::!.{# Int}
	,	exp_type_heaps	::!.TypeHeaps
	,	exp_error		::!.ErrorAdmin
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
290
291
	}

292
class expand a :: !Index !a  !*ExpandState -> (!a, !*ExpandState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
293

294
295
296
297
expandTypeVariable :: TypeVar !*ExpandState -> (!Type, !*ExpandState)
expandTypeVariable {tv_info_ptr} expst=:{exp_type_heaps}
	# (TVI_Type type, th_vars) = readPtr tv_info_ptr exp_type_heaps.th_vars
	= (type, { expst & exp_type_heaps = { exp_type_heaps & th_vars  = th_vars }})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
298

299
300
301
302
303
304
expandTypeAttribute :: !TypeAttribute !*ExpandState -> (!TypeAttribute, !*ExpandState)
expandTypeAttribute (TA_Var {av_info_ptr}) expst=:{exp_type_heaps}
	# (AVI_Attr attr, th_attrs) = readPtr av_info_ptr exp_type_heaps.th_attrs
	= (attr, { expst & exp_type_heaps = { exp_type_heaps & th_attrs = th_attrs }})
expandTypeAttribute attr expst
	= (attr, expst)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
305
306
307

instance expand Type
where
308
309
310
	expand module_index (TV tv) expst
		= expandTypeVariable tv expst
	expand module_index type=:(TA type_cons=:{type_name,type_index={glob_object,glob_module}} types) expst=:{exp_marks,exp_error}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
311
		| module_index == glob_module
312
			#! mark = exp_marks.[glob_object]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
313
			| mark == CS_NotChecked
314
315
316
				# expst = expandSynType module_index glob_object expst
				  (types, expst) = expand module_index types expst
				= (TA type_cons types,expst)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
317
			| mark == CS_Checked
318
319
				# (types, expst) = expand module_index types expst
				= (TA type_cons types, expst)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
320
//			| mark == CS_Checking
321
322
323
324
325
326
327
				= (type, { expst & exp_error = checkError type_name "cyclic dependency between type synonyms" exp_error })
			# (types, expst) = expand module_index types expst
			= (TA type_cons types, expst)
	expand module_index (arg_type --> res_type) expst
		# (arg_type, expst) = expand module_index arg_type expst
		  (res_type, expst) = expand module_index res_type expst
		= (arg_type --> res_type, expst)
328
329
330
331
332
// AA..
	expand module_index (TArrow1 type) expst
		# (type, expst) = expand module_index type expst
		= (TArrow1 type, expst)
// ..AA				
333
334
335
336
	expand module_index (CV tv :@: types) expst
		# (type, expst) = expandTypeVariable tv expst
		  (types, expst) = expand module_index types expst
		= (simplify_type_appl type types, expst) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
337
338
339
340
341
342
		where
			simplify_type_appl :: !Type ![AType] -> Type
			simplify_type_appl (TA type_cons=:{type_arity} cons_args) type_args
				= TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args)
			simplify_type_appl (TV tv) type_args
				= CV tv :@: type_args
343
344
			simplify_type_appl TE t2
				= TE
345
346
	expand module_index type expst
		= (type, expst)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
347
348
349

instance expand [a] | expand a
where
350
351
352
353
354
355
	expand module_index [x:xs] expst
		# (x, expst) = expand module_index x expst
		  (xs, expst) = expand module_index xs expst
		= ([x:xs], expst)
	expand module_index [] expst
		= ([], expst)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
356
357
358

instance expand AType
where
359
360
361
362
	expand module_index atype=:{at_type,at_attribute} expst
		# (at_attribute, expst) = expandTypeAttribute at_attribute expst
		  (at_type, expst) = expand module_index at_type expst
		= ({ atype & at_type = at_type, at_attribute = at_attribute }, expst)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
363

364
class look_for_cycles a :: !Index !a !*ExpandState -> *ExpandState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
365
366
367

instance look_for_cycles Type
where
368
	look_for_cycles module_index type=:(TA type_cons=:{type_name,type_index={glob_object,glob_module}} types) expst=:{exp_marks,exp_error}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
369
		| module_index == glob_module
370
			#! mark = exp_marks.[glob_object]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
371
			| mark == CS_NotChecked
372
373
				# expst = expandSynType module_index glob_object expst
				= look_for_cycles module_index types expst
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
374
			| mark == CS_Checked
375
376
377
378
379
				= look_for_cycles module_index types expst
				= { expst & exp_error = checkError type_name "cyclic dependency between type synonyms" exp_error }
		= look_for_cycles module_index types expst
	look_for_cycles module_index (arg_type --> res_type) expst
		= look_for_cycles module_index res_type (look_for_cycles module_index arg_type expst)
380
381
382
383
//AA..
	look_for_cycles module_index (TArrow1 arg_type) expst
		= look_for_cycles module_index arg_type expst
//..AA
384
385
386
387
	look_for_cycles module_index (type :@: types) expst
		= look_for_cycles module_index types expst
	look_for_cycles module_index type expst
		= expst
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
388
389
390
	
instance look_for_cycles [a] | look_for_cycles a
where
391
392
	look_for_cycles mod_index l expst
		= foldr (look_for_cycles mod_index) expst l
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
393
394
395

instance look_for_cycles AType
where
396
397
	look_for_cycles mod_index {at_type} expst
		= look_for_cycles mod_index at_type expst
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
398

399
400
import StdDebug

401
402
403
404
expandSynType ::  !Index !Index !*ExpandState -> *ExpandState
expandSynType mod_index type_index expst=:{exp_type_defs}
	# (type_def, exp_type_defs) = exp_type_defs![type_index]
	  expst = { expst & exp_type_defs = exp_type_defs }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
405
	= case type_def.td_rhs of
406
		SynType type=:{at_type = TA {type_name,type_index={glob_object,glob_module}} types}		
407
408
409
	   		# ({td_args,td_attribute,td_rhs}, _, exp_type_defs, exp_modules) = getTypeDef glob_object glob_module mod_index expst.exp_type_defs expst.exp_modules
	   		  expst = { expst & exp_type_defs = exp_type_defs, exp_modules = exp_modules }
			-> case td_rhs of
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
410
				SynType rhs_type
411
					# exp_type_heaps = bindTypeVarsAndAttributes td_attribute type_def.td_attribute td_args types expst.exp_type_heaps
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
412
					  position = newPosition type_def.td_name type_def.td_pos
413
414
415
416
417
418
419
420
421
					  exp_error = pushErrorAdmin position expst.exp_error
	  		  		  exp_marks = { expst.exp_marks & [type_index] = CS_Checking }			  
					  (exp_type, expst) = expand mod_index rhs_type.at_type { expst & exp_marks = exp_marks,
										exp_error = exp_error, exp_type_heaps = exp_type_heaps }
					-> {expst & exp_type_defs = { expst.exp_type_defs & [type_index] = { type_def & td_rhs = SynType { type & at_type = exp_type }}},
						 		exp_marks = { expst.exp_marks & [type_index] = CS_Checked },
						 		exp_type_heaps = clearBindingsOfTypeVarsAndAttributes td_attribute td_args expst.exp_type_heaps,
								exp_error = popErrorAdmin expst.exp_error }

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
422
				_
423
					# exp_marks = { expst.exp_marks & [type_index] = CS_Checking }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
424
					  position = newPosition type_def.td_name type_def.td_pos
425
426
	  		  		  expst = look_for_cycles mod_index types { expst & exp_marks = exp_marks, exp_error = pushErrorAdmin position expst.exp_error }
					-> { expst & exp_marks = { expst.exp_marks & [type_index] = CS_Checked }, exp_error = popErrorAdmin expst.exp_error }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
427
		_
428
			-> { expst &  exp_marks = { expst.exp_marks & [type_index] = CS_Checked }}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
429

Martijn Vervoort's avatar
Martijn Vervoort committed
430
checkTypeDefs :: /* TD */ !Bool !Bool !*{# CheckedTypeDef} !Index !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
431
	-> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState)
Martijn Vervoort's avatar
Martijn Vervoort committed
432
checkTypeDefs /* TD */ is_dcl_module is_main_dcl type_defs module_index  cons_defs selector_defs modules var_heap type_heaps cs
433
	#! nr_of_types = size type_defs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
434
	#  ts = { ts_type_defs = type_defs, ts_cons_defs = cons_defs, ts_selector_defs = selector_defs, ts_modules = modules }
435
	   ti = { ti_type_heaps = type_heaps, ti_var_heap = var_heap  }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
436
437
	= check_type_defs is_main_dcl 0 nr_of_types module_index ts ti cs
where
438
	check_type_defs is_main_dcl type_index nr_of_types module_index ts ti=:{ti_type_heaps,ti_var_heap} cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
439
		| type_index == nr_of_types
440
			= (ts.ts_type_defs, ts.ts_cons_defs, ts.ts_selector_defs, ts.ts_modules, ti_var_heap, ti_type_heaps, cs)
Martijn Vervoort's avatar
Martijn Vervoort committed
441
			# (ts, ti, cs) = checkTypeDef /* TD */ is_dcl_module type_index module_index ts ti cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
442
443
			= check_type_defs is_main_dcl (inc type_index) nr_of_types module_index ts ti cs

444
445
446
447
448
449
450
expand_syn_types module_index type_index nr_of_types expst
	| type_index == nr_of_types
		= expst
	| expst.exp_marks.[type_index] == CS_NotChecked
		# expst = expandSynType module_index type_index expst
		= expand_syn_types module_index (inc type_index) nr_of_types expst
		= expand_syn_types module_index (inc type_index) nr_of_types expst
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
/*
Tracea_tn a
	# s=size a
	# f=stderr
	# r=t 0 f
	  with
	  	t i f
	  		| i<s && file_to_true (stderr <<< i <<< '\n' <<< a.[i] <<< '\n')
	  			= t (i+1) f
	  			= True
	 = r

file_to_true :: !File -> Bool;
file_to_true file = code {
  .inline file_to_true
          pop_b 2
          pushB TRUE
  .end
 }
*/
471
472
473
474
475
476
477
478
479
480
481
482
483
484

expandSynonymTypes :: !.Index !*{#CheckedTypeDef} !*{#.DclModule} !*TypeHeaps !*ErrorAdmin
	-> (!.{#CheckedTypeDef},!.{#DclModule},!.TypeHeaps,!.ErrorAdmin)
expandSynonymTypes module_index exp_type_defs exp_modules exp_type_heaps exp_error
	#! nr_of_types
			= size exp_type_defs
	# marks 
			= createArray nr_of_types CS_NotChecked
	  {exp_type_defs,exp_modules,exp_type_heaps,exp_error}
			= expand_syn_types module_index 0 nr_of_types
			  		{	exp_type_defs = exp_type_defs, exp_modules = exp_modules, exp_marks = marks,
			  			exp_type_heaps = exp_type_heaps, exp_error = exp_error }
	= (exp_type_defs,exp_modules,exp_type_heaps,exp_error)
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
485
486
487
488
489
490
491
492
493
494
495
496
497
::	OpenTypeInfo =
	{	oti_heaps		:: !.TypeHeaps
	,	oti_all_vars	:: ![TypeVar]
	,	oti_all_attrs	:: ![AttributeVar]
	,	oti_global_vars	:: ![TypeVar]
	}

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

determineAttributeVariable attr_var=:{av_name=attr_name=:{id_info}} oti=:{oti_heaps,oti_all_attrs} symbol_table
498
	# (entry=:{ste_kind,ste_def_level}, symbol_table) = readPtr id_info symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
499
500
501
502
503
504
505
506
507
508
509
	| 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

510
newAttribute :: !DemandedAttributeKind {#Char} TypeAttribute !*OpenTypeInfo !*CheckState -> (!TypeAttribute, !*OpenTypeInfo, !*CheckState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
511
512
513
514
515
516
517
518
519
520
521
newAttribute DAK_Ignore var_name _ oti cs
	= (TA_Multi, oti, cs)
newAttribute DAK_Unique var_name new_attr  oti cs
	= case new_attr of
		TA_Unique
			-> (TA_Unique, oti, cs)
		TA_Multi
			-> (TA_Unique, oti, cs)
		TA_None
			-> (TA_Unique, oti, cs)
		_
522
			-> (TA_Unique, oti, { cs & cs_error = checkError var_name "inconsistently attributed" cs.cs_error })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
newAttribute DAK_None var_name (TA_Var attr_var) oti cs=:{cs_symbol_table}
	# (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 })
newAttribute DAK_None var_name TA_Anonymous oti=:{oti_heaps, oti_all_attrs} cs
	# (new_attr_ptr, th_attrs) = newPtr AVI_Empty oti_heaps.th_attrs
	  new_attr = { av_info_ptr = new_attr_ptr, av_name = emptyIdent var_name }
	= (TA_Var new_attr, { oti & oti_heaps = { oti_heaps & th_attrs = th_attrs }, oti_all_attrs = [new_attr : oti_all_attrs] }, cs)
newAttribute DAK_None var_name TA_Unique oti cs
	= (TA_Unique, oti, cs)
newAttribute DAK_None var_name attr oti cs
	= (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
539
		# (type_def, type_defs) = type_defs![type_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
540
		= (type_def, type_index, type_defs, modules)
541
542
543
		# ({dcl_common={com_type_defs},dcl_conversions}, modules) = modules![type_module]
		  type_def = com_type_defs.[type_index]
		  type_index = convertIndex type_index (toInt STE_Type) dcl_conversions
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
544
545
		= (type_def, type_index, type_defs, modules)

546
547
548
549
550
checkArityOfType act_arity form_arity (SynType _)
	= form_arity == act_arity
checkArityOfType act_arity form_arity _
	= form_arity >= act_arity

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
551
552
553
554
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
555
		# (class_def, class_defs) = class_defs![class_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
556
		= (class_def, class_index, class_defs, modules)
557
558
559
		# ({dcl_common={com_class_defs},dcl_conversions}, modules) = modules![type_module]
		  class_def = com_class_defs.[class_index]
		  class_index = convertIndex class_index (toInt STE_Class) dcl_conversions
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
560
561
		= (class_def, class_index, class_defs, modules)

562
563
564
565
566
567
568
569
570
571
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)
		# ({dcl_common={com_generic_defs},dcl_conversions}, modules) = modules![type_module]
		  generic_def = com_generic_defs.[generic_index]
		  generic_index = convertIndex generic_index (toInt STE_Generic) dcl_conversions
		= (generic_def, generic_index, generic_defs, modules)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
572

573
574
575
576
checkTypeVar :: !Level !DemandedAttributeKind !TypeVar !TypeAttribute !(!*OpenTypeInfo, !*CheckState)
					-> (! TypeVar, !TypeAttribute, !(!*OpenTypeInfo, !*CheckState))
checkTypeVar scope dem_attr tv=:{tv_name=var_name=:{id_name,id_info}} tv_attr (oti, cs=:{cs_symbol_table})
	# (entry=:{ste_kind,ste_def_level},cs_symbol_table) = readPtr id_info cs_symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
577
	| ste_kind == STE_Empty || ste_def_level == cModuleScope
578
		# (new_attr, oti=:{oti_heaps,oti_all_vars}, cs) = newAttribute dem_attr id_name tv_attr oti { cs & cs_symbol_table = cs_symbol_table }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
579
580
		  (new_var_ptr, th_vars) = newPtr (TVI_Attribute new_attr) oti_heaps.th_vars
		  new_var = { tv & tv_info_ptr = new_var_ptr }
581
		= (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
582
583
584
585
586
				{ 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
		  (var_info, th_vars) = readPtr tv_info_ptr oti_heaps.th_vars
587
588
589
		  (var_attr, oti, cs) = check_attribute id_name dem_attr var_info tv_attr { oti & oti_heaps = { oti_heaps & th_vars = th_vars }}
		  								{ 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
590
591
592
593
594
595
596
597
598
599
600
601
where
	check_attribute var_name DAK_Ignore (TVI_Attribute prev_attr) this_attr oti cs=:{cs_error}
		= (TA_Multi, oti, cs)
	check_attribute var_name dem_attr (TVI_Attribute prev_attr) this_attr oti cs=:{cs_error}
		# (new_attr, cs_error) = determine_attribute var_name dem_attr this_attr cs_error
		= 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,
602
						cs_error = checkError new_var.av_name "inconsistently attributed" cs_error })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
603
604
605
606
607
608
609
		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)
				_
610
					-> (TA_Unique, oti, { cs & cs_error = checkError var_name "inconsistently attributed" cs.cs_error })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
611
612
613
614
615
616
617
		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)
				_
618
					-> (TA_Multi, oti, { cs & cs_error = checkError var_name "inconsistently attributed" cs.cs_error })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
619
		check_var_attribute var_attr new_attr oti cs
620
			= (var_attr, oti, { cs & cs_error = checkError var_name "inconsistently attributed" cs.cs_error })// ---> (var_attr, new_attr)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
621
622
623
624
625
626
627
628
629
630
631
		
		
		determine_attribute var_name DAK_Unique new_attr error
			= case new_attr of
				 TA_Multi
				 	-> (TA_Unique, error)
				 TA_None
				 	-> (TA_Unique, error)
				 TA_Unique
				 	-> (TA_Unique, error)
				 _
632
				 	-> (TA_Unique, checkError var_name "inconsistently attributed" error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
633
634
635
636
637
638
639
640
		determine_attribute var_name dem_attr TA_None error
			= (TA_Multi, error)
		determine_attribute var_name dem_attr new_attr error
			= (new_attr, error)

	check_attribute var_name dem_attr _ this_attr oti cs
		= (TA_Multi, oti, cs)

641
642
checkOpenAType :: !Index !Int !DemandedAttributeKind !AType !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)
	-> (!AType, !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState))
643
644
645
checkOpenAType mod_index scope dem_attr type=:{at_type = TV tv, at_attribute} (ots, oti, cs)
	# (tv, at_attribute, (oti, cs)) = checkTypeVar scope dem_attr tv at_attribute (oti, cs)
	= ({ type & at_type = TV tv, at_attribute = at_attribute }, (ots, oti, cs))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
646
647
checkOpenAType mod_index scope dem_attr type=:{at_type = GTV var_id=:{tv_name={id_info}}} (ots, oti=:{oti_heaps,oti_global_vars}, cs=:{cs_symbol_table})
	# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
648
	  (type_var, oti_global_vars, th_vars, entry) = retrieve_global_variable var_id entry oti_global_vars oti_heaps.th_vars
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
	= ({type & at_type = TV type_var, at_attribute = TA_Multi }, (ots, { oti & oti_heaps = { oti_heaps & th_vars = th_vars }, oti_global_vars = oti_global_vars },
								{ 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 })
670
//
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
671
checkOpenAType mod_index scope dem_attr type=:{ at_type=TA type_cons=:{type_name=type_name=:{id_name,id_info}} types, at_attribute}
672
673
674
675
		(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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
676
	| type_index <> NotFound
677
		# ({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
678
		  ots = { ots & ots_type_defs = ots_type_defs, ots_modules = ots_modules }
679
		| checkArityOfType type_cons.type_arity td_arity td_rhs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
680
			# type_cons = { type_cons & type_index = { glob_object = type_index, glob_module = type_module }}
681
			  (types, (ots, oti, cs)) = check_args_of_type_cons mod_index scope /* dem_attr */ types td_args (ots, oti, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
682
683
			  (new_attr, oti, cs) = newAttribute (new_demanded_attribute dem_attr td_attribute) id_name at_attribute oti cs
			= ({ type & at_type = TA type_cons types, at_attribute = new_attr } , (ots, oti, cs)) 
684
685
			= (type, (ots, oti, {cs & cs_error = checkError type_name "used with wrong arity" cs.cs_error}))
		= (type, (ots, oti, {cs & cs_error = checkError type_name "undefined" cs.cs_error}))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
686
where
687
688
	check_args_of_type_cons :: !Index !Int ![AType] ![ATypeVar] !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)
		-> (![AType], !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState))
689
690
691
692
693
694
	check_args_of_type_cons mod_index scope [] _ cot_state
		= ([], cot_state)
	check_args_of_type_cons mod_index scope [arg_type : arg_types] [ {atv_attribute} : td_args ] cot_state
		# (arg_type, cot_state) = checkOpenAType mod_index scope (new_demanded_attribute DAK_None atv_attribute) arg_type cot_state
		  (arg_types, cot_state) = check_args_of_type_cons mod_index scope arg_types td_args cot_state
		= ([arg_type : arg_types], cot_state)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
695
696
697
698
699
700
701
702
703
704
705
706
707

	new_demanded_attribute DAK_Ignore _
		= DAK_Ignore
	new_demanded_attribute _ TA_Unique
		= DAK_Unique
	new_demanded_attribute dem_attr _
		= dem_attr

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))
708
709
710
711
712
713
//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
714
checkOpenAType mod_index scope dem_attr type=:{at_type = CV tv :@: types, at_attribute} (ots, oti, cs)
715
	# (cons_var, _, (oti, cs)) = checkTypeVar scope DAK_None tv TA_Multi (oti, cs)
716
	  (types, (ots, oti, cs)) = mapSt (checkOpenAType mod_index scope DAK_None) types (ots, oti, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
	  (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))
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
	# ({at_type}, cot_state) = checkOpenAType mod_index scope dem_attr { at_type = type, at_attribute = TA_Multi, at_annotation = AN_None } cot_state
	= (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
733
checkInstanceType :: !Index !(Global DefinedSymbol) !InstanceType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
734
	-> (!InstanceType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
Martin Wierich's avatar
Martin Wierich committed
735
736
737
738
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
739
	  oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars= [] }
740
741
742
743
744
	  (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 })
	  oti = { oti &  oti_all_vars = [], oti_all_attrs = [] }
	  (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
745
	  (specials, cs) = checkSpecialTypeVars specials { cs & cs_error = cs_error }
746
747
	  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
748
	  (specials, type_defs, modules, heaps, cs) = checkSpecialTypes mod_index specials type_defs modules heaps { cs & cs_symbol_table = cs_symbol_table }
749
	= ({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
750
	    	specials, type_defs, class_defs, modules, heaps, cs)
Martin Wierich's avatar
Martin Wierich committed
751
752
753
  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
754
			= checkError "context restriction not allowed for fully polymorph instance" "" cs_error
Martin Wierich's avatar
Martin Wierich committed
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
		= cs_error
	  where
		is_type_var (TV _) = True
		is_type_var _ = False

	compare_context_and_instance_types ins_class it_types {tc_class, tc_types} cs_error
		| ins_class<>tc_class
			= 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
		compare_context_and_instance_type (_ --> _) (_ --> _) are_equal_accu
			= are_equal_accu
773
774
775
776
777
778
//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
779
780
781
782
783
784
785
786
787
		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

788
789
790
791
792
793
794
795
796
797
798
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
799

800
checkSymbolType :: !Bool !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
801
	-> (!SymbolType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
802
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
803
804
805
	# 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)
806
807
808
809
810
	  (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
811
	  (specials, cs) = checkSpecialTypeVars specials cs 
812
813
	  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
814
	  (specials, type_defs, modules, heaps, cs) = checkSpecialTypes mod_index specials type_defs modules heaps { cs & cs_symbol_table = cs_symbol_table }
815
816
	  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 }
817
	= (checked_st, specials, type_defs, class_defs, modules, heaps, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
818
819
where
	check_attr_inequality ineq=:{ai_demanded=ai_demanded=:{av_name=dem_name},ai_offered=ai_offered=:{av_name=off_name}} cs=:{cs_symbol_table,cs_error}
820
		# (dem_entry, cs_symbol_table) = readPtr dem_name.id_info cs_symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
821
822
		# (found_dem_attr, dem_attr_ptr) = retrieve_attribute dem_entry
		| found_dem_attr
823
		   	# (off_entry, cs_symbol_table) = readPtr off_name.id_info cs_symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
824
825
			# (found_off_attr, off_attr_ptr) = retrieve_attribute off_entry
			| found_off_attr
826
827
828
829
				= ({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 })
830
831
832
833
834
835
836
837
838
839
840
841
	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

842
843
844
845
// 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
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
	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
867
where
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
	add_variable_to_symbol_table :: !TypeVar !(![TypeVar], !*SymbolTable, !*TypeVarHeap, !*ErrorAdmin)
		-> (![TypeVar],!*SymbolTable,!*TypeVarHeap,!*ErrorAdmin)
	add_variable_to_symbol_table tv=:{tv_name={id_name,id_info}} (rev_class_args, symbol_table, th_vars, error)
	  	# (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)
	retrieve_variables_from_symbol_table [var=:{tv_name={id_name,id_info}} : vars] class_args symbol_table
		# (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))
checkTypeContext mod_index tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ident=ds_ident=:{id_name,id_info},ds_arity}},tc_types}
	  	(class_defs, ots, oti, cs=:{cs_symbol_table, cs_predef_symbols})
	# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
	  cs = { cs & cs_symbol_table = cs_symbol_table }
	# (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
		  ots = { ots & ots_modules = ots_modules }
		  (tc_types, (ots, oti, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs)
		  cs = check_context_types 	class_def.class_name tc_types cs
		  tc = { tc & tc_class = { tc_class & glob_object = { class_name & ds_index = class_index }, glob_module = class_module }, tc_types = tc_types}
		| class_def.class_arity == ds_arity
			= (tc, (class_defs, ots, oti, cs))
Martin Wierich's avatar
Martin Wierich committed
900
901
			= (tc, (class_defs, ots, oti, { cs & cs_error = checkError id_name "used with wrong arity" cs.cs_error }))
		= ({tc & tc_types = []}, (class_defs, ots, oti, { cs & cs_error = checkError id_name "undefined" cs.cs_error }))
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
where
	
	check_context_types tc_class [] cs=:{cs_error}
		= { cs & cs_error = checkError tc_class "type context should contain one or more type variables" cs_error}
	check_context_types tc_class [((CV {tv_name}) :@: _):_] cs=:{cs_error}
		= cs
//		= { cs & cs_error = checkError tv_name "not allowed as higher order type variable in context" cs_error}
	check_context_types tc_class [TV _ : types] cs
		= cs
	check_context_types tc_class [type : types] cs
		= check_context_types tc_class types cs

checkTypeContext1 ::  !Index !TypeContext !(!v:{# ClassDef}, !x:{# GenericDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)
	-> (!TypeContext,!(!v:{# ClassDef}, !x:{# GenericDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState))
checkTypeContext1 mod_index tc (class_defs, generic_defs, ots, oti, cs)
	# (entry, cs) = get_entry tc cs
	= check_context mod_index entry tc (class_defs, generic_defs, ots, oti, cs)
where
	get_entry tc cs=:{cs_symbol_table}
		# (entry, cs_symbol_table) = readPtr tc.tc_class.glob_object.ds_ident.id_info cs_symbol_table
		= (entry, {cs & cs_symbol_table = cs_symbol_table}) 

	check_context 
			mod_index 
			entry 
			tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ident=ds_ident=:{id_name,id_info},ds_arity}},tc_types}
	  		(class_defs, generic_defs, ots, oti, cs)
		# (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
			  ots = { ots & ots_modules = ots_modules }
			  (tc_types, (ots, oti, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs)
			  cs = check_context_types 	class_def.class_name tc_types cs
			  tc = { tc & tc_class = { tc_class & glob_object = { class_name & ds_index = class_index }, glob_module = class_module }, tc_types = tc_types}
			| class_def.class_arity == ds_arity
				= (tc, (class_defs, generic_defs, ots, oti, cs))
				= (tc, (class_defs, generic_defs, ots, oti, { cs & cs_error = checkError id_name "used with wrong arity" cs.cs_error }))
			= ({tc & tc_types = []}, (class_defs, generic_defs, ots, oti, { cs & cs_error = checkError id_name "class undefined" cs.cs_error }))
	check_context 
			mod_index
			entry
			tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ident=ds_ident=:{id_name,id_info},ds_arity}},tc_types}
			(class_defs, generic_defs, ots, oti, cs)	
		# 	(generic_index, generic_module) = retrieveGlobalDefinition entry STE_Generic mod_index
		| generic_index <> NotFound
			# (generic_def, generic_index, generic_defs, ots_modules) = getGenericDef generic_index generic_module mod_index generic_defs ots.ots_modules
			  ots = { ots & ots_modules = ots_modules }
			  (tc_types, (ots, oti, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs)
			  //cs = check_context_types 	generic_def.gen_name tc_types cs
			  tc = { tc & tc_class = { tc_class & glob_object = { class_name & ds_index = generic_index }, glob_module = generic_module }, tc_types = tc_types}
			| ds_arity == 1
				= (tc, (class_defs, generic_defs, ots, oti, cs))
				= (tc, (class_defs, generic_defs, ots, oti, { cs & cs_error = checkError id_name "used with wrong arity" cs.cs_error }))
			= ({tc & tc_types = []}, (class_defs, generic_defs, ots, oti, { cs & cs_error = checkError id_name "generic undefined" cs.cs_error }))
			
957
	check_context_types tc_class [] cs=:{cs_error}
Martin Wierich's avatar
Martin Wierich committed
958
		= { cs & cs_error = checkError tc_class "type context should contain one or more type variables" cs_error}
Martin Wierich's avatar
Martin Wierich committed
959
	check_context_types tc_class [((CV {tv_name}) :@: _):_] cs=:{cs_error}
960
961
		= cs
//		= { cs & cs_error = checkError tv_name "not allowed as higher order type variable in context" cs_error}
962
963
964
965
966
	check_context_types tc_class [TV _ : types] cs
		= cs
	check_context_types tc_class [type : types] cs
		= check_context_types tc_class types cs

967
968
969
970
971
972
973
974
975
976
977
978
979
checkTypeContexts :: ![TypeContext] !Index !v:{# ClassDef} !u:OpenTypeSymbols !*OpenTypeInfo !*CheckState
	-> (![TypeContext], !u:{# CheckedTypeDef}, !v:{# ClassDef}, u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkTypeContexts tcs mod_index class_defs ots oti cs
	# (tcs, (class_defs, { ots_modules, ots_type_defs}, oti, cs)) = mapSt (checkTypeContext mod_index) tcs (class_defs, ots, oti, cs)
	  cs = check_class_variables oti.oti_all_vars cs
	  cs = check_class_attributes oti.oti_all_attrs cs
	= (tcs, ots_type_defs, class_defs, ots_modules, oti.oti_heaps, cs)
where
	check_class_variables class_variables cs
		= foldSt check_class_variable class_variables cs
	where
		check_class_variable {tv_name} cs=:{cs_symbol_table,cs_error}
			= { cs & cs_symbol_table	= removeDefinitionFromSymbolTable cGlobalScope tv_name cs_symbol_table,
Martin Wierich's avatar
Martin Wierich committed
980
					 cs_error			= checkError tv_name "wrongly used or not used at all" cs_error}
981
982
983
984
985
986
	
	check_class_attributes class_attributes cs
		= foldSt check_class_attribute class_attributes cs
	where
		check_class_attribute {av_name} cs=:{cs_symbol_table,cs_error}
			= { cs & cs_symbol_table	= removeDefinitionFromSymbolTable cGlobalScope av_name cs_symbol_table,