diff options
| -rw-r--r-- | frontend/analtypes.icl | 80 |
1 files changed, 78 insertions, 2 deletions
diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index ec209ef..dd48784 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -1,7 +1,7 @@ implementation module analtypes import StdEnv -import syntax, checksupport, checktypes, check, typesupport, utilities, RWSDebug +import syntax, checksupport, checktypes, check, typesupport, utilities, analunitypes, RWSDebug :: UnifyKindsInfo = { uki_kind_heap ::!.KindHeap @@ -470,7 +470,10 @@ analTypeDefs modules used_module_numbers heaps error 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, as_heaps, as_error) + (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 @@ -484,6 +487,11 @@ where = 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) + + instance == AttributeVar where (==) av1 av2 = av1.av_info_ptr == av2.av_info_ptr @@ -491,3 +499,71 @@ where instance <<< DynamicType where (<<<) file {dt_global_vars,dt_type} = file <<< dt_global_vars <<< dt_type + + +checkLeftRootAttributionOfTypeDef :: !{# CommonDefs} !Index !Index !(!*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] + | 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) + | is_unique + = (td_infos, th_vars, checkErrorWithIdentPos (newPosition td_name td_pos) + " left root * attribute expected" error) + = (td_infos, th_vars, error) + +isUniqueTypeRhs common_defs mod_index (AlgType constructors) state + = one_constructor_is_unique common_defs mod_index constructors state +isUniqueTypeRhs common_defs mod_index (SynType rhs) state + = isUnique common_defs rhs state +isUniqueTypeRhs common_defs mod_index (RecordType {rt_constructor}) state + = one_constructor_is_unique common_defs mod_index [rt_constructor] state +isUniqueTypeRhs common_defs mod_index _ state + = (False, state) + +one_constructor_is_unique common_defs mod_index [] state + = (False, state) +one_constructor_is_unique common_defs mod_index [{ds_index}:constructors] state + # {cons_type} + = common_defs.[mod_index].com_cons_defs.[ds_index] + (uniqueness_of_args, state) + = mapSt (isUnique common_defs) cons_type.st_args state + = (or uniqueness_of_args, state) + +class isUnique a :: !{# CommonDefs} !a !(!*TypeDefInfos, !*TypeVarHeap) -> (!Bool, !(!*TypeDefInfos, !*TypeVarHeap)) + +instance isUnique AType + where + isUnique common_defs {at_attribute=TA_Unique} state + = (True, state) + isUnique common_defs {at_type} state + = isUnique common_defs at_type state + +instance isUnique Type + where + isUnique common_defs (TA {type_index={glob_module, glob_object}} type_args) (td_infos, th_vars) + # type_def + = common_defs.[glob_module].com_type_defs.[glob_object] + | isUniqueAttr type_def.td_attribute + = (True, (td_infos, th_vars)) + # (prop_classification, th_vars, td_infos) + = propClassification glob_object glob_module (repeatn type_def.td_arity 0) + common_defs th_vars td_infos + (uniqueness_of_args, (td_infos, th_vars)) + = mapSt (isUnique common_defs) type_args (td_infos, th_vars) + = (unique_if_arg_is_unique_and_propagating uniqueness_of_args prop_classification, (td_infos, th_vars)) + where + unique_if_arg_is_unique_and_propagating [] _ + = False + unique_if_arg_is_unique_and_propagating [is_unique_argument:rest] prop_classification + | isOdd prop_classification /*MW:cool!*/ && is_unique_argument + = True + = unique_if_arg_is_unique_and_propagating rest (prop_classification>>1) + isUnique common_defs _ state + = (False, state) + +isUniqueAttr TA_Unique = True +isUniqueAttr _ = False |