diff options
| -rw-r--r-- | frontend/analtypes.icl | 207 |
1 files changed, 97 insertions, 110 deletions
diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index 619426d..a0a40ad 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, analunitypes //, RWSDebug +import syntax, checksupport, checktypes, check, typesupport, utilities, analunitypes :: TypeGroups :== [[GlobalIndex]] @@ -360,7 +360,6 @@ where = (info_ptr == kind_info_ptr, kind_heap) contains_kind_ptr info_ptr (KI_Const) kind_heap = (False, kind_heap) - unify_kinds kind k1=:(KI_Var info_ptr1) uni_info = unify_kinds k1 kind uni_info unify_kinds kind1=:(KI_Arrow x1 y1) kind2=:(KI_Arrow x2 y2) uni_info @@ -370,7 +369,6 @@ where unify_kinds kind1 kind2 uni_info=:{uki_error} = { uni_info & uki_error = kindError kind1 kind2 uki_error } - kindToKindInfo (KindVar info_ptr) = KI_Var info_ptr kindToKindInfo KindConst @@ -472,23 +470,24 @@ analTypes_for_TA type_ident glob_module glob_object type_arity types has_root_at where anal_types_of_rec_type_cons modules form_tvs [] _ conds_as = (cIsHyperStrict, conds_as) - anal_types_of_rec_type_cons modules form_tvs [type : types] [(KindVar kind_info_ptr) : tvs] conds_as + anal_types_of_rec_type_cons modules form_tvs [type : types] [KindVar kind_info_ptr : tvs] 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 - # (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 }) + # (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 }) + # conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds] + # (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) where is_type_var {at_type = TV _} = True is_type_var _ = False - + anal_types_of_type_cons modules form_tvs [] _ conds_as = (cIsHyperStrict, conds_as) anal_types_of_type_cons modules form_tvs [type : types] [tk : tks] conds_as @@ -547,17 +546,9 @@ where (tks, is_non_coercible, conds_as) = check_type_list kind_var modules form_tvs types conds_as = (KI_Arrow 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_type_var_heap,as_kind_heap}) - # (as_type_var_heap, as_kind_heap) = new_local_kind_variables vars as_type_var_heap as_kind_heap - = analTypes has_root_attr modules form_tvs type (conds, { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap}) - where - new_local_kind_variables :: [ATypeVar] !*TypeVarHeap !*KindHeap -> (!*TypeVarHeap,!*KindHeap) - new_local_kind_variables type_vars type_var_heap as_kind_heap - = foldSt new_kind type_vars (type_var_heap, as_kind_heap) - where - new_kind :: !ATypeVar !(!*TypeVarHeap,!*KindHeap) -> (!*TypeVarHeap,!*KindHeap) - new_kind {atv_variable={tv_info_ptr}} (type_var_heap, kind_heap) - # (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)) + # (as_type_var_heap, as_kind_heap) = new_local_kind_variables_for_universal_vars vars as_type_var_heap as_kind_heap + as = {as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap} + = analTypes has_root_attr modules form_tvs type (conds,as) analTypes has_root_attr modules form_tvs type conds_as = (KI_Const, cIsHyperStrict, conds_as) @@ -603,8 +594,7 @@ where cons_props = if (arg_is_strict strictness_index args_strictness) (combineTypeProperties cv_props other_type_props) (combineCoercionProperties cv_props other_type_props) - = (cons_props, (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })) -// ---> ("anal_types_of_cons", type) + = (cons_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error})) isATopConsVar cv :== cv < 0 encodeTopConsVar cv :== dec (~cv) @@ -612,61 +602,61 @@ decodeTopConsVar cv :== ~(inc cv) emptyIdent name :== { id_name = name, id_info = nilPtr } -newKindVariables td_args (type_var_heap, as_kind_heap) - = mapSt new_kind td_args (type_var_heap, as_kind_heap) -where - new_kind :: ATypeVar *(*TypeVarHeap,*KindHeap) -> (!.TypeKind,!(!*TypeVarHeap,!*KindHeap)); - new_kind {atv_variable={tv_info_ptr}} (type_var_heap, kind_heap) - # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap - = (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))) - analyseTypeDefs :: !{#CommonDefs} !TypeGroups !{#CheckedTypeDef} !Int !*TypeDefInfos !*TypeVarHeap !*ErrorAdmin - -> (!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin) + -> (!*TypeDefInfos,!*TypeVarHeap,!*ErrorAdmin) analyseTypeDefs modules groups dcl_types dcl_mod_index type_def_infos type_var_heap error - # as = { as_kind_heap = newHeap, as_type_var_heap = type_var_heap, as_td_infos = type_def_infos, as_error = error } + # as = {as_kind_heap = newHeap, as_type_var_heap = type_var_heap, as_td_infos = type_def_infos, as_error = error} {as_td_infos,as_type_var_heap,as_error} = foldSt (anal_type_defs_in_group modules) groups as = check_left_root_attribution_of_typedefs modules groups as_td_infos as_type_var_heap as_error where anal_type_defs_in_group modules group as=:{as_td_infos,as_type_var_heap,as_kind_heap} # (is_abstract_type, as_td_infos, as_type_var_heap, as_kind_heap) = foldSt (init_type_def_infos modules) group (False, as_td_infos, as_type_var_heap, as_kind_heap) - as = { as & as_td_infos = as_td_infos, as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap } + as = {as & as_td_infos = as_td_infos, as_type_var_heap = as_type_var_heap, 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) + # (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 + 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 modules type_properties normalized_top_vars group - kinds_in_group kind_var_store as_kind_heap as_td_infos - as = { as & as_kind_heap = as_kind_heap, as_td_infos = as_td_infos } - as = foldSt (check_dcl_properties modules dcl_types dcl_mod_index type_properties) group as - = as + (as_kind_heap, as_td_infos) + = update_type_def_infos modules 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 + = foldSt (check_dcl_properties modules dcl_types dcl_mod_index type_properties) group as init_type_def_infos modules gi=:{gi_module,gi_index} (is_abstract_type, type_def_infos, as_type_var_heap, 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}, as_type_var_heap, kind_heap) + # type_def_infos = init_abstract_type_def properties td_args gi_module gi_index type_def_infos + -> (True, type_def_infos, as_type_var_heap, kind_heap) AbstractSynType 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}, as_type_var_heap, kind_heap) + # type_def_infos = init_abstract_type_def properties td_args gi_module gi_index type_def_infos + -> (True, type_def_infos, as_type_var_heap, kind_heap) _ # (tdi_kinds, (as_type_var_heap, kind_heap)) = newKindVariables td_args (as_type_var_heap, kind_heap) - -> (is_abstract_type, { type_def_infos & [gi_module].[gi_index].tdi_kinds = tdi_kinds }, as_type_var_heap, kind_heap) + -> (is_abstract_type, {type_def_infos & [gi_module].[gi_index].tdi_kinds = tdi_kinds}, as_type_var_heap, kind_heap) + + init_abstract_type_def properties td_args gi_module gi_index type_def_infos + # (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 } + = {type_def_infos & [gi_module].[gi_index] = new_tdi} + + newKindVariables td_args (type_var_heap, as_kind_heap) + = mapSt new_kind td_args (type_var_heap, as_kind_heap) + where + new_kind :: ATypeVar *(*TypeVarHeap,*KindHeap) -> (!TypeKind,!(!*TypeVarHeap,!*KindHeap)); + new_kind {atv_variable={tv_info_ptr}} (type_var_heap, kind_heap) + # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap + = (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))) 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_ident,td_pos,td_args,td_rhs} = com_type_defs.[gi_index] as_error = pushErrorAdmin (newPosition td_ident 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 }) + (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 @@ -676,7 +666,7 @@ where anal_rhs_of_type_def modules _ (SynType type) conds_as # (type_kind, cv_props, (conds, as=:{as_kind_heap, as_error})) = analTypes True /* cDummyBool */ modules [] type.at_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 = uki_kind_heap, as_error = uki_error })) + = (cv_props, (conds, {as & as_kind_heap = uki_kind_heap, as_error = uki_error})) anal_rhs_of_type_def modules com_cons_defs (NewType cons) conds_as = analTypesOfConstructor modules com_cons_defs cons conds_as @@ -714,13 +704,13 @@ where determine_var_bind kind_info_ptr kind_info kind_heap = (kind_info_ptr, kind_heap) - nomalize_var :: !KindInfoPtr !KindInfo !(!Int,!*KindHeap) -> (!Int,!(!Int,!*KindHeap)) - nomalize_var orig_kind_info (KI_VarBind kind_info_ptr) (kind_store, kind_heap) + normalize_var :: !KindInfoPtr !KindInfo !(!Int,!*KindHeap) -> (!Int,!(!Int,!*KindHeap)) + normalize_var orig_kind_info (KI_VarBind kind_info_ptr) (kind_store, kind_heap) # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap - = nomalize_var kind_info_ptr kind_info (kind_store, kind_heap) - nomalize_var kind_info_ptr (KI_NormVar var_number) (kind_store, kind_heap) + = normalize_var kind_info_ptr kind_info (kind_store, kind_heap) + normalize_var kind_info_ptr (KI_NormVar var_number) (kind_store, kind_heap) = (var_number, (kind_store, kind_heap)) - nomalize_var kind_info_ptr kind (kind_store, kind_heap) + normalize_var kind_info_ptr kind (kind_store, kind_heap) = (kind_store, (inc kind_store, writePtr kind_info_ptr (KI_NormVar kind_store) kind_heap)) normalize_top_vars top_vars kind_store kind_heap @@ -729,36 +719,35 @@ where normalize_top_var :: !KindInfoPtr !(!Int,!*KindHeap) -> (!Int,!(!Int,!*KindHeap)) normalize_top_var kind_info_ptr (kind_store, kind_heap) # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap - = nomalize_var kind_info_ptr kind_info (kind_store, kind_heap) - + = normalize_var kind_info_ptr kind_info (kind_store, kind_heap) + update_type_def_infos modules 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 modules (type_properties bitor cIsAnalysed) top_vars) group updated_kinds_of_group (kind_store, kind_heap, td_infos) - = (as_kind_heap, as_td_infos) + # (_,as_kind_heap,as_td_infos) = fold2St (update_type_def_info modules (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 modules type_properties top_vars {gi_module,gi_index} updated_kinds - (kind_store, kind_heap, td_infos) -// # {com_type_defs} = modules.[gi_module] -// {td_ident} = com_type_defs.[gi_index] - # (td_info=:{tdi_kinds}, td_infos) = td_infos![gi_module].[gi_index] // ---> ("update_type_def_info", td_ident, type_properties) + (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 }}) + # td_info & tdi_properties = type_properties, tdi_kinds = updated_kinds, tdi_group_vars = group_vars, tdi_cons_vars = cons_vars + #! td_infos & [gi_module,gi_index] = td_info + = (kind_store, kind_heap, td_infos) - determine_type_def_info [ KindVar kind_info_ptr : kind_vars ] [ kind : kinds ] top_vars kind_store kind_heap + determine_type_def_info [KindVar kind_info_ptr : kind_vars] [kind : kinds] top_vars kind_store kind_heap # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap - # (var_number, (kind_store, kind_heap)) = nomalize_var kind_info_ptr kind_info (kind_store, kind_heap) + # (var_number, (kind_store, kind_heap)) = normalize_var kind_info_ptr kind_info (kind_store, kind_heap) (group_vars, cons_vars, kind_store, kind_heap) = determine_type_def_info kind_vars kinds top_vars kind_store kind_heap = case kind of KindArrow _ | is_a_top_var var_number top_vars - -> ([ var_number : group_vars ], [ encodeTopConsVar var_number : cons_vars ], kind_store, kind_heap) - -> ([ var_number : group_vars ], [ var_number : cons_vars ], kind_store, kind_heap) + -> ([var_number : group_vars], [encodeTopConsVar var_number : cons_vars], kind_store, kind_heap) + -> ([var_number : group_vars], [var_number : cons_vars], kind_store, kind_heap) _ - -> ([ var_number : group_vars ], cons_vars, kind_store, kind_heap) + -> ([var_number : group_vars], cons_vars, kind_store, kind_heap) determine_type_def_info [] [] top_vars kind_store kind_heap = ([], [], kind_store, kind_heap) - is_a_top_var var_number [ top_var_number : top_var_numbers] + is_a_top_var var_number [top_var_number : top_var_numbers] = var_number == top_var_number || is_a_top_var var_number top_var_numbers is_a_top_var var_number [] = False @@ -776,17 +765,16 @@ where with check_abstract_type spec_properties td_ident td_args td_pos as # as_error = pushErrorAdmin (newPosition td_ident td_pos) as.as_error - | check_coercibility spec_properties properties -// ---> ("check_coercibility", td_ident, spec_properties, properties) + | check_coercibility spec_properties properties | check_hyperstrictness spec_properties properties | spec_properties bitand cIsNonCoercible == 0 # (as_type_var_heap, as_td_infos, as_error) = check_positive_sign gi_module gi_index modules td_args as.as_type_var_heap as.as_td_infos as_error = {as & as_type_var_heap = as_type_var_heap, as_td_infos = as_td_infos, as_error = popErrorAdmin as_error} = {as & as_error = popErrorAdmin as_error} - # as_error = checkError "abstract type as defined in the implementation module is not hyperstrict" "" as_error - = { as & as_error = popErrorAdmin as_error } - # as_error = checkError "abstract type as defined in the implementation module is not coercible" "" as_error - = { as & as_error = popErrorAdmin as_error } + # as_error = checkError "abstract type as defined in the implementation module is not hyperstrict" "" as_error + = {as & as_error = popErrorAdmin as_error} + # as_error = checkError "abstract type as defined in the implementation module is not coercible" "" as_error + = {as & as_error = popErrorAdmin as_error} = as where check_coercibility dcl_props icl_props @@ -794,7 +782,7 @@ where check_hyperstrictness dcl_props icl_props = dcl_props bitand cIsHyperStrict == 0 || icl_props bitand cIsHyperStrict > 0 - + check_positive_sign mod_index type_index modules td_args type_var_heap type_def_infos error # top_signs = [ TopSignClass \\ _ <- td_args ] # (signs, type_var_heap, type_def_infos) = signClassification type_index mod_index top_signs modules type_var_heap type_def_infos @@ -802,11 +790,9 @@ where = (type_var_heap, type_def_infos, error) # error = checkError "signs of abstract type variables should be positive" "" error = (type_var_heap, type_def_infos, error) - check_left_root_attribution_of_typedefs modules groups type_def_infos type_var_heap error - # (type_def_infos, type_var_heap, error) = foldSt (foldSt (checkLeftRootAttributionOfTypeDef modules)) groups (type_def_infos, type_var_heap, error) - = (type_def_infos, type_var_heap, error) + = foldSt (foldSt (checkLeftRootAttributionOfTypeDef modules)) groups (type_def_infos, type_var_heap, error) cDummyConditions =: { con_top_var_binds = [], con_var_binds = []} @@ -839,11 +825,11 @@ where determine_kinds_type_list :: !{#CommonDefs} [AType] !*AnalyseState -> *AnalyseState determine_kinds_type_list modules types as = foldSt (force_star_kind modules) types as -where - force_star_kind modules type as - # (off_kind, as=:{as_kind_heap,as_error}) = determineKind modules type as - {uki_kind_heap, uki_error} = unifyKinds off_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error} - = { as & as_kind_heap = uki_kind_heap, as_error = uki_error } + +force_star_kind modules type as + # (off_kind, as=:{as_kind_heap,as_error}) = determineKind modules type as + {uki_kind_heap, uki_error} = unifyKinds off_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error} + = { as & as_kind_heap = uki_kind_heap, as_error = uki_error } class_def_error = "cyclic dependencies between type classes" type_appl_error = "type constructor has too many arguments" @@ -907,8 +893,7 @@ where # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap = fresh_kind_vars (dec nr_of_vars) [ kind_info_ptr : fresh_vars] (kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr)) = (fresh_vars, kind_heap) - - + isCyclicClass [ KindCycle : _ ] = True isCyclicClass _ = False @@ -965,6 +950,15 @@ where # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap = kindInfoToKind kind_info kind_heap +new_local_kind_variables_for_universal_vars :: [ATypeVar] !*TypeVarHeap !*KindHeap -> (!*TypeVarHeap,!*KindHeap) +new_local_kind_variables_for_universal_vars type_vars type_var_heap as_kind_heap + = foldSt new_kind type_vars (type_var_heap, as_kind_heap) + where + new_kind :: !ATypeVar !(!*TypeVarHeap,!*KindHeap) -> (!*TypeVarHeap,!*KindHeap) + new_kind {atv_variable={tv_info_ptr}} (type_var_heap, kind_heap) + # (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)) + bindFreshKindVariablesToTypeVars :: [TypeVar] !*TypeVarHeap !*KindHeap -> (!*TypeVarHeap,!*KindHeap) bindFreshKindVariablesToTypeVars type_vars type_var_heap as_kind_heap = foldSt new_kind type_vars (type_var_heap, as_kind_heap) @@ -1079,14 +1073,13 @@ where = {as & as_error = as_error, as_td_infos = as_td_infos} where rank_of_kind KindConst = 0 - rank_of_kind (KindArrow kinds) = 1 + foldr max 0 (map rank_of_kind kinds) - + rank_of_kind (KindArrow kinds) = 1 + foldr max 0 (map rank_of_kind kinds) check_kinds_of_gencase gencase as = as check_kinds_of_icl_fuction common_defs fun_index (icl_fun_defs, class_infos, expression_heap, as) # ({fun_type,fun_ident,fun_info,fun_pos}, icl_fun_defs) = icl_fun_defs![fun_index] - (expression_heap, as) = check_kinds_of_dynamics common_defs fun_info.fi_dynamics expression_heap as + (expression_heap,as) = check_kinds_of_dynamics common_defs fun_info.fi_dynamics expression_heap as = case fun_type of Yes symbol_type # as_error = pushErrorAdmin (newPosition fun_ident fun_pos) as.as_error @@ -1104,14 +1097,14 @@ where check_kinds_of_dcl_fuction common_defs dcl_functions fun_index (class_infos, as) # {ft_type,ft_ident,ft_pos} = dcl_functions.[fun_index] as_error = pushErrorAdmin (newPosition ft_ident ft_pos) as.as_error - (class_infos, as) = check_kinds_of_symbol_type common_defs ft_type class_infos - { as & as_error = as_error } + (class_infos, as) = check_kinds_of_symbol_type common_defs ft_type class_infos {as & as_error = as_error} = (class_infos, { as & as_error = popErrorAdmin as.as_error}) check_kinds_of_symbol_type :: !{#CommonDefs} !SymbolType !*ClassDefInfos !*AnalyseState -> (!*ClassDefInfos, !*AnalyseState) check_kinds_of_symbol_type common_defs {st_vars,st_result,st_args,st_context} class_infos as=:{as_type_var_heap,as_kind_heap} # (as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars st_vars as_type_var_heap as_kind_heap - as = determine_kinds_type_list common_defs [st_result:st_args] { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap} + as = {as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap} + as = determine_kinds_type_list common_defs [st_result:st_args] as = determine_kinds_of_type_contexts common_defs st_context class_infos as check_kinds_of_dynamics :: {#CommonDefs} [DynamicPtr] *ExpressionHeap *AnalyseState -> (*ExpressionHeap, *AnalyseState) @@ -1119,21 +1112,18 @@ where = foldSt (check_kinds_of_dynamic common_defs) dynamic_ptrs (expr_heap, as) where check_kinds_of_dynamic :: {#CommonDefs} DynamicPtr (*ExpressionHeap, *AnalyseState) -> (*ExpressionHeap, *AnalyseState) - check_kinds_of_dynamic common_defs dynamic_ptr (expr_heap, as) + check_kinds_of_dynamic common_defs dynamic_ptr (expr_heap,as) # (dynamic_info, expr_heap) = readPtr dynamic_ptr expr_heap - (expr_heap, as) = check_kinds_of_dynamic_info common_defs dynamic_info (expr_heap, as) - = (expr_heap, as) + = check_kinds_of_dynamic_info common_defs dynamic_info (expr_heap, as) check_kinds_of_dynamic_info :: {#CommonDefs} ExprInfo (*ExpressionHeap, *AnalyseState) -> (*ExpressionHeap, *AnalyseState) check_kinds_of_dynamic_info common_defs (EI_Dynamic opt_type locals) (expr_heap, as) # as = check_kinds_of_opt_dynamic_type common_defs opt_type as - (expr_heap, as) = check_kinds_of_dynamics common_defs locals expr_heap as - = (expr_heap, as) + = check_kinds_of_dynamics common_defs locals expr_heap as check_kinds_of_dynamic_info common_defs (EI_DynamicTypeWithVars vars type locals) (expr_heap, as=:{as_type_var_heap,as_kind_heap}) # (as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars vars as_type_var_heap as_kind_heap as = check_kinds_of_dynamic_type common_defs type { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap} - (expr_heap, as) = check_kinds_of_dynamics common_defs locals expr_heap as - = (expr_heap, as) + = check_kinds_of_dynamics common_defs locals expr_heap as check_kinds_of_opt_dynamic_type :: {#CommonDefs} (Optional DynamicType) *AnalyseState -> *AnalyseState check_kinds_of_opt_dynamic_type common_defs (Yes type) as @@ -1143,9 +1133,7 @@ where check_kinds_of_dynamic_type :: {#CommonDefs} DynamicType *AnalyseState -> *AnalyseState check_kinds_of_dynamic_type common_defs {dt_type, dt_uni_vars, dt_global_vars} as=:{as_type_var_heap,as_kind_heap} - # (as_type_var_heap, as_kind_heap) - = bindFreshKindVariablesToTypeVars [atv_variable \\ {atv_variable} <- dt_uni_vars] - as_type_var_heap as_kind_heap + # (as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars [atv_variable \\ {atv_variable} <- dt_uni_vars] as_type_var_heap as_kind_heap (as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars dt_global_vars as_type_var_heap as_kind_heap = determine_kinds_type_list common_defs [dt_type] { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap} @@ -1169,7 +1157,7 @@ checkLeftRootAttributionOfTypeDef common_defs {gi_module,gi_index} (td_infos, th = (td_infos, th_vars, checkErrorWithIdentPos (newPosition td_ident td_pos) " left root * attribute expected" error) = (td_infos, th_vars, error) - + isUniqueTypeRhs common_defs mod_index (AlgType constructors) state = has_unique_constructor constructors common_defs mod_index state isUniqueTypeRhs common_defs mod_index (SynType rhs) state @@ -1215,8 +1203,7 @@ instance isUnique Type isUnique_for_TA :: Int Int [AType] !{# CommonDefs} !*TypeDefInfos !*TypeVarHeap -> (!Bool, !(!*TypeDefInfos, !*TypeVarHeap)) isUnique_for_TA glob_module glob_object type_args common_defs td_infos th_vars - # type_def - = common_defs.[glob_module].com_type_defs.[glob_object] + # 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) |