@@ -5472,12 +5472,14 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
tree lab1, lab2;
tree b_if, b_else;
tree back;
- gfc_loopinfo loop;
- gfc_actual_arglist *actual;
- gfc_ss *arrayss;
- gfc_ss *maskss;
+ gfc_loopinfo loop, *ploop;
+ gfc_actual_arglist *actual, *array_arg, *dim_arg, *mask_arg, *kind_arg;
+ gfc_actual_arglist *back_arg;
+ gfc_ss *arrayss = nullptr;
+ gfc_ss *maskss = nullptr;
gfc_se arrayse;
gfc_se maskse;
+ gfc_se *base_se;
gfc_expr *arrayexpr;
gfc_expr *maskexpr;
gfc_expr *backexpr;
@@ -5489,6 +5491,14 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
bool optional_mask;
actual = expr->value.function.actual;
+ array_arg = actual;
+ dim_arg = array_arg->next;
+ mask_arg = dim_arg->next;
+ kind_arg = mask_arg->next;
+ back_arg = kind_arg->next;
+
+ bool dim_present = dim_arg->expr != nullptr;
+ bool nested_loop = dim_present && expr->rank > 0;
/* The last argument, BACK, is passed by value. Ensure that
by setting its name to %VAL. */
@@ -5502,11 +5512,15 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
if (se->ss->info->useflags)
{
- /* The inline implementation of MINLOC/MAXLOC has been generated
- before, out of the scalarization loop; now we can just use the
- result. */
- gfc_conv_tmp_array_ref (se);
- return;
+ if (!dim_present || !gfc_inline_intrinsic_function_p (expr))
+ {
+ /* The code generating and initializing the result array has been
+ generated already before the scalarization loop, either with a
+ library function call or with inline code; now we can just use
+ the result. */
+ gfc_conv_tmp_array_ref (se);
+ return;
+ }
}
else if (!gfc_inline_intrinsic_function_p (expr))
{
@@ -5522,8 +5536,9 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
if (arrayexpr->ts.type == BT_CHARACTER)
{
- gfc_actual_arglist *a;
- a = actual;
+ gcc_assert (expr->rank == 0);
+
+ gfc_actual_arglist *a = actual;
strip_kind_from_actual (a);
while (a)
{
@@ -5540,7 +5555,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
type = gfc_typenode_for_spec (&expr->ts);
- if (expr->rank > 0)
+ if (expr->rank > 0 && !dim_present)
{
gfc_array_spec as;
memset (&as, 0, sizeof (as));
@@ -5558,8 +5573,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
result_var = gfc_create_var (array, "loc_result");
}
+ const int reduction_dimensions = dim_present ? 1 : arrayexpr->rank;
+
/* Initialize the result. */
- for (int i = 0; i < arrayexpr->rank; i++)
+ for (int i = 0; i < reduction_dimensions; i++)
{
pos[i] = gfc_create_var (gfc_array_index_type,
gfc_get_string ("pos%d", i));
@@ -5569,17 +5586,11 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
gfc_get_string ("idx%d", i));
}
- /* Walk the arguments. */
- arrayss = gfc_walk_expr (arrayexpr);
- gcc_assert (arrayss != gfc_ss_terminator);
-
- actual = actual->next->next;
- gcc_assert (actual);
- maskexpr = actual->expr;
+ maskexpr = mask_arg->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;
+ backexpr = back_arg->expr;
gfc_init_se (&backse, NULL);
if (backexpr == nullptr)
@@ -5604,13 +5615,25 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
back = gfc_evaluate_now_loc (input_location, back, &se->pre);
gfc_add_block_to_block (&se->pre, &backse.post);
- nonempty = NULL;
- if (maskexpr && maskexpr->rank != 0)
- {
- maskss = gfc_walk_expr (maskexpr);
- gcc_assert (maskss != gfc_ss_terminator);
- }
+ if (nested_loop)
+ base_se = se;
else
+ {
+ /* Walk the arguments. */
+ arrayss = gfc_walk_expr (arrayexpr);
+ gcc_assert (arrayss != gfc_ss_terminator);
+
+ if (maskexpr && maskexpr->rank != 0)
+ {
+ maskss = gfc_walk_expr (maskexpr);
+ gcc_assert (maskss != gfc_ss_terminator);
+ }
+
+ base_se = nullptr;
+ }
+
+ nonempty = nullptr;
+ if (!(maskexpr && maskexpr->rank > 0))
{
mpz_t asize;
if (gfc_array_size (arrayexpr, &asize))
@@ -5681,47 +5704,59 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
"second_loop_entry");
gfc_add_modify (&se->pre, second_loop_entry, logical_false_node);
- /* Initialize the scalarizer. */
- gfc_init_loopinfo (&loop);
+ if (nested_loop)
+ {
+ ploop = enter_nested_loop (se);
+ ploop->temp_dim = 1;
+ }
+ else
+ {
+ /* Initialize the scalarizer. */
+ gfc_init_loopinfo (&loop);
- /* 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. */
+ /* 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);
+ if (maskss)
+ gfc_add_ss_to_loop (&loop, maskss);
- gfc_add_ss_to_loop (&loop, arrayss);
+ gfc_add_ss_to_loop (&loop, arrayss);
- /* Initialize the loop. */
- gfc_conv_ss_startstride (&loop);
+ /* Initialize the loop. */
+ gfc_conv_ss_startstride (&loop);
- /* The code generated can have more than one loop in sequence (see the
- comment at the function header). This doesn't work well with the
- scalarizer, which changes arrays' offset when the scalarization loops
- are generated (see gfc_trans_preloop_setup). Fortunately, we can use
- the scalarizer temporary code to handle multiple loops. Thus, we set
- temp_dim here, we call gfc_mark_ss_chain_used with flag=3 later, and
- we use gfc_trans_scalarized_loop_boundary even later to restore
- offset. */
- loop.temp_dim = loop.dimen;
- gfc_conv_loop_setup (&loop, &expr->where);
+ /* The code generated can have more than one loop in sequence (see the
+ comment at the function header). This doesn't work well with the
+ scalarizer, which changes arrays' offset when the scalarization loops
+ are generated (see gfc_trans_preloop_setup). Fortunately, we can use
+ the scalarizer temporary code to handle multiple loops. Thus, we set
+ temp_dim here, we call gfc_mark_ss_chain_used with flag=3 later, and
+ we use gfc_trans_scalarized_loop_boundary even later to restore
+ offset. */
+ loop.temp_dim = loop.dimen;
+ gfc_conv_loop_setup (&loop, &expr->where);
+
+ ploop = &loop;
+ }
+
+ gcc_assert (reduction_dimensions == ploop->dimen);
if (nonempty == NULL && maskss == NULL)
{
nonempty = logical_true_node;
- for (int i = 0; i < loop.dimen; i++)
+ for (int i = 0; i < ploop->dimen; i++)
{
- if (!(loop.from[i] && loop.to[i]))
+ if (!(ploop->from[i] && ploop->to[i]))
{
nonempty = NULL;
break;
}
tree tmp = fold_build2_loc (input_location, LE_EXPR,
- logical_type_node, loop.from[i],
- loop.to[i]);
+ logical_type_node, ploop->from[i],
+ ploop->to[i]);
nonempty = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
logical_type_node, nonempty, tmp);
@@ -5741,11 +5776,12 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
gfc_array_index_type, nonempty,
gfc_index_one_node,
gfc_index_zero_node);
- for (int i = 0; i < loop.dimen; i++)
- gfc_add_modify (&loop.pre, pos[i], init);
+ for (int i = 0; i < ploop->dimen; i++)
+ gfc_add_modify (&ploop->pre, pos[i], init);
}
else
{
+ gcc_assert (!nested_loop);
for (int i = 0; i < loop.dimen; i++)
gfc_add_modify (&loop.pre, pos[i], gfc_index_zero_node);
lab1 = gfc_build_label_decl (NULL_TREE);
@@ -5756,24 +5792,29 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
/* An offset must be added to the loop
counter to obtain the required position. */
- for (int i = 0; i < loop.dimen; i++)
+ for (int i = 0; i < ploop->dimen; i++)
{
- gcc_assert (loop.from[i]);
+ gcc_assert (ploop->from[i]);
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, loop.from[i]);
- gfc_add_modify (&loop.pre, offset[i], tmp);
+ gfc_index_one_node, ploop->from[i]);
+ gfc_add_modify (&ploop->pre, offset[i], tmp);
+ }
+
+ if (!nested_loop)
+ {
+ gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
+ if (maskss)
+ gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
}
- gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
- if (maskss)
- gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
/* Generate the loop body. */
- gfc_start_scalarized_body (&loop, &body);
+ gfc_start_scalarized_body (ploop, &body);
/* If we have a mask, only check this element if the mask is set. */
if (maskss)
{
+ gcc_assert (!nested_loop);
gfc_init_se (&maskse, NULL);
gfc_copy_loopinfo_to_se (&maskse, &loop);
maskse.ss = maskss;
@@ -5786,9 +5827,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
gfc_init_block (&block);
/* Compare with the current limit. */
- gfc_init_se (&arrayse, NULL);
- gfc_copy_loopinfo_to_se (&arrayse, &loop);
- arrayse.ss = arrayss;
+ gfc_init_se (&arrayse, base_se);
+ gfc_copy_loopinfo_to_se (&arrayse, ploop);
+ if (!nested_loop)
+ arrayse.ss = arrayss;
gfc_conv_expr_val (&arrayse, arrayexpr);
gfc_add_block_to_block (&block, &arrayse.pre);
@@ -5803,6 +5845,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
stmtblock_t ifblock2;
tree ifbody2;
+ gcc_assert (!nested_loop);
+
gfc_start_block (&ifblock2);
for (int i = 0; i < loop.dimen; i++)
{
@@ -5819,12 +5863,12 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
gfc_add_expr_to_block (&block, tmp);
}
- for (int i = 0; i < loop.dimen; i++)
+ for (int i = 0; i < ploop->dimen; i++)
{
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
- loop.loopvar[i], offset[i]);
+ ploop->loopvar[i], offset[i]);
gfc_add_modify (&ifblock, pos[i], tmp);
- gfc_add_modify (&ifblock, idx[i], loop.loopvar[i]);
+ gfc_add_modify (&ifblock, idx[i], ploop->loopvar[i]);
}
gfc_add_modify (&ifblock, second_loop_entry, logical_true_node);
@@ -5891,6 +5935,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
if (lab1)
{
+ gcc_assert (!nested_loop);
+
for (int i = 0; i < loop.dimen; i++)
loop.from[i] = fold_build3_loc (input_location, COND_EXPR,
TREE_TYPE (loop.from[i]),
@@ -6007,7 +6053,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
gfc_add_modify (&body, second_loop_entry, logical_false_node);
}
- gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_trans_scalarizing_loops (ploop, &body);
if (lab2)
gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
@@ -6017,6 +6063,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
tree ifmask;
+ gcc_assert (!nested_loop);
+
gfc_init_se (&maskse, NULL);
gfc_conv_expr_val (&maskse, maskexpr);
gfc_add_block_to_block (&se->pre, &maskse.pre);
@@ -6039,12 +6087,14 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
}
else
{
- gfc_add_block_to_block (&se->pre, &loop.pre);
- gfc_add_block_to_block (&se->pre, &loop.post);
+ gfc_add_block_to_block (&se->pre, &ploop->pre);
+ gfc_add_block_to_block (&se->pre, &ploop->post);
}
- gfc_cleanup_loop (&loop);
- if (expr->rank > 0)
+ if (!nested_loop)
+ gfc_cleanup_loop (&loop);
+
+ if (!dim_present)
{
for (int i = 0; i < arrayexpr->rank; i++)
{
@@ -11805,7 +11855,29 @@ walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED)
if (expr->rank == 0)
return ss;
- return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
+ gfc_actual_arglist *array_arg = expr->value.function.actual;
+ gfc_actual_arglist *dim_arg = array_arg->next;
+
+ gfc_expr *array = array_arg->expr;
+ gfc_expr *dim = dim_arg->expr;
+
+ if (dim == nullptr)
+ return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
+
+ gfc_ss *tmp_ss = gfc_ss_terminator;
+
+ gfc_ss *array_ss = gfc_walk_subexpr (tmp_ss, array);
+ gcc_assert (array_ss != tmp_ss);
+
+ tmp_ss = array_ss;
+
+ /* Move the dimension on which we will sum to a separate nested scalarization
+ chain, "hiding" that dimension from the outer scalarization. */
+ int dim_val = mpz_get_si (dim->value.integer);
+ gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val - 1);
+ tail->next = ss;
+
+ return array_ss;
}
@@ -11944,9 +12016,11 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr)
gfc_actual_arglist *array_arg = expr->value.function.actual;
gfc_actual_arglist *dim_arg = array_arg->next;
+ gfc_actual_arglist *mask_arg = dim_arg->next;
gfc_expr *array = array_arg->expr;
gfc_expr *dim = dim_arg->expr;
+ gfc_expr *mask = mask_arg->expr;
if (!(array->ts.type == BT_INTEGER
|| array->ts.type == BT_REAL))
@@ -11958,6 +12032,15 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr)
if (dim == nullptr)
return true;
+ if (dim->expr_type != EXPR_CONSTANT)
+ return false;
+
+ if (array->ts.type != BT_INTEGER)
+ return false;
+
+ if (mask == nullptr)
+ return true;
+
return false;
}
@@ -1,6 +1,6 @@
! { dg-do run }
! { dg-options "-fbounds-check" }
-! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic in dimension 1: is 3, should be 2" }
+! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic in dimension 1: is 3, should be 2|Array bound mismatch for dimension 1 of array 'res' .3/2." }
program main
integer(kind=4), allocatable :: f(:,:)
integer(kind=4) :: res(3)
@@ -10,5 +10,5 @@ program main
res = maxloc(f,dim=1)
write(line,fmt='(80I1)') res
end program main
-! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic in dimension 1: is 3, should be 2" }
+! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic in dimension 1: is 3, should be 2|Array bound mismatch for dimension 1 of array 'res' .3/2." }
@@ -1,6 +1,6 @@
! { dg-do run }
! { dg-options "-fbounds-check" }
-! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic in dimension 1: is 3, should be 2" }
+! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic in dimension 1: is 3, should be 2|Array bound mismatch for dimension 1 of array 'res' .3/2." }
program main
integer(kind=4), allocatable :: f(:,:)
logical, allocatable :: m(:,:)
@@ -12,5 +12,5 @@ program main
res = maxloc(f,dim=1,mask=m)
write(line,fmt='(80I1)') res
end program main
-! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic in dimension 1: is 3, should be 2" }
+! { dg-output "Fortran runtime error: Incorrect extent in return value of MAXLOC intrinsic in dimension 1: is 3, should be 2|Array bound mismatch for dimension 1 of array 'res' .3/2." }
@@ -1,6 +1,6 @@
! { dg-do run }
! { dg-options "-fbounds-check" }
-! { dg-shouldfail "Incorrect extent in MASK argument of MAXLOC intrinsic in dimension 2: is 3, should be 2" }
+! { dg-shouldfail "Incorrect extent in MASK argument of MAXLOC intrinsic in dimension 2: is 3, should be 2|Array bound mismatch for dimension 2 of array 'f' .2/3." }
program main
integer(kind=4), allocatable :: f(:,:)
logical, allocatable :: m(:,:)
@@ -12,5 +12,5 @@ program main
res = maxloc(f,dim=1,mask=m)
write(line,fmt='(80I1)') res
end program main
-! { dg-output "Fortran runtime error: Incorrect extent in MASK argument of MAXLOC intrinsic in dimension 2: is 3, should be 2" }
+! { dg-output "Fortran runtime error: Incorrect extent in MASK argument of MAXLOC intrinsic in dimension 2: is 3, should be 2|Array bound mismatch for dimension 2 of array 'f' .2/3." }
new file mode 100644
@@ -0,0 +1,182 @@
+! { dg-do compile }
+! { dg-additional-options "-O -fdump-tree-original" }
+! { dg-final { scan-tree-dump-not "gfortran_\[sm\]?minloc" "original" } }
+! { dg-final { scan-tree-dump-not "gfortran_\[sm\]?maxloc" "original" } }
+!
+! PR fortran/90608
+! Check that all MINLOC and MAXLOC calls are inlined with optimizations,
+! when ARRAY is of integral type, DIM is a constant, and MASK is absent.
+
+subroutine check_maxloc
+ implicit none
+ integer, parameter :: data60(*) = (/ 2, 5, 4, 6, 0, 9, 3, 5, 4, 4, &
+ 1, 7, 3, 2, 1, 2, 5, 4, 6, 0, &
+ 9, 3, 5, 4, 4, 1, 7, 3, 2, 1, &
+ 2, 5, 4, 6, 0, 9, 3, 5, 4, 4, &
+ 1, 7, 3, 2, 1, 2, 5, 4, 6, 0, &
+ 9, 3, 5, 4, 4, 1, 7, 3, 2, 1 /)
+ integer, parameter :: data1(*) = (/ 2, 3, 2, 3, &
+ 1, 2, 3, 2, &
+ 3, 1, 2, 3, &
+ 2, 3, 1, 2, &
+ 3, 2, 3, 1 /)
+ integer, parameter :: data2(*) = (/ 2, 1, 2, &
+ 3, 2, 3, &
+ 4, 3, 4, &
+ 2, 1, 2, &
+ 1, 2, 1 /)
+ integer, parameter :: data3(*) = (/ 5, 1, 5, &
+ 1, 2, 1, &
+ 2, 1, 2, &
+ 3, 2, 3 /)
+ call check_int_const_shape_rank_3
+ call check_int_const_shape_empty_4
+ call check_int_alloc_rank_3
+ call check_int_alloc_empty_4
+contains
+ subroutine check_int_const_shape_rank_3()
+ integer :: a(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape(data60, shape(a))
+ r = maxloc(a, dim=1)
+ if (any(shape(r) /= (/ 4, 5 /))) error stop 11
+ if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 12
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) error stop 13
+ if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 14
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) error stop 15
+ if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 16
+ end subroutine
+ subroutine check_int_const_shape_empty_4()
+ integer :: a(9,3,0,7)
+ integer, allocatable :: r(:,:,:)
+ a = reshape((/ integer:: /), shape(a))
+ r = maxloc(a, dim=1)
+ if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 21
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 22
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 23
+ if (any(r /= 0)) error stop 24
+ r = maxloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 25
+ end subroutine
+ subroutine check_int_alloc_rank_3()
+ integer, allocatable :: a(:,:,:)
+ integer, allocatable :: r(:,:)
+ allocate(a(3,4,5))
+ a(:,:,:) = reshape(data60, shape(a))
+ r = maxloc(a, dim=1)
+ if (any(shape(r) /= (/ 4, 5 /))) error stop 31
+ if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 32
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) error stop 33
+ if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 34
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) error stop 35
+ if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 36
+ end subroutine
+ subroutine check_int_alloc_empty_4()
+ integer, allocatable :: a(:,:,:,:)
+ integer, allocatable :: r(:,:,:)
+ allocate(a(9,3,0,7))
+ a(:,:,:,:) = reshape((/ integer:: /), shape(a))
+ r = maxloc(a, dim=1)
+ if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 41
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 42
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 43
+ if (any(r /= 0)) error stop 44
+ r = maxloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 45
+ end subroutine
+end subroutine
+
+subroutine check_minloc
+ implicit none
+ integer, parameter :: data60(*) = (/ 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, &
+ 8, 2, 6, 7, 8, 7, 4, 5, 3, 9, &
+ 0, 6, 4, 5, 5, 8, 2, 6, 7, 8, &
+ 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, &
+ 8, 2, 6, 7, 8, 7, 4, 5, 3, 9, &
+ 0, 6, 4, 5, 5, 8, 2, 6, 7, 8 /)
+ integer, parameter :: data1(*) = (/ 2, 3, 2, 3, &
+ 1, 2, 3, 2, &
+ 3, 1, 2, 3, &
+ 2, 3, 1, 2, &
+ 3, 2, 3, 1 /)
+ integer, parameter :: data2(*) = (/ 2, 1, 2, &
+ 3, 2, 3, &
+ 4, 3, 4, &
+ 2, 1, 2, &
+ 1, 2, 1 /)
+ integer, parameter :: data3(*) = (/ 5, 1, 5, &
+ 1, 2, 1, &
+ 2, 1, 2, &
+ 3, 2, 3 /)
+ call check_int_const_shape_rank_3
+ call check_int_const_shape_empty_4
+ call check_int_alloc_rank_3
+ call check_int_alloc_empty_4
+contains
+ subroutine check_int_const_shape_rank_3()
+ integer :: a(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape(data60, shape(a))
+ r = minloc(a, dim=1)
+ if (any(shape(r) /= (/ 4, 5 /))) error stop 111
+ if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 112
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) error stop 113
+ if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 114
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) error stop 115
+ if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 116
+ end subroutine
+ subroutine check_int_const_shape_empty_4()
+ integer :: a(9,3,0,7)
+ integer, allocatable :: r(:,:,:)
+ a = reshape((/ integer:: /), shape(a))
+ r = minloc(a, dim=1)
+ if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 121
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 122
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 123
+ if (any(r /= 0)) error stop 124
+ r = minloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 125
+ end subroutine
+ subroutine check_int_alloc_rank_3()
+ integer, allocatable :: a(:,:,:)
+ integer, allocatable :: r(:,:)
+ allocate(a(3,4,5))
+ a(:,:,:) = reshape(data60, shape(a))
+ r = minloc(a, dim=1)
+ if (any(shape(r) /= (/ 4, 5 /))) error stop 131
+ if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 132
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) error stop 133
+ if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 134
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) error stop 135
+ if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 136
+ end subroutine
+ subroutine check_int_alloc_empty_4()
+ integer, allocatable :: a(:,:,:,:)
+ integer, allocatable :: r(:,:,:)
+ allocate(a(9,3,0,7))
+ a(:,:,:,:) = reshape((/ integer:: /), shape(a))
+ r = minloc(a, dim=1)
+ if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 141
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 142
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 143
+ if (any(r /= 0)) error stop 144
+ r = minloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 145
+ end subroutine
+end subroutine
From: Mikael Morin <mikael@gcc.gnu.org> Bootstrapped and regression-tested on x86_64-pc-linux-gnu. OK for master? -- >8 -- Enable generation of inline code for the MINLOC and MAXLOC intrinsics, if the ARRAY argument is of integral type and of rank > 1 (only the rank 1 case was previously inlined), the DIM argument is a constant value and there is no MASK argument. The restriction to integral ARRAY and absent MASK limits the scope of the change to the cases where we generate single loop inline code. This change uses the existing scalarizer suport for reductions, that is arrays used in scalarization loops, where each element uses a nested scalarization loop to calculate its value. The nested loop (and respectively the nested scalarization chain) is created while walking the MINLOC/MAXLOC expression, it's set up automatically at the time the outer loop is set up, and gfc_conv_intrinsic_minmaxloc is changed to use it as a replacement for the local loop variable (respectively ARRAY scalarization chain) used in the non-reduction case (i.e. when DIM is absent). PR fortran/90608 gcc/fortran/ChangeLog: * trans-intrinsic.cc (gfc_inline_intrinsic_function_p): Return true if DIM is constant, ARRAY is integral and MASK is absent. (walk_inline_intrinsic_minmaxloc): If DIM is present, walk ARRAY and move the dimension corresponding to DIM to a nested chain, keeping the rest of the dimensions as the returned scalarization chain. (gfc_conv_intrinsic_minmaxloc): When inside the scalarization loops, proceed with inline code generation If DIM is present. If DIM is present, skip result array creation and final initialization from individual result local variables. If DIM is present and ARRAY has rank greater than 1, use the nested loop initialized by the scalarizer instead of the local one, use 1 as scalarization dimension, and evaluate ARRAY using the inherited scalarization chain instead of creating a local one by walking the expression. gcc/testsuite/ChangeLog: * gfortran.dg/maxloc_bounds_1.f90: Also accept the error message generated by the scalarizer in case the function call is implemented through inline code. * gfortran.dg/maxloc_bounds_2.f90: Likewise. * gfortran.dg/maxloc_bounds_3.f90: Likewise. * gfortran.dg/minmaxloc_19.f90: New test. --- gcc/fortran/trans-intrinsic.cc | 229 ++++++++++++------ gcc/testsuite/gfortran.dg/maxloc_bounds_1.f90 | 4 +- gcc/testsuite/gfortran.dg/maxloc_bounds_2.f90 | 4 +- gcc/testsuite/gfortran.dg/maxloc_bounds_3.f90 | 4 +- gcc/testsuite/gfortran.dg/minmaxloc_19.f90 | 182 ++++++++++++++ 5 files changed, 344 insertions(+), 79 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/minmaxloc_19.f90