Commit 5d9db15d authored by Martin Wierich's avatar Martin Wierich
Browse files

fixing several bugs

parent 1b67fc5c
......@@ -9,7 +9,7 @@ checkModule :: !ScannedModule !IndexRange ![FunDef] !Int !Int !(Optional Scanned
checkFunctions :: !Index !Level !Index !Index !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef}, !*ExpressionInfo, !*Heaps, !*CheckState)
determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps -> (!SymbolType, !Specials, !*TypeHeaps)
determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps !(Optional *ErrorAdmin) -> (!SymbolType, !Specials, !*TypeHeaps, !Optional *ErrorAdmin)
arrayFunOffsetToPD_IndexTable :: !w:{# MemberDef} !v:{# PredefinedSymbol} -> (!{# Index}, !x:{#MemberDef}, !v:{#PredefinedSymbol}) , [w<=x]
......
This diff is collapsed.
......@@ -29,7 +29,8 @@ instance bindTypes AType
where
bindTypes cti atype=:{at_attribute,at_type} ts_ti_cs
# (at_type, type_attr, (ts, ti, cs)) = bindTypes cti at_type ts_ti_cs
(combined_attribute, cs_error) = check_type_attribute at_attribute type_attr cti.cti_lhs_attribute cs.cs_error
cs_error = check_attr_of_type_var at_attribute at_type cs.cs_error
(combined_attribute, cs_error) = check_type_attribute at_attribute type_attr cti.cti_lhs_attribute cs_error
= ({ atype & at_attribute = combined_attribute, at_type = at_type }, combined_attribute, (ts, ti, { cs & cs_error = cs_error }))
where
check_type_attribute :: !TypeAttribute !TypeAttribute !TypeAttribute !*ErrorAdmin -> (!TypeAttribute,!*ErrorAdmin)
......@@ -60,6 +61,13 @@ where
try_to_combine_attributes _ _
= False
check_attr_of_type_var :: !TypeAttribute !Type !*ErrorAdmin -> .ErrorAdmin
check_attr_of_type_var TA_Unique (TV var) error
// the case "TA_Var" is catched by check_type_attribute
= checkError var "uniqueness attribute not allowed" error
check_attr_of_type_var attr _ error
= error
instance bindTypes TypeVar
where
bindTypes cti tv=:{tv_name=var_id=:{id_info}} (ts, ti, cs=:{cs_symbol_table /* TD ... */, cs_x={x_type_var_position,x_is_dcl_module} /* ... TD */ })
......
......@@ -802,8 +802,8 @@ determineMemberTypes module_index ins_index
// determine type of the member instance
# (symbol_type, _, hp_type_heaps) =
determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None hp_type_heaps
# (symbol_type, _, hp_type_heaps, _) =
determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None hp_type_heaps No
# (st_context, hp_var_heap) = initializeContextVariables symbol_type.st_context hp_var_heap
# symbol_type = {symbol_type & st_context = st_context}
......@@ -946,8 +946,8 @@ buildMemberType generic_def=:{gen_name,gen_type,gen_args} kind class_var type_he
#! (gen_type, type_heaps) = generate_member_type gen_type gen_args kind class_vars type_heaps
// run the real susbstitution
#! (fresh_st_args, type_heaps) = substitute gen_type.st_args type_heaps
#! (fresh_st_result, type_heaps) = substitute gen_type.st_result type_heaps
#! (_, fresh_st_args, type_heaps) = substitute gen_type.st_args type_heaps
#! (_, fresh_st_result, type_heaps) = substitute gen_type.st_result type_heaps
#! member_type = {gen_type &
st_vars = gen_type.st_vars ++ fresh_st_vars,
......@@ -963,8 +963,8 @@ where
gen_type gen_args
kind class_vars type_heaps
#! (gen_type_varss, type_heaps) = subst_generic_vars gen_args class_vars kind type_heaps
#! (fresh_st_args, type_heaps) = substitute gen_type.st_args type_heaps
#! (fresh_st_result, type_heaps) = substitute gen_type.st_result type_heaps
#! (_, fresh_st_args, type_heaps) = substitute gen_type.st_args type_heaps
#! (_, fresh_st_result, type_heaps) = substitute gen_type.st_result type_heaps
#! gen_type_varss = transpose gen_type_varss
#! (arg_types, type_heaps) = generate_args gen_type gen_args kind gen_type_varss type_heaps
......@@ -1738,10 +1738,10 @@ freshSymbolType postfix st type_heaps
# (new_st_vars, type_heaps) = subst_type_vars postfix st_vars type_heaps
# (new_st_attr_vars, type_heaps) = subst_attr_vars postfix st_attr_vars type_heaps
# (new_st_args, type_heaps) = substitute st_args type_heaps
# (new_st_result, type_heaps) = substitute st_result type_heaps
# (new_st_context, type_heaps) = substitute st_context type_heaps
# (new_st_attr_env, type_heaps) = substitute st_attr_env type_heaps
# (_, new_st_args, type_heaps) = substitute st_args type_heaps
# (_, new_st_result, type_heaps) = substitute st_result type_heaps
# (_, new_st_context, type_heaps) = substitute st_context type_heaps
# (_, new_st_attr_env, type_heaps) = substitute st_attr_env type_heaps
# new_st = { st &
st_vars = new_st_vars
......
......@@ -339,7 +339,7 @@ where
= mapSt fresh_context contexts heaps
where
fresh_context tc=:{tc_types} (var_heap, type_heaps)
# (tc_types, type_heaps) = substitute 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 }, (var_heap, type_heaps))
......@@ -491,7 +491,7 @@ tryToExpandTypeSyn defs cons_id=:{type_name,type_index={glob_object,glob_module}
expandTypeSyn td_attribute td_args type_args td_rhs type_heaps
# type_heaps = bindTypeVarsAndAttributes td_attribute TA_Multi td_args type_args type_heaps
(expanded_type, type_heaps) = substitute td_rhs type_heaps
(_, expanded_type, type_heaps) = substitute td_rhs type_heaps
= (expanded_type, clearBindingsOfTypeVarsAndAttributes td_attribute td_args type_heaps)
class match type :: !{# CommonDefs} !type !type !*TypeHeaps -> (!Bool, !*TypeHeaps)
......@@ -647,7 +647,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)
......@@ -854,7 +854,7 @@ where
# {tc_class={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
......
......@@ -58,19 +58,10 @@ instance toString Ident
| STE_DictCons !ConsDef
| STE_DictField !SelectorDef
| STE_Called ![Index] /* used during macro expansion to indicate that this function is called */
| STE_ExplImp !Bool !(Optional ImportDeclaration) !STE_Kind !Bool /* auxiliary used in module explicitimports. */
/* 1st arg: initialized with False and set to True when the searched symbol has been found to indicate.
2nd arg: Yes: the ImportDeclaration with which it was intended to import the symbol.
No: for symbols within a bracket (fields, constructors, members)
3rd arg: for error messages: the expected namespace of the intended imported symbol
4th arg: at first the idents for _all_ fields, constructors & members are added to the symbol table. In
case of a selective import like "... import :: R {f1}" this bit is used to remove all
fields different from "f1" from the symbol table again.
*/
| STE_ExplImpSymbol !Int
| STE_ExplImpComponentNrs ![ComponentNrAndIndex] ![Declaration]
/* stores the numbers of all module components that import the symbol from
the "actual" dcl module. Further for each class the all encountered
the "actual" dcl module. Further for each class all encountered
instances are accumulated.
*/
| STE_BelongingSymbol !Int
......
......@@ -58,7 +58,6 @@ where toString {import_module} = toString import_module
| STE_DictCons !ConsDef
| STE_DictField !SelectorDef
| STE_Called ![Index] /* used during macro expansion to indicate that this function is called */
| STE_ExplImp !Bool !(Optional ImportDeclaration) !STE_Kind !Bool /* auxiliary used in module explicitimports. */
| STE_ExplImpSymbol !Int
| STE_ExplImpComponentNrs ![ComponentNrAndIndex] ![Declaration]
| STE_BelongingSymbol !Int
......
......@@ -987,8 +987,8 @@ possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti
{th_vars,th_attrs} = ti.ti_type_heaps
(type_variables, th_vars) = getTypeVars [ct_result_type:arg_types] th_vars
(fresh_type_vars, th_vars) = mapSt bind_to_fresh_type_variable type_variables th_vars
(fresh_arg_types, ti_type_heaps) = substitute arg_types { th_vars = th_vars, th_attrs = th_attrs }
(fresh_result_type, ti_type_heaps) = substitute ct_result_type ti_type_heaps
(_, fresh_arg_types, ti_type_heaps) = substitute arg_types { th_vars = th_vars, th_attrs = th_attrs }
(_, fresh_result_type, ti_type_heaps) = substitute ct_result_type ti_type_heaps
us = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = Yes ti_type_heaps,
us_cleanup_info=ti.ti_cleanup_info }
ui = {ui_handle_aci_free_vars = SubstituteThem, ui_convert_module_n= -1,ui_conversion_table=No }
......@@ -1315,7 +1315,7 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi
= foldSt bind_to_temp_attr_var st_attr_vars (FirstAttrVar, ti_type_heaps.th_attrs)
ti_type_heaps
= { ti_type_heaps & th_attrs = th_attrs, th_vars = th_vars }
((st_args,st_result), ti_type_heaps)
(_, (st_args,st_result), ti_type_heaps)
= substitute (st_args,st_result) ti_type_heaps
(new_fun_args, new_arg_types_array, next_attr_nr,
new_linear_bits, new_cons_args, uniqueness_requirements, subst, ti_type_heaps=:{th_vars, th_attrs},
......@@ -1507,7 +1507,7 @@ where
uniqueness_requirements, subst, type_heaps, symbol_heap, fun_defs, fun_heap, var_heap)
# (arg_type, arg_types)
= arg_types![prod_index]
(int_class_type, type_heaps)
(_, int_class_type, type_heaps)
= substitute class_type type_heaps
type_input
= { ti_common_defs = ro.ro_common_defs
......@@ -1568,7 +1568,7 @@ where
(next_attr_nr, th_attrs)
= foldSt bind_to_temp_attr_var st_attr_vars (next_attr_nr, th_attrs)
// prepare for substitute calls
((st_args, st_result), type_heaps)
(_, (st_args, st_result), type_heaps)
= substitute (st_args, st_result) { type_heaps & th_vars = th_vars, th_attrs = th_attrs }
nr_of_applied_args
= symbol.symb_arity
......@@ -1726,9 +1726,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)
......@@ -1873,7 +1873,7 @@ where
max_group_index_of_producer PR_Empty current_max fun_defs fun_heap cons_args
= current_max
max_group_index_of_producer (PR_Class {app_args} _ _) current_max fun_defs fun_heap cons_args
= max_group_index_of_members app_args current_max fun_defs fun_heap cons_args
= foldSt (foldrExprSt (max_group_index_of_member fun_defs fun_heap cons_args)) app_args current_max
max_group_index_of_producer (PR_Curried {symb_kind=SK_Function {glob_object=fun_index, glob_module}}) current_max fun_defs fun_heap cons_args
| glob_module<>ro_main_dcl_module_n
= current_max
......@@ -1890,32 +1890,31 @@ where
max_group_index_of_producer prod current_max fun_defs fun_heap cons_args
= abort ("trans.icl: max_group_index_of_producer" ---> prod)
ro_main_dcl_module_n = ro.ro_main_dcl_module_n
max_group_index_of_member fun_defs fun_heap cons_args current_max
max_group_index_of_member fun_defs fun_heap cons_args
(App {app_symb = {symb_name, symb_kind = SK_Function { glob_object = fun_index, glob_module = mod_index}}})
current_max
| mod_index == ro_main_dcl_module_n
| fun_index < size cons_args
# {fun_info = {fi_group_index}} = fun_defs.[fun_index]
= max fi_group_index current_max
= current_max
= current_max
max_group_index_of_member fun_defs fun_heap cons_args current_max
(App {app_symb = {symb_name, symb_kind = SK_LocalMacroFunction fun_index}})
max_group_index_of_member fun_defs fun_heap cons_args
(App {app_symb = {symb_name, symb_kind = SK_LocalMacroFunction fun_index}})
current_max
| fun_index < size cons_args
# {fun_info = {fi_group_index}} = fun_defs.[fun_index]
= max fi_group_index current_max
= current_max
max_group_index_of_member fun_defs fun_heap cons_args current_max
max_group_index_of_member fun_defs fun_heap cons_args
(App {app_symb = {symb_kind = SK_GeneratedFunction fun_ptr _ }})
current_max
# (FI_Function {gf_fun_def={fun_info = {fi_group_index}}}) = sreadPtr fun_ptr fun_heap
= max fi_group_index current_max
max_group_index_of_member fun_defs fun_heap cons_args current_max
(App {app_symb = {symb_kind = SK_Constructor _}, app_args})
= max_group_index_of_members app_args current_max fun_defs fun_heap cons_args
max_group_index_of_member fun_defs fun_heap cons_args _ current_max
= current_max
max_group_index_of_members members current_max fun_defs fun_heap cons_args
= foldl (max_group_index_of_member fun_defs fun_heap cons_args) current_max members
max_group_index_of_fun_with_fun_index fun_index current_max fun_defs
# fun_def = fun_defs.[fun_index]
= max fun_def.fun_info.fi_group_index current_max
......@@ -2446,7 +2445,7 @@ expand_syn_types_in_TA rem_annots common_defs type_symb=:{type_index={glob_objec
SynType rhs_type
# ets_type_heaps = bind_attr td_attribute attribute ets.ets_type_heaps
ets_type_heaps = (fold2St bind_var_and_attr td_args types ets_type_heaps)
(type, ets_type_heaps) = substitute_rhs rem_annots rhs_type.at_type ets_type_heaps
(_, type, ets_type_heaps) = substitute_rhs rem_annots rhs_type.at_type ets_type_heaps
-> expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps }
_
# (types, ets) = expandSynTypes rem_annots common_defs types ets
......@@ -2767,18 +2766,33 @@ mapExprSt map_expr map_free_var postprocess_free_var expr st :== map_expr_st exp
= map_expr let_expr st
st = foldSt (\{lb_dst} st -> postprocess_free_var lb_dst st) let_lazy_binds st
st = foldSt (\{lb_dst} st -> postprocess_free_var lb_dst st) let_strict_binds st
= ( Let { lad & let_lazy_binds = combine lazy_free_vars lazy_rhss let_lazy_binds,
let_strict_binds = combine strict_free_vars strict_rhss let_strict_binds,
let_expr = let_expr
}
, st
)
= map_expr ( Let { lad & let_lazy_binds = combine lazy_free_vars lazy_rhss let_lazy_binds,
let_strict_binds = combine strict_free_vars strict_rhss let_strict_binds,
let_expr = let_expr
})
st
map_expr_st (Selection a expr b) st
# (expr, st) = map_expr expr st
= (Selection a expr b, st)
= map_expr (Selection a expr b) st
combine :: [FreeVar] [Expression] [LetBind] -> [LetBind]
combine free_vars rhss original_binds
= [{ original_bind & lb_dst = lb_dst, lb_src = lb_src}
\\ lb_dst <- free_vars & lb_src <- rhss & original_bind <- original_binds]
foldrExprSt f expr st :== foldr_expr_st expr st
where
foldr_expr_st expr=:(Var _) st
= f expr st
foldr_expr_st app=:(App {app_args}) st
= f app (foldSt foldr_expr_st app_args st)
foldr_expr_st lad=:(Let {let_lazy_binds, let_strict_binds, let_expr}) st
# st
= foldSt (\{lb_src} st -> foldr_expr_st lb_src st) let_lazy_binds st
st
= foldSt (\{lb_src} st -> foldr_expr_st lb_src st) let_strict_binds st
st
= f let_expr st
= f lad st
foldr_expr_st sel=:(Selection a expr b) st
= f sel (foldr_expr_st expr st)
......@@ -247,7 +247,7 @@ unfoldVariable var=:{var_name,var_info_ptr} us
substitute_class_types class_types no=: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)
readVarInfo var_info_ptr us
......@@ -381,7 +381,7 @@ where
= ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, us)
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)
......@@ -495,11 +495,11 @@ 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
# (_, new_case_type, type_heaps) = substitute case_type type_heaps
= (EI_CaseType new_case_type, Yes type_heaps)
// = (EI_CaseType 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
# (_, new_let_type, type_heaps) = substitute let_type type_heaps
= (EI_LetType new_let_type, Yes type_heaps)
instance unfold CasePatterns
......
......@@ -2308,8 +2308,8 @@ where
create_instance_type members array_members unboxed_array_type offset_table record_type member_index (array_defs, type_heaps)
# {me_type,me_symb,me_class_vars,me_pos} = array_members.[members.[member_index].ds_index]
(instance_type, _, type_heaps) = determineTypeOfMemberInstance me_type me_class_vars {it_vars = [], it_attr_vars = [], it_context = [],
it_types = [unboxed_array_type, record_type]} SP_None type_heaps
(instance_type, _, type_heaps, _) = determineTypeOfMemberInstance me_type me_class_vars {it_vars = [], it_attr_vars = [], it_context = [],
it_types = [unboxed_array_type, record_type]} SP_None type_heaps No
instance_type = makeElemTypeOfArrayFunctionStrict instance_type member_index offset_table
fun =
{ fun_symb = me_symb
......
......@@ -68,7 +68,7 @@ beautifulizeAttributes :: !SymbolType !*AttrVarHeap -> (!SymbolType, !.AttrVarHe
updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*ExpressionHeap -> (!*TypeHeaps, !*ExpressionHeap)
class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
class substitute a :: !a !*TypeHeaps -> (!Bool, !a, !*TypeHeaps)
instance substitute AType, Type, TypeContext, AttrInequality, CaseType, [a] | substitute a,
(a,b) | substitute a & substitute b
......
......@@ -23,13 +23,15 @@ import syntax, parse, check, unitype, utilities, checktypes, RWSDebug
| UncheckedType !TempSymbolType | ExpandedType !SymbolType !TempSymbolType !TempSymbolType | EmptyFunctionType
simplifyTypeApplication :: !Type ![AType] -> Type
simplifyTypeApplication :: !Type ![AType] -> (!Bool, !Type)
simplifyTypeApplication (TA type_cons=:{type_arity} cons_args) type_args
= TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args)
= (True, TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args))
simplifyTypeApplication (TV tv) type_args
= CV tv :@: type_args
= (True, CV tv :@: type_args)
simplifyTypeApplication (CV tv :@: type_args1) type_args2
= CV tv :@: (type_args1 ++ type_args2)
= (True, CV tv :@: (type_args1 ++ type_args2))
simplifyTypeApplication (TB _) _
= (False, TE)
:: AttributeEnv :== {! TypeAttribute }
:: VarEnv :== {! Type }
......@@ -104,7 +106,7 @@ where
# (type, cus) = cus!cus_var_env.[tempvar]
# (type, cus) = cleanUpVariable cui.cui_top_level type tempvar cus
(types, cus) = clean_up cui types cus
= (simplifyTypeApplication type types, cus)
= (snd (simplifyTypeApplication type types), cus)
clean_up cui (TempQCV tempvar :@: types) cus
# (type, cus) = cus!cus_var_env.[tempvar]
# (TV tv, cus) = cleanUpVariable cui.cui_top_level type tempvar cus
......@@ -178,7 +180,7 @@ where
| checkCleanUpResult cur1 cUndefinedVar
= (cur1, TempCV tv_number :@: types, env)
# (cur2, types, env) = cleanUpClosed types env
= (combineCleanUpResults cur1 cur2, simplifyTypeApplication type types, env)
= (combineCleanUpResults cur1 cur2, snd (simplifyTypeApplication type types), env)
cleanUpClosed t env
= (cClosed, t, env)
......@@ -439,13 +441,13 @@ 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
# (_, case_type, type_heaps) = substitute case_type type_heaps
-> (type_heaps, expr_heap <:= (expr_ptr, EI_CaseType case_type))
EI_LetType let_type
# (let_type, type_heaps) = substitute let_type type_heaps
# (_, let_type, type_heaps) = substitute let_type type_heaps
-> (type_heaps, expr_heap <:= (expr_ptr, EI_LetType let_type))
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))
......@@ -482,13 +484,13 @@ instance bindInstances AType
= bindInstances t1 t2 type_var_heap
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)
# (ok, (at_attribute,at_type), heaps) = substitute (at_attribute,at_type) heaps
= (ok, { atype & at_attribute = at_attribute, at_type = at_type }, heaps)
instance substitute TypeAttribute
where
......@@ -496,36 +498,36 @@ where
#! av_info = sreadPtr av_info_ptr th_attrs
= case av_info 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)
= (True, 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)
# (ok_x, x, heaps) = substitute x heaps
(ok_y, y, heaps) = substitute y heaps
= (ok_x && ok_y, (x,y), heaps)
instance substitute [a] | substitute a
where
substitute [] heaps
= ([], heaps)
= (True, [], heaps)
substitute [t:ts] heaps
# (t, heaps) = substitute t heaps
(ts, heaps) = substitute ts heaps
= ([t:ts], heaps)
# (ok_t, t, heaps) = substitute t heaps
(ok_ts, ts, heaps) = substitute ts heaps
= (ok_t && ok_ts, [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)
# (ok, tc_types, heaps) = substitute tc_types heaps
= (ok, { tc & tc_types = tc_types }, heaps)
substituteTypeVariable tv=:{tv_name,tv_info_ptr} heaps=:{th_vars}
# (tv_info, th_vars) = readPtr tv_info_ptr th_vars
......@@ -539,31 +541,27 @@ substituteTypeVariable tv=:{tv_name,tv_info_ptr} heaps=:{th_vars}
instance substitute Type
where
substitute (TV tv) heaps
= substituteTypeVariable tv heaps
# (type, heaps) = substituteTypeVariable tv heaps
= (True, type, heaps)
substitute (arg_type --> res_type) heaps
# ((arg_type, res_type), heaps) = substitute (arg_type, res_type) heaps
= (arg_type --> res_type, heaps)
# (ok, (arg_type, res_type), heaps) = substitute (arg_type, res_type) heaps
= (ok, arg_type --> res_type, heaps)
substitute (TA cons_id cons_args) heaps
# (cons_args, heaps) = substitute cons_args heaps
= (TA cons_id cons_args, heaps)
/* MW3 was
substitute (CV type_var :@: types) heaps
# (type, heaps) = substituteTypeVariable type_var heaps
(types, heaps) = substitute types heaps
= (simplifyTypeApplication type types, heaps)
*/
# (ok, cons_args, heaps) = substitute cons_args heaps
= (ok, TA cons_id cons_args, heaps)
substitute (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
(ok1, types, heaps) = substitute types heaps
= case tv_info of
TVI_Type tv=:(TempV i)
-> (TempCV i :@: types, heaps)
-> (ok1, TempCV i :@: types, heaps)
_
# (type, heaps) = substituteTypeVariable type_var heaps
-> (simplifyTypeApplication type types, heaps)
(ok2, simplified_type) = simplifyTypeApplication type types
-> (ok1 && ok2, simplified_type, heaps)
substitute type heaps
= (type, heaps)
= (True, type, heaps)
instance substitute AttributeVar
where
......@@ -571,24 +569,24 @@ where
#! av_info = sreadPtr av_info_ptr th_attrs
= case av_info of
AVI_Attr (TA_Var attr_var)
-> (attr_var, heaps)
-> (True, attr_var, heaps)
_
-> (av, heaps)
-> (True, 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)
# (ok, (ai_demanded, ai_offered), heaps) = substitute (ai_demanded, ai_offered) heaps
= (ok, {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)
# (ok1, ct_pattern_type, heaps) = substitute ct_pattern_type heaps
(ok2, ct_result_type, heaps) = substitute ct_result_type heaps
(ok3, ct_cons_types, heaps) = substitute ct_cons_types heaps
= (ok1 && ok2 && ok3, {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)
......@@ -654,7 +652,7 @@ where
expandTypeApplication :: ![ATypeVar] !TypeAttribute !Type ![AType] !TypeAttribute !*TypeHeaps -> (!Type, !*TypeHeaps)
expandTypeApplication type_args form_attr type_rhs arg_types act_attr type_heaps=:{th_attrs}
# type_heaps = bindTypeVarsAndAttributes form_attr act_attr type_args arg_types type_heaps
(exp_type, type_heaps) = substitute type_rhs type_heaps