Commit 7d16a0cf authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

Bug fix: specified overloaded types were not treated correctly

parent 12e61eac
......@@ -35,7 +35,7 @@ import syntax, check
:: LocalTypePatternVariable
tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos)] !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState
tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState
-> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
:: TypeCodeInfo =
......@@ -44,7 +44,7 @@ tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos)] !{
, tci_type_var_heap :: !.TypeVarHeap
}
removeOverloadedFunctions :: ![Int] ![(Optional [TypeContext], IdentPos)] ![TypeContext] ![LocalTypePatternVariable] !*{#FunDef} !*ExpressionHeap
removeOverloadedFunctions :: ![(Optional [TypeContext], IdentPos, Index)] ![TypeContext] ![LocalTypePatternVariable] !*{#FunDef} !*ExpressionHeap
!*TypeCodeInfo !*VarHeap !*ErrorAdmin
-> (!*{#FunDef}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin)
......
......@@ -525,13 +525,13 @@ where
try_specialized_instances type_contexts_types [] type_var_heap
= (ObjectNotFound, type_var_heap)
tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos)] !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState
tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState
-> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
tryToSolveOverloading ocs defs instance_info coercion_env os
= foldSt (try_to_solve_overloading defs instance_info) ocs ([], coercion_env, [], os)
where
try_to_solve_overloading defs instance_info (fun_context, call_ptrs, location) (contexts, coercion_env, type_pattern_vars, os=:{os_error})
try_to_solve_overloading defs instance_info (fun_context, call_ptrs, location, _) (contexts, coercion_env, type_pattern_vars, os=:{os_error})
| isEmpty call_ptrs
= (contexts, coercion_env, type_pattern_vars, os)
# os = { os & os_error = setErrorAdmin location os_error }
......@@ -541,10 +541,10 @@ where
# (_, coercion_env, type_pattern_vars, os)
= reduce_and_simplify_contexts call_ptrs defs instance_info True specified_context coercion_env type_pattern_vars os
-> (contexts, coercion_env, type_pattern_vars, os)
// ---> ("try_to_solve_overloading (Yes ...)", specified_context)
// ---> ("try_to_solve_overloading (Yes ...)", location, specified_context)
No
-> reduce_and_simplify_contexts call_ptrs defs instance_info False contexts coercion_env type_pattern_vars os
// ---> ("try_to_solve_overloading (No)", contexts)
// ---> ("try_to_solve_overloading (No)", location, contexts)
reduce_and_simplify_contexts :: ![ExprInfoPtr] !{# CommonDefs } !ClassInstanceInfo !Bool ![TypeContext] !*Coercions ![LocalTypePatternVariable]
!*OverloadingState -> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState)
......@@ -600,6 +600,7 @@ simplifyOverloadedCall {symb_kind = SK_OverloadedFunction {glob_module,glob_obje
(inst_expr, contexts, (type_heaps, var_heap, symbol_heap), error)
= adjust_member_application mem_def symb_arity class_appl class_exprs defs has_context contexts heaps error
= (contexts, type_heaps, var_heap, symbol_heap <:= (expr_info_ptr, inst_expr), error)
// ---> ("simplifyOverloadedCall", expr_info_ptr, inst_expr)
where
adjust_member_application {me_symb,me_offset,me_class} symb_arity (CA_Instance red_contexts) class_exprs defs has_context contexts heaps error
......@@ -616,6 +617,7 @@ where
selector = selectFromDictionary glob_module ds_index me_offset defs
= (EI_Selection (generateClassSelection address [RecordSelection selector me_offset]) class_context.tc_var class_exprs,
contexts, (type_heaps, var_heap, symbol_heap), error)
// ---> ("adjust_member_application", contexts, class_context.tc_var)
adjust_member_application _ _ (CA_GlobalTypeCode {tci_index,tci_contexts}) _ defs has_context contexts heaps error
# (exprs, (contexts, heaps, error)) = convertClassApplsToExpressions defs has_context tci_contexts (contexts, heaps, error)
......@@ -641,6 +643,7 @@ simplifyOverloadedCall _ expr_info_ptr appls defs has_context contexts type_heap
# (class_expressions, (contexts, (type_heaps, var_heap, symbol_heap), error))
= convertClassApplsToExpressions defs has_context appls (contexts, (type_heaps, var_heap, symbol_heap), error)
= (contexts, type_heaps, var_heap, symbol_heap <:= (expr_info_ptr, EI_Context class_expressions), error)
// ---> ("simplifyOverloadedCall", expr_info_ptr, class_expressions)
expressionToTypeCodeExpression (TypeCodeExpression texpr) = texpr
......@@ -665,7 +668,7 @@ where
convert_class_appl_to_expression defs has_context (CA_Context tc) (contexts, (type_heaps, var_heap, expr_heap), error)
# (class_context, context_address, contexts, type_heaps, var_heap, error)
= determineContextAddress tc has_context contexts defs type_heaps var_heap error
| isEmpty context_address
| isEmpty context_address // ---> ("convert_class_appl_to_expression", tc , contexts, class_context)
= (ClassVariable class_context.tc_var, (contexts, (type_heaps, var_heap, expr_heap), error))
= (Selection No (ClassVariable class_context.tc_var) (generateClassSelection context_address []), (contexts, (type_heaps, var_heap, expr_heap), error))
convert_class_appl_to_expression defs has_context (CA_LocalTypeCode new_var_ptr) contexts_heaps_error
......@@ -761,8 +764,12 @@ where
-> find_super_instance context tcs (inc tc_index) address dict_mod dict_index defs type_heaps
getClassVariable var_info_ptr var_heap
# (VI_ClassVar var_name new_info_ptr count, var_heap) = readPtr var_info_ptr var_heap
= (var_name, new_info_ptr, var_heap <:= (var_info_ptr, VI_ClassVar var_name new_info_ptr (inc count)))
# (var_info, var_heap) = readPtr var_info_ptr var_heap
= case var_info of
VI_ClassVar var_name new_info_ptr count
-> (var_name, new_info_ptr, var_heap <:= (var_info_ptr, VI_ClassVar var_name new_info_ptr (inc count)))
_
-> abort "getClassVariable" ---> var_info_ptr
updateDynamics :: ![Int] ![TypeContext] ![LocalTypePatternVariable] !*{#FunDef} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin
-> (!*{#FunDef}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin)
......@@ -785,17 +792,17 @@ where
fun_def = { fun_def & fun_body = TransformedBody {tb & tb_rhs = tb_rhs}}
= update_dynamics funs type_contexts { ui_fun_defs & [fun] = fun_def } ui_symbol_heap type_code_info { ltp & ltp_var_heap = ui_var_heap } error
removeOverloadedFunctions :: ![Int] ![(Optional [TypeContext], IdentPos)] ![TypeContext] ![LocalTypePatternVariable] !*{#FunDef} !*ExpressionHeap
removeOverloadedFunctions :: ![(Optional [TypeContext], IdentPos, Index)] ![TypeContext] ![LocalTypePatternVariable] !*{#FunDef} !*ExpressionHeap
!*TypeCodeInfo !*VarHeap !*ErrorAdmin
-> (!*{#FunDef}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin)
removeOverloadedFunctions funs opt_spec_contexts type_contexts type_pattern_vars fun_defs symbol_heap type_code_info var_heap error
removeOverloadedFunctions opt_spec_contexts type_contexts type_pattern_vars fun_defs symbol_heap type_code_info var_heap error
| error.ea_ok
# (_, fun_defs, symbol_heap, type_code_info, ltp, error)
= fold2St (remove_overloaded_function type_contexts) funs opt_spec_contexts
= foldSt (remove_overloaded_function type_contexts) opt_spec_contexts
(False, fun_defs, symbol_heap, type_code_info, { ltp_var_heap = var_heap, ltp_variables = type_pattern_vars}, error)
= (fun_defs, symbol_heap, type_code_info, ltp.ltp_var_heap, error)
where
remove_overloaded_function derived_context fun_index (opt_context, location)
remove_overloaded_function derived_context (opt_context, location, fun_index)
(refresh_variables, fun_defs, symbol_heap, type_code_info, ltp, error)
# (fun_def, fun_defs) = fun_defs![fun_index]
{fun_body = TransformedBody {tb_args,tb_rhs},fun_info,fun_arity,fun_symb} = fun_def
......@@ -1131,18 +1138,18 @@ where
adjustClassExpressions exprs tail_exprs var_heap
= mapAppendSt adjustClassExpression exprs tail_exprs var_heap
adjustClassExpression (App app=:{app_args}) var_heap
# (app_args, var_heap) = adjustClassExpressions app_args [] var_heap
= (App { app & app_args = app_args }, var_heap)
adjustClassExpression (ClassVariable var_info_ptr) var_heap
# (var_name, var_info_ptr, var_heap) = getClassVariable var_info_ptr var_heap
= (Var { var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr }, var_heap)
adjustClassExpression (Selection opt_type expr selectors) var_heap
# (expr, var_heap) = adjustClassExpression expr var_heap
= (Selection opt_type expr selectors, var_heap)
adjustClassExpression expr var_heap
= (expr, var_heap)
where
adjustClassExpression (App app=:{app_args}) var_heap
# (app_args, var_heap) = adjustClassExpressions app_args [] var_heap
= (App { app & app_args = app_args }, var_heap)
adjustClassExpression (ClassVariable var_info_ptr) var_heap
# (var_name, var_info_ptr, var_heap) = getClassVariable var_info_ptr var_heap
= (Var { var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr }, var_heap)
adjustClassExpression (Selection opt_type expr selectors) var_heap
# (expr, var_heap) = adjustClassExpression expr var_heap
= (Selection opt_type expr selectors, var_heap)
adjustClassExpression expr var_heap
= (expr, var_heap)
class equalTypes a :: !a !a !*TypeVarHeap -> (!Bool, !*TypeVarHeap)
......@@ -1198,7 +1205,7 @@ where
instance <<< TypeContext
where
(<<<) file tc = file <<< tc.tc_class.glob_object.ds_ident <<< ' ' <<< tc.tc_types
(<<<) file tc = file <<< tc.tc_class.glob_object.ds_ident <<< ' ' <<< tc.tc_types <<< " <" <<< tc.tc_var <<< '>'
instance <<< FunCall
where
......@@ -1217,3 +1224,14 @@ instance <<< TypeCodeExpression
where
(<<<) file _ = file
instance <<< DefinedSymbol
where
(<<<) file ds = file <<< ds.ds_ident
instance <<< ExprInfo
where
(<<<) file (EI_Instance symb exprs) = file <<< symb <<< exprs
(<<<) file (EI_Selection sels var_ptr exprs) = file <<< sels <<< var_ptr <<< exprs
(<<<) file (EI_Context exprs) = file <<< exprs
(<<<) file _ = file
......@@ -1152,7 +1152,7 @@ instance == ModuleKind, Ident
instance <<< Module a | <<< a, ParsedDefinition, InstanceType, AttributeVar, TypeVar, SymbolType, Expression, Type, Ident, Global object | <<< object,
Position, CaseAlt, AType, FunDef, ParsedExpr, TypeAttribute, Bind a b | <<< a & <<< b, ParsedConstructor, TypeDef a | <<< a, TypeVarInfo,
BasicValue, ATypeVar, TypeRhs, FunctionPattern, (Import from_symbol) | <<< from_symbol, ImportDeclaration, ImportedIdent, CasePatterns,
Optional a | <<< a, ConsVariable, BasicType, Annotation
Optional a | <<< a, ConsVariable, BasicType, Annotation, Selection
instance == TypeAttribute
instance == Annotation
......
......@@ -1257,7 +1257,7 @@ where
instance <<< TypeContext
where
(<<<) file co = file <<< co.tc_class <<< " " <<< co.tc_types
(<<<) file co = file <<< co.tc_class <<< " " <<< co.tc_types <<< " <" <<< ptrToInt co.tc_var <<< '>'
instance <<< SymbIdent
where
......@@ -1374,7 +1374,7 @@ where
(<<<) file (AnyCodeExpr input output code_sequence) = file <<< "code\n" <<< input <<< "\n" <<< output <<< "\n" <<< code_sequence
(<<<) file (FreeVar {fv_name}) = file <<< "FREEVAR " <<< fv_name
(<<<) file (ClassVariable _) = file <<< "ClassVariable "
(<<<) file (ClassVariable info_ptr) = file <<< "ClassVariable " <<< ptrToInt info_ptr
(<<<) file expr = abort ("<<< (Expression) [line 1290]" )//<<- expr)
......
......@@ -1366,6 +1366,7 @@ addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars} nr_of
:: FunctionRequirements =
{ fe_requirements :: !Requirements
, fe_context :: !Optional [TypeContext]
, fe_index :: !Index
, fe_location :: !IdentPos
}
......@@ -1497,7 +1498,7 @@ where
type_component comp class_instances ti=:{ti_common_defs} (type_error, fun_defs, predef_symbols, special_instances, ts)
# (fun_defs, predef_symbols, cons_variables, ts) = CreateInitialSymbolTypes ti_common_defs comp (fun_defs, predef_symbols, [], ts)
(names, fun_defs) = show_component comp fun_defs
(fun_reqs, (cons_variables, fun_defs, ts)) = type_functions comp ti cons_variables fun_defs ts //(ts ---> names)
(fun_reqs, (cons_variables, fun_defs, ts)) = type_functions comp ti cons_variables fun_defs ts /* (ts ---> names) */
#! nr_of_type_variables = ts.ts_var_store
# (subst, ts_type_heaps, ts_error)
......@@ -1550,7 +1551,7 @@ where
type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances,
tci_type_var_heap = ts_type_heaps.th_vars }
(fun_defs, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error)
= removeOverloadedFunctions comp (map (\(co,_,pos) -> (co,pos)) over_info)
= removeOverloadedFunctions [(co, pos, index) \\ (co, _, pos, index) <- over_info]
contexts local_pattern_variables fun_defs ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error
= ( type_error || not ts_error.ea_ok,
fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances },
......@@ -1610,12 +1611,12 @@ 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}:reqs] calls (subst, expr_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 reqs [(Yes context, req_overloaded_calls, fe_location) : calls]
= 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}:reqs] calls (subst, expr_heap)
= collect_and_expand_overloaded_calls reqs [(fe_context, req_overloaded_calls, fe_location) : calls]
collect_and_expand_overloaded_calls [{fe_context, fe_requirements={req_overloaded_calls}, fe_location, fe_index}:reqs] calls (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))
expand_type_contexts over_info_ptr (subst, expr_heap)
......@@ -1693,7 +1694,7 @@ where
req_type_coercions = [{tc_demanded = temp_fun_type.tst_result,tc_offered = rhs_type, tc_position = {cp_expression = tb_rhs }, tc_coercible = True} :
rhs_reqs.req_type_coercions ]
ts_expr_heap = storeAttribute rhs_expr_ptr temp_fun_type.tst_result.at_attribute ts.ts_expr_heap
= ({fe_location = fe_location, fe_context = if (has_option fun_type) (Yes temp_fun_type.tst_context) No,
= ({fe_location = fe_location, fe_context = if (has_option fun_type) (Yes temp_fun_type.tst_context) No, fe_index = fun_index,
fe_requirements = { rhs_reqs & req_type_coercions = req_type_coercions, req_cons_variables = [] }}, (rhs_reqs.req_cons_variables, fun_defs,
{ ts & ts_expr_heap = ts_expr_heap }))
// ---> ("type_function", fun_symb, tb_args, tb_rhs, fun_info.fi_local_vars)
......
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