diff options
| -rw-r--r-- | frontend/analtypes.icl | 31 | ||||
| -rw-r--r-- | frontend/check.icl | 62 | ||||
| -rw-r--r-- | frontend/generics1.icl | 32 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 6 | ||||
| -rw-r--r-- | frontend/syntax.icl | 6 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 1 |
6 files changed, 65 insertions, 73 deletions
diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index b24225d..5b299cf 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -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 diff --git a/frontend/check.icl b/frontend/check.icl index a222d25..28bc2a5 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -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] diff --git a/frontend/generics1.icl b/frontend/generics1.icl index 9c28918..9acad49 100644 --- a/frontend/generics1.icl +++ b/frontend/generics1.icl @@ -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 diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 5fbfe18..7f5c055 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -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, diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 4ad082f..a3d51bc 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -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, diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index b49c471..9ef6cf0 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -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 |