aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--frontend/overloading.dcl4
-rw-r--r--frontend/overloading.icl66
-rw-r--r--frontend/syntax.dcl2
-rw-r--r--frontend/syntax.icl4
-rw-r--r--frontend/type.icl15
5 files changed, 55 insertions, 36 deletions
diff --git a/frontend/overloading.dcl b/frontend/overloading.dcl
index 2b1accb..ddf1835 100644
--- a/frontend/overloading.dcl
+++ b/frontend/overloading.dcl
@@ -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)
diff --git a/frontend/overloading.icl b/frontend/overloading.icl
index 51bdaed..ff0b5b9 100644
--- a/frontend/overloading.icl
+++ b/frontend/overloading.icl
@@ -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
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index 139f5c7..a2ec1ba 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -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
diff --git a/frontend/syntax.icl b/frontend/syntax.icl
index 9e489b9..a7f9d7b 100644
--- a/frontend/syntax.icl
+++ b/frontend/syntax.icl
@@ -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)
diff --git a/frontend/type.icl b/frontend/type.icl
index de16283..5b28349 100644
--- a/frontend/type.icl
+++ b/frontend/type.icl
@@ -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)
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-13 20:16:09 +0000