Commit 404f41b1 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

update of dictionary types

Peter's bug removed
parent b0a85baf
......@@ -34,9 +34,10 @@ import syntax, check, typesupport
}
:: LocalTypePatternVariable
:: DictionaryTypes :== [(Index, [ExprInfoPtr])]
tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState
-> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
-> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], DictionaryTypes, !*OverloadingState)
:: TypeCodeInfo =
{ tci_next_index :: !Index
......
......@@ -521,20 +521,22 @@ where
try_specialized_instances type_contexts_types [] type_var_heap
= (ObjectNotFound, type_var_heap)
:: DictionaryTypes :== [(Index, [ExprInfoPtr])]
tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState
-> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
-> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], DictionaryTypes, !*OverloadingState)
tryToSolveOverloading ocs defs instance_info coercion_env os
# (reduced_contexts, contexts, coercion_env, type_pattern_vars, os) = foldSt (reduce_contexts 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_type_heaps) = remove_sub_classes contexts os.os_type_heaps
{ hp_var_heap, hp_expression_heap, hp_type_heaps} = 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}
= (contexts, coercion_env, type_pattern_vars, { os & os_type_heaps = hp_type_heaps, os_symbol_heap = hp_expression_heap, os_var_heap = hp_var_heap })
= ([], coercion_env, type_pattern_vars, os)
({ hp_var_heap, hp_expression_heap, hp_type_heaps}, dict_types) = 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}, [])
= (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} )
= ([], coercion_env, type_pattern_vars, [], os)
where
reduce_contexts defs instance_info (opt_spec_contexts, expr_ptrs, pos, index) rc_state
= foldSt (reduce_contexts_of_application defs instance_info) expr_ptrs rc_state
= foldSt (reduce_contexts_of_application index defs instance_info) expr_ptrs rc_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
......@@ -547,10 +549,10 @@ where
add_spec_contexts (No, expr_ptrs, pos, index) contexts_and_var_heap
= contexts_and_var_heap
reduce_contexts_of_application :: !{# CommonDefs } !ClassInstanceInfo !ExprInfoPtr
([(SymbIdent, ExprInfoPtr,[ClassApplication])], ![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
-> ([(SymbIdent, ExprInfoPtr,[ClassApplication])], ![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
reduce_contexts_of_application defs instance_info over_info_ptr (reduced_calls, new_contexts, coercion_env, type_pattern_vars,
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
......@@ -563,7 +565,7 @@ where
(os_var_heap, os_type_heaps), coercion_env, os_predef_symbols, os_error)
= reduceContexts oc_context defs instance_info new_contexts os_special_instances type_pattern_vars
(os_var_heap, os_type_heaps) coercion_env os_predef_symbols os_error
= ([ (oc_symbol, over_info_ptr, class_applications) : reduced_calls ], new_contexts, coercion_env, type_pattern_vars,
= ([ (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 })
......@@ -588,9 +590,19 @@ where
= context
= [tc : context]
convert_dictionaries :: !{# CommonDefs } ![TypeContext] !(!SymbIdent,!ExprInfoPtr,![ClassApplication]) !*Heaps -> *Heaps
convert_dictionaries defs contexts (oc_symbol, over_info_ptr, class_applications) heaps
= convertOverloadedCall defs contexts oc_symbol over_info_ptr class_applications heaps
convert_dictionaries :: !{# CommonDefs } ![TypeContext] !(!SymbIdent,!Index,!ExprInfoPtr,![ClassApplication]) !(!*Heaps,!DictionaryTypes) -> (!*Heaps,!DictionaryTypes)
convert_dictionaries defs contexts (oc_symbol, index, over_info_ptr, class_applications) (heaps, dict_types)
# (heaps, ptrs) = convertOverloadedCall defs contexts oc_symbol over_info_ptr class_applications (heaps, [])
| isEmpty ptrs
= (heaps, dict_types)
= (heaps, add_to_dict_types index ptrs dict_types)
add_to_dict_types index ptrs []
= [(index, ptrs)]
add_to_dict_types new_index new_ptrs dt=:[(index, ptrs) : dict_types]
| new_index == index
= [(index, new_ptrs ++ ptrs) : dict_types]
= [(new_index, new_ptrs) : dt]
selectFromDictionary dict_mod dict_index member_index defs
# (RecordType {rt_fields}) = defs.[dict_mod].com_type_defs.[dict_index].td_rhs
......@@ -602,30 +614,30 @@ getDictionaryTypeAndConstructor {glob_module, glob_object = {ds_ident,ds_index}}
(RecordType {rt_constructor}) = defs.[glob_module].com_type_defs.[class_dictionary.ds_index].td_rhs
= (class_dictionary, rt_constructor)
convertOverloadedCall :: !{#CommonDefs} ![TypeContext] !SymbIdent !ExprInfoPtr ![ClassApplication] !*Heaps -> *Heaps
convertOverloadedCall defs contexts {symb_name,symb_kind = SK_OverloadedFunction {glob_module,glob_object}, symb_arity} expr_ptr [class_appl:class_appls] heaps
convertOverloadedCall :: !{#CommonDefs} ![TypeContext] !SymbIdent !ExprInfoPtr ![ClassApplication] !(!*Heaps, ![ExprInfoPtr]) -> (!*Heaps, ![ExprInfoPtr])
convertOverloadedCall defs contexts {symb_name,symb_kind = SK_OverloadedFunction {glob_module,glob_object}, symb_arity} expr_ptr [class_appl:class_appls] heaps_and_ptrs
# mem_def = defs.[glob_module].com_member_defs.[glob_object]
(class_exprs, heaps) = convertClassApplsToExpressions defs contexts class_appls heaps
(inst_expr, heaps) = adjust_member_application defs contexts mem_def symb_arity class_appl class_exprs heaps
= { heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_ptr, inst_expr)}
(class_exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts class_appls heaps_and_ptrs
(inst_expr, (heaps, ptrs)) = adjust_member_application defs contexts mem_def symb_arity class_appl class_exprs heaps_and_ptrs
= ({ heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_ptr, inst_expr)}, ptrs)
where
adjust_member_application defs contexts {me_symb,me_offset,me_class} symb_arity (CA_Instance red_contexts) class_exprs heaps
adjust_member_application defs contexts {me_symb,me_offset,me_class} symb_arity (CA_Instance red_contexts) class_exprs heaps_and_ptrs
# ({glob_module,glob_object}, red_contexts) = find_instance_of_member me_class me_offset red_contexts
(exprs, heaps) = convertClassApplsToExpressions defs contexts red_contexts heaps
(exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts red_contexts heaps_and_ptrs
class_exprs = exprs ++ class_exprs
= (EI_Instance { glob_module = glob_module, glob_object = { ds_ident = me_symb, ds_arity = length class_exprs, ds_index = glob_object }} class_exprs,
heaps)
adjust_member_application defs contexts {me_symb,me_offset,me_class={glob_module,glob_object}} symb_arity (CA_Context tc) class_exprs heaps=:{hp_type_heaps}
heaps_and_ptrs)
adjust_member_application defs contexts {me_symb,me_offset,me_class={glob_module,glob_object}} symb_arity (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}} = defs.[glob_module].com_class_defs.[glob_object]
selector = selectFromDictionary glob_module ds_index me_offset defs
= (EI_Selection (generateClassSelection address [RecordSelection selector me_offset]) class_context.tc_var class_exprs,
{ heaps & hp_type_heaps = hp_type_heaps } )
adjust_member_application defs contexts _ _ (CA_GlobalTypeCode {tci_index,tci_contexts}) _ heaps
# (exprs, heaps) = convertClassApplsToExpressions defs contexts tci_contexts heaps
= (EI_TypeCode (TCE_Constructor tci_index (map expressionToTypeCodeExpression exprs)), heaps)
adjust_member_application defs contexts _ _ (CA_LocalTypeCode new_var_ptr) _ heaps
= (EI_TypeCode (TCE_Var new_var_ptr), heaps)
({ heaps & hp_type_heaps = hp_type_heaps }, ptrs))
adjust_member_application defs contexts _ _ (CA_GlobalTypeCode {tci_index,tci_contexts}) _ heaps_and_ptrs
# (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs
= (EI_TypeCode (TCE_Constructor tci_index (map expressionToTypeCodeExpression 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)
find_instance_of_member me_class me_offset { rcs_class_context = {rc_class, rc_inst_module, rc_inst_members, rc_red_contexts}, rcs_constraints_contexts}
| rc_class.glob_module == me_class.glob_module && rc_class.glob_object.ds_index == me_class.glob_object
......@@ -636,13 +648,12 @@ where
= find_instance_of_member me_class me_offset {rcs & rcs_constraints_contexts = rcs_constraints_contexts ++ rcss}
find_instance_of_member_in_constraints me_class me_offset []
= abort "Error in module overloading: find_instance_of_member_in_constraints\n"
convertOverloadedCall defs contexts {symb_name,symb_kind = SK_TypeCode} expr_info_ptr class_appls heaps
# (class_expressions, heaps) = convertClassApplsToExpressions defs contexts class_appls heaps
// = abort ("convertOverloadedCall" +++ toString symb_name) // class_expressions
= { heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_TypeCodes (map expressionToTypeCodeExpression class_expressions))}
convertOverloadedCall defs contexts {symb_name} expr_info_ptr appls heaps
# (class_expressions, heaps) = convertClassApplsToExpressions defs contexts appls heaps
= { heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_Context class_expressions)}
convertOverloadedCall defs contexts {symb_name,symb_kind = SK_TypeCode} expr_info_ptr class_appls heaps_and_ptrs
# (class_expressions, (heaps, ptrs)) = convertClassApplsToExpressions defs contexts class_appls heaps_and_ptrs
= ({ heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_TypeCodes (map expressionToTypeCodeExpression class_expressions))}, ptrs)
convertOverloadedCall defs contexts {symb_name} expr_info_ptr appls heaps_and_ptrs
# (class_expressions, (heaps, ptrs)) = convertClassApplsToExpressions defs contexts appls heaps_and_ptrs
= ({ heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_Context class_expressions)}, ptrs)
expressionToTypeCodeExpression (TypeCodeExpression texpr) = texpr
......@@ -665,42 +676,42 @@ where
toString (CA_LocalTypeCode _) = abort "CA_LocalTypeCode"
toString (CA_GlobalTypeCode _) = abort "CA_GlobalTypeCode"
convertClassApplsToExpressions defs contexts cl_appls heaps
= mapSt (convert_class_appl_to_expression defs contexts) cl_appls heaps
convertClassApplsToExpressions defs contexts cl_appls heaps_and_ptrs
= mapSt (convert_class_appl_to_expression defs contexts) cl_appls heaps_and_ptrs
where
convert_class_appl_to_expression defs contexts (CA_Instance rcs) heaps
= convert_reduced_contexts_to_expression defs contexts rcs heaps
convert_class_appl_to_expression defs contexts (CA_Context tc) heaps=:{hp_type_heaps}
convert_class_appl_to_expression defs contexts (CA_Instance rcs) heaps_and_ptrs
= convert_reduced_contexts_to_expression defs contexts rcs heaps_and_ptrs
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 })
= (Selection No (ClassVariable class_context.tc_var) (generateClassSelection context_address []), { heaps & hp_type_heaps = hp_type_heaps })
convert_class_appl_to_expression defs contexts (CA_LocalTypeCode new_var_ptr) heaps
= (TypeCodeExpression (TCE_Var new_var_ptr), heaps)
convert_class_appl_to_expression defs contexts (CA_GlobalTypeCode {tci_index,tci_contexts}) heaps
# (exprs, heaps) = convertClassApplsToExpressions defs contexts tci_contexts heaps
= (TypeCodeExpression (TCE_Constructor tci_index (map expressionToTypeCodeExpression exprs)), heaps)
convert_reduced_contexts_to_expression defs contexts {rcs_class_context,rcs_constraints_contexts} heaps
# (rcs_exprs, heaps) = mapSt (convert_reduced_contexts_to_expression defs contexts) rcs_constraints_contexts heaps
= convert_reduced_context_to_expression defs contexts rcs_class_context rcs_exprs heaps
= (ClassVariable class_context.tc_var, ({ heaps & hp_type_heaps = hp_type_heaps }, ptrs))
= (Selection No (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_index,tci_contexts}) heaps_and_ptrs
# (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs
= (TypeCodeExpression (TCE_Constructor tci_index (map expressionToTypeCodeExpression 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_reduced_contexts_to_expression defs contexts) rcs_constraints_contexts heaps_and_ptrs
= convert_reduced_context_to_expression defs contexts rcs_class_context rcs_exprs heaps_and_ptrs
where
convert_reduced_context_to_expression defs contexts {rc_class, rc_inst_module, rc_inst_members, rc_red_contexts, rc_types} dictionary_args heaps
# (expressions, heaps) = convertClassApplsToExpressions defs contexts rc_red_contexts heaps
convert_reduced_context_to_expression defs contexts {rc_class, rc_inst_module, rc_inst_members, rc_red_contexts, rc_types} dictionary_args heaps_and_ptrs
# (expressions, (heaps, class_ptrs)) = convertClassApplsToExpressions defs contexts rc_red_contexts heaps_and_ptrs
context_size = length expressions
| size rc_inst_members > 1 && context_size > 0
# (let_binds, let_types, rev_dicts, hp_var_heap, hp_expression_heap)
= foldSt (bind_shared_dictionary (size rc_inst_members)) expressions ([], [], [], heaps.hp_var_heap, heaps.hp_expression_heap)
dictionary_args = build_class_members (size rc_inst_members) rc_inst_members rc_inst_module (reverse rev_dicts) context_size dictionary_args
(dict_expr, hp_expression_heap) = build_dictionary rc_class rc_types dictionary_args defs hp_expression_heap
(dict_expr, hp_expression_heap, class_ptrs) = build_dictionary rc_class rc_types dictionary_args defs hp_expression_heap class_ptrs
| isEmpty let_binds
= (dict_expr, { heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap })
= (dict_expr, ({ heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap }, class_ptrs))
# (let_info_ptr, hp_expression_heap) = newPtr (EI_LetType let_types) hp_expression_heap
= (Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = dict_expr, let_info_ptr = let_info_ptr },
{ heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap })
({ heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap }, [let_info_ptr : class_ptrs]))
# dictionary_args = build_class_members (size rc_inst_members) rc_inst_members rc_inst_module expressions context_size dictionary_args
(dict_expr, hp_expression_heap) = build_dictionary rc_class rc_types dictionary_args defs heaps.hp_expression_heap
= (dict_expr, { heaps & hp_expression_heap = hp_expression_heap })
(dict_expr, hp_expression_heap, class_ptrs) = build_dictionary rc_class rc_types dictionary_args defs heaps.hp_expression_heap class_ptrs
= (dict_expr, ({ heaps & hp_expression_heap = hp_expression_heap }, class_ptrs))
build_class_members mem_offset ins_members mod_index class_arguments arity dictionary_args
| mem_offset == 0
......@@ -715,7 +726,7 @@ where
app_info_ptr = nilPtr }
= build_class_members mem_offset ins_members mod_index class_arguments arity [ mem_expr : dictionary_args ]
build_dictionary class_symbol instance_types dictionary_args defs expr_heap
build_dictionary class_symbol instance_types dictionary_args defs expr_heap ptrs
# (dict_type, dict_cons) = getDictionaryTypeAndConstructor class_symbol defs
record_symbol = { symb_name = dict_cons.ds_ident,
symb_kind = SK_Constructor {glob_module = class_symbol.glob_module, glob_object = dict_cons.ds_index},
......@@ -724,7 +735,7 @@ where
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, expr_heap)
= (rc_record, expr_heap, [app_info_ptr : ptrs])
bind_shared_dictionary nr_of_members dict=:(Let {let_expr=App {app_symb={symb_name}, app_info_ptr}}) (binds, types, rev_dicts, var_heap, expr_heap)
# (EI_DictionaryType class_type, expr_heap) = readPtr app_info_ptr expr_heap
......
......@@ -4,6 +4,8 @@ import StdEnv
import scanner, general, typeproperties, Heap
PA_BUG on off :== on
:: Ident =
{ id_name :: !String
, id_info :: !SymbolPtr
......
......@@ -6,6 +6,8 @@ import RWSDebug
import scanner, general, Heap, typeproperties, utilities
PA_BUG on off :== on
:: Ident =
{ id_name :: !String
, id_info :: !SymbolPtr
......@@ -1157,8 +1159,6 @@ where
= "u" + toString tav_number + ": "
toString (TA_Var avar)
= toString avar + ": "
toString TA_TempExVar
= "(E)"
toString (TA_RootVar avar)
= toString avar + ": "
toString (TA_Anonymous)
......@@ -1169,6 +1169,8 @@ where
= "o "
toString (TA_List _ _)
= "??? "
toString TA_TempExVar
= PA_BUG "(E)" (abort "toString TA_TempExVar")
instance <<< Annotation
where
......
......@@ -357,8 +357,7 @@ freshCopyOfTypeAttribute (TA_Var avar) attr_var_heap
/* Should be removed !!!!!!!!!! */
freshCopyOfTypeAttribute (TA_RootVar avar) attr_var_heap
// = freshCopyOfAttributeVar avar attr_var_heap
= (TA_TempExVar, attr_var_heap)
= PA_BUG (TA_TempExVar, attr_var_heap) (freshCopyOfAttributeVar avar attr_var_heap)
freshCopyOfTypeAttribute TA_None attr_var_heap
= (TA_Multi, attr_var_heap)
freshCopyOfTypeAttribute TA_Unique attr_var_heap
......@@ -1324,42 +1323,51 @@ specification_error type err
format = { form_properties = cAttributed, form_attr_position = No}
= { err & ea_file = err.ea_file <<< " specified type conflicts with derived type " <:: (format, type) <<< '\n' }
cleanUpAndCheckFunctionTypes [] _ start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
cleanUpAndCheckFunctionTypes [] _ _ start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
= (fun_defs, ts)
cleanUpAndCheckFunctionTypes [fun : funs] [ {fe_requirements = {req_case_and_let_exprs}} : reqs] start_index defs type_contexts coercion_env
cleanUpAndCheckFunctionTypes [fun : funs] [ {fe_requirements = {req_case_and_let_exprs}} : reqs] dict_types start_index defs type_contexts coercion_env
attr_partition type_var_env attr_var_env (fun_defs, ts)
# (fd, fun_defs) = fun_defs![fun]
# (type_var_env, attr_var_env, ts) = clean_up_and_check_function_type fd fun (start_index == fun) defs type_contexts
req_case_and_let_exprs coercion_env attr_partition type_var_env attr_var_env ts
= cleanUpAndCheckFunctionTypes funs reqs start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
dict_ptrs = get_dict_ptrs fun dict_types
(type_var_env, attr_var_env, ts) = clean_up_and_check_function_type fd fun (start_index == fun) defs type_contexts
(dict_ptrs ++ req_case_and_let_exprs) coercion_env attr_partition type_var_env attr_var_env ts
= cleanUpAndCheckFunctionTypes funs reqs dict_types start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
where
clean_up_and_check_function_type {fun_symb,fun_pos,fun_type = opt_fun_type} fun is_start_rule defs type_contexts case_and_let_exprs
get_dict_ptrs fun_index []
= []
get_dict_ptrs fun_index [(index, ptrs) : dict_types]
| fun_index == index
= ptrs
= get_dict_ptrs fun_index dict_types
clean_up_and_check_function_type {fun_symb,fun_pos,fun_type = opt_fun_type} fun is_start_rule defs type_contexts type_ptrs
coercion_env attr_partition type_var_env attr_var_env ts
# (env_type, ts) = ts!ts_fun_env.[fun]
# ts = { ts & ts_error = setErrorAdmin (newPosition fun_symb fun_pos) ts.ts_error}
= case env_type of
ExpandedType fun_type tmp_fun_type exp_fun_type
# (clean_fun_type, type_var_env, attr_var_env, ts_type_heaps, ts_var_heap, ts_expr_heap, ts_error)
= cleanUpSymbolType is_start_rule cSpecifiedType exp_fun_type type_contexts case_and_let_exprs coercion_env
= cleanUpSymbolType is_start_rule cSpecifiedType exp_fun_type type_contexts type_ptrs coercion_env
attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_var_heap ts.ts_expr_heap ts.ts_error
| ts_error.ea_ok
# (ts_fun_env, attr_var_env, ts_type_heaps, ts_expr_heap, ts_error)
= check_function_type fun_type tmp_fun_type clean_fun_type case_and_let_exprs defs ts.ts_fun_env attr_var_env ts_type_heaps ts_expr_heap ts_error
= check_function_type fun_type tmp_fun_type clean_fun_type type_ptrs defs ts.ts_fun_env attr_var_env ts_type_heaps ts_expr_heap ts_error
-> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error })
-> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_error = ts_error })
UncheckedType exp_fun_type
# (clean_fun_type, type_var_env, attr_var_env, ts_type_heaps, ts_var_heap, ts_expr_heap, ts_error)
= cleanUpSymbolType is_start_rule cDerivedType exp_fun_type type_contexts case_and_let_exprs coercion_env
= cleanUpSymbolType is_start_rule cDerivedType exp_fun_type type_contexts type_ptrs coercion_env
attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_var_heap ts.ts_expr_heap ts.ts_error
ts_fun_env = { ts.ts_fun_env & [fun] = CheckedType clean_fun_type }
-> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error })
check_function_type fun_type tmp_fun_type=:{tst_lifted} clean_fun_type=:{st_arity, st_args, st_vars, st_attr_vars, st_context} case_and_let_exprs
check_function_type fun_type tmp_fun_type=:{tst_lifted} clean_fun_type=:{st_arity, st_args, st_vars, st_attr_vars, st_context} type_ptrs
defs fun_env attr_var_env type_heaps expr_heap error
# (equi, attr_var_env, type_heaps) = equivalent clean_fun_type tmp_fun_type (length fun_type.st_context) defs attr_var_env type_heaps
| equi
# type_with_lifted_arg_types = addLiftedArgumentsToSymbolType fun_type tst_lifted st_args st_vars st_attr_vars st_context
(type_heaps, expr_heap) = updateExpressionTypes clean_fun_type type_with_lifted_arg_types case_and_let_exprs type_heaps expr_heap
(type_heaps, expr_heap) = updateExpressionTypes clean_fun_type type_with_lifted_arg_types type_ptrs type_heaps expr_heap
= ({ fun_env & [fun] = CheckedType type_with_lifted_arg_types}, attr_var_env, type_heaps, expr_heap, error)
// ---> ("check_function_type", clean_fun_type, fun_type, type_with_lifted_arg_types)
= (fun_env, attr_var_env, type_heaps, expr_heap, specification_error clean_fun_type error)
......@@ -1529,8 +1537,7 @@ where
coer_offered = {{ CT_Empty \\ i <- [0 .. nr_of_attr_vars - 1] } & [AttrMulti] = CT_NonUnique }
coercion_env = build_initial_coercion_env fun_reqs {coer_demanded = coer_demanded, coer_offered = coer_offered }
(over_info, (subst, ts_expr_heap)) = collect_and_expand_overloaded_calls fun_reqs [] (subst, ts_expr_heap)
(ts_expr_heap, subst) = expand_types_of_cases_and_lets fun_reqs (ts_expr_heap, subst)
(contexts, coercion_env, local_pattern_variables,
(contexts, coercion_env, local_pattern_variables, dict_types,
{ os_type_heaps, os_var_heap, os_symbol_heap, os_predef_symbols, os_special_instances, os_error })
= tryToSolveOverloading over_info ti_common_defs class_instances coercion_env
{ os_type_heaps = {ts_type_heaps & th_vars = th_vars}, os_var_heap = ts_var_heap, os_symbol_heap = ts_expr_heap,
......@@ -1547,7 +1554,7 @@ where
(subst, ts_fun_env) = expand_function_types comp subst ts.ts_fun_env
attr_var_env = createArray nr_of_attr_vars TA_None
var_env = { subst & [i] = TE \\ i <- [0..dec ts_var_store]}
(fun_defs, ts) = cleanUpAndCheckFunctionTypes comp fun_reqs start_index ti_common_defs contexts coer_demanded attr_partition var_env attr_var_env
(fun_defs, ts) = cleanUpAndCheckFunctionTypes comp fun_reqs dict_types start_index ti_common_defs contexts coer_demanded attr_partition var_env attr_var_env
(fun_defs, { ts & ts_error = ts_error, ts_fun_env = ts_fun_env, ts_type_heaps = ts_type_heaps,
ts_td_infos = ts_td_infos, ts_var_heap = os_var_heap, ts_expr_heap = os_symbol_heap })
| not ts.ts_error.ea_ok
......@@ -1628,32 +1635,32 @@ where
collect_and_expand_overloaded_calls [] calls subst_and_heap
= (calls, subst_and_heap)
collect_and_expand_overloaded_calls [{ fe_context=Yes context, fe_requirements={req_overloaded_calls}, fe_location, fe_index}:reqs] calls (subst, expr_heap)
# (context, subst) = arraySubst context subst
collect_and_expand_overloaded_calls [{ fe_context=Yes context, fe_requirements={req_overloaded_calls,req_case_and_let_exprs}, fe_location, fe_index}:reqs] calls (subst, expr_heap)
# (context, subst) = arraySubst context subst
subst_expr_heap = expand_case_or_let_types req_case_and_let_exprs (subst, expr_heap)
= collect_and_expand_overloaded_calls reqs [(Yes context, req_overloaded_calls, fe_location, fe_index) : calls]
(foldSt expand_type_contexts req_overloaded_calls (subst, expr_heap))
collect_and_expand_overloaded_calls [{fe_context, fe_requirements={req_overloaded_calls}, fe_location, fe_index}:reqs] calls (subst, expr_heap)
(foldSt expand_type_contexts req_overloaded_calls subst_expr_heap)
collect_and_expand_overloaded_calls [{fe_context, fe_requirements={req_overloaded_calls,req_case_and_let_exprs}, fe_location, fe_index}:reqs] calls subst_expr_heap
# subst_expr_heap = expand_case_or_let_types req_case_and_let_exprs subst_expr_heap
= collect_and_expand_overloaded_calls reqs [(fe_context, req_overloaded_calls, fe_location, fe_index) : calls]
(foldSt expand_type_contexts req_overloaded_calls (subst, expr_heap))
(foldSt expand_type_contexts req_overloaded_calls subst_expr_heap)
expand_type_contexts over_info_ptr (subst, expr_heap)
# (EI_Overloaded info, expr_heap) = readPtr over_info_ptr expr_heap
(oc_context, subst) = arraySubst info.oc_context subst
= (subst, expr_heap <:= (over_info_ptr, EI_Overloaded { info & oc_context = oc_context })) //---> oc_context
expand_types_of_cases_and_lets [] heap_and_subst
= heap_and_subst
expand_types_of_cases_and_lets [{fe_requirements={req_case_and_let_exprs}}:reqs] heap_and_subst
= expand_types_of_cases_and_lets reqs (foldl expand_case_or_let_type heap_and_subst req_case_and_let_exprs)
expand_case_or_let_types info_ptrs subst_expr_heap
= foldSt expand_case_or_let_type info_ptrs subst_expr_heap
expand_case_or_let_type (expr_heap, subst) info_ptr
expand_case_or_let_type info_ptr (subst, expr_heap)
= case (readPtr info_ptr expr_heap) of
(EI_CaseType case_type, expr_heap)
# (case_type, subst) = arraySubst case_type subst
-> (expr_heap <:= (info_ptr, EI_CaseType case_type), subst)
-> (subst, expr_heap <:= (info_ptr, EI_CaseType case_type))
(EI_LetType let_type, expr_heap)
# (let_type, subst) = arraySubst let_type subst
-> (expr_heap <:= (info_ptr, EI_LetType let_type), subst)
-> (subst, expr_heap <:= (info_ptr, EI_LetType let_type))
expand_function_types :: ![Int] !*{!Type} *{! FunctionType} -> (!*{!Type}, *{! FunctionType})
expand_function_types [fun : funs] subst ts_fun_env
......
......@@ -66,8 +66,6 @@ attrIsUndefined _ = False
instance clean_up TypeAttribute
where
clean_up cui TA_TempExVar cus
= (TA_Multi, cus)
clean_up cui TA_Unique cus
= (TA_Unique, cus)
clean_up cui TA_Multi cus
......@@ -88,6 +86,8 @@ where
cus_heaps = { cus_heaps & th_attrs = th_attrs }, cus_attr_store = inc cus_attr_store})
= (attr, cus)
= (TA_Multi, cus)
clean_up cui TA_TempExVar cus
= PA_BUG (TA_Multi, cus) (abort "clean_up cui (TA_TempExVar)")
instance clean_up Type
where
......@@ -386,6 +386,10 @@ where
EI_LetType let_type
# (let_type, cus) = clean_up cui let_type cus
-> (expr_heap <:= (expr_ptr, EI_LetType let_type), cus)
EI_DictionaryType dict_type
# (dict_type, cus) = clean_up cui dict_type cus
-> (expr_heap <:= (expr_ptr, EI_DictionaryType dict_type), cus)
check_type_of_start_rule is_start_rule {st_context,st_arity,st_args} cus_error
| is_start_rule
......@@ -422,12 +426,12 @@ where
*/
updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*ExpressionHeap -> (!*TypeHeaps, !*ExpressionHeap)
updateExpressionTypes {st_args,st_vars,st_result,st_attr_vars} st_copy case_and_let_exprs heaps=:{th_vars,th_attrs} expr_heap
updateExpressionTypes {st_args,st_vars,st_result,st_attr_vars} st_copy type_ptrs heaps=:{th_vars,th_attrs} expr_heap
# th_vars = foldSt (\{tv_info_ptr} var_heap -> var_heap <:= (tv_info_ptr, TVI_Empty)) st_vars th_vars
th_attrs = foldSt (\{av_info_ptr} attr_heap -> attr_heap <:= (av_info_ptr, AVI_Empty)) st_attr_vars th_attrs
th_vars = bindInstances st_args st_copy.st_args th_vars
th_vars = bindInstances st_result st_copy.st_result th_vars
= foldSt update_expression_type case_and_let_exprs ({heaps & th_vars = th_vars, th_attrs = th_attrs}, expr_heap)
= foldSt update_expression_type type_ptrs ({heaps & th_vars = th_vars, th_attrs = th_attrs}, expr_heap)
where
update_expression_type expr_ptr (type_heaps, expr_heap)
# (info, expr_heap) = readPtr expr_ptr expr_heap
......@@ -438,6 +442,9 @@ where
EI_LetType let_type
# (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
-> (type_heaps, expr_heap <:= (expr_ptr, EI_DictionaryType dict_type))
class bindInstances a :: !a !a !*TypeVarHeap -> *TypeVarHeap
......@@ -877,14 +884,14 @@ where
= file <<< '*'
show_attribute TA_Multi coercions file
= file
show_attribute TA_TempExVar coercions file
= file <<< "(E)"
show_attribute (TA_TempVar av_number) coercions file
| isUniqueAttribute av_number coercions
= file <<< '*'
| isNonUniqueAttribute av_number coercions
= file
= file <<< '.' <<< "[[" <<< av_number <<< "]]"
show_attribute TA_TempExVar coercions file
= PA_BUG (file <<< "(E)") (abort "show_attribute TA_TempExVar")
instance <:: Type
where
......
......@@ -402,7 +402,7 @@ where
toInt (TA_TempVar av_number) = av_number
toInt TA_Multi = AttrMulti
toInt TA_None = AttrMulti
toInt TA_TempExVar = AttrExi
toInt TA_TempExVar = PA_BUG AttrExi (abort "toInt TA_TempExVar")
:: CoercionState =
......@@ -423,9 +423,9 @@ offered_attribute according to sign. Failure is indicated by returning False as
/* Just Temporary */
coerceAttributes TA_TempExVar dem_attr _ coercions
= (True, coercions)
= PA_BUG (True, coercions) (abort "coerceAttributes TA_TempExVar")
coerceAttributes _ TA_TempExVar _ coercions
= (True, coercions)
= PA_BUG (True, coercions) (abort "coerceAttributes TA_TempExVar")
/* ... remove this !!!! */
coerceAttributes TA_Unique dem_attr {neg_sign} coercions
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment