Skip to content
GitLab
Commit 2389ad52 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

Bug fix: caching combined with omitted type and class definitions

parent a8d7972b
Hide whitespace changes
Inline Side-by-side
frontend/analtypes.dcl
View file @ 2389ad52
......@@ -2,5 +2,9 @@ definition module analtypes
import checksupport, typesupport
analTypeDefs :: !{#CommonDefs} !NumberSet !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin)
partionateAndExpandTypes :: !NumberSet !Index !*CommonDefs !*{#DclModule} !*TypeHeaps !*ErrorAdmin
-> (!TypeGroups, !*{# CommonDefs}, !*TypeDefInfos, !*CommonDefs, !*{#DclModule}, !*TypeHeaps, !*ErrorAdmin)
:: TypeGroups :== [[GlobalIndex]]
analyseTypeDefs :: !{#CommonDefs} !TypeGroups !*TypeDefInfos !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin)
frontend/analtypes.icl
View file @ 2389ad52
......@@ -3,6 +3,217 @@ implementation module analtypes
import StdEnv
import syntax, checksupport, checktypes, check, typesupport, utilities, analunitypes //, RWSDebug
/*
:: TypeGroup =
{ tg_number :: !Int
, tg_members :: ![GlobalIndex]
}
*/
:: TypeGroups :== [[GlobalIndex]]
:: PartitioningInfo =
{ pi_marks :: !.{# .{# Int}}
, pi_type_defs :: !.{# .{# CheckedTypeDef}}
, pi_type_def_infos :: !.TypeDefInfos
, pi_next_num :: !Int
, pi_next_group_num :: !Int
, pi_groups :: !TypeGroups
, pi_deps :: ![GlobalIndex]
, pi_error :: !.ErrorAdmin
}
cNotPartitionated :== -1
cChecking :== -1
partionateAndExpandTypes :: !NumberSet !Index !*CommonDefs !*{#DclModule} !*TypeHeaps !*ErrorAdmin
-> (!TypeGroups, !*{# CommonDefs}, !*TypeDefInfos, !*CommonDefs, !*{#DclModule}, !*TypeHeaps, !*ErrorAdmin)
partionateAndExpandTypes used_module_numbers main_dcl_module_index icl_common=:{com_type_defs,com_class_defs} dcl_modules type_heaps error
#! nr_of_modules = size dcl_modules
#! nr_of_types_in_icl_mod = size com_type_defs - size com_class_defs
# (dcl_type_defs, dcl_modules, new_type_defs, new_marks, type_def_infos)
= copy_type_defs_and_create_marks_and_infos used_module_numbers main_dcl_module_index nr_of_types_in_icl_mod nr_of_modules (com_type_defs, dcl_modules)
pi = {pi_marks = new_marks, pi_type_defs = new_type_defs, pi_type_def_infos = type_def_infos,
pi_next_num = 0, pi_deps = [], pi_next_group_num = 0, pi_groups = [], pi_error = error }
{pi_error,pi_groups,pi_type_defs,pi_type_def_infos} = iFoldSt partionate_type_defs 0 nr_of_modules pi
| not pi_error.ea_ok
# (icl_type_defs, type_defs) = replace pi_type_defs main_dcl_module_index dcl_type_defs
(dcl_modules, common_defs) = update_modules_and_create_commondefs used_module_numbers type_defs nr_of_modules dcl_modules
= (reverse pi_groups, common_defs, pi_type_def_infos, {icl_common & com_type_defs = icl_type_defs }, dcl_modules, type_heaps, pi_error)
# (type_defs, dcl_type_defs, type_heaps, error)
= foldSt (expand_synonym_types_of_group main_dcl_module_index) pi_groups (pi_type_defs, dcl_type_defs, type_heaps, pi_error)
(icl_type_defs, type_defs) = replace type_defs main_dcl_module_index dcl_type_defs
(dcl_modules, common_defs) = update_modules_and_create_commondefs used_module_numbers type_defs nr_of_modules dcl_modules
= (reverse pi_groups, common_defs, pi_type_def_infos, {icl_common & com_type_defs = icl_type_defs}, dcl_modules, type_heaps, error)
where
copy_type_defs_and_create_marks_and_infos used_module_numbers main_dcl_module_index nr_of_types_in_icl_mod nr_of_modules (icl_type_defs, dcl_modules)
# type_defs = { {} \\ nr_of_types <- [0..nr_of_modules] }
marks = { {} \\ nr_of_types <- [0..nr_of_modules] }
type_def_infos = { {} \\ nr_of_types <- [0..nr_of_modules] }
= iFoldSt (copy_type_def_and_create_marks_and_infos used_module_numbers main_dcl_module_index nr_of_types_in_icl_mod) 0 nr_of_modules
(icl_type_defs, dcl_modules, type_defs, marks, type_def_infos)
where
copy_type_def_and_create_marks_and_infos used_module_numbers main_dcl_module_index nr_of_types_in_icl_mod module_index
(icl_type_defs, dcl_modules, type_defs, marks, type_def_infos)
| inNumberSet module_index used_module_numbers
# ({com_type_defs,com_class_defs}, dcl_modules) = dcl_modules![module_index].dcl_common
| module_index == main_dcl_module_index
= ( { type_def \\ type_def <-: com_type_defs }, dcl_modules, { type_defs & [module_index] = icl_type_defs },
{ marks & [module_index] = createArray nr_of_types_in_icl_mod cNotPartitionated },
{ type_def_infos & [module_index] = createArray nr_of_types_in_icl_mod EmptyTypeDefInfo })
# nr_of_types = size com_type_defs - size com_class_defs
= ( icl_type_defs, dcl_modules, { type_defs & [module_index] = { type_def \\ type_def <-: com_type_defs }},
{ marks & [module_index] = createArray nr_of_types cNotPartitionated },
{ type_def_infos & [module_index] = createArray nr_of_types EmptyTypeDefInfo })
= (icl_type_defs, dcl_modules, type_defs, marks,type_def_infos)
partionate_type_defs mod_index pi=:{pi_marks}
#! nr_of_typedefs_to_be_examined = size pi_marks.[mod_index]
= iFoldSt (partitionate_type_def mod_index) 0 nr_of_typedefs_to_be_examined pi
where
partitionate_type_def module_index type_index pi=:{pi_marks}
# mark = pi_marks.[module_index, type_index]
| mark == cNotPartitionated
# (_, pi) = partitionateTypeDef {gi_module = module_index, gi_index = type_index} pi
= pi
= pi
expand_synonym_types_of_group main_dcl_module_index group_members (type_defs, main_dcl_type_defs, type_heaps, error)
= foldSt (expand_synonym_type main_dcl_module_index) group_members (type_defs, main_dcl_type_defs, type_heaps, error)
where
expand_synonym_type main_dcl_module_index gi=:{gi_module,gi_index} (type_defs, main_dcl_type_defs, type_heaps, error)
# (td=:{td_rhs,td_attribute}, type_defs) = type_defs![gi_module, gi_index]
= case td_rhs of
SynType type
# (opt_type, type_defs, type_heaps, error)
= try_to_expand_synonym_type (newPosition td.td_name td.td_pos) type td_attribute (type_defs, type_heaps, error)
-> case opt_type of
Yes type
# type_defs = { type_defs & [gi_module, gi_index] = { td & td_rhs = SynType type}}
-> try_to_expand_synonym_type_in_main_dcl main_dcl_module_index gi (type_defs, main_dcl_type_defs, type_heaps, error)
No
-> (type_defs, main_dcl_type_defs, type_heaps, error)
_
-> (type_defs, main_dcl_type_defs, type_heaps, error)
try_to_expand_synonym_type pos type=:{at_type = TA {type_name,type_index={glob_object,glob_module}} types} attribute (type_defs, type_heaps, error)
# (used_td=:{td_rhs}, type_defs) = type_defs![glob_module, glob_object]
= case td_rhs of
SynType {at_type}
# (ok, subst_rhs, type_heaps) = substituteType used_td.td_attribute attribute used_td.td_args types at_type type_heaps
| ok
-> (Yes {type & at_type = subst_rhs }, type_defs, type_heaps, error)
# error = popErrorAdmin (typeSynonymError used_td.td_name "kind conflict in argument of type synonym" (pushErrorAdmin pos error))
-> (No, type_defs, type_heaps, error)
_
-> (No, type_defs, type_heaps, error)
try_to_expand_synonym_type pos type attribute (type_defs, type_heaps, error)
= (No, type_defs, type_heaps, error)
try_to_expand_synonym_type_in_main_dcl main_dcl_module_index {gi_module,gi_index} (type_defs, main_dcl_type_defs, type_heaps, error)
| main_dcl_module_index == main_dcl_module_index && gi_index < size main_dcl_type_defs
# (td=:{td_rhs,td_attribute,td_name,td_pos}, main_dcl_type_defs) = main_dcl_type_defs![gi_index]
= case td_rhs of
SynType type
# (opt_type, type_defs, type_heaps, error)
= try_to_expand_synonym_type (newPosition td_name td_pos) type td_attribute (type_defs, type_heaps, error)
-> case opt_type of
Yes type
-> (type_defs, { main_dcl_type_defs & [gi_index] = { td & td_rhs = SynType type}}, type_heaps, error)
No
-> (type_defs, main_dcl_type_defs, type_heaps, error)
_
-> (type_defs, main_dcl_type_defs, type_heaps, error)
= (type_defs, main_dcl_type_defs, type_heaps, error)
update_modules_and_create_commondefs used_module_numbers type_defs nr_of_modules dcl_modules
# (arbitrary_value_for_initializing, dcl_modules) = dcl_modules![0].dcl_common
initial_common_defs = createArray nr_of_modules arbitrary_value_for_initializing
= iFoldSt (copy_commondefs_and_adjust_type_defs used_module_numbers type_defs) 0 nr_of_modules (dcl_modules, initial_common_defs)
where
copy_commondefs_and_adjust_type_defs used_module_numbers type_defs module_index (dcl_modules, common_defs)
| inNumberSet module_index used_module_numbers
# (dcl_module=:{dcl_common}, dcl_modules) = dcl_modules![module_index]
dcl_common = { dcl_common & com_type_defs = type_defs.[module_index]}
= ({ dcl_modules & [module_index] = { dcl_module & dcl_common = dcl_common }}, { common_defs & [module_index] = dcl_common })
= (dcl_modules, common_defs)
// # (dcl_common, dcl_modules) = dcl_modules![module_index].dcl_common
// = (dcl_modules, { common_defs & [module_index] = dcl_common })
// ---> ("update_modules_and_create_commondefs", module_index)
partitionateTypeDef gi=:{gi_module,gi_index} pi=:{pi_type_defs}
# ({td_name,td_pos,td_used_types}, pi) = pi!pi_type_defs.[gi_module].[gi_index]
pi = push_on_dep_stack gi pi
(min_dep, pi) = foldSt visit_type td_used_types (cMAXINT, pi)
= try_to_close_group gi min_dep pi
where
visit_type gi=:{gi_module,gi_index} (min_dep, pi=:{pi_marks})
#! mark = pi_marks.[gi_module].[gi_index]
| mark == cNotPartitionated
# (ldep, pi) = partitionateTypeDef gi pi
= (min min_dep ldep, pi)
= (min min_dep mark, pi)
push_on_dep_stack type_index=:{gi_module,gi_index} pi=:{pi_deps,pi_marks,pi_next_num}
= { pi & pi_deps = [type_index : pi_deps], pi_marks = { pi_marks & [gi_module].[gi_index] = pi_next_num }, pi_next_num = inc pi_next_num }
try_to_close_group this_type=:{gi_module,gi_index} ldep pi=:{pi_deps,pi_marks,pi_next_group_num,pi_groups,pi_type_defs,pi_error,pi_type_def_infos}
#! my_mark = pi_marks.[gi_module].[gi_index]
| (ldep == cMAXINT || ldep == my_mark)
# (pi_deps, group_members) = close_group this_type pi_deps []
(reorganised_group_members, pi_marks, pi_type_defs, pi_error) = check_cyclic_type_defs group_members [] pi_marks pi_type_defs pi_error
pi_type_def_infos = update_type_def_infos pi_next_group_num reorganised_group_members group_members pi_type_def_infos
= (cMAXINT, { pi & pi_marks = pi_marks, pi_deps = pi_deps, pi_next_group_num = inc pi_next_group_num, pi_error = pi_error,
pi_type_defs = pi_type_defs, pi_type_def_infos = pi_type_def_infos,
pi_groups = [reorganised_group_members : pi_groups ]})
// ---> ("try_to_close_group", reorganised_group_members, group_members)
= (min my_mark ldep, pi)
where
close_group first_type [td : tds] group
| first_type == td
= (tds, [td : group])
= close_group first_type tds [td : group]
check_cyclic_type_defs tds group marks type_defs error
= foldSt check_cyclic_type_def tds (group, marks, type_defs, error)
where
check_cyclic_type_def td=:{gi_module,gi_index} (group, marks, typedefs, error)
# (mark, marks) = marks![gi_module,gi_index]
# ({td_name,td_pos,td_used_types,td_rhs}, typedefs) = typedefs![gi_module].[gi_index]
| mark == cChecking
= (group, marks, typedefs, typeSynonymError td_name "cyclic dependency between type synonyms" error)
| mark < cMAXINT
| is_synonym_type td_rhs
# marks = { marks & [gi_module,gi_index] = cChecking }
error = pushErrorAdmin (newPosition td_name td_pos) error
(group, marks, typedefs, error) = check_cyclic_type_defs td_used_types [td : group] marks typedefs error
error = popErrorAdmin error
= (group, { marks & [gi_module,gi_index] = cMAXINT }, typedefs, error)
= ([td : group], { marks & [gi_module,gi_index] = cMAXINT }, typedefs, error)
= (group, marks, typedefs, error)
is_synonym_type (SynType _) = True
is_synonym_type td_rhs = False
update_type_def_infos group_nr group_members tds type_def_infos
# (_, type_def_infos) = foldSt (update_type_def_info group_nr group_members) tds (0, type_def_infos)
= type_def_infos
where
update_type_def_info group_nr group_members {gi_module,gi_index} (index_in_group, type_def_infos)
# (info, type_def_infos) = type_def_infos![gi_module,gi_index]
= (inc index_in_group,
{ type_def_infos & [gi_module,gi_index] = { info & tdi_group_nr = group_nr, tdi_index_in_group = index_in_group, tdi_group = group_members}})
typeSynonymError type_symb msg error
= checkError type_symb msg error
:: UnifyKindsInfo =
{ uki_kind_heap ::!.KindHeap
, uki_error ::!.ErrorAdmin
......@@ -71,40 +282,6 @@ where
unify_kinds kind1 kind2 uni_info=:{uki_error}
= { uni_info & uki_error = kindError kind1 kind2 uki_error }
/*
unifyKinds :: !KindInfo !KindInfo !*UnifyKindsInfo -> *UnifyKindsInfo
unifyKinds (KI_Indirection kind1) kind2 uni_info=:{uki_kind_heap}
= unifyKinds kind1 kind2 uni_info
unifyKinds kind1 (KI_Indirection kind2) uni_info=:{uki_kind_heap}
= unifyKinds kind1 kind2 uni_info
unifyKinds (KI_Var info_ptr1) kind=:(KI_Var info_ptr2) uni_info=:{uki_kind_heap}
| info_ptr1 == info_ptr2
= uni_info
= { uni_info & uki_kind_heap = writePtr info_ptr1 (KI_Indirection kind) uki_kind_heap }
unifyKinds k1=:(KI_Var info_ptr1) kind uni_info=:{uki_kind_heap,uki_error}
| contains_kind_ptr info_ptr1 uki_kind_heap kind
= { uni_info & uki_error = kindError k1 kind uki_error }
= { uni_info & uki_kind_heap = writePtr info_ptr1 (KI_Indirection kind) uki_kind_heap }
where
contains_kind_ptr info_ptr uki_kind_heap (KI_Arrow kinds)
= any (contains_kind_ptr info_ptr uki_kind_heap) kinds
contains_kind_ptr info_ptr uki_kind_heap (KI_Indirection kind_info)
= contains_kind_ptr info_ptr uki_kind_heap kind_info
contains_kind_ptr info_ptr uki_kind_heap (KI_Var kind_info_ptr)
= info_ptr1 == kind_info_ptr
contains_kind_ptr info_ptr uki_kind_heap (KI_Const)
= False
unifyKinds kind k1=:(KI_Var info_ptr1) uni_info
= unifyKinds k1 kind uni_info
unifyKinds kind1=:(KI_Arrow kinds1) kind2=:(KI_Arrow kinds2) uni_info=:{uki_error}
| length kinds1 == length kinds2
= foldr2 unifyKinds uni_info kinds1 kinds2
= { uni_info & uki_error = kindError kind1 kind2 uki_error }
unifyKinds KI_Const KI_Const uni_info
= uni_info
unifyKinds kind1 kind2 uni_info=:{uki_error}
= { uni_info & uki_error = kindError kind1 kind2 uki_error }
*/
class toKindInfo a :: !a -> KindInfo
......@@ -128,18 +305,11 @@ where
{ con_top_var_binds :: ![KindInfoPtr]
, con_var_binds :: ![VarBind]
}
:: AnalState =
{ as_td_infos :: !.TypeDefInfos
, as_heaps :: !.TypeHeaps
, as_kind_heap :: !.KindHeap
, as_check_marks :: !.{# .{# Int}}
, as_next_num :: !Int
, as_deps :: ![Global Index]
// , as_groups :: ![[Global Index]]
, as_next_group_num :: !Int
, as_error :: !.ErrorAdmin
}
......@@ -156,7 +326,7 @@ combineCoercionProperties prop1 prop2 :== (prop1 bitor prop2) bitand cIsNonCoerc
combineHyperstrictness prop1 prop2 :== (prop1 bitand prop2) bitand cIsHyperStrict
class analTypes type :: !Bool !{#CommonDefs} ![KindInfoPtr] !type !(!Conditions, !*AnalState)
-> (!Int, !KindInfo, TypeProperties, !(!Conditions, !*AnalState))
-> (!KindInfo, !TypeProperties, !(!Conditions, !*AnalState))
cDummyBool :== False
......@@ -175,46 +345,37 @@ where
(kind_info, as_kind_heap) = readPtr kind_info_ptr as_kind_heap
(kind_info, as_kind_heap) = skipIndirections kind_info as_kind_heap
| isEmpty form_tvs
= (cMAXINT, kind_info, cIsHyperStrict, (conds, { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap }))
= (cMAXINT, kind_info, cIsHyperStrict, ({ conds & con_var_binds = [{vb_var = kind_info_ptr, vb_vars = form_tvs } : con_var_binds] },
= (kind_info, cIsHyperStrict, (conds, { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap }))
= (kind_info, cIsHyperStrict, ({ conds & con_var_binds = [{vb_var = kind_info_ptr, vb_vars = form_tvs } : con_var_binds] },
{ as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap }))
instance analTypes Type
where
analTypes has_root_attr modules form_tvs (TV tv) conds_as
= analTypes has_root_attr modules form_tvs tv conds_as
analTypes has_root_attr modules form_tvs type=:(TA {type_index={glob_module,glob_object},type_arity} types) conds_as
# (ldep, (conds, as)) = anal_type_def modules glob_module glob_object conds_as
{td_arity} = modules.[glob_module].com_type_defs.[glob_object]
analTypes has_root_attr modules form_tvs type=:(TA {type_name,type_index={glob_module,glob_object},type_arity} types) (conds, as)
# form_type_arity = modules.[glob_module].com_type_defs.[glob_object].td_arity
({tdi_kinds, tdi_properties}, as) = as!as_td_infos.[glob_module].[glob_object]
kind = if (td_arity == type_arity) KI_Const (KI_Arrow [ toKindInfo tk \\ tk <- drop type_arity tdi_kinds ])
| ldep < cMAXINT /* hence we have a recursive type application */ // ---> ("analTypes", toString kind)
# (ldep2, type_props, conds_as)
= anal_types_of_rec_type_cons modules form_tvs types tdi_kinds (conds, as)
= (min ldep ldep2, kind, type_props, conds_as)
# (ldep2, type_props, conds_as)
= anal_types_of_type_cons modules form_tvs types tdi_kinds (conds, as)
// ---> (types, tdi_kinds)
= (min ldep ldep2, kind, condCombineTypeProperties has_root_attr type_props tdi_properties, conds_as)
kind = if (form_type_arity == type_arity) KI_Const (KI_Arrow [ toKindInfo tk \\ tk <- drop type_arity tdi_kinds ])
| tdi_properties bitand cIsAnalysed == 0
# (type_properties, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tdi_kinds (conds, as)
= (kind, type_properties, conds_as)
# (type_properties, conds_as) = anal_types_of_type_cons modules form_tvs types tdi_kinds (conds, as)
= (kind, type_properties, conds_as)
where
anal_types_of_rec_type_cons modules form_tvs [] _ conds_as
= (cMAXINT, cIsHyperStrict, conds_as)
= (cIsHyperStrict, conds_as)
anal_types_of_rec_type_cons modules form_tvs [type : types] [(KindVar kind_info_ptr) : tvs] conds_as
# (ldep, type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules [ kind_info_ptr : form_tvs ] type conds_as
# (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules [ kind_info_ptr : form_tvs ] type conds_as
(kind, as_kind_heap) = readPtr kind_info_ptr as_kind_heap
{uki_kind_heap, uki_error} = unifyKinds type_kind kind {uki_kind_heap = as_kind_heap, uki_error = as_error}
| is_type_var type
# (min_dep, other_type_props, conds_as) =
anal_types_of_rec_type_cons modules form_tvs types tvs (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (min ldep min_dep, combineTypeProperties type_props other_type_props, conds_as)
# (min_dep, other_type_props, conds_as) =
anal_types_of_rec_type_cons modules form_tvs types tvs
({ conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds]}, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
# (min_dep, other_type_props, conds_as) =
anal_types_of_rec_type_cons modules form_tvs types tvs
({ conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds]}, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (min ldep min_dep, combineTypeProperties type_props other_type_props, conds_as)
# (other_type_props, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tvs
(conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (combineTypeProperties type_props other_type_props, conds_as)
# (other_type_props, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tvs
({ conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds]}, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (combineTypeProperties type_props other_type_props, conds_as)
where
is_type_var {at_type = TV _}
= True
......@@ -222,46 +383,39 @@ where
= False
anal_types_of_type_cons modules form_tvs [] _ conds_as
= (cMAXINT, cIsHyperStrict, conds_as)
= (cIsHyperStrict, conds_as)
anal_types_of_type_cons modules form_tvs [type : types] [tk : tks] conds_as
# (ldep, type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as
# (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as
{uki_kind_heap, uki_error} = unifyKinds type_kind (toKindInfo tk) {uki_kind_heap = as_kind_heap, uki_error = as_error}
(min_dep, other_type_props, conds_as)
= anal_types_of_type_cons modules form_tvs types tks (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (min ldep min_dep, combineTypeProperties type_props other_type_props, conds_as)
as = { as & as_kind_heap = uki_kind_heap, as_error = uki_error }
(other_type_props, conds_as) = anal_types_of_type_cons modules form_tvs types tks (conds, as)
= (combineTypeProperties type_props other_type_props, conds_as)
anal_types_of_type_cons modules form_tvs types tks conds_as
= abort ("anal_types_of_type_cons (analtypes.icl)" ---> (types, tks))
anal_type_def modules module_index type_index (conds, as=:{as_check_marks})
#! mark = as_check_marks.[module_index].[type_index]
| mark == AS_NotChecked
# (mark, ({con_var_binds,con_top_var_binds}, as)) = analTypeDef modules module_index type_index as
= (mark, ({con_top_var_binds = con_top_var_binds ++ conds.con_top_var_binds, con_var_binds = con_var_binds ++ conds.con_var_binds}, as))
= (mark, (conds, as))
analTypes has_root_attr modules form_tvs (arg_type --> res_type) conds_as
# (arg_ldep, arg_kind, arg_type_props, conds_as) = analTypes has_root_attr modules form_tvs arg_type conds_as
(res_ldep, res_kind, res_type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs res_type conds_as
# (arg_kind, arg_type_props, conds_as) = analTypes has_root_attr modules form_tvs arg_type conds_as
(res_kind, res_type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs res_type conds_as
{uki_kind_heap, uki_error} = unifyKinds res_kind KI_Const (unifyKinds arg_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error})
type_props = if has_root_attr
(combineCoercionProperties arg_type_props res_type_props bitor cIsNonCoercible)
(combineCoercionProperties arg_type_props res_type_props)
= (min arg_ldep res_ldep, KI_Const, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error }))
= (KI_Const, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error }))
analTypes has_root_attr modules form_tvs (CV tv :@: types) conds_as
# (ldep1, type_kind, cv_props, conds_as) = analTypes has_root_attr modules form_tvs tv conds_as
(ldep2, type_kinds, is_non_coercible, (conds, as=:{as_kind_heap,as_error})) = check_type_list modules form_tvs types conds_as
# (type_kind, cv_props, conds_as) = analTypes has_root_attr modules form_tvs tv conds_as
(type_kinds, is_non_coercible, (conds, as=:{as_kind_heap,as_error})) = check_type_list modules form_tvs types conds_as
{uki_kind_heap, uki_error} = unifyKinds type_kind (KI_Arrow type_kinds) {uki_kind_heap = as_kind_heap, uki_error = as_error}
type_props = if (is_non_coercible || has_root_attr) cIsNonCoercible (cv_props bitand cIsNonCoercible)
= (min ldep1 ldep2, KI_Const, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error }))
= (KI_Const, type_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error }))
where
check_type_list modules form_tvs [] conds_as
= (cMAXINT, [], False, conds_as)
= ([], False, conds_as)
check_type_list modules form_tvs [type : types] conds_as
# (ldep1, tk, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as
# (tk, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as
{uki_kind_heap, uki_error} = unifyKinds tk KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error}
(ldep2, tks, is_non_coercible, conds_as) = check_type_list modules form_tvs types (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (min ldep1 ldep2, [tk : tks], is_non_coercible || (type_props bitand cIsNonCoercible <> 0), conds_as)
(tks, is_non_coercible, conds_as) = check_type_list modules form_tvs types (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= ([tk : tks], is_non_coercible || (type_props bitand cIsNonCoercible <> 0), conds_as)
analTypes has_root_attr modules form_tvs (TFA vars type) (conds, as=:{as_heaps,as_kind_heap})
# (th_vars, as_kind_heap) = new_local_kind_variables vars (as_heaps.th_vars, as_kind_heap)
= analTypes has_root_attr modules form_tvs type (conds, { as & as_heaps = { as_heaps & th_vars = th_vars}, as_kind_heap = as_kind_heap})
......@@ -275,25 +429,17 @@ where
# (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap
= ( type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr))
analTypes has_root_attr modules form_tvs type conds_as
= (cMAXINT, KI_Const, cIsHyperStrict, conds_as)
/*
analTypesOfConstructor :: !Index !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymbol] !Bool !Index !Level !TypeAttribute !Conditions !*TypeSymbols !*TypeInfo !*CheckState
-> *(!TypeProperties, !Conditions, !Int, !*TypeSymbols, !*TypeInfo, !*CheckState)
*/
= (KI_Const, cIsHyperStrict, conds_as)
analTypesOfConstructor modules cons_defs [{ds_index}:conses] (conds, as=:{as_heaps,as_kind_heap})
# {cons_exi_vars,cons_type} = cons_defs.[ds_index]
# {cons_exi_vars,cons_type} = cons_defs.[ds_index ]
(coercible, th_vars, as_kind_heap) = new_local_kind_variables cons_exi_vars (as_heaps.th_vars, as_kind_heap)
(cons_ldep, cons_properties, conds_as) = anal_types_of_cons modules cons_type.st_args
(cons_properties, conds_as) = anal_types_of_cons modules cons_type.st_args
(conds, { as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap })
(conses_ldep, other_properties, conds_as) = analTypesOfConstructor modules cons_defs conses conds_as
(other_properties, conds_as) = analTypesOfConstructor modules cons_defs conses conds_as
properties = combineTypeProperties cons_properties other_properties
= (min cons_ldep conses_ldep, if coercible properties (properties bitor cIsNonCoercible), conds_as)
= (if coercible properties (properties bitor cIsNonCoercible), conds_as)
where
/*
check_types_of_cons :: ![AType] !Bool !Index !Level ![TypeVar] !TypeAttribute ![AttrInequality] !Conditions !*TypeSymbols !*TypeInfo !*CheckState
-> *(![AType], ![[ATypeVar]], ![AttrInequality], !TypeProperties, !Conditions, !Int, !*TypeSymbols, !*TypeInfo, !*CheckState)
*/
new_local_kind_variables :: [ATypeVar] !(!*TypeVarHeap,!*KindHeap) -> (!Bool,!*TypeVarHeap,!*KindHeap)
new_local_kind_variables td_args (type_var_heap, as_kind_heap)
= foldSt new_kind td_args (True, type_var_heap, as_kind_heap)
......@@ -308,15 +454,15 @@ where
is_not_a_variable attr = True
anal_types_of_cons modules [] conds_as
= (cMAXINT, cIsHyperStrict, conds_as)
= (cIsHyperStrict, conds_as)
anal_types_of_cons modules [type : types] conds_as
# (ldep1, other_type_props, conds_as) = anal_types_of_cons modules types conds_as
(ldep2, type_kind, cv_props, (conds, as=:{as_kind_heap, as_error})) = analTypes cDummyBool modules [] type conds_as
# (other_type_props, conds_as) = anal_types_of_cons modules types conds_as
(type_kind, cv_props, (conds, as=:{as_kind_heap, as_error})) = analTypes cDummyBool modules [] type conds_as
{uki_kind_heap, uki_error} = unifyKinds type_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error}
cons_props = if (type_is_strict type.at_annotation)
(combineTypeProperties cv_props other_type_props)
(combineCoercionProperties cv_props other_type_props)
= (min ldep1 ldep2, cons_props, (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error }))
= (cons_props, (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error }))
where
type_is_strict AN_Strict
......@@ -325,21 +471,7 @@ where
= False
analTypesOfConstructor _ _ [] conds_as
= (cMAXINT, cIsHyperStrict, conds_as)
/*
analRhsOfTypeDef :: !CheckedTypeDef ![AttributeVar] !Bool !Index !Level !TypeAttribute !Index !Conditions !*TypeSymbols !*TypeInfo !*CheckState
-> (!TypeRhs, !TypeProperties, !Conditions, !Int, !*TypeSymbols, !*TypeInfo, !*CheckState)
*/
analRhsOfTypeDef modules com_cons_defs (AlgType conses) conds_as
= analTypesOfConstructor modules com_cons_defs conses conds_as
analRhsOfTypeDef modules com_cons_defs (RecordType {rt_constructor}) conds_as
= analTypesOfConstructor modules com_cons_defs [rt_constructor] conds_as
analRhsOfTypeDef modules _ (SynType type) conds_as
# (ldep, type_kind, cv_props, (conds, as=:{as_kind_heap, as_error})) = analTypes cDummyBool modules [] type conds_as
{uki_kind_heap, uki_error} = unifyKinds type_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error}
= (ldep, cv_props, (conds, { as & as_kind_heap = as_kind_heap, as_error = as_error }))
= (cIsHyperStrict, conds_as)
emptyIdent name :== { id_name = name, id_info = nilPtr }
......@@ -352,71 +484,62 @@ where
= (KindVar kind_info_ptr, (type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr)))
/*
checkTypeDef :: !Bool !Index !Index !Level !*TypeSymbols !*TypeInfo !*CheckState -> (!Int, !Conditions, !*TypeSymbols, !*TypeInfo, !*CheckState);
checkTypeDef is_main_dcl type_index module_index level ts=:{ts_type_defs} ti=:{ti_kind_heap,ti_heaps} cs=:{cs_error}
*/
analTypeDef modules type_module type_index as=:{as_error,as_heaps,as_kind_heap,as_td_infos}
# {com_type_defs,com_cons_defs} = modules.[type_module]
{td_name,td_pos,td_args,td_rhs} = com_type_defs.[type_index]
(is_abs_type, abs_type_properties) = is_abstract_type td_rhs
| is_abs_type
# (tdi, as_td_infos) = as_td_infos![type_module].[type_index]
tdi = { tdi & tdi_kinds = [ KindConst \\ _ <- td_args ], tdi_group = [{glob_module = type_module, glob_object = type_index}],
tdi_group_vars = [ i \\ _ <- td_args & i <- [0..]], tdi_properties = abs_type_properties,
tdi_tmp_index = 0 }
= (cMAXINT, ({con_top_var_binds = [], con_var_binds = [] }, { as & as_td_infos = { as_td_infos & [type_module].[type_index] = tdi}}))
# position = newPosition td_name td_pos
as_error = pushErrorAdmin position as_error
(tdi_kinds, (th_vars, as_kind_heap)) = newKindVariables td_args (as_heaps.th_vars, as_kind_heap)
(ldep, type_properties, (conds, as)) = analRhsOfTypeDef modules com_cons_defs td_rhs ({ con_top_var_binds = [], con_var_binds = [] },
push_on_dep_stack type_module type_index
{ as & as_heaps = { as_heaps & th_vars = th_vars }, as_kind_heap = as_kind_heap, as_error = as_error,
as_td_infos = { as_td_infos & [type_module].[type_index].tdi_kinds = tdi_kinds }})
// ---> (td_name, td_args, tdi_kinds)
= try_to_close_group modules type_module type_index ldep (conds,
{ as & as_error = popErrorAdmin as.as_error, as_td_infos = { as.as_td_infos & [type_module].[type_index].tdi_properties = type_properties }})
// ---> ("analTypeDef", td_name, type_module, type_index)
is_abs (AbstractType _) = True
is_abs _ = False
analyseTypeDefs :: !{#CommonDefs} !TypeGroups !*TypeDefInfos !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin)
analyseTypeDefs modules groups