aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--frontend/analtypes.dcl3
-rw-r--r--frontend/analtypes.icl53
-rw-r--r--frontend/analunitypes.icl11
-rw-r--r--frontend/checktypes.icl33
-rw-r--r--frontend/frontend.icl6
-rw-r--r--frontend/refmark.icl2
-rw-r--r--frontend/syntax.dcl2
-rw-r--r--frontend/syntax.icl3
-rw-r--r--frontend/type.icl5
-rw-r--r--frontend/typesupport.icl2
-rw-r--r--frontend/unitype.icl16
11 files changed, 101 insertions, 35 deletions
diff --git a/frontend/analtypes.dcl b/frontend/analtypes.dcl
index 3edafa8..6036b24 100644
--- a/frontend/analtypes.dcl
+++ b/frontend/analtypes.dcl
@@ -7,7 +7,8 @@ partionateAndExpandTypes :: !NumberSet !Index !*CommonDefs !*{#DclModule} !*Type
:: TypeGroups :== [[GlobalIndex]]
-analyseTypeDefs :: !{#CommonDefs} !TypeGroups !*TypeDefInfos !*TypeVarHeap !*ErrorAdmin -> (!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin)
+analyseTypeDefs :: !{#CommonDefs} !TypeGroups !{#CheckedTypeDef} !Int !*TypeDefInfos !*TypeVarHeap !*ErrorAdmin
+ -> (!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin)
determineKindsOfClasses :: !NumberSet !{#CommonDefs} !*TypeDefInfos !*TypeVarHeap !*ErrorAdmin
-> (!*ClassDefInfos, !*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin)
diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl
index 906defc..6f410b7 100644
--- a/frontend/analtypes.icl
+++ b/frontend/analtypes.icl
@@ -533,8 +533,9 @@ where
# (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 !*TypeDefInfos !*TypeVarHeap !*ErrorAdmin -> (!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin)
-analyseTypeDefs modules groups type_def_infos type_var_heap error
+analyseTypeDefs :: !{#CommonDefs} !TypeGroups !{#CheckedTypeDef} !Int !*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_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
@@ -546,10 +547,12 @@ where
| is_abstract_type
= as
# (type_properties, conds, as) = foldSt (anal_type_def modules) group (cIsHyperStrict, { con_top_var_binds = [], con_var_binds = [] }, as)
+ as = foldSt (check_dcl_properties modules dcl_types dcl_mod_index type_properties) group 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_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, as_type_var_heap, kind_heap)
@@ -583,7 +586,7 @@ where
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
+ # (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 = as_kind_heap, as_error = as_error }))
@@ -639,11 +642,11 @@ where
= nomalize_var kind_info_ptr kind_info (kind_store, kind_heap)
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) = 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)
+ 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] =
@@ -662,12 +665,42 @@ where
-> ([ 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]
= var_number == top_var_number || is_a_top_var var_number top_var_numbers
is_a_top_var var_number []
= False
+ check_dcl_properties modules dcl_types dcl_mod_index properties {gi_module, gi_index} as
+ | gi_module == dcl_mod_index && gi_index < size dcl_types
+ # {td_rhs} = dcl_types.[gi_index]
+ = case td_rhs of
+ AbstractType spec_properties
+ | equivalent_properties spec_properties properties
+ | spec_properties bitand cIsNonCoercible == 0
+ # (as_type_var_heap, as_td_infos, as_error) = check_possitive_sign gi_module gi_index modules as.as_type_var_heap as.as_td_infos as.as_error
+ = {as & as_type_var_heap = as_type_var_heap, as_td_infos = as_td_infos, as_error = as_error}
+ # as_error = checkError "abstract type properties conflict with derived properties in implementation module" "" as.as_error
+ = { as & as_error = as_error }
+ _
+ = as
+ = as
+ where
+ equivalent_properties icl_props dcl_props
+ | icl_props bitand cIsNonCoercible > 0 && dcl_props bitand cIsNonCoercible == 0
+ = False
+ | dcl_props bitand cIsHyperStrict > 0 && icl_props bitand cIsHyperStrict == 0
+ = False
+ = True
+
+ check_possitive_sign mod_index type_index modules type_var_heap type_def_infos error
+ # (signs, type_var_heap, type_def_infos) = signClassification mod_index type_index [] modules type_var_heap type_def_infos
+ | signs.sc_neg_vect == 0
+ = (type_var_heap, type_def_infos, error)
+ # error = checkError "abstract type properties conflict with derived properties in implementation module" "" 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)
@@ -888,8 +921,10 @@ where
# as_error = pushErrorAdmin (newPosition ins_ident ins_pos) as_error
(as_type_var_heap, as_kind_heap) = bindFreshKindVariablesToTypeVars it_vars as_type_var_heap as_kind_heap
as = { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap, as_error = as_error }
+ context = {tc_class = TCClass ins_class, tc_types = it_types, tc_var = nilPtr}
(class_infos, as) = determine_kinds_of_type_contexts common_defs
- [{tc_class = TCClass ins_class, tc_types = it_types, tc_var = nilPtr} : it_context] class_infos as
+ [ context : it_context] class_infos as
+// ---> ("check_kinds_of_class_instance", context.tc_class, context.tc_types)
= (class_infos, { as & as_error = popErrorAdmin as.as_error})
check_kinds_of_generics common_defs index generic_defs class_infos gen_heap as
diff --git a/frontend/analunitypes.icl b/frontend/analunitypes.icl
index 0e7db0c..a39f63e 100644
--- a/frontend/analunitypes.icl
+++ b/frontend/analunitypes.icl
@@ -35,8 +35,10 @@ signClassification :: !Index !Index ![SignClassification] !{# CommonDefs } !*Typ
-> (!SignClassification, !*TypeVarHeap, !*TypeDefInfos)
signClassification type_index module_index hio_signs defs type_var_heap td_infos
# (td_info, td_infos) = td_infos![module_index].[type_index]
- = determineSignClassOfTypeDef type_index module_index td_info hio_signs defs type_var_heap td_infos
-// ---> ("signClassification", defs.[module_index].com_type_defs.[type_index].td_name)
+ # (tsp_sign, type_var_heap, td_infos)
+ = determineSignClassOfTypeDef type_index module_index td_info hio_signs defs type_var_heap td_infos
+ = (tsp_sign, type_var_heap, td_infos)
+// ---> ("signClassification", defs.[module_index].com_type_defs.[type_index].td_name, tsp_sign)
removeTopClasses [cv : cvs] [tc : tcs]
@@ -320,7 +322,10 @@ propClassification type_index module_index hio_props defs type_var_heap td_infos
# (td_info, td_infos) = td_infos![module_index].[type_index]
| td_info.tdi_group_nr== (-1) // is an exported dictionary ?
= (0, type_var_heap, td_infos)
- = determinePropClassOfTypeDef type_index module_index td_info hio_props defs type_var_heap td_infos
+ # (tsp_prop, type_var_heap, td_infos)
+ = determinePropClassOfTypeDef type_index module_index td_info hio_props defs type_var_heap td_infos
+ = (tsp_prop, type_var_heap, td_infos)
+// ---> ("propClassification", defs.[module_index].com_type_defs.[type_index].td_name, tsp_prop)
determinePropClassOfTypeDef :: !Int !Int !TypeDefInfo ![PropClassification] !{# CommonDefs} !*TypeVarHeap !*TypeDefInfos
-> (!PropClassification,!*TypeVarHeap, !*TypeDefInfos)
diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl
index b8c1f13..0825905 100644
--- a/frontend/checktypes.icl
+++ b/frontend/checktypes.icl
@@ -452,21 +452,27 @@ checkTypeVar scope dem_attr tv=:{tv_name=var_name=:{id_name,id_info}} tv_attr (o
# (entry=:{ste_kind,ste_def_level},cs_symbol_table) = readPtr id_info cs_symbol_table
| ste_kind == STE_Empty || ste_def_level == cModuleScope
# (new_attr, oti=:{oti_heaps,oti_all_vars}, cs) = newAttribute dem_attr id_name tv_attr oti { cs & cs_symbol_table = cs_symbol_table }
- (new_var_ptr, th_vars) = newPtr (TVI_Attribute new_attr) oti_heaps.th_vars
+ (new_var_ptr, th_vars) = newPtr (TVI_AttrAndRefCount new_attr 1) oti_heaps.th_vars
new_var = { tv & tv_info_ptr = new_var_ptr }
= (new_var, new_attr, ({ oti & oti_heaps = { oti_heaps & th_vars = th_vars }, oti_all_vars = [new_var : oti_all_vars]},
{ cs & cs_symbol_table = cs.cs_symbol_table <:= (id_info, {ste_index = NoIndex, ste_kind = STE_TypeVariable new_var_ptr,
ste_def_level = scope, ste_previous = entry })}))
# (STE_TypeVariable tv_info_ptr) = ste_kind
{oti_heaps} = oti
- (var_info, th_vars) = readPtr tv_info_ptr oti_heaps.th_vars
- (var_attr, oti, cs) = check_attribute id_name dem_attr var_info tv_attr { oti & oti_heaps = { oti_heaps & th_vars = th_vars }}
+ (tv_info, th_vars) = readPtr tv_info_ptr oti_heaps.th_vars
+ th_vars = incr_ref_count tv_info_ptr tv_info th_vars
+ (var_attr, oti, cs) = check_attribute id_name dem_attr tv_info tv_attr { oti & oti_heaps = { oti_heaps & th_vars = th_vars }}
{ cs & cs_symbol_table = cs_symbol_table }
= ({ tv & tv_info_ptr = tv_info_ptr }, var_attr, (oti, cs))
where
- check_attribute var_name DAK_Ignore (TVI_Attribute prev_attr) this_attr oti cs=:{cs_error}
+ incr_ref_count tv_info_ptr (TVI_AttrAndRefCount prev_attr ref_count) th_vars
+ = th_vars <:= (tv_info_ptr, TVI_AttrAndRefCount prev_attr (inc ref_count))
+ incr_ref_count tv_info_ptr _ th_vars
+ = th_vars
+
+ check_attribute var_name DAK_Ignore (TVI_AttrAndRefCount prev_attr ref_count) this_attr oti cs=:{cs_error}
= (TA_Multi, oti, cs)
- check_attribute var_name dem_attr (TVI_Attribute prev_attr) this_attr oti cs=:{cs_error}
+ check_attribute var_name dem_attr (TVI_AttrAndRefCount prev_attr ref_count) this_attr oti cs=:{cs_error}
# (new_attr, cs_error) = determine_attribute var_name dem_attr this_attr cs_error
= check_var_attribute prev_attr new_attr oti { cs & cs_error = cs_error }
where
@@ -622,7 +628,7 @@ where
# (entry=:{ste_kind,ste_def_level},cs_symbol_table) = readPtr id_info cs_symbol_table
| ste_kind == STE_Empty || ste_def_level < cRankTwoScope
# (new_attr, oti=:{oti_heaps}, cs) = newAttribute DAK_None id_name atv_attribute oti { cs & cs_symbol_table = cs_symbol_table }
- (new_var_ptr, th_vars) = newPtr (TVI_Attribute new_attr) oti_heaps.th_vars
+ (new_var_ptr, th_vars) = newPtr (TVI_AttrAndRefCount new_attr 1) oti_heaps.th_vars
= ({atv & atv_variable = { tv & tv_info_ptr = new_var_ptr}, atv_attribute = new_attr },
({ oti & oti_heaps = { oti_heaps & th_vars = th_vars }}, { cs & cs_symbol_table =
cs.cs_symbol_table <:= (id_info, {ste_index = NoIndex, ste_kind = STE_TypeVariable new_var_ptr,
@@ -657,7 +663,8 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de
oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars= [] }
(it_types, (ots, oti=:{oti_all_vars = it_vars, oti_all_attrs = it_attr_vars}, cs))
= checkOpenTypes mod_index cGlobalScope DAK_None it_types (ots, oti, { cs & cs_error = cs_error })
- oti = { oti & oti_all_vars = [], oti_all_attrs = [] }
+ (heaps, cs) = check_linearity_of_type_vars it_vars oti.oti_heaps cs
+ oti = { oti & oti_all_vars = [], oti_all_attrs = [], oti_heaps = heaps }
(it_context, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts it_context mod_index class_defs ots oti cs
cs_error = foldSt (compare_context_and_instance_types ins_class it_types) it_context cs.cs_error
(specials, cs) = checkSpecialTypeVars specials { cs & cs_error = cs_error }
@@ -675,6 +682,18 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de
is_type_var (TV _) = True
is_type_var _ = False
+ check_linearity_of_type_vars vars heaps=:{th_vars} cs=:{cs_error}
+ # (th_vars, cs_error) = foldSt check_linearity vars (th_vars, cs_error)
+ = ({heaps & th_vars = th_vars}, {cs & cs_error = cs_error})
+ where
+ check_linearity {tv_name, tv_info_ptr} (th_vars, error)
+ # (TVI_AttrAndRefCount prev_attr ref_count, th_vars) = readPtr tv_info_ptr th_vars
+ | ref_count > 1
+ = (th_vars, checkError tv_name ": this type variable occurs more than once in an instance type" error)
+ = (th_vars, error)
+
+
+
compare_context_and_instance_types ins_class it_types {tc_class=TCGeneric _, tc_types} cs_error
= cs_error
compare_context_and_instance_types ins_class it_types {tc_class=TCClass clazz, tc_types} cs_error
diff --git a/frontend/frontend.icl b/frontend/frontend.icl
index f61feb6..9982011 100644
--- a/frontend/frontend.icl
+++ b/frontend/frontend.icl
@@ -98,8 +98,10 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an
# (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, th_vars, error_admin) = analyseTypeDefs ti_common_defs type_groups td_infos type_heaps.th_vars error_admin
+// ti_common_defs = { ti_common_defs & [main_dcl_module_n] = icl_common }
+// # (td_infos, th_vars, error_admin) = analyseTypeDefs ti_common_defs type_groups td_infos type_heaps.th_vars error_admin
+ ({com_type_defs}, ti_common_defs) = replace ti_common_defs main_dcl_module_n icl_common
+ # (td_infos, th_vars, error_admin) = analyseTypeDefs ti_common_defs type_groups com_type_defs main_dcl_module_n td_infos type_heaps.th_vars error_admin
# (class_infos, td_infos, th_vars, error_admin)
= determineKindsOfClasses icl_used_module_numbers ti_common_defs td_infos th_vars error_admin
# (fun_defs, dcl_mods, td_infos, th_vars, hp_expression_heap, gen_heap, error_admin)
diff --git a/frontend/refmark.icl b/frontend/refmark.icl
index 9c5c5d4..0232978 100644
--- a/frontend/refmark.icl
+++ b/frontend/refmark.icl
@@ -366,7 +366,7 @@ refMarkOfCase free_vars sel def {case_expr, case_guards=OverloadedListPatterns t
refMarkOfCase free_vars sel def {case_expr, case_guards=DynamicPatterns patterns,case_default,case_explicit} rms=:{rms_var_heap}
# (def, all_closed_let_vars, rms) = refMarkOfDefault case_explicit free_vars sel def case_expr case_default [] { rms & rms_var_heap = rms_var_heap }
- (pattern_depth, used_lets, rms) = foldSt (ref_mark_of_dynamic_pattern free_vars sel def case_expr) patterns (0, all_closed_let_vars, rms)
+ (pattern_depth, all_closed_let_vars, rms) = foldSt (ref_mark_of_dynamic_pattern free_vars sel def case_expr) patterns (0, all_closed_let_vars, rms)
(let_vars_in_default, rms_var_heap) = addRefMarkOfDefault pattern_depth free_vars def rms.rms_var_heap
rms_var_heap = setUsedLetVars [let_vars_in_default : all_closed_let_vars] rms_var_heap
rms_var_heap = parCombine free_vars rms_var_heap
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index af12d3d..d1142ed 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -964,7 +964,7 @@ cNonRecursiveAppl :== False
| TVI_TypeVar !TypeVarInfoPtr // Sjaak: to collect and check universally quantified type variables
| TVI_Forward !TempVarId | TVI_TypeKind !KindInfoPtr
| TVI_SignClass !Index !SignClassification !TypeVarInfo | TVI_PropClass !Index !PropClassification !TypeVarInfo
- | TVI_Attribute TypeAttribute
+ | TVI_AttrAndRefCount !TypeAttribute !Int
| TVI_CorrespondenceNumber !Int /* auxiliary used in module comparedefimp */
| TVI_AType !AType /* auxiliary used in module comparedefimp */
| TVI_Used /* to administer that this variable is encountered (in checkOpenTypes) */
diff --git a/frontend/syntax.icl b/frontend/syntax.icl
index 5faa466..2efe053 100644
--- a/frontend/syntax.icl
+++ b/frontend/syntax.icl
@@ -812,6 +812,7 @@ where
(<<<) file (LinePos file_name line) = file <<< '[' <<< file_name <<< ',' <<< line <<< ']'
(<<<) file _ = file
+
instance <<< TypeVarInfo
where
(<<<) file TVI_Empty = file <<< "TVI_Empty"
@@ -819,7 +820,7 @@ where
(<<<) file (TVI_TypeVar ptr) = file <<< (ptrToInt ptr)
(<<<) file (TVI_Forward _) = file <<< "TVI_Forward"
(<<<) file (TVI_SignClass _ _ _) = file <<< "TVI_SignClass"
- (<<<) file (TVI_Attribute ta) = file <<< "TVI_Attribute " <<< ta
+ (<<<) file (TVI_AttrAndRefCount ta rc) = file <<< "TVI_AttrAndRefCount " <<< ta <<< " " <<< rc
(<<<) file (TVI_CorrespondenceNumber n) = file <<< "TVI_CorrespondenceNumber " <<< n
(<<<) file (TVI_AType at) = file <<< "TVI_AType " <<< at
(<<<) file TVI_Used = file <<< "TVI_Used"
diff --git a/frontend/type.icl b/frontend/type.icl
index 4ded1b0..73fb624 100644
--- a/frontend/type.icl
+++ b/frontend/type.icl
@@ -1864,7 +1864,10 @@ where
(th_vars, ts_expr_heap) = clear_dynamics fi_dynamics (prop_type_heaps.th_vars, ts.ts_expr_heap)
(fresh_fun_type, ts) = freshSymbolType No cWithoutFreshContextVars ft_with_prop common_defs { ts & ts_type_heaps = { prop_type_heaps & th_vars = th_vars }, ts_expr_heap = ts_expr_heap,
ts_td_infos = prop_td_infos, ts_error = ts_error }
- (lifted_args, ts) = fresh_non_unique_type_variables fun_lifted [] ts
+// (lifted_args, ts) = fresh_non_unique_type_variables fun_lifted [] ts
+ (lifted_args, ts) = fresh_attributed_type_variables fun_lifted [] ts
+
+
(ts_var_store, ts_type_heaps, ts_var_heap, ts_expr_heap, pre_def_symbols)
= fresh_dynamics fi_dynamics (ts.ts_var_store, ts.ts_type_heaps, ts.ts_var_heap, ts.ts_expr_heap, pre_def_symbols)
= (pre_def_symbols,
diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl
index 53f8373..244b8fd 100644
--- a/frontend/typesupport.icl
+++ b/frontend/typesupport.icl
@@ -43,6 +43,8 @@ simplifyTypeApplication (TB _) _
= (False, TE)
simplifyTypeApplication (TArrow1 _) _
= (False, TE)
+simplifyTypeApplication (_ --> _ ) _
+ = (False, TE)
diff --git a/frontend/unitype.icl b/frontend/unitype.icl
index 20189bd..a5f512f 100644
--- a/frontend/unitype.icl
+++ b/frontend/unitype.icl
@@ -5,8 +5,6 @@ import StdEnv
import syntax, analunitypes, type, utilities, checktypes,
compilerSwitches //, RWSDebug
-// import cheat
-
AttrUni :== 0
AttrMulti :== 1
/*
@@ -53,6 +51,7 @@ determineAttributeCoercions off_type dem_type coercible subst coercions defs con
(_, exp_dem_type, (subst, {es_td_infos,es_type_heaps})) = expandType defs cons_vars dem_type es
(result, {crc_type_heaps, crc_coercions, crc_td_infos}) = coerce (if coercible PositiveSign TopSign) defs cons_vars [] exp_off_type exp_dem_type
{ crc_type_heaps = es_type_heaps, crc_coercions = coercions, crc_td_infos = es_td_infos}
+
= case result of
No
-> (No, subst, crc_coercions, crc_td_infos, crc_type_heaps)
@@ -61,19 +60,17 @@ determineAttributeCoercions off_type dem_type coercible subst coercions defs con
/*
-
-
= case result of
No
- # (crc_coercions, copy_crc_coercions) = uniqueCopy crc_coercions
+ # (crc_coercions, copy_crc_coercions) = copyCoercions crc_coercions
format = { form_properties = cMarkAttribute, form_attr_position = Yes ([], copy_crc_coercions) }
- | file_to_true (stderr <:: (format, exp_off_type,No) <:: (format, exp_dem_type,No) <<< '\n')
- ---> ("determineAttributeCoercions (OK)", off_type, exp_off_type, ('\n', dem_type, exp_dem_type))
+ | file_to_true (stderr <:: (format, exp_off_type, No) <:: (format, exp_dem_type, No) <<< '\n')
+ ---> ("determineAttributeCoercions (OK)", off_type, exp_off_type, ('\n', dem_type, exp_dem_type))
-> (No, subst, crc_coercions, crc_td_infos, crc_type_heaps)
-> undef
// -> (No, subst, crc_coercions, crc_td_infos, crc_type_heaps)
Yes pos
- # (crc_coercions, copy_crc_coercions) = uniqueCopy crc_coercions
+ # (crc_coercions, copy_crc_coercions) = copyCoercions crc_coercions
format = { form_properties = cMarkAttribute, form_attr_position = Yes ([], copy_crc_coercions) }
| file_to_true (stderr <:: (format, exp_off_type,No) <:: (format, exp_dem_type,No) <<< '\n')
---> ("determineAttributeCoercions (NOK)", off_type, exp_off_type, ('\n', dem_type, exp_dem_type))
@@ -450,7 +447,8 @@ expandTempTypeVariable tv_number (subst, es)
IsArrowKind (KindArrow _) = True
IsArrowKind _ = False
-equal_type_prop {tsp_sign=sign0,tsp_propagation=prop0,tsp_coercible=coerc0} {tsp_sign=sign1,tsp_propagation=prop1,tsp_coercible=coerc1}
+equal_type_prop {tsp_sign=sign0,tsp_propagation=prop0,tsp_coercible=coerc0}
+ {tsp_sign=sign1,tsp_propagation=prop1,tsp_coercible=coerc1}
= prop0==prop1 && coerc0==coerc1 && sign0.sc_pos_vect==sign1.sc_pos_vect && sign0.sc_neg_vect==sign1.sc_neg_vect
instance expandType Type
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-15 00:48:26 +0000