diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 19 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 42 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 61 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/trans.c | 9 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 3 |
6 files changed, 71 insertions, 65 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 83ad8cd..bf28737 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,22 @@ +2009-05-10 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/38863 + * trans-expr.c (gfc_conv_operator_assign): Remove function. + * trans.h : Remove prototype for gfc_conv_operator_assign. + * trans-stmt.c (gfc_conv_elemental_dependencies): Initialize + derivde types with intent(out). + (gfc_trans_call): Add mask, count1 and invert arguments. Add + code to use mask for WHERE assignments. + (gfc_trans_forall_1): Use new arguments for gfc_trans_call. + (gfc_trans_where_assign): The gfc_symbol argument is replaced + by the corresponding code. If this has a resolved_sym, then + gfc_trans_call is called. The call to gfc_conv_operator_assign + is removed. + (gfc_trans_where_2): Change the last argument in the call to + gfc_trans_where_assign. + * trans-stmt.h : Modify prototype for gfc_trans_call. + * trans.c (gfc_trans_code): Use new args for gfc_trans_call. + 2009-05-08 Janus Weil <janus@gcc.gnu.org> PR fortran/39876 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 280a192..14f64c9 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1529,48 +1529,6 @@ conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr) } -/* Translate the call for an elemental subroutine call used in an operator - assignment. This is a simplified version of gfc_conv_procedure_call. */ - -tree -gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym) -{ - tree args; - tree tmp; - gfc_se se; - stmtblock_t block; - - /* Only elemental subroutines with two arguments. */ - gcc_assert (sym->attr.elemental && sym->attr.subroutine); - gcc_assert (sym->formal->next->next == NULL); - - gfc_init_block (&block); - - gfc_add_block_to_block (&block, &lse->pre); - gfc_add_block_to_block (&block, &rse->pre); - - /* Build the argument list for the call, including hidden string lengths. */ - args = gfc_chainon_list (NULL_TREE, gfc_build_addr_expr (NULL_TREE, lse->expr)); - args = gfc_chainon_list (args, gfc_build_addr_expr (NULL_TREE, rse->expr)); - if (lse->string_length != NULL_TREE) - args = gfc_chainon_list (args, lse->string_length); - if (rse->string_length != NULL_TREE) - args = gfc_chainon_list (args, rse->string_length); - - /* Build the function call. */ - gfc_init_se (&se, NULL); - conv_function_val (&se, sym, NULL); - tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr))); - tmp = build_call_list (tmp, se.expr, args); - gfc_add_expr_to_block (&block, tmp); - - gfc_add_block_to_block (&block, &lse->post); - gfc_add_block_to_block (&block, &rse->post); - - return gfc_finish_block (&block); -} - - /* Initialize MAPPING. */ void diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index d695759..9bad071 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -270,9 +270,11 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e)); gfc_add_block_to_block (&se->pre, &parmse.pre); - /* If we've got INTENT(INOUT), initialize the array temporary with - a copy of the values. */ - if (fsym->attr.intent == INTENT_INOUT) + /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT), + initialize the array temporary with a copy of the values. */ + if (fsym->attr.intent == INTENT_INOUT + || (fsym->ts.type ==BT_DERIVED + && fsym->attr.intent == INTENT_OUT)) initial = parmse.expr; else initial = NULL_TREE; @@ -332,12 +334,16 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, /* Translate the CALL statement. Builds a call to an F95 subroutine. */ tree -gfc_trans_call (gfc_code * code, bool dependency_check) +gfc_trans_call (gfc_code * code, bool dependency_check, + tree mask, tree count1, bool invert) { gfc_se se; gfc_ss * ss; int has_alternate_specifier; gfc_dep_check check_variable; + tree index = NULL_TREE; + tree maskexpr = NULL_TREE; + tree tmp; /* A CALL starts a new block because the actual arguments may have to be evaluated first. */ @@ -429,10 +435,32 @@ gfc_trans_call (gfc_code * code, bool dependency_check) gfc_start_scalarized_body (&loop, &body); gfc_init_block (&block); + if (mask && count1) + { + /* Form the mask expression according to the mask. */ + index = count1; + maskexpr = gfc_build_array_ref (mask, index, NULL); + if (invert) + maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), + maskexpr); + } + /* Add the subroutine call to the block. */ - gfc_conv_procedure_call (&loopse, code->resolved_sym, code->ext.actual, - code->expr, NULL_TREE); - gfc_add_expr_to_block (&loopse.pre, loopse.expr); + gfc_conv_procedure_call (&loopse, code->resolved_sym, + code->ext.actual, code->expr, + NULL_TREE); + + if (mask && count1) + { + tmp = build3_v (COND_EXPR, maskexpr, loopse.expr, + build_empty_stmt ()); + gfc_add_expr_to_block (&loopse.pre, tmp); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, + count1, gfc_index_one_node); + gfc_add_modify (&loopse.pre, count1, tmp); + } + else + gfc_add_expr_to_block (&loopse.pre, loopse.expr); gfc_add_block_to_block (&block, &loopse.pre); gfc_add_block_to_block (&block, &loopse.post); @@ -3028,7 +3056,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) /* Explicit subroutine calls are prevented by the frontend but interface assignments can legitimately produce them. */ case EXEC_ASSIGN_CALL: - assign = gfc_trans_call (c, true); + assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false); tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1); gfc_add_expr_to_block (&block, tmp); break; @@ -3223,7 +3251,7 @@ static tree gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask, bool invert, tree count1, tree count2, - gfc_symbol *sym) + gfc_code *cnext) { gfc_se lse; gfc_se rse; @@ -3237,6 +3265,10 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, stmtblock_t body; tree index, maskexpr; + /* A defined assignment. */ + if (cnext && cnext->resolved_sym) + return gfc_trans_call (cnext, true, mask, count1, invert); + #if 0 /* TODO: handle this special case. Special case a single function returning an array. */ @@ -3338,11 +3370,8 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr); /* Use the scalar assignment as is. */ - if (sym == NULL) - tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, - loop.temp_ss != NULL, false); - else - tmp = gfc_conv_operator_assign (&lse, &rse, sym); + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, + loop.temp_ss != NULL, false); tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); @@ -3609,7 +3638,7 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, tmp = gfc_trans_where_assign (expr1, expr2, cmask, invert, count1, count2, - cnext->resolved_sym); + cnext); tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); @@ -3627,7 +3656,7 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, tmp = gfc_trans_where_assign (expr1, expr2, cmask, invert, count1, count2, - cnext->resolved_sym); + cnext); gfc_add_expr_to_block (block, tmp); } diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index ff8a838..0b167b9 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -40,7 +40,7 @@ tree gfc_trans_goto (gfc_code *); tree gfc_trans_entry (gfc_code *); tree gfc_trans_pause (gfc_code *); tree gfc_trans_stop (gfc_code *); -tree gfc_trans_call (gfc_code *, bool); +tree gfc_trans_call (gfc_code *, bool, tree, tree, bool); tree gfc_trans_return (gfc_code *); tree gfc_trans_if (gfc_code *); tree gfc_trans_arithmetic_if (gfc_code *); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 54d40d7..28cb60a 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1111,16 +1111,19 @@ gfc_trans_code (gfc_code * code) if (code->resolved_isym && code->resolved_isym->id == GFC_ISYM_MVBITS) is_mvbits = true; - res = gfc_trans_call (code, is_mvbits); + res = gfc_trans_call (code, is_mvbits, NULL_TREE, + NULL_TREE, false); } break; case EXEC_CALL_PPC: - res = gfc_trans_call (code, false); + res = gfc_trans_call (code, false, NULL_TREE, + NULL_TREE, false); break; case EXEC_ASSIGN_CALL: - res = gfc_trans_call (code, true); + res = gfc_trans_call (code, true, NULL_TREE, + NULL_TREE, false); break; case EXEC_RETURN: diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index c75f40e..4846af2 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -310,9 +310,6 @@ void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *); /* Does an intrinsic map directly to an external library call. */ int gfc_is_intrinsic_libcall (gfc_expr *); -/* Used to call the elemental subroutines used in operator assignments. */ -tree gfc_conv_operator_assign (gfc_se *, gfc_se *, gfc_symbol *); - /* Used to call ordinary functions/subroutines and procedure pointer components. */ int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *, |