diff options
author | sjakie | 2001-09-21 08:08:59 +0000 |
---|---|---|
committer | sjakie | 2001-09-21 08:08:59 +0000 |
commit | 68a9935f0203b73b5edb13a9e3996b8b06d05f48 (patch) | |
tree | 779071559cd7c17f66dcd4b02949f9805615f34f /frontend | |
parent | Added module owners for convertDynamics, type_io and type_io_common (diff) |
Bug fix: caching combined with omitted type and class definitions
git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@800 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d
Diffstat (limited to 'frontend')
-rw-r--r-- | frontend/analtypes.dcl | 6 | ||||
-rw-r--r-- | frontend/analtypes.icl | 578 | ||||
-rw-r--r-- | frontend/check.icl | 89 | ||||
-rw-r--r-- | frontend/checkKindCorrectness.dcl | 2 | ||||
-rw-r--r-- | frontend/checkKindCorrectness.icl | 19 | ||||
-rw-r--r-- | frontend/checksupport.dcl | 11 | ||||
-rw-r--r-- | frontend/checksupport.icl | 27 | ||||
-rw-r--r-- | frontend/checktypes.dcl | 8 | ||||
-rw-r--r-- | frontend/checktypes.icl | 508 | ||||
-rw-r--r-- | frontend/comparedefimp.dcl | 2 | ||||
-rw-r--r-- | frontend/comparedefimp.icl | 371 | ||||
-rw-r--r-- | frontend/frontend.dcl | 16 | ||||
-rw-r--r-- | frontend/frontend.icl | 84 | ||||
-rw-r--r-- | frontend/main.icl | 10 | ||||
-rw-r--r-- | frontend/overloading.icl | 17 | ||||
-rw-r--r-- | frontend/parse.icl | 6 | ||||
-rw-r--r-- | frontend/refmark.icl | 9 | ||||
-rw-r--r-- | frontend/syntax.dcl | 32 | ||||
-rw-r--r-- | frontend/syntax.icl | 38 | ||||
-rw-r--r-- | frontend/type.icl | 4 | ||||
-rw-r--r-- | frontend/typesupport.dcl | 7 | ||||
-rw-r--r-- | frontend/typesupport.icl | 86 | ||||
-rw-r--r-- | frontend/unitype.icl | 3 |
23 files changed, 1090 insertions, 843 deletions
diff --git a/frontend/analtypes.dcl b/frontend/analtypes.dcl index 9fa9735..22b25d3 100644 --- a/frontend/analtypes.dcl +++ b/frontend/analtypes.dcl @@ -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) diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index 664c21d..d616b2c 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -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 type_def_infos heaps error + # as = { as_kind_heap = newHeap, as_heaps = heaps, as_td_infos = type_def_infos, as_error = error } + {as_td_infos,as_heaps,as_error} = foldSt (anal_type_defs_in_group modules) groups as + = check_left_root_attribution_of_typedefs modules groups as_td_infos as_heaps as_error where - is_abstract_type (AbstractType properties) - = (True, properties) - is_abstract_type _ - = (False, cAllBitsClear) - - push_on_dep_stack module_index type_index as=:{as_deps,as_check_marks,as_next_num} - = { as & - as_deps = [{glob_module = module_index, glob_object = type_index } : as_deps], - as_check_marks = { as_check_marks & [module_index].[type_index] = as_next_num }, - as_next_num = inc as_next_num } - - try_to_close_group modules type_module type_index ldep (conds=:{con_top_var_binds,con_var_binds}, - as=:{as_check_marks,as_deps,as_next_group_num,as_kind_heap,as_heaps,as_td_infos}) - #! my_mark = as_check_marks.[type_module].[type_index] - | (ldep == cMAXINT || ldep == my_mark) - # (as_deps, as_check_marks, group) = close_group type_module type_index as_deps as_check_marks [] - (kinds, (type_properties, as_kind_heap, as_td_infos)) = determine_kinds_and_properties_of_group group as_kind_heap as_td_infos - as_kind_heap = unify_var_binds con_var_binds as_kind_heap - (normalized_top_vars, (kind_var_store, as_kind_heap)) = normalize_top_vars con_top_var_binds 0 as_kind_heap - (as_kind_heap, as_td_infos) = update_type_group_info group kinds type_properties normalized_top_vars group as_next_group_num 0 kind_var_store as_kind_heap as_td_infos - = (cMAXINT, ({con_top_var_binds = [], con_var_binds = [] }, - { as & as_check_marks = as_check_marks, as_deps = as_deps, as_kind_heap = as_kind_heap, - as_td_infos = as_td_infos, as_next_group_num = inc as_next_group_num })) - = (min my_mark ldep, (conds, as)) - - close_group first_module first_index [d:ds] marks group - # marks = { marks & [d.glob_module].[d.glob_object] = cMAXINT } - | d.glob_module == first_module && d.glob_object == first_index - = (ds, marks, [d : group]) - = close_group first_module first_index ds marks [d : group] - - determine_kinds_and_properties_of_group group kind_heap as_td_infos - = mapSt determine_kinds group (cIsHyperStrict, kind_heap, as_td_infos) + anal_type_defs_in_group modules group as=:{as_td_infos,as_heaps,as_kind_heap} + # (is_abstract_type, as_td_infos, as_heaps, as_kind_heap) + = foldSt (init_type_def_infos modules) group (False, as_td_infos, as_heaps, as_kind_heap) + as = { as & as_td_infos = as_td_infos, as_heaps = as_heaps, as_kind_heap = as_kind_heap } + | is_abstract_type + = as + # (type_properties, conds, as) = foldSt (anal_type_def modules) group (cIsHyperStrict, { con_top_var_binds = [], con_var_binds = [] }, as) + (kinds_in_group, (as_kind_heap, as_td_infos)) = mapSt determine_kinds group (as.as_kind_heap, as.as_td_infos) + as_kind_heap = unify_var_binds conds.con_var_binds as_kind_heap + (normalized_top_vars, (kind_var_store, as_kind_heap)) = normalize_top_vars conds.con_top_var_binds 0 as_kind_heap + (as_kind_heap, as_td_infos) = update_type_def_infos type_properties normalized_top_vars group kinds_in_group kind_var_store as_kind_heap as_td_infos + = { as & as_kind_heap = as_kind_heap, as_td_infos = as_td_infos } + + init_type_def_infos modules gi=:{gi_module,gi_index} (is_abstract_type, type_def_infos, type_heaps, kind_heap) + # {td_args,td_rhs} = modules.[gi_module].com_type_defs.[gi_index] + = case td_rhs of + AbstractType properties + # (tdi, type_def_infos) = type_def_infos![gi_module,gi_index] + new_tdi = { tdi & tdi_kinds = [ KindConst \\ _ <- td_args ], + tdi_group_vars = [ i \\ _ <- td_args & i <- [0..]], + tdi_properties = properties bitor cIsAnalysed } + -> (True, { type_def_infos & [gi_module].[gi_index] = new_tdi}, type_heaps, kind_heap) + _ + # (tdi_kinds, (th_vars, kind_heap)) = newKindVariables td_args (type_heaps.th_vars, kind_heap) + -> (is_abstract_type, { type_def_infos & [gi_module].[gi_index].tdi_kinds = tdi_kinds }, { type_heaps & th_vars = th_vars }, kind_heap) + + anal_type_def modules gi=:{gi_module,gi_index} (group_properties, conds, as=:{as_error}) + # {com_type_defs,com_cons_defs} = modules.[gi_module] + {td_name,td_pos,td_args,td_rhs} = com_type_defs.[gi_index] + as_error = pushErrorAdmin (newPosition td_name td_pos) as_error + (type_properties, (conds, as)) = anal_rhs_of_type_def modules com_cons_defs td_rhs (conds, { as & as_error = as_error }) + = (combineTypeProperties group_properties type_properties, conds, {as & as_error = popErrorAdmin as.as_error }) + where + anal_rhs_of_type_def modules com_cons_defs (AlgType conses) conds_as + = analTypesOfConstructor modules com_cons_defs conses conds_as + anal_rhs_of_type_def modules com_cons_defs (RecordType {rt_constructor}) conds_as + = analTypesOfConstructor modules com_cons_defs [rt_constructor] conds_as + anal_rhs_of_type_def modules _ (SynType type) 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} + = (cv_props, (conds, { as & as_kind_heap = as_kind_heap, as_error = as_error })) + + determine_kinds {gi_module,gi_index} (kind_heap, td_infos) + # (td_info=:{tdi_kinds}, td_infos) = td_infos![gi_module,gi_index] + (new_kinds, kind_heap) = mapSt retrieve_kind tdi_kinds kind_heap + = (new_kinds, (kind_heap, td_infos)) where - determine_kinds {glob_module,glob_object} (type_properties, kind_heap, as_td_infos) - # ({tdi_properties,tdi_kinds}, as_td_infos) = as_td_infos![glob_module].[glob_object] - (kinds, kind_heap) = mapSt retrieve_kind tdi_kinds kind_heap - = (kinds, (combineTypeProperties type_properties tdi_properties, kind_heap, as_td_infos)) - retrieve_kind (KindVar kind_info_ptr) kind_heap # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap = determine_kind kind_info kind_heap @@ -429,7 +552,7 @@ where -> (KindArrow kinds, kind_heap) _ -> (KindConst, kind_heap) - + unify_var_binds :: ![VarBind] !*KindHeap -> *KindHeap unify_var_binds binds kind_heap = foldr unify_var_bind kind_heap binds @@ -472,22 +595,17 @@ where # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap = nomalize_var kind_info_ptr kind_info (kind_store, kind_heap) -// update_type_group_info :: ![Index] ![[TypeKind]] !TypeProperties ![Int] ![Int] !Index !Int !*KindHeap !*{# CheckedTypeDef} -> (!*KindHeap,!*{# CheckedTypeDef}) - update_type_group_info [td:tds] [td_kinds : tds_kinds] type_properties top_vars group group_nr loc_type_index kind_store kind_heap td_infos - # (kind_store, kind_heap, td_infos) = update_type_def_info td td_kinds type_properties top_vars group group_nr loc_type_index kind_store kind_heap td_infos - = update_type_group_info tds tds_kinds type_properties top_vars group group_nr (inc loc_type_index) kind_store kind_heap td_infos - update_type_group_info [] [] type_properties top_vars group group_nr loc_type_index kind_store kind_heap td_infos - = (kind_heap, td_infos) - -// update_type_def_info :: !Int ![TypeKind] !TypeProperties ![Int] ![Int] !Int !Index !Int !*KindHeap !*{# CheckedTypeDef} -> (!Int,!*KindHeap,!*{# CheckedTypeDef}) - update_type_def_info {glob_module,glob_object} td_kinds type_properties top_vars group group_nr loc_type_index kind_store kind_heap td_infos - # (td_info=:{tdi_kinds}, td_infos) = td_infos![glob_module].[glob_object] - # (group_vars, cons_vars, kind_store, kind_heap) = determine_type_def_info tdi_kinds td_kinds top_vars kind_store kind_heap - = (kind_store, kind_heap, { td_infos & [glob_module].[glob_object] = - {td_info & tdi_properties = type_properties, tdi_kinds = td_kinds, tdi_group = group, - tdi_group_vars = group_vars, tdi_cons_vars = cons_vars, tdi_group_nr = group_nr, tdi_tmp_index = loc_type_index } }) -// ---> ("update_type_def_info", glob_module, glob_object, (group_nr, loc_type_index)) + update_type_def_infos type_properties top_vars group updated_kinds_of_group kind_store kind_heap td_infos + # (_, as_kind_heap, as_td_infos) = fold2St (update_type_def_info (type_properties bitor cIsAnalysed) top_vars) group updated_kinds_of_group + (kind_store, kind_heap, td_infos) + = (as_kind_heap, as_td_infos) where + update_type_def_info type_properties top_vars {gi_module,gi_index} updated_kinds (kind_store, kind_heap, td_infos) + # (td_info=:{tdi_kinds}, td_infos) = td_infos![gi_module].[gi_index] + # (group_vars, cons_vars, kind_store, kind_heap) = determine_type_def_info tdi_kinds updated_kinds top_vars kind_store kind_heap + = (kind_store, kind_heap, { td_infos & [gi_module,gi_index] = + {td_info & tdi_properties = type_properties, tdi_kinds = updated_kinds, tdi_group_vars = group_vars, tdi_cons_vars = cons_vars }}) + determine_type_def_info [ KindVar kind_info_ptr : kind_vars ] [ kind : kinds ] top_vars kind_store kind_heap #! kind_info = sreadPtr kind_info_ptr kind_heap # (var_number, (kind_store, kind_heap)) = nomalize_var kind_info_ptr kind_info (kind_store, kind_heap) @@ -507,61 +625,31 @@ where is_a_top_var var_number [] = False -//import RWSDebug - -analTypeDefs :: !{#CommonDefs} !NumberSet !*TypeHeaps !*ErrorAdmin -> (!*TypeDefInfos, !*TypeHeaps, !*ErrorAdmin) -analTypeDefs modules used_module_numbers heaps error -// #! modules = modules ---> "analTypeDefs" -// # sizes = [ size mod.com_type_defs - size mod.com_class_defs \\ mod <-: modules ] -// # used_module_numbers = used_module_numbers <<- used_module_numbers - # sizes = [ if (inNumberSet module_n used_module_numbers) (size mod.com_type_defs - size mod.com_class_defs) 0 \\ mod <-: modules & module_n<-[0..]] - - check_marks = { createArray nr_of_types AS_NotChecked \\ nr_of_types <- sizes } - type_def_infos = { createArray nr_of_types EmptyTypeDefInfo \\ nr_of_types <- sizes } - - as = { as_check_marks = check_marks, as_kind_heap = newHeap, as_heaps = heaps, as_td_infos = type_def_infos, - as_next_num = 0, as_deps = [], as_next_group_num = 0, as_error = error } - - {as_td_infos,as_heaps,as_error} = anal_type_defs modules 0 sizes as - (as_td_infos, th_vars, as_error) - = foldSt (check_left_root_attribution_of_typedef_in_module modules) - [(s,i) \\ s<-sizes & i<-[0..]] (as_td_infos, as_heaps.th_vars, as_error) - = (as_td_infos, { as_heaps & th_vars = th_vars }, as_error) -where - anal_type_defs modules mod_index [ size : sizes ] as - # as = iFoldSt (anal_type_def modules mod_index) 0 size as - = anal_type_defs modules (inc mod_index) sizes as - anal_type_defs _ _ [] as - = as - - anal_type_def modules mod_index type_index as=:{as_check_marks} - | as_check_marks.[mod_index].[type_index] == AS_NotChecked - # (_, (_, as)) = analTypeDef modules mod_index type_index as - = as - = as - - check_left_root_attribution_of_typedef_in_module modules (siz,mod_index) (as_td_infos, th_vars, as_error) - = iFoldSt (checkLeftRootAttributionOfTypeDef modules mod_index) - 0 siz (as_td_infos, th_vars, as_error) + check_left_root_attribution_of_typedefs modules groups type_def_infos type_heaps error + # (type_def_infos, th_vars, error) = foldSt (foldSt (checkLeftRootAttributionOfTypeDef modules)) groups (type_def_infos, type_heaps.th_vars, error) + = (type_def_infos, { type_heaps & th_vars = th_vars }, error) + instance <<< DynamicType where (<<<) file {dt_global_vars,dt_type} = file <<< dt_global_vars <<< dt_type +instance <<< GlobalIndex +where + (<<<) file {gi_module,gi_index} = file <<< '[' <<< gi_module <<< ',' <<< gi_index <<< ']' -checkLeftRootAttributionOfTypeDef :: !{# CommonDefs} !Index !Index !(!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin) +checkLeftRootAttributionOfTypeDef :: !{# CommonDefs} GlobalIndex !(!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin) -> (!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin) -checkLeftRootAttributionOfTypeDef common_defs mod_index type_index (td_infos, th_vars, error) - # {td_rhs, td_attribute, td_name, td_pos} - = common_defs.[mod_index].com_type_defs.[type_index] +checkLeftRootAttributionOfTypeDef common_defs {gi_module,gi_index} (td_infos, th_vars, error) + # {td_rhs, td_attribute, td_name, td_pos} = common_defs.[gi_module].com_type_defs.[gi_index] | isUniqueAttr td_attribute = (td_infos, th_vars, error) # (is_unique, (td_infos, th_vars)) - = isUniqueTypeRhs common_defs mod_index td_rhs (td_infos, th_vars) + = isUniqueTypeRhs common_defs gi_module td_rhs (td_infos, th_vars) | is_unique = (td_infos, th_vars, checkErrorWithIdentPos (newPosition td_name td_pos) " left root * attribute expected" error) - = (td_infos, th_vars, error) + = (td_infos, th_vars, error) isUniqueTypeRhs common_defs mod_index (AlgType constructors) state = one_constructor_is_unique common_defs mod_index constructors state diff --git a/frontend/check.icl b/frontend/check.icl index 33e53b6..c67deb5 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -81,11 +81,12 @@ checkTypeClasses :: !Index !Index !*{#ClassDef} !*{#MemberDef} !*{#CheckedTypeDe checkTypeClasses class_index module_index class_defs member_defs type_defs modules type_heaps cs=:{cs_symbol_table,cs_error} | class_index == size class_defs = (class_defs, member_defs, type_defs, modules, type_heaps, cs) - # (class_def=:{class_name,class_pos,class_args,class_context,class_members}, class_defs) = class_defs![class_index] + # (class_def=:{class_name,class_pos,class_args,class_context,class_members,class_dictionary}, class_defs) = class_defs![class_index] cs = {cs & cs_error = setErrorAdmin (newPosition class_name class_pos) cs_error } (class_args, class_context, type_defs, class_defs, modules, type_heaps, cs) = checkSuperClasses class_args class_context module_index type_defs class_defs modules type_heaps cs - class_defs = { class_defs & [class_index] = { class_def & class_context = class_context, class_args = class_args }} + class_dictionary = { class_dictionary & ds_ident.id_info = nilPtr } + class_defs = { class_defs & [class_index] = { class_def & class_context = class_context, class_args = class_args, class_dictionary = class_dictionary }} member_defs = set_classes_in_member_defs 0 class_members {glob_object = class_index, glob_module = module_index} member_defs = checkTypeClasses (inc class_index) module_index class_defs member_defs type_defs modules type_heaps cs where @@ -868,9 +869,7 @@ where createCommonDefinitions {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances, def_generics} = { com_type_defs = { type \\ type <- def_types } - - , com_unexpanded_type_defs = {} - +// , com_unexpanded_type_defs = {} , com_cons_defs = { cons \\ cons <- def_constructors } , com_selector_defs = { sel \\ sel <- def_selectors } , com_class_defs = { class_def \\ class_def <- def_classes } @@ -1041,34 +1040,39 @@ renumber_icl_definitions_as_dcl_definitions _ icl_decl_symbols modules cdefs icl # class_def = {class_def & class_members=class_members} # cdefs = {cdefs & com_class_defs.[decl_index] =class_def} = (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cClassDefs,decl_index]},cdefs) + renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Instance _, decl_index}) cdefs + = (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cInstanceDefs,decl_index]},cdefs) renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Generic, decl_index}) cdefs = (Declaration {icl_decl_symbol & decl_index=icl_to_dcl_index_table.[cGenericDefs,decl_index]},cdefs) renumber_icl_decl_symbol icl_decl_symbol cdefs = (icl_decl_symbol,cdefs) # cdefs=reorder_common_definitions cdefs with - reorder_common_definitions {com_type_defs,com_cons_defs,com_selector_defs,com_class_defs,com_member_defs,com_instance_defs, /* AA */ com_generic_defs} + reorder_common_definitions {com_type_defs,com_cons_defs,com_selector_defs,com_class_defs,com_member_defs,com_instance_defs,com_generic_defs} # com_type_defs=reorder_array com_type_defs icl_to_dcl_index_table.[cTypeDefs] # com_cons_defs=reorder_array com_cons_defs icl_to_dcl_index_table.[cConstructorDefs] # com_selector_defs=reorder_array com_selector_defs icl_to_dcl_index_table.[cSelectorDefs] # com_class_defs=reorder_array com_class_defs icl_to_dcl_index_table.[cClassDefs] # com_member_defs=reorder_array com_member_defs icl_to_dcl_index_table.[cMemberDefs] + # com_instance_defs=reorder_array com_instance_defs icl_to_dcl_index_table.[cInstanceDefs] # com_generic_defs=reorder_array com_generic_defs icl_to_dcl_index_table.[cGenericDefs] = { - com_unexpanded_type_defs={},com_type_defs=com_type_defs,com_cons_defs=com_cons_defs,com_selector_defs=com_selector_defs, +// com_unexpanded_type_defs={}, + com_type_defs=com_type_defs,com_cons_defs=com_cons_defs,com_selector_defs=com_selector_defs, com_class_defs=com_class_defs,com_member_defs=com_member_defs,com_instance_defs=com_instance_defs,com_generic_defs=com_generic_defs } where reorder_array array index_array # new_array={e\\e<-:array} = {new_array & [index_array.[i]]=e \\ e<-:array & i<-[0..]} - # conversion_table = {if (kind_index<=cMemberDefs) {i\\i<-[0..size table-1]} table \\ table<-:conversion_table & kind_index<-[0..]} + # conversion_table = {if (kind_index<=cInstanceDefs) {i\\i<-[0..size table-1]} table \\ table<-:conversion_table & kind_index<-[0..]} # modules = {modules & [main_dcl_module_n].dcl_conversions=Yes conversion_table} = (icl_decl_symbols,modules,cdefs,cs) -combineDclAndIclModule :: ModuleKind *{#.DclModule} [Declaration] (CollectedDefinitions a b) *{#.Int} *CheckState -> (!*{#DclModule},![Declaration],!CollectedDefinitions a b,!*{#Int},!.CheckState); +combineDclAndIclModule :: ModuleKind *{#DclModule} [Declaration] (CollectedDefinitions a b) *{#Int} *CheckState + -> (!CopiedDefinitions, !*{#DclModule}, ![Declaration], !CollectedDefinitions a b, !*{#Int}, !*CheckState); combineDclAndIclModule MK_Main modules icl_decl_symbols icl_definitions icl_sizes cs - = (modules, icl_decl_symbols, icl_definitions, icl_sizes, cs) + = ({ copied_type_defs = [], copied_class_defs = [] }, modules, icl_decl_symbols, icl_definitions, icl_sizes, cs) combineDclAndIclModule _ modules icl_decl_symbols icl_definitions icl_sizes cs #! main_dcl_module_n=cs.cs_x.x_main_dcl_module_n # (dcl_mod=:{dcl_declared={dcls_local},dcl_macros, dcl_sizes, dcl_common}, modules) = modules![main_dcl_module_n] @@ -1078,12 +1082,13 @@ combineDclAndIclModule _ modules icl_decl_symbols icl_definitions icl_sizes cs (moved_dcl_defs, conversion_table, icl_sizes, icl_decl_symbols, cs) = foldSt (add_to_conversion_table dcl_macros.ir_from dcl_common) dcls_local ([], { createArray size NoIndex \\ size <-: dcl_sizes }, icl_sizes, icl_decl_symbols, cs) - (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, /*AA*/new_generic_defs, cs) - = foldSt (add_dcl_definition dcl_common) moved_dcl_defs ([], [], [], [], [], /*AA*/[],cs) + (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, copied_defs, cs) + = foldSt (add_dcl_definition dcl_common) moved_dcl_defs ([], [], [], [], [], [], { copied_type_defs = [], copied_class_defs = [] }, cs) cs_symbol_table = removeDeclarationsFromSymbolTable icl_decl_symbols cGlobalScope cs.cs_symbol_table - = ( { modules & [main_dcl_module_n] = { dcl_mod & dcl_conversions = Yes conversion_table }} + = ( copied_defs + , { modules & [main_dcl_module_n] = { dcl_mod & dcl_conversions = Yes conversion_table }} , icl_decl_symbols , { icl_definitions & def_types = my_append icl_definitions.def_types new_type_defs @@ -1145,10 +1150,11 @@ where ) add_dcl_definition {com_type_defs} dcl=:(Declaration {decl_kind = STE_Type, decl_index}) - (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs,cs) + (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, copied_defs=:{copied_type_defs}, cs) # type_def = com_type_defs.[decl_index] (new_type_defs, cs) = add_type_def type_def new_type_defs cs - = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, cs) + copied_defs = { copied_defs & copied_type_defs = [decl_index : copied_type_defs] } + = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, copied_defs, cs) where add_type_def td=:{td_pos, td_rhs = AlgType conses} new_type_defs cs # (conses, cs) = mapSt (redirect_defined_symbol STE_Constructor td_pos) conses cs @@ -1181,34 +1187,30 @@ where is_field _ = False add_dcl_definition {com_cons_defs} dcl=:(Declaration {decl_kind = STE_Constructor, decl_index}) - (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs,new_generic_defs,cs) - = (new_type_defs, new_class_defs, [ com_cons_defs.[decl_index] : new_cons_defs ], new_selector_defs, new_member_defs,new_generic_defs,cs) + (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, copied_defs, cs) + = (new_type_defs, new_class_defs, [ com_cons_defs.[decl_index] : new_cons_defs ], new_selector_defs, new_member_defs, new_generic_defs, copied_defs, cs) add_dcl_definition {com_selector_defs} dcl=:(Declaration {decl_kind = STE_Field _, decl_index}) - (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs,new_generic_defs,cs) - = (new_type_defs, new_class_defs, new_cons_defs, [ com_selector_defs.[decl_index] : new_selector_defs ], new_member_defs,new_generic_defs,cs) + (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, copied_defs, cs) + = (new_type_defs, new_class_defs, new_cons_defs, [ com_selector_defs.[decl_index] : new_selector_defs ], new_member_defs, new_generic_defs, copied_defs, cs) add_dcl_definition {com_class_defs} dcl=:(Declaration {decl_kind = STE_Class, decl_index, decl_pos}) - (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs,new_generic_defs,cs) + (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, copied_defs=:{copied_class_defs}, cs) # class_def = com_class_defs.[decl_index] + copied_defs = { copied_defs & copied_class_defs = [decl_index : copied_class_defs] } (new_class_defs, cs) = add_class_def decl_pos class_def new_class_defs cs - = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, cs) + = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, copied_defs, cs) where add_class_def decl_pos cd=:{class_members} new_class_defs cs # (new_class_members, cs) = mapSt (redirect_defined_symbol STE_Member decl_pos) [ cm \\ cm<-:class_members ] cs = ([{cd & class_members={cm \\ cm<-new_class_members}}:new_class_defs], cs) add_dcl_definition {com_member_defs} dcl=:(Declaration {decl_kind = STE_Member, decl_index, decl_pos}) - (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs,new_generic_defs,cs) + (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, copied_defs, cs) # member_def = com_member_defs.[decl_index] - = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, [member_def:new_member_defs], new_generic_defs, cs) -// AA.. + = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, [member_def:new_member_defs], new_generic_defs, copied_defs, cs) add_dcl_definition {com_generic_defs} dcl=:(Declaration {decl_kind = STE_Generic, decl_index, decl_pos}) - (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, cs) + (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, copied_defs, cs) # generic_def = com_generic_defs.[decl_index] - = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, [generic_def:new_generic_defs], cs) -// ..AA - - add_dcl_definition _ _ - (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, cs) - = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, cs) + = (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, [generic_def:new_generic_defs], copied_defs, cs) + add_dcl_definition _ _ result = result redirect_defined_symbol req_kind pos ds=:{ds_ident} cs # ({ste_kind,ste_index}, cs_symbol_table) = readPtr ds_ident.id_info cs.cs_symbol_table @@ -1755,7 +1757,7 @@ check_module2 :: Ident [.ImportedObject] .[Import ImportDeclaration] .ModuleKind check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_function_range icl_instance_range nr_of_functions n_functions_and_macros_in_dcl_modules optional_pre_def_mod local_defs icl_functions init_dcl_modules cdefs sizes heaps cs # (main_dcl_module_n,cs)=cs!cs_x.x_main_dcl_module_n (icl_sizes_without_added_dcl_defs, sizes) = memcpy sizes - (dcl_modules, local_defs, cdefs, icl_sizes, cs) + (copied_dcl_defs, dcl_modules, local_defs, cdefs, icl_sizes, cs) = combineDclAndIclModule mod_type init_dcl_modules local_defs cdefs sizes cs | not cs.cs_error.ea_ok = (False, abort "evaluated error 1 (check.icl)", {}, {}, No, {}, cs.cs_x.x_main_dcl_module_n,heaps, cs.cs_predef_symbols, cs.cs_symbol_table, cs.cs_error.ea_file, []) @@ -1837,7 +1839,7 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func (icl_common, dcl_modules, hp_type_heaps, hp_var_heap, cs) = checkCommonDefinitions cIsNotADclModule main_dcl_module_n icl_common dcl_modules heaps.hp_type_heaps heaps.hp_var_heap cs - +/* (unexpanded_icl_type_defs, icl_common) = copy_com_type_defs icl_common @@ -1847,7 +1849,7 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func = { icl_common & com_type_defs = com_type_defs } cs = { cs & cs_error = cs_error } - +*/ (instance_types, icl_common, dcl_modules, hp_var_heap, hp_type_heaps, cs) = checkInstances main_dcl_module_n icl_common dcl_modules hp_var_heap hp_type_heaps cs @@ -1905,8 +1907,8 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func com_cons_defs = e_info.ef_cons_defs, com_member_defs = e_info.ef_member_defs, com_generic_defs = e_info.ef_generic_defs, // AA com_instance_defs = class_instances } - icl_mod = { icl_name = mod_name, icl_functions = icl_functions, icl_common = icl_common, icl_instances = icl_instances, icl_specials = icl_specials, - icl_imported_objects = mod_imported_objects, icl_used_module_numbers = imported_module_numbers, + icl_mod = { icl_name = mod_name, icl_functions = icl_functions, icl_common = icl_common, icl_instances = icl_instances, icl_specials = icl_specials, + icl_imported_objects = mod_imported_objects, icl_used_module_numbers = imported_module_numbers, icl_copied_from_dcl = copied_dcl_defs, icl_import = icl_imported } heaps = { heaps & hp_var_heap = var_heap, hp_expression_heap = expr_heap, hp_type_heaps = {hp_type_heaps & th_vars = th_vars}} @@ -1916,7 +1918,7 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func (icl_mod, heaps, cs_error) = compareDefImp icl_sizes_without_added_dcl_defs untransformed_fun_bodies main_dcl_module_n - unexpanded_icl_type_defs main_dcl_module icl_mod heaps cs_error + /* unexpanded_icl_type_defs */ main_dcl_module icl_mod heaps cs_error = (cs_error.ea_ok, icl_mod, dcl_modules, groups, dcl_icl_conversions, cached_functions_and_macros, cs_x.x_main_dcl_module_n, heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file, directly_imported_dcl_modules) # icl_common = { icl_common & com_type_defs = e_info.ef_type_defs, com_selector_defs = e_info.ef_selector_defs, com_class_defs = e_info.ef_class_defs, @@ -1925,7 +1927,7 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func icl_mod = { icl_name = mod_name, icl_functions = icl_functions, icl_common = icl_common, icl_instances = icl_instance_range, icl_specials = {ir_from = nr_of_functions, ir_to = nr_of_functions}, - icl_imported_objects = mod_imported_objects, icl_used_module_numbers = imported_module_numbers, + icl_imported_objects = mod_imported_objects, icl_used_module_numbers = imported_module_numbers, icl_copied_from_dcl = copied_dcl_defs, icl_import = icl_imported } = (False, icl_mod, dcl_modules, {}, No, {}, cs_x.x_main_dcl_module_n,heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file, directly_imported_dcl_modules) where @@ -2159,12 +2161,12 @@ check_needed_modules_are_imported mod_name extension cs=:{cs_x={x_needed_modules // MV ... switched_off_Clean_feature pd mod_name explanation extension cs=:{cs_predef_symbols, cs_symbol_table} - # (ident,cs_predef_symbols) = cs_predef_symbols![pd].pds_ident + # (ident,cs_predef_symbols) = cs_predef_symbols![pd].pds_ident # error_location = { ip_ident = mod_name, ip_line = 1, ip_file = mod_name.id_name+++extension} cs_error = pushErrorAdmin error_location cs.cs_error cs_error = checkError ident ("not supported"+++explanation) cs_error cs_error = popErrorAdmin cs_error - = { cs & cs_error = cs_error, cs_predef_symbols=cs_predef_symbols} + = { cs & cs_error = cs_error, cs_predef_symbols = cs_predef_symbols } // ... MV arrayFunOffsetToPD_IndexTable :: !w:{# MemberDef} !v:{# PredefinedSymbol} -> (!{# Index}, !x:{#MemberDef}, !v:{#PredefinedSymbol}) , [w<=x] @@ -2499,9 +2501,9 @@ doSomeThingsThatHaveToBeDoneAfterTheWholeComponentHasBeenChecked mod_index (dcl_modules, heaps=:{hp_type_heaps, hp_var_heap}, cs=:{cs_error}) #! main_dcl_module_n = cs.cs_x.x_main_dcl_module_n - # (dcl_modules, hp_type_heaps, cs_error) +/* # (dcl_modules, hp_type_heaps, cs_error) = expand_syn_types_of_dcl_mod mod_index (dcl_modules, hp_type_heaps, cs_error) - (dcl_mod=:{dcl_functions, dcl_common}, dcl_modules) +*/ # (dcl_mod=:{dcl_functions, dcl_common}, dcl_modules) = dcl_modules![mod_index] nr_of_dcl_functions = size dcl_functions @@ -2547,6 +2549,7 @@ doSomeThingsThatHaveToBeDoneAfterTheWholeComponentHasBeenChecked mod_index = { dcl_modules & [mod_index] = dcl_mod } = (dcl_modules, heaps, cs) where +/* expand_syn_types_of_dcl_mod mod_index (dcl_modules, hp_type_heaps, cs_error) # (type_defs, dcl_modules) = dcl_modules![mod_index].dcl_common.com_type_defs @@ -2559,7 +2562,7 @@ doSomeThingsThatHaveToBeDoneAfterTheWholeComponentHasBeenChecked mod_index dcl_modules = { dcl_modules & [mod_index].dcl_common.com_type_defs = expanded_type_defs } = (dcl_modules, hp_type_heaps, cs_error) - +*/ adjust_instance_types_of_array_functions_in_std_array_dcl array_mod_index class_members class_instances fun_types cs=:{cs_predef_symbols} #! nr_of_instances = size class_instances # ({pds_def}, cs_predef_symbols) = cs_predef_symbols![PD_ArrayClass] diff --git a/frontend/checkKindCorrectness.dcl b/frontend/checkKindCorrectness.dcl index 72ee63e..6dc5678 100644 --- a/frontend/checkKindCorrectness.dcl +++ b/frontend/checkKindCorrectness.dcl @@ -2,5 +2,5 @@ definition module checkKindCorrectness import syntax, checksupport -checkKindCorrectness :: !Index IndexRange !{#CommonDefs} !Int !u:{# FunDef} !*{#DclModule} !*TypeVarHeap !*TypeDefInfos !*ErrorAdmin +checkKindCorrectness :: !Index !Index IndexRange !{#CommonDefs} !Int !u:{# FunDef} !*{#DclModule} !*TypeVarHeap !*TypeDefInfos !*ErrorAdmin -> (!u:{# FunDef}, !*{#DclModule}, !*TypeVarHeap, !*TypeDefInfos, !*ErrorAdmin) diff --git a/frontend/checkKindCorrectness.icl b/frontend/checkKindCorrectness.icl index a11d692..b7d118b 100644 --- a/frontend/checkKindCorrectness.icl +++ b/frontend/checkKindCorrectness.icl @@ -5,9 +5,9 @@ import syntax, containers, checksupport, utilities //import RWSDebug -checkKindCorrectness :: !Index IndexRange !{#CommonDefs} !Int !u:{# FunDef} !*{#DclModule} !*TypeVarHeap !*TypeDefInfos !*ErrorAdmin +checkKindCorrectness :: !Index !Index IndexRange !{#CommonDefs} !Int !u:{# FunDef} !*{#DclModule} !*TypeVarHeap !*TypeDefInfos !*ErrorAdmin -> (!u:{# FunDef}, !*{#DclModule}, !*TypeVarHeap, !*TypeDefInfos, !*ErrorAdmin) -checkKindCorrectness main_dcl_module_n icl_instances common_defs n_cached_dcl_modules fun_defs dcl_mods th_vars td_infos error_admin +checkKindCorrectness main_dcl_module_n first_uncached_function icl_instances common_defs n_cached_dcl_modules fun_defs dcl_mods th_vars td_infos error_admin #! n_fun_defs = size fun_defs size_dcl_mods = size dcl_mods # (dcl_mods, th_vars, td_infos, error_admin) @@ -32,7 +32,7 @@ checkKindCorrectness main_dcl_module_n icl_instances common_defs n_cached_dcl_mo 0 size_dcl_mods (bv_uninitialized_mods, th_vars, td_infos, error_admin) // check_icl_function: don't check the types that were generated for instances state - = iFoldSt (check_icl_function common_defs) 0 icl_instances.ir_from + = iFoldSt (check_icl_function common_defs) first_uncached_function /* 0 */ icl_instances.ir_from (fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin) (fun_defs, bv_uninitialized_mods, th_vars, td_infos, error_admin) = iFoldSt (check_icl_function common_defs) icl_instances.ir_to n_fun_defs state @@ -120,6 +120,7 @@ checkKindCorrectness main_dcl_module_n icl_instances common_defs n_cached_dcl_mo get_expected_kinds class_index=:{glob_module, glob_object} common_defs bv_uninitialized_mods th_vars | bitvectSelect glob_module bv_uninitialized_mods +// ---> ("get_expected_kinds", glob_module) /* the desired class is defined in a module which is a cached one => check_classes has not been called for all the classes within that module @@ -325,17 +326,7 @@ checkKindCorrectness main_dcl_module_n icl_instances common_defs n_cached_dcl_mo = "type of argument nr "+++toString i = "type context nr "+++toString (~i) - get_common_defs dcl_mods - #! size = size dcl_mods - # ({dcl_common=arbitrary_value_for_initializing}, dcl_mods) = dcl_mods![0] - = loop 0 (createArray size arbitrary_value_for_initializing) dcl_mods - where - loop :: !Int !*{#CommonDefs} !u:{#DclModule} -> (!*{#CommonDefs}, !u:{#DclModule}) - loop i common_defs dcl_mods - | i==size dcl_mods - = (common_defs, dcl_mods) - # ({dcl_common}, dcl_mods) = dcl_mods![i] - = loop (i+1) { common_defs & [i] = dcl_common } dcl_mods in_index_range test ir :== test>=ir.ir_from && test < ir.ir_to + diff --git a/frontend/checksupport.dcl b/frontend/checksupport.dcl index 95b5fc9..f1baa74 100644 --- a/frontend/checksupport.dcl +++ b/frontend/checksupport.dcl @@ -53,7 +53,7 @@ cConversionTableSize :== 9 // AA :: CommonDefs = { com_type_defs :: !.{# CheckedTypeDef} - , com_unexpanded_type_defs :: !{# CheckedTypeDef} +// , com_unexpanded_type_defs :: !{# CheckedTypeDef} , com_cons_defs :: !.{# ConsDef} , com_selector_defs :: !.{# SelectorDef} , com_class_defs :: !.{# ClassDef} @@ -83,16 +83,21 @@ cConversionTableSize :== 9 // AA , di_belonging :: !NumberSet } +:: CopiedDefinitions = + { copied_type_defs :: [Index] + , copied_class_defs :: [Index] + } + :: IclModule = { icl_name :: !Ident , icl_functions :: !.{# FunDef } , icl_instances :: !IndexRange , icl_specials :: !IndexRange , icl_common :: !.CommonDefs -// , icl_declared :: !Declarations - , icl_import :: !{!Declaration} + , icl_import :: !{!Declaration} , icl_imported_objects :: ![ImportedObject] , icl_used_module_numbers :: !NumberSet + , icl_copied_from_dcl :: !CopiedDefinitions } :: DclModule = diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl index e1a22c9..3320f1a 100644 --- a/frontend/checksupport.icl +++ b/frontend/checksupport.icl @@ -45,12 +45,12 @@ cConstructorDefs :== 1 cSelectorDefs :== 2 cClassDefs :== 3 cMemberDefs :== 4 -cGenericDefs :== 5 // AA +cGenericDefs :== 5 cInstanceDefs :== 6 cFunctionDefs :== 7 cMacroDefs :== 8 -cConversionTableSize :== 9 // AA +cConversionTableSize :== 9 instance toInt STE_Kind where @@ -67,9 +67,7 @@ where :: CommonDefs = { com_type_defs :: !.{# CheckedTypeDef} - - , com_unexpanded_type_defs :: !{# CheckedTypeDef} - +// , com_unexpanded_type_defs :: !{# CheckedTypeDef} , com_cons_defs :: !.{# ConsDef} , com_selector_defs :: !.{# SelectorDef} , com_class_defs :: !.{# ClassDef} @@ -98,16 +96,21 @@ where , di_belonging :: !NumberSet } +:: CopiedDefinitions = + { copied_type_defs :: [Index] + , copied_class_defs :: [Index] + } + :: IclModule = - { icl_name :: !Ident - , icl_functions :: !.{# FunDef } - , icl_instances :: !IndexRange - , icl_specials :: !IndexRange - , icl_common :: !.CommonDefs -// , icl_declared :: !Declarations - , icl_import :: !{!Declaration} + { icl_name :: !Ident + , icl_functions :: !.{# FunDef } + , icl_instances :: !IndexRange + , icl_specials :: !IndexRange + , icl_common :: !.CommonDefs + , icl_import :: !{!Declaration} , icl_imported_objects :: ![ImportedObject] , icl_used_module_numbers :: !NumberSet + , icl_copied_from_dcl :: !CopiedDefinitions } :: DclModule = diff --git a/frontend/checktypes.dcl b/frontend/checktypes.dcl index e668552..e035f29 100644 --- a/frontend/checktypes.dcl +++ b/frontend/checktypes.dcl @@ -22,15 +22,15 @@ checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType) !u:{# CheckedT createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !*TypeVarHeap !*VarHeap !*CheckState -> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*CheckState) - +/* bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps; clearBindingsOfTypeVarsAndAttributes :: !TypeAttribute ![ATypeVar] !*TypeHeaps -> *TypeHeaps; - +*/ isATopConsVar cv :== cv < 0 encodeTopConsVar cv :== dec (~cv) decodeTopConsVar cv :== ~(inc cv) - +/* expandSynonymTypes :: !.Index !*{#CheckedTypeDef} !*{#.DclModule} !*TypeHeaps !*ErrorAdmin -> (!.{#CheckedTypeDef},!.{#DclModule},!.TypeHeaps,!.ErrorAdmin) - +*/ removeVariablesFromSymbolTable :: !Int ![TypeVar] !*SymbolTable -> *SymbolTable diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index ea81616..a43e1d4 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -15,6 +15,7 @@ import syntax, checksupport, check, typesupport, utilities, :: TypeInfo = { ti_var_heap :: !.VarHeap , ti_type_heaps :: !.TypeHeaps + , ti_used_types :: ![SymbolPtr] } :: CurrentTypeInfo = @@ -91,6 +92,21 @@ where = ([x : xs], attr, ts_ti_cs) +retrieveTypeDefinition :: SymbolPtr !Index !*SymbolTable ![SymbolPtr] -> ((!Index, !Index), !*SymbolTable, ![SymbolPtr]) +retrieveTypeDefinition type_ptr mod_index symbol_table used_types + # (entry, symbol_table) = readPtr type_ptr symbol_table + = case entry of + ({ste_kind = this_kind =: STE_Imported STE_Type decl_index, ste_def_level, ste_index}) + -> ((ste_index, decl_index), symbol_table <:= (type_ptr, { entry & ste_kind = STE_UsedType decl_index this_kind }), [type_ptr : used_types]) + ({ste_kind = this_kind =: STE_Type, ste_def_level, ste_index}) + | ste_def_level == cGlobalScope + -> ((ste_index, mod_index), symbol_table <:= (type_ptr, { entry & ste_kind = STE_UsedType mod_index this_kind }), [type_ptr : used_types]) + -> ((NotFound, mod_index), symbol_table, used_types) + ({ste_kind = STE_UsedType mod_index _, ste_def_level, ste_index}) + -> ((ste_index, mod_index), symbol_table, used_types) + _ + -> ((NotFound, mod_index), symbol_table, used_types) + instance bindTypes Type where bindTypes cti (TV tv) ts_ti_cs @@ -98,9 +114,9 @@ where = (TV tv, attr, ts_ti_cs) bindTypes cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} type=:(TA type_cons=:{type_name=type_name=:{id_info}} types) (ts=:{ts_type_defs,ts_modules}, ti, cs=:{cs_symbol_table}) - # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table - cs = { cs & cs_symbol_table = cs_symbol_table } - (type_index, type_module) = retrieveGlobalDefinition entry STE_Type cti_module_index + # ((type_index, type_module), cs_symbol_table, ti_used_types) = retrieveTypeDefinition id_info cti_module_index cs_symbol_table ti.ti_used_types + ti = { ti & ti_used_types = ti_used_types } + # cs = { cs & cs_symbol_table = cs_symbol_table } | type_index <> NotFound # ({td_arity,td_attribute,td_rhs},type_index,ts_type_defs,ts_modules) = getTypeDef type_index type_module cti_module_index ts_type_defs ts_modules ts = { ts & ts_type_defs = ts_type_defs, ts_modules = ts_modules } @@ -110,8 +126,8 @@ where = (TA { type_cons & type_index = { glob_object = type_index, glob_module = type_module}} types, cti_lhs_attribute, ts_ti_cs) = (TA { type_cons & type_index = { glob_object = type_index, glob_module = type_module}} types, determine_type_attribute td_attribute, ts_ti_cs) - = (TE /* JVG was: type */, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name "used with wrong arity" cs.cs_error })) - = (TE /* JVG was: type */, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name "undefined" cs.cs_error})) + = (TE, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name "used with wrong arity" cs.cs_error })) + = (TE, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name "undefined" cs.cs_error})) where determine_type_attribute TA_Unique = TA_Unique determine_type_attribute _ = TA_Multi @@ -154,108 +170,7 @@ addToAttributeEnviron (TA_RootVar attr_var) root_attr attr_env error addToAttributeEnviron _ _ attr_env error = (attr_env, checkError "inconsistent attribution of type definition" "" error) -bindTypesOfConstructors :: !CurrentTypeInfo !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymbol] !(!*TypeSymbols,!*TypeInfo,!*CheckState) - -> (!*TypeSymbols, !*TypeInfo, !*CheckState) -bindTypesOfConstructors _ _ _ _ _ [] ts_ti_cs - = ts_ti_cs -bindTypesOfConstructors cti=:{cti_lhs_attribute} cons_index free_vars free_attrs type_lhs [{ds_index}:conses] (ts=:{ts_cons_defs}, ti=:{ti_type_heaps}, cs) - # (cons_def, ts_cons_defs) = ts_cons_defs![ds_index] - # (exi_vars, (ti_type_heaps, cs)) - = addExistentionalTypeVariablesToSymbolTable cti_lhs_attribute cons_def.cons_exi_vars ti_type_heaps cs - (st_args, cons_arg_vars, st_attr_env, (ts, ti, cs)) - = bind_types_of_cons cons_def.cons_type.st_args cti free_vars [] - ({ ts & ts_cons_defs = ts_cons_defs }, { ti & ti_type_heaps = ti_type_heaps }, cs) - cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cGlobalScope /* cOuterMostLevel */ exi_vars cs.cs_symbol_table - (ts, ti, cs) = bindTypesOfConstructors cti (inc cons_index) free_vars free_attrs type_lhs conses - (ts, ti, { cs & cs_symbol_table = cs_symbol_table }) - cons_type = { cons_def.cons_type & st_vars = free_vars, st_args = st_args, st_result = type_lhs, st_attr_vars = free_attrs, st_attr_env = st_attr_env } - (new_type_ptr, ti_var_heap) = newPtr VI_Empty ti.ti_var_heap - = ({ ts & ts_cons_defs = { ts.ts_cons_defs & [ds_index] = - { cons_def & cons_type = cons_type, cons_index = cons_index, cons_type_index = cti.cti_type_index, cons_exi_vars = exi_vars, - cons_type_ptr = new_type_ptr, cons_arg_vars = cons_arg_vars }}}, { ti & ti_var_heap = ti_var_heap }, cs) -where - bind_types_of_cons :: ![AType] !CurrentTypeInfo ![TypeVar] ![AttrInequality] !(!*TypeSymbols, !*TypeInfo, !*CheckState) - -> !(![AType], ![[ATypeVar]], ![AttrInequality], !(!*TypeSymbols, !*TypeInfo, !*CheckState)) - bind_types_of_cons [] cti free_vars attr_env ts_ti_cs - = ([], [], attr_env, ts_ti_cs) - bind_types_of_cons [type : types] cti free_vars attr_env ts_ti_cs - # (types, local_vars_list, attr_env, ts_ti_cs) - = bind_types_of_cons types cti free_vars attr_env ts_ti_cs - (type, type_attr, (ts, ti, cs)) = bindTypes cti type ts_ti_cs - (local_vars, cs_symbol_table) = foldSt retrieve_local_vars free_vars ([], cs.cs_symbol_table) - (attr_env, cs_error) = addToAttributeEnviron type_attr cti.cti_lhs_attribute attr_env cs.cs_error - = ([type : types], [local_vars : local_vars_list], attr_env, (ts, ti , { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })) - where - retrieve_local_vars tv=:{tv_name={id_info}} (local_vars, symbol_table) - # (ste=:{ste_kind = STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count }}, symbol_table) = readPtr id_info symbol_table - | stv_count == 0 - = (local_vars, symbol_table) - - = ([{ atv_variable = { tv & tv_info_ptr = stv_info_ptr}, atv_attribute = stv_attribute, atv_annotation = AN_None } : local_vars], - symbol_table <:= (id_info, { ste & ste_kind = STE_BoundTypeVariable { bv & stv_count = 0}})) -// -checkRhsOfTypeDef :: !CheckedTypeDef ![AttributeVar] !CurrentTypeInfo !(!*TypeSymbols, !*TypeInfo, !*CheckState) - -> (!TypeRhs, !(!*TypeSymbols, !*TypeInfo, !*CheckState)) -// -checkRhsOfTypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:AlgType conses} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs - # type_lhs = { at_annotation = AN_None, at_attribute = cti_lhs_attribute, - at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_name td_arity) - [{at_annotation = AN_None, at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]} - ts_ti_cs = bindTypesOfConstructors cti 0 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs conses ts_ti_cs - = (td_rhs, ts_ti_cs) -checkRhsOfTypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_constructor=rec_cons=:{ds_index}, rt_fields}} - attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs - # type_lhs = { at_annotation = AN_None, at_attribute = cti_lhs_attribute, - at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_name td_arity) - [{at_annotation = AN_None, at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]} - (ts, ti, cs) = bindTypesOfConstructors cti 0 [ atv_variable \\ {atv_variable} <- td_args] - attr_vars type_lhs [rec_cons] ts_ti_cs - # (rec_cons_def, ts) = ts!ts_cons_defs.[ds_index] - # {cons_type = { st_vars,st_args,st_result,st_attr_vars }, cons_exi_vars} = rec_cons_def - - | size rt_fields<>length st_args - = abort ("checkRhsOfTypeDef "+++rt_fields.[0].fs_name.id_name+++" "+++rec_cons_def.cons_symb.id_name+++toString ds_index) - - # (ts_selector_defs, ti_var_heap, cs_error) = check_selectors 0 rt_fields cti_type_index st_args st_result st_vars st_attr_vars cons_exi_vars - ts.ts_selector_defs ti.ti_var_heap cs.cs_error - = (td_rhs, ({ ts & ts_selector_defs = ts_selector_defs }, { ti & ti_var_heap = ti_var_heap }, { cs & cs_error = cs_error})) -where - check_selectors :: !Index !{# FieldSymbol} !Index ![AType] !AType ![TypeVar] ![AttributeVar] ![ATypeVar] !*{#SelectorDef} !*VarHeap !*ErrorAdmin - -> (!*{#SelectorDef}, !*VarHeap, !*ErrorAdmin) - check_selectors field_nr fields rec_type_index sel_types rec_type st_vars st_attr_vars exi_vars selector_defs var_heap error - | field_nr < size fields - # {fs_index} = fields.[field_nr] - # (sel_def, selector_defs) = selector_defs![fs_index] - [sel_type : sel_types] = sel_types - # (sel_type, (st_vars, st_attr_vars)) = lift_quantifier sel_type (st_vars, st_attr_vars) - # (st_attr_env, error) = addToAttributeEnviron sel_type.at_attribute rec_type.at_attribute [] error - # (new_type_ptr, var_heap) = newPtr VI_Empty var_heap - sd_type = { sel_def.sd_type & st_arity = 1, st_args = [rec_type], st_result = sel_type, st_vars = st_vars, - st_attr_vars = st_attr_vars, st_attr_env = st_attr_env } - selector_defs = { selector_defs & [fs_index] = { sel_def & sd_type = sd_type, sd_field_nr = field_nr, sd_type_index = rec_type_index, - sd_type_ptr = new_type_ptr, sd_exi_vars = exi_vars } } - = check_selectors (inc field_nr) fields rec_type_index sel_types rec_type st_vars st_attr_vars exi_vars selector_defs var_heap error - = (selector_defs, var_heap, error) - where - lift_quantifier at=:{at_type = TFA vars type} (type_vars, attr_vars) - = ({ at & at_type = type}, foldSt add_var_and_attr vars (type_vars, attr_vars)) - lift_quantifier at (type_vars, attr_vars) - = (at, (type_vars, attr_vars)) - - add_var_and_attr {atv_variable, atv_attribute} (type_vars, attr_vars) - = ([atv_variable : type_vars], add_attr_var atv_attribute attr_vars) - - add_attr_var (TA_Var av) attr_vars - = [av : attr_vars] - add_attr_var attr attr_vars - = attr_vars - -checkRhsOfTypeDef {td_rhs = SynType type} _ cti ts_ti_cs - # (type, type_attr, ts_ti_cs) = bindTypes cti type ts_ti_cs - = (SynType type, ts_ti_cs) -checkRhsOfTypeDef {td_rhs} _ _ ts_ti_cs - = (td_rhs, ts_ti_cs) emptyIdent name :== { id_name = name, id_info = nilPtr } @@ -266,19 +181,22 @@ decodeTopConsVar cv :== ~(inc cv) checkTypeDef :: !Index !Index !*TypeSymbols !*TypeInfo !*CheckState -> (!*TypeSymbols, !*TypeInfo, !*CheckState); checkTypeDef type_index module_index ts=:{ts_type_defs} ti=:{ti_type_heaps} cs=:{cs_error} # (type_def, ts_type_defs) = ts_type_defs![type_index] - # {td_name,td_pos,td_args,td_attribute} = type_def - # position = newPosition td_name td_pos - cs_error = pushErrorAdmin position cs_error - (td_attribute, attr_vars, th_attrs) = determine_root_attribute td_attribute td_name.id_name ti_type_heaps.th_attrs - (type_vars, (attr_vars, ti_type_heaps, cs)) - = addTypeVariablesToSymbolTable cGlobalScope td_args attr_vars { ti_type_heaps & th_attrs = th_attrs } { cs & cs_error = cs_error } - type_def = { type_def & td_args = type_vars, td_index = type_index, td_attrs = attr_vars, td_attribute = td_attribute } - (td_rhs, (ts, ti, cs)) = checkRhsOfTypeDef type_def attr_vars - { cti_module_index = module_index, cti_type_index = type_index, cti_lhs_attribute = td_attribute } - ({ ts & ts_type_defs = ts_type_defs },{ ti & ti_type_heaps = ti_type_heaps}, cs) - = ({ ts & ts_type_defs = { ts.ts_type_defs & [type_index] = { type_def & td_rhs = td_rhs }}}, ti, - { cs & cs_error = popErrorAdmin cs.cs_error, - cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cGlobalScope /* cOuterMostLevel */ type_vars cs.cs_symbol_table}) + # {td_name,td_pos,td_args,td_attribute,td_index} = type_def + | td_index == NoIndex + # position = newPosition td_name td_pos + cs_error = pushErrorAdmin position cs_error + (td_attribute, attr_vars, th_attrs) = determine_root_attribute td_attribute td_name.id_name ti_type_heaps.th_attrs + (type_vars, (attr_vars, ti_type_heaps, cs)) + = addTypeVariablesToSymbolTable cGlobalScope td_args attr_vars { ti_type_heaps & th_attrs = th_attrs } { cs & cs_error = cs_error } + type_def = { type_def & td_args = type_vars, td_index = type_index, td_attrs = attr_vars, td_attribute = td_attribute } + (td_rhs, (ts, ti, cs)) = check_rhs_of_TypeDef type_def attr_vars + { cti_module_index = module_index, cti_type_index = type_index, cti_lhs_attribute = td_attribute } + ({ ts & ts_type_defs = ts_type_defs },{ ti & ti_type_heaps = ti_type_heaps}, cs) + (td_used_types, cs_symbol_table) = retrieve_used_types ti.ti_used_types cs.cs_symbol_table + = ({ ts & ts_type_defs = { ts.ts_type_defs & [type_index] = { type_def & td_rhs = td_rhs, td_used_types = td_used_types }}}, { ti & ti_used_types = [] }, + { cs & cs_error = popErrorAdmin cs.cs_error, + cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cGlobalScope type_vars cs_symbol_table}) + = ({ ts & ts_type_defs = ts_type_defs }, ti, cs) where determine_root_attribute TA_None name attr_var_heap # (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap @@ -287,188 +205,122 @@ where determine_root_attribute TA_Unique name attr_var_heap = (TA_Unique, [], attr_var_heap) - -CS_Checked :== 1 -CS_Checking :== 0 - -:: ExpandState = - { exp_type_defs ::!.{# CheckedTypeDef} - , exp_modules ::!.{# DclModule} - , exp_marks ::!.{# Int} - , exp_type_heaps ::!.TypeHeaps - , exp_error ::!.ErrorAdmin - } - -class expand a :: !Index !a !*ExpandState -> (!a, !*ExpandState) - -expandTypeVariable :: TypeVar !*ExpandState -> (!Type, !*ExpandState) -expandTypeVariable {tv_info_ptr} expst=:{exp_type_heaps} - # (TVI_Type type, th_vars) = readPtr tv_info_ptr exp_type_heaps.th_vars - = (type, { expst & exp_type_heaps = { exp_type_heaps & th_vars = th_vars }}) - -expandTypeAttribute :: !TypeAttribute !*ExpandState -> (!TypeAttribute, !*ExpandState) -expandTypeAttribute (TA_Var {av_info_ptr}) expst=:{exp_type_heaps} - # (AVI_Attr attr, th_attrs) = readPtr av_info_ptr exp_type_heaps.th_attrs - = (attr, { expst & exp_type_heaps = { exp_type_heaps & th_attrs = th_attrs }}) -expandTypeAttribute attr expst - = (attr, expst) - -instance expand Type -where - expand module_index (TV tv) expst - = expandTypeVariable tv expst - expand module_index type=:(TA type_cons=:{type_name,type_index={glob_object,glob_module}} types) expst=:{exp_marks,exp_error} - | module_index == glob_module - #! mark = exp_marks.[glob_object] - | mark == CS_NotChecked - # expst = expandSynType module_index glob_object expst - (types, expst) = expand module_index types expst - = (TA type_cons types,expst) - | mark == CS_Checked - # (types, expst) = expand module_index types expst - = (TA type_cons types, expst) -// | mark == CS_Checking - = (type, { expst & exp_error = checkError type_name "cyclic dependency between type synonyms" exp_error }) - # (types, expst) = expand module_index types expst - = (TA type_cons types, expst) - expand module_index (arg_type --> res_type) expst - # (arg_type, expst) = expand module_index arg_type expst - (res_type, expst) = expand module_index res_type expst - = (arg_type --> res_type, expst) -// AA.. - expand module_index (TArrow1 type) expst - # (type, expst) = expand module_index type expst - = (TArrow1 type, expst) -// ..AA - expand module_index (CV tv=:{tv_name} :@: types) expst - # (type, expst) = expandTypeVariable tv expst - (types, expst) = expand module_index types expst - (combined_type, exp_error) = simplify_type_appl tv_name type types expst.exp_error - = (combined_type, { expst & exp_error = exp_error }) + // + check_rhs_of_TypeDef :: !CheckedTypeDef ![AttributeVar] !CurrentTypeInfo !(!*TypeSymbols, !*TypeInfo, !*CheckState) + -> (!TypeRhs, !(!*TypeSymbols, !*TypeInfo, !*CheckState)) + // + check_rhs_of_TypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:AlgType conses} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs + # type_lhs = { at_annotation = AN_None, at_attribute = cti_lhs_attribute, + at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_name td_arity) + [{at_annotation = AN_None, at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]} + ts_ti_cs = bind_types_of_constructors cti 0 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs conses ts_ti_cs + = (td_rhs, ts_ti_cs) + check_rhs_of_TypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_constructor=rec_cons=:{ds_index}, rt_fields}} + attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs + # type_lhs = { at_annotation = AN_None, at_attribute = cti_lhs_attribute, + at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_name td_arity) + [{at_annotation = AN_None, at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]} + (ts, ti, cs) = bind_types_of_constructors cti 0 [ atv_variable \\ {atv_variable} <- td_args] + attr_vars type_lhs [rec_cons] ts_ti_cs + # (rec_cons_def, ts) = ts!ts_cons_defs.[ds_index] + # {cons_type = { st_vars,st_args,st_result,st_attr_vars }, cons_exi_vars} = rec_cons_def + # (ts_selector_defs, ti_var_heap, cs_error) = check_selectors 0 rt_fields cti_type_index st_args st_result st_vars st_attr_vars cons_exi_vars + ts.ts_selector_defs ti.ti_var_heap cs.cs_error + = (td_rhs, ({ ts & ts_selector_defs = ts_selector_defs }, { ti & ti_var_heap = ti_var_heap }, { cs & cs_error = cs_error})) + where + check_selectors :: !Index !{# FieldSymbol} !Index ![AType] !AType ![TypeVar] ![AttributeVar] ![ATypeVar] !*{#SelectorDef} !*VarHeap !*ErrorAdmin + -> (!*{#SelectorDef}, !*VarHeap, !*ErrorAdmin) + check_selectors field_nr fields rec_type_index sel_types rec_type st_vars st_attr_vars exi_vars selector_defs var_heap error + | field_nr < size fields + # {fs_index} = fields.[field_nr] + # (sel_def, selector_defs) = selector_defs![fs_index] + [sel_type : sel_types] = sel_types + # (sel_type, (st_vars, st_attr_vars)) = lift_quantifier sel_type (st_vars, st_attr_vars) + # (st_attr_env, error) = addToAttributeEnviron sel_type.at_attribute rec_type.at_attribute [] error + # (new_type_ptr, var_heap) = newPtr VI_Empty var_heap + sd_type = { sel_def.sd_type & st_arity = 1, st_args = [rec_type], st_result = sel_type, st_vars = st_vars, + st_attr_vars = st_attr_vars, st_attr_env = st_attr_env } + selector_defs = { selector_defs & [fs_index] = { sel_def & sd_type = sd_type, sd_field_nr = field_nr, sd_type_index = rec_type_index, + sd_type_ptr = new_type_ptr, sd_exi_vars = exi_vars } } + = check_selectors (inc field_nr) fields rec_type_index sel_types rec_type st_vars st_attr_vars exi_vars selector_defs var_heap error + = (selector_defs, var_heap, error) where - simplify_type_appl :: !Ident !Type ![AType] !*ErrorAdmin -> (!Type, *ErrorAdmin) - simplify_type_appl cv (TA type_cons=:{type_arity} cons_args) type_args error - = (TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args), error) - simplify_type_appl cv (TV tv) type_args error - = (CV tv :@: type_args, error) - simplify_type_appl cv TE t2 error - = (TE, error) - simplify_type_appl cv t1 t2 error - = (TE, checkError cv "kind conflict in argument of type synonym" error) + lift_quantifier at=:{at_type = TFA vars type} (type_vars, attr_vars) + = ({ at & at_type = type}, foldSt add_var_and_attr vars (type_vars, attr_vars)) + lift_quantifier at (type_vars, attr_vars) + = (at, (type_vars, attr_vars)) - expand module_index (TFA vars type) expst - # (type, expst) = expand module_index type expst - = (TFA vars type, expst) - expand module_index type expst - = (type, expst) - -instance expand [a] | expand a -where - expand module_index [x:xs] expst - # (x, expst) = expand module_index x expst - (xs, expst) = expand module_index xs expst - = ([x:xs], expst) - expand module_index [] expst - = ([], expst) - -instance expand AType -where - expand module_index atype=:{at_type,at_attribute} expst - # (at_attribute, expst) = expandTypeAttribute at_attribute expst - (at_type, expst) = expand module_index at_type expst - = ({ atype & at_type = at_type, at_attribute = at_attribute }, expst) -/* -expandTypeApplication (CV tv={tv_name}) types expst - # (type, expst) = expandTypeVariable tv expst - (types, expst) = expand module_index types expst - (combined_type, exp_error) = simplify_type_appl tv_name type types expst.exp_error - = (simplify_type_appl type types, { expst & exp_error = exp_error }) + add_var_and_attr {atv_variable, atv_attribute} (type_vars, attr_vars) + = ([atv_variable : type_vars], add_attr_var atv_attribute attr_vars) + + add_attr_var (TA_Var av) attr_vars + = [av : attr_vars] + add_attr_var attr attr_vars + = attr_vars + + check_rhs_of_TypeDef {td_rhs = SynType type} _ cti ts_ti_cs + # (type, type_attr, ts_ti_cs) = bindTypes cti type ts_ti_cs + = (SynType type, ts_ti_cs) + check_rhs_of_TypeDef {td_rhs} _ _ ts_ti_cs + = (td_rhs, ts_ti_cs) + + bind_types_of_constructors :: !CurrentTypeInfo !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymbol] !(!*TypeSymbols,!*TypeInfo,!*CheckState) + -> (!*TypeSymbols, !*TypeInfo, !*CheckState) + bind_types_of_constructors _ _ _ _ _ [] ts_ti_cs + = ts_ti_cs + bind_types_of_constructors cti=:{cti_lhs_attribute} cons_index free_vars free_attrs type_lhs [{ds_index}:conses] (ts=:{ts_cons_defs}, ti=:{ti_type_heaps}, cs) + # (cons_def, ts_cons_defs) = ts_cons_defs![ds_index] + # (exi_vars, (ti_type_heaps, cs)) + = addExistentionalTypeVariablesToSymbolTable cti_lhs_attribute cons_def.cons_exi_vars ti_type_heaps cs + (st_args, cons_arg_vars, st_attr_env, (ts, ti, cs)) + = bind_types_of_cons cons_def.cons_type.st_args cti free_vars [] + ({ ts & ts_cons_defs = ts_cons_defs }, { ti & ti_type_heaps = ti_type_heaps }, cs) + cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cGlobalScope /* cOuterMostLevel */ exi_vars cs.cs_symbol_table + (ts, ti, cs) = bind_types_of_constructors cti (inc cons_index) free_vars free_attrs type_lhs conses + (ts, ti, { cs & cs_symbol_table = cs_symbol_table }) + cons_type = { cons_def.cons_type & st_vars = free_vars, st_args = st_args, st_result = type_lhs, st_attr_vars = free_attrs, st_attr_env = st_attr_env } + (new_type_ptr, ti_var_heap) = newPtr VI_Empty ti.ti_var_heap + = ({ ts & ts_cons_defs = { ts.ts_cons_defs & [ds_index] = + { cons_def & cons_type = cons_type, cons_index = cons_index, cons_type_index = cti.cti_type_index, cons_exi_vars = exi_vars, + cons_type_ptr = new_type_ptr, cons_arg_vars = cons_arg_vars }}}, { ti & ti_var_heap = ti_var_heap }, cs) where - simplify_type_appl :: !Ident !Type ![AType] !*ErrorAdmin -> (!Type, *ErrorAdmin) - simplify_type_appl cv (TA type_cons=:{type_arity} cons_args) type_args error - = (TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args), error) - simplify_type_appl cv (TV tv) type_args error - = (CV tv :@: type_args, error) - simplify_type_appl cv TE t2 error - = (TE, error) - simplify_type_appl cv t1 t2 error - = (TE, checkError cv "kind conflict in argument of type synonym" error) -*/ - - -class look_for_cycles a :: !Index !a !*ExpandState -> *ExpandState - -instance look_for_cycles Type -where - look_for_cycles module_index type=:(TA type_cons=:{type_name,type_index={glob_object,glob_module}} types) expst=:{exp_marks,exp_error} - | module_index == glob_module - #! mark = exp_marks.[glob_object] - | mark == CS_NotChecked - # expst = expandSynType module_index glob_object expst - = look_for_cycles module_index types expst - | mark == CS_Checked - = look_for_cycles module_index types expst - = { expst & exp_error = checkError type_name "cyclic dependency between type synonyms" exp_error } - = look_for_cycles module_index types expst - look_for_cycles module_index (arg_type --> res_type) expst - = look_for_cycles module_index res_type (look_for_cycles module_index arg_type expst) -//AA.. - look_for_cycles module_index (TArrow1 arg_type) expst - = look_for_cycles module_index arg_type expst -//..AA - look_for_cycles module_index (type :@: types) expst - = look_for_cycles module_index types expst - look_for_cycles module_index type expst - = expst + bind_types_of_cons :: ![AType] !CurrentTypeInfo ![TypeVar] ![AttrInequality] !(!*TypeSymbols, !*TypeInfo, !*CheckState) + -> !(![AType], ![[ATypeVar]], ![AttrInequality], !(!*TypeSymbols, !*TypeInfo, !*CheckState)) + bind_types_of_cons [] cti free_vars attr_env ts_ti_cs + = ([], [], attr_env, ts_ti_cs) + bind_types_of_cons [type : types] cti free_vars attr_env ts_ti_cs + # (types, local_vars_list, attr_env, ts_ti_cs) + = bind_types_of_cons types cti free_vars attr_env ts_ti_cs + (type, type_attr, (ts, ti, cs)) = bindTypes cti type ts_ti_cs + (local_vars, cs_symbol_table) = foldSt retrieve_local_vars free_vars ([], cs.cs_symbol_table) + (attr_env, cs_error) = addToAttributeEnviron type_attr cti.cti_lhs_attribute attr_env cs.cs_error + = ([type : types], [local_vars : local_vars_list], attr_env, (ts, ti , { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })) + where + retrieve_local_vars tv=:{tv_name={id_info}} (local_vars, symbol_table) + # (ste=:{ste_kind = STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count }}, symbol_table) = readPtr id_info symbol_table + | stv_count == 0 + = (local_vars, symbol_table) + + = ([{ atv_variable = { tv & tv_info_ptr = stv_info_ptr}, atv_attribute = stv_attribute, atv_annotation = AN_None } : local_vars], + symbol_table <:= (id_info, { ste & ste_kind = STE_BoundTypeVariable { bv & stv_count = 0}})) + + retrieve_used_types symb_ptrs symbol_table + = foldSt retrieve_used_type symb_ptrs ([], symbol_table) + where + retrieve_used_type symb_ptr (used_types, symbol_table) + # (ste=:{ste_kind=STE_UsedType decl_index orig_kind,ste_index}, symbol_table) = readPtr symb_ptr symbol_table + = ([{gi_module = decl_index, gi_index = ste_index} : used_types], symbol_table <:= (symb_ptr, { ste & ste_kind = orig_kind })) -instance look_for_cycles [a] | look_for_cycles a -where - look_for_cycles mod_index l expst - = foldr (look_for_cycles mod_index) expst l - -instance look_for_cycles AType -where - look_for_cycles mod_index {at_type} expst - = look_for_cycles mod_index at_type expst - -import StdDebug - -expandSynType :: !Index !Index !*ExpandState -> *ExpandState -expandSynType mod_index type_index expst=:{exp_type_defs} - # (type_def, exp_type_defs) = exp_type_defs![type_index] - expst = { expst & exp_type_defs = exp_type_defs } - = case type_def.td_rhs of - SynType type=:{at_type = TA {type_name,type_index={glob_object,glob_module}} types} - # ({td_args,td_attribute,td_rhs}, _, exp_type_defs, exp_modules) = getTypeDef glob_object glob_module mod_index expst.exp_type_defs expst.exp_modules - expst = { expst & exp_type_defs = exp_type_defs, exp_modules = exp_modules } - -> case td_rhs of - SynType rhs_type - # exp_type_heaps = bindTypeVarsAndAttributes td_attribute type_def.td_attribute td_args types expst.exp_type_heaps - position = newPosition type_def.td_name type_def.td_pos - exp_error = pushErrorAdmin position expst.exp_error - exp_marks = { expst.exp_marks & [type_index] = CS_Checking } - (exp_type, expst) = expand mod_index rhs_type.at_type { expst & exp_marks = exp_marks, - exp_error = exp_error, exp_type_heaps = exp_type_heaps } - -> {expst & exp_type_defs = { expst.exp_type_defs & [type_index] = { type_def & td_rhs = SynType { type & at_type = exp_type }}}, - exp_marks = { expst.exp_marks & [type_index] = CS_Checked }, - exp_type_heaps = clearBindingsOfTypeVarsAndAttributes td_attribute td_args expst.exp_type_heaps, - exp_error = popErrorAdmin expst.exp_error } -// ---> ("SynType", rhs_type, exp_type) +CS_Checked :== 1 +CS_Checking :== 0 - _ - # exp_marks = { expst.exp_marks & [type_index] = CS_Checking } - position = newPosition type_def.td_name type_def.td_pos - expst = look_for_cycles mod_index types { expst & exp_marks = exp_marks, exp_error = pushErrorAdmin position expst.exp_error } - -> { expst & exp_marks = { expst.exp_marks & [type_index] = CS_Checked }, exp_error = popErrorAdmin expst.exp_error } - _ - -> { expst & exp_marks = { expst.exp_marks & [type_index] = CS_Checked }} checkTypeDefs :: !Bool !*{# CheckedTypeDef} !Index !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*VarHeap !*TypeHeaps !*CheckState -> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState) checkTypeDefs is_main_dcl type_defs module_index cons_defs selector_defs modules var_heap type_heaps cs #! nr_of_types = size type_defs # ts = { ts_type_defs = type_defs, ts_cons_defs = cons_defs, ts_selector_defs = selector_defs, ts_modules = modules } - ti = { ti_type_heaps = type_heaps, ti_var_heap = var_heap } + ti = { ti_type_heaps = type_heaps, ti_var_heap = var_heap, ti_used_types = [] } = check_type_defs is_main_dcl 0 nr_of_types module_index ts ti cs where check_type_defs is_main_dcl type_index nr_of_types module_index ts ti=:{ti_type_heaps,ti_var_heap} cs @@ -477,48 +329,6 @@ where # (ts, ti, cs) = checkTypeDef type_index module_index ts ti cs = check_type_defs is_main_dcl (inc type_index) nr_of_types module_index ts ti cs -/* -Tracea_tn a - # s=size a - # f=stderr - # r=t 0 f - with - t i f - | i<s && file_to_true (stderr <<< i <<< '\n' <<< a.[i] <<< '\n') - = t (i+1) f - = True - = r - -file_to_true :: !File -> Bool; -file_to_true file = code { - .inline file_to_true - pop_b 2 - pushB TRUE - .end - } -*/ - -expandSynonymTypes :: !.Index !*{#CheckedTypeDef} !*{#.DclModule} !*TypeHeaps !*ErrorAdmin - -> (!.{#CheckedTypeDef},!.{#DclModule},!.TypeHeaps,!.ErrorAdmin) -expandSynonymTypes module_index exp_type_defs exp_modules exp_type_heaps exp_error - #! nr_of_types - = size exp_type_defs - # marks - = createArray nr_of_types CS_NotChecked - {exp_type_defs,exp_modules,exp_type_heaps,exp_error} - = expand_syn_types module_index 0 nr_of_types - { exp_type_defs = exp_type_defs, exp_modules = exp_modules, exp_marks = marks, - exp_type_heaps = exp_type_heaps, exp_error = exp_error } - = (exp_type_defs,exp_modules,exp_type_heaps,exp_error) -where - expand_syn_types module_index type_index nr_of_types expst - | type_index == nr_of_types - = expst - | expst.exp_marks.[type_index] == CS_NotChecked - # expst = expandSynType module_index type_index expst - = expand_syn_types module_index (inc type_index) nr_of_types expst - = expand_syn_types module_index (inc type_index) nr_of_types expst - :: OpenTypeInfo = { oti_heaps :: !.TypeHeaps , oti_all_vars :: ![TypeVar] @@ -1355,12 +1165,14 @@ createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index ! -> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*CheckState) createClassDictionaries mod_index class_defs modules first_type_index first_selector_index first_cons_index type_var_heap var_heap cs | cs.cs_error.ea_ok + # (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) = create_class_dictionaries mod_index 0 class_defs modules [] { index_type = first_type_index, index_cons= first_cons_index, index_selector = first_selector_index } type_var_heap var_heap cs (type_defs, sel_defs, cons_defs, cs_symbol_table) = foldSt collect_type_def rev_dictionary_list ([], [], [], cs.cs_symbol_table) = (class_defs, modules, type_defs, sel_defs, cons_defs, type_var_heap, var_heap, {cs & cs_symbol_table = cs_symbol_table }) = (class_defs, modules, [], [], [], type_var_heap, var_heap, cs) where + collect_type_def type_ptr (type_defs, sel_defs, cons_defs, symbol_table) # ({ ste_kind = STE_DictType type_def }, symbol_table) = readPtr type_ptr symbol_table (RecordType {rt_constructor, rt_fields}) = type_def.td_rhs @@ -1429,9 +1241,7 @@ where , td_rhs = RecordType {rt_constructor = cons_symbol, rt_fields = { field \\ field <- reverse rev_fields }} , td_attribute = TA_None , td_pos = NoPos -// , td_kinds = [] -// , td_properties = cAllBitsClear -// , td_info = EmptyTypeDefInfo + , td_used_types = [] } cons_def = @@ -1442,7 +1252,6 @@ where , cons_index = 0 , cons_type_index = index_type , cons_exi_vars = [] -// , cons_exi_attrs = [] , cons_arg_vars = [] , cons_type_ptr = cons_type_ptr , cons_pos = NoPos @@ -1514,33 +1323,6 @@ where = (field, var_heap, symbol_table <:= (id_info, { ste_kind = STE_DictField sel_def, ste_index = selector_index, ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" })) -bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps; -bindTypeVarsAndAttributes form_root_attribute act_root_attribute form_type_args act_type_args type_heaps - # th_attrs = bind_attribute form_root_attribute act_root_attribute type_heaps.th_attrs - = fold2St bind_type_and_attr form_type_args act_type_args { type_heaps & th_attrs = th_attrs } -where - bind_type_and_attr {atv_attribute, atv_variable={tv_info_ptr}} {at_type,at_attribute} type_heaps=:{th_vars,th_attrs} - = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), - th_attrs = bind_attribute atv_attribute at_attribute th_attrs } - - bind_attribute (TA_Var {av_info_ptr}) attr th_attrs - = th_attrs <:= (av_info_ptr, AVI_Attr attr) - bind_attribute _ _ th_attrs - = th_attrs - -clearBindingsOfTypeVarsAndAttributes :: !TypeAttribute ![ATypeVar] !*TypeHeaps -> *TypeHeaps; -clearBindingsOfTypeVarsAndAttributes form_root_attribute form_type_args type_heaps - # th_attrs = clear_attribute form_root_attribute type_heaps.th_attrs - = foldSt clear_type_and_attr form_type_args { type_heaps & th_attrs = th_attrs } -where - clear_type_and_attr {atv_attribute, atv_variable={tv_info_ptr}} type_heaps=:{th_vars,th_attrs} - = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Empty), th_attrs = clear_attribute atv_attribute th_attrs } - - clear_attribute (TA_Var {av_info_ptr}) th_attrs - = th_attrs <:= (av_info_ptr, AVI_Empty) - clear_attribute _ th_attrs - = th_attrs - class toVariable var :: !STE_Kind !Ident -> var instance toVariable TypeVar diff --git a/frontend/comparedefimp.dcl b/frontend/comparedefimp.dcl index be5210b..b371c14 100644 --- a/frontend/comparedefimp.dcl +++ b/frontend/comparedefimp.dcl @@ -4,7 +4,7 @@ import syntax, checksupport // compare definition and implementation module -compareDefImp :: !{#Int} !{!FunctionBody} !Int !{#CheckedTypeDef} !DclModule !*IclModule !*Heaps !*ErrorAdmin +compareDefImp :: !{#Int} !{!FunctionBody} !Int !DclModule !*IclModule !*Heaps !*ErrorAdmin -> (!.IclModule,!.Heaps,!.ErrorAdmin) symbolTypesCorrespond :: !SymbolType !SymbolType !*TypeHeaps -> (!ComparisionErrorCode, !.TypeHeaps) diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index 48f324e..2959e4e 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -2,6 +2,321 @@ implementation module comparedefimp import syntax, checksupport, compare_constructor, utilities, StdCompare, compilerSwitches +:: CompareState = + { comp_type_var_heap :: !.TypeVarHeap + , comp_attr_var_heap :: !.AttrVarHeap + , comp_error :: !.ErrorAdmin + } + +type_def_error = "type definition in the impl module conflicts with the def module" +class_def_error = "class definition in the impl module conflicts with the def module" +instance_def_error = "instance definition in the impl module conflicts with the def module" + +compareError message pos error_admin + = popErrorAdmin (checkError "" message (pushErrorAdmin pos error_admin)) + +markCheckedDefinitions :: !Int ![Index] -> *{# Bool} +markCheckedDefinitions nr_of_defs not_to_be_checked + # marks = createArray nr_of_defs True + = foldSt mark_def not_to_be_checked marks +where + mark_def index marks = { marks & [index] = False } + +compareTypeDefs :: !{# Int} ![Index] !{# CheckedTypeDef} !{# ConsDef} !u:{# CheckedTypeDef} !v:{# ConsDef} !*CompareState + -> (!u:{# CheckedTypeDef}, !v:{# ConsDef}, !*CompareState) +compareTypeDefs dcl_sizes copied_from_dcl dcl_type_defs dcl_cons_defs icl_type_defs icl_cons_defs comp_st + # nr_of_dcl_types = dcl_sizes.[cTypeDefs] + to_be_checked = markCheckedDefinitions nr_of_dcl_types copied_from_dcl + = iFoldSt (compare_type_defs to_be_checked dcl_type_defs dcl_cons_defs) 0 nr_of_dcl_types (icl_type_defs, icl_cons_defs, comp_st) +where + compare_type_defs :: !{# Bool} !{# CheckedTypeDef} !{# ConsDef} !Index (!u:{# CheckedTypeDef}, !v:{# ConsDef}, !*CompareState) + -> (!u:{# CheckedTypeDef}, !v:{# ConsDef}, !*CompareState) + compare_type_defs to_be_checked dcl_type_defs dcl_cons_defs type_index (icl_type_defs, icl_cons_defs, comp_st=:{comp_type_var_heap,comp_attr_var_heap}) + | to_be_checked.[type_index] + # dcl_type_def = dcl_type_defs.[type_index] + (icl_type_def, icl_type_defs) = icl_type_defs![type_index] + comp_type_var_heap = initialyseATypeVars dcl_type_def.td_args comp_type_var_heap + comp_type_var_heap = initialyseATypeVars icl_type_def.td_args comp_type_var_heap + comp_attr_var_heap = initialyseAttributeVars dcl_type_def.td_attrs comp_attr_var_heap + comp_attr_var_heap = initialyseAttributeVars icl_type_def.td_attrs comp_attr_var_heap + comp_st = { comp_st & comp_type_var_heap = comp_type_var_heap, comp_attr_var_heap = comp_attr_var_heap } + (ok, icl_cons_defs, comp_st) = compare_rhs_of_types dcl_type_def.td_rhs icl_type_def.td_rhs dcl_cons_defs icl_cons_defs comp_st + | ok + = (icl_type_defs, icl_cons_defs, comp_st) + # comp_error = compareError type_def_error (newPosition icl_type_def.td_name icl_type_def.td_pos) comp_st.comp_error + = (icl_type_defs, icl_cons_defs, { comp_st & comp_error = comp_error }) +// ---> ("compare_type_defs", dcl_type_def.td_name, dcl_type_def.td_rhs, icl_type_def.td_name, icl_type_def.td_rhs) + = (icl_type_defs, icl_cons_defs, comp_st) + + compare_rhs_of_types (AlgType dclConstructors) (AlgType iclConstructors) dcl_cons_defs icl_cons_defs comp_st + = compare_constructor_lists dclConstructors iclConstructors dcl_cons_defs icl_cons_defs comp_st + where + compare_constructor_lists [ dcl_cons : dcl_conses ][icl_cons : icl_conses] dcl_cons_defs icl_cons_defs comp_st + | dcl_cons.ds_index == icl_cons.ds_index + # last_cons = isEmpty dcl_conses + # (ok, icl_cons_defs, comp_st) = compare_constructors last_cons dcl_cons.ds_index dcl_cons_defs icl_cons_defs comp_st + | ok + | last_cons + = (isEmpty icl_conses, icl_cons_defs, comp_st) + = compare_constructor_lists dcl_conses icl_conses dcl_cons_defs icl_cons_defs comp_st + = (False, icl_cons_defs, comp_st) + = (False, icl_cons_defs, comp_st) + + compare_rhs_of_types (SynType dclType) (SynType iclType) dcl_cons_defs icl_cons_defs comp_st + # (ok, comp_st) = compare dclType iclType comp_st + = (ok, icl_cons_defs, comp_st) + compare_rhs_of_types (RecordType dclRecord) (RecordType iclRecord) dcl_cons_defs icl_cons_defs comp_st + = compare_records dclRecord iclRecord dcl_cons_defs icl_cons_defs comp_st + where + compare_records dcl_rec icl_rec dcl_cons_defs icl_cons_defs comp_st + # nr_of_dcl_fields = size dcl_rec.rt_fields + | nr_of_dcl_fields == size icl_rec.rt_fields && compare_fields nr_of_dcl_fields dcl_rec.rt_fields icl_rec.rt_fields + = compare_constructors True dcl_rec.rt_constructor.ds_index dcl_cons_defs icl_cons_defs comp_st + = (False, icl_cons_defs, comp_st) + + compare_fields field_nr dcl_fields icl_fields + | field_nr == 0 + = True + # field_nr = dec field_nr + = dcl_fields.[field_nr].fs_index == icl_fields.[field_nr].fs_index && compare_fields field_nr dcl_fields icl_fields + + compare_rhs_of_types (AbstractType _) icl_type dcl_cons_defs icl_cons_defs comp_st + = (True, icl_cons_defs, comp_st) + compare_rhs_of_types dcl_type icl_type dcl_cons_defs icl_cons_defs comp_st + = (False, icl_cons_defs, comp_st) + + compare_constructors do_compare_result_types cons_index dcl_cons_defs icl_cons_defs comp_st=:{comp_type_var_heap} + # dcl_cons_def = dcl_cons_defs.[cons_index] + (icl_cons_def, icl_cons_defs) = icl_cons_defs![cons_index] + dcl_cons_type = dcl_cons_def.cons_type + icl_cons_type = icl_cons_def.cons_type + comp_type_var_heap = initialyseATypeVars dcl_cons_def.cons_exi_vars comp_type_var_heap + comp_type_var_heap = initialyseATypeVars icl_cons_def.cons_exi_vars comp_type_var_heap + comp_st = { comp_st & comp_type_var_heap = comp_type_var_heap } + (ok, comp_st) = compare dcl_cons_type.st_args icl_cons_type.st_args comp_st + | dcl_cons_def.cons_priority == icl_cons_def.cons_priority + | ok && do_compare_result_types + # (ok, comp_st) = compare dcl_cons_type.st_result icl_cons_type.st_result comp_st + = (ok, icl_cons_defs, comp_st) + = (ok, icl_cons_defs, comp_st) + = (False, icl_cons_defs, comp_st) + + +compareClassDefs :: !{# Int} ![Index] !{# ClassDef} !{# MemberDef} !u:{# ClassDef} !v:{# MemberDef} !*CompareState + -> (!u:{# ClassDef}, !v:{# MemberDef}, !*CompareState) +compareClassDefs dcl_sizes copied_from_dcl dcl_class_defs dcl_member_defs icl_class_defs icl_member_defs comp_st + # nr_of_dcl_classes = dcl_sizes.[cClassDefs] + to_be_checked = markCheckedDefinitions nr_of_dcl_classes copied_from_dcl + = iFoldSt (compare_class_defs to_be_checked dcl_class_defs dcl_member_defs) 0 nr_of_dcl_classes (icl_class_defs, icl_member_defs, comp_st) +where + compare_class_defs :: !{# Bool} {# ClassDef} {# MemberDef} !Index (!u:{# ClassDef}, !v:{# MemberDef}, !*CompareState) + -> (!u:{# ClassDef}, v:{# MemberDef}, !*CompareState) + compare_class_defs to_be_checked dcl_class_defs dcl_member_defs class_index (icl_class_defs, icl_member_defs, comp_st) + | to_be_checked.[class_index] + # dcl_class_def = dcl_class_defs.[class_index] + (icl_class_def, icl_class_defs) = icl_class_defs![class_index] + # (ok, icl_member_defs, comp_st) = compare_classes dcl_class_def dcl_member_defs icl_class_def icl_member_defs comp_st + | ok // ---> ("compare_class_defs", dcl_class_def.class_name, icl_class_def.class_name) + = (icl_class_defs, icl_member_defs, comp_st) + # comp_error = compareError class_def_error (newPosition icl_class_def.class_name icl_class_def.class_pos) comp_st.comp_error + = (icl_class_defs, icl_member_defs, { comp_st & comp_error = comp_error }) + = (icl_class_defs, icl_member_defs, comp_st) + + compare_classes dcl_class_def dcl_member_defs icl_class_def icl_member_defs comp_st=:{comp_type_var_heap} + # comp_type_var_heap = initialyseTypeVars dcl_class_def.class_args comp_type_var_heap + comp_type_var_heap = initialyseTypeVars icl_class_def.class_args comp_type_var_heap + comp_st = { comp_st & comp_type_var_heap = comp_type_var_heap } + # (ok, comp_st) = compare dcl_class_def.class_context icl_class_def.class_context comp_st + | ok + # nr_of_dcl_members = size dcl_class_def.class_members + | nr_of_dcl_members == size icl_class_def.class_members + = compare_array_of_class_members nr_of_dcl_members dcl_class_def.class_members icl_class_def.class_members dcl_member_defs icl_member_defs comp_st + = (False, icl_member_defs, comp_st) + = (False, icl_member_defs, comp_st) + + compare_array_of_class_members loc_member_index dcl_members icl_members dcl_member_defs icl_member_defs comp_st + | loc_member_index == 0 + = (True, icl_member_defs, comp_st) + # loc_member_index = dec loc_member_index + # dcl_member = dcl_members.[loc_member_index] + # icl_member = icl_members.[loc_member_index] + | dcl_member == icl_member + # glob_member_index = dcl_member.ds_index + # dcl_member_def = dcl_member_defs.[glob_member_index] + (icl_member_def, icl_member_defs) = icl_member_defs![glob_member_index] + (ok, comp_st) = compare dcl_member_def.me_type icl_member_def.me_type comp_st + | ok && dcl_member_def.me_priority == icl_member_def.me_priority + = compare_array_of_class_members loc_member_index dcl_members icl_members dcl_member_defs icl_member_defs comp_st + = (False, icl_member_defs, comp_st) + = (False, icl_member_defs, comp_st) + +compareInstanceDefs :: !{# Int} !{# ClassInstance} !u:{# ClassInstance} !*CompareState -> (!u:{# ClassInstance}, !*CompareState) +compareInstanceDefs dcl_sizes dcl_instance_defs icl_instance_defs comp_st + # nr_of_dcl_instances = dcl_sizes.[cInstanceDefs] + = iFoldSt (compare_instance_defs dcl_instance_defs) 0 nr_of_dcl_instances (icl_instance_defs, comp_st) +where + compare_instance_defs :: !{# ClassInstance} !Index (!u:{# ClassInstance}, !*CompareState) -> (!u:{# ClassInstance}, !*CompareState) + compare_instance_defs dcl_instance_defs instance_index (icl_instance_defs, comp_st) + # dcl_instance_def = dcl_instance_defs.[instance_index] + (icl_instance_def, icl_instance_defs) = icl_instance_defs![instance_index] + (ok, comp_st) = compare dcl_instance_def.ins_type icl_instance_def.ins_type comp_st + | ok + = (icl_instance_defs, comp_st) + # comp_error = compareError instance_def_error (newPosition icl_instance_def.ins_ident icl_instance_def.ins_pos) comp_st.comp_error + = (icl_instance_defs, { comp_st & comp_error = comp_error }) +// ---> ("compare_instance_defs", dcl_instance_def.ins_ident, dcl_instance_def.ins_type, icl_instance_def.ins_ident, icl_instance_def.ins_type) + + +class compare a :: !a !a !*CompareState -> (!Bool, !*CompareState) + + +instance compare (a,b) | compare a & compare b +where + compare (x1, y1) (x2, y2) comp_st + # (ok, comp_st) = compare x1 x2 comp_st + | ok + = compare y1 y2 comp_st + = (False, comp_st) + +instance compare (Global a) | == a +where + compare g1 g2 comp_st + = (g1.glob_module == g2.glob_module && g1.glob_object == g2.glob_object, comp_st) + +instance compare [a] | compare a +where + compare [x:xs] [y:ys] comp_st + = compare (x, xs) (y, ys) comp_st + compare [] [] comp_st + = (True, comp_st) + compare _ _ comp_st + = (False, comp_st) + +instance compare Type +where + compare (TA dclIdent dclArgs) (TA iclIdent iclArgs) comp_st + = compare (dclIdent.type_index, dclArgs) (iclIdent.type_index, iclArgs) comp_st + compare (dclFun --> dclArg) (iclFun --> iclArg) comp_st + = compare (dclFun, dclArg) (iclFun, iclArg) comp_st + compare (CV dclVar :@: dclArgs) (CV iclVar :@: iclArgs) comp_st + = compare (dclVar, dclArgs) (iclVar, iclArgs) comp_st + compare (TB dclDef) (TB iclDef) comp_st + = (dclDef == iclDef, comp_st) + compare (GTV dclDef) (GTV iclDef) comp_st + = compare dclDef iclDef comp_st + compare (TV dclVar) (TV iclVar) comp_st + = compare dclVar iclVar comp_st + compare _ _ comp_st + = (False, comp_st) + +instance compare AType +where + compare at1 at2 comp_st + = compare (at1.at_attribute, (at1.at_annotation, at1.at_type)) (at2.at_attribute, (at2.at_annotation, at2.at_type)) comp_st + +instance compare TypeAttribute +where + compare ta1 ta2 comp_st + | equal_constructor ta1 ta2 + = compare_equal_constructor ta1 ta2 comp_st + = (False, comp_st) + where + compare_equal_constructor (TA_Var dclDef) (TA_Var iclDef) comp_st + = compare dclDef iclDef comp_st + compare_equal_constructor (TA_RootVar dclDef) (TA_RootVar iclDef) comp_st + = compare dclDef iclDef comp_st + compare_equal_constructor _ _ comp_st + = (True, comp_st) + +instance compare Annotation +where + compare an1 an2 comp_st + = (equal_constructor an1 an2, comp_st) + +instance compare AttributeVar +where + compare {av_info_ptr = dcl_info_ptr} {av_info_ptr = icl_info_ptr} comp_st=:{comp_attr_var_heap} + # (dcl_info, comp_attr_var_heap) = readPtr dcl_info_ptr comp_attr_var_heap + (icl_info, comp_attr_var_heap) = readPtr icl_info_ptr comp_attr_var_heap + (ok, comp_attr_var_heap) = compare_vars dcl_info icl_info dcl_info_ptr icl_info_ptr comp_attr_var_heap + = (ok, { comp_st & comp_attr_var_heap = comp_attr_var_heap }) + where + compare_vars AVI_Empty AVI_Empty dcl_av_info_ptr icl_av_info_ptr comp_attr_var_heap + = (True, comp_attr_var_heap <:= (dcl_av_info_ptr, AVI_AttrVar icl_av_info_ptr) <:= (icl_av_info_ptr, AVI_AttrVar dcl_av_info_ptr)) + compare_vars (AVI_AttrVar dcl_forward) (AVI_AttrVar icl_forward) dcl_av_info_ptr icl_av_info_ptr comp_attr_var_heap + = (dcl_forward == icl_av_info_ptr && icl_forward == dcl_av_info_ptr, comp_attr_var_heap) + compare_vars dcl_info icl_info dcl_av_info_ptr icl_av_info_ptr comp_attr_var_heap + = (True, comp_attr_var_heap) + +instance compare TypeVar +where + compare {tv_info_ptr = dcl_info_ptr} {tv_info_ptr = icl_info_ptr} comp_st=:{comp_type_var_heap} + # (dcl_info, comp_type_var_heap) = readPtr dcl_info_ptr comp_type_var_heap + (icl_info, comp_type_var_heap) = readPtr icl_info_ptr comp_type_var_heap + (ok, comp_type_var_heap) = compare_vars dcl_info icl_info dcl_info_ptr icl_info_ptr comp_type_var_heap + = (ok, { comp_st & comp_type_var_heap = comp_type_var_heap }) + where + compare_vars TVI_Empty TVI_Empty dcl_tv_info_ptr icl_tv_info_ptr type_var_heap + = (True, type_var_heap <:= (dcl_tv_info_ptr, TVI_TypeVar icl_tv_info_ptr) <:= (icl_tv_info_ptr, TVI_TypeVar dcl_tv_info_ptr)) + compare_vars (TVI_TypeVar dcl_forward) (TVI_TypeVar icl_forward) dcl_tv_info_ptr icl_tv_info_ptr type_var_heap + = (dcl_forward == icl_tv_info_ptr && icl_forward == dcl_tv_info_ptr, type_var_heap) + compare_vars dcl_info icl_info dcl_tv_info_ptr icl_tv_info_ptr type_var_heap + = (True, type_var_heap) + +instance compare AttrInequality +where + compare dcl_ineq icl_ineq comp_st + = compare (dcl_ineq.ai_demanded, dcl_ineq.ai_offered) (icl_ineq.ai_demanded, icl_ineq.ai_offered) comp_st + +instance compare SymbolType +where + compare dcl_st icl_st comp_st=:{comp_type_var_heap,comp_attr_var_heap} + # comp_type_var_heap = initialyseTypeVars dcl_st.st_vars comp_type_var_heap + comp_type_var_heap = initialyseTypeVars icl_st.st_vars comp_type_var_heap + comp_attr_var_heap = initialyseAttributeVars dcl_st.st_attr_vars comp_attr_var_heap + comp_attr_var_heap = initialyseAttributeVars icl_st.st_attr_vars comp_attr_var_heap + comp_st = { comp_st & comp_type_var_heap = comp_type_var_heap, comp_attr_var_heap = comp_attr_var_heap } + = compare (dcl_st.st_args, (dcl_st.st_result, (dcl_st.st_context, dcl_st.st_attr_env))) + (icl_st.st_args, (icl_st.st_result, (icl_st.st_context, icl_st.st_attr_env))) comp_st +// ---> ("compare SymbolType", dcl_st, icl_st) + +instance compare InstanceType +where + compare dcl_it icl_it comp_st=:{comp_type_var_heap,comp_attr_var_heap} + # comp_type_var_heap = initialyseTypeVars dcl_it.it_vars comp_type_var_heap + comp_type_var_heap = initialyseTypeVars icl_it.it_vars comp_type_var_heap + comp_attr_var_heap = initialyseAttributeVars dcl_it.it_attr_vars comp_attr_var_heap + comp_attr_var_heap = initialyseAttributeVars icl_it.it_attr_vars comp_attr_var_heap + comp_st = { comp_st & comp_type_var_heap = comp_type_var_heap, comp_attr_var_heap = comp_attr_var_heap } + = compare (dcl_it.it_types, dcl_it.it_context) (icl_it.it_types, icl_it.it_context) comp_st +// ---> ("compare InstanceType", dcl_it, icl_it) + +instance compare TypeContext +where + compare dcl_tc icl_tc comp_st + | dcl_tc.tc_class == icl_tc.tc_class + = compare dcl_tc.tc_types icl_tc.tc_types comp_st + = (False, comp_st) + + +initialyseTypeVars type_vars type_var_heap + = foldSt init_type_var type_vars type_var_heap +where + init_type_var {tv_info_ptr} type_var_heap + = type_var_heap <:= (tv_info_ptr, TVI_Empty) + +initialyseATypeVars atype_vars type_var_heap + = foldSt init_atype_var atype_vars type_var_heap +where + init_atype_var {atv_variable={tv_info_ptr}} type_var_heap + = type_var_heap <:= (tv_info_ptr, TVI_Empty) + +initialyseAttributeVars attr_vars attr_var_heap + = foldSt init_attr_var attr_vars attr_var_heap +where + init_attr_var {av_info_ptr} attr_var_heap + = attr_var_heap <:= (av_info_ptr, AVI_Empty) + :: TypesCorrespondState = { tc_type_vars :: !.HeapWithNumber TypeVarInfo @@ -72,39 +387,46 @@ class CorrespondenceNumber a where initial_hwn hwn_heap = { hwn_heap = hwn_heap, hwn_number = 0 } -compareDefImp :: !{#Int} !{!FunctionBody} !Int !{#CheckedTypeDef} !DclModule !*IclModule !*Heaps !*ErrorAdmin +compareDefImp :: !{#Int} !{!FunctionBody} !Int !DclModule !*IclModule !*Heaps !*ErrorAdmin -> (!.IclModule,!.Heaps,!.ErrorAdmin) -compareDefImp size_uncopied_icl_defs untransformed main_dcl_module_n icl_com_type_defs main_dcl_module +compareDefImp size_uncopied_icl_defs untransformed main_dcl_module_n main_dcl_module icl_module heaps error_admin - -// | print_function_body_array untransformed -// && print_function_body_array icl_module.icl_functions - - - // icl definitions with indices >= size_uncopied_icl_defs.[def_type] don't have to be compared, - // because they are copies of definitions that appear exclusively in the dcl module = case main_dcl_module.dcl_conversions of No -> (icl_module, heaps, error_admin) Yes conversion_table # {dcl_functions, dcl_macros, dcl_common} = main_dcl_module - {icl_common, icl_functions} + {icl_common, icl_functions, icl_copied_from_dcl = {copied_type_defs,copied_class_defs}} = icl_module {hp_var_heap, hp_expression_heap, hp_type_heaps={th_vars, th_attrs}} = heaps - { com_cons_defs=icl_com_cons_defs, - com_selector_defs=icl_com_selector_defs, com_class_defs=icl_com_class_defs, + { com_cons_defs=icl_com_cons_defs, com_type_defs = icl_com_type_defs, + com_selector_defs=icl_com_selector_defs, com_class_defs = icl_com_class_defs, com_member_defs=icl_com_member_defs, com_instance_defs = icl_com_instance_defs } = icl_common - tc_state - = { tc_type_vars = initial_hwn th_vars - , tc_attr_vars = initial_hwn th_attrs - , tc_ignore_strictness = False - } - (_, tc_state, error_admin) + comp_st + = { comp_type_var_heap = th_vars + , comp_attr_var_heap = th_attrs + , comp_error = error_admin + } + + (icl_com_type_defs, icl_com_cons_defs, comp_st) + = compareTypeDefs main_dcl_module.dcl_sizes copied_type_defs dcl_common.com_type_defs dcl_common.com_cons_defs + icl_com_type_defs icl_com_cons_defs comp_st + (icl_com_class_defs, icl_com_member_defs, comp_st) + = compareClassDefs main_dcl_module.dcl_sizes copied_class_defs dcl_common.com_class_defs dcl_common.com_member_defs + icl_com_class_defs icl_com_member_defs comp_st + + (icl_com_instance_defs, comp_st) + = compareInstanceDefs main_dcl_module.dcl_sizes dcl_common.com_instance_defs icl_com_instance_defs comp_st + + +/* + (icl_com_type_defs, tc_state, error_admin) = compareWithConversions size_uncopied_icl_defs.[cTypeDefs] conversion_table.[cTypeDefs] - dcl_common.com_unexpanded_type_defs icl_com_type_defs tc_state error_admin +// dcl_common.com_unexpanded_type_defs icl_com_type_defs tc_state error_admin + dcl_common.com_type_defs icl_com_type_defs tc_state error_admin (icl_com_cons_defs, tc_state, error_admin) = compareWithConversions size_uncopied_icl_defs.[cConstructorDefs] conversion_table.[cConstructorDefs] @@ -125,6 +447,15 @@ compareDefImp size_uncopied_icl_defs untransformed main_dcl_module_n icl_com_typ = compareWithConversions size_uncopied_icl_defs.[cInstanceDefs] conversion_table.[cInstanceDefs] dcl_common.com_instance_defs icl_com_instance_defs tc_state error_admin +*/ + + { comp_type_var_heap = th_vars, comp_attr_var_heap = th_attrs, comp_error = error_admin } = comp_st + + tc_state + = { tc_type_vars = initial_hwn th_vars + , tc_attr_vars = initial_hwn th_attrs + , tc_ignore_strictness = False + } (icl_functions, hp_var_heap, hp_expression_heap, tc_state, error_admin) = compareMacrosWithConversion main_dcl_module_n conversion_table.[cMacroDefs] conversion_table.[cFunctionDefs] @@ -136,7 +467,7 @@ compareDefImp size_uncopied_icl_defs untransformed main_dcl_module_n icl_com_typ { tc_type_vars, tc_attr_vars } = tc_state icl_common - = { icl_common & com_cons_defs=icl_com_cons_defs, + = { icl_common & com_cons_defs=icl_com_cons_defs, com_type_defs = icl_com_type_defs, com_selector_defs=icl_com_selector_defs, com_class_defs=icl_com_class_defs, com_member_defs=icl_com_member_defs, com_instance_defs = icl_com_instance_defs } heaps diff --git a/frontend/frontend.dcl b/frontend/frontend.dcl index 8fa0abc..c3c4261 100644 --- a/frontend/frontend.dcl +++ b/frontend/frontend.dcl @@ -13,13 +13,13 @@ import checksupport, transform, overloading } :: FrontEndSyntaxTree - = { fe_icl :: !IclModule - , fe_dcls :: !{#DclModule} - , fe_components :: !{!Group} - , fe_dclIclConversions ::!Optional {# Index} - , fe_iclDclConversions ::!Optional {# Index} - , fe_globalFunctions :: !IndexRange - , fe_arrayInstances :: !ArrayAndListInstances + = { fe_icl :: !IclModule + , fe_dcls :: !{#DclModule} + , fe_components :: !{!Group} + , fe_dclIclConversions :: !Optional {# Index} + , fe_iclDclConversions :: !Optional {# Index} + , fe_globalFunctions :: !IndexRange + , fe_arrayInstances :: !ArrayAndListInstances } :: FrontEndPhase @@ -31,4 +31,4 @@ import checksupport, transform, overloading | FrontEndPhaseAll frontEndInterface :: !FrontEndOptions !Ident !SearchPaths !{#DclModule} !{#FunDef} !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File (!Optional !*File) !*Heaps - -> ( !Optional *FrontEndSyntaxTree,!.{# FunDef },!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional !*File, !*Heaps) + -> ( !Optional *FrontEndSyntaxTree,!*{# FunDef },!{#DclModule},!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional !*File, !*Heaps) diff --git a/frontend/frontend.icl b/frontend/frontend.icl index eb412d2..c47db55 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -14,13 +14,13 @@ SwitchGenerics on off :== off } :: FrontEndSyntaxTree - = { fe_icl :: !IclModule - , fe_dcls :: !{#DclModule} - , fe_components :: !{!Group} - , fe_dclIclConversions ::!Optional {# Index} - , fe_iclDclConversions ::!Optional {# Index} - , fe_globalFunctions :: !IndexRange - , fe_arrayInstances :: !ArrayAndListInstances + = { fe_icl :: !IclModule + , fe_dcls :: !{#DclModule} + , fe_components :: !{!Group} + , fe_dclIclConversions :: !Optional {# Index} + , fe_iclDclConversions :: !Optional {# Index} + , fe_globalFunctions :: !IndexRange + , fe_arrayInstances :: !ArrayAndListInstances } // trace macro @@ -67,7 +67,7 @@ instance == FrontEndPhase where (==) a b = equal_constructor a b -frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions +frontSyntaxTree cached_functions_and_macros cached_dcl_mods n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps :== (Yes { fe_icl = {icl_mod & icl_functions=fun_defs } @@ -77,30 +77,31 @@ frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_module , fe_iclDclConversions = build_optional_icl_dcl_conversions (size fun_defs) optional_dcl_icl_conversions , fe_globalFunctions = global_fun_range , fe_arrayInstances = array_instances - },cached_functions_and_macros,n_functions_and_macros_in_dcl_modules,main_dcl_module_n,predef_symbols,hash_table,files,error,io,out,tcl_file,heaps + },cached_functions_and_macros,cached_dcl_mods,n_functions_and_macros_in_dcl_modules,main_dcl_module_n,predef_symbols,hash_table,files,error,io,out,tcl_file,heaps ) //import StdDebug frontEndInterface :: !FrontEndOptions !Ident !SearchPaths !{#DclModule} !{#FunDef} !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File (!Optional !*File) !*Heaps - -> ( !Optional *FrontEndSyntaxTree,!.{# FunDef },!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional !*File, !*Heaps) + -> ( !Optional *FrontEndSyntaxTree,!*{# FunDef },!{#DclModule},!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional !*File, !*Heaps) frontEndInterface options mod_ident search_paths cached_dcl_modules functions_and_macros list_inferred_types predef_symbols hash_table files error io out tcl_file heaps // # files = trace_n ("Compiling "+++mod_ident.id_name) files # (ok, mod, hash_table, error, predef_symbols, files) = wantModule cWantIclFile mod_ident NoPos options.feo_generics(hash_table /* ---> ("Parsing:", mod_ident)*/) error search_paths predef_symbols files | not ok - = (No,{},0,0,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) + = (No,{},{},0,0,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) # cached_module_idents = [dcl_mod.dcl_name \\ dcl_mod<-:cached_dcl_modules] + # (nr_of_chached_functions_and_macros, functions_and_macros) = usize functions_and_macros # (ok, mod, global_fun_range, mod_functions, optional_dcl_mod, modules, dcl_module_n_in_cache,n_functions_and_macros_in_dcl_modules,hash_table, error, predef_symbols, files) - = scanModule (mod -*-> "Scanning") cached_module_idents (size functions_and_macros) options.feo_generics hash_table error search_paths predef_symbols files + = scanModule (mod -*-> "Scanning") cached_module_idents nr_of_chached_functions_and_macros options.feo_generics hash_table error search_paths predef_symbols files /* JVG: */ // # hash_table = {hash_table & hte_entries={}} # hash_table = remove_icl_symbols_from_hash_table hash_table /**/ | not ok - = (No,{},0,0,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) + = (No,{},{},0,0,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) # symbol_table = hash_table.hte_symbol_heap #! n_cached_dcl_modules=size cached_dcl_modules # (ok, icl_mod, dcl_mods, components, optional_dcl_icl_conversions,cached_functions_and_macros,main_dcl_module_n,heaps, predef_symbols, symbol_table, error /* TD */, directly_imported_dcl_modules) @@ -108,14 +109,14 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an hash_table = { hash_table & hte_symbol_heap = symbol_table} | not ok - = (No,{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) + = (No,{},dcl_mods,0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) #! (icl_functions,icl_mod) = select_and_remove_icl_functions_from_record icl_mod with select_and_remove_icl_functions_from_record :: !*IclModule -> (!.{#FunDef},!.IclModule) select_and_remove_icl_functions_from_record icl_mod=:{icl_functions} = (icl_functions,{icl_mod & icl_functions={}}) - # {icl_instances,icl_specials,icl_common,icl_import,icl_name,icl_imported_objects,icl_used_module_numbers} = icl_mod + # {icl_instances,icl_specials,icl_common,icl_import,icl_name,icl_imported_objects,icl_used_module_numbers,icl_copied_from_dcl} = icl_mod /* (_,f,files) = fopen "components" FWriteText files (components, icl_functions, f) = showComponents components 0 True icl_functions f @@ -131,15 +132,24 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an | options.feo_up_to_phase == FrontEndPhaseCheck # array_instances = {ali_array_first_instance_indices=[],ali_list_first_instance_indices=[],ali_tail_strict_list_first_instance_indices=[],ali_instances_range={ir_from=0,ir_to=0}} - = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps + = frontSyntaxTree cached_functions_and_macros dcl_mods n_functions_and_macros_in_dcl_modules main_dcl_module_n + predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps // AA.. # error_admin = {ea_file = error, ea_loc = [], ea_ok = True } +/* # (ti_common_defs, dcl_mods) = get_common_defs dcl_mods ti_common_defs = { ti_common_defs & [main_dcl_module_n] = icl_common } - # (td_infos, type_heaps, error_admin) = analTypeDefs ti_common_defs icl_used_module_numbers type_heaps error_admin +*/ + + # (cached_dcl_mods, dcl_mods) = copy_dcl_modules dcl_mods + + # (type_groups, ti_common_defs, td_infos, icl_common, dcl_mods, type_heaps, error_admin) + = partionateAndExpandTypes icl_used_module_numbers main_dcl_module_n icl_common dcl_mods type_heaps error_admin + ti_common_defs = { ti_common_defs & [main_dcl_module_n] = icl_common } + # (td_infos, type_heaps, error_admin) = analyseTypeDefs ti_common_defs type_groups td_infos type_heaps error_admin (fun_defs, dcl_mods, th_vars, td_infos, error_admin) - = checkKindCorrectness main_dcl_module_n icl_instances ti_common_defs n_cached_dcl_modules fun_defs dcl_mods type_heaps.th_vars td_infos error_admin + = checkKindCorrectness main_dcl_module_n nr_of_chached_functions_and_macros icl_instances ti_common_defs n_cached_dcl_modules fun_defs dcl_mods type_heaps.th_vars td_infos error_admin type_heaps = { type_heaps & th_vars = th_vars } # heaps = { heaps & hp_type_heaps = type_heaps } # (saved_main_dcl_common, ti_common_defs) = replace (dcl_common_defs dcl_mods) main_dcl_module_n icl_common @@ -171,14 +181,14 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an # error = error_admin.ea_file #! ok = error_admin.ea_ok | not ok - = (No,{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) + = (No,{},{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) // ..AA # (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, type_def_infos, heaps, predef_symbols, error,out) = typeProgram (components -*-> "Typing") main_dcl_module_n fun_defs/*icl_functions*/ icl_specials list_inferred_types icl_common [a\\a<-:icl_import] dcl_mods icl_used_module_numbers td_infos heaps predef_symbols error out dcl_mods | not ok - = (No,{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) + = (No,{},{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) # (fun_def_size, fun_defs) = usize fun_defs @@ -189,7 +199,8 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an // (fun_defs, error) = showFunctions array_instances fun_defs error | options.feo_up_to_phase == FrontEndPhaseTypeCheck - = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps + = frontSyntaxTree cached_functions_and_macros cached_dcl_mods n_functions_and_macros_in_dcl_modules main_dcl_module_n + predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps # (components, fun_defs, predef_symbols, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap, tcl_file) = convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs main_dcl_module_n (components -*-> "convertDynamics") fun_defs predef_symbols @@ -199,7 +210,8 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an | options.feo_up_to_phase == FrontEndPhaseConvertDynamics # heaps = {hp_var_heap=var_heap, hp_type_heaps=type_heaps, hp_expression_heap=expression_heap} - = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps + = frontSyntaxTree cached_functions_and_macros cached_dcl_mods n_functions_and_macros_in_dcl_modules main_dcl_module_n + predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps // (components, fun_defs, error) = showComponents components 0 True fun_defs error @@ -218,7 +230,8 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an | options.feo_up_to_phase == FrontEndPhaseTransformGroups # heaps = {hp_var_heap=var_heap, hp_type_heaps=type_heaps, hp_expression_heap=expression_heap} - = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps + = frontSyntaxTree cached_functions_and_macros cached_dcl_mods n_functions_and_macros_in_dcl_modules main_dcl_module_n + predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps # (dcl_types, used_conses, var_heap, type_heaps) = convertIclModule main_dcl_module_n common_defs (dcl_types -*-> "Convert icl") used_conses var_heap type_heaps # (dcl_types, used_conses, var_heap, type_heaps) = convertDclModule main_dcl_module_n dcl_mods common_defs (dcl_types -*-> "Convert dcl") used_conses var_heap type_heaps @@ -227,7 +240,8 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an | options.feo_up_to_phase == FrontEndPhaseConvertModules # heaps = {hp_var_heap=var_heap, hp_type_heaps=type_heaps, hp_expression_heap=expression_heap} - = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps + = frontSyntaxTree cached_functions_and_macros cached_dcl_mods n_functions_and_macros_in_dcl_modules main_dcl_module_n + predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps // (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) @@ -251,8 +265,9 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an # heaps = {hp_var_heap = var_heap, hp_expression_heap=expression_heap, hp_type_heaps=type_heaps} #! fe ={ fe_icl = // {icl_mod & icl_functions=fun_defs } - {icl_functions=fun_defs,icl_instances=icl_instances,icl_specials=icl_specials,icl_common=icl_common,icl_import=icl_import, - icl_name=icl_name,icl_imported_objects=icl_imported_objects,icl_used_module_numbers=icl_used_module_numbers } + {icl_functions=fun_defs,icl_instances=icl_instances,icl_specials=icl_specials,icl_common=icl_common,icl_import=icl_import, + icl_name=icl_name,icl_imported_objects=icl_imported_objects,icl_used_module_numbers=icl_used_module_numbers, + icl_copied_from_dcl=icl_copied_from_dcl} , fe_dcls = dcl_mods , fe_components = components @@ -260,7 +275,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an , fe_iclDclConversions = build_optional_icl_dcl_conversions (size fun_defs) optional_dcl_icl_conversions , fe_arrayInstances = array_instances,fe_globalFunctions=global_fun_range } - = (Yes fe,cached_functions_and_macros,n_functions_and_macros_in_dcl_modules,main_dcl_module_n,predef_symbols,hash_table,files,error,io,out,tcl_file,heaps) + = (Yes fe,cached_functions_and_macros,cached_dcl_mods,n_functions_and_macros_in_dcl_modules,main_dcl_module_n,predef_symbols,hash_table,files,error,io,out,tcl_file,heaps) where build_optional_icl_dcl_conversions :: !Int !(Optional {# Index}) -> Optional {# Index} build_optional_icl_dcl_conversions size No @@ -287,17 +302,10 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an = fill_empty_positions (inc next_index) table_size (inc next_new_index) { icl_conversions & [next_index] = next_new_index } = fill_empty_positions (inc next_index) table_size next_new_index icl_conversions = icl_conversions - get_common_defs dcl_mods - #! size = size dcl_mods - # ({dcl_common=arbitrary_value_for_initializing}, dcl_mods) = dcl_mods![0] - = loop 0 (createArray size arbitrary_value_for_initializing) dcl_mods - where - loop :: !Int !*{#CommonDefs} !u:{#DclModule} -> (!*{#CommonDefs}, !u:{#DclModule}) - loop i common_defs dcl_mods - | i==size dcl_mods - = (common_defs, dcl_mods) - # ({dcl_common}, dcl_mods) = dcl_mods![i] - = loop (i+1) { common_defs & [i] = dcl_common } dcl_mods + + copy_dcl_modules dcl_mods + #! nr_of_dcl_mods = size dcl_mods + = arrayCopyBegin dcl_mods nr_of_dcl_mods newSymbolTable :: !Int -> *{# SymbolTableEntry} newSymbolTable size diff --git a/frontend/main.icl b/frontend/main.icl index c50011a..e1795d4 100644 --- a/frontend/main.icl +++ b/frontend/main.icl @@ -167,15 +167,15 @@ compileModule mod_name dcl_cache ms loadModule :: Ident *DclCache *MainState -> *(!Optional InterMod,!*DclCache,!*MainState); loadModule mod_ident {dcl_modules,functions_and_macros,predef_symbols,hash_table,heaps} ms=:{ms_files,ms_error,ms_io,ms_out,ms_paths} - # (optional_syntax_tree,cached_functions_and_macros,_,main_dcl_module_n,predef_symbols, hash_table, ms_files, ms_error, ms_io, ms_out,_,heaps) - = frontEndInterface {feo_up_to_phase=FrontEndPhaseAll,feo_generics=False} mod_ident {sp_locations = [], sp_paths = ms_paths} dcl_modules functions_and_macros No predef_symbols hash_table ms_files ms_error ms_io ms_out No heaps + # (optional_syntax_tree,cached_functions_and_macros,cached_dcl_mods,_,main_dcl_module_n,predef_symbols, hash_table, ms_files, ms_error, ms_io, ms_out,_,heaps) + = frontEndInterface { feo_up_to_phase = FrontEndPhaseAll,feo_generics = False} mod_ident {sp_locations = [], sp_paths = ms_paths} dcl_modules functions_and_macros No predef_symbols hash_table ms_files ms_error ms_io ms_out No heaps # ms = {ms & ms_files=ms_files, ms_error=ms_error,ms_io=ms_io,ms_out=ms_out} = case optional_syntax_tree of Yes {fe_icl={/*icl_functions,*/icl_used_module_numbers}, fe_dcls, fe_dclIclConversions, fe_iclDclConversions} - # dcl_modules={{dcl_module \\ dcl_module<-:fe_dcls} & [main_dcl_module_n].dcl_conversions=No} + # dcl_modules={{dcl_module \\ dcl_module<-:cached_dcl_mods} & [main_dcl_module_n].dcl_conversions=No} # var_heap = remove_expanded_types_from_dcl_modules 0 dcl_modules icl_used_module_numbers heaps.hp_var_heap # heaps = {heaps & hp_var_heap = var_heap } - -> (Yes (buildInterMod mod_ident icl_used_module_numbers fe_dcls /*icl_functions fe_dclIclConversions fe_iclDclConversions*/), + -> (Yes (buildInterMod mod_ident icl_used_module_numbers fe_dcls), {dcl_modules=dcl_modules,functions_and_macros=cached_functions_and_macros,predef_symbols=predef_symbols,hash_table=hash_table,heaps=heaps}, ms) No -> (No, {dcl_modules=dcl_modules,functions_and_macros=cached_functions_and_macros,predef_symbols=predef_symbols,hash_table=hash_table,heaps=heaps},ms) @@ -242,7 +242,7 @@ where = collect_modules modules collected_modules random_numbers proj ms # ms = {ms & ms_io = ms.ms_io <<< "Compiling " <<< id_name <<< "\n"} # dcl_cache = proj.proj_cache -// # dcl_cache = empty_cache +// # dcl_cache = (empty_cache proj.proj_cache.hash_table.hte_symbol_heap) # (this_mod,dcl_cache,ms) = compileModule id_name dcl_cache ms # proj = {proj & proj_cache=dcl_cache} = case this_mod of diff --git a/frontend/overloading.icl b/frontend/overloading.icl index d44bf48..3218836 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -470,7 +470,7 @@ where is_predefined_symbol glob_module glob_object PD_UnboxedArrayType predef_symbols -> (unboxable, No, (predef_symbols, type_heaps)) SynType {at_type} - # (expanded_type, type_heaps) = expandTypeSyn td_attribute td_args type_args at_type type_heaps + # (_, expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args at_type type_heaps -> try_to_unbox expanded_type defs (predef_symbols, type_heaps) _ -> (False, No, (predef_symbols, type_heaps)) @@ -558,16 +558,11 @@ tryToExpandTypeSyn defs cons_id=:{type_name,type_index={glob_object,glob_module} # {td_name,td_rhs,td_args,td_attribute} = defs.[glob_module].com_type_defs.[glob_object] = case td_rhs of SynType {at_type} - # (expanded_type, type_heaps) = expandTypeSyn td_attribute td_args type_args at_type type_heaps + # (_, expanded_type, type_heaps) = substituteType td_attribute TA_Multi td_args type_args at_type type_heaps -> (True, expanded_type, type_heaps) _ -> (False, TA cons_id type_args, type_heaps) -expandTypeSyn td_attribute td_args type_args td_rhs type_heaps - # type_heaps = bindTypeVarsAndAttributes td_attribute TA_Multi td_args type_args type_heaps - (_, expanded_type, type_heaps) = substitute td_rhs type_heaps - = (expanded_type, clearBindingsOfTypeVarsAndAttributes td_attribute td_args type_heaps) - class match type :: !{# CommonDefs} !type !type !*TypeHeaps -> (!Bool, !*TypeHeaps) instance match AType @@ -1053,7 +1048,7 @@ where # (fun_def, fun_defs) = fun_defs![fun_index] (CheckedType st=:{st_context}, fun_env) = fun_env![fun_index] {fun_body = TransformedBody {tb_args,tb_rhs},fun_info,fun_arity,fun_symb,fun_pos} = fun_def - (rev_variables, var_heap) = foldSt determine_class_argument st_context ([], var_heap) // ---> ("remove_overloaded_function", fun_symb, st_context)) + (rev_variables, var_heap) = foldSt determine_class_argument st_context ([], var_heap) error = setErrorAdmin (newPosition fun_symb fun_pos) error (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) = convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) @@ -1200,7 +1195,6 @@ getTCDictionary symb_name var_info_ptr (var_heap, error) _ -> (var_info_ptr, (var_heap, overloadingError symb_name error)) -// import RWSDebug :: TypeCodeInfo = { tci_next_index :: !Index @@ -1267,8 +1261,6 @@ where // ... MV } -import RWSDebug - class updateExpression e :: !Index !e !*UpdateInfo -> (!e, !*UpdateInfo) instance updateExpression Expression @@ -1449,9 +1441,6 @@ where updateExpression group_index No ui = (No, ui) -//import StdDebug -//import RWSDebug - instance updateExpression CasePatterns where updateExpression group_index (AlgebraicPatterns type patterns) ui diff --git a/frontend/parse.icl b/frontend/parse.icl index 0a419f2..2955d9c 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -2675,14 +2675,16 @@ where (lhs_expr, pState) = wantExpression cIsAPattern pState (token, pState) = nextToken FunctionContext pState | token == LeftArrowToken +//MW3 was: = want_generators IsListGenerator (toLineAndColumn qual_position) lhs_expr pState = want_generators IsListGenerator (toLineAndColumn qual_position) qual_filename lhs_expr pState - | token == LeftArrowWithBarToken - = want_generators IsOverloadedListGenerator (toLineAndColumn qual_position) qual_filename lhs_expr pState | token == LeftArrowColonToken +//MW3 was: = want_generators IsArrayGenerator (toLineAndColumn qual_position) lhs_expr pState = want_generators IsArrayGenerator (toLineAndColumn qual_position) qual_filename lhs_expr pState = ({qual_generators = [], qual_filter = No, qual_position = {lc_line = 0, lc_column = 0}, qual_filename = "" }, parseError "comprehension: qualifier" (Yes token) "qualifier(s)" pState) +//MW3 was: want_generators :: !GeneratorKind !LineAndColumn !ParsedExpr !ParseState -> (!Qualifier, !ParseState) +//MW3 was: want_generators gen_kind qual_position pattern_exp pState want_generators :: !GeneratorKind !LineAndColumn !FileName !ParsedExpr !ParseState -> (!Qualifier, !ParseState) want_generators gen_kind qual_position qual_filename pattern_exp pState # (gen_position, pState) = getPosition pState diff --git a/frontend/refmark.icl b/frontend/refmark.icl index 30cb44e..f607bc1 100644 --- a/frontend/refmark.icl +++ b/frontend/refmark.icl @@ -352,17 +352,8 @@ where var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel def ap_expr var_heap // (var_heap ---> ("ref_mark_of_algebraic_pattern", ap_expr)) var_heap = restore_binding_of_pattern_variable opt_pattern_var used_pattern_vars var_heap (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap) -// var_heap = clear_local_vars used_pattern_vars var_heap = (with_pattern_bindings || not (isEmpty used_pattern_vars), pattern_depth, used_lets, var_heap) - clear_local_vars vars var_heap - = foldSt clear_occurrence vars var_heap - where - clear_occurrence ({fv_name,fv_info_ptr},_) var_heap - # (var_info, var_heap) = readPtr fv_info_ptr var_heap - = case var_info of - VI_Occurrence occ - -> var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_previous = [], occ_bind = OB_Empty }) bind_optional_pattern_variable _ [] var_heap = var_heap diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index fed82c2..e3be8f8 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -58,6 +58,9 @@ instance toString Ident instances are accumulated. */ | STE_BelongingSymbol !Int + + | STE_UsedType !Index !STE_Kind + /* used during binding of types to mark types that have been applied. The first */ :: Declaration = Declaration !DeclarationRecord @@ -369,16 +372,15 @@ cIsImportedObject :== False :: ParsedTypeDef :== TypeDef RhsDefsOfType :: CheckedTypeDef :== TypeDef TypeRhs -/* -cIsHyperStrict :== True -cIsNotHyperStrict :== False -*/ - cAllBitsClear :== 0 - cIsHyperStrict :== 1 cIsNonCoercible :== 2 -// cMayBeNonCoercible :== 4 +cIsAnalysed :== 4 + +:: GlobalIndex = + { gi_module ::!Int + , gi_index ::!Int + } :: TypeDef type_rhs = { td_name :: !Ident @@ -390,16 +392,17 @@ cIsNonCoercible :== 2 , td_rhs :: !type_rhs , td_attribute :: !TypeAttribute , td_pos :: !Position + , td_used_types :: ![GlobalIndex] } :: TypeDefInfo = { tdi_kinds :: ![TypeKind] , tdi_properties :: !BITVECT - , tdi_group :: ![Global Index] + , tdi_group :: ![GlobalIndex] , tdi_group_nr :: !Int , tdi_group_vars :: ![Int] , tdi_cons_vars :: ![Int] - , tdi_tmp_index :: !Int + , tdi_index_in_group :: !Index , tdi_classification :: !TypeClassification } @@ -1034,7 +1037,10 @@ cNonUniqueSelection :== False | PS_Array !ParsedExpr | PS_Erroneous -:: GeneratorKind = IsListGenerator | IsOverloadedListGenerator | IsArrayGenerator +:: GeneratorKind :== Bool + +IsListGenerator :== True +IsArrayGenerator :== False :: LineAndColumn = {lc_line :: !Int, lc_column :: !Int} @@ -1268,6 +1274,8 @@ instance <<< FunctionBody instance == TypeAttribute instance == Annotation +instance == GlobalIndex + /* ErrorToString :: Error -> String @@ -1282,7 +1290,7 @@ EmptySymbolTableEntryCAF :: BoxedSymbolTableEntry cNotAGroupNumber :== -1 EmptyTypeDefInfo :== { tdi_kinds = [], tdi_properties = cAllBitsClear, tdi_group = [], tdi_group_vars = [], tdi_cons_vars = [], - tdi_classification = EmptyTypeClassification, tdi_group_nr = cNotAGroupNumber, tdi_tmp_index = NoIndex } + tdi_classification = EmptyTypeClassification, tdi_group_nr = cNotAGroupNumber, tdi_index_in_group = NoIndex } MakeTypeVar name :== { tv_name = name, tv_info_ptr = nilPtr } MakeVar name :== { var_name = name, var_info_ptr = nilPtr, var_expr_ptr = nilPtr } @@ -1334,7 +1342,7 @@ ParsedInstanceToClassInstance pi members :== 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, - td_pos = pos, td_rhs = rhs } + td_pos = pos, td_rhs = rhs, td_used_types = [] } MakeDefinedSymbol ident index arity :== { ds_ident = ident, ds_arity = arity, ds_index = index } diff --git a/frontend/syntax.icl b/frontend/syntax.icl index d343053..ed5461d 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -57,6 +57,7 @@ where toString {import_module} = toString import_module | STE_ExplImpSymbol !Int | STE_ExplImpComponentNrs ![ComponentNrAndIndex] ![Declaration] | STE_BelongingSymbol !Int + | STE_UsedType !Index !STE_Kind :: Declaration = Declaration !DeclarationRecord @@ -373,11 +374,20 @@ cIsImportedObject :== False :: CheckedTypeDef :== TypeDef TypeRhs cAllBitsClear :== 0 - cIsHyperStrict :== 1 cIsNonCoercible :== 2 -cMayBeNonCoercible :== 4 +cIsAnalysed :== 4 +cIsAbstractType :== 8 + +:: GlobalIndex = + { gi_module ::!Int + , gi_index ::!Int + } +instance == GlobalIndex +where + (==) gi1 gi2 = gi1.gi_module == gi2.gi_module && gi1.gi_index == gi2.gi_index + :: TypeDef type_rhs = { td_name :: !Ident , td_index :: !Int @@ -388,6 +398,7 @@ cMayBeNonCoercible :== 4 , td_rhs :: !type_rhs , td_attribute :: !TypeAttribute , td_pos :: !Position + , td_used_types :: ![GlobalIndex] } :: FunType = @@ -929,11 +940,11 @@ cNotVarNumber :== -1 :: TypeDefInfo = { tdi_kinds :: ![TypeKind] , tdi_properties :: !BITVECT - , tdi_group :: ![Global Index] + , tdi_group :: ![GlobalIndex] , tdi_group_nr :: !Int , tdi_group_vars :: ![Int] , tdi_cons_vars :: ![Int] - , tdi_tmp_index :: !Int + , tdi_index_in_group :: !Index , tdi_classification :: !TypeClassification } @@ -1010,7 +1021,11 @@ cNonUniqueSelection :== False | PS_Array !ParsedExpr | PS_Erroneous -:: GeneratorKind = IsListGenerator | IsOverloadedListGenerator | IsArrayGenerator + +:: GeneratorKind :== Bool + +IsListGenerator :== True +IsArrayGenerator :== False :: LineAndColumn = {lc_line :: !Int, lc_column :: !Int} @@ -1480,11 +1495,7 @@ where instance <<< Generator where (<<<) file {gen_kind,gen_pattern,gen_expr} - = file <<< gen_pattern <<< (gen_kind_to_string gen_kind) <<< gen_expr - where - gen_kind_to_string IsListGenerator = "<-" - gen_kind_to_string IsOverloadedListGenerator = "<|-" - gen_kind_to_string IsArrayGenerator = "<-:" + = file <<< gen_pattern <<< (if gen_kind "<-" "<-:") <<< gen_expr instance <<< BasicValue where @@ -1799,7 +1810,8 @@ where instance <<< TypeDefInfo where (<<<) file {tdi_group,tdi_group_vars,tdi_cons_vars} - = file <<< '[' <<< tdi_group <<< '=' <<< tdi_group_vars <<< '=' <<< tdi_cons_vars <<< ']' +// = file <<< '[' <<< tdi_group <<< '=' <<< tdi_group_vars <<< '=' <<< tdi_cons_vars <<< ']' + = file <<< '[' <<< tdi_group_vars <<< '=' <<< tdi_cons_vars <<< ']' instance <<< DefinedSymbol where @@ -2111,7 +2123,7 @@ abort_empty_SymbolTableEntry = abort "empty SymbolTableEntry" cNotAGroupNumber :== -1 EmptyTypeDefInfo :== { tdi_kinds = [], tdi_properties = cAllBitsClear, tdi_group = [], tdi_group_vars = [], tdi_cons_vars = [], - tdi_classification = EmptyTypeClassification, tdi_group_nr = cNotAGroupNumber, tdi_tmp_index = NoIndex } + tdi_classification = EmptyTypeClassification, tdi_group_nr = cNotAGroupNumber, tdi_index_in_group = NoIndex } MakeTypeVar name :== { tv_name = name, tv_info_ptr = nilPtr } MakeVar name :== { var_name = name, var_info_ptr = nilPtr, var_expr_ptr = nilPtr } @@ -2168,7 +2180,7 @@ ParsedInstanceToClassInstance pi members :== 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, - td_pos = pos, td_rhs = rhs } + td_pos = pos, td_rhs = rhs, td_used_types = [] } MakeDefinedSymbol ident index arity :== { ds_ident = ident, ds_arity = arity, ds_index = index } diff --git a/frontend/type.icl b/frontend/type.icl index 0f551bb..6160182 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -349,8 +349,8 @@ tryToExpand type=:(TA {type_index={glob_object,glob_module}} type_args) type_att #! type_def = ti_common_defs.[glob_module].com_type_defs.[glob_object] = case type_def.td_rhs of SynType {at_type} - # (res_type, type_heaps) = expandTypeApplication type_def.td_args type_def.td_attribute at_type type_args type_attr type_heaps - -> (True, res_type, type_heaps) + # (_, expanded_type, type_heaps) = substituteType type_def.td_attribute type_attr type_def.td_args type_args at_type type_heaps + -> (True, expanded_type, type_heaps) _ -> (False, type, type_heaps) tryToExpand type type_attr modules type_heaps diff --git a/frontend/typesupport.dcl b/frontend/typesupport.dcl index e0ef601..895d6e7 100644 --- a/frontend/typesupport.dcl +++ b/frontend/typesupport.dcl @@ -40,8 +40,6 @@ cleanUpSymbolType :: !Bool !Bool !TempSymbolType ![TypeContext] ![ExprInfoPtr] ! !*VarEnv !*AttributeEnv !*TypeHeaps !*VarHeap !*ExpressionHeap !*ErrorAdmin -> (!SymbolType, !*VarEnv, !*AttributeEnv, !*TypeHeaps, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) -expandTypeApplication :: ![ATypeVar] !TypeAttribute !Type ![AType] !TypeAttribute !*TypeHeaps -> (!Type, !*TypeHeaps) - equivalent :: !SymbolType !TempSymbolType !Int !{# CommonDefs} !*AttributeEnv !*TypeHeaps -> (!Bool, !*AttributeEnv, !*TypeHeaps) NewAttrVarId :: !Int -> Ident @@ -73,6 +71,11 @@ class substitute a :: !a !*TypeHeaps -> (!Bool, !a, !*TypeHeaps) instance substitute AType, Type, TypeContext, AttrInequality, CaseType, [a] | substitute a, (a,b) | substitute a & substitute b +substituteType :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !Type !*TypeHeaps -> (!Bool, !Type, !*TypeHeaps) + +bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps; +clearBindingsOfTypeVarsAndAttributes :: !TypeAttribute ![ATypeVar] !*TypeHeaps -> *TypeHeaps; + instance <<< TempSymbolType clearBindings :: ![ATypeVar] !*TypeHeaps -> !*TypeHeaps diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index e22a9bf..f458dc5 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -26,20 +26,18 @@ import syntax, parse, check, unitype, utilities, checktypes, compilerSwitches simplifyTypeApplication :: !Type ![AType] -> (!Bool, !Type) simplifyTypeApplication (TA type_cons=:{type_arity} cons_args) type_args = (True, TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args)) -simplifyTypeApplication (TV tv) type_args - = (True, CV tv :@: type_args) simplifyTypeApplication (CV tv :@: type_args1) type_args2 = (True, CV tv :@: (type_args1 ++ type_args2)) -simplifyTypeApplication (TB _) _ - = (False, TE) -//AA.. simplifyTypeApplication TArrow [type1, type2] = (True, type1 --> type2) simplifyTypeApplication TArrow [type] = (True, TArrow1 type) simplifyTypeApplication (TArrow1 type1) [type2] = (True, type1 --> type2) -//AA.. +simplifyTypeApplication (TV tv) type_args + = (True, CV tv :@: type_args) +simplifyTypeApplication (TB _) _ + = (False, TE) simplifyTypeApplication (TArrow1 _) _ = (False, TE) @@ -271,11 +269,9 @@ where cleanUpClosed (argtype --> restype) env # (cur, (argtype,restype), env) = cleanUpClosed (argtype,restype) env = (cur, argtype --> restype, env) -//AA.. cleanUpClosed (TArrow1 argtype) env # (cur, argtype, env) = cleanUpClosed argtype env = (cur, TArrow1 argtype, env) -//..AA cleanUpClosed (TempCV tv_number :@: types) env # (type, env) = env![tv_number] # (cur1, type, env) = cleanUpClosedVariable type env @@ -646,6 +642,39 @@ instance bindInstances AType bindInstances {at_type=t1} {at_type=t2} type_var_heap = bindInstances t1 t2 type_var_heap +substituteType :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !Type !*TypeHeaps -> (!Bool, !Type, !*TypeHeaps) +substituteType form_root_attribute act_root_attribute form_type_args act_type_args orig_type type_heaps + # type_heaps = bindTypeVarsAndAttributes form_root_attribute act_root_attribute form_type_args act_type_args type_heaps + (ok, expanded_type, type_heaps) = substitute orig_type type_heaps + = (ok, expanded_type, clearBindingsOfTypeVarsAndAttributes form_root_attribute form_type_args type_heaps) + + +bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps +bindTypeVarsAndAttributes form_root_attribute act_root_attribute form_type_args act_type_args type_heaps + # th_attrs = bind_attribute form_root_attribute act_root_attribute type_heaps.th_attrs + = fold2St bind_type_and_attr form_type_args act_type_args { type_heaps & th_attrs = th_attrs } +where + bind_type_and_attr {atv_attribute, atv_variable={tv_info_ptr}} {at_type,at_attribute} type_heaps=:{th_vars,th_attrs} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), + th_attrs = bind_attribute atv_attribute at_attribute th_attrs } + + bind_attribute (TA_Var {av_info_ptr}) attr th_attrs + = th_attrs <:= (av_info_ptr, AVI_Attr attr) + bind_attribute _ _ th_attrs + = th_attrs + +clearBindingsOfTypeVarsAndAttributes :: !TypeAttribute ![ATypeVar] !*TypeHeaps -> *TypeHeaps +clearBindingsOfTypeVarsAndAttributes form_root_attribute form_type_args type_heaps + # th_attrs = clear_attribute form_root_attribute type_heaps.th_attrs + = foldSt clear_type_and_attr form_type_args { type_heaps & th_attrs = th_attrs } +where + clear_type_and_attr {atv_attribute, atv_variable={tv_info_ptr}} type_heaps=:{th_vars,th_attrs} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Empty), th_attrs = clear_attribute atv_attribute th_attrs } + + clear_attribute (TA_Var {av_info_ptr}) th_attrs + = th_attrs <:= (av_info_ptr, AVI_Empty) + clear_attribute _ th_attrs + = th_attrs class substitute a :: !a !*TypeHeaps -> (!Bool, !a, !*TypeHeaps) @@ -685,50 +714,45 @@ where (ok_ts, ts, heaps) = substitute ts heaps = (ok_t && ok_ts, [t:ts], heaps) - instance substitute TypeContext where substitute tc=:{tc_types} heaps # (ok, tc_types, heaps) = substitute tc_types heaps = (ok, { tc & tc_types = tc_types }, heaps) -substituteTypeVariable tv=:{tv_name,tv_info_ptr} heaps=:{th_vars} - # (tv_info, th_vars) = readPtr tv_info_ptr th_vars - heaps = { heaps & th_vars = th_vars } - = case tv_info of - TVI_Type type - -> (type, heaps) - _ - -> (TV tv, heaps) - instance substitute Type where - substitute (TV tv) heaps - # (type, heaps) = substituteTypeVariable tv heaps - = (True, type, heaps) + substitute tv=:(TV {tv_info_ptr}) heaps=:{th_vars} + # (tv_info, th_vars) = readPtr tv_info_ptr th_vars + heaps = { heaps & th_vars = th_vars } + = case tv_info of + TVI_Type type + -> (True, type, heaps) + _ + -> (True, tv, heaps) substitute (arg_type --> res_type) heaps # (ok, (arg_type, res_type), heaps) = substitute (arg_type, res_type) heaps = (ok, arg_type --> res_type, heaps) -//AA.. substitute (TArrow1 arg_type) heaps # (ok, arg_type, heaps) = substitute arg_type heaps = (ok, TArrow1 arg_type, heaps) - -//..AA substitute (TA cons_id cons_args) heaps # (ok, cons_args, heaps) = substitute cons_args heaps = (ok, TA cons_id cons_args, heaps) substitute (CV type_var :@: types) heaps=:{th_vars} # (tv_info, th_vars) = readPtr type_var.tv_info_ptr th_vars heaps = { heaps & th_vars = th_vars } - (ok1, types, heaps) = substitute types heaps + (ok_types, types, heaps) = substitute types heaps = case tv_info of - TVI_Type tv=:(TempV i) - -> (ok1, TempCV i :@: types, heaps) + TVI_Type type + -> case type of + TempV i + -> (ok_types, TempCV i :@: types, heaps) + _ + # (ok_type, simplified_type) = simplifyTypeApplication type types + -> (ok_type && ok_types, simplified_type, heaps) _ - # (type, heaps) = substituteTypeVariable type_var heaps - (ok2, simplified_type) = simplifyTypeApplication type types - -> (ok1 && ok2, simplified_type, heaps) + -> (ok_types, CV type_var :@: types, heaps) substitute type heaps = (True, type, heaps) @@ -825,11 +849,13 @@ where = (True, { st & st_args = st_args, st_result = st_result }) = (False, st) +/* expandTypeApplication :: ![ATypeVar] !TypeAttribute !Type ![AType] !TypeAttribute !*TypeHeaps -> (!Type, !*TypeHeaps) expandTypeApplication type_args form_attr type_rhs arg_types act_attr type_heaps=:{th_attrs} # type_heaps = bindTypeVarsAndAttributes form_attr act_attr type_args arg_types type_heaps (_, exp_type, type_heaps) = substitute type_rhs type_heaps = (exp_type, clearBindingsOfTypeVarsAndAttributes form_attr type_args type_heaps) +*/ VarIdTable :: {# String} VarIdTable =: { "a", "b", "c", "d", "e", "f", "g", "h", "i", "j" } diff --git a/frontend/unitype.icl b/frontend/unitype.icl index c6d5561..3850467 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -821,11 +821,12 @@ tryToExpandTypeSyn :: !{#CommonDefs} !{#BOOLVECT} !TypeSymbIdent ![AType] !TypeA tryToExpandTypeSyn defs cons_vars cons_id=:{type_index={glob_object,glob_module}} type_args attribute type_heaps td_infos # {td_rhs,td_args,td_attribute,td_name} = defs.[glob_module].com_type_defs.[glob_object] = case td_rhs of - SynType {at_type} + SynType {at_type} # type_heaps = bindTypeVarsAndAttributes td_attribute attribute td_args type_args type_heaps (_, expanded_type, (_, {es_type_heaps, es_td_infos})) = expandType defs cons_vars at_type ({}, { es_type_heaps = type_heaps, es_td_infos = td_infos }) -> (True, expanded_type, clearBindingsOfTypeVarsAndAttributes attribute td_args es_type_heaps, es_td_infos) + _ -> (False, TA cons_id type_args, type_heaps, td_infos) |