Commit 82fd627c authored by Artem Alimarine's avatar Artem Alimarine
Browse files

fixes in generics to compile with Clean 2.0

parent 027616aa
......@@ -852,6 +852,7 @@ where
| module_index == main_module_index
# (class_infos, as) = check_kinds_of_class_instances common_defs 0 common_defs.[module_index].com_instance_defs class_infos as
# (class_infos, gen_heap, as) = check_kinds_of_generics common_defs 0 common_defs.[module_index].com_generic_defs class_infos gen_heap as
# as = check_kinds_of_gencases 0 common_defs.[module_index].com_gencase_defs as
# (icl_fun_defs, class_infos, as) = foldSt (check_kinds_of_icl_fuctions common_defs) icl_fun_def_ranges (icl_fun_defs, class_infos, as)
with
check_kinds_of_icl_fuctions common_defs {ir_from,ir_to} (icl_fun_defs, class_infos, as)
......@@ -860,6 +861,7 @@ where
| module_index >= first_uncached_module
# (class_infos, as) = check_kinds_of_class_instances common_defs 0 common_defs.[module_index].com_instance_defs class_infos as
# (class_infos, gen_heap, as) = check_kinds_of_generics common_defs 0 common_defs.[module_index].com_generic_defs class_infos gen_heap as
# as = check_kinds_of_gencases 0 common_defs.[module_index].com_gencase_defs as
# (dcl_modules, class_infos, as) = check_kinds_of_dcl_fuctions common_defs module_index dcl_modules class_infos as
= (icl_fun_defs, dcl_modules, class_infos, gen_heap, as)
= (icl_fun_defs, dcl_modules, class_infos, gen_heap, as)
......@@ -872,11 +874,8 @@ where
= check_kinds_of_class_instances common_defs (inc instance_index) instance_defs class_infos as
where
check_kinds_of_class_instance :: !{#CommonDefs} !ClassInstance !*ClassDefInfos !*AnalyseState -> (!*ClassDefInfos, !*AnalyseState)
check_kinds_of_class_instance common_defs {ins_generated, ins_class,ins_ident,ins_pos,ins_type={it_vars,it_types,it_context}} class_infos
check_kinds_of_class_instance common_defs {ins_class,ins_ident,ins_pos,ins_type={it_vars,it_types,it_context}} class_infos
as=:{as_type_var_heap,as_kind_heap,as_error}
| ins_generated
// generic instances are cheched in the generic phase
= (class_infos, as)
# as_error = pushErrorAdmin (newPosition ins_ident ins_pos) as_error
(as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars it_vars as_type_var_heap as_kind_heap
as = { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap, as_error = as_error }
......@@ -910,7 +909,8 @@ where
check_kinds_of_generic_vars :: ![TypeKind] !*AnalyseState -> !*AnalyseState
check_kinds_of_generic_vars [gen_kind:gen_kinds] as
| all (\k -> k == gen_kind) gen_kinds
//| all (\k -> k == gen_kind) gen_kinds
| all ((==) KindConst) [gen_kind:gen_kinds] // forcing all kind variables be of kind star
= as
# as_error = checkError
"conflicting kinds: "
......@@ -918,6 +918,27 @@ where
as.as_error
= {as & as_error = as_error}
check_kinds_of_gencases :: !Index !{#GenericCaseDef} !*AnalyseState -> !*AnalyseState
check_kinds_of_gencases index gencases as
| index == size gencases
= as
# as = check_kinds_of_gencase gencases.[index] as
= check_kinds_of_gencases (inc index) gencases as
where
check_kinds_of_gencase gencase=:{gc_type_cons=TypeConsSymb {type_index}} as=:{as_error, as_td_infos}
# ({tdi_kinds}, as_td_infos) = as_td_infos ! [type_index.glob_module, type_index.glob_object]
# kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
# as_error = case rank_of_kind kind > 2 of
True -> checkError kind "only kinds up to rank-2 supported by generics" as_error
False -> as_error
= {as & as_error = as_error, as_td_infos = as_td_infos}
where
rank_of_kind KindConst = 0
rank_of_kind (KindArrow kinds) = 1 + foldr max 0 (map rank_of_kind kinds)
check_kinds_of_gencase gencase as
= as
check_kinds_of_icl_fuction common_defs fun_index (icl_fun_defs, class_infos, as)
# ({fun_type,fun_symb,fun_pos}, icl_fun_defs) = icl_fun_defs![fun_index]
= case fun_type of
......
......@@ -490,12 +490,8 @@ where
check_class_instance :: ClassDef !Index !Index !Index !ClassInstance !u:InstanceSymbols !*TypeHeaps !*CheckState
-> (!ClassInstance, !u:InstanceSymbols, !*TypeHeaps, !*CheckState)
check_class_instance class_def module_index class_index class_mod_index
ins=:{ins_members,ins_class={glob_object = class_name =: {ds_ident = {id_name,id_info},ds_arity}},ins_type,ins_specials,ins_pos,ins_ident,ins_generated}
ins=:{ins_members,ins_class={glob_object = class_name =: {ds_ident = {id_name,id_info},ds_arity}},ins_type,ins_specials,ins_pos,ins_ident}
is=:{is_class_defs,is_modules} type_heaps cs=:{cs_symbol_table}
| ins_generated
= ( ins, is, type_heaps
, { cs & cs_error = checkError id_name "cannot generate class instance" cs.cs_error }
)
| class_def.class_arity == ds_arity
# ins_class = { glob_object = { class_name & ds_index = class_index }, glob_module = class_mod_index}
(ins_type, ins_specials, is_type_defs, is_class_defs, is_modules, type_heaps, cs)
......@@ -530,9 +526,7 @@ where
// otherwise
= (instance_types, instance_defs, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
check_class_instance {ins_pos,ins_class,ins_members,ins_type, ins_generated} mod_index instance_types class_defs member_defs generic_defs type_defs modules var_heap type_heaps cs
| ins_generated
= (instance_types, class_defs, member_defs, generic_defs, type_defs, modules, var_heap, type_heaps, cs)
check_class_instance {ins_pos,ins_class,ins_members,ins_type} mod_index instance_types class_defs member_defs generic_defs type_defs modules var_heap type_heaps cs
# ({class_members,class_name}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules
class_size = size class_members
| class_size == size ins_members
......@@ -810,34 +804,20 @@ where
determine_types_of_instances x_main_dcl_module_n inst_index next_class_inst_index next_mem_inst_index mod_index all_class_specials
class_defs member_defs modules instance_defs type_heaps var_heap predef_symbols error
| inst_index < size instance_defs
# (instance_def, instance_defs) = instance_defs![inst_index]
# {ins_class,ins_pos,ins_type,ins_specials, ins_generated} = instance_def
| ins_generated
// REMOVE ins_generated functionality
# empty_st =
{ st_vars = []
, st_args = []
, st_arity = -1
, st_result = {at_type=TE, at_attribute=TA_None, at_annotation=AN_None}
, st_context = []
, st_attr_vars = []
, st_attr_env = []
}
= undef
# ({class_name, class_members}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules
class_size = size class_members
(ins_members, memb_inst_defs1, member_defs, modules, type_heaps, var_heap, error)
= determine_instance_symbols_and_types x_main_dcl_module_n next_mem_inst_index 0 mod_index ins_class.glob_module class_size class_members
ins_type ins_specials class_name ins_pos member_defs modules type_heaps var_heap error
instance_def = { instance_def & ins_members = { member \\ member <- ins_members }}
(ins_specials, next_class_inst_index, all_class_specials, type_heaps, predef_symbols,error)
= check_instance_specials mod_index instance_def inst_index ins_specials next_class_inst_index all_class_specials type_heaps predef_symbols error
(memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, predef_symbols,error)
= determine_types_of_instances x_main_dcl_module_n (inc inst_index) next_class_inst_index (next_mem_inst_index + class_size) mod_index all_class_specials
class_defs member_defs modules { instance_defs & [inst_index] = { instance_def & ins_specials = ins_specials }} type_heaps var_heap predef_symbols error
= (memb_inst_defs1 ++ memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, predef_symbols,error)
# (instance_def=:{ins_class,ins_pos,ins_type,ins_specials}, instance_defs) = instance_defs![inst_index]
# ({class_name, class_members}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules
class_size = size class_members
(ins_members, memb_inst_defs1, member_defs, modules, type_heaps, var_heap, error)
= determine_instance_symbols_and_types x_main_dcl_module_n next_mem_inst_index 0 mod_index ins_class.glob_module class_size class_members
ins_type ins_specials class_name ins_pos member_defs modules type_heaps var_heap error
instance_def = { instance_def & ins_members = { member \\ member <- ins_members }}
(ins_specials, next_class_inst_index, all_class_specials, type_heaps, predef_symbols,error)
= check_instance_specials mod_index instance_def inst_index ins_specials next_class_inst_index all_class_specials type_heaps predef_symbols error
(memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, predef_symbols,error)
= determine_types_of_instances x_main_dcl_module_n (inc inst_index) next_class_inst_index (next_mem_inst_index + class_size) mod_index all_class_specials
class_defs member_defs modules { instance_defs & [inst_index] = { instance_def & ins_specials = ins_specials }} type_heaps var_heap predef_symbols error
= (memb_inst_defs1 ++ memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, predef_symbols,error)
= ([], next_mem_inst_index, all_class_specials, class_defs, member_defs, modules, instance_defs, type_heaps, var_heap, predef_symbols,error)
determine_instance_symbols_and_types :: !Index !Index !Index !Index !Index !Int !{#DefinedSymbol} !InstanceType !Specials Ident !Position
......@@ -3459,12 +3439,10 @@ where
= foldlArraySt (count_members_of_instance mod_index) com_instance_defs (0, com_class_defs, modules)
= sum
count_members_of_instance mod_index {ins_class,ins_generated} (sum, com_class_defs, modules)
| ins_generated
= (1 + sum, com_class_defs, modules)
# ({class_members}, com_class_defs, modules)
= getClassDef ins_class mod_index com_class_defs modules
= (size class_members + sum, com_class_defs, modules)
count_members_of_instance mod_index {ins_class} (sum, com_class_defs, modules)
# ({class_members}, com_class_defs, modules)
= getClassDef ins_class mod_index com_class_defs modules
= (size class_members + sum, com_class_defs, modules)
adjustPredefSymbol predef_index mod_index symb_kind cs=:{cs_symbol_table,cs_error}
# pre_id = predefined_idents.[predef_index]
......
......@@ -819,7 +819,6 @@ where
com_cons_defs = arrayPlusList cons_defs new_cons_defs}
#! heaps = {heaps & hp_var_heap = hp_var_heap, hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}
#! modules = { modules & [module_index] = common_defs }
= (common_defs, dcl_modules, heaps, symbol_table)
......@@ -1289,14 +1288,6 @@ where
build_instance_and_member module_index class_index gencase symbol_type ins_type fun_info ins_info heaps
#! (memfun_ds, fun_info, heaps)
= build_instance_member module_index gencase symbol_type fun_info heaps
/*
#! ins_type =
{ it_vars = []
, it_types = [gencase.gc_type]
, it_attr_vars = []
, it_context = []
}
*/
#! ins_info = build_class_instance class_index gencase memfun_ds ins_type ins_info
= (fun_info, ins_info, heaps)
......@@ -1366,7 +1357,6 @@ where
, ins_members = {member_fun_ds}
, ins_specials = SP_None
, ins_pos = gc_pos
, ins_generated = True
}
= (inc ins_index, [ins:instances])
......@@ -1812,23 +1802,23 @@ instance foldType TypeContext where
// mapping of a AType, depth first
//----------------------------------------------------------------------------------------
class mapTypeSt type ::
(Type .st -> (Type, .st)) // called on each type before recursion
(AType .st -> (AType, .st)) // called on each attributed type before recursion
(Type .st -> (Type, .st)) // called on each type after recursion
(AType .st -> (AType, .st)) // called on each attributed type after recursion
type .st -> (type, .st)
(Type -> u:(.st -> u:(Type, .st))) // called on each type before recursion
(AType -> u:(.st -> u:(AType, .st))) // called on each attributed type before recursion
(Type -> u:(.st -> u:(Type, .st))) // called on each type after recursion
(AType -> u:(.st -> u:(AType, .st))) // called on each attributed type after recursion
type .st -> u:(type, .st)
mapTypeBeforeSt ::
(Type .st -> (Type, .st)) // called on each type before recursion
(AType .st -> (AType, .st)) // called on each attributed type before recursion
type .st -> (type, .st) | mapTypeSt type
(Type -> u:(.st -> u:(Type, .st))) // called on each type before recursion
(AType -> u:(.st -> u:(AType, .st))) // called on each attributed type before recursion
type .st -> u:(type, .st) | mapTypeSt type
mapTypeBeforeSt on_type_before on_atype_before type st
= mapTypeSt on_type_before on_atype_before idSt idSt type st
mapTypeAfterSt ::
(Type .st -> (Type, .st)) // called on each type after recursion
(AType .st -> (AType, .st)) // called on each attributed type after recursion
type .st -> (type, .st) | mapTypeSt type
(Type -> u:(.st -> u:(Type, .st))) // called on each type after recursion
(AType -> u:(.st -> u:(AType, .st))) // called on each attributed type after recursion
type .st -> u:(type, .st) | mapTypeSt type
mapTypeAfterSt on_type_after on_atype_after type st
= mapTypeSt idSt idSt on_type_after on_atype_after type st
......
......@@ -361,7 +361,6 @@ cNameLocationDependent :== True
, ins_members :: !{# DefinedSymbol}
, ins_specials :: !Specials
, ins_pos :: !Position
, ins_generated :: !Bool //AA
}
/*
......@@ -877,6 +876,9 @@ cNonRecursiveAppl :== False
, tc_var :: !VarInfoPtr
}
:: TCClass = TCClass !(Global DefinedSymbol)
| TCGeneric !(Global DefinedSymbol) !TypeKind
:: AType =
{ at_attribute :: !TypeAttribute
, at_type :: !Type
......@@ -1415,7 +1417,7 @@ ParsedInstanceToClassInstance pi members :==
{ ins_class = {glob_object = MakeDefinedSymbol pi.pi_class NoIndex (length pi.pi_types), glob_module = NoIndex}, ins_ident = pi.pi_ident,
ins_type = { it_vars = [], it_types = pi.pi_types, it_attr_vars = [],
it_context = pi.pi_context },
ins_members = members, ins_specials = pi.pi_specials, ins_pos = pi.pi_pos, ins_generated = False}
ins_members = members, ins_specials = pi.pi_specials, ins_pos = pi.pi_pos}
MakeTypeDef name lhs rhs attr contexts pos :==
{ td_name = name, td_index = -1, td_arity = length lhs, td_args = lhs, td_attrs = [], td_attribute = attr, td_context = contexts,
......
......@@ -373,7 +373,6 @@ addGenericKind generic_def=:{gen_name, gen_classes} kind
, ins_members :: !{# DefinedSymbol}
, ins_specials :: !Specials
, ins_pos :: !Position
, ins_generated :: !Bool // AA
}
:: Import from_symbol =
......@@ -850,6 +849,9 @@ cNotVarNumber :== -1
, tc_var :: !VarInfoPtr
}
:: TCClass = TCClass !(Global DefinedSymbol)
| TCGeneric !(Global DefinedSymbol) !TypeKind
:: AType =
{ at_attribute :: !TypeAttribute
, at_type :: !Type
......@@ -2335,7 +2337,7 @@ ParsedInstanceToClassInstance pi members :==
{ ins_class = {glob_object = MakeDefinedSymbol pi.pi_class NoIndex (length pi.pi_types), glob_module = NoIndex}, ins_ident = pi.pi_ident,
ins_type = { it_vars = [], it_types = pi.pi_types, it_attr_vars = [],
it_context = pi.pi_context },
ins_members = members, ins_specials = pi.pi_specials, ins_pos = pi.pi_pos, ins_generated = False}
ins_members = members, ins_specials = pi.pi_specials, ins_pos = pi.pi_pos}
MakeTypeDef name lhs rhs attr contexts pos :==
{ td_name = name, td_index = -1, td_arity = length lhs, td_args = lhs, td_attrs = [], td_attribute = attr, td_context = contexts,
......
......@@ -655,7 +655,6 @@ where
bind_attribute (TA_Var {av_info_ptr}) attr th_attrs
= th_attrs <:= (av_info_ptr, AVI_Attr attr)
// ---> ("typesupport 1 writePtr av_info_ptr", ptrToInt av_info_ptr, attr)
bind_attribute _ _ th_attrs
= th_attrs
......
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