diff options
| -rw-r--r-- | frontend/checkFunctionBodies.icl | 10 | ||||
| -rw-r--r-- | frontend/mergecases.icl | 68 |
2 files changed, 43 insertions, 35 deletions
diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl index 4dfdaa7..6ad9d59 100644 --- a/frontend/checkFunctionBodies.icl +++ b/frontend/checkFunctionBodies.icl @@ -900,7 +900,7 @@ where # (let_expr, var_heap, expr_heap, error_admin) = merge_case let_expr var_heap expr_heap error_admin = (Let {lad & let_expr = let_expr}, var_heap, expr_heap, error_admin) merge_case (Case kees) var_heap expr_heap error_admin - # cases = map (make_case kees.case_expr) (split_patterns kees.case_guards) + # cases = map (make_case kees.case_expr kees.case_explicit) (split_patterns kees.case_guards) cases = init cases ++ [{last cases & case_default = kees.case_default}] [firstCase : otherCases] = [(Case kees, NoPos) \\ kees <- cases] ((Case {case_guards},_), var_heap, expr_heap, error_admin) = mergeCases firstCase otherCases var_heap expr_heap error_admin @@ -919,8 +919,8 @@ where split_patterns NoPattern = [NoPattern] - make_case :: Expression CasePatterns -> Case - make_case expr guard + make_case :: Expression Bool CasePatterns -> Case + make_case expr explicit guard = { case_expr = expr , case_guards = guard @@ -928,9 +928,7 @@ where , case_ident = No , case_info_ptr = nilPtr , case_default_pos= NoPos -// RWS ... - , case_explicit = False -// ... RWS + , case_explicit = explicit } merge_case expr var_heap expr_heap error_admin = (expr, var_heap, expr_heap, error_admin) diff --git a/frontend/mergecases.icl b/frontend/mergecases.icl index c502a59..833beaa 100644 --- a/frontend/mergecases.icl +++ b/frontend/mergecases.icl @@ -33,26 +33,35 @@ instance GetSetPatternRhs DynamicPattern get_pattern_rhs p = p.dp_rhs set_pattern_rhs p expr = {p & dp_rhs=expr} + mergeCases :: !(!Expression, !Position) ![(!Expression, !Position)] !*VarHeap !*ExpressionHeap !*ErrorAdmin -> *(!(!Expression, !Position), !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) -mergeCases expr_and_pos [] var_heap symbol_heap error +mergeCases expr_and_pos exprs var_heap symbol_heap error + = mergeCaseWithCases False expr_and_pos exprs var_heap symbol_heap error + +mergeNestedCases + :== mergeCaseWithCases True + +mergeCaseWithCases :: !Bool !(!Expression, !Position) ![(!Expression, !Position)] !*VarHeap !*ExpressionHeap !*ErrorAdmin + -> *(!(!Expression, !Position), !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) +mergeCaseWithCases _ expr_and_pos [] var_heap symbol_heap error = (expr_and_pos, var_heap, symbol_heap, error) -mergeCases (Let lad=:{let_expr}, pos) exprs var_heap symbol_heap error - # ((let_expr, _), var_heap, symbol_heap, error) = mergeCases (let_expr, NoPos) exprs var_heap symbol_heap error +mergeCaseWithCases nested (Let lad=:{let_expr}, pos) exprs var_heap symbol_heap error + # ((let_expr, _), var_heap, symbol_heap, error) = mergeCaseWithCases nested (let_expr, NoPos) 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) +mergeCaseWithCases nested (case_expr=:(Case first_case=:{case_expr = Var {var_info_ptr}, case_default = No, case_explicit}), 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 - = case split_result of - 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 - -> mergeCases (Case { first_case & case_guards = case_guards, case_default = case_default }, NoPos) - exprs var_heap symbol_heap error - No - # ((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, case_default_pos = pos }, case_pos), - var_heap, symbol_heap, error) - + | not (nested && case_explicit) + # (split_result, var_heap, symbol_heap) = split_case var_info_ptr expr var_heap symbol_heap + = case split_result of + 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 + -> mergeCaseWithCases nested (Case { first_case & case_guards = case_guards, case_default = case_default }, NoPos) + exprs var_heap symbol_heap error + No + # ((case_default, pos), var_heap, symbol_heap, error) = mergeCaseWithCases nested (expr, expr_pos) exprs 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 split_case split_var_info_ptr (Case this_case=:{case_expr = Var {var_info_ptr}, case_guards, case_default}) var_heap symbol_heap | split_var_info_ptr == skip_alias var_info_ptr var_heap @@ -315,10 +324,10 @@ where 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 | isEmpty new_pattern.ap_vars - # ((ap_expr, _), var_heap, symbol_heap, error) = mergeCases (ap_expr, NoPos) [(new_pattern.ap_expr, NoPos)] var_heap symbol_heap error + # ((ap_expr, _), var_heap, symbol_heap, error) = mergeNestedCases (ap_expr, NoPos) [(new_pattern.ap_expr, NoPos)] 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 - ((ap_expr, _), var_heap, symbol_heap, error) = mergeCases (ap_expr, NoPos) [(new_expr, NoPos)] var_heap symbol_heap error + ((ap_expr, _), var_heap, symbol_heap, error) = mergeNestedCases (ap_expr, NoPos) [(new_expr, NoPos)] 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 = ([ pattern : patterns ], var_heap, symbol_heap, error) @@ -333,7 +342,7 @@ where where merge_basic_pattern_with_patterns new_pattern [pattern=:{bp_value,bp_expr} : patterns] var_heap symbol_heap error | new_pattern.bp_value == bp_value - # ((bp_expr, _), var_heap, symbol_heap, error) = mergeCases (bp_expr, NoPos) [(new_pattern.bp_expr, NoPos)] var_heap symbol_heap error + # ((bp_expr, _), var_heap, symbol_heap, error) = mergeNestedCases (bp_expr, NoPos) [(new_pattern.bp_expr, NoPos)] 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 = ([ pattern : patterns ], var_heap, symbol_heap, error) @@ -380,16 +389,17 @@ where incompatible_patterns_in_case_error error = checkError "" "incompatible patterns in case" 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 - Yes default_expr - # ((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, case_default_pos = case_default_pos }, case_pos), - var_heap, symbol_heap, error) - No - # ((default_expr, pos), var_heap, symbol_heap, error) = mergeCases expr exprs var_heap symbol_heap error - -> ((Case { first_case & case_default = Yes default_expr, case_default_pos = pos }, case_pos), - var_heap, symbol_heap, error) -mergeCases expr_and_pos _ var_heap symbol_heap error +mergeCaseWithCases nested (case_expr=:(Case first_case=:{case_default, case_default_pos, case_explicit}), case_pos) [expr : exprs] var_heap symbol_heap error + | not (nested && case_explicit) + = case case_default of + Yes default_expr + # ((default_expr, case_default_pos), var_heap, symbol_heap, error) = mergeCaseWithCases nested (default_expr, case_default_pos) [expr : exprs] 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 + # ((default_expr, pos), var_heap, symbol_heap, error) = mergeCaseWithCases nested expr exprs var_heap symbol_heap error + -> ((Case { first_case & case_default = Yes default_expr, case_default_pos = pos }, case_pos), + var_heap, symbol_heap, error) +mergeCaseWithCases _ expr_and_pos _ var_heap symbol_heap error = (expr_and_pos, var_heap, symbol_heap, checkWarning "" " alternative will never match" error) |