diff options
| -rw-r--r-- | frontend/check.icl | 39 | ||||
| -rw-r--r-- | frontend/comparedefimp.icl | 2 | ||||
| -rw-r--r-- | frontend/convertDynamics.icl | 3 | ||||
| -rw-r--r-- | frontend/explicitimports.icl | 4 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 11 | ||||
| -rw-r--r-- | frontend/syntax.icl | 18 | ||||
| -rw-r--r-- | frontend/trans.icl | 3 | ||||
| -rw-r--r-- | frontend/transform.icl | 73 | ||||
| -rw-r--r-- | frontend/type.icl | 21 |
9 files changed, 122 insertions, 52 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 082a690..883e81f 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -1041,7 +1041,7 @@ newFreeVariable new_var [] 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_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 @@ -1427,16 +1427,18 @@ where # (case_expr_ptr, expr_heap) = newPtr EI_Empty 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, - 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) No # (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap -> (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 # (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 # (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap @@ -1869,13 +1871,15 @@ where # (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap 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_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 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 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_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 = 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 (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 }, 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) 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 @@ -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 = ({ 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_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) 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) @@ -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) = 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 } - (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 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) where check_patterns [pattern : patterns] p_input accus var_store e_info cs @@ -2182,11 +2188,12 @@ where 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) = 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 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, - es_dynamics = dynamics_in_patterns ++ es_dynamics }, e_info, cs) + = ([{ ca_rhs = rhs_expr, ca_position = position } : rhs_exprs], 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) check_function_bodies free_vars fun_args [] e_input e_state e_info cs = ([], free_vars, e_state, e_info, cs) @@ -2253,14 +2260,16 @@ where 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_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) 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 (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_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) 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) diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index 489ccb1..46ce20c 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -742,7 +742,7 @@ instance e_corresponds FunctionBody where = e_corresponds (from_body dclDef) (from_body iclDef) where 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 e_corresponds dclDef iclDef diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index 5f4a29c..d4f4d52 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -400,7 +400,8 @@ where case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs, bp_position = NoPos }], case_default = default_expr, 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 } = (a_ij_binds ++ binds, let_expr, { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]}) where diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl index 35e9b06..4487bf8 100644 --- a/frontend/explicitimports.icl +++ b/frontend/explicitimports.icl @@ -665,6 +665,10 @@ instance check_completeness CasePatterns where check_completeness NoPattern _ ccs = ccs +instance check_completeness CheckedAlternative where + check_completeness {ca_rhs} cci ccs + = check_completeness ca_rhs cci ccs + instance check_completeness CheckedBody where check_completeness {cb_rhs} cci ccs = check_completeness cb_rhs cci ccs diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index d70b6e7..350717d 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -380,10 +380,16 @@ cIsNonCoercible :== 2 } :: CheckedBody = - { cb_args :: ![FreeVar] - , cb_rhs :: ![Expression] + { cb_args :: ![FreeVar] + , 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 = { tb_args :: ![FreeVar] , tb_rhs :: !Expression @@ -1012,6 +1018,7 @@ cIsNotStrict :== False , case_default :: !Optional Expression , case_ident :: !Optional Ident , case_info_ptr :: !ExprInfoPtr + , case_default_pos:: !Position } :: Let = diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 5f34227..fae746d 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -355,10 +355,16 @@ cMayBeNonCoercible :== 4 } :: CheckedBody = - { cb_args :: ![FreeVar] - , cb_rhs :: ![Expression] + { cb_args :: ![FreeVar] + , 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 = { tb_args :: ![FreeVar] , tb_rhs :: !Expression @@ -972,6 +978,7 @@ cIsNotStrict :== False , case_default :: !Optional Expression , case_ident :: !Optional Ident , case_info_ptr :: !ExprInfoPtr + , case_default_pos:: !Position } :: Let = @@ -994,7 +1001,6 @@ cIsNotStrict :== False | DynamicPatterns [DynamicPattern] /* auxiliary */ | NoPattern /* auxiliary */ - :: Selection = RecordSelection !(Global DefinedSymbol) !Int | ArraySelection !(Global DefinedSymbol) !ExprInfoPtr !Expression | DictionarySelection !BoundVar ![Selection] !ExprInfoPtr !Expression @@ -1311,6 +1317,10 @@ where (<<<) file (DynamicPatterns patterns) = file <<< patterns (<<<) file NoPattern = file +instance <<< CheckedAlternative +where + (<<<) file {ca_rhs} = file <<< ca_rhs + instance <<< Qualifier where (<<<) file {qual_generators,qual_filter = Yes qual_filter} = file <<< qual_generators <<< "| " <<< qual_filter @@ -1352,7 +1362,7 @@ where (<<<) file (Case {case_expr,case_guards,case_default=No}) = file <<< "case " <<< case_expr <<< " of\n" <<< case_guards (<<<) 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 (Conditional {if_cond,if_then,if_else}) = else_part (file <<< "IF " <<< if_cond <<< "\nTHEN\n" <<< if_then) if_else diff --git a/frontend/trans.icl b/frontend/trans.icl index df7c9a7..3ba0218 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -704,7 +704,8 @@ setExtendedVarInfo var_info_ptr extension var_heap = case old_var_info of 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 -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 transform dyn=:{dyn_expr} ro ti diff --git a/frontend/transform.icl b/frontend/transform.icl index a562be4..57dd93b 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -26,6 +26,12 @@ where lift 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 where lift (FreeVar {fv_name,fv_info_ptr}) ls=:{ls_var_heap} @@ -735,10 +741,15 @@ where 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 - ([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 }) - (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 + # (prev_calls, fun_defs, es_symbol_table) + = addFunctionCallsToSymbolTable fi_calls fun_defs es_symbol_table + ([rhs:rhss], (fun_defs, modules, (all_calls, es)) ) + = 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}) = determineVariablesAndRefCounts cb_args merged_rhs { 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 = (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_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 cContainsNoFreeVars :== False @@ -755,21 +770,25 @@ cMacroIsCalled :== True cNoMacroIsCalled :== False -mergeCases :: !Expression ![Expression] !*VarHeap !*ExpressionHeap !*ErrorAdmin -> *(!Expression, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin); -mergeCases expr [] var_heap symbol_heap error - = (expr, var_heap, symbol_heap, error) -mergeCases (Let lad=:{let_expr}) exprs var_heap symbol_heap error - # (let_expr, var_heap, symbol_heap, error) = mergeCases let_expr exprs var_heap symbol_heap error - = (Let {lad & let_expr = let_expr}, 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 +mergeCases :: !(!Expression, !Position) ![(!Expression, !Position)] !*VarHeap !*ExpressionHeap !*ErrorAdmin + -> *(!(!Expression, !Position), !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) +mergeCases 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 + = ((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 = 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 }) 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 - # (case_default, var_heap, symbol_heap, error) = mergeCases expr exprs var_heap symbol_heap error - -> (Case { first_case & case_default = Yes case_default}, 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, 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 @@ -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 | new_pattern.ap_symbol == ap_symbol | 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) # (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) # (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) @@ -965,25 +984,27 @@ 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 [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) # (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) merge_basic_pattern_with_patterns 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 Yes default_expr - # (default_expr, var_heap, symbol_heap, error) = mergeCases default_expr [expr : exprs] var_heap symbol_heap error - -> (Case { first_case & case_default = Yes default_expr }, 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, case_default_pos = case_default_pos }, case_pos), + var_heap, symbol_heap, error) No - # (default_expr, 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) -mergeCases expr _ var_heap symbol_heap error - = (expr, var_heap, symbol_heap, checkWarning "" " alternative will never match" 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, case_default_pos = pos }, case_pos), + var_heap, symbol_heap, 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 # (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) diff --git a/frontend/type.icl b/frontend/type.icl index 37dc4b6..afd8528 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -840,11 +840,13 @@ where instance requirements Case where - requirements ti {case_expr,case_guards,case_default,case_info_ptr} reqs_ts +// MW4 was: requirements ti {case_expr,case_guards,case_default,case_info_ptr} reqs_ts + requirements ti {case_expr,case_guards,case_default,case_info_ptr, case_default_pos} reqs_ts # (expr_type, opt_expr_ptr, (reqs, ts)) = requirements ti case_expr reqs_ts (fresh_v, ts) = freshAttributedVariable ts (cons_types, reqs_ts) = requirements_of_guarded_expressions ti case_guards case_expr expr_type opt_expr_ptr fresh_v (reqs, ts) - (reqs, ts) = requirements_of_default ti case_default fresh_v reqs_ts +// MW4 was: (reqs, ts) = requirements_of_default ti case_default fresh_v reqs_ts + (reqs, ts) = requirements_of_default ti case_default case_default_pos fresh_v reqs_ts ts_expr_heap = ts.ts_expr_heap <:= (case_info_ptr, EI_CaseType { ct_pattern_type = expr_type, ct_result_type = fresh_v, ct_cons_types = cons_types }) = (fresh_v, No, ({ reqs & req_case_and_let_exprs = [case_info_ptr : reqs.req_case_and_let_exprs]}, { ts & ts_expr_heap = ts_expr_heap })) @@ -977,6 +979,7 @@ where // ..MW4 +/* MW4 was: requirements_of_default ti (Yes expr) goal_type reqs_ts # (res_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr reqs_ts ts_expr_heap = storeAttribute opt_expr_ptr res_type.at_attribute ts.ts_expr_heap @@ -984,6 +987,20 @@ where { ts & ts_expr_heap = ts_expr_heap }) requirements_of_default ti No goal_type reqs_ts = reqs_ts +*/ + requirements_of_default ti (Yes expr) case_default_pos goal_type reqs_ts + = possibly_accumulate_reqs_in_new_group + case_default_pos + (reqs_of_default ti expr goal_type) + reqs_ts + requirements_of_default ti No _ goal_type reqs_ts + = reqs_ts + + reqs_of_default ti expr goal_type reqs_ts + # (res_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr reqs_ts + ts_expr_heap = storeAttribute opt_expr_ptr res_type.at_attribute ts.ts_expr_heap + = ({ reqs & req_type_coercions = [ { tc_demanded = goal_type, tc_offered = res_type, tc_position = CP_Expression expr, tc_coercible = True } : reqs.req_type_coercions] }, + { ts & ts_expr_heap = ts_expr_heap }) instance requirements Let where |