Commit 46ed5ee5 authored by Martin Wierich's avatar Martin Wierich
Browse files

added position information to case defaults to improve type error messages

parent d2e07b78
...@@ -1041,7 +1041,7 @@ newFreeVariable new_var [] ...@@ -1041,7 +1041,7 @@ newFreeVariable new_var []
buildTypeCase type_case_dynamic type_case_patterns type_case_default type_case_info_ptr :== buildTypeCase type_case_dynamic type_case_patterns type_case_default type_case_info_ptr :==
Case { case_expr = type_case_dynamic, case_guards = DynamicPatterns type_case_patterns, case_default = type_case_default, Case { case_expr = type_case_dynamic, case_guards = DynamicPatterns type_case_patterns, case_default = type_case_default,
case_info_ptr = type_case_info_ptr, case_ident = No } case_info_ptr = type_case_info_ptr, case_ident = No, case_default_pos = NoPos }
consOptional (Yes thing) things consOptional (Yes thing) things
...@@ -1427,16 +1427,18 @@ where ...@@ -1427,16 +1427,18 @@ where
# (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap # (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
(bound_var, expr_heap) = allocate_bound_var var expr_heap (bound_var, expr_heap) = allocate_bound_var var expr_heap
result = Case {case_expr = Var bound_var, case_guards = patterns, case_default = Yes result, result = Case {case_expr = Var bound_var, case_guards = patterns, case_default = Yes result,
case_ident = Yes case_ident, case_info_ptr = case_expr_ptr} case_ident = Yes case_ident, case_info_ptr = case_expr_ptr,
case_default_pos = NoPos }
(case_expression, expr_heap) = bind_default_variable expr var result expr_heap (case_expression, expr_heap) = bind_default_variable expr var result expr_heap
-> (case_expression, expr_heap) -> (case_expression, expr_heap)
No No
# (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap # (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
-> (Case {case_expr = expr, case_guards = patterns, case_default = Yes result, -> (Case {case_expr = expr, case_guards = patterns, case_default = Yes result,
case_ident = Yes case_ident, case_info_ptr = case_expr_ptr }, expr_heap) case_ident = Yes case_ident, case_info_ptr = case_expr_ptr, case_default_pos = NoPos }, expr_heap)
build_case patterns No expr case_ident expr_heap build_case patterns No expr case_ident expr_heap
# (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap # (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
= (Case {case_expr = expr, case_guards = patterns, case_default = No, case_ident = Yes case_ident, case_info_ptr = case_expr_ptr }, expr_heap) = (Case {case_expr = expr, case_guards = patterns, case_default = No, case_ident = Yes case_ident,
case_info_ptr = case_expr_ptr, case_default_pos = NoPos }, expr_heap)
bind_default_variable bind_src bind_dst result_expr expr_heap bind_default_variable bind_src bind_dst result_expr expr_heap
# (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap # (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
...@@ -1869,13 +1871,15 @@ where ...@@ -1869,13 +1871,15 @@ where
# (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap # (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
basic_pattern = {bp_value = (BVB True), bp_expr = expr, bp_position = NoPos } basic_pattern = {bp_value = (BVB True), bp_expr = expr, bp_position = NoPos }
case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [basic_pattern], case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [basic_pattern],
case_default = result_expr, case_ident = No, case_info_ptr = case_expr_ptr } case_default = result_expr, case_ident = No, case_info_ptr = case_expr_ptr,
case_default_pos = NoPos }
= build_sequential_lets let_binds case_expr es_expr_heap = build_sequential_lets let_binds case_expr es_expr_heap
convert_guards_to_cases [(let_binds, guard, expr) : rev_guarded_exprs] result_expr es_expr_heap convert_guards_to_cases [(let_binds, guard, expr) : rev_guarded_exprs] result_expr es_expr_heap
# (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap # (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
basic_pattern = {bp_value = (BVB True), bp_expr = expr, bp_position = NoPos } basic_pattern = {bp_value = (BVB True), bp_expr = expr, bp_position = NoPos }
case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [basic_pattern], case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [basic_pattern],
case_default = result_expr, case_ident = No, case_info_ptr = case_expr_ptr } case_default = result_expr, case_ident = No, case_info_ptr = case_expr_ptr,
case_default_pos = NoPos }
(result_expr, es_expr_heap) = build_sequential_lets let_binds case_expr es_expr_heap (result_expr, es_expr_heap) = build_sequential_lets let_binds case_expr es_expr_heap
= convert_guards_to_cases rev_guarded_exprs (Yes result_expr) es_expr_heap = convert_guards_to_cases rev_guarded_exprs (Yes result_expr) es_expr_heap
...@@ -2003,7 +2007,8 @@ convertSubPattern (AP_Algebraic cons_symbol type_index args opt_var) result_expr ...@@ -2003,7 +2007,8 @@ convertSubPattern (AP_Algebraic cons_symbol type_index args opt_var) result_expr
(case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
= ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 },
Case { case_expr = Var { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr }, Case { case_expr = Var { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr },
case_guards = case_guards, case_default = No, case_ident = No, case_info_ptr = case_expr_ptr }, case_guards = case_guards, case_default = No, case_ident = No, case_info_ptr = case_expr_ptr,
case_default_pos = NoPos },
NoPos, var_store, expr_heap, opt_dynamics, cs) NoPos, var_store, expr_heap, opt_dynamics, cs)
convertSubPattern (AP_Basic basic_val opt_var) result_expr pattern_position var_store expr_heap opt_dynamics cs convertSubPattern (AP_Basic basic_val opt_var) result_expr pattern_position var_store expr_heap opt_dynamics cs
# (basic_type, cs) = typeOfBasicValue basic_val cs # (basic_type, cs) = typeOfBasicValue basic_val cs
...@@ -2013,7 +2018,8 @@ convertSubPattern (AP_Basic basic_val opt_var) result_expr pattern_position var_ ...@@ -2013,7 +2018,8 @@ convertSubPattern (AP_Basic basic_val opt_var) result_expr pattern_position var_
(case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
= ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 },
Case { case_expr = Var { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr }, Case { case_expr = Var { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr },
case_guards = case_guards, case_default = No, case_ident = No, case_info_ptr = case_expr_ptr}, case_guards = case_guards, case_default = No, case_ident = No, case_info_ptr = case_expr_ptr,
case_default_pos = NoPos},
NoPos, var_store, expr_heap, opt_dynamics, cs) NoPos, var_store, expr_heap, opt_dynamics, cs)
convertSubPattern (AP_Dynamic pattern type opt_var) result_expr pattern_position var_store expr_heap opt_dynamics cs convertSubPattern (AP_Dynamic pattern type opt_var) result_expr pattern_position var_store expr_heap opt_dynamics cs
# (var_arg, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) # (var_arg, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs)
...@@ -2140,10 +2146,10 @@ checkFunctionBodies (ParsedBody [{pb_args,pb_rhs={rhs_alts,rhs_locals}, pb_posit ...@@ -2140,10 +2146,10 @@ checkFunctionBodies (ParsedBody [{pb_args,pb_rhs={rhs_alts,rhs_locals}, pb_posit
(rhss, free_vars, e_state=:{es_dynamics,es_expr_heap,es_var_heap}, e_info, cs) (rhss, free_vars, e_state=:{es_dynamics,es_expr_heap,es_var_heap}, e_info, cs)
= check_function_bodies free_vars cb_args bodies e_input { e_state & es_dynamics = [], es_var_heap = es_var_heap } e_info = check_function_bodies free_vars cb_args bodies e_input { e_state & es_dynamics = [], es_var_heap = es_var_heap } e_info
{ cs & cs_symbol_table = cs_symbol_table } { cs & cs_symbol_table = cs_symbol_table }
(rhs, _, es_var_heap, es_expr_heap, dynamics_in_patterns, cs) (rhs, position, es_var_heap, es_expr_heap, dynamics_in_patterns, cs)
= transform_patterns_into_cases aux_patterns cb_args expr_with_array_selections pb_position es_var_heap es_expr_heap = transform_patterns_into_cases aux_patterns cb_args expr_with_array_selections pb_position es_var_heap es_expr_heap
dynamics_in_rhs cs dynamics_in_rhs cs
= (CheckedBody { cb_args = cb_args, cb_rhs = [rhs : rhss] }, free_vars, = (CheckedBody { cb_args = cb_args, cb_rhs = [{ ca_rhs = rhs, ca_position = position } : rhss] }, free_vars,
{ e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap, es_dynamics = dynamics_in_patterns ++ es_dynamics }, e_info, cs) { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap, es_dynamics = dynamics_in_patterns ++ es_dynamics }, e_info, cs)
where where
check_patterns [pattern : patterns] p_input accus var_store e_info cs check_patterns [pattern : patterns] p_input accus var_store e_info cs
...@@ -2182,11 +2188,12 @@ where ...@@ -2182,11 +2188,12 @@ where
cs_symbol_table = removeLocalIdentsFromSymbolTable ei_expr_level var_env cs.cs_symbol_table cs_symbol_table = removeLocalIdentsFromSymbolTable ei_expr_level var_env cs.cs_symbol_table
(rhs_exprs, free_vars, e_state=:{es_dynamics,es_expr_heap,es_var_heap}, e_info, cs) (rhs_exprs, free_vars, e_state=:{es_dynamics,es_expr_heap,es_var_heap}, e_info, cs)
= check_function_bodies free_vars fun_args bodies e_input { e_state & es_dynamics = [] } e_info { cs & cs_symbol_table = cs_symbol_table } = check_function_bodies free_vars fun_args bodies e_input { e_state & es_dynamics = [] } e_info { cs & cs_symbol_table = cs_symbol_table }
(rhs_expr, _, es_var_heap, es_expr_heap, dynamics_in_patterns, cs) (rhs_expr, position, es_var_heap, es_expr_heap, dynamics_in_patterns, cs)
= transform_patterns_into_cases aux_patterns fun_args rhs_expr pb_position = transform_patterns_into_cases aux_patterns fun_args rhs_expr pb_position
es_var_heap es_expr_heap dynamics_in_rhs cs es_var_heap es_expr_heap dynamics_in_rhs cs
= ([rhs_expr : rhs_exprs], free_vars, { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap, = ([{ ca_rhs = rhs_expr, ca_position = position } : rhs_exprs], free_vars,
es_dynamics = dynamics_in_patterns ++ es_dynamics }, e_info, cs) { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap,
es_dynamics = dynamics_in_patterns ++ es_dynamics }, e_info, cs)
check_function_bodies free_vars fun_args [] e_input e_state e_info cs check_function_bodies free_vars fun_args [] e_input e_state e_info cs
= ([], free_vars, e_state, e_info, cs) = ([], free_vars, e_state, e_info, cs)
...@@ -2253,14 +2260,16 @@ where ...@@ -2253,14 +2260,16 @@ where
alg_pattern = { ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr, ap_position = pattern_position } alg_pattern = { ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr, ap_position = pattern_position }
case_guards = AlgebraicPatterns type_symbol [alg_pattern] case_guards = AlgebraicPatterns type_symbol [alg_pattern]
(case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
= (Case { case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No, case_info_ptr = case_expr_ptr }, = (Case { case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No,
case_info_ptr = case_expr_ptr, case_default_pos = NoPos },
NoPos, var_store, expr_heap, opt_dynamics, cs) NoPos, var_store, expr_heap, opt_dynamics, cs)
transform_pattern_into_cases (AP_Basic basic_val opt_var) fun_arg result_expr pattern_position var_store expr_heap opt_dynamics cs transform_pattern_into_cases (AP_Basic basic_val opt_var) fun_arg result_expr pattern_position var_store expr_heap opt_dynamics cs
# (basic_type, cs) = typeOfBasicValue basic_val cs # (basic_type, cs) = typeOfBasicValue basic_val cs
(act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap (act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap
case_guards = BasicPatterns basic_type [{ bp_value = basic_val, bp_expr = result_expr, bp_position = pattern_position }] case_guards = BasicPatterns basic_type [{ bp_value = basic_val, bp_expr = result_expr, bp_position = pattern_position }]
(case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
= (Case { case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No, case_info_ptr = case_expr_ptr }, = (Case { case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No,
case_info_ptr = case_expr_ptr, case_default_pos = NoPos },
NoPos, var_store, expr_heap, opt_dynamics, cs) NoPos, var_store, expr_heap, opt_dynamics, cs)
transform_pattern_into_cases (AP_Dynamic pattern type opt_var) fun_arg result_expr pattern_position var_store expr_heap opt_dynamics cs transform_pattern_into_cases (AP_Dynamic pattern type opt_var) fun_arg result_expr pattern_position var_store expr_heap opt_dynamics cs
# (var_arg, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) # (var_arg, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs)
......
...@@ -742,7 +742,7 @@ instance e_corresponds FunctionBody where ...@@ -742,7 +742,7 @@ instance e_corresponds FunctionBody where
= e_corresponds (from_body dclDef) (from_body iclDef) = e_corresponds (from_body dclDef) (from_body iclDef)
where where
from_body (TransformedBody {tb_args, tb_rhs}) = (tb_args, [tb_rhs]) from_body (TransformedBody {tb_args, tb_rhs}) = (tb_args, [tb_rhs])
from_body (CheckedBody {cb_args, cb_rhs}) = (cb_args, cb_rhs) from_body (CheckedBody {cb_args, cb_rhs}) = (cb_args, [ca_rhs \\ {ca_rhs} <- cb_rhs])
instance e_corresponds TransformedBody where instance e_corresponds TransformedBody where
e_corresponds dclDef iclDef e_corresponds dclDef iclDef
......
...@@ -400,7 +400,8 @@ where ...@@ -400,7 +400,8 @@ where
case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs, bp_position = NoPos }], case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs, bp_position = NoPos }],
case_default = default_expr, case_default = default_expr,
case_ident = No, case_ident = No,
case_info_ptr = case_info_ptr }, case_info_ptr = case_info_ptr,
case_default_pos= NoPos }, // MW4++
let_info_ptr = let_info_ptr } let_info_ptr = let_info_ptr }
= (a_ij_binds ++ binds, let_expr, { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]}) = (a_ij_binds ++ binds, let_expr, { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]})
where where
......
...@@ -665,6 +665,10 @@ instance check_completeness CasePatterns where ...@@ -665,6 +665,10 @@ instance check_completeness CasePatterns where
check_completeness NoPattern _ ccs check_completeness NoPattern _ ccs
= ccs = ccs
instance check_completeness CheckedAlternative where
check_completeness {ca_rhs} cci ccs
= check_completeness ca_rhs cci ccs
instance check_completeness CheckedBody where instance check_completeness CheckedBody where
check_completeness {cb_rhs} cci ccs check_completeness {cb_rhs} cci ccs
= check_completeness cb_rhs cci ccs = check_completeness cb_rhs cci ccs
......
...@@ -380,10 +380,16 @@ cIsNonCoercible :== 2 ...@@ -380,10 +380,16 @@ cIsNonCoercible :== 2
} }
:: CheckedBody = :: CheckedBody =
{ cb_args :: ![FreeVar] { cb_args :: ![FreeVar]
, cb_rhs :: ![Expression] , cb_rhs :: ![CheckedAlternative]
} }
:: CheckedAlternative =
{ ca_rhs :: !Expression
, ca_position :: !Position // the position is NoPos iff the position information for this
} // alternative is already stored in a case alternative
// (in ap_position, bp_position or dp_position)
:: TransformedBody = :: TransformedBody =
{ tb_args :: ![FreeVar] { tb_args :: ![FreeVar]
, tb_rhs :: !Expression , tb_rhs :: !Expression
...@@ -1012,6 +1018,7 @@ cIsNotStrict :== False ...@@ -1012,6 +1018,7 @@ cIsNotStrict :== False
, case_default :: !Optional Expression , case_default :: !Optional Expression
, case_ident :: !Optional Ident , case_ident :: !Optional Ident
, case_info_ptr :: !ExprInfoPtr , case_info_ptr :: !ExprInfoPtr
, case_default_pos:: !Position
} }
:: Let = :: Let =
......
...@@ -355,10 +355,16 @@ cMayBeNonCoercible :== 4 ...@@ -355,10 +355,16 @@ cMayBeNonCoercible :== 4
} }
:: CheckedBody = :: CheckedBody =
{ cb_args :: ![FreeVar] { cb_args :: ![FreeVar]
, cb_rhs :: ![Expression] , cb_rhs :: ![CheckedAlternative]
} }
:: CheckedAlternative =
{ ca_rhs :: !Expression
, ca_position :: !Position // the position is NoPos iff the position information for this
} // alternative is already stored in a case alternative
// (in ap_position, bp_position or dp_position)
:: TransformedBody = :: TransformedBody =
{ tb_args :: ![FreeVar] { tb_args :: ![FreeVar]
, tb_rhs :: !Expression , tb_rhs :: !Expression
...@@ -972,6 +978,7 @@ cIsNotStrict :== False ...@@ -972,6 +978,7 @@ cIsNotStrict :== False
, case_default :: !Optional Expression , case_default :: !Optional Expression
, case_ident :: !Optional Ident , case_ident :: !Optional Ident
, case_info_ptr :: !ExprInfoPtr , case_info_ptr :: !ExprInfoPtr
, case_default_pos:: !Position
} }
:: Let = :: Let =
...@@ -994,7 +1001,6 @@ cIsNotStrict :== False ...@@ -994,7 +1001,6 @@ cIsNotStrict :== False
| DynamicPatterns [DynamicPattern] /* auxiliary */ | DynamicPatterns [DynamicPattern] /* auxiliary */
| NoPattern /* auxiliary */ | NoPattern /* auxiliary */
:: Selection = RecordSelection !(Global DefinedSymbol) !Int :: Selection = RecordSelection !(Global DefinedSymbol) !Int
| ArraySelection !(Global DefinedSymbol) !ExprInfoPtr !Expression | ArraySelection !(Global DefinedSymbol) !ExprInfoPtr !Expression
| DictionarySelection !BoundVar ![Selection] !ExprInfoPtr !Expression | DictionarySelection !BoundVar ![Selection] !ExprInfoPtr !Expression
...@@ -1311,6 +1317,10 @@ where ...@@ -1311,6 +1317,10 @@ where
(<<<) file (DynamicPatterns patterns) = file <<< patterns (<<<) file (DynamicPatterns patterns) = file <<< patterns
(<<<) file NoPattern = file (<<<) file NoPattern = file
instance <<< CheckedAlternative
where
(<<<) file {ca_rhs} = file <<< ca_rhs
instance <<< Qualifier instance <<< Qualifier
where where
(<<<) file {qual_generators,qual_filter = Yes qual_filter} = file <<< qual_generators <<< "| " <<< qual_filter (<<<) file {qual_generators,qual_filter = Yes qual_filter} = file <<< qual_generators <<< "| " <<< qual_filter
...@@ -1352,7 +1362,7 @@ where ...@@ -1352,7 +1362,7 @@ where
(<<<) file (Case {case_expr,case_guards,case_default=No}) (<<<) file (Case {case_expr,case_guards,case_default=No})
= file <<< "case " <<< case_expr <<< " of\n" <<< case_guards = file <<< "case " <<< case_expr <<< " of\n" <<< case_guards
(<<<) file (Case {case_expr,case_guards,case_default= Yes def_expr}) (<<<) file (Case {case_expr,case_guards,case_default= Yes def_expr})
= file <<< "case " <<< case_expr <<< " of\n" <<< case_guards <<< "\n\t-> " <<< def_expr = file <<< "case " <<< case_expr <<< " of\n" <<< case_guards <<< "\n\t->" <<< def_expr
(<<<) file (BasicExpr basic_value basic_type) = file <<< basic_value (<<<) file (BasicExpr basic_value basic_type) = file <<< basic_value
(<<<) file (Conditional {if_cond,if_then,if_else}) = (<<<) file (Conditional {if_cond,if_then,if_else}) =
else_part (file <<< "IF " <<< if_cond <<< "\nTHEN\n" <<< if_then) if_else else_part (file <<< "IF " <<< if_cond <<< "\nTHEN\n" <<< if_then) if_else
......
...@@ -704,7 +704,8 @@ setExtendedVarInfo var_info_ptr extension var_heap ...@@ -704,7 +704,8 @@ setExtendedVarInfo var_info_ptr extension var_heap
= case old_var_info of = case old_var_info of
VI_Extended _ original_var_info -> writePtr var_info_ptr (VI_Extended extension original_var_info) var_heap VI_Extended _ original_var_info -> writePtr var_info_ptr (VI_Extended extension original_var_info) var_heap
_ -> writePtr var_info_ptr (VI_Extended extension old_var_info) var_heap _ -> writePtr var_info_ptr (VI_Extended extension old_var_info) var_heap
neverMatchingCase = { case_expr = EE, case_guards = NoPattern, case_default = No, case_ident = No, case_info_ptr = nilPtr } neverMatchingCase = { case_expr = EE, case_guards = NoPattern, case_default = No, case_ident = No,
case_info_ptr = nilPtr, case_default_pos = NoPos }
instance transform DynamicExpr where instance transform DynamicExpr where
transform dyn=:{dyn_expr} ro ti transform dyn=:{dyn_expr} ro ti
......
...@@ -26,6 +26,12 @@ where ...@@ -26,6 +26,12 @@ where
lift no ls lift no ls
= (no, ls) = (no, ls)
instance lift CheckedAlternative
where
lift ca=:{ca_rhs} ls
# (ca_rhs, ls) = lift ca_rhs ls
= ({ ca & ca_rhs = ca_rhs }, ls)
instance lift Expression instance lift Expression
where where
lift (FreeVar {fv_name,fv_info_ptr}) ls=:{ls_var_heap} lift (FreeVar {fv_name,fv_info_ptr}) ls=:{ls_var_heap}
...@@ -735,10 +741,15 @@ where ...@@ -735,10 +741,15 @@ where
expandMacrosInBody fi_calls {cb_args,cb_rhs} fun_defs mod_index alias_dummy modules es=:{es_symbol_table} expandMacrosInBody fi_calls {cb_args,cb_rhs} fun_defs mod_index alias_dummy modules es=:{es_symbol_table}
# (prev_calls, fun_defs, es_symbol_table) = addFunctionCallsToSymbolTable fi_calls fun_defs es_symbol_table # (prev_calls, fun_defs, es_symbol_table)
([rhs:rhss], fun_defs, modules, (all_calls, es)) = expand cb_rhs fun_defs mod_index modules (prev_calls, { es & es_symbol_table = es_symbol_table }) = addFunctionCallsToSymbolTable fi_calls fun_defs es_symbol_table
(fun_defs, es_symbol_table) = removeFunctionCallsFromSymbolTable all_calls fun_defs es.es_symbol_table ([rhs:rhss], (fun_defs, modules, (all_calls, es)) )
(merged_rhs, es_var_heap, es_symbol_heap, es_error) = mergeCases rhs rhss es.es_var_heap es.es_symbol_heap es.es_error = mapSt (expandCheckedAlternative mod_index) cb_rhs
(fun_defs, modules, (prev_calls, { es & es_symbol_table = es_symbol_table }))
(fun_defs, es_symbol_table)
= removeFunctionCallsFromSymbolTable all_calls fun_defs es.es_symbol_table
((merged_rhs, _), es_var_heap, es_symbol_heap, es_error)
= mergeCases rhs rhss es.es_var_heap es.es_symbol_heap es.es_error
(new_rhs, new_args, local_vars, {cos_error, cos_var_heap, cos_symbol_heap}) (new_rhs, new_args, local_vars, {cos_error, cos_var_heap, cos_symbol_heap})
= determineVariablesAndRefCounts cb_args merged_rhs = determineVariablesAndRefCounts cb_args merged_rhs
{ cos_error = es_error, cos_var_heap = es_var_heap, cos_symbol_heap = es_symbol_heap, { cos_error = es_error, cos_var_heap = es_var_heap, cos_symbol_heap = es_symbol_heap,
...@@ -746,7 +757,11 @@ expandMacrosInBody fi_calls {cb_args,cb_rhs} fun_defs mod_index alias_dummy modu ...@@ -746,7 +757,11 @@ expandMacrosInBody fi_calls {cb_args,cb_rhs} fun_defs mod_index alias_dummy modu
= (new_args, new_rhs, local_vars, all_calls, fun_defs, modules, = (new_args, new_rhs, local_vars, all_calls, fun_defs, modules,
{ es & es_error = cos_error, es_var_heap = cos_var_heap, es_symbol_heap = cos_symbol_heap, { es & es_error = cos_error, es_var_heap = cos_var_heap, es_symbol_heap = cos_symbol_heap,
es_symbol_table = es_symbol_table }) es_symbol_table = es_symbol_table })
// ---> ("expandMacrosInBody", (cb_args, cb_rhs, '\n'), ("merged_rhs", merged_rhs, '\n'), ("new_rhs", new_args, local_vars, (new_rhs, '\n'))) // ---> ("expandMacrosInBody", (cb_args, ca_rhs, '\n'), ("merged_rhs", merged_rhs, '\n'), ("new_rhs", new_args, local_vars, (new_rhs, '\n')))
expandCheckedAlternative mod_index {ca_rhs, ca_position} (fun_defs, modules, es)
# (ca_rhs, fun_defs, modules, es) = expand ca_rhs fun_defs mod_index modules es
= ((ca_rhs, ca_position), (fun_defs, modules, es))
cContainsFreeVars :== True cContainsFreeVars :== True
cContainsNoFreeVars :== False cContainsNoFreeVars :== False
...@@ -755,21 +770,25 @@ cMacroIsCalled :== True ...@@ -755,21 +770,25 @@ cMacroIsCalled :== True
cNoMacroIsCalled :== False cNoMacroIsCalled :== False
mergeCases :: !Expression ![Expression] !*VarHeap !*ExpressionHeap !*ErrorAdmin -> *(!Expression, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin); mergeCases :: !(!Expression, !Position) ![(!Expression, !Position)] !*VarHeap !*ExpressionHeap !*ErrorAdmin
mergeCases expr [] var_heap symbol_heap error -> *(!(!Expression, !Position), !*VarHeap, !*ExpressionHeap, !*ErrorAdmin)
= (expr, var_heap, symbol_heap, error) mergeCases expr_and_pos [] var_heap symbol_heap error
mergeCases (Let lad=:{let_expr}) exprs var_heap symbol_heap error = (expr_and_pos, var_heap, symbol_heap, error)
# (let_expr, var_heap, symbol_heap, error) = mergeCases let_expr exprs var_heap symbol_heap error mergeCases (Let lad=:{let_expr}, pos) exprs var_heap symbol_heap error
= (Let {lad & let_expr = let_expr}, var_heap,symbol_heap, error) # ((let_expr, _), var_heap, symbol_heap, error) = mergeCases (let_expr, NoPos) exprs var_heap symbol_heap error
mergeCases case_expr=:(Case first_case=:{case_expr = Var {var_info_ptr}, case_default = No}) [expr : exprs] var_heap symbol_heap error = ((Let {lad & let_expr = let_expr}, pos), var_heap,symbol_heap, error)
mergeCases (case_expr=:(Case first_case=:{case_expr = Var {var_info_ptr}, case_default = No}), case_pos)
[(expr, expr_pos) : exprs] var_heap symbol_heap error
# (split_result, var_heap, symbol_heap) = split_case var_info_ptr expr var_heap symbol_heap # (split_result, var_heap, symbol_heap) = split_case var_info_ptr expr var_heap symbol_heap
= case split_result of = case split_result of
Yes {case_guards,case_default} Yes {case_guards,case_default}
# (case_guards, var_heap, symbol_heap, error) = merge_guards first_case.case_guards case_guards var_heap symbol_heap error # (case_guards, var_heap, symbol_heap, error) = merge_guards first_case.case_guards case_guards var_heap symbol_heap error
-> mergeCases (Case { first_case & case_guards = case_guards, case_default = case_default }) exprs var_heap symbol_heap error -> mergeCases (Case { first_case & case_guards = case_guards, case_default = case_default }, NoPos)
exprs var_heap symbol_heap error
No No
# (case_default, var_heap, symbol_heap, error) = mergeCases expr exprs var_heap symbol_heap error # ((case_default, pos), var_heap, symbol_heap, error) = mergeCases (expr, expr_pos) exprs var_heap symbol_heap error
-> (Case { first_case & case_default = Yes case_default}, var_heap, symbol_heap, error) -> ((Case { first_case & case_default = Yes case_default, case_default_pos = pos }, case_pos),
var_heap, symbol_heap, error)
where where
split_case split_var_info_ptr (Case this_case=:{case_expr = Var {var_info_ptr}, case_guards, case_default}) var_heap symbol_heap split_case split_var_info_ptr (Case this_case=:{case_expr = Var {var_info_ptr}, case_guards, case_default}) var_heap symbol_heap
...@@ -941,10 +960,10 @@ where ...@@ -941,10 +960,10 @@ where
merge_algebraic_pattern_with_patterns new_pattern [pattern=:{ap_symbol,ap_vars,ap_expr} : patterns] var_heap symbol_heap error merge_algebraic_pattern_with_patterns new_pattern [pattern=:{ap_symbol,ap_vars,ap_expr} : patterns] var_heap symbol_heap error
| new_pattern.ap_symbol == ap_symbol | new_pattern.ap_symbol == ap_symbol
| isEmpty new_pattern.ap_vars | isEmpty new_pattern.ap_vars
# (ap_expr, var_heap, symbol_heap, error) = mergeCases ap_expr [new_pattern.ap_expr] var_heap symbol_heap error # ((ap_expr, _), var_heap, symbol_heap, error) = mergeCases (ap_expr, NoPos) [(new_pattern.ap_expr, NoPos)] var_heap symbol_heap error
= ([{ pattern & ap_expr = ap_expr} : patterns], var_heap, symbol_heap, error) = ([{ pattern & ap_expr = ap_expr} : patterns], var_heap, symbol_heap, error)
# (new_expr, var_heap, symbol_heap) = replace_variables new_pattern.ap_vars new_pattern.ap_expr ap_vars var_heap symbol_heap # (new_expr, var_heap, symbol_heap) = replace_variables new_pattern.ap_vars new_pattern.ap_expr ap_vars var_heap symbol_heap
(ap_expr, var_heap, symbol_heap, error) = mergeCases ap_expr [new_expr] var_heap symbol_heap error ((ap_expr, _), var_heap, symbol_heap, error) = mergeCases (ap_expr, NoPos) [(new_expr, NoPos)] var_heap symbol_heap error
= ([{ pattern & ap_expr = ap_expr} : patterns], var_heap, symbol_heap, error) = ([{ pattern & ap_expr = ap_expr} : patterns], var_heap, symbol_heap, error)
# (patterns, var_heap, symbol_heap, error) = merge_algebraic_pattern_with_patterns new_pattern patterns var_heap symbol_heap error # (patterns, var_heap, symbol_heap, error) = merge_algebraic_pattern_with_patterns new_pattern patterns var_heap symbol_heap error
= ([ pattern : patterns ], var_heap, symbol_heap, error) = ([ pattern : patterns ], var_heap, symbol_heap, error)
...@@ -965,25 +984,27 @@ where ...@@ -965,25 +984,27 @@ where
merge_basic_pattern_with_patterns new_pattern [pattern=:{bp_value,bp_expr} : patterns] var_heap symbol_heap error merge_basic_pattern_with_patterns new_pattern [pattern=:{bp_value,bp_expr} : patterns] var_heap symbol_heap error
| new_pattern.bp_value == bp_value | new_pattern.bp_value == bp_value
# (bp_expr, var_heap, symbol_heap, error) = mergeCases bp_expr [new_pattern.bp_expr] var_heap symbol_heap error # ((bp_expr, _), var_heap, symbol_heap, error) = mergeCases (bp_expr, NoPos) [(new_pattern.bp_expr, NoPos)] var_heap symbol_heap error
= ([{ pattern & bp_expr = bp_expr} : patterns], var_heap, symbol_heap, error) = ([{ pattern & bp_expr = bp_expr} : patterns], var_heap, symbol_heap, error)
# (patterns, var_heap, symbol_heap, error) = merge_basic_pattern_with_patterns new_pattern patterns var_heap symbol_heap error # (patterns, var_heap, symbol_heap, error) = merge_basic_pattern_with_patterns new_pattern patterns var_heap symbol_heap error
= ([ pattern : patterns ], var_heap, symbol_heap, error) = ([ pattern : patterns ], var_heap, symbol_heap, error)
merge_basic_pattern_with_patterns new_pattern [] var_heap symbol_heap error merge_basic_pattern_with_patterns new_pattern [] var_heap symbol_heap error
= ([new_pattern], var_heap, symbol_heap, error) = ([new_pattern], var_heap, symbol_heap, error)
mergeCases case_expr=:(Case first_case=:{case_default}) [expr : exprs] var_heap symbol_heap error mergeCases (case_expr=:(Case first_case=:{case_default, case_default_pos}), case_pos) [expr : exprs] var_heap symbol_heap error
= case case_default of = case case_default of
Yes default_expr Yes default_expr
# (default_expr, var_heap, symbol_heap, error) = mergeCases default_expr [expr : exprs] var_heap symbol_heap error # ((default_expr, case_default_pos), var_heap, symbol_heap, error) = mergeCases (default_expr, case_default_pos) [expr : exprs] var_heap symbol_heap error
-> (Case { first_case & case_default = Yes default_expr }, var_heap, symbol_heap, error) -> ((Case { first_case & case_default = Yes default_expr, case_default_pos = case_default_pos }, case_pos),
var_heap, symbol_heap, error)
No No
# (default_expr, var_heap, symbol_heap, error) = mergeCases expr exprs var_heap symbol_heap error # ((default_expr, pos), var_heap, symbol_heap, error) = mergeCases expr exprs var_heap symbol_heap error
-> (Case { first_case & case_default = Yes default_expr }, var_heap, symbol_heap, error) -> ((Case { first_case & case_default = Yes default_expr, case_default_pos = pos }, case_pos),
mergeCases expr _ var_heap symbol_heap error var_heap, symbol_heap, error)
= (expr, var_heap, symbol_heap, checkWarning "" " alternative will never match" error) mergeCases expr_and_pos _ var_heap symbol_heap error
= (expr_and_pos, var_heap, symbol_heap, checkWarning "" " alternative will never match" error)
liftFunctions min_level group group_index fun_defs var_heap expr_heap liftFunctions min_level group group_index fun_defs var_heap expr_heap
# (contains_free_vars, lifted_function_called, fun_defs) # (contains_free_vars, lifted_function_called, fun_defs)
= foldSt (add_free_vars_of_non_recursive_calls_to_function group_index) group (False, False, fun_defs) = foldSt (add_free_vars_of_non_recursive_calls_to_function group_index) group (False, False, fun_defs)
......
...@@ -840,11 +840,13 @@ where ...@@ -840,11 +840,13 @@ where
instance requirements Case instance