aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--frontend/checkFunctionBodies.icl63
1 files changed, 59 insertions, 4 deletions
diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl
index ab5128a..250c896 100644
--- a/frontend/checkFunctionBodies.icl
+++ b/frontend/checkFunctionBodies.icl
@@ -1,7 +1,7 @@
implementation module checkFunctionBodies
import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef //, RWSDebug
-import explicitimports, comparedefimp
+import explicitimports, comparedefimp, mergecases
cIsInExpressionList :== True
cIsNotInExpressionList :== False
@@ -516,9 +516,10 @@ checkExpression free_vars (PE_Case case_ident expr alts) e_input e_state e_info
# (pattern_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs
(guards, _, pattern_variables, defaul, free_vars, e_state, e_info, cs) = check_guarded_expressions free_vars alts [] case_ident.id_name e_input e_state e_info cs
(pattern_expr, binds, es_expr_heap) = bind_pattern_variables pattern_variables pattern_expr e_state.es_expr_heap
- (case_expr, es_expr_heap) = build_case guards defaul pattern_expr case_ident es_expr_heap
+ (case_expr, es_var_heap, es_expr_heap, cs_error) = build_and_merge_case guards defaul pattern_expr case_ident e_state.es_var_heap es_expr_heap cs.cs_error
+ cs = {cs & cs_error = cs_error}
(result_expr, es_expr_heap) = buildLetExpression [] binds case_expr NoPos es_expr_heap
- = (result_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs)
+ = (result_expr, free_vars, { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap }, e_info, cs)
where
check_guarded_expressions free_vars [g] pattern_variables case_name e_input=:{ei_expr_level} e_state e_info cs
@@ -617,7 +618,8 @@ where
# free_var = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }
(new_bound_var, expr_heap) = allocate_bound_var free_var expr_heap
case_ident = { id_name = case_name, id_info = nilPtr }
- (new_case, expr_heap) = build_case patterns defaul (Var new_bound_var) case_ident expr_heap
+ (new_case, var_store, expr_heap, cs_error) = build_and_merge_case patterns defaul (Var new_bound_var) case_ident var_store expr_heap cs.cs_error
+ cs = {cs & cs_error = cs_error}
new_defaul = insert_as_default new_case result_expr
= (NoPattern, pattern_scheme, (cons_optional opt_var pattern_variables), Yes (Yes free_var, new_defaul),
var_store, expr_heap, opt_dynamics, cs)
@@ -643,6 +645,59 @@ where
Yes defaul -> Case { kees & case_default = Yes (insert_as_default to_insert defaul)}
insert_as_default _ expr = expr // checkWarning "pattern won't match"
+ build_and_merge_case patterns defaul expr case_ident var_heap expr_heap error_admin
+ # (expr, expr_heap)= build_case patterns defaul expr case_ident expr_heap
+ # (expr, var_heap, expr_heap) = share_case_expr expr var_heap expr_heap
+ = merge_case expr var_heap expr_heap error_admin
+
+ share_case_expr (Let lad=:{let_expr}) var_heap expr_heap
+ # (let_expr, var_heap, expr_heap) = share_case_expr let_expr var_heap expr_heap
+ = (Let {lad & let_expr = let_expr}, var_heap, expr_heap)
+ share_case_expr expr=:(Case {case_expr=Var var_ptr}) var_heap expr_heap
+ = (expr, var_heap, expr_heap)
+ share_case_expr (Case kees=:{case_expr}) var_heap expr_heap
+ # (free_var, var_heap) = allocate_free_var { id_name = "_case_var", id_info = nilPtr } var_heap
+ (bound_var, expr_heap) = allocate_bound_var free_var expr_heap
+ (case_expression, expr_heap) = bind_default_variable case_expr free_var (Case {kees & case_expr = Var bound_var}) expr_heap
+ = (case_expression, var_heap, expr_heap)
+ share_case_expr expr var_heap expr_heap
+ = (expr, var_heap, expr_heap)
+
+ merge_case (Let lad=:{let_expr}) var_heap expr_heap error_admin
+ # (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 = 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
+ kees = {kees & case_guards = case_guards}
+ = (Case kees, var_heap, expr_heap, error_admin)
+ where
+ split_patterns :: CasePatterns -> [CasePatterns]
+ split_patterns (AlgebraicPatterns index patterns)
+ = [AlgebraicPatterns index [pattern] \\ pattern <- patterns]
+ split_patterns (BasicPatterns basicType patterns)
+ = [BasicPatterns basicType [pattern] \\ pattern <- patterns]
+ split_patterns (DynamicPatterns patterns)
+ = [DynamicPatterns [pattern] \\ pattern <- patterns]
+ split_patterns NoPattern
+ = [NoPattern]
+
+ make_case :: Expression CasePatterns -> Case
+ make_case expr guard
+ =
+ { case_expr = expr
+ , case_guards = guard
+ , case_default = No
+ , case_ident = No
+ , case_info_ptr = nilPtr
+ , case_default_pos= NoPos
+ }
+ merge_case expr var_heap expr_heap error_admin
+ = (expr, var_heap, expr_heap, error_admin)
+
+
build_case NoPattern defaul expr case_ident expr_heap
= case defaul of
Yes (opt_var, result)