diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/check.icl | 183 | ||||
| -rw-r--r-- | frontend/convertDynamics.icl | 3 | ||||
| -rw-r--r-- | frontend/postparse.icl | 24 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 8 | ||||
| -rw-r--r-- | frontend/syntax.icl | 7 | ||||
| -rw-r--r-- | frontend/type.icl | 152 |
6 files changed, 281 insertions, 96 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 99b941f..082a690 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -1303,9 +1303,9 @@ where !String !*VarHeap !*ExpressionHeap ![DynamicPtr] !*CheckState -> (!CasePatterns, !CasePatterns, !Env Ident VarInfoPtr, !Optional (!Optional FreeVar,!Expression), !*VarHeap, !*ExpressionHeap, ![DynamicPtr], !*CheckState) transform_pattern (AP_Algebraic cons_symbol type_index args opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ var_store expr_heap opt_dynamics cs - # (var_args, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr var_store expr_heap opt_dynamics cs + # (var_args, result_expr, _, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr NoPos var_store expr_heap opt_dynamics cs type_symbol = { glob_module = cons_symbol.glob_module, glob_object = type_index} - pattern = { ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr} + pattern = { ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr, ap_position = NoPos} pattern_variables = cons_optional opt_var pattern_variables = case pattern_scheme of AlgebraicPatterns alg_type _ @@ -1322,7 +1322,7 @@ where -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, { cs & cs_error = checkError cons_symbol.glob_object.ds_ident "illegal combination of patterns" cs.cs_error }) transform_pattern (AP_Basic basic_val opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ var_store expr_heap opt_dynamics cs - # pattern = { bp_value = basic_val, bp_expr = result_expr} + # pattern = { bp_value = basic_val, bp_expr = result_expr, bp_position = NoPos} pattern_variables = cons_optional opt_var pattern_variables (type_symbol, cs) = typeOfBasicValue basic_val cs = case pattern_scheme of @@ -1342,9 +1342,10 @@ where -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, { cs & cs_error = checkError basic_val "illegal combination of patterns" cs.cs_error}) transform_pattern (AP_Dynamic pattern type opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ var_store expr_heap opt_dynamics cs - # (var_arg, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr var_store expr_heap opt_dynamics cs + # (var_arg, result_expr, _, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr NoPos var_store expr_heap opt_dynamics cs (dynamic_info_ptr, expr_heap) = newPtr (EI_DynamicType type opt_dynamics) expr_heap - pattern = { dp_var = var_arg, dp_type = dynamic_info_ptr, dp_rhs = result_expr, dp_type_patterns_vars = [], dp_type_code = TCE_Empty } + pattern = { dp_var = var_arg, dp_type = dynamic_info_ptr, dp_rhs = result_expr, dp_type_patterns_vars = [], + dp_type_code = TCE_Empty, dp_position = NoPos } pattern_variables = cons_optional opt_var pattern_variables = case pattern_scheme of DynamicPatterns _ @@ -1866,12 +1867,14 @@ where convert_guards_to_cases [(let_binds, guard, expr)] result_expr es_expr_heap # (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap - case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [{bp_value = (BVB True), bp_expr = expr}], + 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 } = 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 - case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [{bp_value = (BVB True), bp_expr = expr}], + 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 } (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 @@ -1969,57 +1972,68 @@ determinePatternVariable No var_heap # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap = ({ bind_src = newVarId "_x", bind_dst = new_info_ptr }, var_heap) -convertSubPatterns [] result_expr var_store expr_heap opt_dynamics cs - = ([], result_expr, var_store, expr_heap, opt_dynamics, cs) -convertSubPatterns [pattern : patterns] result_expr var_store expr_heap opt_dynamics cs - # (var_args, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns patterns result_expr var_store expr_heap opt_dynamics cs - (var_arg, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr var_store expr_heap opt_dynamics cs - = ([var_arg : var_args], result_expr, var_store, expr_heap, opt_dynamics, cs) +convertSubPatterns [] result_expr pattern_position var_store expr_heap opt_dynamics cs + = ([], result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) +convertSubPatterns [pattern : patterns] result_expr pattern_position var_store expr_heap opt_dynamics cs + # (var_args, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) + = convertSubPatterns patterns result_expr pattern_position var_store expr_heap opt_dynamics cs + (var_arg, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) + = convertSubPattern pattern result_expr pattern_position var_store expr_heap opt_dynamics cs + = ([var_arg : var_args], result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) -convertSubPattern (AP_Variable name var_info (Yes {bind_src,bind_dst})) result_expr var_store expr_heap opt_dynamics cs +convertSubPattern (AP_Variable name var_info (Yes {bind_src,bind_dst})) result_expr pattern_position var_store expr_heap opt_dynamics cs # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap bound_var = { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr } free_var = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 } (let_expr, expr_heap) = buildLetExpression [] [{ bind_src = Var bound_var, bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}] result_expr expr_heap - = (free_var, let_expr, var_store, expr_heap, opt_dynamics, cs) -convertSubPattern (AP_Variable name var_info No) result_expr var_store expr_heap opt_dynamics cs - = ({ fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, result_expr, var_store, expr_heap, opt_dynamics, cs) -convertSubPattern (AP_Algebraic cons_symbol type_index args opt_var) result_expr var_store expr_heap opt_dynamics cs - # (var_args, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr var_store expr_heap opt_dynamics cs + = (free_var, let_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) +convertSubPattern (AP_Variable name var_info No) result_expr pattern_position var_store expr_heap opt_dynamics cs + = ({ fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, result_expr, pattern_position, + var_store, expr_heap, opt_dynamics, cs) +convertSubPattern (AP_Algebraic cons_symbol type_index args opt_var) result_expr pattern_position + var_store expr_heap opt_dynamics cs + # (var_args, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) + = convertSubPatterns args result_expr pattern_position var_store expr_heap opt_dynamics cs type_symbol = { glob_module = cons_symbol.glob_module, glob_object = type_index } - case_guards = AlgebraicPatterns type_symbol [{ ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr }] + 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] ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store (var_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 }, - 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 }, var_store, expr_heap, opt_dynamics, cs) -convertSubPattern (AP_Basic basic_val opt_var) result_expr var_store expr_heap opt_dynamics cs + 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 }, + 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 - case_guards = BasicPatterns basic_type [{ bp_value = basic_val, bp_expr = result_expr }] + case_guards = BasicPatterns basic_type [{ bp_value = basic_val, bp_expr = result_expr, bp_position = pattern_position }] ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store (var_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 }, - 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}, var_store, expr_heap, opt_dynamics, cs) -convertSubPattern (AP_Dynamic pattern type opt_var) result_expr var_store expr_heap opt_dynamics cs - # (var_arg, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr var_store expr_heap opt_dynamics cs + 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}, + 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) + = convertSubPattern pattern result_expr pattern_position var_store expr_heap opt_dynamics cs ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap (dynamic_info_ptr, expr_heap) = newPtr (EI_DynamicType type opt_dynamics) expr_heap - type_case_patterns = [{ dp_var = var_arg, dp_type = dynamic_info_ptr, dp_rhs = result_expr, dp_type_patterns_vars = [], dp_type_code = TCE_Empty }] + type_case_patterns = [{ dp_var = var_arg, dp_type = dynamic_info_ptr, dp_rhs = result_expr, dp_type_patterns_vars = [], + dp_type_code = TCE_Empty, dp_position = pattern_position }] = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, - buildTypeCase (Var { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr }) type_case_patterns No type_case_info_ptr, - var_store, expr_heap, [dynamic_info_ptr], cs) -convertSubPattern (AP_WildCard opt_var) result_expr var_store expr_heap opt_dynamics cs + buildTypeCase (Var { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr }) + type_case_patterns No type_case_info_ptr, + NoPos, var_store, expr_heap, [dynamic_info_ptr], cs) +convertSubPattern (AP_WildCard opt_var) result_expr pattern_position var_store expr_heap opt_dynamics cs # ({bind_src,bind_dst}, var_store) = determinePatternVariable opt_var var_store - = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, result_expr, var_store, expr_heap, opt_dynamics, cs) -convertSubPattern (AP_Empty _) result_expr var_store expr_heap opt_dynamics cs - = convertSubPattern (AP_WildCard No) EE var_store expr_heap opt_dynamics cs - + = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, result_expr, pattern_position, + var_store, expr_heap, opt_dynamics, cs) +convertSubPattern (AP_Empty _) result_expr pattern_position var_store expr_heap opt_dynamics cs + = convertSubPattern (AP_WildCard No) EE pattern_position var_store expr_heap opt_dynamics cs typeOfBasicValue :: !BasicValue !*CheckState -> (!BasicType, !*CheckState) typeOfBasicValue (BVI _) cs = (BT_Int, cs) @@ -2110,7 +2124,7 @@ allocate_free_var ident var_heap # (new_var_info_ptr, var_heap) = newPtr VI_Empty var_heap = ({ fv_def_level = NotALevel, fv_name = ident, fv_info_ptr = new_var_info_ptr, fv_count = 0 }, var_heap) -checkFunctionBodies (ParsedBody [{pb_args,pb_rhs={rhs_alts,rhs_locals}} : bodies]) e_input=:{ei_expr_level,ei_mod_index} +checkFunctionBodies (ParsedBody [{pb_args,pb_rhs={rhs_alts,rhs_locals}, pb_position} : bodies]) e_input=:{ei_expr_level,ei_mod_index} e_state=:{es_var_heap, es_fun_defs} e_info cs # (aux_patterns, (var_env, array_patterns), {ps_var_heap, ps_fun_defs}, e_info, cs) = check_patterns pb_args {pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False} ([], []) @@ -2126,8 +2140,8 @@ checkFunctionBodies (ParsedBody [{pb_args,pb_rhs={rhs_alts,rhs_locals}} : bodies (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) - = transform_patterns_into_cases aux_patterns cb_args expr_with_array_selections es_var_heap es_expr_heap + (rhs, _, 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, { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap, es_dynamics = dynamics_in_patterns ++ es_dynamics }, e_info, cs) @@ -2156,8 +2170,8 @@ where # ({bind_src,bind_dst}, var_store) = determinePatternVariable No var_store = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store) - check_function_bodies free_vars fun_args [{pb_args,pb_rhs={rhs_alts,rhs_locals}} : bodies] e_input=:{ei_expr_level,ei_mod_index} - e_state=:{es_var_heap,es_fun_defs} e_info cs + check_function_bodies free_vars fun_args [{pb_args,pb_rhs={rhs_alts,rhs_locals},pb_position} : bodies] + e_input=:{ei_expr_level,ei_mod_index} e_state=:{es_var_heap,es_fun_defs} e_info cs # (aux_patterns, (var_env, array_patterns), {ps_var_heap, ps_fun_defs}, e_info, cs) = check_patterns pb_args { pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False } ([], []) {ps_var_heap = es_var_heap, ps_fun_defs = es_fun_defs} e_info cs @@ -2168,30 +2182,37 @@ 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) - = transform_patterns_into_cases aux_patterns fun_args rhs_expr es_var_heap es_expr_heap dynamics_in_rhs cs + (rhs_expr, _, 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) check_function_bodies free_vars fun_args [] e_input e_state e_info cs = ([], free_vars, e_state, e_info, cs) - transform_patterns_into_cases [pattern : patterns] [fun_arg : fun_args] result_expr var_store expr_heap opt_dynamics cs - # (patterns_expr, var_store, expr_heap, opt_dynamics, cs) - = transform_succeeding_patterns_into_cases patterns fun_args result_expr var_store expr_heap opt_dynamics cs - = transform_pattern_into_cases pattern fun_arg patterns_expr var_store expr_heap opt_dynamics cs + transform_patterns_into_cases [pattern : patterns] [fun_arg : fun_args] result_expr pattern_position + var_store expr_heap opt_dynamics cs + # (patterns_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) + = transform_succeeding_patterns_into_cases patterns fun_args result_expr pattern_position + var_store expr_heap opt_dynamics cs + = transform_pattern_into_cases pattern fun_arg patterns_expr pattern_position var_store expr_heap opt_dynamics cs where - transform_succeeding_patterns_into_cases [] _ result_expr var_store expr_heap opt_dynamics cs - = (result_expr, var_store, expr_heap, opt_dynamics, cs) - transform_succeeding_patterns_into_cases [pattern : patterns] [fun_arg : fun_args] result_expr var_store expr_heap opt_dynamics cs - # (patterns_expr, var_store, expr_heap, opt_dynamics, cs) - = transform_succeeding_patterns_into_cases patterns fun_args result_expr var_store expr_heap opt_dynamics cs - = transform_pattern_into_cases pattern fun_arg patterns_expr var_store expr_heap opt_dynamics cs - transform_patterns_into_cases [] _ result_expr var_store expr_heap opt_dynamics cs - = (result_expr, var_store, expr_heap, opt_dynamics, cs) + transform_succeeding_patterns_into_cases [] _ result_expr pattern_position var_store expr_heap opt_dynamics cs + = (result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) + transform_succeeding_patterns_into_cases [pattern : patterns] [fun_arg : fun_args] result_expr pattern_position + var_store expr_heap opt_dynamics cs + # (patterns_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) + = transform_succeeding_patterns_into_cases patterns fun_args result_expr pattern_position + var_store expr_heap opt_dynamics cs + = transform_pattern_into_cases pattern fun_arg patterns_expr pattern_position var_store expr_heap opt_dynamics cs + + transform_patterns_into_cases [] _ result_expr pattern_position var_store expr_heap opt_dynamics cs + = (result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) - transform_pattern_into_cases :: !AuxiliaryPattern !FreeVar !Expression !*VarHeap !*ExpressionHeap ![DynamicPtr] !*CheckState - -> (!Expression, !*VarHeap, !*ExpressionHeap, ![DynamicPtr], !*CheckState) - transform_pattern_into_cases (AP_Variable name var_info opt_var) fun_arg=:{fv_info_ptr,fv_name} result_expr var_store expr_heap opt_dynamics cs + transform_pattern_into_cases :: !AuxiliaryPattern !FreeVar !Expression !Position !*VarHeap !*ExpressionHeap ![DynamicPtr] !*CheckState + -> (!Expression, !Position, !*VarHeap, !*ExpressionHeap, ![DynamicPtr], !*CheckState) + transform_pattern_into_cases (AP_Variable name var_info opt_var) fun_arg=:{fv_info_ptr,fv_name} result_expr pattern_position + var_store expr_heap opt_dynamics cs = case opt_var of Yes {bind_src, bind_dst} | bind_dst == fv_info_ptr @@ -2200,7 +2221,8 @@ where -> (Let { let_strict_binds = [], let_lazy_binds= [ { bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}], - let_expr = result_expr, let_info_ptr = let_expr_ptr}, var_store, expr_heap, opt_dynamics, cs) + let_expr = result_expr, let_info_ptr = let_expr_ptr}, + pattern_position, var_store, expr_heap, opt_dynamics, cs) # (var_expr_ptr1, expr_heap) = newPtr EI_Empty expr_heap (var_expr_ptr2, expr_heap) = newPtr EI_Empty expr_heap (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap @@ -2209,43 +2231,50 @@ where bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}, { bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr2 }, bind_dst = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }}], - let_expr = result_expr, let_info_ptr = let_expr_ptr}, var_store, expr_heap, opt_dynamics, cs) + let_expr = result_expr, let_info_ptr = let_expr_ptr}, + pattern_position, var_store, expr_heap, opt_dynamics, cs) No | var_info == fv_info_ptr - -> (result_expr, var_store, expr_heap, opt_dynamics, cs) + -> (result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap -> (Let { let_strict_binds = [], let_lazy_binds= [{ bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}], - let_expr = result_expr, let_info_ptr = let_expr_ptr}, var_store, expr_heap, opt_dynamics, cs) + let_expr = result_expr, let_info_ptr = let_expr_ptr}, + pattern_position, var_store, expr_heap, opt_dynamics, cs) - transform_pattern_into_cases (AP_Algebraic cons_symbol type_index args opt_var) fun_arg result_expr var_store expr_heap opt_dynamics cs - # (var_args, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr var_store expr_heap opt_dynamics cs + transform_pattern_into_cases (AP_Algebraic cons_symbol type_index args opt_var) fun_arg result_expr pattern_position + var_store expr_heap opt_dynamics cs + # (var_args, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) + = convertSubPatterns args result_expr pattern_position var_store expr_heap opt_dynamics cs type_symbol = {glob_module = cons_symbol.glob_module, glob_object = type_index} (act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap - case_guards = AlgebraicPatterns type_symbol [{ ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr }] + 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 }, - var_store, expr_heap, opt_dynamics, cs) - transform_pattern_into_cases (AP_Basic basic_val opt_var) fun_arg result_expr 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 # (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 }] + 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 }, - var_store, expr_heap, opt_dynamics, cs) - transform_pattern_into_cases (AP_Dynamic pattern type opt_var) fun_arg result_expr var_store expr_heap opt_dynamics cs - # (var_arg, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr 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 + # (var_arg, result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) + = convertSubPattern pattern result_expr pattern_position var_store expr_heap opt_dynamics cs (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap (dynamic_info_ptr, expr_heap) = newPtr (EI_DynamicType type opt_dynamics) expr_heap (act_var, result_expr, expr_heap) = transform_pattern_variable fun_arg opt_var result_expr expr_heap - type_case_patterns = [{ dp_var = var_arg, dp_type = dynamic_info_ptr, dp_rhs = result_expr, dp_type_patterns_vars = [], dp_type_code = TCE_Empty }] - = (buildTypeCase act_var type_case_patterns No type_case_info_ptr, var_store, expr_heap, [dynamic_info_ptr], cs) - transform_pattern_into_cases (AP_WildCard _) fun_arg result_expr var_store expr_heap opt_dynamics cs - = (result_expr, var_store, expr_heap, opt_dynamics, cs) - transform_pattern_into_cases (AP_Empty name) fun_arg result_expr var_store expr_heap opt_dynamics cs - = (result_expr, var_store, expr_heap, opt_dynamics, cs) + type_case_patterns = [{ dp_var = var_arg, dp_type = dynamic_info_ptr, dp_rhs = result_expr, dp_type_patterns_vars = [], + dp_type_code = TCE_Empty, dp_position = pattern_position }] + = (buildTypeCase act_var type_case_patterns No type_case_info_ptr, NoPos, var_store, expr_heap, [dynamic_info_ptr], cs) + transform_pattern_into_cases (AP_WildCard _) fun_arg result_expr pattern_position var_store expr_heap opt_dynamics cs + = (result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) + transform_pattern_into_cases (AP_Empty name) fun_arg result_expr pattern_position var_store expr_heap opt_dynamics cs + = (result_expr, pattern_position, var_store, expr_heap, opt_dynamics, cs) transform_pattern_variable :: !FreeVar !(Optional !(Bind Ident VarInfoPtr)) !Expression !*ExpressionHeap -> (!Expression, !Expression, !*ExpressionHeap) diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index 11caa44..5f4a29c 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -396,7 +396,8 @@ where bind_dst = unify_bool_fv } : let_binds ], let_expr = Case { case_expr = Var unify_bool_var, - case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs}], +// MW was: case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs}], + 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 }, diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 282dc16..eea5437 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -306,7 +306,8 @@ transformLambda :: Ident [ParsedExpr] ParsedExpr Position -> FunDef transformLambda lam_ident args result pos # lam_rhs = { rhs_alts = UnGuardedExpr { ewl_nodes = [], ewl_expr = result, ewl_locals = NoCollectedLocalDefs }, rhs_locals = NoCollectedLocalDefs } - lam_body = [{pb_args = args, pb_rhs = lam_rhs }] +// MW4 was: lam_body = [{pb_args = args, pb_rhs = lam_rhs }] + lam_body = [{pb_args = args, pb_rhs = lam_rhs, pb_position = pos }] // MW was: fun_def = MakeNewFunction lam_ident (length args) lam_body (FK_Function cNameLocationDependent) NoPrio No NoPos fun_def = MakeNewFunction lam_ident (length args) lam_body (FK_Function cNameLocationDependent) NoPrio No pos = fun_def @@ -789,8 +790,10 @@ collectFunctionBodies fun_name fun_arity fun_prio fun_kind all_defs=:[PD_Functio (bodies, new_fun_kind, rest_defs, ca) = collectFunctionBodies fun_name fun_arity fun_prio new_fun_kind defs ca act_arity = length args | fun_arity == act_arity - = ([{ pb_args = args, pb_rhs = rhs } : bodies ], new_fun_kind, rest_defs, ca) - = ([{ pb_args = args, pb_rhs = rhs } : bodies ], new_fun_kind, rest_defs, +// MW4 was: = ([{ pb_args = args, pb_rhs = rhs } : bodies ], new_fun_kind, rest_defs, ca) + = ([{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies ], new_fun_kind, rest_defs, ca) +// MW4 was: = ([{ pb_args = args, pb_rhs = rhs } : bodies ], new_fun_kind, rest_defs, + = ([{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies ], new_fun_kind, rest_defs, postParseError pos ("This alternative has " + toString act_arity + (if (act_arity == 1)" argument instead of " " arguments instead of ") + toString fun_arity ) ca @@ -814,7 +817,8 @@ reorganiseDefinitions icl_module [PD_Function pos name is_infix args rhs fun_kin fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca - fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies] fun_kind prio No pos +// MW4 was: fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies] fun_kind prio No pos + fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies] fun_kind prio No pos | fun_kind == FK_Macro = (fun_defs, { c_defs & def_macros = [ fun : c_defs.def_macros ]}, imports, imported_objects, ca) = ([ fun : fun_defs ], c_defs, imports, imported_objects, ca) @@ -829,7 +833,8 @@ reorganiseDefinitions icl_module [PD_TypeSpec fun_pos fun_name prio No specials # fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca - fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos +// MW4 was: fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos + fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies ] fun_kind prio No pos | fun_kind == FK_Macro -> (fun_defs, { c_defs & def_macros = [ fun : c_defs.def_macros]}, imports, imported_objects, ca) -> ([ fun : fun_defs ], c_defs, imports, imported_objects, ca) @@ -932,7 +937,8 @@ where fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca (mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca - macro = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies] FK_Macro prio No fun_pos +// MW4 was: macro = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies] FK_Macro prio No fun_pos + macro = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = fun_pos } : bodies] FK_Macro prio No fun_pos = (mem_defs, [macro : mem_macros], ca) check_symbols_of_class_members [def : _] type_context ca = abort "postparse.check_symbols_of_class_members: unknown def" <<- def @@ -966,7 +972,8 @@ where prio = if is_infix (Prio NoAssoc 9) NoPrio (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca (fun_defs, ca) = collect_member_instances defs ca - fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos +// MW4 was: fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos + fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies ] fun_kind prio No pos = ([ fun : fun_defs ], ca) collect_member_instances [PD_TypeSpec fun_pos fun_name prio type specials : defs] ca = case defs of @@ -1005,7 +1012,8 @@ reorganiseLocalDefinitions [PD_Function pos name is_infix args rhs fun_kind : de fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca - fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos +// MW4 was: fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos + fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs, pb_position = pos } : bodies ] fun_kind prio No pos = ([ fun : fun_defs ], node_defs, ca) reorganiseLocalDefinitions [PD_TypeSpec pos1 name1 prio type specials : defs] ca = case defs of diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index b2f77dc..d70b6e7 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -374,8 +374,9 @@ cIsNonCoercible :== 2 } :: ParsedBody = - { pb_args :: ![ParsedExpr] - , pb_rhs :: !Rhs + { pb_args :: ![ParsedExpr] + , pb_rhs :: !Rhs + , pb_position :: !Position } :: CheckedBody = @@ -1081,11 +1082,13 @@ cIsNotStrict :== False { ap_symbol :: !(Global DefinedSymbol) , ap_vars :: ![FreeVar] , ap_expr :: !Expression + , ap_position :: !Position } :: BasicPattern = { bp_value :: !BasicValue , bp_expr :: !Expression + , bp_position :: !Position } :: TypeCase = @@ -1101,6 +1104,7 @@ cIsNotStrict :== False , dp_type_patterns_vars :: ![VarInfoPtr] /* filled after type checking */ , dp_type_code :: !TypeCodeExpression /* filled after type checking */ , dp_rhs :: !Expression + , dp_position :: !Position } /* diff --git a/frontend/syntax.icl b/frontend/syntax.icl index fe0044b..5f34227 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -351,6 +351,7 @@ cMayBeNonCoercible :== 4 :: ParsedBody = { pb_args :: ![ParsedExpr] , pb_rhs :: !Rhs + , pb_position :: !Position } :: CheckedBody = @@ -1012,11 +1013,13 @@ cIsNotStrict :== False { ap_symbol :: !(Global DefinedSymbol) , ap_vars :: ![FreeVar] , ap_expr :: !Expression + , ap_position :: !Position } :: BasicPattern = { bp_value :: !BasicValue , bp_expr :: !Expression + , bp_position :: !Position } :: TypeCase = @@ -1032,6 +1035,7 @@ cIsNotStrict :== False , dp_type_patterns_vars :: ![VarInfoPtr] /* filled after type checking */ , dp_type_code :: !TypeCodeExpression /* filled after type checking */ , dp_rhs :: !Expression + , dp_position :: !Position } @@ -1293,7 +1297,8 @@ where instance <<< AlgebraicPattern where - (<<<) file g = file <<< g.ap_symbol <<< g.ap_vars <<< " -> " <<< g.ap_expr +// (<<<) file g = file <<< g.ap_symbol <<< g.ap_vars <<< " -> " <<< g.ap_expr + (<<<) file g = file <<< g.ap_symbol <<< g.ap_vars <<< " " <<< g.ap_position <<< "-> " <<< g.ap_expr instance <<< BasicPattern where diff --git a/frontend/type.icl b/frontend/type.icl index 1af65ca..37dc4b6 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -36,11 +36,20 @@ import RWSDebug :: Requirements = { req_overloaded_calls :: ![ExprInfoPtr] , req_type_coercions :: ![TypeCoercion] + , req_type_coercion_groups:: ![TypeCoercionGroup] // MW4++ , req_attr_coercions :: ![AttrCoercion] , req_cons_variables :: ![[TempVarId]] , req_case_and_let_exprs :: ![ExprInfoPtr] } - + +// MW4 added.. +// one TypeCoercionGroup collects coercions for one function alternative +:: TypeCoercionGroup = + { tcg_type_coercions :: ![TypeCoercion] + , tcg_position :: !Position + } +// ..MW4 + instance toString BoundVar where toString varid = varid.var_name.id_name @@ -863,6 +872,7 @@ where = (reverse used_dyn_types, ({ reqs & req_type_coercions = [{tc_demanded = dyn_type, tc_offered = pattern_type, tc_position = CP_Expression match_expr, tc_coercible = True} : reqs.req_type_coercions] }, { ts & ts_expr_heap = ts_expr_heap })) +/* MW4 was: requirements_of_algebraic_patterns ti [] cons_types goal_type used_cons_types reqs_ts = (used_cons_types, reqs_ts) requirements_of_algebraic_patterns ti=:{ti_common_defs} [{ap_symbol, ap_vars, ap_expr }:gs] [ cons_arg_types : cons_types] goal_type used_cons_types (reqs, ts) @@ -872,7 +882,29 @@ where = requirements_of_algebraic_patterns ti gs cons_types goal_type [ cons_arg_types : used_cons_types ] ({ reqs & req_type_coercions = [ { tc_demanded = goal_type, tc_offered = res_type, tc_position = CP_Expression ap_expr, tc_coercible = True } : reqs.req_type_coercions] }, { ts & ts_expr_heap = ts_expr_heap }) +*/ + + requirements_of_algebraic_patterns ti [] cons_types goal_type used_cons_types reqs_ts + = (used_cons_types, reqs_ts) + requirements_of_algebraic_patterns ti [alg_pattern=:{ap_position}:alg_patterns] [ cons_arg_types : cons_types] + goal_type used_cons_types reqs_ts + = requirements_of_algebraic_patterns ti alg_patterns cons_types goal_type [ cons_arg_types : used_cons_types ] + (possibly_accumulate_reqs_in_new_group + ap_position + (requirements_of_algebraic_pattern ti alg_pattern cons_arg_types goal_type) + reqs_ts + ) + +// MW4++.. + requirements_of_algebraic_pattern ti {ap_symbol, ap_vars, ap_expr} cons_arg_types goal_type (reqs, ts) + # (res_type, opt_expr_ptr, (reqs, ts)) + = requirements ti ap_expr (reqs, { ts & ts_var_heap = makeBase ap_symbol.glob_object.ds_ident 1 ap_vars cons_arg_types ts.ts_var_heap}) + 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 ap_expr, tc_coercible = True } : reqs.req_type_coercions] }, + { ts & ts_expr_heap = ts_expr_heap }) +// ..MW4 +/* requirements_of_basic_patterns _ [] goal_type reqs_ts = reqs_ts requirements_of_basic_patterns ti=:{ti_common_defs} [{bp_expr }:gs] goal_type reqs_ts @@ -881,7 +913,26 @@ where = requirements_of_basic_patterns ti gs goal_type ({ reqs & req_type_coercions = [ { tc_demanded = goal_type, tc_offered = res_type, tc_position = CP_Expression bp_expr, tc_coercible = True } : reqs.req_type_coercions] }, { ts & ts_expr_heap = ts_expr_heap }) +*/ + requirements_of_basic_patterns _ [] goal_type reqs_ts + = reqs_ts + requirements_of_basic_patterns ti [{bp_expr, bp_position}:gs] goal_type reqs_ts + = requirements_of_basic_patterns ti gs goal_type + (possibly_accumulate_reqs_in_new_group + bp_position + (requirements_of_basic_pattern ti bp_expr goal_type) + reqs_ts + ) + +// MW4++.. + requirements_of_basic_pattern ti bp_expr goal_type reqs_ts + # (res_type, opt_expr_ptr, (reqs, ts)) = requirements ti bp_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 bp_expr, tc_coercible = True } : reqs.req_type_coercions] }, + { ts & ts_expr_heap = ts_expr_heap }) +// ..MW4 +/* MW4 was requirements_of_dynamic_patterns ti goal_type [{dp_var={fv_info_ptr},dp_type,dp_rhs} : dps] used_dyn_types (reqs, ts=:{ts_expr_heap, ts_var_heap}) # (EI_TempDynamicPattern _ _ _ _ dyn_type dyn_context dyn_expr_ptr type_code_symbol, ts_expr_heap) = readPtr dp_type ts_expr_heap ts_var_heap = ts_var_heap <:= (fv_info_ptr, VI_Type dyn_type No) @@ -896,6 +947,34 @@ where (dyn_expr_ptr, EI_Overloaded { oc_symbol = type_code_symbol, oc_context = dyn_context, oc_specials = [] }) }) requirements_of_dynamic_patterns ti goal_type [] used_dyn_types reqs_ts = (used_dyn_types, reqs_ts) +*/ + + requirements_of_dynamic_patterns ti goal_type [] used_dyn_types reqs_ts + = (used_dyn_types, reqs_ts) + requirements_of_dynamic_patterns ti goal_type [dp=:{dp_position, dp_type} : dps] used_dyn_types (reqs, ts=:{ts_expr_heap}) + # (EI_TempDynamicPattern _ _ _ _ dyn_type dyn_context dyn_expr_ptr type_code_symbol, ts_expr_heap) + = readPtr dp_type ts_expr_heap + (reqs_ts) + = possibly_accumulate_reqs_in_new_group + dp_position + (requirements_of_dynamic_pattern dyn_type dyn_context dyn_expr_ptr type_code_symbol ti goal_type dp) + (reqs, { ts & ts_expr_heap = ts_expr_heap}) + = requirements_of_dynamic_patterns ti goal_type dps [ [dyn_type] : used_dyn_types ] reqs_ts + +// MW4++.. + requirements_of_dynamic_pattern dyn_type dyn_context dyn_expr_ptr type_code_symbol + ti goal_type {dp_var={fv_info_ptr},dp_rhs} (reqs, ts=:{ts_expr_heap, ts_var_heap}) + # ts_var_heap = ts_var_heap <:= (fv_info_ptr, VI_Type dyn_type No) + (dp_rhs_type, opt_expr_ptr, (reqs, ts)) = requirements ti dp_rhs (reqs, { ts & ts_expr_heap = ts_expr_heap, ts_var_heap = ts_var_heap }) + ts_expr_heap = storeAttribute opt_expr_ptr dp_rhs_type.at_attribute ts.ts_expr_heap + type_coercion = { tc_demanded = goal_type, tc_offered = dp_rhs_type, tc_position = CP_Expression dp_rhs, tc_coercible = True } + | isEmpty dyn_context + # reqs = {reqs & req_type_coercions = [ type_coercion : reqs.req_type_coercions]} + = (reqs, { ts & ts_expr_heap = ts_expr_heap }) + # reqs = { reqs & req_type_coercions = [ type_coercion : reqs.req_type_coercions], req_overloaded_calls = [dyn_expr_ptr : reqs.req_overloaded_calls ]} + = (reqs, { ts & ts_expr_heap = ts_expr_heap <:= + (dyn_expr_ptr, EI_Overloaded { oc_symbol = type_code_symbol, oc_context = dyn_context, oc_specials = [] }) }) +// ..MW4 requirements_of_default ti (Yes expr) goal_type reqs_ts @@ -1139,6 +1218,27 @@ where tc_position = CP_Expression elem_expr, tc_coercible = True } : reqs.req_type_coercions ]} = (reqs, ts) +// MW4.. +possibly_accumulate_reqs_in_new_group position state_transition reqs_ts + :== possibly_accumulate_reqs position reqs_ts + where + possibly_accumulate_reqs position=:(FunPos _ _ _) (reqs=:{req_type_coercions=old_req_type_coercions}, ts) + # reqs_with_empty_accu + = { reqs & req_type_coercions = [] } + (reqs_with_new_group_in_accu, ts) + = state_transition (reqs_with_empty_accu, ts) + new_group + = { tcg_type_coercions = reqs_with_new_group_in_accu.req_type_coercions, + tcg_position = position } + reqs_with_new_group + = { reqs_with_new_group_in_accu & + req_type_coercion_groups = [new_group:reqs_with_new_group_in_accu.req_type_coercion_groups], + req_type_coercions = old_req_type_coercions } + = (reqs_with_new_group, ts) + possibly_accumulate_reqs _ reqs_ts + = state_transition reqs_ts + +// ..MW4 makeBase _ _ [] [] ts_var_heap = ts_var_heap makeBase fun_or_cons_ident arg_nr [{fv_name, fv_info_ptr}:vars] [type:types] ts_var_heap @@ -1524,8 +1624,7 @@ where # (start_index, predef_symbols) = get_index_of_start_rule predef_symbols # (fun_defs, predef_symbols, cons_variables, ts) = CreateInitialSymbolTypes start_index ti_common_defs comp (fun_defs, predef_symbols, [], ts) (fun_reqs, (cons_variables, fun_defs, ts)) = type_functions comp ti cons_variables fun_defs ts - #! nr_of_type_variables = ts.ts_var_store - + #! nr_of_type_variables = ts.ts_var_store # (subst, ts_type_heaps, ts_error) = unify_requirements_of_functions fun_reqs ti (createArray nr_of_type_variables TE) ts.ts_type_heaps ts.ts_error | not ts_error.ea_ok //---> (("begin\n" ---> subst.[2]) ---> "\nend") @@ -1582,6 +1681,7 @@ where { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True }, ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap }, ts_fun_env = ts_fun_env}) +/* MW4 was unify_requirements_of_functions :: ![FunctionRequirements] !TypeInput !*{!Type} !*TypeHeaps !*ErrorAdmin -> (!*{!Type},!*TypeHeaps,!*ErrorAdmin) unify_requirements_of_functions [{fe_requirements={req_type_coercions},fe_location} : reqs_list] modules subst heaps ts_error # ts_error = setErrorAdmin fe_location ts_error @@ -1589,6 +1689,21 @@ where = unify_requirements_of_functions reqs_list modules subst heaps ts_error unify_requirements_of_functions [] modules subst heaps ts_error = (subst, heaps, ts_error) +*/ + unify_requirements_of_functions :: ![FunctionRequirements] !TypeInput !*{!Type} !*TypeHeaps !*ErrorAdmin -> (!*{!Type},!*TypeHeaps,!*ErrorAdmin) + unify_requirements_of_functions [{fe_requirements={req_type_coercion_groups},fe_location={ip_ident}} : reqs_list] ti subst heaps ts_error + # (subst, heaps, ts_error) = foldSt (unify_requirements_of_alternative ip_ident ti) req_type_coercion_groups (subst, heaps, ts_error) + = unify_requirements_of_functions reqs_list ti subst heaps ts_error + unify_requirements_of_functions [] ti subst heaps ts_error + = (subst, heaps, ts_error) + +// MW4 added.. + unify_requirements_of_alternative :: !Ident !TypeInput !TypeCoercionGroup !(*{!Type}, !*TypeHeaps, !*ErrorAdmin) + -> (*{!Type}, !*TypeHeaps, !*ErrorAdmin) + unify_requirements_of_alternative fun_symb ti {tcg_type_coercions, tcg_position} (subst, heaps, ts_error) + # ts_error = setErrorAdmin (newPosition fun_symb tcg_position) ts_error + = unify_coercions tcg_type_coercions ti subst heaps ts_error +// ..MW4 build_initial_coercion_env [{fe_requirements={req_attr_coercions},fe_location} : reqs_list] coercion_env = build_initial_coercion_env reqs_list (add_to_initial_coercion_env req_attr_coercions coercion_env) @@ -1618,6 +1733,7 @@ where (prev_vect, bitvects) = bitvects![bit_index] = { bitvects & [bit_index] = prev_vect bitor (1 << BITNUMBER var_number) } +/* MW4 was build_coercion_env [{fe_requirements={req_type_coercions},fe_location} : reqs_list] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error # error = setErrorAdmin fe_location error (subst, coercion_env, type_signs, type_var_heap, error) @@ -1625,6 +1741,22 @@ where = build_coercion_env reqs_list subst coercion_env common_defs cons_var_vects type_signs type_var_heap error build_coercion_env [] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error = (subst, coercion_env, type_signs, type_var_heap, error) +*/ + build_coercion_env [{fe_requirements={req_type_coercion_groups},fe_location={ip_ident}} : reqs_list] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error + # (subst, coercion_env, type_signs, type_var_heap, error) + = foldSt (build_coercion_env_for_alternative ip_ident common_defs cons_var_vects) + req_type_coercion_groups + (subst, coercion_env, type_signs, type_var_heap, error) + = build_coercion_env reqs_list subst coercion_env common_defs cons_var_vects type_signs type_var_heap error + build_coercion_env [] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error + = (subst, coercion_env, type_signs, type_var_heap, error) + +// MW4 added.. + build_coercion_env_for_alternative fun_symb common_defs cons_var_vects {tcg_position, tcg_type_coercions} + (subst, coercion_env, type_signs, type_var_heap, error) + # error = setErrorAdmin (newPosition fun_symb tcg_position) error + = add_to_coercion_env tcg_type_coercions subst coercion_env common_defs cons_var_vects type_signs type_var_heap error +// MW4 add_to_coercion_env [{tc_offered,tc_demanded,tc_coercible,tc_position} : attr_coercions] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error # (subst, coercion_env, type_signs, type_var_heap, error) @@ -1714,15 +1846,21 @@ where ts_var_heap = makeBase fun_symb 1 tb_args temp_fun_type.tst_args ts_var_heap fe_location = newPosition fun_symb fun_pos ts_error = setErrorAdmin fe_location ts_error - reqs = { req_overloaded_calls = [], req_type_coercions = [], req_attr_coercions = [], req_case_and_let_exprs = [], req_cons_variables = cons_variables } +// MW4 was: reqs = { req_overloaded_calls = [], req_type_coercions = [], req_attr_coercions = [], req_case_and_let_exprs = [], req_cons_variables = cons_variables } + reqs = { req_overloaded_calls = [], req_type_coercion_groups = [], req_type_coercions = [], + req_attr_coercions = [], req_case_and_let_exprs = [], req_cons_variables = cons_variables } ( rhs_type, rhs_expr_ptr, (rhs_reqs, ts)) = requirements ti tb_rhs (reqs, { ts & ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_error = ts_error, ts_fun_env = ts_fun_env }) 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_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_coercion_group_from_accu = { tcg_type_coercions = req_type_coercions, tcg_position = fun_pos } + req_type_coercion_groups = [type_coercion_group_from_accu:rhs_reqs.req_type_coercion_groups] + = ( { fe_location = fe_location, fe_context = if (has_option fun_type) (Yes temp_fun_type.tst_context) No, fe_index = fun_index, +// MW4 was: fe_requirements = { rhs_reqs & req_type_coercions = req_type_coercions, req_cons_variables = [] }}, (rhs_reqs.req_cons_variables, fun_defs, + fe_requirements = { rhs_reqs & req_type_coercions = [], req_type_coercion_groups = req_type_coercion_groups, 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) where has_option (Yes _) = True |