diff options
Diffstat (limited to 'gcc/fortran/trans-intrinsic.c')
-rw-r--r-- | gcc/fortran/trans-intrinsic.c | 179 |
1 files changed, 149 insertions, 30 deletions
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 40a7491..473334e 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -4359,6 +4359,28 @@ enter_nested_loop (gfc_se *se) return se->ss->loop; } +/* Build the condition for a mask, which may be optional. */ + +static tree +conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr, + bool optional_mask) +{ + tree present; + tree type; + + if (optional_mask) + { + type = TREE_TYPE (maskse->expr); + present = gfc_conv_expr_present (maskexpr->symtree->n.sym); + present = convert (type, present); + present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type, + present); + return fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + type, present, maskse->expr); + } + else + return maskse->expr; +} /* Inline implementation of the sum and product intrinsics. */ static void @@ -4380,6 +4402,7 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, gfc_se *parent_se; gfc_expr *arrayexpr; gfc_expr *maskexpr; + bool optional_mask; if (expr->rank > 0) { @@ -4419,13 +4442,19 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, arrayexpr = arg_array->expr; if (op == NE_EXPR || norm2) - /* PARITY and NORM2. */ - maskexpr = NULL; + { + /* PARITY and NORM2. */ + maskexpr = NULL; + optional_mask = false; + } else { arg_mask = arg_array->next->next; gcc_assert (arg_mask != NULL); maskexpr = arg_mask->expr; + optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional; } if (expr->rank == 0) @@ -4444,17 +4473,22 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, arrayss); + + /* We add the mask first because the number of iterations is + taken from the last ss, and this breaks if an absent + optional argument is used for mask. */ + if (maskexpr && maskexpr->rank > 0) gfc_add_ss_to_loop (&loop, maskss); + gfc_add_ss_to_loop (&loop, arrayss); /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); gfc_conv_loop_setup (&loop, &expr->where); - gfc_mark_ss_chain_used (arrayss, 1); if (maskexpr && maskexpr->rank > 0) gfc_mark_ss_chain_used (maskss, 1); + gfc_mark_ss_chain_used (arrayss, 1); ploop = &loop; } @@ -4563,10 +4597,13 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, if (maskexpr && maskexpr->rank > 0) { - /* We enclose the above in if (mask) {...} . */ - + /* We enclose the above in if (mask) {...} . If the mask is an + optional argument, generate + IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */ + tree ifmask; tmp = gfc_finish_block (&block); - tmp = build3_v (COND_EXPR, maskse.expr, tmp, + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, build_empty_stmt (input_location)); } else @@ -4591,10 +4628,13 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, } else { + tree ifmask; + gcc_assert (expr->rank == 0); gfc_init_se (&maskse, NULL); gfc_conv_expr_val (&maskse, maskexpr); - tmp = build3_v (COND_EXPR, maskse.expr, tmp, + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, build_empty_stmt (input_location)); } @@ -4833,6 +4873,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_se backse; tree pos; int n; + bool optional_mask; actual = expr->value.function.actual; @@ -4887,6 +4928,9 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) actual = actual->next->next; gcc_assert (actual); maskexpr = actual->expr; + optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional; backexpr = actual->next->next->expr; nonempty = NULL; if (maskexpr && maskexpr->rank != 0) @@ -4939,10 +4983,16 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, arrayss); + + /* We add the mask first because the number of iterations is taken + from the last ss, and this breaks if an absent optional argument + is used for mask. */ + if (maskss) gfc_add_ss_to_loop (&loop, maskss); + gfc_add_ss_to_loop (&loop, arrayss); + /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); @@ -5103,10 +5153,14 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) if (maskss) { - /* We enclose the above in if (mask) {...}. */ - tmp = gfc_finish_block (&block); + /* We enclose the above in if (mask) {...}. If the mask is an + optional argument, generate IF (.NOT. PRESENT(MASK) + .OR. MASK(I)). */ - tmp = build3_v (COND_EXPR, maskse.expr, tmp, + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = gfc_finish_block (&block); + tmp = build3_v (COND_EXPR, ifmask, tmp, build_empty_stmt (input_location)); } else @@ -5197,10 +5251,14 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) if (maskss) { - /* We enclose the above in if (mask) {...}. */ - tmp = gfc_finish_block (&block); + /* We enclose the above in if (mask) {...}. If the mask is + an optional argument, generate IF (.NOT. PRESENT(MASK) + .OR. MASK(I)).*/ - tmp = build3_v (COND_EXPR, maskse.expr, tmp, + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = gfc_finish_block (&block); + tmp = build3_v (COND_EXPR, ifmask, tmp, build_empty_stmt (input_location)); } else @@ -5219,6 +5277,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* For a scalar mask, enclose the loop in an if statement. */ if (maskexpr && maskss == NULL) { + tree ifmask; + gfc_init_se (&maskse, NULL); gfc_conv_expr_val (&maskse, maskexpr); gfc_init_block (&block); @@ -5232,8 +5292,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_init_block (&elseblock); gfc_add_modify (&elseblock, pos, gfc_index_zero_node); elsetmp = gfc_finish_block (&elseblock); - - tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp); + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&se->pre, &block); } @@ -5276,6 +5336,7 @@ gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr) gfc_expr *maskexpr; tree offset; int i; + bool optional_mask; array_arg = expr->value.function.actual; value_arg = array_arg->next; @@ -5326,6 +5387,9 @@ gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr) offset = gfc_create_var (gfc_array_index_type, "offset"); maskexpr = mask_arg->expr; + optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional; /* Generate two loops, one for BACK=.true. and one for BACK=.false. */ @@ -5347,9 +5411,14 @@ gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr) gfc_init_loopinfo (&loop); exit_label = gfc_build_label_decl (NULL_TREE); TREE_USED (exit_label) = 1; - gfc_add_ss_to_loop (&loop, arrayss); + + /* We add the mask first because the number of iterations is + taken from the last ss, and this breaks if an absent + optional argument is used for mask. */ + if (maskss) gfc_add_ss_to_loop (&loop, maskss); + gfc_add_ss_to_loop (&loop, arrayss); /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); @@ -5412,8 +5481,16 @@ gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr) tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location)); if (maskss) - tmp = build3_v (COND_EXPR, maskse.expr, tmp, - build_empty_stmt (input_location)); + { + /* We enclose the above in if (mask) {...}. If the mask is + an optional argument, generate IF (.NOT. PRESENT(MASK) + .OR. MASK(I)). */ + + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, + build_empty_stmt (input_location)); + } gfc_add_expr_to_block (&body, tmp); gfc_add_block_to_block (&body, &arrayse.post); @@ -5444,12 +5521,15 @@ gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr) /* For a scalar mask, enclose the loop in an if statement. */ if (maskexpr && maskss == NULL) { + tree ifmask; tree if_stmt; + gfc_init_se (&maskse, NULL); gfc_conv_expr_val (&maskse, maskexpr); gfc_init_block (&block); gfc_add_expr_to_block (&block, maskse.expr); - if_stmt = build3_v (COND_EXPR, maskse.expr, tmp, + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + if_stmt = build3_v (COND_EXPR, ifmask, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, if_stmt); tmp = gfc_finish_block (&block); @@ -5576,6 +5656,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_expr *arrayexpr; gfc_expr *maskexpr; int n; + bool optional_mask; if (se->ss) { @@ -5665,6 +5746,9 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) actual = actual->next->next; gcc_assert (actual); maskexpr = actual->expr; + optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional; nonempty = NULL; if (maskexpr && maskexpr->rank != 0) { @@ -5687,9 +5771,14 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, arrayss); + + /* We add the mask first because the number of iterations is taken + from the last ss, and this breaks if an absent optional argument + is used for mask. */ + if (maskss) gfc_add_ss_to_loop (&loop, maskss); + gfc_add_ss_to_loop (&loop, arrayss); /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); @@ -5832,9 +5921,15 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) tmp = gfc_finish_block (&block); if (maskss) - /* We enclose the above in if (mask) {...}. */ - tmp = build3_v (COND_EXPR, maskse.expr, tmp, - build_empty_stmt (input_location)); + { + /* We enclose the above in if (mask) {...}. If the mask is an + optional argument, generate IF (.NOT. PRESENT(MASK) + .OR. MASK(I)). */ + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, + build_empty_stmt (input_location)); + } gfc_add_expr_to_block (&body, tmp); if (lab) @@ -5891,8 +5986,13 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) tmp = gfc_finish_block (&block); if (maskss) /* We enclose the above in if (mask) {...}. */ - tmp = build3_v (COND_EXPR, maskse.expr, tmp, - build_empty_stmt (input_location)); + { + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, + build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (&body, tmp); /* Avoid initializing loopvar[0] again, it should be left where it finished by the first loop. */ @@ -5920,6 +6020,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) if (maskexpr && maskss == NULL) { tree else_stmt; + tree ifmask; gfc_init_se (&maskse, NULL); gfc_conv_expr_val (&maskse, maskexpr); @@ -5932,7 +6033,9 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst); else else_stmt = build_empty_stmt (input_location); - tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt); + + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&se->pre, &block); } @@ -10177,7 +10280,8 @@ gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr) bool gfc_inline_intrinsic_function_p (gfc_expr *expr) { - gfc_actual_arglist *args; + gfc_actual_arglist *args, *dim_arg, *mask_arg; + gfc_expr *maskexpr; if (!expr->value.function.isym) return false; @@ -10191,10 +10295,25 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr) return false; args = expr->value.function.actual; + dim_arg = args->next; + /* We need to be able to subset the SUM argument at compile-time. */ - if (args->next->expr && args->next->expr->expr_type != EXPR_CONSTANT) + if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT) return false; + /* FIXME: If MASK is optional for a more than two-dimensional + argument, the scalarizer gets confused if the mask is + absent. See PR 82995. For now, fall back to the library + function. */ + + mask_arg = dim_arg->next; + maskexpr = mask_arg->expr; + + if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional) + return false; + return true; case GFC_ISYM_TRANSPOSE: |