1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
|
implementation module checkgenerics
import syntax,checksupport,checktypes,genericsupport,compare_types
checkGenericDefs :: !Index !(Optional (CopiedDefinitions, Int))
!*{#GenericDef} !*{#CheckedTypeDef} !*{#ClassDef} !*{#DclModule} !*Heaps !*CheckState
-> (!*{#GenericDef},!*{#CheckedTypeDef},!*{#ClassDef},!*{#DclModule},!*Heaps,!*CheckState)
checkGenericDefs mod_index opt_icl_info gen_defs type_defs class_defs modules heaps cs
= check_generics 0 mod_index opt_icl_info gen_defs type_defs class_defs modules heaps cs
where
check_generics index mod_index opt_icl_info gen_defs type_defs class_defs modules heaps cs
# (n_generics, gen_defs) = usize gen_defs
| index == n_generics
= (gen_defs, type_defs, class_defs, modules, heaps, cs)
# (gen_defs, type_defs, class_defs, modules, heaps, cs)
= check_generic_def index mod_index opt_icl_info gen_defs type_defs class_defs modules heaps cs
= check_generics (inc index) mod_index opt_icl_info gen_defs type_defs class_defs modules heaps cs
check_generic_def index mod_index opt_icl_info gen_defs type_defs class_defs modules heaps cs
| has_to_be_checked mod_index index opt_icl_info
= check_generic index mod_index gen_defs type_defs class_defs modules heaps cs
= (gen_defs, type_defs, class_defs, modules, heaps, cs)
has_to_be_checked module_index generic_index No
= True
has_to_be_checked module_index generic_index (Yes ({copied_generic_defs}, n_cached_dcl_mods))
= not (module_index < n_cached_dcl_mods && generic_index < size copied_generic_defs && copied_generic_defs.[generic_index])
check_generic index mod_index gen_defs type_defs class_defs modules heaps cs
# (gen_def=:{gen_ident, gen_pos}, gen_defs) = gen_defs![index]
# cs = pushErrorAdmin (newPosition gen_ident gen_pos) cs
# (gen_def, heaps) = alloc_gen_info gen_def heaps
# (gen_def, type_defs, class_defs, modules, heaps, cs)
= check_generic_type gen_def mod_index type_defs class_defs modules heaps cs
# gen_defs = {gen_defs & [index] = gen_def}
# (cs=:{cs_x}) = popErrorAdmin cs
#! cs = { cs & cs_x = {cs_x & x_needed_modules = cs_x.x_needed_modules bitor cNeedStdGeneric}}
= (gen_defs, type_defs, class_defs, modules, heaps, cs)
alloc_gen_info gen_def heaps=:{hp_generic_heap}
# initial_info =
{ gen_classes = createArray 32 []
, gen_var_kinds = []
, gen_OBJECT_CONS_FIELD_indices = createArray 3 {ocf_module = -1,ocf_index = -1,ocf_ident={id_name="",id_info=nilPtr}}
}
# (gen_info_ptr, hp_generic_heap) = newPtr initial_info hp_generic_heap
= ( {gen_def & gen_info_ptr = gen_info_ptr},
{heaps & hp_generic_heap = hp_generic_heap})
check_generic_type gen_def=:{gen_type, gen_vars, gen_ident, gen_pos} module_index type_defs class_defs modules heaps=:{hp_type_heaps} cs
#! (checked_gen_type, _, type_defs, class_defs, modules, hp_type_heaps, cs)
= checkFunctionType module_index gen_type FSP_None type_defs class_defs modules hp_type_heaps cs
#! (checked_gen_vars, cs) = check_generic_vars gen_vars checked_gen_type.st_vars cs
#! checked_gen_type = { checked_gen_type & st_vars = move_gen_vars checked_gen_vars checked_gen_type.st_vars}
#! (hp_type_heaps, cs) = check_no_generic_vars_in_contexts checked_gen_type checked_gen_vars hp_type_heaps cs
= ( {gen_def & gen_type = checked_gen_type, gen_vars = checked_gen_vars}
, type_defs
, class_defs
, modules
, {heaps & hp_type_heaps = hp_type_heaps}
, cs
)
where
check_generic_vars gen_vars st_vars cs=:{cs_error}
# (gen_vars, _, cs_error) = foldSt check_generic_var gen_vars ([], st_vars, cs_error)
= (reverse gen_vars, {cs & cs_error = cs_error})
// make sure generic variables are first
move_gen_vars gen_vars st_vars
= gen_vars ++ (removeMembers st_vars gen_vars)
check_generic_var gv (acc_gvs, [], error)
= (acc_gvs, [], checkError gv.tv_ident "generic variable not used" error)
check_generic_var gv (acc_gvs, [tv:tvs], error)
| gv.tv_ident.id_name == tv.tv_ident.id_name
= ([tv:acc_gvs], tvs, error)
# (acc_gvs, tvs, error) = check_generic_var gv (acc_gvs, tvs, error)
= (acc_gvs, [tv:tvs], error)
// returns reversed variable list
add_vars_to_symbol_table gen_vars type_heaps=:{th_vars} cs=:{cs_error, cs_symbol_table}
#! (rev_gen_vars,cs_symbol_table,th_vars, cs_error)
= foldSt add_var_to_symbol_table gen_vars ([],cs.cs_symbol_table,th_vars, cs_error)
= ( rev_gen_vars,
{type_heaps & th_vars = th_vars},
{cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table})
add_var_to_symbol_table :: !TypeVar !(![TypeVar], !*SymbolTable, !*TypeVarHeap, !*ErrorAdmin)
-> (![TypeVar],!*SymbolTable,!*TypeVarHeap,!*ErrorAdmin)
add_var_to_symbol_table tv=:{tv_ident={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 "generic variable already defined" error)
// also reverses variable list (but does not make coffe)
remove_vars_from_symbol_table rev_gen_vars cs=:{cs_symbol_table}
#! (gen_vars, cs_symbol_table) = foldSt remove_var_from_symbol_table rev_gen_vars ([], cs_symbol_table)
= (gen_vars, { cs & cs_symbol_table = cs_symbol_table})
remove_var_from_symbol_table tv=:{tv_ident={id_name,id_info}} (gen_vars, symbol_table)
#! (entry, symbol_table) = readPtr id_info symbol_table
#! symbol_table = writePtr id_info entry.ste_previous symbol_table
=([tv:gen_vars], symbol_table)
check_no_generic_vars_in_contexts :: !SymbolType ![TypeVar] !*TypeHeaps !*CheckState -> (!*TypeHeaps, !*CheckState)
check_no_generic_vars_in_contexts gen_type gen_vars th=:{th_vars} cs=:{cs_error}
#! th_vars = clear_type_vars gen_type.st_vars th_vars
#! th_vars = mark_type_vars_used gen_vars th_vars
#! (th_vars, cs_error) = check_type_vars_not_used gen_type.st_context th_vars cs_error
#! th_vars = clear_type_vars gen_type.st_vars th_vars
= ({th & th_vars = th_vars}, {cs & cs_error = cs_error})
where
mark_type_vars_used gen_vars th_vars
= foldSt (write_type_var_info TVI_Used) gen_vars th_vars
clear_type_vars gen_vars th_vars
= foldSt (write_type_var_info TVI_Empty) gen_vars th_vars
write_type_var_info tvi {tv_ident, tv_info_ptr} th_vars
= writePtr tv_info_ptr tvi th_vars
check_type_vars_not_used :: ![TypeContext] !*TypeVarHeap !*ErrorAdmin -> (!*TypeVarHeap, !*ErrorAdmin)
check_type_vars_not_used contexts th_vars cs_error
# types = flatten [tc_types \\ {tc_types} <- contexts]
# atypes = [{at_type=t,at_attribute=TA_None} \\ t <- types]
= performOnTypeVars check_type_var_not_used atypes (th_vars, cs_error)
check_type_var_not_used attr tv=:{tv_ident, tv_info_ptr} (th_vars, cs_error)
#! (tv_info, th_vars) = readPtr tv_info_ptr th_vars
= case tv_info of
TVI_Empty
-> (th_vars, cs_error)
TVI_Used
#! cs_error = checkError tv_ident "context restrictions on generic variables are not allowed" cs_error
-> (th_vars, cs_error)
_ -> abort ("check_no_generic_vars_in_contexts: wrong TVI" ---> (tv, tv_info))
checkGenericCaseDefs :: !Index !*{#GenericCaseDef} !*{#GenericDef} !u:{#CheckedTypeDef} !*{#DclModule} !*Heaps !*CheckState
-> (!*{#GenericCaseDef},!*{#GenericDef},!u:{#CheckedTypeDef},!*{#DclModule},!.Heaps,!.CheckState)
checkGenericCaseDefs mod_index gen_case_defs generic_defs type_defs modules heaps cs
= check_instances 0 mod_index gen_case_defs generic_defs type_defs modules heaps cs
where
check_instances index mod_index gen_case_defs generic_defs type_defs modules heaps cs
# (n_gc, gen_inst_defs) = usize gen_case_defs
| index == n_gc
= (gen_case_defs, generic_defs, type_defs, modules, heaps, cs)
# (gen_case_defs, generic_defs, type_defs, modules, heaps, cs)
= check_instance index mod_index gen_case_defs generic_defs type_defs modules heaps cs
= check_instances (inc index) mod_index gen_case_defs generic_defs type_defs modules heaps cs
check_instance index mod_index gen_case_defs generic_defs type_defs modules heaps cs
#! (case_def=:{gc_ident,gc_gident,gc_pos,gc_type}, gen_case_defs) = gen_case_defs ! [index]
#! cs = pushErrorAdmin (newPosition gc_ident gc_pos) cs
#! (gc_type, gc_type_cons, type_defs, modules, heaps, cs)
= check_instance_type mod_index gc_type type_defs modules heaps cs
#! (generic_gi, cs) = get_generic_index gc_gident mod_index cs
| not cs.cs_error.ea_ok
# cs = popErrorAdmin cs
= (gen_case_defs, generic_defs, type_defs, modules, heaps, cs)
#! case_def =
{ case_def
& gc_generic = generic_gi
, gc_type = gc_type
, gc_type_cons = gc_type_cons
}
#! gen_case_defs = { gen_case_defs & [index] = case_def }
#! (cs=:{cs_x}) = popErrorAdmin cs
#! cs = { cs & cs_x = {cs_x & x_needed_modules = cs_x.x_needed_modules bitor cNeedStdGeneric}}
= (gen_case_defs, generic_defs, type_defs, modules, heaps, cs)
check_instance_type module_index (TA type_cons []) type_defs modules heaps=:{hp_type_heaps} cs
# (entry, cs_symbol_table) = readPtr type_cons.type_ident.id_info cs.cs_symbol_table
# cs = {cs & cs_symbol_table = cs_symbol_table}
# (type_index, type_module) = retrieveGlobalDefinition entry STE_Type module_index
| type_index == NotFound
# cs_error = checkError type_cons.type_ident "generic argument type undefined" cs.cs_error
= (TA type_cons [], TypeConsSymb type_cons, type_defs, modules,{heaps&hp_type_heaps = hp_type_heaps}, {cs&cs_error=cs_error})
# (type_def, type_defs, modules)
= getTypeDef module_index {glob_module=type_module, glob_object=type_index} type_defs modules
# type_cons = { type_cons & type_index = { glob_object = type_index, glob_module = type_module }}
| type_synonym_with_arguments type_def.td_rhs type_def.td_arity
# cs = {cs & cs_error = checkError type_def.td_ident "synonym type not allowed" cs.cs_error}
= (TA type_cons [], TypeConsSymb type_cons, type_defs, modules,{heaps&hp_type_heaps = hp_type_heaps}, cs)
= (TA type_cons [], TypeConsSymb type_cons, type_defs, modules,{heaps&hp_type_heaps = hp_type_heaps}, cs)
where
type_synonym_with_arguments (SynType _) arity
= arity>0
type_synonym_with_arguments _ _
= False
check_instance_type module_index (TB b) type_defs modules heaps cs
= (TB b, TypeConsBasic b, type_defs, modules,heaps, cs)
check_instance_type module_index TArrow type_defs modules heaps cs
= (TArrow, TypeConsArrow, type_defs, modules, heaps , cs)
// General instance ..
check_instance_type module_index (TV tv) type_defs modules heaps=:{hp_type_heaps} cs
# (tv_info_ptr, th_vars) = newPtr TVI_Empty hp_type_heaps.th_vars
# tv = {tv & tv_info_ptr = tv_info_ptr}
= ( TV tv, TypeConsVar tv, type_defs, modules
, {heaps& hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}, cs)
// .. General instance
check_instance_type module_index ins_type type_defs modules heaps cs=:{cs_error}
# cs_error = checkError {id_name="<>",id_info=nilPtr} "invalid generic type argument" cs_error
= (ins_type, TypeConsArrow, type_defs, modules, heaps, {cs & cs_error=cs_error})
get_generic_index :: !Ident !Index !*CheckState -> (!GlobalIndex, !*CheckState)
get_generic_index {id_name,id_info} mod_index cs=:{cs_symbol_table}
# (ste, cs_symbol_table) = readPtr id_info cs_symbol_table
# cs = {cs & cs_symbol_table = cs_symbol_table}
= case ste.ste_kind of
STE_Generic
-> ({gi_module=mod_index,gi_index = ste.ste_index}, cs)
STE_Imported STE_Generic imported_generic_module
-> ({gi_module=imported_generic_module,gi_index = ste.ste_index}, cs)
_ -> ( {gi_module=NoIndex,gi_index = NoIndex}
, {cs & cs_error = checkError id_name "generic undefined" cs.cs_error})
convert_generic_instances :: !.[GenericCaseDef] !Int -> (!.[FunDef], !.[GenericCaseDef])
convert_generic_instances [gc=:{gc_ident, gc_body=GCB_FunDef fun_def} : gcs] next_fun_index
# (fun_defs, gcs) = convert_generic_instances gcs (inc next_fun_index)
# gc = { gc & gc_body = GCB_FunIndex next_fun_index }
= ([fun_def : fun_defs], [gc:gcs])
//---> ("convert generic case: user defined function", gc.gc_ident, gc.gc_type_cons, next_fun_index)
convert_generic_instances [gc=:{gc_ident,gc_pos, gc_type_cons, gc_body=GCB_None} : gcs] next_fun_index
# (fun_defs, gcs) = convert_generic_instances gcs (inc next_fun_index)
# fun_def =
{ fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
, fun_arity = 0
, fun_priority = NoPrio
, fun_body = GeneratedBody
, fun_type = No
, fun_pos = gc_pos
, fun_kind = FK_Unknown
, fun_lifted = 0
, fun_info = EmptyFunInfo
}
# gc = { gc & gc_body = GCB_FunIndex next_fun_index }
= ([fun_def:fun_defs], [gc:gcs])
//---> ("convert generic case: function to derive ", gc.gc_ident, gc.gc_type_cons, next_fun_index)
convert_generic_instances [] next_fun_index
= ([], [])
create_gencase_funtypes :: !Index !*{#GenericCaseDef} !*Heaps
-> (!Index,![FunType],!*{#GenericCaseDef},!*Heaps)
create_gencase_funtypes fun_index gencase_defs heaps
#! (fun_index, new_funs, gencase_defs, hp_var_heap)
= create_funs 0 fun_index gencase_defs heaps.hp_var_heap
= (fun_index, new_funs, gencase_defs, {heaps & hp_var_heap = hp_var_heap})
where
create_funs gc_index fun_index gencase_defs hp_var_heap
| gc_index == size gencase_defs
= (fun_index, [], gencase_defs, hp_var_heap)
#! (fun, gencase_defs,hp_var_heap)
= create_fun gc_index fun_index gencase_defs hp_var_heap
#! (fun_index, funs, gencase_defs,hp_var_heap)
= create_funs (inc gc_index) (inc fun_index) gencase_defs hp_var_heap
= (fun_index, [fun:funs], gencase_defs, hp_var_heap)
create_fun gc_index fun_index gencase_defs hp_var_heap
# (gencase_def=:{gc_ident, gc_pos, gc_type_cons}, gencase_defs) = gencase_defs ! [gc_index]
# gencase_def = { gencase_def & gc_body = GCB_FunIndex fun_index }
# gencase_defs = {gencase_defs & [gc_index] = gencase_def}
#! fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
#! (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap
#! fun = { ft_ident = fun_ident
, ft_arity = 0
, ft_priority = NoPrio
, ft_type = {st_vars=[],st_attr_vars=[],st_arity=0,st_args=[],st_result={at_type=TE,at_attribute=TA_Multi},st_attr_env=[],st_context=[],st_args_strictness=NotStrict}
, ft_pos = gc_pos
, ft_specials = FSP_None
, ft_type_ptr = var_info_ptr }
= (fun, gencase_defs, hp_var_heap)
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 })
getTypeDef :: !Index !(Global Index) !v:{#CheckedTypeDef} !w:{#DclModule}
-> (!CheckedTypeDef, !v:{#CheckedTypeDef}, !w:{#DclModule})
getTypeDef x_main_dcl_module_n {glob_module,glob_object} type_defs modules
| glob_module==x_main_dcl_module_n
# (type_def, type_defs) = type_defs![glob_object]
= (type_def, type_defs, modules)
# (type_def, modules) = modules![glob_module].dcl_common.com_type_defs.[glob_object]
= (type_def, type_defs, modules)
|
