aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog15
-rw-r--r--gcc/fortran/resolve.c14
-rw-r--r--gcc/fortran/trans-expr.c42
-rw-r--r--gcc/fortran/trans-stmt.c36
-rw-r--r--gcc/fortran/trans.h3
5 files changed, 104 insertions, 6 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c81de30..75aa23f 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2007-01-27 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/30407
+ * trans-expr.c (gfc_conv_operator_assign): New function.
+ * trans.h : Add prototype for gfc_conv_operator_assign.
+ * trans-stmt.c (gfc_trans_where_assign): Add a gfc_symbol for
+ a potential operator assignment subroutine. If it is non-NULL
+ call gfc_conv_operator_assign instead of the first assignment.
+ ( gfc_trans_where_2): In the case of an operator assignment,
+ extract the argument expressions from the code for the
+ subroutine call and pass the symbol to gfc_trans_where_assign.
+ resolve.c (resolve_where, gfc_resolve_where_code_in_forall,
+ gfc_resolve_forall_body): Resolve the subroutine call for
+ operator assignments.
+
2007-01-26 Steven Bosscher <stevenb.gcc@gmail.com>
Steven G. Kargl <kargl@gcc.gnu.org>
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 526be48..9a06a98 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4550,6 +4550,11 @@ resolve_where (gfc_code *code, gfc_expr *mask)
"inconsistent shape", &cnext->expr->where);
break;
+
+ case EXEC_ASSIGN_CALL:
+ resolve_call (cnext);
+ break;
+
/* WHERE or WHERE construct is part of a where-body-construct */
case EXEC_WHERE:
resolve_where (cnext, e);
@@ -4750,6 +4755,11 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
case EXEC_ASSIGN:
gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
break;
+
+ /* WHERE operator assignment statement */
+ case EXEC_ASSIGN_CALL:
+ resolve_call (cnext);
+ break;
/* WHERE or WHERE construct is part of a where-body-construct */
case EXEC_WHERE:
@@ -4789,6 +4799,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
gfc_resolve_assign_in_forall (c, nvar, var_expr);
break;
+ case EXEC_ASSIGN_CALL:
+ resolve_call (c);
+ break;
+
/* Because the gfc_resolve_blocks() will handle the nested FORALL,
there is no need to handle it here. */
case EXEC_FORALL:
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 2dc78b6..487b6a7 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1249,6 +1249,48 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
}
+/* Translate the call for an elemental subroutine call used in an operator
+ assignment. This is a simplified version of gfc_conv_function_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, build_fold_addr_expr (lse->expr));
+ args = gfc_chainon_list (args, build_fold_addr_expr (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);
+ gfc_conv_function_val (&se, sym);
+ tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
+ tmp = build3 (CALL_EXPR, tmp, se.expr, args, NULL_TREE);
+ 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 47a846e..6640cf7 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -2878,7 +2878,8 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
static tree
gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
tree mask, bool invert,
- tree count1, tree count2)
+ tree count1, tree count2,
+ gfc_symbol *sym)
{
gfc_se lse;
gfc_se rse;
@@ -2992,8 +2993,12 @@ 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. */
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
- loop.temp_ss != NULL, false);
+ 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 = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
@@ -3102,6 +3107,7 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
tree ppmask = NULL_TREE;
tree cmask = NULL_TREE;
tree pmask = NULL_TREE;
+ gfc_actual_arglist *arg;
/* the WHERE statement or the WHERE construct statement. */
cblock = code->block;
@@ -3213,13 +3219,29 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
switch (cnext->op)
{
/* WHERE assignment statement. */
+ case EXEC_ASSIGN_CALL:
+
+ arg = cnext->ext.actual;
+ expr1 = expr2 = NULL;
+ for (; arg; arg = arg->next)
+ {
+ if (!arg->expr)
+ continue;
+ if (expr1 == NULL)
+ expr1 = arg->expr;
+ else
+ expr2 = arg->expr;
+ }
+ goto evaluate;
+
case EXEC_ASSIGN:
expr1 = cnext->expr;
expr2 = cnext->expr2;
+ evaluate:
if (nested_forall_info != NULL)
{
need_temp = gfc_check_dependency (expr1, expr2, 0);
- if (need_temp)
+ if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
gfc_trans_assign_need_temp (expr1, expr2,
cmask, invert,
nested_forall_info, block);
@@ -3233,7 +3255,8 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
- count1, count2);
+ count1, count2,
+ cnext->resolved_sym);
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
tmp, 1);
@@ -3250,7 +3273,8 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
tmp = gfc_trans_where_assign (expr1, expr2,
cmask, invert,
- count1, count2);
+ count1, count2,
+ cnext->resolved_sym);
gfc_add_expr_to_block (block, tmp);
}
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index d16a5df..a3b6f04 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -303,6 +303,9 @@ 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 *);
+
/* Also used to CALL subroutines. */
int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
tree);
generated by cgit v1.1 at 2025-04-25 23:56:13 +0000