aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--frontend/overloading.icl458
1 files changed, 233 insertions, 225 deletions
diff --git a/frontend/overloading.icl b/frontend/overloading.icl
index 8a06f03..c818013 100644
--- a/frontend/overloading.icl
+++ b/frontend/overloading.icl
@@ -321,67 +321,6 @@ where
-> (ok && succ, coercion_env)
_
-> (False, coercion_env)
-
- context_is_reducible :: TypeContext PredefinedSymbols -> Bool
- context_is_reducible {tc_class=TCClass class_symb,tc_types = [type : types]} predef_symbols
- = type_is_reducible type class_symb predef_symbols && types_are_reducible types type class_symb predef_symbols
- context_is_reducible tc=:{tc_class=TCGeneric {gtc_class}, tc_types = [type : types]} predef_symbols
- = type_is_reducible type gtc_class predef_symbols && types_are_reducible types type gtc_class predef_symbols
-
- type_is_reducible :: Type (Global DefinedSymbol) PredefinedSymbols -> Bool
- type_is_reducible (TempV _) tc_class predef_symbols
- = False // is_predefined_symbol tc_class.glob_module tc_class.glob_object.ds_index PD_TypeCodeClass predef_symbols
- type_is_reducible (_ :@: _) tc_class predef_symbols
- = False
- type_is_reducible (TempQV _) tc_class predef_symbols
- = False
- type_is_reducible (TempQDV _) {glob_object={ds_index},glob_module} predef_symbols
- = is_predefined_symbol glob_module ds_index PD_TypeCodeClass predef_symbols
- type_is_reducible _ tc_class predef_symbols
- = True
-
- types_are_reducible :: [Type] Type (Global DefinedSymbol) PredefinedSymbols -> Bool
- types_are_reducible [] _ _ _
- = True
- types_are_reducible [type : types] first_type tc_class predef_symbols
- = case type of
- TempV _
- -> is_lazy_or_strict_array_or_list_context
- _ :@: _
- -> is_lazy_or_strict_array_or_list_context
- _
- -> is_reducible types tc_class predef_symbols
- where
- is_lazy_or_strict_array_or_list_context
- => (is_predefined_symbol tc_class.glob_module tc_class.glob_object.ds_index PD_ArrayClass predef_symbols &&
- is_lazy_or_strict_array_type first_type predef_symbols)
- ||
- (is_predefined_symbol tc_class.glob_module tc_class.glob_object.ds_index PD_ListClass predef_symbols &&
- is_lazy_or_strict_list_type first_type predef_symbols)
-
- is_lazy_or_strict_array_type :: Type PredefinedSymbols -> Bool
- is_lazy_or_strict_array_type (TA {type_index={glob_module,glob_object}} _) predef_symbols
- = is_predefined_symbol glob_module glob_object PD_LazyArrayType predef_symbols ||
- is_predefined_symbol glob_module glob_object PD_StrictArrayType predef_symbols
- is_lazy_or_strict_array_type _ _
- = False
-
- is_lazy_or_strict_list_type :: Type PredefinedSymbols -> Bool
- is_lazy_or_strict_list_type (TA {type_index={glob_module,glob_object}} _) predef_symbols
- = is_predefined_symbol glob_module glob_object PD_ListType predef_symbols ||
- is_predefined_symbol glob_module glob_object PD_TailStrictListType predef_symbols ||
- is_predefined_symbol glob_module glob_object PD_StrictListType predef_symbols ||
- is_predefined_symbol glob_module glob_object PD_StrictTailStrictListType predef_symbols ||
- is_predefined_symbol glob_module glob_object PD_UnboxedListType predef_symbols ||
- is_predefined_symbol glob_module glob_object PD_UnboxedTailStrictListType predef_symbols
- is_lazy_or_strict_list_type _ _
- = False
-
- is_reducible :: [Type] (Global DefinedSymbol) PredefinedSymbols -> Bool
- is_reducible [] tc_class predef_symbols
- = True
- is_reducible [ type : types] tc_class predef_symbols
- = type_is_reducible type tc_class predef_symbols && is_reducible types tc_class predef_symbols
fresh_contexts :: ![TypeContext] !*TypeHeaps -> ([TypeContext],*TypeHeaps)
fresh_contexts contexts type_heaps
@@ -503,11 +442,6 @@ where
try_to_unbox type _ predef_symbols_type_heaps
= (False, No, predef_symbols_type_heaps)
- is_predefined_symbol :: !Int !Int !Int !PredefinedSymbols -> Bool
- is_predefined_symbol mod_index symb_index predef_index predef_symbols
- # {pds_def,pds_module} = predef_symbols.[predef_index]
- = mod_index == pds_module && symb_index == pds_def
-
is_predefined_global_symbol :: !GlobalIndex !Int !PredefinedSymbols -> Bool
is_predefined_global_symbol {gi_module,gi_index} predef_index predef_symbols
# {pds_def,pds_module} = predef_symbols.[predef_index]
@@ -521,7 +455,7 @@ where
= Yes inst
= look_up_array_or_list_instance record insts
- new_array_instance :: !TypeSymbIdent !{# DefinedSymbol} !Index -> ArrayInstance
+ new_array_instance :: !TypeSymbIdent !{#DefinedSymbol} !Index -> ArrayInstance
new_array_instance record members next_member_index
= { ai_members = { {cim_ident=ds_ident,cim_arity=ds_arity,cim_index=next_inst_index} \\ {ds_ident,ds_arity} <-: members & next_inst_index <- [next_member_index .. ]},
ai_record = record }
@@ -544,15 +478,12 @@ where
where
reduce_tc_context :: {#CommonDefs} TCClass Type *ReduceTCState -> (ClassApplication, !*ReduceTCState)
reduce_tc_context defs type_code_class type=:(TA cons_id=:{type_index} cons_args) rtcs_state=:{rtcs_error,rtcs_type_heaps}
- # rtcs_error
- = disallow_abstract_types_in_dynamics defs type_index rtcs_error
-
+ # rtcs_error = disallow_abstract_types_in_dynamics defs type_index rtcs_error
# (expanded, type, rtcs_type_heaps)
= tryToExpandTypeSyn defs type cons_id cons_args rtcs_type_heaps
# rtcs_state = {rtcs_state & rtcs_error=rtcs_error, rtcs_type_heaps=rtcs_type_heaps}
| expanded
= reduce_tc_context defs type_code_class type rtcs_state
-
# type_constructor = toTypeCodeConstructor type_index defs
(rc_red_contexts, rtcs_state) = reduce_TC_contexts defs type_code_class cons_args rtcs_state
= (CA_GlobalTypeCode { tci_constructor = type_constructor, tci_contexts = rc_red_contexts }, rtcs_state)
@@ -571,7 +502,8 @@ where
= (CA_Context tc, rtcs_state)
= (CA_Context tc, {rtcs_state & rtcs_new_contexts = [tc : rtcs_new_contexts]})
reduce_tc_context defs type_code_class (TempQDV var_number) rtcs_state=:{rtcs_type_pattern_vars, rtcs_var_heap}
- # (inst_var, (rtcs_type_pattern_vars, rtcs_var_heap)) = addLocalTCInstance var_number (rtcs_type_pattern_vars, rtcs_var_heap)
+ # (inst_var, (rtcs_type_pattern_vars, rtcs_var_heap))
+ = addLocalTCInstance var_number (rtcs_type_pattern_vars, rtcs_var_heap)
# rtcs_state = {rtcs_state & rtcs_type_pattern_vars=rtcs_type_pattern_vars, rtcs_var_heap=rtcs_var_heap}
= (CA_LocalTypeCode inst_var, rtcs_state)
reduce_tc_context defs type_code_class (TempV var_number) rtcs_state=:{rtcs_var_heap, rtcs_new_contexts}
@@ -592,7 +524,73 @@ where
reduce_TC_contexts :: {#CommonDefs} TCClass [AType] *ReduceTCState -> ([ClassApplication], !*ReduceTCState)
reduce_TC_contexts defs type_code_class cons_args rtcs_state
= mapSt (\{at_type} -> reduce_tc_context defs type_code_class at_type) cons_args rtcs_state
-
+
+context_is_reducible :: TypeContext PredefinedSymbols -> Bool
+context_is_reducible {tc_class=TCClass class_symb,tc_types = [type : types]} predef_symbols
+ = type_is_reducible type class_symb predef_symbols && types_are_reducible types type class_symb predef_symbols
+context_is_reducible tc=:{tc_class=TCGeneric {gtc_class}, tc_types = [type : types]} predef_symbols
+ = type_is_reducible type gtc_class predef_symbols && types_are_reducible types type gtc_class predef_symbols
+
+types_are_reducible :: [Type] Type (Global DefinedSymbol) PredefinedSymbols -> Bool
+types_are_reducible [] _ _ _
+ = True
+types_are_reducible [type : types] first_type tc_class predef_symbols
+ = case type of
+ TempV _
+ -> is_lazy_or_strict_array_or_list_context
+ _ :@: _
+ -> is_lazy_or_strict_array_or_list_context
+ _
+ -> is_reducible types tc_class predef_symbols
+where
+ is_lazy_or_strict_array_or_list_context
+ => (is_predefined_symbol tc_class.glob_module tc_class.glob_object.ds_index PD_ArrayClass predef_symbols &&
+ is_lazy_or_strict_array_type first_type predef_symbols)
+ ||
+ (is_predefined_symbol tc_class.glob_module tc_class.glob_object.ds_index PD_ListClass predef_symbols &&
+ is_lazy_or_strict_list_type first_type predef_symbols)
+
+ is_lazy_or_strict_array_type :: Type PredefinedSymbols -> Bool
+ is_lazy_or_strict_array_type (TA {type_index={glob_module,glob_object}} _) predef_symbols
+ = is_predefined_symbol glob_module glob_object PD_LazyArrayType predef_symbols ||
+ is_predefined_symbol glob_module glob_object PD_StrictArrayType predef_symbols
+ is_lazy_or_strict_array_type _ _
+ = False
+
+ is_lazy_or_strict_list_type :: Type PredefinedSymbols -> Bool
+ is_lazy_or_strict_list_type (TA {type_index={glob_module,glob_object}} _) predef_symbols
+ = is_predefined_symbol glob_module glob_object PD_ListType predef_symbols ||
+ is_predefined_symbol glob_module glob_object PD_TailStrictListType predef_symbols ||
+ is_predefined_symbol glob_module glob_object PD_StrictListType predef_symbols ||
+ is_predefined_symbol glob_module glob_object PD_StrictTailStrictListType predef_symbols ||
+ is_predefined_symbol glob_module glob_object PD_UnboxedListType predef_symbols ||
+ is_predefined_symbol glob_module glob_object PD_UnboxedTailStrictListType predef_symbols
+ is_lazy_or_strict_list_type _ _
+ = False
+
+ is_reducible :: [Type] (Global DefinedSymbol) PredefinedSymbols -> Bool
+ is_reducible [] tc_class predef_symbols
+ = True
+ is_reducible [type : types] tc_class predef_symbols
+ = type_is_reducible type tc_class predef_symbols && is_reducible types tc_class predef_symbols
+
+type_is_reducible :: Type (Global DefinedSymbol) PredefinedSymbols -> Bool
+type_is_reducible (TempV _) tc_class predef_symbols
+ = False // is_predefined_symbol tc_class.glob_module tc_class.glob_object.ds_index PD_TypeCodeClass predef_symbols
+type_is_reducible (_ :@: _) tc_class predef_symbols
+ = False
+type_is_reducible (TempQV _) tc_class predef_symbols
+ = False
+type_is_reducible (TempQDV _) {glob_object={ds_index},glob_module} predef_symbols
+ = is_predefined_symbol glob_module ds_index PD_TypeCodeClass predef_symbols
+type_is_reducible _ tc_class predef_symbols
+ = True
+
+is_predefined_symbol :: !Int !Int !Int !PredefinedSymbols -> Bool
+is_predefined_symbol mod_index symb_index predef_index predef_symbols
+ # {pds_def,pds_module} = predef_symbols.[predef_index]
+ = mod_index == pds_module && symb_index == pds_def
+
addLocalTCInstance :: Int (([LocalTypePatternVariable], *VarHeap)) -> (VarInfoPtr, ([LocalTypePatternVariable], *VarHeap))
addLocalTCInstance var_number (instances=:[inst : insts], ltp_var_heap)
# cmp = var_number =< inst.ltpv_var
@@ -779,61 +777,63 @@ where
tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !Int !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState !{# DclModule}
-> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], DictionaryTypes, !*OverloadingState)
tryToSolveOverloading ocs main_dcl_module_n defs instance_info coercion_env os dcl_modules
- # (reduced_contexts, contexts, coercion_env, type_pattern_vars, os) = foldSt (reduce_contexts defs instance_info) ocs ([], [], coercion_env, [], os)
+ # (reduced_calls, contexts, coercion_env, type_pattern_vars, os) = foldSt (reduce_contexts_of_applications_in_function defs instance_info) ocs ([], [], coercion_env, [], os)
| os.os_error.ea_ok
- # (contexts, os_var_heap) = foldSt add_spec_contexts ocs (contexts, os.os_var_heap)
+ # (contexts, os_var_heap) = foldSt add_specified_contexts ocs (contexts,os.os_var_heap)
(contexts, os_type_heaps) = remove_super_classes contexts os.os_type_heaps
- ({ hp_var_heap, hp_expression_heap, hp_type_heaps,hp_generic_heap}, dict_types, os_error)
- = foldSt (convert_dictionaries defs contexts) reduced_contexts
- ({ hp_var_heap = os_var_heap, hp_expression_heap = os.os_symbol_heap, hp_type_heaps = os_type_heaps,hp_generic_heap=os.os_generic_heap}, [], os.os_error)
- = (contexts, coercion_env, type_pattern_vars, dict_types, { os & os_type_heaps = hp_type_heaps, os_symbol_heap = hp_expression_heap, os_var_heap = hp_var_heap, os_generic_heap = hp_generic_heap, os_error = os_error} )
+ ({hp_var_heap, hp_expression_heap, hp_type_heaps,hp_generic_heap}, dict_types, os_error)
+ = foldSt (convert_dictionaries defs contexts) reduced_calls
+ ({hp_var_heap = os_var_heap, hp_expression_heap = os.os_symbol_heap, hp_type_heaps = os_type_heaps,hp_generic_heap=os.os_generic_heap}, [], os.os_error)
+ = (contexts, coercion_env, type_pattern_vars, dict_types, {os & os_type_heaps = hp_type_heaps, os_symbol_heap = hp_expression_heap, os_var_heap = hp_var_heap, os_generic_heap = hp_generic_heap, os_error = os_error})
= ([], coercion_env, type_pattern_vars, [], os)
where
- reduce_contexts :: {#CommonDefs} ClassInstanceInfo (.a, [ExprInfoPtr], .b, Index)
- ([(SymbIdent, Index, ExprInfoPtr,[ClassApplication])], ![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
- -> ([(SymbIdent, Index, ExprInfoPtr,[ClassApplication])], ![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
- reduce_contexts defs instance_info (opt_spec_contexts, expr_ptrs, pos, index) state
+ reduce_contexts_of_applications_in_function :: {#CommonDefs} ClassInstanceInfo (.a, [ExprInfoPtr], .b, Index)
+ ([(SymbIdent,Index,ExprInfoPtr,[ClassApplication])], ![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
+ -> ([(SymbIdent,Index,ExprInfoPtr,[ClassApplication])], ![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
+ reduce_contexts_of_applications_in_function defs instance_info (opt_spec_contexts, expr_ptrs, pos, index) state
= foldSt (reduce_contexts_of_application index defs instance_info) expr_ptrs state
- add_spec_contexts (Yes spec_context, expr_ptrs, pos, index) contexts_and_var_heap
- = foldSt add_spec_context spec_context contexts_and_var_heap
+ reduce_contexts_of_application :: !Index !{#CommonDefs} !ClassInstanceInfo !ExprInfoPtr
+ ([(SymbIdent,Index,ExprInfoPtr,[ClassApplication])], ![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
+ -> ([(SymbIdent,Index,ExprInfoPtr,[ClassApplication])], ![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
+ reduce_contexts_of_application fun_index defs instance_info over_info_ptr (reduced_calls, new_contexts, coercion_env, type_pattern_vars,
+ os=:{os_symbol_heap,os_type_heaps,os_var_heap,os_special_instances,os_error,os_predef_symbols})
+ = case readPtr over_info_ptr os_symbol_heap of
+ (EI_Overloaded {oc_symbol,oc_context,oc_specials},os_symbol_heap)
+ # (glob_fun, os_type_heaps) = trySpecializedInstances oc_context oc_specials os_type_heaps
+ | FoundObject glob_fun
+ # over_info = EI_Instance {glob_module = glob_fun.glob_module, glob_object =
+ {ds_ident = oc_symbol.symb_ident, ds_arity = 0, ds_index = glob_fun.glob_object}} []
+ # os_symbol_heap = os_symbol_heap <:= (over_info_ptr,over_info)
+ -> (reduced_calls,new_contexts,coercion_env,type_pattern_vars,{os & os_type_heaps=os_type_heaps, os_symbol_heap=os_symbol_heap})
+ | otherwise
+ # rs_state = {rs_new_contexts=new_contexts, rs_special_instances = os_special_instances,
+ rs_type_pattern_vars=type_pattern_vars,rs_var_heap=os_var_heap,
+ rs_type_heaps=os_type_heaps, rs_coercions=coercion_env,
+ rs_predef_symbols=os_predef_symbols, rs_error=os_error}
+ info = {ri_main_dcl_module_n=main_dcl_module_n, ri_defs=defs, ri_instance_info=instance_info}
+ (class_applications, rs_state) = reduceContexts info oc_context rs_state
+ {rs_new_contexts=new_contexts, rs_special_instances = os_special_instances,
+ rs_type_pattern_vars=type_pattern_vars, rs_var_heap=os_var_heap, rs_type_heaps=os_type_heaps,
+ rs_coercions=coercion_env, rs_predef_symbols=os_predef_symbols, rs_error=os_error}
+ = rs_state
+ os = {os & os_type_heaps=os_type_heaps, os_symbol_heap=os_symbol_heap, os_var_heap=os_var_heap,
+ os_special_instances=os_special_instances, os_error=os_error, os_predef_symbols=os_predef_symbols}
+ -> ([(oc_symbol,fun_index,over_info_ptr,class_applications):reduced_calls],new_contexts,coercion_env,type_pattern_vars,os)
+
+ add_specified_contexts (Yes spec_context, expr_ptrs, pos, index) (contexts,var_heap)
+ = add_contexts spec_context contexts var_heap
+ add_specified_contexts (No, expr_ptrs, pos, index) (contexts,var_heap)
+ = (contexts,var_heap)
+
+ add_contexts contexts all_contexts var_heap
+ = foldSt add_spec_context contexts (all_contexts,var_heap)
where
add_spec_context tc (contexts, var_heap)
| containsContext tc contexts
= (contexts, var_heap)
- # (tc_var, var_heap) = newPtr VI_Empty var_heap
- = ([{ tc & tc_var = tc_var } : contexts], var_heap)
- add_spec_contexts (No, expr_ptrs, pos, index) contexts_and_var_heap
- = contexts_and_var_heap
-
- reduce_contexts_of_application :: !Index !{# CommonDefs } !ClassInstanceInfo !ExprInfoPtr
- ([(SymbIdent, Index, ExprInfoPtr,[ClassApplication])], ![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
- -> ([(SymbIdent, Index, ExprInfoPtr,[ClassApplication])], ![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
- reduce_contexts_of_application fun_index defs instance_info over_info_ptr (reduced_calls, new_contexts, coercion_env, type_pattern_vars,
- os=:{os_symbol_heap,os_type_heaps,os_var_heap,os_special_instances,os_error,os_predef_symbols})
- # (EI_Overloaded {oc_symbol, oc_context, oc_specials}, os_symbol_heap) = readPtr over_info_ptr os_symbol_heap
- (glob_fun, os_type_heaps) = trySpecializedInstances oc_context oc_specials os_type_heaps
- | FoundObject glob_fun
- # os_symbol_heap = os_symbol_heap <:= (over_info_ptr, EI_Instance {glob_module = glob_fun.glob_module, glob_object =
- { ds_ident = oc_symbol.symb_ident, ds_arity = 0, ds_index = glob_fun.glob_object }} [])
- = (reduced_calls, new_contexts, coercion_env, type_pattern_vars, { os & os_type_heaps = os_type_heaps, os_symbol_heap = os_symbol_heap })
- | otherwise
- # rs_state = {rs_new_contexts=new_contexts, rs_special_instances = os_special_instances,
- rs_type_pattern_vars=type_pattern_vars,rs_var_heap=os_var_heap,
- rs_type_heaps=os_type_heaps, rs_coercions=coercion_env,
- rs_predef_symbols=os_predef_symbols, rs_error=os_error}
- # info
- = {ri_main_dcl_module_n=main_dcl_module_n, ri_defs=defs, ri_instance_info=instance_info}
- # (class_applications, rs_state)
- = reduceContexts info oc_context rs_state
- # {rs_new_contexts=new_contexts, rs_special_instances = os_special_instances,
- rs_type_pattern_vars=type_pattern_vars,rs_var_heap=os_var_heap,
- rs_type_heaps=os_type_heaps, rs_coercions=coercion_env,
- rs_predef_symbols=os_predef_symbols, rs_error=os_error}
- = rs_state
- = ([ (oc_symbol, fun_index, over_info_ptr, class_applications) : reduced_calls ], new_contexts, coercion_env, type_pattern_vars,
- { os & os_type_heaps = os_type_heaps, os_symbol_heap = os_symbol_heap, os_var_heap = os_var_heap,
- os_special_instances = os_special_instances, os_error = os_error, os_predef_symbols = os_predef_symbols })
+ # (tc_var,var_heap) = newPtr VI_Empty var_heap
+ = ([{tc & tc_var = tc_var} : contexts], var_heap)
remove_super_classes contexts type_heaps
# (super_classes, type_heaps) = foldSt generate_super_classes contexts ([], type_heaps)
@@ -843,7 +843,7 @@ where
generate_super_classes tc=:{tc_class=TCGeneric {gtc_class}} st
= generate_super_classes {tc & tc_class=TCClass gtc_class} st
generate_super_classes {tc_class=TCClass {glob_object={ds_index},glob_module},tc_types} (super_classes, type_heaps)
- # {class_args,class_members,class_context,class_dictionary} = defs.[glob_module].com_class_defs.[ds_index]
+ # {class_args,class_members,class_context} = defs.[glob_module].com_class_defs.[ds_index]
th_vars = fold2St set_type class_args tc_types type_heaps.th_vars
= foldSt subst_context_and_generate_super_classes class_context (super_classes, { type_heaps & th_vars = th_vars })
where
@@ -861,8 +861,8 @@ where
= context
= [tc : context]
- convert_dictionaries :: !{# CommonDefs } ![TypeContext] !(!SymbIdent,!Index,!ExprInfoPtr,![ClassApplication]) !(!*Heaps,!DictionaryTypes, !*ErrorAdmin) -> (!*Heaps,!DictionaryTypes, !*ErrorAdmin)
- convert_dictionaries defs contexts (oc_symbol, index, over_info_ptr, class_applications) (heaps, dict_types, error)
+ convert_dictionaries :: !{#CommonDefs} ![TypeContext] !(!SymbIdent,!Index,!ExprInfoPtr,![ClassApplication]) !(!*Heaps,!DictionaryTypes, !*ErrorAdmin) -> (!*Heaps,!DictionaryTypes, !*ErrorAdmin)
+ convert_dictionaries defs contexts (oc_symbol,index,over_info_ptr,class_applications) (heaps, dict_types, error)
# (heaps, ptrs, error) = convertOverloadedCall defs contexts oc_symbol over_info_ptr class_applications (heaps, [], error)
| isEmpty ptrs
= (heaps, dict_types, error)
@@ -886,12 +886,14 @@ getDictionaryTypeAndConstructor {gi_module,gi_index} defs
(RecordType {rt_constructor}) = defs.[gi_module].com_type_defs.[class_dictionary.ds_index].td_rhs
= (class_dictionary, rt_constructor)
+AttributedType type :== { at_attribute = TA_Multi, at_type = type }
+
convertOverloadedCall :: !{#CommonDefs} ![TypeContext] !SymbIdent !ExprInfoPtr ![ClassApplication] !(!*Heaps, ![ExprInfoPtr],!*ErrorAdmin) -> (!*Heaps, ![ExprInfoPtr],!*ErrorAdmin)
convertOverloadedCall defs contexts {symb_ident,symb_kind = SK_OverloadedFunction {glob_module,glob_object}} expr_ptr [class_appl:class_appls] (heaps,ptrs,error)
# mem_def = defs.[glob_module].com_member_defs.[glob_object]
(class_exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts class_appls (heaps, ptrs)
- (inst_expr, (heaps, ptrs)) = adjust_member_application defs contexts mem_def class_appl class_exprs heaps_and_ptrs
- = ({ heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_ptr, inst_expr)}, ptrs, error)
+ (inst_expr, (heaps, ptrs)) = adjust_member_application defs contexts mem_def class_appl class_exprs heaps_and_ptrs
+ = ({heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_ptr, inst_expr)}, ptrs, error)
where
adjust_member_application defs contexts {me_ident,me_offset,me_class} (CA_Instance red_contexts) class_exprs heaps_and_ptrs
# ({glob_module,glob_object}, red_contexts_appls) = find_instance_of_member me_class me_offset red_contexts
@@ -899,7 +901,7 @@ where
class_exprs = exprs ++ class_exprs
= (EI_Instance { glob_module = glob_module, glob_object = { ds_ident = me_ident, ds_arity = length class_exprs, ds_index = glob_object }} class_exprs,
heaps_and_ptrs)
- adjust_member_application defs contexts {me_ident,me_offset,me_class={glob_module,glob_object}} (CA_Context tc) class_exprs (heaps=:{hp_type_heaps}, ptrs)
+ adjust_member_application defs contexts {me_ident,me_offset,me_class={glob_module,glob_object}} (CA_Context tc) class_exprs (heaps=:{hp_type_heaps}, ptrs)
# (class_context, address, hp_type_heaps) = determineContextAddress contexts defs tc hp_type_heaps
# {class_dictionary={ds_index,ds_ident}} = defs.[glob_module].com_class_defs.[glob_object]
selector = selectFromDictionary glob_module ds_index me_offset defs
@@ -907,7 +909,7 @@ where
({ heaps & hp_type_heaps = hp_type_heaps }, ptrs))
adjust_member_application defs contexts _ (CA_GlobalTypeCode {tci_constructor,tci_contexts}) _ heaps_and_ptrs
# (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs
- = (EI_TypeCode (TCE_Constructor tci_constructor (map expressionToTypeCodeExpression exprs)), heaps_and_ptrs)
+ = (EI_TypeCode (TCE_Constructor tci_constructor (expressionsToTypeCodeExpressions exprs)), heaps_and_ptrs)
adjust_member_application defs contexts _ (CA_LocalTypeCode new_var_ptr) _ heaps_and_ptrs
= (EI_TypeCode (TCE_Var new_var_ptr), heaps_and_ptrs)
@@ -933,13 +935,16 @@ convertOverloadedCall defs contexts symbol=:{symb_ident, symb_kind = SK_Generic
No
# error = checkError ("no generic instances of " +++ toString symb_ident +++ " for kind") kind error
-> (heaps, expr_info_ptrs, error)
- Yes member_glob -> convertOverloadedCall defs contexts {symbol & symb_kind = SK_OverloadedFunction member_glob} expr_ptr class_appls (heaps, expr_info_ptrs, error)
+ Yes member_glob -> convertOverloadedCall defs contexts {symbol & symb_kind = SK_OverloadedFunction member_glob} expr_ptr class_appls (heaps, expr_info_ptrs, error)
convertOverloadedCall defs contexts {symb_ident,symb_kind = SK_TypeCode} expr_info_ptr class_appls (heaps, ptrs, error)
# (class_expressions, (heaps, ptrs)) = convertClassApplsToExpressions defs contexts class_appls (heaps, ptrs)
- = ({ heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_TypeCodes (map expressionToTypeCodeExpression class_expressions))}, ptrs, error)
-convertOverloadedCall defs contexts {symb_ident} expr_info_ptr appls (heaps,ptrs, error)
+ = ({heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_TypeCodes (map expressionToTypeCodeExpression class_expressions))}, ptrs, error)
+convertOverloadedCall defs contexts symbol expr_info_ptr appls (heaps,ptrs, error)
# (class_expressions, (heaps, ptrs)) = convertClassApplsToExpressions defs contexts appls (heaps,ptrs)
- = ({ heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_Context class_expressions)}, ptrs, error)
+ = ({heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_Context class_expressions)}, ptrs, error)
+
+expressionsToTypeCodeExpressions class_expressions
+ = map expressionToTypeCodeExpression class_expressions
expressionToTypeCodeExpression (TypeCodeExpression texpr)
= texpr
@@ -953,8 +958,6 @@ expressionToTypeCodeExpression expr
generateClassSelection address last_selectors
= mapAppend (\(off_set,selector) -> RecordSelection selector off_set) address last_selectors
-AttributedType type :== { at_attribute = TA_Multi, at_type = type }
-
instance toString ClassApplication
where
toString (CA_Instance _) = abort "CA_Instance"
@@ -972,13 +975,13 @@ where
convert_class_appl_to_expression defs contexts (CA_Context tc) (heaps=:{hp_type_heaps}, ptrs)
# (class_context, context_address, hp_type_heaps) = determineContextAddress contexts defs tc hp_type_heaps
| isEmpty context_address
- = (ClassVariable class_context.tc_var, ({ heaps & hp_type_heaps = hp_type_heaps }, ptrs))
- = (Selection NormalSelector (ClassVariable class_context.tc_var) (generateClassSelection context_address []), ({ heaps & hp_type_heaps = hp_type_heaps }, ptrs))
+ = (ClassVariable class_context.tc_var, ({heaps & hp_type_heaps=hp_type_heaps}, ptrs))
+ = (Selection NormalSelector (ClassVariable class_context.tc_var) (generateClassSelection context_address []), ({heaps & hp_type_heaps = hp_type_heaps}, ptrs))
convert_class_appl_to_expression defs contexts (CA_LocalTypeCode new_var_ptr) heaps_and_ptrs
= (TypeCodeExpression (TCE_Var new_var_ptr), heaps_and_ptrs)
convert_class_appl_to_expression defs contexts (CA_GlobalTypeCode {tci_constructor,tci_contexts}) heaps_and_ptrs
# (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs
- = (TypeCodeExpression (TCE_Constructor tci_constructor (map expressionToTypeCodeExpression exprs)), heaps_and_ptrs)
+ = (TypeCodeExpression (TCE_Constructor tci_constructor (expressionsToTypeCodeExpressions exprs)), heaps_and_ptrs)
convert_reduced_contexts_to_expression defs contexts {rcs_class_context,rcs_constraints_contexts} heaps_and_ptrs
# (rcs_exprs, heaps_and_ptrs) = mapSt (convert_class_appl_to_expression defs contexts) rcs_constraints_contexts heaps_and_ptrs
@@ -1036,9 +1039,9 @@ where
symb_kind = SK_Constructor {glob_module = class_index.gi_module, glob_object = dict_cons.ds_index}
}
dict_type_symbol = MakeTypeSymbIdent {glob_module = class_index.gi_module, glob_object = dict_type.ds_index} dict_type.ds_ident dict_type.ds_arity
- class_type = TA dict_type_symbol [ AttributedType type \\ type <- instance_types ]
+ class_type = TA dict_type_symbol [AttributedType type \\ type <- instance_types]
(app_info_ptr, expr_heap) = newPtr (EI_DictionaryType class_type) expr_heap
- rc_record = App { app_symb = record_symbol, app_args = dictionary_args, app_info_ptr = app_info_ptr }
+ rc_record = App {app_symb = record_symbol, app_args = dictionary_args, app_info_ptr = app_info_ptr}
= (rc_record, expr_heap, [app_info_ptr : ptrs])
bind_shared_dictionary nr_of_members dict=:(Let {let_expr=App {app_symb={symb_ident}, app_info_ptr}}) (binds, types, rev_dicts, var_heap, expr_heap)
@@ -1110,7 +1113,8 @@ getClassVariable symb var_info_ptr var_heap error
-> (var_ident, new_info_ptr, var_heap <:= (var_info_ptr, VI_ClassVar var_ident new_info_ptr (inc count)), error)
(_,var_heap)
# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
- -> (symb, new_info_ptr, var_heap <:= (var_info_ptr, VI_ClassVar symb new_info_ptr 1), overloadingError symb error)
+ # error = overloadingError symb error
+ -> (symb, new_info_ptr, var_heap <:= (var_info_ptr, VI_ClassVar symb new_info_ptr 1), error)
removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !Int !*{#FunDef} !*{! FunctionType} !*ExpressionHeap
!*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol}
@@ -1132,11 +1136,11 @@ where
= convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error)
(tb_rhs, ui)
- = updateExpression fun_info.fi_group_index tb_rhs { ui_instance_calls = [], ui_local_vars = fun_info.fi_local_vars, ui_symbol_heap = symbol_heap,
+ = updateExpression fun_info.fi_group_index tb_rhs {ui_instance_calls = [], ui_local_vars = fun_info.fi_local_vars, ui_symbol_heap = symbol_heap,
ui_var_heap = var_heap, ui_fun_defs = fun_defs, ui_fun_env = fun_env, ui_error = error,
ui_has_type_codes = False,
ui_x = {x_type_code_info=type_code_info, x_predef_symbols=predef_symbols,x_main_dcl_module_n=main_dcl_module_n}}
-
+
# {ui_instance_calls, ui_local_vars, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_has_type_codes, ui_error, ui_x = {x_type_code_info = type_code_info, x_predef_symbols = predef_symbols}}
= ui
# (tb_args, var_heap) = foldSt retrieve_class_argument rev_variables (tb_args, ui_var_heap)
@@ -1156,40 +1160,41 @@ where
determine_class_argument {tc_class, tc_var} (variables,var_heap,error)
# (var_info, var_heap) = readPtr tc_var var_heap
- = case var_info of
+ = case var_info of
VI_ForwardClassVar var_info_ptr
# (var_info, var_heap) = readPtr var_info_ptr var_heap
-> case var_info of
VI_Empty
- # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
- -> ([var_info_ptr : variables],var_heap <:= (var_info_ptr, VI_ClassVar (build_var_name (toString tc_class)) new_info_ptr 0),error)
+ -> add_class_var var_info_ptr tc_class var_heap error
VI_ClassVar _ _ _
# error = errorHeading "Overloading error" error
error = {error & ea_file = error.ea_file <<< " a type context occurs multiple times in the specified type\n" }
-> ([var_info_ptr : variables],var_heap,error)
- _
- -> abort ("determine_class_argument 1 (overloading.icl)") //<<- var_info)
-
VI_Empty
- # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
- -> ([tc_var : variables],var_heap <:= (tc_var, VI_ClassVar (build_var_name (toString tc_class)) new_info_ptr 0),error)
- _
- -> abort ("determine_class_argument 2 (overloading.icl)") // <<- var_info)
+ -> add_class_var tc_var tc_class var_heap error
+ where
+ add_class_var var tc_class var_heap error
+ # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
+ var_heap = writePtr var (VI_ClassVar (build_var_name (toString tc_class)) new_info_ptr 0) var_heap
+ = ([var : variables],var_heap,error)
build_var_name id_name
= { id_name = "_v" +++ id_name, id_info = nilPtr }
retrieve_class_argument var_info_ptr (args, var_heap)
# (VI_ClassVar var_ident new_info_ptr count, var_heap) = readPtr var_info_ptr var_heap
- = ([{fv_ident = var_ident, fv_info_ptr = new_info_ptr, fv_def_level = NotALevel, fv_count = count } : args], var_heap <:= (var_info_ptr, VI_Empty))
+ = ([{fv_ident = var_ident, fv_info_ptr = new_info_ptr, fv_def_level = NotALevel, fv_count = count } : args], var_heap <:= (var_info_ptr, VI_Empty))
+convertDynamicTypes :: [ExprInfoPtr]
+ *(*TypeCodeInfo,*ExpressionHeap,[LocalTypePatternVariable],*VarHeap,*ErrorAdmin)
+ -> *(*TypeCodeInfo,*ExpressionHeap,[LocalTypePatternVariable],*VarHeap,*ErrorAdmin)
convertDynamicTypes dyn_ptrs update_info
= foldSt update_dynamic dyn_ptrs update_info
-where
+where
update_dynamic dyn_ptr (type_code_info, expr_heap, type_pattern_vars, var_heap, error)
# (dyn_info, expr_heap) = readPtr dyn_ptr expr_heap
= case dyn_info of
- EI_TempDynamicType (Yes {dt_global_vars, dt_uni_vars, dt_type}) loc_dynamics _ _ expr_ptr {symb_ident}
+ EI_TempDynamicType (Yes {dt_global_vars,dt_uni_vars,dt_type}) loc_dynamics _ _ expr_ptr {symb_ident}
# (expr_info, expr_heap) = readPtr expr_ptr expr_heap
-> case expr_info of
EI_TypeCodes type_codes
@@ -1217,7 +1222,7 @@ where
# (_, var_info_ptr, var_heap, error) = getClassVariable symb_ident record_var var_heap error
expr_heap = expr_heap <:= (dyn_ptr, EI_TypeOfDynamic (convert_selectors selectors var_info_ptr))
-> convert_local_dynamics loc_dynamics (type_code_info, expr_heap, type_pattern_vars, var_heap, error)
- EI_TempDynamicPattern type_vars {dt_global_vars, dt_uni_vars, dt_type} loc_dynamics temp_local_vars _ _ expr_ptr {symb_ident}
+ EI_TempDynamicPattern type_vars {dt_global_vars,dt_uni_vars,dt_type} loc_dynamics temp_local_vars _ _ expr_ptr {symb_ident}
# (expr_info, expr_heap) = readPtr expr_ptr expr_heap
-> case expr_info of
EI_TypeCodes type_codes
@@ -1225,13 +1230,19 @@ where
= bind_type_vars_to_type_codes symb_ident dt_global_vars type_codes type_code_info.tci_type_var_heap var_heap error
(var_ptrs, (type_pattern_vars, var_heap)) = mapSt addLocalTCInstance temp_local_vars (type_pattern_vars, var_heap)
type_var_heap = bind_type_vars_to_type_var_codes type_vars var_ptrs type_var_heap
- (type_code_expr, (type_code_info,var_heap,error)) = toTypeCodeExpression (add_universal_vars_to_type dt_uni_vars dt_type) ({ type_code_info & tci_type_var_heap = type_var_heap },var_heap, error)
- -> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), type_pattern_vars, var_heap, error)
+ type_code_info = {type_code_info & tci_type_var_heap = type_var_heap}
+ (type_code_expr, (type_code_info,var_heap,error))
+ = toTypeCodeExpression (add_universal_vars_to_type dt_uni_vars dt_type) (type_code_info, var_heap, error)
+ expr_heap = expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr)
+ -> convert_local_dynamics loc_dynamics (type_code_info, expr_heap, type_pattern_vars, var_heap, error)
EI_Empty
# (var_ptrs, (type_pattern_vars, var_heap)) = mapSt addLocalTCInstance temp_local_vars (type_pattern_vars, var_heap)
type_var_heap = bind_type_vars_to_type_var_codes type_vars var_ptrs type_code_info.tci_type_var_heap
- (type_code_expr, (type_code_info,var_heap,error)) = toTypeCodeExpression (add_universal_vars_to_type dt_uni_vars dt_type) ({ type_code_info & tci_type_var_heap = type_var_heap }, var_heap, error)
- -> convert_local_dynamics loc_dynamics (type_code_info, expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr), type_pattern_vars, var_heap, error)
+ type_code_info = {type_code_info & tci_type_var_heap = type_var_heap}
+ (type_code_expr, (type_code_info,var_heap,error))
+ = toTypeCodeExpression (add_universal_vars_to_type dt_uni_vars dt_type) (type_code_info, var_heap, error)
+ expr_heap = expr_heap <:= (dyn_ptr, EI_TypeOfDynamicPattern var_ptrs type_code_expr)
+ -> convert_local_dynamics loc_dynamics (type_code_info, expr_heap, type_pattern_vars, var_heap, error)
where
bind_type_vars_to_type_codes symb_ident type_vars type_codes type_var_heap var_heap error
= fold2St (bind_type_var_to_type_code symb_ident) type_vars type_codes (type_var_heap, var_heap, error)
@@ -1243,7 +1254,7 @@ where
bind_type_vars_to_type_var_codes type_vars var_ptrs type_var_heap
= fold2St bind_type_var_to_type_var_code type_vars var_ptrs type_var_heap
where
- bind_type_var_to_type_var_code {tv_ident,tv_info_ptr} var_ptr type_var_heap
+ bind_type_var_to_type_var_code {tv_info_ptr} var_ptr type_var_heap
= type_var_heap <:= (tv_info_ptr, TVI_TypeCode (TCE_Var var_ptr))
add_universal_vars_to_type [] at
@@ -1385,13 +1396,14 @@ where
updateExpression group_index (App {app_symb={symb_kind=SK_NewTypeConstructor _},app_args=[arg]}) ui
= updateExpression group_index arg ui
updateExpression group_index (App app=:{app_symb=symb=:{symb_kind,symb_ident},app_args,app_info_ptr}) ui
- # (app_args, ui) = updateExpression group_index app_args ui
| isNilPtr app_info_ptr
- = (App { app & app_args = app_args }, ui)
+ # (app_args, ui) = updateExpression group_index app_args ui
+ = (App {app & app_args = app_args}, ui)
# (symb_info, ui_symbol_heap) = readPtr app_info_ptr ui.ui_symbol_heap
- ui = { ui & ui_symbol_heap = ui_symbol_heap }
+ ui = {ui & ui_symbol_heap = ui_symbol_heap}
= case symb_info of
EI_Empty
+ # (app_args, ui) = updateExpression group_index app_args ui
#! main_dcl_module_n = ui.ui_x.UpdateInfoX.x_main_dcl_module_n
#! fun_index = get_recursive_fun_index group_index symb_kind main_dcl_module_n ui.ui_fun_defs
| fun_index == NoIndex
@@ -1400,6 +1412,7 @@ where
(app_args, (ui_var_heap, ui_error)) = mapAppendSt (build_context_arg symb_ident) st_context app_args (ui.ui_var_heap, ui.ui_error)
-> (App { app & app_args = app_args }, { ui & ui_var_heap = ui_var_heap, ui_error = ui_error })
EI_Context context_args
+ # (app_args, ui) = updateExpression group_index app_args ui
# (app_args, ui) = adjustClassExpressions symb_ident context_args app_args ui
#! main_dcl_module_n = ui.ui_x.UpdateInfoX.x_main_dcl_module_n
#! fun_index = get_recursive_fun_index group_index symb_kind main_dcl_module_n ui.ui_fun_defs
@@ -1412,11 +1425,13 @@ where
(app_args, (ui_var_heap, ui_error)) = mapAppendSt (build_context_arg symb_ident) (take nr_of_lifted_contexts st_context) app_args (ui.ui_var_heap,ui.ui_error)
-> (App { app & app_args = app_args }, examine_calls context_args {ui & ui_var_heap = ui_var_heap, ui_error = ui_error })
EI_Instance inst_symbol context_args
+ # (app_args, ui) = updateExpression group_index app_args ui
# (context_args, ui=:{ui_var_heap, ui_error}) = adjustClassExpressions symb_ident context_args [] ui
-> (build_application inst_symbol context_args app_args app_info_ptr,
examine_calls context_args (new_call inst_symbol.glob_module inst_symbol.glob_object.ds_index
{ ui & ui_var_heap = ui_var_heap, ui_error = ui_error }))
EI_Selection selectors record_var context_args
+ # (app_args, ui) = updateExpression group_index app_args ui
# (all_args, ui=:{ui_var_heap, ui_error}) = adjustClassExpressions symb_ident context_args app_args ui
(var_ident, var_info_ptr, ui_var_heap, ui_error) = getClassVariable symb_ident record_var ui_var_heap ui_error
select_expr = Selection NormalSelector (Var { var_ident = var_ident, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr }) selectors
@@ -1424,7 +1439,6 @@ where
-> (select_expr, { ui & ui_var_heap = ui_var_heap, ui_error = ui_error })
-> (select_expr @ all_args, examine_calls context_args
{ ui & ui_var_heap = ui_var_heap, ui_error = ui_error })
-
where
build_context_arg symb tc=:{tc_var} (var_heap, error)
# (var_info, var_heap) = readPtr tc_var var_heap
@@ -1461,43 +1475,6 @@ where
symb_kind = SK_Function { def_symbol & glob_object = glob_object.ds_index } },
app_args = context_args ++ orig_args, app_info_ptr = app_info_ptr }
- examine_application (SK_Function {glob_module,glob_object}) ui
- = new_call glob_module glob_object ui
- examine_application symb_kind ui
- = ui
-
- new_call mod_index symb_index ui=:{ui_instance_calls,ui_fun_defs}
- | mod_index == ui.ui_x.UpdateInfoX.x_main_dcl_module_n && symb_index < size ui_fun_defs
- # ui_instance_calls = add_call symb_index ui_instance_calls
- = { ui & ui_instance_calls = ui_instance_calls }
- = ui
- where
- add_call fun_num []
- = [FunCall fun_num 0]
- add_call fun_num funs=:[call=:(FunCall fc_index _) : ui]
- | fun_num == fc_index
- = funs
- | fun_num < fc_index
- = [FunCall fun_num 0 : funs]
- = [call : add_call fun_num ui]
-
- examine_calls [expr : exprs] ui
- = examine_calls exprs (examine_calls_in_expr expr ui)
- where
- examine_calls_in_expr (App {app_symb = {symb_ident,symb_kind}, app_args}) ui
- = examine_calls app_args (examine_application symb_kind ui)
- examine_calls_in_expr (Let {let_expr,let_lazy_binds}) ui
- # ui = examine_calls_in_expr let_expr ui
- = foldSt (examine_calls_bind) let_lazy_binds (examine_calls_in_expr let_expr ui)
- examine_calls_in_expr _ ui
- = ui
-
- examine_calls_bind {lb_src,lb_dst} ui=:{ui_local_vars}
- = examine_calls_in_expr lb_src { ui & ui_local_vars = [lb_dst : ui_local_vars ]}
-
- examine_calls [] ui
- = ui
-
updateExpression group_index (expr @ exprs) ui
# ((expr, exprs), ui) = updateExpression group_index (expr, exprs) ui
= (expr @ exprs, ui)
@@ -1527,15 +1504,14 @@ where
= (RecordUpdate cons_symbol expression expressions, ui)
updateExpression group_index (DynamicExpr dyn=:{dyn_expr,dyn_info_ptr}) ui=:{ui_has_type_codes}
# (dyn_expr, ui) = updateExpression group_index dyn_expr {ui & ui_has_type_codes = False}
- # ui = check_type_codes_in_dynamic ui
+ ui = check_type_codes_in_dynamic ui
with
check_type_codes_in_dynamic ui=:{ui_has_type_codes, ui_error}
| ui_has_type_codes
# ui_error = typeCodeInDynamicError ui_error
= {ui & ui_error = ui_error}
- // otherwise
- = ui
- # ui = {ui & ui_has_type_codes=ui_has_type_codes}
+ = ui
+ ui = {ui & ui_has_type_codes=ui_has_type_codes}
(EI_TypeOfDynamic type_code, ui_symbol_heap) = readPtr dyn_info_ptr ui.ui_symbol_heap
ui = { ui & ui_symbol_heap = ui_symbol_heap }
= (DynamicExpr { dyn & dyn_expr = dyn_expr, dyn_type_code = type_code }, ui)
@@ -1552,12 +1528,12 @@ where
= updateExpression group_index expr ui
updateExpression group_index expr=:(Var {var_info_ptr}) ui
# (var_info,var_heap) = readPtr var_info_ptr ui.ui_var_heap
- # ui = { ui & ui_var_heap = var_heap }
+ # ui = {ui & ui_var_heap = var_heap}
= case var_info of
VI_Alias var2
# (var_info2,var_heap) = readPtr var2.var_info_ptr ui.ui_var_heap
# ui = { ui & ui_var_heap = var_heap }
- -> skip_aliases var_info2 var2 var_info_ptr ui
+ -> skip_aliases var_info2 var2 var_info_ptr ui
_
-> (expr,ui)
where
@@ -1573,6 +1549,42 @@ where
updateExpression group_index expr ui
= (expr, ui)
+examine_calls [expr : exprs] ui
+ = examine_calls exprs (examine_calls_in_expr expr ui)
+where
+ examine_calls_in_expr (App {app_symb = {symb_ident,symb_kind}, app_args}) ui
+ = examine_calls app_args (examine_application symb_kind ui)
+ examine_calls_in_expr (Let {let_expr,let_lazy_binds}) ui
+ # ui = examine_calls_in_expr let_expr ui
+ = foldSt (examine_calls_bind) let_lazy_binds (examine_calls_in_expr let_expr ui)
+ examine_calls_in_expr _ ui
+ = ui
+
+ examine_calls_bind {lb_src,lb_dst} ui=:{ui_local_vars}
+ = examine_calls_in_expr lb_src {ui & ui_local_vars = [lb_dst : ui_local_vars]}
+
+ examine_application (SK_Function {glob_module,glob_object}) ui
+ = new_call glob_module glob_object ui
+ examine_application symb_kind ui
+ = ui
+examine_calls [] ui
+ = ui
+
+new_call mod_index symb_index ui=:{ui_instance_calls,ui_fun_defs}
+ | mod_index == ui.ui_x.UpdateInfoX.x_main_dcl_module_n && symb_index < size ui_fun_defs
+ # ui_instance_calls = add_call symb_index ui_instance_calls
+ = {ui & ui_instance_calls = ui_instance_calls}
+ = ui
+where
+ add_call fun_num []
+ = [FunCall fun_num 0]
+ add_call fun_num funs=:[call=:(FunCall fc_index _) : ui]
+ | fun_num == fc_index
+ = funs
+ | fun_num < fc_index
+ = [FunCall fun_num 0 : funs]
+ = [call : add_call fun_num ui]
+
set_alias_and_detect_cycle info_ptr var ui
| info_ptr<>var.var_info_ptr
= { ui & ui_var_heap = writePtr info_ptr (VI_Alias var) ui.ui_var_heap }
@@ -1669,7 +1681,7 @@ where
instance updateExpression AlgebraicPattern
where
- updateExpression group_index pattern=:{ap_vars,ap_expr} ui
+ updateExpression group_index pattern=:{ap_expr} ui
# (ap_expr, ui) = updateExpression group_index ap_expr ui
= ({ pattern & ap_expr = ap_expr }, ui)
@@ -1698,9 +1710,9 @@ where
instance updateExpression DynamicPattern
where
updateExpression group_index dp=:{dp_type,dp_rhs} ui
- # (dp_rhs, ui) = updateExpression group_index dp_rhs ui
+ # (dp_rhs, ui) = updateExpression group_index dp_rhs ui
(EI_TypeOfDynamicPattern type_pattern_vars type_code, ui_symbol_heap) = readPtr dp_type ui.ui_symbol_heap
- = ({ dp & dp_rhs = dp_rhs, dp_type_code = type_code }, { ui & ui_symbol_heap = ui_symbol_heap })
+ = ({dp & dp_rhs = dp_rhs, dp_type_code = type_code}, {ui & ui_symbol_heap = ui_symbol_heap})
instance updateExpression (a,b) | updateExpression a & updateExpression b
where
@@ -1760,35 +1772,31 @@ adjustClassExpressions symb_ident exprs tail_exprs ui
= mapAppendSt (adjustClassExpression symb_ident) exprs tail_exprs ui
where
adjustClassExpression symb_ident (App app=:{app_args}) ui
- # (app_args, ui) = adjustClassExpressions symb_ident app_args [] ui
- = (App { app & app_args = app_args }, ui)
+ # (app_args, ui) = adjustClassExpressions symb_ident app_args [] ui
+ = (App {app & app_args = app_args}, ui)
adjustClassExpression symb_ident (ClassVariable var_info_ptr) ui=:{ui_var_heap, ui_error}
# (var_ident, var_info_ptr, ui_var_heap, ui_error) = getClassVariable symb_ident var_info_ptr ui_var_heap ui_error
- = (Var { var_ident = var_ident, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr }, { ui & ui_var_heap = ui_var_heap, ui_error = ui_error})
+ = (Var {var_ident = var_ident, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}, {ui & ui_var_heap = ui_var_heap, ui_error = ui_error})
adjustClassExpression symb_ident (Selection opt_type expr selectors) ui
# (expr, ui) = adjustClassExpression symb_ident expr ui
= (Selection opt_type expr selectors, ui)
adjustClassExpression symb_ident tce=:(TypeCodeExpression type_code) ui
- # (type_code, ui) = adjust_type_code type_code ui
+ # (type_code, ui) = adjust_type_code type_code ui
= (TypeCodeExpression type_code, {ui & ui_has_type_codes = True})
where
adjust_type_code (TCE_TypeTerm var_info_ptr) ui=:{ui_var_heap,ui_error}
# (var_info_ptr, (ui_var_heap,ui_error))
- = getTCDictionary symb_ident var_info_ptr (ui_var_heap, ui_error)
- # ui
- = { ui & ui_var_heap = ui_var_heap, ui_error = ui_error}
- = (TCE_TypeTerm var_info_ptr, ui)
- adjust_type_code (TCE_Constructor cons typecode_exprs)
- ui
- # (typecode_exprs, ui)
- = mapSt adjust_type_code typecode_exprs ui
- = (TCE_Constructor cons typecode_exprs, ui)
+ = getTCDictionary symb_ident var_info_ptr (ui_var_heap, ui_error)
+ # ui = {ui & ui_var_heap = ui_var_heap, ui_error = ui_error}
+ = (TCE_TypeTerm var_info_ptr, ui)
+ adjust_type_code (TCE_Constructor cons typecode_exprs) ui
+ # (typecode_exprs, ui) = mapSt adjust_type_code typecode_exprs ui
+ = (TCE_Constructor cons typecode_exprs, ui)
adjust_type_code (TCE_UniType uni_vars type_code) ui
- # (type_code, ui)
- = adjust_type_code type_code ui
- = (TCE_UniType uni_vars type_code, ui)
+ # (type_code, ui) = adjust_type_code type_code ui
+ = (TCE_UniType uni_vars type_code, ui)
adjust_type_code type_code ui
- = (type_code, ui)
+ = (type_code, ui)
adjustClassExpression symb_ident (Let this_let=:{let_strict_binds, let_lazy_binds, let_expr }) ui
# (let_strict_binds, ui) = adjust_let_binds symb_ident let_strict_binds ui