aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--frontend/analtypes.icl16
-rw-r--r--frontend/analunitypes.icl17
-rw-r--r--frontend/checkKindCorrectness.icl20
3 files changed, 38 insertions, 15 deletions
diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl
index e225544..f68e216 100644
--- a/frontend/analtypes.icl
+++ b/frontend/analtypes.icl
@@ -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),
diff --git a/frontend/analunitypes.icl b/frontend/analunitypes.icl
index ab31866..695b28a 100644
--- a/frontend/analunitypes.icl
+++ b/frontend/analunitypes.icl
@@ -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)
diff --git a/frontend/checkKindCorrectness.icl b/frontend/checkKindCorrectness.icl
index 0228541..53abb0d 100644
--- a/frontend/checkKindCorrectness.icl
+++ b/frontend/checkKindCorrectness.icl
@@ -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)
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-16 13:32:55 +0000