Commit 42496f31 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

removed kind correctness checking module

parent 2218df38
......@@ -7,4 +7,14 @@ partionateAndExpandTypes :: !NumberSet !Index !*CommonDefs !*{#DclModule} !*Type
:: TypeGroups :== [[GlobalIndex]]
analyseTypeDefs :: !{#CommonDefs} !TypeGroups !*TypeDefInfos !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin)
analyseTypeDefs :: !{#CommonDefs} !TypeGroups !*TypeDefInfos !*TypeVarHeap !*ErrorAdmin -> (!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin)
determineKindsOfClasses :: !NumberSet !{#CommonDefs} !*TypeDefInfos !*TypeVarHeap !*ErrorAdmin
-> (!*ClassDefInfos, !*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin)
checkKindsOfCommonDefsAndFunctions :: !Index !Index !NumberSet !IndexRange !{#CommonDefs} !u:{# FunDef} !v:{#DclModule} !*TypeDefInfos !*ClassDefInfos
!*TypeVarHeap !*ErrorAdmin -> (!u:{# FunDef}, !v:{#DclModule}, !*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin)
isATopConsVar cv :== cv < 0
encodeTopConsVar cv :== dec (~cv)
decodeTopConsVar cv :== ~(inc cv)
This diff is collapsed.
......@@ -903,16 +903,17 @@ checkCommonDefinitions is_dcl module_index common modules type_heaps var_heap cs
(size_com_selector_defs,com_selector_defs) = usize com_selector_defs
(size_com_cons_defs,com_cons_defs) = usize com_cons_defs
(com_class_defs, modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, var_heap, cs)
(com_class_defs, modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, var_heap, cs_symbol_table)
= createClassDictionaries module_index com_class_defs modules size_com_type_defs size_com_selector_defs size_com_cons_defs
type_heaps.th_vars var_heap cs
type_heaps.th_vars var_heap cs.cs_symbol_table
com_type_defs = array_plus_list com_type_defs new_type_defs
com_selector_defs = array_plus_list com_selector_defs new_selector_defs
com_cons_defs = array_plus_list com_cons_defs new_cons_defs
= ({common & com_type_defs = com_type_defs, com_cons_defs = com_cons_defs, com_selector_defs = com_selector_defs, com_class_defs = com_class_defs,
com_member_defs = com_member_defs, com_instance_defs = com_instance_defs, /* AA */ com_generic_defs = com_generic_defs }, modules, { type_heaps & th_vars = th_vars }, var_heap, cs)
com_member_defs = com_member_defs, com_instance_defs = com_instance_defs, /* AA */ com_generic_defs = com_generic_defs }, modules,
{ type_heaps & th_vars = th_vars }, var_heap, { cs & cs_symbol_table = cs_symbol_table })
collectCommonfinitions :: !(CollectedDefinitions ClassInstance a) -> (!*{# Int}, ![Declaration])
collectCommonfinitions {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances, def_generics}
......
......@@ -20,17 +20,7 @@ checkSuperClasses :: ![TypeVar] ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{
checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType) !u:{# CheckedTypeDef} !u:{# DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState
-> (!u:{# CheckedTypeDef}, !u:{# DclModule}, !*TypeHeaps, !*ExpressionHeap, !*CheckState)
createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !*TypeVarHeap !*VarHeap !*CheckState
-> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*CheckState)
/*
bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps;
clearBindingsOfTypeVarsAndAttributes :: !TypeAttribute ![ATypeVar] !*TypeHeaps -> *TypeHeaps;
*/
isATopConsVar cv :== cv < 0
encodeTopConsVar cv :== dec (~cv)
decodeTopConsVar cv :== ~(inc cv)
/*
expandSynonymTypes :: !.Index !*{#CheckedTypeDef} !*{#.DclModule} !*TypeHeaps !*ErrorAdmin
-> (!.{#CheckedTypeDef},!.{#DclModule},!.TypeHeaps,!.ErrorAdmin)
*/
createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !*TypeVarHeap !*VarHeap !*SymbolTable
-> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*SymbolTable)
removeVariablesFromSymbolTable :: !Int ![TypeVar] !*SymbolTable -> *SymbolTable
......@@ -174,10 +174,6 @@ addToAttributeEnviron _ _ attr_env error
emptyIdent name :== { id_name = name, id_info = nilPtr }
isATopConsVar cv :== cv < 0
encodeTopConsVar cv :== dec (~cv)
decodeTopConsVar cv :== ~(inc cv)
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}
# (type_def, ts_type_defs) = ts_type_defs![type_index]
......@@ -1161,18 +1157,15 @@ removeVariablesFromSymbolTable scope vars symbol_table
makeAttributedType attr annot type :== { at_attribute = attr, at_annotation = annot, at_type = type }
createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !*TypeVarHeap !*VarHeap !*CheckState
-> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*CheckState)
createClassDictionaries mod_index class_defs modules first_type_index first_selector_index first_cons_index type_var_heap var_heap cs
| cs.cs_error.ea_ok
# (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) = create_class_dictionaries mod_index 0 class_defs modules []
{ index_type = first_type_index, index_cons= first_cons_index, index_selector = first_selector_index } type_var_heap var_heap cs
(type_defs, sel_defs, cons_defs, cs_symbol_table) = foldSt collect_type_def rev_dictionary_list ([], [], [], cs.cs_symbol_table)
= (class_defs, modules, type_defs, sel_defs, cons_defs, type_var_heap, var_heap, {cs & cs_symbol_table = cs_symbol_table })
= (class_defs, modules, [], [], [], type_var_heap, var_heap, cs)
where
createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !*TypeVarHeap !*VarHeap !*SymbolTable
-> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*SymbolTable)
createClassDictionaries mod_index class_defs modules first_type_index first_selector_index first_cons_index type_var_heap var_heap symbol_table
# (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, symbol_table)
= create_class_dictionaries mod_index 0 class_defs modules []
{ index_type = first_type_index, index_cons= first_cons_index, index_selector = first_selector_index } type_var_heap var_heap symbol_table
(type_defs, sel_defs, cons_defs, symbol_table) = foldSt collect_type_def rev_dictionary_list ([], [], [], symbol_table)
= (class_defs, modules, type_defs, sel_defs, cons_defs, type_var_heap, var_heap, symbol_table)
where
collect_type_def type_ptr (type_defs, sel_defs, cons_defs, symbol_table)
# ({ ste_kind = STE_DictType type_def }, symbol_table) = readPtr type_ptr symbol_table
(RecordType {rt_constructor, rt_fields}) = type_def.td_rhs
......@@ -1194,91 +1187,71 @@ where
= create_class_dictionaries mod_index (inc class_index) class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs
= (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs)
create_class_dictionary :: !Index !Index !*{#ClassDef} !w:{#DclModule} !v:[SymbolPtr] !u:Indexes !*TypeVarHeap !*VarHeap !*CheckState
-> (!*{#ClassDef}, !w:{#DclModule}, !v:[SymbolPtr], !u:Indexes, !*TypeVarHeap, !*VarHeap, !*CheckState)
create_class_dictionary :: !Index !Index !*{#ClassDef} !w:{#DclModule} !v:[SymbolPtr] !u:Indexes !*TypeVarHeap !*VarHeap !*SymbolTable
-> (!*{#ClassDef}, !w:{#DclModule}, !v:[SymbolPtr], !u:Indexes, !*TypeVarHeap, !*VarHeap, !*SymbolTable)
create_class_dictionary mod_index class_index class_defs =:{[class_index] = class_def } modules rev_dictionary_list
indexes type_var_heap var_heap cs=:{cs_symbol_table,cs_error}
indexes type_var_heap var_heap symbol_table
# {class_name,class_args,class_arity,class_members,class_context,class_dictionary=ds=:{ds_ident={id_name,id_info}}} = class_def
| isNilPtr id_info
# (type_id_info, cs_symbol_table) = newPtr EmptySymbolTableEntry cs_symbol_table
nr_of_members = size class_members
nr_of_fields = nr_of_members + length class_context
rec_type_id = { class_name & id_info = type_id_info}
class_dictionary = { ds & ds_ident = rec_type_id }
class_defs = { class_defs & [class_index] = { class_def & class_dictionary = class_dictionary}}
(class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs)
= create_class_dictionaries_of_contexts mod_index class_context class_defs modules
rev_dictionary_list indexes type_var_heap var_heap { cs & cs_symbol_table = cs_symbol_table }
{ index_type, index_cons, index_selector } = indexes
type_symb = MakeTypeSymbIdent { glob_object = index_type, glob_module = mod_index } rec_type_id class_arity
rec_type = makeAttributedType TA_Multi AN_Strict (TA type_symb [makeAttributedType TA_Multi AN_None TE \\ i <- [1..class_arity]])
field_type = makeAttributedType TA_Multi AN_None TE
(rev_fields, var_heap, cs_symbol_table)
= build_fields 0 nr_of_members class_members rec_type field_type index_type index_selector [] var_heap cs.cs_symbol_table
(index_selector, rev_fields, rev_field_types, class_defs, modules, var_heap, cs_symbol_table)
= build_context_fields mod_index nr_of_members class_context rec_type index_type (index_selector + nr_of_members) rev_fields
[ { field_type & at_annotation = AN_Strict } \\ i <- [1..nr_of_members] ] class_defs modules var_heap cs_symbol_table
(cons_id_info, cs_symbol_table) = newPtr EmptySymbolTableEntry cs_symbol_table
rec_cons_id = { class_name & id_info = cons_id_info}
cons_symbol = { ds_ident = rec_cons_id, ds_arity = nr_of_fields, ds_index = index_cons }
(cons_type_ptr, var_heap) = newPtr VI_Empty var_heap
(td_args, type_var_heap) = mapSt new_attributed_type_variable class_args type_var_heap
type_def =
{ td_name = rec_type_id
, td_index = index_type
, td_arity = 0
, td_args = td_args
, td_attrs = []
, td_context = []
, td_rhs = RecordType {rt_constructor = cons_symbol, rt_fields = { field \\ field <- reverse rev_fields }}
, td_attribute = TA_None
, td_pos = NoPos
, td_used_types = []
}
cons_def =
{ cons_symb = rec_cons_id
, cons_type = { st_vars = [], st_args = reverse rev_field_types, st_result = rec_type,
st_arity = nr_of_fields, st_context = [], st_attr_vars = [], st_attr_env = [] }
, cons_priority = NoPrio
, cons_index = 0
, cons_type_index = index_type
, cons_exi_vars = []
, cons_arg_vars = []
, cons_type_ptr = cons_type_ptr
, cons_pos = NoPos
}
= ({ class_defs & [class_index] = { class_def & class_dictionary = { class_dictionary & ds_index = index_type }}}, modules,
[ type_id_info : rev_dictionary_list ], { index_type = inc index_type, index_cons = inc index_cons, index_selector = index_selector },
type_var_heap, var_heap, { cs & cs_symbol_table = cs_symbol_table
<:= (type_id_info, { ste_kind = STE_DictType type_def, ste_index = index_type,
ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" })
<:= (cons_id_info, { ste_kind = STE_DictCons cons_def, ste_index = index_cons,
ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" })})
# ({ste_kind}, cs_symbol_table) = readPtr id_info cs_symbol_table
| ste_kind == STE_Empty
= (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap,
{ cs & cs_symbol_table = cs_symbol_table, cs_error = checkError class_name "cyclic dependencies between type classes" cs_error})
= (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, { cs & cs_symbol_table = cs_symbol_table })
create_class_dictionaries_of_contexts mod_index [{tc_class = {glob_module, glob_object={ds_index}}}:tcs] class_defs modules
rev_dictionary_list indexes type_var_heap var_heap cs
| mod_index == glob_module
# (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs)
= create_class_dictionary mod_index ds_index class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs
= create_class_dictionaries_of_contexts mod_index tcs class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs
= create_class_dictionaries_of_contexts mod_index tcs class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs
create_class_dictionaries_of_contexts mod_index [] class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs
= (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs)
# (type_id_info, symbol_table) = newPtr EmptySymbolTableEntry symbol_table
nr_of_members = size class_members
nr_of_fields = nr_of_members + length class_context
rec_type_id = { class_name & id_info = type_id_info}
class_dictionary = { ds & ds_ident = rec_type_id }
{ index_type, index_cons, index_selector } = indexes
type_symb = MakeTypeSymbIdent { glob_object = index_type, glob_module = mod_index } rec_type_id class_arity
rec_type = makeAttributedType TA_Multi AN_Strict (TA type_symb [makeAttributedType TA_Multi AN_None TE \\ i <- [1..class_arity]])
field_type = makeAttributedType TA_Multi AN_None TE
(rev_fields, var_heap, symbol_table)
= build_fields 0 nr_of_members class_members rec_type field_type index_type index_selector [] var_heap symbol_table
(index_selector, rev_fields, rev_field_types, class_defs, modules, var_heap, symbol_table)
= build_context_fields mod_index nr_of_members class_context rec_type index_type (index_selector + nr_of_members) rev_fields
[ { field_type & at_annotation = AN_Strict } \\ i <- [1..nr_of_members] ] class_defs modules var_heap symbol_table
(cons_id_info, symbol_table) = newPtr EmptySymbolTableEntry symbol_table
rec_cons_id = { class_name & id_info = cons_id_info}
cons_symbol = { ds_ident = rec_cons_id, ds_arity = nr_of_fields, ds_index = index_cons }
(cons_type_ptr, var_heap) = newPtr VI_Empty var_heap
(td_args, type_var_heap) = mapSt new_attributed_type_variable class_args type_var_heap
type_def =
{ td_name = rec_type_id
, td_index = index_type
, td_arity = 0
, td_args = td_args
, td_attrs = []
, td_context = []
, td_rhs = RecordType {rt_constructor = cons_symbol, rt_fields = { field \\ field <- reverse rev_fields }}
, td_attribute = TA_None
, td_pos = NoPos
, td_used_types = []
}
cons_def =
{ cons_symb = rec_cons_id
, cons_type = { st_vars = [], st_args = reverse rev_field_types, st_result = rec_type,
st_arity = nr_of_fields, st_context = [], st_attr_vars = [], st_attr_env = [] }
, cons_priority = NoPrio
, cons_index = 0
, cons_type_index = index_type
, cons_exi_vars = []
, cons_arg_vars = []
, cons_type_ptr = cons_type_ptr
, cons_pos = NoPos
}
= ({ class_defs & [class_index] = { class_def & class_dictionary = { class_dictionary & ds_index = index_type }}}, modules,
[ type_id_info : rev_dictionary_list ], { index_type = inc index_type, index_cons = inc index_cons, index_selector = index_selector },
type_var_heap, var_heap,
symbol_table <:= (type_id_info, { ste_kind = STE_DictType type_def, ste_index = index_type,
ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" })
<:= (cons_id_info, { ste_kind = STE_DictCons cons_def, ste_index = index_cons,
ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" }))
new_attributed_type_variable tv type_var_heap
# (new_tv_ptr, type_var_heap) = newPtr TVI_Empty type_var_heap
......@@ -1313,7 +1286,6 @@ where
, sd_type = { st_vars = [], st_args = [ rec_type ], st_result = field_type, st_arity = 1,
st_context = [], st_attr_vars = [], st_attr_env = [] }
, sd_exi_vars = []
// , sd_exi_attrs = []
, sd_field_nr = field_nr
, sd_type_index = rec_type_index
, sd_type_ptr = sd_type_ptr
......
......@@ -4,7 +4,7 @@
implementation module frontend
import scanner, parse, postparse, check, type, trans, convertcases, overloading, utilities, convertDynamics,
convertimportedtypes, checkKindCorrectness, compilerSwitches, analtypes, generics
convertimportedtypes, /*checkKindCorrectness, */ compilerSwitches, analtypes, generics
SwitchGenerics on off :== off
......@@ -80,12 +80,12 @@ frontSyntaxTree cached_functions_and_macros cached_dcl_mods n_functions_and_macr
},cached_functions_and_macros,cached_dcl_mods,n_functions_and_macros_in_dcl_modules,main_dcl_module_n,predef_symbols,hash_table,files,error,io,out,tcl_file,heaps
)
//import StdDebug
// import StdDebug
frontEndInterface :: !FrontEndOptions !Ident !SearchPaths !{#DclModule} !{#FunDef} !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File (!Optional !*File) !*Heaps
-> ( !Optional *FrontEndSyntaxTree,!*{# FunDef },!{#DclModule},!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional !*File, !*Heaps)
frontEndInterface options mod_ident search_paths cached_dcl_modules functions_and_macros list_inferred_types predef_symbols hash_table files error io out tcl_file heaps
// # files = trace_n ("Compiling "+++mod_ident.id_name) files
// # files = trace_n ("Compiling "+++mod_ident.id_name) files
# (ok, mod, hash_table, error, predef_symbols, files)
= wantModule cWantIclFile mod_ident NoPos options.feo_generics(hash_table /* ---> ("Parsing:", mod_ident)*/) error search_paths predef_symbols files
......@@ -147,9 +147,18 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an
# (type_groups, ti_common_defs, td_infos, icl_common, dcl_mods, type_heaps, error_admin)
= partionateAndExpandTypes icl_used_module_numbers main_dcl_module_n icl_common dcl_mods type_heaps error_admin
ti_common_defs = { ti_common_defs & [main_dcl_module_n] = icl_common }
# (td_infos, type_heaps, error_admin) = analyseTypeDefs ti_common_defs type_groups td_infos type_heaps error_admin
# (td_infos, th_vars, error_admin) = analyseTypeDefs ti_common_defs type_groups td_infos type_heaps.th_vars error_admin
/*
(fun_defs, dcl_mods, th_vars, td_infos, error_admin)
= checkKindCorrectness main_dcl_module_n nr_of_chached_functions_and_macros icl_instances ti_common_defs n_cached_dcl_modules fun_defs dcl_mods type_heaps.th_vars td_infos error_admin
*/
(class_infos, td_infos, th_vars, error_admin)
= determineKindsOfClasses icl_used_module_numbers ti_common_defs td_infos th_vars error_admin
#! nr_of_icl_functions = icl_mod.icl_instances.ir_from
# (fun_defs, dcl_mods, td_infos, th_vars, error_admin)
= checkKindsOfCommonDefsAndFunctions n_cached_dcl_modules main_dcl_module_n icl_used_module_numbers global_fun_range
ti_common_defs fun_defs dcl_mods td_infos class_infos th_vars error_admin
type_heaps = { type_heaps & th_vars = th_vars }
# heaps = { heaps & hp_type_heaps = type_heaps }
# (saved_main_dcl_common, ti_common_defs) = replace (dcl_common_defs dcl_mods) main_dcl_module_n icl_common
......
......@@ -232,18 +232,17 @@ convertGenerics
}
}
#! (gs_dcl_modules, gs_modules, gs_heaps, cs) =
create_class_dictionaries 0 gs_dcl_modules gs_modules gs_heaps cs
#! (gs_dcl_modules, gs_modules, gs_heaps, cs_symbol_table) =
create_class_dictionaries 0 gs_dcl_modules gs_modules gs_heaps cs.cs_symbol_table
// create_class_dictionaries1 main_dcl_module_n dcl_modules gs_modules gs_heaps cs
//---> "*** create class dictionaries"
# {cs_symbol_table, cs_predef_symbols, cs_error} = cs
# hash_table = { hash_table & hte_symbol_heap = cs_symbol_table }
#! index_range = {ir_from = gs.gs_first_fun, ir_to = gs.gs_last_fun}
= ( gs_groups, gs_modules, gs_fun_defs, index_range, gs_td_infos, gs_heaps, hash_table,
cs_predef_symbols, gs_dcl_modules, gs_opt_dcl_icl_conversions, cs_error)
cs.cs_predef_symbols, gs_dcl_modules, gs_opt_dcl_icl_conversions, cs.cs_error)
where
return { gs_modules, gs_groups, gs_fun_defs, gs_td_infos, gs_gtd_infos,
gs_heaps, gs_main_dcl_module_n, gs_dcl_modules, gs_opt_dcl_icl_conversions, gs_error}
......@@ -252,21 +251,21 @@ where
gs_td_infos, gs_heaps, hash_table, predefs, gs_dcl_modules,
gs_opt_dcl_icl_conversions, gs_error)
create_class_dictionaries module_index dcl_modules modules heaps cs
create_class_dictionaries module_index dcl_modules modules heaps symbol_table
#! size_of_modules = size modules
| module_index == size_of_modules
= (dcl_modules, modules, heaps, cs)
#! (dcl_modules, modules, heaps, cs) =
create_class_dictionaries1 module_index dcl_modules modules heaps cs
= create_class_dictionaries (inc module_index) dcl_modules modules heaps cs
= (dcl_modules, modules, heaps, symbol_table)
#! (dcl_modules, modules, heaps, symbol_table) =
create_class_dictionaries1 module_index dcl_modules modules heaps symbol_table
= create_class_dictionaries (inc module_index) dcl_modules modules heaps symbol_table
create_class_dictionaries1
module_index dcl_modules modules
heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}, hp_var_heap}
cs
symbol_table
#! (common_defs, modules) = modules![module_index]
#! class_defs = { x \\ x <-: common_defs.com_class_defs } // make unique copy
#! (class_defs, dcl_modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, hp_var_heap, cs) =
#! (class_defs, dcl_modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, hp_var_heap, symbol_table) =
createClassDictionaries
module_index
class_defs
......@@ -274,7 +273,7 @@ where
(size common_defs.com_type_defs)
(size common_defs.com_selector_defs)
(size common_defs.com_cons_defs)
th_vars hp_var_heap cs
th_vars hp_var_heap symbol_table
#! common_defs = { common_defs &
com_class_defs = class_defs,
......@@ -284,7 +283,7 @@ where
#! heaps = {heaps & hp_var_heap = hp_var_heap, hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}
#! modules = { modules & [module_index] = common_defs }
= (dcl_modules, modules, heaps, cs)
= (dcl_modules, modules, heaps, symbol_table)
convertInstances :: !*GenericState
-> (![Global Index], !*GenericState)
......
......@@ -255,6 +255,8 @@ cNameLocationDependent :== True
, class_arg_kinds :: ![TypeKind] // filled in in checkKindCorrectness phase
}
:: ClassDefInfos :== {# .{! [TypeKind]}}
:: MemberDef =
{ me_symb :: !Ident
, me_class :: !Global Index
......@@ -858,7 +860,7 @@ cNonRecursiveAppl :== False
:: KindInfoPtr :== Ptr KindInfo
:: KindInfo = KI_Var !KindInfoPtr
| KI_Arrow ![KindInfo]
| KI_Arrow !KindInfo !KindInfo
| KI_Const
| KI_ConsVar
......@@ -932,7 +934,7 @@ cNonRecursiveAppl :== False
:: BasicValue = BVI !String | BVC !String | BVB !Bool | BVR !String | BVS !String
:: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow ![TypeKind]
:: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow ![TypeKind] | KindCycle
instance toString TypeKind
instance <<< TypeKind
......
......@@ -247,6 +247,8 @@ cNameLocationDependent :== True
, class_arg_kinds :: ![TypeKind] // filled in in checkKindCorrectness phase
}
:: ClassDefInfos :== {# .{! [TypeKind]}}
:: MemberDef =
{ me_symb :: !Ident
, me_class :: !Global Index
......@@ -839,7 +841,7 @@ cNotVarNumber :== -1
:: KindInfoPtr :== Ptr KindInfo
:: KindInfo = KI_Var !KindInfoPtr
| KI_Arrow ![KindInfo]
| KI_Arrow !KindInfo !KindInfo
| KI_Const
| KI_ConsVar
......@@ -917,8 +919,7 @@ cNotVarNumber :== -1
:: BasicValue = BVI !String | BVC !String | BVB !Bool | BVR !String | BVS !String
//:: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow !Int
:: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow ![TypeKind]
:: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow ![TypeKind] | KindCycle
:: Occurrence =
{ occ_ref_count :: !ReferenceCount
......@@ -935,7 +936,6 @@ cNotVarNumber :== -1
:: OccurrenceBinding = OB_Empty | OB_OpenLet !Expression | OB_LockedLet !Expression
| OB_Pattern ![(FreeVar, Int)] !OccurrenceBinding
// | OB_Closed !LetOccurrences | OB_Marked !LetOccurrences
:: TypeDefInfo =
{ tdi_kinds :: ![TypeKind]
......@@ -1798,14 +1798,12 @@ where
instance toString KindInfo
where
toString (KI_Var ptr) = "*" +++ toString (ptrToInt ptr)
toString (KI_Const) = "*"
toString (KI_Arrow kinds) = kind_list_to_string kinds
toString (KI_Var ptr) = "*" +++ toString (ptrToInt ptr)
toString (KI_Const) = "*"
toString (KI_Arrow kind1 kind2) = withBrackets kind1 (toString kind1) +++ " -> " +++ toString kind2
where
kind_list_to_string [] = " ?????? "
kind_list_to_string [k] = "* -> *"
kind_list_to_string [k:ks] = "* -> " +++ kind_list_to_string ks
withBrackets (KI_Arrow _ _) kind_str = "(" +++ kind_str +++ ")"
withBrackets _ kind_str = kind_str
instance <<< TypeDefInfo
where
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment