Commit d061d154 authored by John van Groningen's avatar John van Groningen
Browse files

add generic function dependencies for generic function definitions,

add generic case definitions in definition modules for the types used to make the generic representation,
in generic case definitions in definition modules specify what generic info and dependencies are used
parent 0b9f6610
......@@ -2033,10 +2033,18 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
(icl_gencase, icl_gencases) = icl_gencases![icl_index]
dcl_gencase = dcl_gencases.[dcl_index]
= case (dcl_gencase,icl_gencase) of
({gc_gcf=GCF _ {gcf_body = GCB_FunIndex dcl_fun}},
{gc_gcf=GCF _ {gcf_body = GCB_FunIndex icl_fun}})
#! new_table = { new_table & [dcl_fun] = icl_fun }
-> (new_table, icl_gencases, error)
({gc_gcf=GCF _ {gcf_body = GCB_FunIndex dcl_fun,gcf_generic_info=dcl_generic_info,gcf_generic_instance_deps=dcl_generic_instance_deps}},
{gc_gcf=GCF _ {gcf_body = GCB_FunIndex icl_fun,gcf_generic_info=icl_generic_info,gcf_generic_instance_deps=icl_generic_instance_deps}})
#! new_table = {new_table & [dcl_fun] = icl_fun}
# (icl_gencases, error)
= compare_icl_and_dcl_generic_info icl_generic_info dcl_generic_info icl_generic_instance_deps dcl_generic_instance_deps icl_gencase dcl_gencase icl_index icl_gencases error
-> (new_table, icl_gencases, error)
({gc_gcf=GCF _ {gcf_body = GCB_FunAndMacroIndex dcl_fun dcl_macro,gcf_generic_info=dcl_generic_info,gcf_generic_instance_deps=dcl_generic_instance_deps}},
{gc_gcf=GCF _ {gcf_body = GCB_FunIndex icl_fun,gcf_generic_info=icl_generic_info,gcf_generic_instance_deps=icl_generic_instance_deps}})
#! new_table & [dcl_fun] = icl_fun
# (icl_gencases, error)
= compare_icl_and_dcl_generic_info icl_generic_info dcl_generic_info icl_generic_instance_deps dcl_generic_instance_deps icl_gencase dcl_gencase icl_index icl_gencases error
-> (new_table, icl_gencases, error)
({gc_gcf=GCFS dcl_gcfs},{gc_gcf=GCFS icl_gcfs})
#! new_table = build_conversion_table_for_generic_superclasses dcl_gcfs icl_gcfs new_table
-> (new_table, icl_gencases, error)
......@@ -2044,6 +2052,62 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
// error already reported in checkGenericCaseDefs
-> (new_table, icl_gencases, error)
where
compare_icl_and_dcl_generic_info :: Int Int GenericInstanceDependencies GenericInstanceDependencies GenericCaseDef GenericCaseDef Int
*{#GenericCaseDef} *ErrorAdmin -> (!*{#GenericCaseDef},!*ErrorAdmin)
compare_icl_and_dcl_generic_info icl_generic_info dcl_generic_info icl_generic_instance_deps dcl_generic_instance_deps icl_gencase dcl_gencase icl_index icl_gencases error
| icl_generic_info<>dcl_generic_info
# {gc_gcf=GCF gcf_ident _,gc_type_cons,gc_pos} = icl_gencase
error_message = "different generic info for "+++type_cons_to_string gc_type_cons+++" in implementation and definition module"
error = checkErrorWithIdentPos (newPosition gcf_ident gc_pos) error_message error
= (icl_gencases, error)
= case (dcl_generic_instance_deps,icl_generic_instance_deps) of
(AllGenericInstanceDependencies,AllGenericInstanceDependencies)
-> (icl_gencases, error)
(AllGenericInstanceDependencies,_)
# (GCF gcf_ident gcf) = icl_gencase.gc_gcf
# icl_gencases & [icl_index].gc_gcf = GCF gcf_ident {gcf & gcf_generic_instance_deps=AllGenericInstanceDependencies}
-> (icl_gencases, error)
(_,AllGenericInstanceDependencies)
# {gc_gcf=GCF gcf_ident _,gc_type_cons,gc_pos} = dcl_gencase
error_message = "restricting dependent generic functions not allow for type "+++type_cons_to_string gc_type_cons
error = checkErrorWithIdentPos (newPosition gcf_ident gc_pos) error_message error
-> (icl_gencases, error)
(GenericInstanceDependencies dcl_n_deps dcl_deps,GenericInstanceUsedArgs icl_n_deps icl_deps)
| icl_n_deps==dcl_n_deps
| icl_deps==dcl_deps
# generic_instance_deps = GenericInstanceDependencies icl_n_deps icl_deps
# (GCF gcf_ident gcf) = icl_gencase.gc_gcf
# icl_gencases & [icl_index].gc_gcf = GCF gcf_ident {gcf & gcf_generic_instance_deps=generic_instance_deps}
-> (icl_gencases, error)
-> (icl_gencases, different_restriction_error icl_gencase error)
| icl_n_deps>dcl_n_deps
# icl_deps = icl_deps bitand ((1<<dcl_n_deps)-1)
| icl_deps==dcl_deps
# generic_instance_deps = GenericInstanceDependencies dcl_n_deps icl_deps
# (GCF gcf_ident gcf) = icl_gencase.gc_gcf
# icl_gencases & [icl_index].gc_gcf = GCF gcf_ident {gcf & gcf_generic_instance_deps=generic_instance_deps}
-> (icl_gencases, error)
-> (icl_gencases, different_restriction_error icl_gencase error)
-> (icl_gencases, different_restriction_error icl_gencase error)
(GenericInstanceDependencies dcl_n_deps dcl_deps,GenericInstanceDependencies icl_n_deps icl_deps)
| icl_n_deps==dcl_n_deps && icl_deps==dcl_deps
-> (icl_gencases, error)
-> (icl_gencases, different_restriction_error icl_gencase error)
(GenericInstanceUsedArgs dcl_n_deps dcl_deps, GenericInstanceUsedArgs icl_n_deps icl_deps)
| dcl_n_deps==icl_n_deps && dcl_deps==icl_deps
-> (icl_gencases, error)
-> (icl_gencases, different_restriction_error icl_gencase error)
where
type_cons_to_string (TypeConsSymb {type_ident}) = toString type_ident
type_cons_to_string (TypeConsBasic bt) = toString bt
type_cons_to_string TypeConsArrow = "(->)"
type_cons_to_string (TypeConsVar tv) = tv.tv_ident.id_name
different_restriction_error icl_gencase error
# {gc_gcf=GCF gcf_ident _,gc_type_cons,gc_pos} = icl_gencase
error_message = "different restriction of dependent generic functions for "+++type_cons_to_string gc_type_cons+++" in implementation and definition module"
= checkErrorWithIdentPos (newPosition gcf_ident gc_pos) error_message error
build_conversion_table_for_generic_superclasses [!{gcf_body=GCB_FunIndex dcl_fun}:dcl_gcfs!] [!{gcf_body=GCB_FunIndex icl_fun}:icl_gcfs!] new_table
# new_table = {new_table & [dcl_fun] = icl_fun}
= build_conversion_table_for_generic_superclasses dcl_gcfs icl_gcfs new_table
......@@ -2107,7 +2171,7 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
{gc_gcf=GCFS gcfs}
# gcfs = renumber_gcfs gcfs function_conversion_table
# gencase = {gencase & gc_gcf=GCFS gcfs}
# gencases = {gencases & [gencase_index] = gencase}
# gencases = {gencases & [gencase_index] = gencase}
-> renumber_gencase_members (gencase_index+1) gencases
= gencases
......
implementation module checkgenerics
import syntax,checksupport,checktypes,genericsupport,compare_types,typesupport
import syntax,checksupport,checktypes,genericsupport,explicitimports,compare_types,typesupport
checkGenericDefs :: !Index !(Optional (CopiedDefinitions, Int))
!*{#GenericDef} !*{#CheckedTypeDef} !*{#ClassDef} !*{#DclModule} !*Heaps !*CheckState
......@@ -35,6 +35,8 @@ where
# (gen_def, type_defs, class_defs, modules, heaps, cs)
= check_generic_type gen_def mod_index type_defs class_defs modules heaps cs
# (gen_def, gen_defs, modules, cs) = check_generic_dependencies index mod_index gen_ident gen_def gen_defs modules 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}}
......@@ -44,7 +46,11 @@ where
# initial_info =
{ gen_classes = createArray 32 []
, gen_var_kinds = []
, gen_rep_conses = createArray 4 {gcf_module = -1,gcf_index = -1,gcf_ident={id_name="",id_info=nilPtr}}
, gen_rep_conses
= createArray 7 {grc_module = -1, grc_index = GCB_None, grc_local_fun_index = -1, grc_generic_info = -1,
grc_generic_instance_deps = AllGenericInstanceDependencies,
grc_ident={id_name="",id_info=nilPtr},
grc_optional_fun_type=No}
}
# (gen_info_ptr, hp_generic_heap) = newPtr initial_info hp_generic_heap
= ( {gen_def & gen_info_ptr = gen_info_ptr},
......@@ -140,6 +146,70 @@ where
-> (th_vars, cs_error)
_ -> abort ("check_no_generic_vars_in_contexts: wrong TVI" ---> (tv, tv_info))
// TODO: TvN: check that a generic function also includes all the dependencies of its dependencies, and so on. This is required when
// deriving generic functions since then the generated function needs to have all the arguments to all the generic functions called. In a
// that process collapses all dependencies.
check_generic_dependencies index mod_index gen_ident gen_def=:{gen_vars, gen_deps} gen_defs modules cs
# (gen_deps, (gen_defs, modules, cs)) = foldSt check_dependency gen_deps ([], (gen_defs, modules, cs))
= ({gen_def & gen_deps = reverse gen_deps}, gen_defs, modules, cs)
where
check_dependency gen_dep=:{gd_ident, gd_vars} (acc, (gen_defs, modules, cs))
# (gen_dep, cs) = resolve_dependency_index gen_dep cs
| gen_dep.gd_index.gi_index < 0
= (acc, (gen_defs, modules, cs))
# (gen_dep=:{gd_index, gd_vars}, gen_defs, modules, cs) = check_dependency_vars gen_dep gen_defs modules cs
| gd_index.gi_index == index && gd_index.gi_module == mod_index && gd_vars == gen_vars
= (acc, (gen_defs, modules, check_generic_dep_error gd_ident "already implicitly depends on itself" cs))
| isMember gen_dep acc
= (acc, (gen_defs, modules, check_generic_dep_error gd_ident "duplicate generic dependency" cs))
// TODO: TvN: This check is to prevent duplicate dependencies with different generic dependency variables
// See functions: generics1.build_specialized_expr and generics1.specialize_type_var
| isMember gen_dep.gd_index [gd_index \\ {gd_index} <- acc]
= (acc, (gen_defs, modules, check_generic_dep_error gd_ident "dependency occurs multiple times with different generic dependency variables, but only one occurrence of the same generic function as a dependency is currently allowed" cs))
= ([gen_dep:acc], (gen_defs, modules, cs))
resolve_dependency_index gen_dep=:{gd_ident} cs
= case gd_ident of
Ident ident
# (index, cs) = get_generic_index ident mod_index cs
= ({gen_dep & gd_index = index}, cs)
QualifiedIdent mod_ident name
# (found, {decl_kind, decl_ident, decl_index}, cs) = search_qualified_ident mod_ident name GenericNameSpaceN cs
| not found
= (gen_dep, check_generic_dep_error gd_ident "generic dependency not defined" cs)
= case decl_kind of
STE_Imported STE_Generic generic_module
-> ({gen_dep & gd_ident = Ident decl_ident, gd_index = {gi_module = generic_module, gi_index = decl_index}}, cs)
_
-> (gen_dep, check_generic_dep_error gd_ident "not a generic function" cs)
check_dependency_vars gen_dep=:{gd_ident, gd_vars} gen_defs modules cs
# (gen_defs, modules, cs) = check_dependency_arity gen_dep gen_defs modules cs
# (gd_vars, gd_nums, cs) = mapY2St (resolve_dependency_var 0 gen_vars) gd_vars cs
= ({gen_dep & gd_vars = gd_vars, gd_nums = gd_nums}, gen_defs, modules, cs)
where
check_dependency_arity {gd_ident, gd_index, gd_vars} gen_defs modules cs
# (gen_def, gen_defs, modules) = lookup_dependency_def gd_index gen_defs modules
| not (length gd_vars == length gen_def.gen_vars)
= (gen_defs, modules, check_generic_dep_error gd_ident "incorrect dependency variable arity" cs)
= (gen_defs, modules, cs)
where
lookup_dependency_def {gi_module, gi_index} gen_defs modules
| gi_module == mod_index
# (gen_def, gen_defs) = gen_defs![gi_index]
= (gen_def, gen_defs, modules)
# (gen_def, modules) = modules![gi_module].dcl_common.com_generic_defs.[gi_index]
= (gen_def, gen_defs, modules)
resolve_dependency_var num [] var cs
= (var, -1, check_generic_dep_error gd_ident "generic dependency is indexed by an unbound generic variable" cs)
resolve_dependency_var num [gen_var:gen_vars] var cs
| var.tv_ident.id_name == gen_var.tv_ident.id_name
= (gen_var, num, cs)
= resolve_dependency_var (inc num) gen_vars var cs
check_generic_dep_error ident msg cs = {cs & cs_error = checkError ident msg cs.cs_error}
checkGenericCaseDefs :: !Index !*{#GenericCaseDef} !*{#GenericDef} !u:{#CheckedTypeDef} !*{#ClassDef} !*{#DclModule} !*Heaps !*CheckState
-> (!*{#GenericCaseDef},!*{#GenericDef},!u:{#CheckedTypeDef},!*{#ClassDef},!*{#DclModule},!.Heaps,!.CheckState)
checkGenericCaseDefs mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
......@@ -154,7 +224,7 @@ where
= (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs)
# (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs)
= check_generic_case_def index mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
= check_generic_case_defs (inc index) mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
= check_generic_case_defs (inc index) mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
check_generic_case_def index mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
# (case_def=:{gc_pos,gc_type,gc_gcf}, gen_case_defs) = gen_case_defs![index]
......@@ -220,8 +290,10 @@ where
gcf_gident = ds_ident,
gcf_generic = {gi_module=NoIndex,gi_index=NoIndex},
gcf_arity = 0,
gcf_generic_info = 0,
gcf_body = GCB_None,
gcf_kind = KindError }
gcf_kind = KindError,
gcf_generic_instance_deps = AllGenericInstanceDependencies }
# gcfs = convert_generic_contexts type_contexts
= [!gcf:gcfs!]
convert_generic_contexts [_:type_contexts]
......@@ -345,8 +417,10 @@ convert_generic_instances gci next_fun_index gencase_defs class_defs symbol_tabl
gcf_gident = ds_ident,
gcf_generic = {gi_module=NoIndex,gi_index=NoIndex},
gcf_arity = 0,
gcf_generic_info = 0,
gcf_body = GCB_FunIndex next_fun_index,
gcf_kind = KindError }
gcf_kind = KindError,
gcf_generic_instance_deps = AllGenericInstanceDependencies }
# (gcfs,next_fun_index,new_fun_defs) = convert_generic_contexts type_contexts type_cons pos (next_fun_index+1) new_fun_defs
= ([!gcf:gcfs!],next_fun_index,[fun_def:new_fun_defs])
convert_generic_contexts [_:type_contexts] type_cons pos next_fun_index new_fun_defs
......@@ -366,12 +440,19 @@ where
= (fun_index, [], gencase_defs, hp_var_heap)
# (gencase_def,gencase_defs) = gencase_defs![gc_index]
= case gencase_def of
{gc_gcf=GCF gc_ident gcf=:{gcf_body=GCB_MacroIndex macro_index},gc_pos,gc_type_cons}
# gencase_def & gc_gcf=GCF gc_ident {gcf & gcf_body = GCB_FunAndMacroIndex fun_index macro_index}
gencase_defs & [gc_index] = gencase_def
(fun,hp_var_heap) = create_gencase_function_type gc_ident gc_type_cons gc_pos hp_var_heap
(fun_index,funs,gencase_defs,hp_var_heap)
= create_funs (gc_index+1) (fun_index+1) gencase_defs hp_var_heap
-> (fun_index, [fun:funs], gencase_defs, hp_var_heap)
{gc_gcf=GCF gc_ident gcf,gc_pos,gc_type_cons}
# gencase_def & gc_gcf=GCF gc_ident {gcf & gcf_body = GCB_FunIndex fun_index}
gencase_defs & [gc_index] = gencase_def
(fun,hp_var_heap) = create_gencase_function_type gc_ident gc_type_cons gc_pos hp_var_heap
#! (fun_index, funs, gencase_defs,hp_var_heap)
= create_funs (gc_index+1) (inc fun_index) gencase_defs hp_var_heap
(fun_index,funs,gencase_defs,hp_var_heap)
= create_funs (gc_index+1) (fun_index+1) gencase_defs hp_var_heap
-> (fun_index, [fun:funs], gencase_defs, hp_var_heap)
{gc_gcf=GCFS gcfs,gc_pos,gc_type_cons}
# (gcfs,superclass_funs,fun_index,hp_var_heap)
......
......@@ -242,13 +242,18 @@ where
# (ok1, comp_st) = compare dcl_generic_def.gen_type icl_generic_def.gen_type comp_st
# (ok2, comp_st) = compare dcl_generic_def.gen_vars icl_generic_def.gen_vars comp_st
| ok1 && ok2
# (ok3, comp_st) = compare dcl_generic_def.gen_deps icl_generic_def.gen_deps comp_st
| ok1 && ok2 && ok3
= (icl_generic_defs, comp_st)
# comp_error = compareError generic_def_error (newPosition icl_generic_def.gen_ident icl_generic_def.gen_pos) comp_st.comp_error
= (icl_generic_defs, { comp_st & comp_error = comp_error })
| otherwise
= (icl_generic_defs, comp_st)
collectGenericCaseDefMacros :: !{#GenericCaseDef} -> [(GenericCaseBody,Int)]
collectGenericCaseDefMacros dcl_generic_case_defs
= [(gcf_body,gcf_generic_info) \\ {gc_gcf=GCF _ {gcf_body=gcf_body=:GCB_FunAndMacroIndex _ _,gcf_generic_info}} <-: dcl_generic_case_defs]
class compare a :: !a !a !*CompareState -> (!Bool, !*CompareState)
instance compare (a,b) | compare a & compare b
......@@ -413,6 +418,12 @@ where
= compare dcl_tc.tc_types icl_tc.tc_types comp_st
= (False, comp_st)
instance compare GenericDependency
where
compare dcl_gd icl_gd comp_st
| dcl_gd.gd_index == icl_gd.gd_index = compare dcl_gd.gd_vars icl_gd.gd_vars comp_st
= (False, comp_st)
initialyseTypeVars [{tv_info_ptr=dcl_tv_info_ptr}:dcl_type_vars] [{tv_info_ptr=icl_tv_info_ptr}:icl_type_vars] type_var_heap
# type_var_heap = type_var_heap <:= (icl_tv_info_ptr, TVI_TypeVar dcl_tv_info_ptr) <:= (dcl_tv_info_ptr, TVI_TypeVar icl_tv_info_ptr)
= initialyseTypeVars dcl_type_vars icl_type_vars type_var_heap
......@@ -451,6 +462,7 @@ initialyseAttributeVars [] [] type_var_heap
AllowFirstMoreStrictness:==1;
FirstHasMoreStrictness:==2;
CompareGenericCaseMacro:==4; // only used from ec_tc_state
:: TypesCorrespondMonad
:== *TypesCorrespondState -> *(!Bool, !*TypesCorrespondState)
......@@ -534,9 +546,9 @@ compareDefImp main_dcl_module_n main_dcl_module (Yes macro_conversion_table) {co
= compareInstanceDefs main_dcl_module.dcl_sizes dcl_common.com_instance_defs icl_com_instance_defs icl_functions comp_st
(icl_com_generic_defs, comp_st)
= compareGenericDefs
main_dcl_module.dcl_sizes copied_generic_defs
dcl_common.com_generic_defs icl_com_generic_defs comp_st
= compareGenericDefs main_dcl_module.dcl_sizes copied_generic_defs dcl_common.com_generic_defs icl_com_generic_defs comp_st
generic_case_def_macros = collectGenericCaseDefMacros dcl_common.com_gencase_defs
{ comp_type_var_heap = th_vars, comp_attr_var_heap = th_attrs, comp_error = error_admin } = comp_st
......@@ -546,7 +558,7 @@ compareDefImp main_dcl_module_n main_dcl_module (Yes macro_conversion_table) {co
, tc_strictness_flags = 0
}
(icl_functions, macro_defs, hp_var_heap, hp_expression_heap, tc_state, error_admin)
= compareMacrosWithConversion main_dcl_module_n macro_conversion_table dcl_macros icl_functions macro_defs hp_var_heap hp_expression_heap tc_state error_admin
= compareMacrosWithConversion main_dcl_module_n macro_conversion_table dcl_macros generic_case_def_macros icl_functions macro_defs hp_var_heap hp_expression_heap tc_state error_admin
(icl_functions, tc_state, error_admin)
= compareFunctionTypes n_exported_global_functions dcl_functions icl_functions tc_state error_admin
{ tc_type_vars, tc_attr_vars }
......@@ -634,7 +646,7 @@ generate_error message iclDef iclDefs tc_state error_admin
error_admin = checkError ident_pos.ip_ident message error_admin
= (iclDefs, tc_state, popErrorAdmin error_admin)
compareMacrosWithConversion main_dcl_module_n conversions macro_range icl_functions macro_defs var_heap expr_heap tc_state error_admin
compareMacrosWithConversion main_dcl_module_n conversions macro_range generic_case_def_macros icl_functions macro_defs var_heap expr_heap tc_state error_admin
#! n_icl_functions = size icl_functions
#! n_dcl_macros_and_functions = size macro_defs.[main_dcl_module_n]
# ec_state = { ec_icl_correspondences = createArray n_icl_functions cNoCorrespondence,
......@@ -647,8 +659,15 @@ compareMacrosWithConversion main_dcl_module_n conversions macro_range icl_functi
with
compareMacroWithConversion conversions ir_from dclIndex ec_state=:{ec_main_dcl_module_n}
= compareTwoMacroFuns ec_main_dcl_module_n dclIndex conversions.[dclIndex-ir_from] ec_state
{ec_icl_functions,ec_macro_defs,ec_var_heap, ec_expr_heap, ec_error_admin, ec_tc_state} = ec_state
= (ec_icl_functions,ec_macro_defs, ec_var_heap.hwn_heap, ec_expr_heap, ec_tc_state, ec_error_admin)
ec_state = compare_generic_case_def_macros generic_case_def_macros ec_state
with
compare_generic_case_def_macros [(GCB_FunAndMacroIndex fun_index macro_index,generic_info):gcbs] ec_state=:{ec_main_dcl_module_n}
# ec_state = compare_generic_case_def_macro_and_function macro_index fun_index generic_info ec_state
= compare_generic_case_def_macros gcbs ec_state
compare_generic_case_def_macros [] ec_state
= ec_state
{ec_icl_functions,ec_macro_defs,ec_var_heap,ec_expr_heap,ec_error_admin,ec_tc_state} = ec_state
= (ec_icl_functions,ec_macro_defs,ec_var_heap.hwn_heap,ec_expr_heap,ec_tc_state,ec_error_admin)
compareTwoMacroFuns :: !Int !Int !Int !*ExpressionsCorrespondState -> .ExpressionsCorrespondState;
compareTwoMacroFuns macro_module_index dclIndex iclIndex ec_state=:{ec_icl_functions,ec_macro_defs,ec_main_dcl_module_n}
......@@ -672,13 +691,44 @@ compareTwoMacroFuns macro_module_index dclIndex iclIndex ec_state=:{ec_icl_funct
# ident_pos = getIdentPos dcl_function
ec_error_admin = pushErrorAdmin ident_pos ec_state.ec_error_admin
ec_state = { ec_state & ec_error_admin = ec_error_admin }
| dcl_function.fun_info.fi_properties bitand FI_IsMacroFun <> icl_function.fun_info.fi_properties bitand FI_IsMacroFun ||
| (dcl_function.fun_info.fi_properties bitand FI_IsMacroFun <> icl_function.fun_info.fi_properties bitand FI_IsMacroFun
&& (ec_state.ec_tc_state.tc_strictness_flags bitand CompareGenericCaseMacro==0 && dcl_function.fun_info.fi_properties bitand FI_IsMacroFun<>0)) ||
dcl_function.fun_priority<>icl_function.fun_priority
# ec_state = give_error dcl_function.fun_ident ec_state
= { ec_state & ec_error_admin = popErrorAdmin ec_state.ec_error_admin }
# ec_state = e_corresponds dcl_function.fun_body icl_function.fun_body ec_state
= { ec_state & ec_error_admin = popErrorAdmin ec_state.ec_error_admin }
compare_generic_case_def_macro_and_function :: !Int !Int !Int !*ExpressionsCorrespondState -> .ExpressionsCorrespondState;
compare_generic_case_def_macro_and_function dclIndex iclIndex generic_info ec_state=:{ec_icl_functions,ec_macro_defs,ec_main_dcl_module_n}
| iclIndex==NoIndex
= ec_state
# (dcl_function, ec_macro_defs) = ec_macro_defs![ec_main_dcl_module_n,dclIndex]
(icl_function, ec_icl_functions) = ec_icl_functions![iclIndex]
ec_state & ec_icl_correspondences.[iclIndex]=dclIndex, ec_dcl_correspondences.[dclIndex]=iclIndex,
ec_icl_functions = ec_icl_functions,ec_macro_defs=ec_macro_defs
ident_pos = getIdentPos dcl_function
ec_state & ec_error_admin = pushErrorAdmin ident_pos ec_state.ec_error_admin
dcl_args_and_rhs = from_body dcl_function.fun_body
icl_args_and_rhs = from_body icl_function.fun_body
icl_args_and_rhs
= if (generic_info==0)
(remove_generic_info_arg icl_args_and_rhs)
icl_args_and_rhs
{ec_tc_state} = ec_state
ec_state & ec_tc_state = {ec_tc_state & tc_strictness_flags = ec_tc_state.tc_strictness_flags bitor CompareGenericCaseMacro}
ec_state = e_corresponds dcl_args_and_rhs icl_args_and_rhs ec_state
{ec_tc_state} = ec_state
ec_state & ec_tc_state = {ec_tc_state & tc_strictness_flags = ec_tc_state.tc_strictness_flags bitand (bitnot CompareGenericCaseMacro)}
= {ec_state & ec_error_admin = popErrorAdmin ec_state.ec_error_admin}
where
remove_generic_info_arg ([generic_info_arg:args],rhs)
= (args,rhs)
remove_generic_info_arg args_and_rhs
= args_and_rhs
instance getIdentPos (TypeDef a) where
getIdentPos {td_ident, td_pos}
= newPosition td_ident td_pos
......@@ -1313,13 +1363,16 @@ e_corresponds_app_symb {symb_ident, symb_kind=SK_Generic dcl_glob_index dcl_kind
= give_error symb_ident ec_state
= ec_state
e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_DclMacro dcl_glob_index} icl_app_symb=:{symb_kind=SK_IclMacro icl_index} ec_state
= continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_glob_index.glob_module dcl_glob_index.glob_object icl_app_symb icl_index ec_state
= continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_glob_index icl_app_symb icl_index ec_state
e_corresponds_app_symb {symb_ident,symb_kind=SK_DclMacro dcl_glob_index} {symb_kind=SK_DclMacro icl_glob_index} ec_state
| dcl_glob_index==icl_glob_index
= ec_state
= give_error symb_ident ec_state
e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_LocalDclMacroFunction dcl_glob_index} icl_app_symb=:{symb_kind=SK_LocalMacroFunction icl_index} ec_state
= continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_glob_index.glob_module dcl_glob_index.glob_object icl_app_symb icl_index ec_state
= continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_glob_index icl_app_symb icl_index ec_state
e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_LocalDclMacroFunction dcl_glob_index} icl_app_symb=:{symb_kind=SK_Function {glob_module,glob_object=icl_index}} ec_state
| glob_module==ec_state.ec_main_dcl_module_n && ec_state.ec_tc_state.tc_strictness_flags bitand CompareGenericCaseMacro<>0
= continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_glob_index icl_app_symb icl_index ec_state
e_corresponds_app_symb {symb_ident=dcl_symb_name, symb_kind=SK_Constructor dcl_glob_index} {symb_ident=icl_symb_name, symb_kind=SK_Constructor icl_glob_index} ec_state
| dcl_glob_index.glob_module==icl_glob_index.glob_module && dcl_symb_name.id_name==icl_symb_name.id_name
= ec_state
......@@ -1331,7 +1384,7 @@ e_corresponds_app_symb {symb_ident=dcl_symb_name, symb_kind=SK_NewTypeConstructo
e_corresponds_app_symb {symb_ident,symb_kind} {symb_kind=symb_kind2} ec_state
= give_error symb_ident ec_state
continuation_for_possibly_twice_defined_macros dcl_app_symb dcl_module_index dcl_index icl_app_symb icl_index ec_state
continuation_for_possibly_twice_defined_macros dcl_app_symb {glob_module=dcl_module_index, glob_object=dcl_index} icl_app_symb icl_index ec_state
| icl_index==NoIndex
= ec_state
// two different functions were referenced. In case of macro functions they still could correspond
......
......@@ -701,8 +701,12 @@ instance check_completeness FunType where
= check_completeness ft_type cci ccs
instance check_completeness GenericDef where
check_completeness {gen_type} cci ccs
= check_completeness gen_type cci ccs
check_completeness {gen_ident, gen_type, gen_deps} cci ccs
= (check_completeness gen_type cci o foldSt (flip check_completeness cci) gen_deps) ccs
instance check_completeness GenericDependency where
check_completeness {gd_ident=Ident ident, gd_index={gi_module, gi_index}} cci ccs
= check_whether_ident_is_imported ident gi_module gi_index STE_Generic cci ccs
instance check_completeness (Global x) | check_completeness x where
check_completeness { glob_object } cci ccs
......
......@@ -4,11 +4,6 @@ import scanner, parse, postparse, check, type, trans, partition, convertcases, o
convertimportedtypes, compilerSwitches, analtypes, generics1,
typereify, compare_types
// trace macro
(-*->) infixl
(-*->) value trace
:== value // ---> trace
instance == FrontEndPhase where
(==) a b
= equal_constructor a b
......@@ -23,8 +18,8 @@ frontSyntaxTree cached_dcl_macros cached_dcl_mods main_dcl_module_n predef_symbo
)
frontEndInterface :: !(Optional (*File,{#Char},{#Char})) !FrontEndOptions !Ident !SearchPaths !{#DclModule} !*{#*{#FunDef}} !(Optional Bool) !*PredefinedSymbols !*HashTable (ModTimeFunction *Files) !*Files !*File !*File !*File !(Optional *File) !*Heaps
-> ( !Optional *FrontEndSyntaxTree,!*{#*{#FunDef}},!{#DclModule},!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *File, !*Heaps)
frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_modules cached_dcl_macros list_inferred_types predef_symbols hash_table modtimefunction files error io out tcl_file heaps
-> (!Optional *FrontEndSyntaxTree,!*{#*{#FunDef}},!{#DclModule},!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *File, !*Heaps)
frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_modules cached_dcl_macros list_inferred_types predef_symbols hash_table modtimefunction files error io out tcl_file heaps
| case opt_file_dir_time of No -> True; _ -> False
# error = moduleCouldNotBeImportedError True mod_ident NoPos error
= (No,{},{},0,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps)
......@@ -121,24 +116,17 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo
type_heaps = { type_heaps & th_vars = th_vars }
# heaps = { heaps & hp_type_heaps = type_heaps, hp_expression_heap = hp_expression_heap, hp_generic_heap = gen_heap, hp_var_heap=hp_var_heap }
# (saved_main_dcl_common, ti_common_defs) = replace (dcl_common_defs dcl_mods) main_dcl_module_n icl_common
with
dcl_common_defs :: .{#DclModule} -> .{#CommonDefs} // needed for Clean 2.0 to disambiguate overloading
dcl_common_defs dcl_mods
= {dcl_common \\ {dcl_common} <-: dcl_mods }
# (saved_main_dcl_common, ti_common_defs) = replace {#dcl_common \\ {dcl_common}<-:dcl_mods} main_dcl_module_n icl_common
#! (ti_common_defs, groups, fun_defs, generic_ranges, td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin)
#! (ti_common_defs, groups, fun_defs, td_infos, heaps, hash_table, predef_symbols, dcl_mods, cached_dcl_macros, error_admin)
= case options.feo_generics of
True
-> convertGenerics main_dcl_module_n icl_used_module_numbers ti_common_defs groups fun_defs
td_infos heaps hash_table predef_symbols dcl_mods error_admin
td_infos heaps hash_table predef_symbols dcl_mods cached_dcl_macros error_admin
False
-> (ti_common_defs, groups, fun_defs, [], td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin)
-> (ti_common_defs, groups, fun_defs, td_infos, heaps, hash_table, predef_symbols, dcl_mods, cached_dcl_macros, error_admin)
# (icl_common, ti_common_defs) = replace copied_ti_common_defs main_dcl_module_n saved_main_dcl_common
with
copied_ti_common_defs :: .{#CommonDefs} // needed for Clean 2.0 to disambiguate overloading of replace
copied_ti_common_defs = {x \\ x <-: ti_common_defs}
# (icl_common, ti_common_defs) = replace {#x \\ x<-:ti_common_defs} main_dcl_module_n saved_main_dcl_common
# dcl_mods = { {dcl_mod & dcl_common = common} \\ dcl_mod <-: dcl_mods & common <-: ti_common_defs }
......@@ -153,7 +141,6 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo
# (ok,files) = fclose genout files
| not ok = abort "could not write genout"
*/
#! ok = error_admin.ea_ok
| not ok
= (No,{},{},main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps)
......@@ -163,8 +150,8 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo
| not ok
= (No,{},{},main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps)
# icl_gencase_indices = icl_function_indices.ifi_gencase_indices++generic_ranges
# icl_gencase_indices = icl_function_indices.ifi_gencase_indices
# icl_function_indices = {icl_function_indices & ifi_gencase_indices = icl_gencase_indices }
# (fun_def_size, fun_defs) = usize fun_defs
......@@ -190,7 +177,7 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo
# (stdStrictLists_module_n,predef_symbols) = get_StdStrictLists_module_n predef_symbols
# (cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap)
= analyseGroups common_defs imported_funs array_instances.ali_instances_range main_dcl_module_n stdStrictLists_module_n (components -*-> "Analyse") fun_defs var_heap expression_heap
= analyseGroups common_defs imported_funs array_instances.ali_instances_range main_dcl_module_n stdStrictLists_module_n components fun_defs var_heap expression_heap
# (def_max, acc_args) = usize acc_args
# (def_min, fun_defs) = usize fun_defs
......@@ -244,10 +231,10 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo
// (components, fun_defs, out) = showComponents components 0 False fun_defs out
# (used_funs, components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
= convertCasesOfFunctions components main_dcl_module_n imported_funs common_defs fun_defs (dcl_types -*-> "Convert cases") used_conses
= convertCasesOfFunctions components main_dcl_module_n imported_funs common_defs fun_defs dcl_types used_conses
var_heap type_heaps expression_heap
#! (dcl_types, type_heaps, var_heap)
= convertImportedTypeSpecifications main_dcl_module_n dcl_mods imported_funs common_defs used_conses used_funs (dcl_types -*-> "Convert types") type_heaps var_heap
= convertImportedTypeSpecifications main_dcl_module_n dcl_mods imported_funs common_defs used_conses used_funs dcl_types type_heaps var_heap
// # (components, fun_defs, error) = showTypes components 0 fun_defs error
// # (dcl_mods, out) = showDclModules dcl_mods out
// # (components, fun_defs, out) = showComponents components 0 False fun_defs out
......@@ -411,10 +398,9 @@ where
# (size_dcl_mods, dcl_mods) = usize dcl_mods
| mod_index == size_dcl_mods
= (dcl_mods, file)
| otherwise
# (dcl_mod, dcl_mods) = dcl_mods ! [mod_index]
# (dcl_mod, dcl_mods) = dcl_mods![mod_index]
# file = show_dcl_mod dcl_mod file
= (dcl_mods, file)
= show_dcl_mods (mod_index+1) dcl_mods file
show_dcl_mod {dcl_name, dcl_functions} file
# file = file <<< dcl_name <<< ":\n"
......
......@@ -14,15 +14,16 @@ convertGenerics ::
!*HashTable
!*PredefinedSymbols
!u:{# DclModule}
!*ErrorAdmin
!*{#*{#FunDef}}
!*ErrorAdmin
-> ( !{#CommonDefs}
, !{!Group}
, !*{# FunDef}
, ![IndexRange]
, !*TypeDefInfos
, !*Heaps
, !*HashTable