Commit 4e2c02b3 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

universally quantified types added

parent fb09c605
......@@ -208,6 +208,18 @@ where
{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)
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})
where
new_local_kind_variables :: [ATypeVar] !(!*TypeVarHeap,!*KindHeap) -> (!*TypeVarHeap,!*KindHeap)
new_local_kind_variables td_args (type_var_heap, as_kind_heap)
= foldSt new_kind td_args (type_var_heap, as_kind_heap)
where
new_kind :: !ATypeVar !(!*TypeVarHeap,!*KindHeap) -> (!*TypeVarHeap,!*KindHeap)
new_kind {atv_variable={tv_info_ptr},atv_attribute} (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))
analTypes has_root_attr modules form_tvs type conds_as
= (cMAXINT, KI_Const, cIsHyperStrict, conds_as)
......@@ -228,11 +240,11 @@ 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] *(*Heap TypeVarInfo,*Heap KindInfo) -> (!Bool,!.Heap TypeVarInfo,!.Heap KindInfo);
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)
where
new_kind :: ATypeVar *(.Bool,*Heap TypeVarInfo,*Heap KindInfo) -> (!Bool,!.Heap TypeVarInfo,!.Heap KindInfo);
new_kind :: !ATypeVar !(!Bool,!*TypeVarHeap,!*KindHeap) -> (!Bool,!*TypeVarHeap,!*KindHeap)
new_kind {atv_variable={tv_info_ptr},atv_attribute} (coercible, type_var_heap, kind_heap)
# (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap
= (coercible && is_not_a_variable atv_attribute, type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr),
......
......@@ -299,20 +299,20 @@ signClassOfType (arg_type --> res_type) sign use_top_sign group_nr ci scs
(res_class, _, scs) = signClassOfType res_type.at_type PositiveSign use_top_sign group_nr ci scs
= (sign *+ (arg_class + res_class), BottomSignClass, scs)
signClassOfType (TFA vars type) sign use_top_sign group_nr ci scs
= signClassOfType type sign use_top_sign group_nr ci scs
signClassOfType type _ _ _ _ scs
= (BottomSignClass, BottomSignClass, scs)
propClassification :: !Index !Index ![PropClassification] !{# CommonDefs } !*TypeVarHeap !*TypeDefInfos
-> (!PropClassification, !*TypeVarHeap, !*TypeDefInfos)
propClassification type_index module_index hio_props defs type_var_heap td_infos
// MW3..
| type_index>=size td_infos.[module_index]
// must be a dictionary => doesn't propagate
| type_index >= size td_infos.[module_index]
= (0, type_var_heap, td_infos)
// ..MW3
# {td_args, td_name} = defs.[module_index].com_type_defs.[type_index]
(td_info, td_infos) = td_infos![module_index].[type_index]
= determinePropClassOfTypeDef type_index module_index td_args td_info hio_props defs type_var_heap td_infos
# {td_args, td_name} = defs.[module_index].com_type_defs.[type_index]
(td_info, td_infos) = td_infos![module_index].[type_index]
= determinePropClassOfTypeDef type_index module_index td_args td_info hio_props defs type_var_heap td_infos
determinePropClassOfTypeDef :: !Int !Int ![ATypeVar] !TypeDefInfo ![PropClassification] !{# CommonDefs} !*TypeVarHeap !*TypeDefInfos
-> (!PropClassification,!*TypeVarHeap, !*TypeDefInfos)
......@@ -542,6 +542,9 @@ where
prop_class_of_type_list [] _ _ _ _ cumm_class pcs
= (cumm_class, pcs)
propClassOfType (TFA vars type) group_nr ci pcs
= propClassOfType type group_nr ci pcs
propClassOfType _ _ _ pcs
= (NoPropClass, NoPropClass, pcs)
......@@ -72,7 +72,7 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs
check_class com_member_defs class_def=:{class_name, class_args, class_members}
(class_defs_accu, th_vars, td_infos, error_admin)
# th_vars
= foldSt init_type_var class_args th_vars
= init_type_vars class_args th_vars
(th_vars, td_infos, error_admin)
= foldlArraySt (\{ds_index} state
-> check_member_without_context class_args
......@@ -87,7 +87,7 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs
# error_admin
= setErrorAdmin (newPosition me_symb me_pos) error_admin
th_vars
= foldSt init_type_var st_vars th_vars
= init_type_vars st_vars th_vars
th_vars
= fold2St copy_TVI class_args me_class_vars th_vars
(th_vars, td_infos, error_admin)
......@@ -121,7 +121,7 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs
error_admin
= setErrorAdmin (newPosition ins_ident ins_pos) error_admin
th_vars
= foldSt init_type_var ins_type.it_vars th_vars
= init_type_vars ins_type.it_vars th_vars
(th_vars, td_infos, error_admin)
= unsafeFold3St possibly_check_type expected_kinds [1..]
ins_type.it_types (th_vars, td_infos, error_admin)
......@@ -223,7 +223,7 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs
# error_admin
= setErrorAdmin (newPosition fun_symb fun_pos) error_admin
th_vars
= foldSt init_type_var st_vars th_vars
= init_type_vars st_vars th_vars
(th_vars, td_infos, error_admin)
= unsafeFold2St (check_atype KindConst)
[0..] [st_result:st_args] (th_vars, td_infos, error_admin)
......@@ -291,6 +291,11 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs
# error_admin
= check_equality_of_kinds arg_nr expected_kind KindConst error_admin
= (th_vars, td_infos, error_admin)
// Sjaak ... 170801
check_type expected_kind arg_nr (TFA vars type) (th_vars, td_infos, error_admin)
# th_vars = init_type_vars [ atv_variable \\ {atv_variable} <- vars ] th_vars
= check_type expected_kind arg_nr type (th_vars, td_infos, error_admin)
// ... Sjaak 170801
check_context common_defs {tc_class, tc_types}
(bv_uninitialized_mods, th_vars, td_infos, error_admin)
......@@ -303,8 +308,11 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs
where
descending i = [i:descending (i-1)]
init_type_var {tv_info_ptr} th_vars
= writePtr tv_info_ptr TVI_Empty th_vars
init_type_vars vars tv_heap
= foldSt init_type_var vars tv_heap
where
init_type_var {tv_info_ptr} tv_heap
= tv_heap <:= (tv_info_ptr, TVI_Empty)
unify_var_kinds expected_kind tv=:{tv_name, tv_info_ptr} th_vars error_admin
# (tvi, th_vars)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment