aboutsummaryrefslogtreecommitdiff
path: root/frontend
diff options
context:
space:
mode:
Diffstat (limited to 'frontend')
-rw-r--r--frontend/check.icl15
-rw-r--r--frontend/expand_types.dcl5
-rw-r--r--frontend/expand_types.icl208
-rw-r--r--frontend/overloading.icl12
-rw-r--r--frontend/trans.icl52
-rw-r--r--frontend/typesupport.icl16
6 files changed, 179 insertions, 129 deletions
diff --git a/frontend/check.icl b/frontend/check.icl
index a17ad19..6ebb935 100644
--- a/frontend/check.icl
+++ b/frontend/check.icl
@@ -338,15 +338,14 @@ instantiateTypes old_type_vars old_attr_vars types type_contexts attr_env {ss_en
(new_attr_vars, th_attrs) = foldSt build_attr_var_subst ss_attrs ([], th_attrs)
type_heaps = foldSt build_type_subst ss_environ { type_heaps & th_vars = th_vars, th_attrs = th_attrs }
- (new_ss_context, type_heaps) = substitute ss_context type_heaps
+ (_, new_ss_context, type_heaps) = substitute ss_context type_heaps
(inst_vars, th_vars) = foldSt determine_free_var old_type_vars (new_type_vars, type_heaps.th_vars)
(inst_attr_vars, th_attrs) = foldSt build_attr_var_subst old_attr_vars (new_attr_vars, type_heaps.th_attrs)
(inst_types, (ok2, type_heaps)) = mapSt substitue_arg_type types (True, { type_heaps & th_vars = th_vars, th_attrs = th_attrs })
-// (ok2, inst_types, type_heaps) = substitute types { type_heaps & th_vars = th_vars, th_attrs = th_attrs }
- (inst_contexts, type_heaps) = substitute type_contexts type_heaps
- (inst_attr_env, type_heaps) = substitute attr_env type_heaps
+ (_, inst_contexts, type_heaps) = substitute type_contexts type_heaps
+ (_, inst_attr_env, type_heaps) = substitute attr_env type_heaps
(special_subst_list, th_vars) = mapSt adjust_special_subst special_subst_list type_heaps.th_vars
= (inst_vars, inst_attr_vars, inst_types, new_ss_context ++ inst_contexts, inst_attr_env, special_subst_list, { type_heaps & th_vars = th_vars }, error)
where
@@ -361,7 +360,7 @@ where
-> (free_vars, type_var_heap)
build_type_subst {bind_src,bind_dst} type_heaps
- # (bind_src, type_heaps) = substitute bind_src type_heaps
+ # (_, bind_src, type_heaps) = substitute bind_src type_heaps
// RWS ...
/*
FIXME: this is a patch for the following incorrect function type (in a dcl module)
@@ -382,10 +381,10 @@ where
substitue_arg_type at=:{at_type = TFA type_vars type} (was_ok, type_heaps)
# (fresh_type_vars, type_heaps) = foldSt build_avar_subst type_vars ([], type_heaps)
- (new_at, type_heaps) = substitute {at & at_type = type} type_heaps
+ (_, new_at, type_heaps) = substitute {at & at_type = type} type_heaps
= ({ new_at & at_type = TFA fresh_type_vars new_at.at_type}, (was_ok, type_heaps))
substitue_arg_type type (was_ok, type_heaps)
- # (type, type_heaps) = substitute type type_heaps
+ # (_, type, type_heaps) = substitute type type_heaps
= (type, (was_ok, type_heaps))
build_var_subst var (free_vars, type_var_heap)
@@ -2267,7 +2266,7 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m
(instance_types, icl_common, dcl_modules, hp_var_heap, hp_type_heaps, cs)
= checkIclInstances main_dcl_module_n icl_common dcl_modules hp_var_heap hp_type_heaps cs
-
+
heaps = { heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap }
e_info = { ef_type_defs = icl_common.com_type_defs, ef_selector_defs = icl_common.com_selector_defs, ef_class_defs = icl_common.com_class_defs,
diff --git a/frontend/expand_types.dcl b/frontend/expand_types.dcl
index ae7ac5e..fca50e8 100644
--- a/frontend/expand_types.dcl
+++ b/frontend/expand_types.dcl
@@ -33,11 +33,10 @@ class expandSynTypes a :: !Int !{#CommonDefs} !a !*ExpandTypeState -> (!Bool,!a,
instance expandSynTypes (a,b) | expandSynTypes a & expandSynTypes b special a=[AType],b=AType
-class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
+class substitute a :: !a !*TypeHeaps -> (!Bool, !a, !*TypeHeaps)
instance substitute Type,AType,TypeContext,AttrInequality,CaseType
-instance substitute [a] | substitute a special a=AType; a=AttrInequality; a=TypeContext
-instance substitute (a,b) | substitute a & substitute b special a=[AType],b=AType
+instance substitute [a] | substitute a special a=AType; a=TypeContext; a=AttrInequality
class removeAnnotations a :: !a -> (!Bool, !a)
diff --git a/frontend/expand_types.icl b/frontend/expand_types.icl
index a8e4cc4..f9591ec 100644
--- a/frontend/expand_types.icl
+++ b/frontend/expand_types.icl
@@ -261,10 +261,12 @@ where
= type_heaps
substitute_rhs rem_annots rhs_type type_heaps
- | (rem_annots bitand RemoveAnnotationsMask)<>0
+ | rem_annots bitand RemoveAnnotationsMask<>0
# (_, rhs_type) = removeAnnotations rhs_type
- = substitute rhs_type type_heaps
- = substitute rhs_type type_heaps
+ # (_,type,heaps) = substitute rhs_type type_heaps
+ = (type,heaps)
+ # (_,type,heaps) = substitute rhs_type type_heaps
+ = (type,heaps)
collect_imported_constructors :: !{#.CommonDefs} !.Int !.TypeRhs !*ExpandTypeState -> .ExpandTypeState
collect_imported_constructors common_defs mod_index (RecordType {rt_constructor}) ets=:{ets_collected_conses,ets_var_heap}
@@ -290,119 +292,167 @@ where
has_been_collected (VI_ExpandedType _) = True
has_been_collected _ = False
-class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
+class substitute a :: !a !*TypeHeaps -> (!Bool, !a, !*TypeHeaps)
instance substitute AType
where
substitute atype=:{at_attribute,at_type} heaps
- # ((at_attribute,at_type), heaps) = substitute (at_attribute,at_type) heaps
- = ({ atype & at_attribute = at_attribute, at_type = at_type }, heaps)
+ # (changed_attribute, at_attribute_r, heaps) = substitute at_attribute heaps
+ # (changed_type, at_type_r, heaps) = substitute at_type heaps
+ | changed_attribute
+ | changed_type
+ = (True, {at_attribute = at_attribute_r, at_type = at_type_r}, heaps)
+ = (True, {atype & at_attribute = at_attribute_r}, heaps)
+ | changed_type
+ = (True, {atype & at_type = at_type_r}, heaps)
+ = (False, atype, heaps)
instance substitute TypeAttribute
where
- substitute (TA_Var {av_ident, av_info_ptr}) heaps=:{th_attrs}
- #! av_info = sreadPtr av_info_ptr th_attrs
- = case av_info of
+ substitute (TA_Var {av_info_ptr}) heaps=:{th_attrs}
+ = case sreadPtr av_info_ptr th_attrs of
AVI_Attr attr
- -> (attr, heaps)
+ -> (True, attr, heaps)
_
- -> (TA_Multi, heaps)
+ -> (True, TA_Multi, heaps)
substitute (TA_RootVar {av_info_ptr}) heaps=:{th_attrs}
- #! av_info = sreadPtr av_info_ptr th_attrs
- = case av_info of
+ = case sreadPtr av_info_ptr th_attrs of
AVI_Attr attr
- -> (attr, heaps)
+ -> (True, attr, heaps)
_
- -> (TA_Multi, heaps)
+ -> (True, TA_Multi, heaps)
substitute TA_None heaps
- = (TA_Multi, heaps)
+ = (True, TA_Multi, heaps)
substitute attr heaps
- = (attr, heaps)
-
-instance substitute (a,b) | substitute a & substitute b
-where
- substitute (x,y) heaps
- # (x, heaps) = substitute x heaps
- (y, heaps) = substitute y heaps
- = ((x,y), heaps)
-
-instance substitute [a] | substitute a
-where
- substitute [] heaps
- = ( [], heaps)
- substitute [t:ts] heaps
- # (t, heaps) = substitute t heaps
- ( ts, heaps) = substitute ts heaps
- = ([t:ts], heaps)
-
-instance substitute TypeContext
-where
- substitute tc=:{tc_types} heaps
- # (tc_types, heaps) = substitute tc_types heaps
- = ({ tc & tc_types = tc_types }, heaps)
+ = (False, attr, heaps)
instance substitute Type
where
substitute tv=:(TV {tv_info_ptr}) heaps=:{th_vars}
# (tv_info, th_vars) = readPtr tv_info_ptr th_vars
- heaps = {heaps & th_vars = th_vars}
+ heaps & th_vars = th_vars
= case tv_info of
TVI_Type type
- -> (type, heaps)
+ -> (True, type, heaps)
_
- -> (tv, heaps)
- substitute (arg_type --> res_type) heaps
- # ((arg_type, res_type), heaps) = substitute (arg_type, res_type) heaps
- = (arg_type --> res_type, heaps)
- substitute (TArrow1 arg_type) heaps
- # (arg_type, heaps) = substitute arg_type heaps
- = (TArrow1 arg_type, heaps)
- substitute (TA cons_id cons_args) heaps
- # (cons_args, heaps) = substitute cons_args heaps
- = (TA cons_id cons_args, heaps)
- substitute (TAS cons_id cons_args strictness) heaps
- # (cons_args, heaps) = substitute cons_args heaps
- = (TAS cons_id cons_args strictness, heaps)
- substitute (CV type_var :@: types) heaps=:{th_vars}
+ -> (False, tv, heaps)
+ substitute type=:(arg_type --> res_type) heaps
+ # (changed_arg_type, arg_type_r, heaps) = substitute arg_type heaps
+ # (changed_res_type, res_type_r, heaps) = substitute res_type heaps
+ | changed_arg_type
+ | changed_res_type
+ = (True, arg_type_r --> res_type_r, heaps)
+ = (True, arg_type_r --> res_type, heaps)
+ | changed_res_type
+ = (True, arg_type --> res_type_r, heaps)
+ = (False, type, heaps)
+ substitute type=:(TA cons_id cons_args) heaps
+ # (changed, cons_args_r, heaps) = substitute cons_args heaps
+ | changed
+ = (True, TA cons_id cons_args_r, heaps)
+ = (False, type, heaps)
+ substitute type=:(TAS cons_id cons_args strictness) heaps
+ # (changed, cons_args_r, heaps) = substitute cons_args heaps
+ | changed
+ = (True, TAS cons_id cons_args_r strictness, heaps)
+ = (False, type, heaps)
+ substitute type=:(CV type_var :@: types) heaps=:{th_vars}
# (tv_info, th_vars) = readPtr type_var.tv_info_ptr th_vars
- heaps = {heaps & th_vars = th_vars}
- (types, heaps) = substitute types heaps
- = case tv_info of
- TVI_Type type
- # (ok, simplified_type) = simplifyAndCheckTypeApplication type types
- | ok
- -> (simplified_type, heaps)
- // otherwise
- // this will lead to a kind check error later on
- -> (CV type_var :@: types, heaps)
- -> (CV type_var :@: types, heaps)
+ heaps & th_vars = th_vars
+ (changed, types_r, heaps) = substitute types heaps
+ | changed
+ = case tv_info of
+ TVI_Type s_type
+ # (ok, simplified_type) = simplifyAndCheckTypeApplication s_type types_r
+ | ok
+ -> (True, simplified_type, heaps)
+ // this will lead to a kind check error later on
+ -> (True, CV type_var :@: types_r, heaps)
+ _
+ -> (True, CV type_var :@: types_r, heaps)
+ = case tv_info of
+ TVI_Type s_type
+ # (ok, simplified_type) = simplifyAndCheckTypeApplication s_type types
+ | ok
+ -> (True, simplified_type, heaps)
+ // this will lead to a kind check error later on
+ -> (False, type, heaps)
+ _
+ -> (False, type, heaps)
+ substitute type=:(TArrow1 arg_type) heaps
+ # (changed, arg_type_r, heaps) = substitute arg_type heaps
+ | changed
+ = (True, TArrow1 arg_type_r, heaps)
+ = (False, type, heaps)
substitute type heaps
- = (type, heaps)
+ = (False, type, heaps)
+
+instance substitute [a] | substitute a
+where
+ substitute lt=:[t:ts] heaps
+ # (changed_t, t_r, heaps) = substitute t heaps
+ (changed_ts, ts_r, heaps) = substitute ts heaps
+ | changed_t
+ | changed_ts
+ = (True, [t_r:ts_r], heaps)
+ = (True, [t_r:ts], heaps)
+ | changed_ts
+ = (True, [t:ts_r], heaps)
+ = (False, lt, heaps)
+ substitute [] heaps
+ = (False, [], heaps)
+
+instance substitute TypeContext
+where
+ substitute tc=:{tc_types} heaps
+ # (changed_tc_types, tc_types_r, heaps) = substitute tc_types heaps
+ | changed_tc_types
+ = (True, {tc & tc_types = tc_types_r}, heaps)
+ = (False, tc, heaps)
instance substitute AttributeVar
where
substitute av=:{av_info_ptr} heaps=:{th_attrs}
- #! av_info = sreadPtr av_info_ptr th_attrs
- = case av_info of
+ = case sreadPtr av_info_ptr th_attrs of
AVI_Attr (TA_Var attr_var)
- -> (attr_var, heaps)
+ -> (True, attr_var, heaps)
_
- -> (av, heaps)
+ -> (False, av, heaps)
instance substitute AttrInequality
where
substitute {ai_demanded,ai_offered} heaps
- # ((ai_demanded, ai_offered), heaps) = substitute (ai_demanded, ai_offered) heaps
- = ({ai_demanded = ai_demanded, ai_offered = ai_offered}, heaps)
+ # (changed_ai_demanded, ai_demanded_r, heaps) = substitute ai_demanded heaps
+ (changed_ai_offered, ai_offered_r, heaps) = substitute ai_offered heaps
+ | changed_ai_demanded
+ | changed_ai_offered
+ = (True, {ai_demanded = ai_demanded_r, ai_offered = ai_offered_r}, heaps)
+ = (True, {ai_demanded = ai_demanded_r, ai_offered = ai_offered}, heaps)
+ | changed_ai_offered
+ = (True, {ai_demanded = ai_demanded, ai_offered = ai_offered_r}, heaps)
+ = (False, {ai_demanded = ai_demanded, ai_offered = ai_offered}, heaps)
instance substitute CaseType
where
- substitute {ct_pattern_type, ct_result_type, ct_cons_types} heaps
- # (ct_pattern_type, heaps) = substitute ct_pattern_type heaps
- (ct_result_type, heaps) = substitute ct_result_type heaps
- (ct_cons_types, heaps) = substitute ct_cons_types heaps
- = ({ct_pattern_type = ct_pattern_type, ct_result_type = ct_result_type,
- ct_cons_types = ct_cons_types}, heaps)
+ substitute {ct_pattern_type, ct_result_type, ct_cons_types} heaps
+ # (changed_pattern_type, pattern_type_r, heaps) = substitute ct_pattern_type heaps
+ (changed_result_type, result_type_r, heaps) = substitute ct_result_type heaps
+ (changed_cons_types, cons_types_r, heaps) = substitute ct_cons_types heaps
+ | changed_pattern_type
+ | changed_result_type
+ | changed_cons_types
+ = (True, {ct_pattern_type=pattern_type_r, ct_result_type=result_type_r, ct_cons_types=cons_types_r}, heaps)
+ = (True, {ct_pattern_type=pattern_type_r, ct_result_type=result_type_r, ct_cons_types=ct_cons_types}, heaps)
+ | changed_cons_types
+ = (True, {ct_pattern_type=pattern_type_r, ct_result_type=ct_result_type, ct_cons_types=cons_types_r}, heaps)
+ = (True, {ct_pattern_type=pattern_type_r, ct_result_type=ct_result_type, ct_cons_types=ct_cons_types}, heaps)
+ | changed_result_type
+ | changed_cons_types
+ = (True, {ct_pattern_type=ct_pattern_type, ct_result_type=result_type_r, ct_cons_types=cons_types_r}, heaps)
+ = (True, {ct_pattern_type=ct_pattern_type, ct_result_type=result_type_r, ct_cons_types=ct_cons_types}, heaps)
+ | changed_cons_types
+ = (True, {ct_pattern_type=ct_pattern_type, ct_result_type=ct_result_type, ct_cons_types=cons_types_r}, heaps)
+ = (False, {ct_pattern_type=ct_pattern_type, ct_result_type=ct_result_type, ct_cons_types=ct_cons_types}, heaps)
class removeAnnotations a :: !a -> (!Bool, !a)
diff --git a/frontend/overloading.icl b/frontend/overloading.icl
index 07b13ca..ed3e286 100644
--- a/frontend/overloading.icl
+++ b/frontend/overloading.icl
@@ -328,10 +328,10 @@ where
where
fresh_context :: !TypeContext !*TypeHeaps -> (TypeContext,*TypeHeaps)
fresh_context tc=:{tc_types} type_heaps
- # (tc_types, type_heaps) = substitute tc_types type_heaps
-// (tc_var, var_heap) = newPtr VI_Empty var_heap
-// = ({ tc & tc_types = tc_types, tc_var = tc_var }, (var_heap, type_heaps))
- = ({ tc & tc_types = tc_types }, type_heaps)
+ # (changed_tc_types, tc_types, type_heaps) = substitute tc_types type_heaps
+ | changed_tc_types
+ = ({tc & tc_types = tc_types}, type_heaps)
+ = (tc, type_heaps)
is_unboxed_array:: [Type] PredefinedSymbols -> Bool
is_unboxed_array [TA {type_index={glob_module,glob_object},type_arity} _ : _] predef_symbols
@@ -851,7 +851,7 @@ where
= type_var_heap <:= (tv_info_ptr, TVI_Type type)
subst_context_and_generate_super_classes class_context (super_classes, type_heaps)
- # (super_class, type_heaps) = substitute class_context type_heaps
+ # (_, super_class, type_heaps) = substitute class_context type_heaps
| containsContext super_class super_classes
= (super_classes, type_heaps)
= generate_super_classes super_class ([super_class : super_classes], type_heaps)
@@ -1090,7 +1090,7 @@ where
# {tc_class=TCClass {glob_object={ds_index},glob_module}} = tc2
{class_args,class_members,class_context,class_dictionary} = defs.[glob_module].com_class_defs.[ds_index]
th_vars = foldr2 (\{tv_info_ptr} type -> writePtr tv_info_ptr (TVI_Type type)) th_vars class_args tc2.tc_types
- (super_instances, type_heaps) = substitute class_context { type_heaps & th_vars = th_vars }
+ (_, super_instances, type_heaps) = substitute class_context {type_heaps & th_vars = th_vars}
= find_super_instance tc1 super_instances (size class_members) address glob_module class_dictionary.ds_index defs type_heaps
where
find_super_instance :: !TypeContext ![TypeContext] !Index ![(Int, Global DefinedSymbol)] !Index !Index !{#CommonDefs} !*TypeHeaps
diff --git a/frontend/trans.icl b/frontend/trans.icl
index e2ad3b8..ea098b9 100644
--- a/frontend/trans.icl
+++ b/frontend/trans.icl
@@ -997,7 +997,6 @@ generate_case_function fun_index case_info_ptr new_expr outer_fun_def outer_cons
app_args = free_vars_to_bound_vars tfi_args
= ( App {app_symb = app_symb, app_args = app_args, app_info_ptr = nilPtr}, ti)
-
generate_case_function_with_pattern_argument :: !Int !ExprInfoPtr !Expression FunDef .ConsClasses [.Bool] !SymbIdent ![FreeVar] !*TransformInfo
-> (!Expression,!*TransformInfo)
generate_case_function_with_pattern_argument fun_index case_info_ptr
@@ -1051,7 +1050,7 @@ generate_case_function_with_pattern_argument fun_index case_info_ptr
, fi_local_vars = []
, fi_dynamics = []
, fi_properties = outer_fun_def.fun_info.fi_properties
- }
+ }
}
# cc_args_from_outer_fun = [ cons_arg \\ cons_arg <- outer_cons_args.cc_args & used <- used_mask | used ]
cc_linear_bits_from_outer_fun = [ cons_arg \\ cons_arg <- outer_cons_args.cc_linear_bits & used <- used_mask | used ]
@@ -1089,8 +1088,8 @@ determine_case_function_type fun_arity ct_result_type arg_types st_attr_env ti=:
# (type_variables, th_vars) = getTypeVars [ct_result_type:arg_types] ti_type_heaps.th_vars
(fresh_type_vars, th_vars) = mapSt bind_to_fresh_type_variable type_variables th_vars
ti_type_heaps = { ti_type_heaps & th_vars = th_vars }
- (fresh_arg_types, ti_type_heaps) = substitute arg_types ti_type_heaps
- (fresh_result_type, ti_type_heaps) = substitute ct_result_type ti_type_heaps
+ (_, fresh_arg_types, ti_type_heaps) = substitute arg_types ti_type_heaps
+ (_, fresh_result_type, ti_type_heaps) = substitute ct_result_type ti_type_heaps
fun_type =
{ st_vars = fresh_type_vars
, st_args = fresh_arg_types
@@ -1467,8 +1466,8 @@ generateFunction app_symb fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_i
das_AVI_Attr_TA_TempVar_info_ptrs = [st_attr_vars]
ti_type_heaps = {ti_type_heaps & th_attrs = th_attrs, th_vars = th_vars}
// | False-!->("before substitute", st_args, "->", st_result) = undef
- # ((st_args,st_result), ti_type_heaps)
- = substitute (st_args,st_result) ti_type_heaps
+ # (_, st_args, ti_type_heaps) = substitute st_args ti_type_heaps
+ # (_, st_result, ti_type_heaps) = substitute st_result ti_type_heaps
// | False-!->("after substitute", st_args, "->", st_result) = undef
// determine args...
# das = { das_vars = []
@@ -1791,9 +1790,9 @@ where
= mapSt bind_to_fresh_type_variable st_vars th_vars
(fresh_st_attr_vars, th_attrs)
= mapSt bind_to_fresh_attr_variable st_attr_vars th_attrs
- ([fresh_st_result:fresh_st_args], ti_type_heaps)
+ (_, [fresh_st_result:fresh_st_args], ti_type_heaps)
= substitute [st_result:st_args] { ti_type_heaps & th_vars = th_vars, th_attrs = th_attrs }
- (fresh_st_attr_env, ti_type_heaps)
+ (_, fresh_st_attr_env, ti_type_heaps)
= substitute st_attr_env ti_type_heaps
= (Yes { symbol_type & st_vars = fresh_st_vars, st_attr_vars = fresh_st_attr_vars, st_args = fresh_st_args,
st_result = fresh_st_result, st_attr_env = fresh_st_attr_env}, ti_type_heaps)
@@ -1981,7 +1980,7 @@ determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr
das=:{das_arg_types, das_subst, das_type_heaps, das_predef}
# (ws_arg_type, das_arg_types) = das_arg_types![prod_index]
# {ats_types=[arg_type:_]} = ws_arg_type
- (int_class_type, das_type_heaps)
+ (_, int_class_type, das_type_heaps)
= substitute class_type das_type_heaps
class_atype = { empty_atype & at_type = int_class_type }
type_input
@@ -2014,9 +2013,9 @@ determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr
= abort ("sanity check nr 93 in module trans failed\n"--->(class_atype,"\n", arg_type))
# (free_vars_and_types,das_type_heaps) = mapSt subFVT free_vars_and_types das_type_heaps
with
- subFVT (fv,ty) th
- # (ty`,th`) = substitute ty th
- = ((fv,ty`),th`)
+ subFVT (fv,ty) type_heaps
+ # (_, ty`,type_heaps) = substitute ty type_heaps
+ = ((fv,ty`),type_heaps)
# ws_ats_types = [ { empty_atype & at_type = at_type } \\ (_, at_type) <- free_vars_and_types]
# ws_arg_type` = {ats_types= ws_ats_types, ats_strictness = first_n_strict (length free_vars_and_types) }
@@ -2057,8 +2056,8 @@ determine_arg producer (Yes {st_args, st_args_strictness, st_result, st_attr_var
// because types in Cases and Lets should not use TA_TempVar's
das_AVI_Attr_TA_TempVar_info_ptrs = [st_attr_vars:das_AVI_Attr_TA_TempVar_info_ptrs]
// prepare for substitute calls
- ((st_args, st_result), das_type_heaps)
- = substitute (st_args, st_result) { das_type_heaps & th_vars = th_vars, th_attrs = th_attrs }
+ (_, st_args, das_type_heaps) = substitute st_args {das_type_heaps & th_vars = th_vars, th_attrs = th_attrs}
+ (_, st_result, das_type_heaps) = substitute st_result das_type_heaps
nr_of_applied_args = symbol_arity
(application_type, attr_env, das_next_attr_nr)
= build_application_type st_arity (length st_context) st_result st_args nr_of_applied_args [] das_next_attr_nr
@@ -4169,11 +4168,6 @@ get_fun_def_and_cons_args (SK_GeneratedFunction fun_info_ptr fun_index) cons_arg
= (gf_fun_def, gf_cons_args, cons_args, fun_defs, fun_heap)
//@ <<<
-/*
-instance <<< Group where
- (<<<) file {group_members}
- = file <<< "Group: " <<< group_members
-*/
instance <<< RootCaseMode where
(<<<) file mode = case mode of NotRootCase -> file <<< "NotRootCase"; RootCase -> file <<< "RootCase"; RootCaseOfZombie -> file <<< "RootCaseOfZombie";
@@ -4459,7 +4453,7 @@ copy_dictionary_variable app_symb app_args class_type ci cs
substitute_class_types class_types No
= (class_types, No)
substitute_class_types class_types (Yes type_heaps)
- # (new_class_types, type_heaps) = substitute class_types type_heaps
+ # (_, new_class_types, type_heaps) = substitute class_types type_heaps
= (new_class_types, Yes type_heaps)
instance copy DynamicExpr
@@ -4536,7 +4530,7 @@ where
= ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, cs)
substitute_EI_DictionaryType (EI_DictionaryType class_type) (Yes type_heaps)
- # (new_class_type, type_heaps) = substitute class_type type_heaps
+ # (_, new_class_type, type_heaps) = substitute class_type type_heaps
= (EI_DictionaryType new_class_type, Yes type_heaps)
substitute_EI_DictionaryType x opt_type_heaps
= (x, opt_type_heaps)
@@ -4684,12 +4678,16 @@ substitute_let_or_case_type expr_info No
substitute_let_or_case_type (EI_Extended extensions expr_info) yes_type_heaps
# (new_expr_info, yes_type_heaps) = substitute_let_or_case_type expr_info yes_type_heaps
= (EI_Extended extensions new_expr_info, yes_type_heaps)
-substitute_let_or_case_type (EI_CaseType case_type) (Yes type_heaps)
- # (new_case_type, type_heaps) = substitute case_type type_heaps
- = (EI_CaseType new_case_type, Yes type_heaps)
-substitute_let_or_case_type (EI_LetType let_type) (Yes type_heaps)
- # (new_let_type, type_heaps) = substitute let_type type_heaps
- = (EI_LetType new_let_type, Yes type_heaps)
+substitute_let_or_case_type expr_info=:(EI_CaseType case_type) (Yes type_heaps)
+ # (changed, new_case_type, type_heaps) = substitute case_type type_heaps
+ | changed
+ = (EI_CaseType new_case_type, Yes type_heaps)
+ = (expr_info, Yes type_heaps)
+substitute_let_or_case_type expr_info=:(EI_LetType let_type) (Yes type_heaps)
+ # (changed, new_let_type, type_heaps) = substitute let_type type_heaps
+ | changed
+ = (EI_LetType new_let_type, Yes type_heaps)
+ = (expr_info, Yes type_heaps)
instance copy CasePatterns
where
diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl
index 04c6f8d..b25149b 100644
--- a/frontend/typesupport.icl
+++ b/frontend/typesupport.icl
@@ -584,13 +584,17 @@ where
# (info, expr_heap) = readPtr expr_ptr expr_heap
= case info of
EI_CaseType case_type
- # (case_type, type_heaps) = substitute case_type type_heaps
- -> (type_heaps, expr_heap <:= (expr_ptr, EI_CaseType case_type))
+ # (changed, case_type_r, type_heaps) = substitute case_type type_heaps
+ | changed
+ -> (type_heaps, expr_heap <:= (expr_ptr, EI_CaseType case_type_r))
+ -> (type_heaps, expr_heap)
EI_LetType let_type
- # (let_type, type_heaps) = substitute let_type type_heaps
- -> (type_heaps, expr_heap <:= (expr_ptr, EI_LetType let_type))
+ # (changed, let_type_r, type_heaps) = substitute let_type type_heaps
+ | changed
+ -> (type_heaps, expr_heap <:= (expr_ptr, EI_LetType let_type_r))
+ -> (type_heaps, expr_heap)
EI_DictionaryType dict_type
- # (dict_type, type_heaps) = substitute dict_type type_heaps
+ # (_, dict_type, type_heaps) = substitute dict_type type_heaps
-> (type_heaps, expr_heap <:= (expr_ptr, EI_DictionaryType dict_type))
class bindInstances a :: !a !a !*TypeVarHeap -> *TypeVarHeap
@@ -640,7 +644,7 @@ instance bindInstances AType
substituteType :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !Type !*TypeHeaps -> (!Type, !*TypeHeaps)
substituteType form_root_attribute act_root_attribute form_type_args act_type_args orig_type type_heaps
# type_heaps = bindTypeVarsAndAttributes form_root_attribute act_root_attribute form_type_args act_type_args type_heaps
- (expanded_type, type_heaps) = substitute orig_type type_heaps
+ (_, expanded_type, type_heaps) = substitute orig_type type_heaps
= (expanded_type, clearBindingsOfTypeVarsAndAttributes form_root_attribute form_type_args type_heaps)
bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-14 16:17:32 +0000