* [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070]
@ 2021-09-21 12:26 Tobias Burnus
2021-09-24 20:38 ` Thomas Koenig
2021-09-24 21:12 ` Harald Anlauf
0 siblings, 2 replies; 9+ messages in thread
From: Tobias Burnus @ 2021-09-21 12:26 UTC (permalink / raw)
To: gcc-patches, fortran, Thomas Koenig, Harald Anlauf, Paul Richard Thomas
[-- Attachment #1: Type: text/plain, Size: 2049 bytes --]
This patch requires the previously mentioned simple-loop-gen patch,
which also still needs to be reviewed:
https://gcc.gnu.org/pipermail/gcc-patches/2021-September/579576.html
For the xfailed part of the new testcase, the updated array descriptor
is needed, but I think leaving it as xfailed for now - and reviewing
this patch first makes more sense.
size(a,dim=i) of an array is simply:
a.dim[i].ubound - a.dim[i].lbound + 1
except that the result is always >= 0, i.e. a(5:-10) has size 0.
Assumed-size arrays like as(5, -3:*) can be passed to assumed-rank
arrays – but, obviously, the upper bound is unknown. Without BIND(C),
the standard is quiet how those get transported but:
ubound(as,dim=2) == size(as,dim=2) == -1
However, for
..., allocatable :: c(:,:)
allocate (c(5,-4:-1))
the size(c,dim=2) is surely 4 and not -1. Thus, when passing it
to a
subroutine foo(x)
..., allocatable :: x(..)
it should also come out as size(x, dim=2) == 4.
To make the distinction, the allocatable/pointer attribute of the
dummy can be used – as an assumed-size array cannot be allocatable.
That's what is used in trans-intrinsic.c/trans-array.c – and the
main reason I started to generate inline code for the array size.
(Given that it permits optimizations and is a trivial code, I
also think that it makes sense in general.)
But even when doing so, it still did not work properly as when
calling
call foo(d)
the bounds where not always reset such that the caller could still
receive ubound(d,dim=last_dim) == -1 - in the case it just happened
to be -1, be it for a zero-sized array or because the lbounds just
happend to be -1 or smaller. That's taken care of in trans-expr.c.
OK for mainline?
Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
[-- Attachment #2: assumed-size-rank-pr94070.diff --]
[-- Type: text/x-patch, Size: 35327 bytes --]
Fortran: Fix assumed-size to assumed-rank passing [PR94070]
This code inlines the size0 and size1 libgfortran calls, the former is still
used by libgfortan itself (and by old code). Besides permitting more
optimizations, it also permits to handle assumed-rank dummies better: If the
dummy argument is a nonpointer/nonallocatable, an assumed-size actual arg is
repesented by having ubound == -1 for the last dimension. However, for
allocatable/pointers, this value can also exist. Hence, the dummy arg attr
has to be honored.
For that reason, when calling an assumed-rank procedure with nonpointer,
nonallocatable dummy arguments, the bounds have to be updated to avoid
the case ubound == -1 for the last dimension.
PR fortran/94070
gcc/fortran/ChangeLog:
* trans-array.c (gfc_tree_array_size): New function to
find size inline (whole array or one dimension).
(array_parameter_size): Use it, take stmt_block as arg.
(gfc_conv_array_parameter): Update call.
* trans-array.h (gfc_tree_array_size): Add prototype.
* trans-expr.c (gfc_conv_procedure_call): Update
bounds of pointer/allocatable actual args to nonallocatable/nonpointer
dummies to be one based.
* trans-intrinsic.c (gfc_conv_intrinsic_shape): Fix case for
assumed rank with allocatable/pointer dummy.
(gfc_conv_intrinsic_size): Update to use inline function.
libgfortran/ChangeLog:
* intrinsics/size.c (size0, size1): Comment that now not
used by newer compiler code.
libgomp/ChangeLog:
* testsuite/libgomp.oacc-fortran/privatized-ref-2.f90: Update
expected dg-note output.
gcc/testsuite/ChangeLog:
* gfortran.dg/c-interop/cf-out-descriptor-6.f90: Remove xfail.
* gfortran.dg/c-interop/size.f90: Remove xfail.
* gfortran.dg/intrinsic_size_3.f90:
* gfortran.dg/transpose_optimization_2.f90:
* gfortran.dg/assumed_rank_22.f90: New test.
* gfortran.dg/assumed_rank_22_aux.c: New test.
gcc/fortran/trans-array.c | 165 ++++++++++++++++----
gcc/fortran/trans-array.h | 2 +
gcc/fortran/trans-expr.c | 43 +++++-
gcc/fortran/trans-intrinsic.c | 119 ++++++---------
gcc/testsuite/gfortran.dg/assumed_rank_22.f90 | 167 +++++++++++++++++++++
gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c | 68 +++++++++
.../gfortran.dg/c-interop/cf-out-descriptor-6.f90 | 2 +-
gcc/testsuite/gfortran.dg/c-interop/size.f90 | 2 +-
gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 | 2 +-
.../gfortran.dg/transpose_optimization_2.f90 | 2 +-
libgfortran/intrinsics/size.c | 4 +
.../libgomp.oacc-fortran/privatized-ref-2.f90 | 13 +-
12 files changed, 476 insertions(+), 113 deletions(-)
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0d013defdbb..b8061f37772 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7901,31 +7901,143 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gfc_cleanup_loop (&loop);
}
+
+/* Calculate the array size (number of elements); if dim != NULL_TREE,
+ return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P). */
+tree
+gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
+{
+ if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+ {
+ gcc_assert (dim == NULL_TREE);
+ return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
+ }
+ tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
+ symbol_attribute attr = gfc_expr_attr (expr);
+ gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
+ if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
+ || !dim)
+ {
+ if (expr->rank < 0)
+ rank = fold_convert (signed_char_type_node,
+ gfc_conv_descriptor_rank (desc));
+ else
+ rank = build_int_cst (signed_char_type_node, expr->rank);
+ }
+
+ if (dim || expr->rank == 1)
+ {
+ if (!dim)
+ dim = gfc_index_zero_node;
+ tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
+ tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
+
+ size = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, ubound, lbound);
+ size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ size, gfc_index_one_node);
+ /* if (!allocatable && !pointer && assumed rank)
+ size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
+ else
+ size = max (0, size); */
+ size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
+ size, gfc_index_zero_node);
+ if (!attr.pointer && !attr.allocatable
+ && as && as->type == AS_ASSUMED_RANK)
+ {
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
+ rank, build_int_cst (signed_char_type_node, 1));
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ fold_convert (signed_char_type_node, dim),
+ tmp);
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ gfc_conv_descriptor_ubound_get (desc, dim),
+ build_int_cst (gfc_array_index_type, -1));
+ cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
+ cond, tmp);
+ tmp = build_int_cst (gfc_array_index_type, -1);
+ size = build3_loc (input_location, COND_EXPR, gfc_array_index_type,
+ cond, tmp, size);
+ }
+ return size;
+ }
+
+ /* size = 1. */
+ size = gfc_create_var (gfc_array_index_type, "size");
+ gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1));
+ tree extent = gfc_create_var (gfc_array_index_type, "extent");
+
+ stmtblock_t cond_block, loop_body;
+ gfc_init_block (&cond_block);
+ gfc_init_block (&loop_body);
+
+ /* Loop: for (i = 0; i < rank; ++i). */
+ tree idx = gfc_create_var (signed_char_type_node, "idx");
+ /* Loop body. */
+ /* #if (assumed-rank + !allocatable && !pointer)
+ if (idx == rank - 1 && dim[idx].ubound == -1)
+ extent = -1;
+ else
+ #endif
+ extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
+ if (extent < 0)
+ extent = 0
+ size *= extent. */
+ cond = NULL_TREE;
+ if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
+ {
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
+ rank, build_int_cst (signed_char_type_node, 1));
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ idx, tmp);
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ gfc_conv_descriptor_ubound_get (desc, idx),
+ build_int_cst (gfc_array_index_type, -1));
+ cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
+ cond, tmp);
+ }
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound_get (desc, idx),
+ gfc_conv_descriptor_lbound_get (desc, idx));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ gfc_add_modify (&cond_block, extent, tmp);
+ tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ extent, gfc_index_zero_node);
+ tmp = build3_v (COND_EXPR, tmp,
+ fold_build2_loc (input_location, MODIFY_EXPR,
+ gfc_array_index_type,
+ extent, gfc_index_zero_node),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&cond_block, tmp);
+ tmp = gfc_finish_block (&cond_block);
+ if (cond)
+ tmp = build3_v (COND_EXPR, cond,
+ fold_build2_loc (input_location, MODIFY_EXPR,
+ gfc_array_index_type, extent,
+ build_int_cst (gfc_array_index_type, -1)),
+ tmp);
+ gfc_add_expr_to_block (&loop_body, tmp);
+ /* size *= extent. */
+ gfc_add_modify (&loop_body, size,
+ fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ size, extent));
+ /* Generate loop. */
+ gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR,
+ build_int_cst (TREE_TYPE (idx), 1),
+ gfc_finish_block (&loop_body));
+ return size;
+}
+
/* Helper function for gfc_conv_array_parameter if array size needs to be
computed. */
static void
-array_parameter_size (tree desc, gfc_expr *expr, tree *size)
+array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size)
{
tree elem;
- if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
- *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
- else if (expr->rank > 1)
- *size = build_call_expr_loc (input_location,
- gfor_fndecl_size0, 1,
- gfc_build_addr_expr (NULL, desc));
- else
- {
- tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
- tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
-
- *size = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, ubound, lbound);
- *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- *size, gfc_index_one_node);
- *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
- *size, gfc_index_zero_node);
- }
+ *size = gfc_tree_array_size (block, desc, expr, NULL);
elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
*size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
*size, fold_convert (gfc_array_index_type, elem));
@@ -8035,7 +8147,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
else
se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
if (size)
- array_parameter_size (tmp, expr, size);
+ array_parameter_size (&se->pre, tmp, expr, size);
return;
}
@@ -8047,7 +8159,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
tmp = se->expr;
}
if (size)
- array_parameter_size (tmp, expr, size);
+ array_parameter_size (&se->pre, tmp, expr, size);
se->expr = gfc_conv_array_data (tmp);
return;
}
@@ -8122,7 +8234,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
se->string_length = expr->ts.u.cl->backend_decl;
if (size)
- array_parameter_size (se->expr, expr, size);
+ array_parameter_size (&se->pre, se->expr, expr, size);
se->expr = gfc_conv_array_data (se->expr);
return;
}
@@ -8132,7 +8244,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
/* Result of the enclosing function. */
gfc_conv_expr_descriptor (se, expr);
if (size)
- array_parameter_size (se->expr, expr, size);
+ array_parameter_size (&se->pre, se->expr, expr, size);
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
@@ -8149,9 +8261,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
gfc_conv_expr_descriptor (se, expr);
if (size)
- array_parameter_size (build_fold_indirect_ref_loc (input_location,
- se->expr),
- expr, size);
+ array_parameter_size (&se->pre,
+ build_fold_indirect_ref_loc (input_location,
+ se->expr),
+ expr, size);
}
/* Deallocate the allocatable components of structures that are
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index e4d443d7118..85ff2161191 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -39,6 +39,8 @@ void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *);
/* Generate entry and exit code for g77 calling convention arrays. */
void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
+tree gfc_tree_array_size (stmtblock_t *, tree, gfc_expr *, tree);
+
tree gfc_full_array_size (stmtblock_t *, tree, int);
tree gfc_duplicate_allocatable (tree, tree, tree, int, tree);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 4a81f4695d9..c3e44999047 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6450,6 +6450,29 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
parmse.force_tmp = 1;
}
+ /* Special case for assumed-rank arrays: when passing an
+ argument to a nonallocatable/nonpointer dummy, the bounds have
+ to be reset as otherwise a last-dim ubound of -1 is
+ indistinguishable from an assumed-size array in the callee. */
+ if (!sym->attr.is_bind_c && e && fsym && fsym->as
+ && fsym->as->type == AS_ASSUMED_RANK
+ && e->rank != -1
+ && e->expr_type == EXPR_VARIABLE
+ && ((fsym->ts.type == BT_CLASS
+ && !CLASS_DATA (fsym)->attr.class_pointer
+ && !CLASS_DATA (fsym)->attr.allocatable)
+ || (fsym->ts.type != BT_CLASS
+ && !fsym->attr.pointer && !fsym->attr.allocatable)))
+ {
+ /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
+ gfc_ref *ref;
+ for (ref = e->ref; ref->next; ref = ref->next)
+ ;
+ if (ref->u.ar.type == AR_FULL
+ && ref->u.ar.as->type != AS_ASSUMED_SIZE)
+ ref->u.ar.type = AR_SECTION;
+ }
+
if (sym->attr.is_bind_c && e
&& (is_CFI_desc (fsym, NULL) || assumed_length_string))
/* Implement F2018, 18.3.6, list item (5), bullet point 2. */
@@ -6510,16 +6533,26 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
sym->name, NULL);
- /* Unallocated allocatable arrays and unassociated pointer arrays
- need their dtype setting if they are argument associated with
- assumed rank dummies, unless already assumed rank. */
+ /* Special case for assumed-rank arrays. */
if (!sym->attr.is_bind_c && e && fsym && fsym->as
&& fsym->as->type == AS_ASSUMED_RANK
&& e->rank != -1)
{
- if (gfc_expr_attr (e).pointer
+ if ((gfc_expr_attr (e).pointer
|| gfc_expr_attr (e).allocatable)
- set_dtype_for_unallocated (&parmse, e);
+ && ((fsym->ts.type == BT_CLASS
+ && (CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable))
+ || (fsym->ts.type != BT_CLASS
+ && (fsym->attr.pointer || fsym->attr.allocatable))))
+ {
+ /* Unallocated allocatable arrays and unassociated pointer
+ arrays need their dtype setting if they are argument
+ associated with assumed rank dummies. However, if the
+ dummy is nonallocate/nonpointer, the user may not
+ pass those. Hence, it can be skipped. */
+ set_dtype_for_unallocated (&parmse, e);
+ }
else if (e->expr_type == EXPR_VARIABLE
&& e->ref
&& e->ref->u.ar.type == AR_FULL
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 42a995be348..bca2b3f8726 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -6697,6 +6697,8 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
gfc_expr *e;
gfc_array_spec *as;
gfc_ss *ss;
+ symbol_attribute attr;
+ tree result_desc = se->expr;
/* Remove the KIND argument, if present. */
s = expr->value.function.actual;
@@ -6707,17 +6709,25 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
gfc_conv_intrinsic_funcall (se, expr);
- as = gfc_get_full_arrayspec_from_expr (s->expr);;
- ss = gfc_walk_expr (s->expr);
-
/* According to F2018 16.9.172, para 5, an assumed rank entity, argument
associated with an assumed size array, has the ubound of the final
dimension set to -1 and SHAPE must return this. */
- if (as && as->type == AS_ASSUMED_RANK
- && se->expr && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))
- && ss && ss->info->type == GFC_SS_SECTION)
+
+ as = gfc_get_full_arrayspec_from_expr (s->expr);
+ if (!as || as->type != AS_ASSUMED_RANK)
+ return;
+ attr = gfc_expr_attr (s->expr);
+ ss = gfc_walk_expr (s->expr);
+ if (attr.pointer || attr.allocatable
+ || !ss || ss->info->type != GFC_SS_SECTION)
+ return;
+ if (se->expr)
+ result_desc = se->expr;
+ if (POINTER_TYPE_P (TREE_TYPE (result_desc)))
+ result_desc = build_fold_indirect_ref_loc (input_location, result_desc);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (result_desc)))
{
- tree desc, rank, minus_one, cond, ubound, tmp;
+ tree rank, minus_one, cond, ubound, tmp;
stmtblock_t block;
gfc_se ase;
@@ -6745,8 +6755,7 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
/* Obtain the last element of the result from the library shape
intrinsic and set it to -1 if that is the value of ubound. */
- desc = se->expr;
- tmp = gfc_conv_array_data (desc);
+ tmp = gfc_conv_array_data (result_desc);
tmp = build_fold_indirect_ref_loc (input_location, tmp);
tmp = gfc_build_array_ref (tmp, rank, NULL, NULL);
@@ -6758,7 +6767,6 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->pre, cond);
}
-
}
static void
@@ -7968,8 +7976,7 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
gfc_actual_arglist *actual;
tree arg1;
tree type;
- tree fncall0;
- tree fncall1;
+ tree size;
gfc_se argse;
gfc_expr *e;
gfc_symbol *sym = NULL;
@@ -8046,37 +8053,31 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
/* For functions that return a class array conv_expr_descriptor is not
able to get the descriptor right. Therefore this special case. */
gfc_conv_expr_reference (&argse, e);
- argse.expr = gfc_build_addr_expr (NULL_TREE,
- gfc_class_data_get (argse.expr));
+ argse.expr = gfc_class_data_get (argse.expr);
}
else if (sym && sym->backend_decl)
{
gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
- argse.expr = sym->backend_decl;
- argse.expr = gfc_build_addr_expr (NULL_TREE,
- gfc_class_data_get (argse.expr));
+ argse.expr = gfc_class_data_get (sym->backend_decl);
}
else
- {
- argse.want_pointer = 1;
- gfc_conv_expr_descriptor (&argse, actual->expr);
- }
+ gfc_conv_expr_descriptor (&argse, actual->expr);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
- arg1 = gfc_evaluate_now (argse.expr, &se->pre);
-
- /* Build the call to size0. */
- fncall0 = build_call_expr_loc (input_location,
- gfor_fndecl_size0, 1, arg1);
+ arg1 = argse.expr;
actual = actual->next;
-
if (actual->expr)
{
+ stmtblock_t block;
+ gfc_init_block (&block);
gfc_init_se (&argse, NULL);
gfc_conv_expr_type (&argse, actual->expr,
gfc_array_index_type);
- gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&block, &argse.pre);
+ tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ argse.expr, gfc_index_one_node);
+ size = gfc_tree_array_size (&block, arg1, e, tmp);
/* Unusually, for an intrinsic, size does not exclude
an optional arg2, so we must test for it. */
@@ -8084,59 +8085,35 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
&& actual->expr->symtree->n.sym->attr.dummy
&& actual->expr->symtree->n.sym->attr.optional)
{
- tree tmp;
- /* Build the call to size1. */
- fncall1 = build_call_expr_loc (input_location,
- gfor_fndecl_size1, 2,
- arg1, argse.expr);
-
+ tree cond;
+ stmtblock_t block2;
+ gfc_init_block (&block2);
gfc_init_se (&argse, NULL);
argse.want_pointer = 1;
argse.data_not_needed = 1;
gfc_conv_expr (&argse, actual->expr);
gfc_add_block_to_block (&se->pre, &argse.pre);
- tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
- argse.expr, null_pointer_node);
- tmp = gfc_evaluate_now (tmp, &se->pre);
- se->expr = fold_build3_loc (input_location, COND_EXPR,
- pvoid_type_node, tmp, fncall1, fncall0);
+ cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ argse.expr, null_pointer_node);
+ cond = gfc_evaluate_now (cond, &se->pre);
+ /* 'block2' contains the arg2 absent case, 'block' the arg2 present
+ case; size_var can be used in both blocks. */
+ tree size_var = gfc_tree_array_size (&block2, arg1, e, NULL_TREE);
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (size_var), size_var, size);
+ gfc_add_expr_to_block (&block, tmp);
+ tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block),
+ gfc_finish_block (&block2));
+ gfc_add_expr_to_block (&se->pre, tmp);
+ size = size_var;
}
else
- {
- se->expr = NULL_TREE;
- argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- argse.expr, gfc_index_one_node);
- }
- }
- else if (expr->value.function.actual->expr->rank == 1)
- {
- argse.expr = gfc_index_zero_node;
- se->expr = NULL_TREE;
+ gfc_add_block_to_block (&se->pre, &block);
}
else
- se->expr = fncall0;
-
- if (se->expr == NULL_TREE)
- {
- tree ubound, lbound;
-
- arg1 = build_fold_indirect_ref_loc (input_location,
- arg1);
- ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
- lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
- se->expr = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, ubound, lbound);
- se->expr = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- se->expr, gfc_index_one_node);
- se->expr = fold_build2_loc (input_location, MAX_EXPR,
- gfc_array_index_type, se->expr,
- gfc_index_zero_node);
- }
-
+ size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE);
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = convert (type, se->expr);
+ se->expr = convert (type, size);
}
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_22.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_22.f90
new file mode 100644
index 00000000000..d03569bf88c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_22.f90
@@ -0,0 +1,167 @@
+! { dg-do run }
+! { dg-additional-sources assumed_rank_22_aux.c }
+!
+! FIXME: wrong extend in array descriptor, see C file.
+! { dg-output "c_assumed - 40 - OK" { xfail *-*-* } }
+! { dg-output "c_assumed - 100 - OK" { xfail *-*-* } }
+!
+! PR fortran/94070
+!
+! Contributed by Tobias Burnus
+! and José Rui Faustino de Sousa
+!
+program main
+ implicit none
+ integer :: A(5,4,2)
+ integer, allocatable :: B(:,:,:)
+ integer :: C(5,4,-2:-1)
+
+ interface
+ subroutine c_assumed (x, num) bind(C)
+ integer :: x(..)
+ integer, value :: num
+ end subroutine
+ subroutine c_allocated (x) bind(C)
+ integer, allocatable :: x(..)
+ end subroutine
+ end interface
+
+ allocate (B(-1:3,4,-1:-1))
+
+ call caller (a) ! num=0: assumed-size
+ call test (b, num=20) ! full array
+ call test (b(:,:,0:-1), num=40) ! zero-sized array
+ call test (c, num=60)
+ call test (c(:,:,:-1), num=80) ! full-size slice
+ call test (c(:,:,1:-1), num=100) !zero-size array
+
+ call test_alloc(b)
+
+ call c_assumed (b, num=20)
+ call c_assumed (b(:,:,0:-1), num=40)
+ call c_assumed (c, num=60)
+ call c_assumed (c(:,:,:-1), num=80)
+ call c_assumed (c(:,:,1:-1), num=100)
+
+ call c_allocated (b)
+contains
+ subroutine caller(y)
+ integer :: y(-1:3,4,*)
+ call test(y, num=0)
+ call c_assumed (y, num=0)
+ end
+ subroutine test (x, num)
+ integer :: x(..), num
+
+ ! SIZE (x)
+ if (num == 0) then
+ if (size (x) /= -20) stop 1
+ elseif (num == 20) then
+ if (size (x) /= 20) stop 21
+ elseif (num == 40) then
+ if (size (x) /= 0) stop 41
+ elseif (num == 60) then
+ if (size (x) /= 40) stop 61
+ elseif (num == 80) then
+ if (size (x) /= 40) stop 81
+ elseif (num == 100) then
+ if (size (x) /= 0) stop 101
+ else
+ stop 99 ! Invalid num
+ endif
+
+ ! SIZE (x, dim=...)
+ if (size (x, dim=1) /= 5) stop num + 2
+ if (size (x, dim=2) /= 4) stop num + 3
+
+ if (num == 0) then
+ if (size (x, dim=3) /= -1) stop 4
+ elseif (num == 20) then
+ if (size (x, dim=3) /= 1) stop 24
+ elseif (num == 40) then
+ if (size (x, dim=3) /= 0) stop 44
+ elseif (num == 60) then
+ if (size (x, dim=3) /= 2) stop 64
+ elseif (num == 80) then
+ if (size (x, dim=3) /= 2) stop 84
+ elseif (num == 100) then
+ if (size (x, dim=3) /= 0) stop 104
+ endif
+
+ ! SHAPE (x)
+ if (num == 0) then
+ if (any (shape (x) /= [5, 4, -1])) stop 5
+ elseif (num == 20) then
+ if (any (shape (x) /= [5, 4, 1])) stop 25
+ elseif (num == 40) then
+ if (any (shape (x) /= [5, 4, 0])) stop 45
+ elseif (num == 60) then
+ if (any (shape (x) /= [5, 4, 2])) stop 65
+ elseif (num == 80) then
+ if (any (shape (x) /= [5, 4, 2])) stop 85
+ elseif (num == 100) then
+ if (any (shape (x) /= [5, 4, 0])) stop 105
+ endif
+
+ ! LBOUND (X)
+ if (any (lbound (x) /= [1, 1, 1])) stop num + 6
+
+ ! LBOUND (X, dim=...)
+ if (lbound (x, dim=1) /= 1) stop num + 7
+ if (lbound (x, dim=2) /= 1) stop num + 8
+ if (lbound (x, dim=3) /= 1) stop num + 9
+
+ ! UBOUND (X)
+ if (num == 0) then
+ if (any (ubound (x) /= [5, 4, -1])) stop 11
+ elseif (num == 20) then
+ if (any (ubound (x) /= [5, 4, 1])) stop 31
+ elseif (num == 40) then
+ if (any (ubound (x) /= [5, 4, 0])) stop 51
+ elseif (num == 60) then
+ if (any (ubound (x) /= [5, 4, 2])) stop 71
+ elseif (num == 80) then
+ if (any (ubound (x) /= [5, 4, 2])) stop 91
+ elseif (num == 100) then
+ if (any (ubound (x) /= [5, 4, 0])) stop 111
+ endif
+
+ ! UBOUND (X, dim=...)
+ if (ubound (x, dim=1) /= 5) stop num + 12
+ if (ubound (x, dim=2) /= 4) stop num + 13
+ if (num == 0) then
+ if (ubound (x, dim=3) /= -1) stop 14
+ elseif (num == 20) then
+ if (ubound (x, dim=3) /= 1) stop 34
+ elseif (num == 40) then
+ if (ubound (x, dim=3) /= 0) stop 54
+ elseif (num == 60) then
+ if (ubound (x, dim=3) /= 2) stop 74
+ elseif (num == 80) then
+ if (ubound (x, dim=3) /= 2) stop 94
+ elseif (num == 100) then
+ if (ubound (x, dim=3) /= 0) stop 114
+ endif
+ end
+
+ subroutine test_alloc (x)
+ integer, allocatable :: x(..)
+
+ if (size (x) /= 20) stop 61
+ if (size (x, dim=1) /= 5) stop 62
+ if (size (x, dim=2) /= 4) stop 63
+ if (size (x, dim=3) /= 1) stop 64
+
+ if (any (shape (x) /= [5, 4, 1])) stop 65
+
+ if (any (lbound (x) /= [-1, 1, -1])) stop 66
+ if (lbound (x, dim=1) /= -1) stop 77
+ if (lbound (x, dim=2) /= 1) stop 78
+ if (lbound (x, dim=3) /= -1) stop 79
+
+ if (any (ubound (x) /= [3, 4, -1])) stop 80
+ if (ubound (x, dim=1) /= 3) stop 92
+ if (ubound (x, dim=2) /= 4) stop 93
+ if (ubound (x, dim=3) /= -1) stop 94
+ end
+end
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c b/gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c
new file mode 100644
index 00000000000..2fbf83d649a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c
@@ -0,0 +1,68 @@
+/* Called by assumed_rank_22.f90. */
+
+#include <ISO_Fortran_binding.h>
+#include <assert.h>
+
+void
+c_assumed (CFI_cdesc_t *x, int num)
+{
+ assert (num == 0 || num == 20 || num == 40 || num == 60 || num == 80
+ || num == 100);
+ assert (x->elem_len == sizeof (int));
+ assert (x->rank == 3);
+ assert (x->type == CFI_type_int32_t);
+
+ assert (x->attribute == CFI_attribute_other);
+ assert (x->dim[0].lower_bound == 0);
+ assert (x->dim[1].lower_bound == 0);
+ assert (x->dim[2].lower_bound == 0);
+ assert (x->dim[0].extent == 5);
+ assert (x->dim[1].extent == 4);
+ if (num == 0)
+ assert (x->dim[2].extent == -1);
+ else if (num == 20)
+ assert (x->dim[2].extent == 1);
+ else if (num == 40)
+ {
+ /* FIXME: - dg-output = 'c_assumed ... OK' checked in .f90 file. */
+ /* assert (x->dim[2].extent == 0); */
+ if (x->dim[2].extent == 0)
+ __builtin_printf ("c_assumed - 40 - OK\n");
+ else
+ __builtin_printf ("ERROR: c_assumed num=%d: "
+ "x->dim[2].extent = %d != 0\n",
+ num, x->dim[2].extent);
+ }
+ else if (num == 60)
+ assert (x->dim[2].extent == 2);
+ else if (num == 80)
+ assert (x->dim[2].extent == 2);
+ else if (num == 100)
+ {
+ /* FIXME: - dg-output = 'c_assumed ... OK' checked in .f90 file. */
+ /* assert (x->dim[2].extent == 0); */
+ if (x->dim[2].extent == 0)
+ __builtin_printf ("c_assumed - 100 - OK\n");
+ else
+ __builtin_printf ("ERROR: c_assumed num=%d: "
+ "x->dim[2].extent = %d != 0\n",
+ num, x->dim[2].extent);
+ }
+ else
+ assert (0);
+}
+
+void
+c_allocated (CFI_cdesc_t *x)
+{
+ assert (x->elem_len == sizeof (int));
+ assert (x->rank == 3);
+ assert (x->type == CFI_type_int32_t);
+ assert (x->attribute == CFI_attribute_allocatable);
+ assert (x->dim[0].lower_bound == -1);
+ assert (x->dim[1].lower_bound == 1);
+ assert (x->dim[2].lower_bound == -1);
+ assert (x->dim[0].extent == 5);
+ assert (x->dim[1].extent == 4);
+ assert (x->dim[2].extent == 1);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90
index b1a8c53b3e8..bc19a71efa7 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90
@@ -1,5 +1,5 @@
! Reported as pr94070.
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "cf-out-descriptor-6-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
diff --git a/gcc/testsuite/gfortran.dg/c-interop/size.f90 b/gcc/testsuite/gfortran.dg/c-interop/size.f90
index 6c6699701bf..58b32b0d5e7 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/size.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/size.f90
@@ -1,5 +1,5 @@
! Reported as pr94070.
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
!
! TS 29113
! 6.4.2 SIZE
diff --git a/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 b/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90
index 923cbc3473d..afdf9b34d4b 100644
--- a/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90
+++ b/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90
@@ -22,4 +22,4 @@ program bug
stop
end program bug
-! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) MAX_EXPR <\\(D.\[0-9\]+->dim.0..ubound - D.\[0-9\]+->dim.0..lbound\\) \\+ 1, 0>;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) MAX_EXPR <\\(a.dim.0..ubound - a.dim.0..lbound\\) \\+ 1, 0>;" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90
index c49cd421058..54271b12bfa 100644
--- a/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90
+++ b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90
@@ -60,5 +60,5 @@ end
!
! The check below for temporaries gave 14 and 33 for "parm" and "atmp".
!
-! { dg-final { scan-tree-dump-times "parm" 72 "original" } }
+! { dg-final { scan-tree-dump-times "parm" 76 "original" } }
! { dg-final { scan-tree-dump-times "atmp" 13 "original" } }
diff --git a/libgfortran/intrinsics/size.c b/libgfortran/intrinsics/size.c
index e9d93861eff..f1a60ba7209 100644
--- a/libgfortran/intrinsics/size.c
+++ b/libgfortran/intrinsics/size.c
@@ -25,6 +25,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include "libgfortran.h"
+/* Note: This function is only used internally in libgfortran and old FE code,
+ new code generates the code inline. */
index_type
size0 (const array_t * array)
{
@@ -47,6 +49,8 @@ iexport(size0);
extern index_type size1 (const array_t * array, index_type dim);
export_proto(size1);
+/* Note: This function it is unused in libgfortran itself and the FE no longer
+ call it; however, old code might still call it. */
index_type
size1 (const array_t * array, index_type dim)
{
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90 b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
index baaee02b82c..2ff60226109 100644
--- a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
+++ b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
@@ -71,17 +71,16 @@ contains
! { dg-note {variable 'offset\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute }
! { dg-note {variable 'S\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute }
! { dg-note {variable 'test\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute }
- ! { dg-note {variable 'parm\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "" { target *-*-* } l_compute$c_compute }
- ! { dg-note {variable 'parm\.[0-9]+' ought to be adjusted for OpenACC privatization level: 'gang'} "" { target *-*-* } l_compute$c_compute }
- ! { dg-note {variable 'parm\.[0-9]+' adjusted for OpenACC privatization level: 'gang'} "" { target { ! { openacc_host_selected || openacc_nvidia_accel_selected } } } l_compute$c_compute }
+ ! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute }
! { dg-note {variable 'A\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: static} "" { target *-*-* } l_compute$c_compute }
array = [(-2*i, i = 1, size(array))]
!$acc loop gang private(array) ! { dg-line l_loop[incr c_loop] }
- ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
- ! { dg-note {variable 'array\.[0-9]+' in 'private' clause is candidate for adjusting OpenACC privatization level} "" { target *-*-* } l_loop$c_loop }
- ! { dg-note {variable 'array\.[0-9]+' ought to be adjusted for OpenACC privatization level: 'gang'} "" { target *-*-* } l_loop$c_loop }
- ! { dg-note {variable 'array\.[0-9]+' adjusted for OpenACC privatization level: 'gang'} "" { target { ! { openacc_host_selected || openacc_nvidia_accel_selected } } } l_loop$c_loop }
+ ! { dg-message {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
+ ! { dg-message {variable 'array\.[0-9]+' in 'private' clause is candidate for adjusting OpenACC privatization level} "" { target *-*-* } l_loop$c_loop }
+ ! { dg-message {variable 'array\.[0-9]+' ought to be adjusted for OpenACC privatization level: 'gang'} "" { target *-*-* } l_loop$c_loop }
+
! { dg-message {sorry, unimplemented: target cannot support alloca} PR65181 { target openacc_nvidia_accel_selected } l_loop$c_loop }
+
do i = 1, 10
array(i) = 9*i
end do
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070]
2021-09-21 12:26 [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070] Tobias Burnus
@ 2021-09-24 20:38 ` Thomas Koenig
2021-09-27 12:07 ` Tobias Burnus
2021-09-24 21:12 ` Harald Anlauf
1 sibling, 1 reply; 9+ messages in thread
From: Thomas Koenig @ 2021-09-24 20:38 UTC (permalink / raw)
To: Tobias Burnus, gcc-patches, fortran
Hi Tobias,
> OK for mainline?
As promised on IRC, here's the review.
Maybe you can add a test case which shows that the call to the size
intrinsic really does not happen.
OK with that.
Thanks for the patch!
Best regards
Thomas
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070]
2021-09-21 12:26 [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070] Tobias Burnus
2021-09-24 20:38 ` Thomas Koenig
@ 2021-09-24 21:12 ` Harald Anlauf
1 sibling, 0 replies; 9+ messages in thread
From: Harald Anlauf @ 2021-09-24 21:12 UTC (permalink / raw)
To: fortran; +Cc: gcc-patches
Hi Tobias,
Am 21.09.21 um 14:26 schrieb Tobias Burnus:
> This patch requires the previously mentioned simple-loop-gen patch,
> which also still needs to be reviewed:
> https://gcc.gnu.org/pipermail/gcc-patches/2021-September/579576.html
>
> For the xfailed part of the new testcase, the updated array descriptor
> is needed, but I think leaving it as xfailed for now - and reviewing
> this patch first makes more sense.
I played around with your patch and was unable to break it.
Are you tracking the xfailed parts?
While playing I stumbled over the fact that when allocating an array
with a dimension that has extent 0, e.g. 4:-5, the lbound gets reset
to 1 and ubound set to 0. I tried to find this in the F2018 standard
but could not find this requirement. 9.7.1.2(1) only requires that
the extent is 0. Has the standard has changed in this respect?
> size(a,dim=i) of an array is simply:
> a.dim[i].ubound - a.dim[i].lbound + 1
> except that the result is always >= 0, i.e. a(5:-10) has size 0.
>
> Assumed-size arrays like as(5, -3:*) can be passed to assumed-rank
> arrays – but, obviously, the upper bound is unknown. Without BIND(C),
> the standard is quiet how those get transported but:
> ubound(as,dim=2) == size(as,dim=2) == -1
> However, for
> ..., allocatable :: c(:,:)
> allocate (c(5,-4:-1))
> the size(c,dim=2) is surely 4 and not -1. Thus, when passing it
> to a
> subroutine foo(x)
> ..., allocatable :: x(..)
> it should also come out as size(x, dim=2) == 4.
>
> To make the distinction, the allocatable/pointer attribute of the
> dummy can be used – as an assumed-size array cannot be allocatable.
>
> That's what is used in trans-intrinsic.c/trans-array.c – and the
> main reason I started to generate inline code for the array size.
> (Given that it permits optimizations and is a trivial code, I
> also think that it makes sense in general.)
Agreed. Loop bounds in loop nests often refer to lbound/ubound/size.
> But even when doing so, it still did not work properly as when
> calling
> call foo(d)
> the bounds where not always reset such that the caller could still
> receive ubound(d,dim=last_dim) == -1 - in the case it just happened
> to be -1, be it for a zero-sized array or because the lbounds just
> happend to be -1 or smaller. That's taken care of in trans-expr.c.
>
> OK for mainline?
I am probably not the best person to review the trans-* parts, but
I did not spot anything I could point at, and the dump-tree looked
reasonable. Therefore OK from my side.
Thanks for the work!
Harald
> Tobias
>
> -----------------
> Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201,
> 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer:
> Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München;
> Registergericht München, HRB 106955
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070]
2021-09-24 20:38 ` Thomas Koenig
@ 2021-09-27 12:07 ` Tobias Burnus
2021-09-27 12:38 ` [committed] libgomp.oacc-fortran/privatized-ref-2.f90: Fix dg-note (was: [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070]) Tobias Burnus
` (2 more replies)
0 siblings, 3 replies; 9+ messages in thread
From: Tobias Burnus @ 2021-09-27 12:07 UTC (permalink / raw)
To: Thomas Koenig, gcc-patches, fortran
[-- Attachment #1: Type: text/plain, Size: 5348 bytes --]
Hi Thomas, hi Harald, hi all,
now committed r12-3897-g00f6de9c69119594f7dad3bd525937c94c8200d0
with the following changes:
* Removed now unused gfor_fndecl_size0/gfor_fndecl_size1 (trans{-decl.c,.h})
* Add a scan-dump-not check for those.
See below for some comments.
On 24.09.21 22:38, Thomas Koenig wrote:
>> OK for mainline?
> As promised on IRC, here's the review.
Thanks for the quick review :-)
> Maybe you can add a test case which shows that the call to the size
> intrinsic really does not happen.
> OK with that.
I think you mean to the (_gfortran_)size0/size1 function libgfortran.
Unsurprisingly, the intrinsic itself _is_ still used and the simplify.c +
trans-instrinsic.c's functions are called. However, the libgfortran
functions size0/size1 shouldn't be callable – given that I deleted
the function decl in the front end. I have nonetheless added some
-fdump-tree checks that size0 and size1 do not appear.
Hmm, looking at my patch again – I think I did intent to remove
the decl – but did not actually do it.
In this patch, I have now actually done what I intended and wrote
above: I removed the gfor_fndecl_size0/gfor_fndecl_size1 also from
trans.h (declared) and trans-decl.c (global var, init with fn decl).
size_optional_dim_1.f90 was the only testcase that used size1 before
the patch (it also used size0). Thus, I added the dump check to it
and to the new assumed_rank_22.f90, which has 7 size0 calls with an
unpatched compiler.
Thus: Thanks for asking for the dump check as it showed that I did
forget to remove something ... :-)
Conclusion: Reviews are very helpful :-)
* * *
As the following email by Harald did not show up at the gcc-patches mailing list:
you can find it at https://gcc.gnu.org/pipermail/fortran/2021-September/056578.html
In my email, it shows up with "To: fortran@" and "CC: gcc-patches@", thus,
I have no idea why it did not arrive at the mailing-list archive :-(
On 24.09.21 23:12, Harald Anlauf via Fortran wrote:
> I played around with your patch and was unable to break it.
Good. That means we can now hand it over to Gerald ;-)
> Are you tracking the xfailed parts?
For my newly added xfail, it is fixed by the posted CFI<->GFC
descriptor patch, which I am currently updating (for several reasons).
Otherwise, I lost a bit track of the various TS29113, C-interop,
class(*), type(*), dimension(..) etc. PRs. I think they do cover
most of it. – Besides that CFI/GFC descriptor patch, some additional
patches are still in Sandra's and my pipeline.
And once the CFI/GFC descriptor patch is in, I think it makes sense
to check a bunch of PRs to see whether they are now fixed or something
still needs to be done. Likewise for José's patches. I think they
will be partially superseded by the patches committed, submitted or
soon to be submitted – but I am sure not all issues are fixed.
> While playing I stumbled over the fact that when allocating an array
> with a dimension that has extent 0, e.g. 4:-5, the lbound gets reset
> to 1 and ubound set to 0.
I am not sure, whether I fully understand what you wrote. For:
integer, allocatable :: a(:)
allocate(a(4:-5))
print *, size(a), size(a, dim=1), shape(a) ! should print the '0 0 0'
print *, lbound(a, dim=1) ! should print '1'
print *, ubound(a, dim=1) ! should print '0'
where the last line is due to F2018, 16.9.196, which has:
'Otherwise, if DIM is present, the result has a value equal to the
number of elements in dimension DIM of ARRAY.'
And lbound(a,dim=1) == 1 due to the "otherwise" case of F2018:16.9.109 LBOUND:
"Case (i): If DIM is present, ARRAY is a whole array, and either
ARRAY is an assumed-size array of rank DIM or dimension DIM of
ARRAY has nonzero extent, the result has a value equal to the
lower bound for subscript DIM of ARRAY. Otherwise, if DIM is
present, the result value is 1."
And when doing
call f(a)
call g(a)
with 'subroutine f(x); integer :: x(:)'
and 'subroutine g(y); integer :: y(..)'
Here, ubound == 0 due to the reason above and lbound is set to
the declared lower bound, which is for 'x' the default ("1") but
could also be 5 with "x(5:)" and for 'y' it cannot be specified.
For 'x', see last sentence of F2018:8.5.8.3. For 'y', I did not
find the exact location but it follows alongsize.
With BIND(C) applied to f and g, ubound remains the same but
lbound is now 0 instead of 1.
> Has the standard has changed in this respect?
I doubt it, but only looked at F2018 and not at older standards.
> I am probably not the best person to review the trans-* parts, but
> I did not spot anything I could point at, and the dump-tree looked
> reasonable. Therefore OK from my side.
>
> Thanks for the work!
Thanks also for your review.
Thanks,
Tobias
PS: I saw that we recently had a couple of double reviews. I think it is
useful if multiple persons look at patches, but hope that we do not
start requiring two reviews for each patch ;-)
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
[-- Attachment #2: committed.diff --]
[-- Type: text/x-patch, Size: 38867 bytes --]
commit 00f6de9c69119594f7dad3bd525937c94c8200d0
Author: Tobias Burnus <tobias@codesourcery.com>
Date: Mon Sep 27 14:04:54 2021 +0200
Fortran: Fix assumed-size to assumed-rank passing [PR94070]
This code inlines the size0 and size1 libgfortran calls, the former is still
used by libgfortan itself (and by old code). Besides permitting more
optimizations, it also permits to handle assumed-rank dummies better: If the
dummy argument is a nonpointer/nonallocatable, an assumed-size actual arg is
repesented by having ubound == -1 for the last dimension. However, for
allocatable/pointers, this value can also exist. Hence, the dummy arg attr
has to be honored.
For that reason, when calling an assumed-rank procedure with nonpointer,
nonallocatable dummy arguments, the bounds have to be updated to avoid
the case ubound == -1 for the last dimension.
PR fortran/94070
gcc/fortran/ChangeLog:
* trans-array.c (gfc_tree_array_size): New function to
find size inline (whole array or one dimension).
(array_parameter_size): Use it, take stmt_block as arg.
(gfc_conv_array_parameter): Update call.
* trans-array.h (gfc_tree_array_size): Add prototype.
* trans-decl.c (gfor_fndecl_size0, gfor_fndecl_size1): Remove
these global vars.
(gfc_build_intrinsic_function_decls): Remove their initialization.
* trans-expr.c (gfc_conv_procedure_call): Update
bounds of pointer/allocatable actual args to nonallocatable/nonpointer
dummies to be one based.
* trans-intrinsic.c (gfc_conv_intrinsic_shape): Fix case for
assumed rank with allocatable/pointer dummy.
(gfc_conv_intrinsic_size): Update to use inline function.
* trans.h (gfor_fndecl_size0, gfor_fndecl_size1): Remove var decl.
libgfortran/ChangeLog:
* intrinsics/size.c (size0, size1): Comment that now not
used by newer compiler code.
libgomp/ChangeLog:
* testsuite/libgomp.oacc-fortran/privatized-ref-2.f90: Update
expected dg-note output.
gcc/testsuite/ChangeLog:
* gfortran.dg/c-interop/cf-out-descriptor-6.f90: Remove xfail.
* gfortran.dg/c-interop/size.f90: Remove xfail.
* gfortran.dg/intrinsic_size_3.f90: Update scan-tree-dump-times.
* gfortran.dg/transpose_optimization_2.f90: Likewise.
* gfortran.dg/size_optional_dim_1.f90: Add scan-tree-dump-not.
* gfortran.dg/assumed_rank_22.f90: New test.
* gfortran.dg/assumed_rank_22_aux.c: New test.
---
gcc/fortran/trans-array.c | 165 ++++++++++++++++----
gcc/fortran/trans-array.h | 2 +
gcc/fortran/trans-decl.c | 14 --
gcc/fortran/trans-expr.c | 43 +++++-
gcc/fortran/trans-intrinsic.c | 119 ++++++---------
gcc/fortran/trans.h | 2 -
gcc/testsuite/gfortran.dg/assumed_rank_22.f90 | 169 +++++++++++++++++++++
gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c | 68 +++++++++
.../gfortran.dg/c-interop/cf-out-descriptor-6.f90 | 2 +-
gcc/testsuite/gfortran.dg/c-interop/size.f90 | 2 +-
gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 | 2 +-
gcc/testsuite/gfortran.dg/size_optional_dim_1.f90 | 4 +
.../gfortran.dg/transpose_optimization_2.f90 | 2 +-
libgfortran/intrinsics/size.c | 4 +
.../libgomp.oacc-fortran/privatized-ref-2.f90 | 13 +-
15 files changed, 482 insertions(+), 129 deletions(-)
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0d013defdbb..b8061f37772 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7901,31 +7901,143 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gfc_cleanup_loop (&loop);
}
+
+/* Calculate the array size (number of elements); if dim != NULL_TREE,
+ return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P). */
+tree
+gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
+{
+ if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+ {
+ gcc_assert (dim == NULL_TREE);
+ return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
+ }
+ tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
+ symbol_attribute attr = gfc_expr_attr (expr);
+ gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
+ if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
+ || !dim)
+ {
+ if (expr->rank < 0)
+ rank = fold_convert (signed_char_type_node,
+ gfc_conv_descriptor_rank (desc));
+ else
+ rank = build_int_cst (signed_char_type_node, expr->rank);
+ }
+
+ if (dim || expr->rank == 1)
+ {
+ if (!dim)
+ dim = gfc_index_zero_node;
+ tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
+ tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
+
+ size = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, ubound, lbound);
+ size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ size, gfc_index_one_node);
+ /* if (!allocatable && !pointer && assumed rank)
+ size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
+ else
+ size = max (0, size); */
+ size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
+ size, gfc_index_zero_node);
+ if (!attr.pointer && !attr.allocatable
+ && as && as->type == AS_ASSUMED_RANK)
+ {
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
+ rank, build_int_cst (signed_char_type_node, 1));
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ fold_convert (signed_char_type_node, dim),
+ tmp);
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ gfc_conv_descriptor_ubound_get (desc, dim),
+ build_int_cst (gfc_array_index_type, -1));
+ cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
+ cond, tmp);
+ tmp = build_int_cst (gfc_array_index_type, -1);
+ size = build3_loc (input_location, COND_EXPR, gfc_array_index_type,
+ cond, tmp, size);
+ }
+ return size;
+ }
+
+ /* size = 1. */
+ size = gfc_create_var (gfc_array_index_type, "size");
+ gfc_add_modify (block, size, build_int_cst (TREE_TYPE (size), 1));
+ tree extent = gfc_create_var (gfc_array_index_type, "extent");
+
+ stmtblock_t cond_block, loop_body;
+ gfc_init_block (&cond_block);
+ gfc_init_block (&loop_body);
+
+ /* Loop: for (i = 0; i < rank; ++i). */
+ tree idx = gfc_create_var (signed_char_type_node, "idx");
+ /* Loop body. */
+ /* #if (assumed-rank + !allocatable && !pointer)
+ if (idx == rank - 1 && dim[idx].ubound == -1)
+ extent = -1;
+ else
+ #endif
+ extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
+ if (extent < 0)
+ extent = 0
+ size *= extent. */
+ cond = NULL_TREE;
+ if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
+ {
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
+ rank, build_int_cst (signed_char_type_node, 1));
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ idx, tmp);
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ gfc_conv_descriptor_ubound_get (desc, idx),
+ build_int_cst (gfc_array_index_type, -1));
+ cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
+ cond, tmp);
+ }
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound_get (desc, idx),
+ gfc_conv_descriptor_lbound_get (desc, idx));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ gfc_add_modify (&cond_block, extent, tmp);
+ tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ extent, gfc_index_zero_node);
+ tmp = build3_v (COND_EXPR, tmp,
+ fold_build2_loc (input_location, MODIFY_EXPR,
+ gfc_array_index_type,
+ extent, gfc_index_zero_node),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&cond_block, tmp);
+ tmp = gfc_finish_block (&cond_block);
+ if (cond)
+ tmp = build3_v (COND_EXPR, cond,
+ fold_build2_loc (input_location, MODIFY_EXPR,
+ gfc_array_index_type, extent,
+ build_int_cst (gfc_array_index_type, -1)),
+ tmp);
+ gfc_add_expr_to_block (&loop_body, tmp);
+ /* size *= extent. */
+ gfc_add_modify (&loop_body, size,
+ fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ size, extent));
+ /* Generate loop. */
+ gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR,
+ build_int_cst (TREE_TYPE (idx), 1),
+ gfc_finish_block (&loop_body));
+ return size;
+}
+
/* Helper function for gfc_conv_array_parameter if array size needs to be
computed. */
static void
-array_parameter_size (tree desc, gfc_expr *expr, tree *size)
+array_parameter_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree *size)
{
tree elem;
- if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
- *size = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
- else if (expr->rank > 1)
- *size = build_call_expr_loc (input_location,
- gfor_fndecl_size0, 1,
- gfc_build_addr_expr (NULL, desc));
- else
- {
- tree ubound = gfc_conv_descriptor_ubound_get (desc, gfc_index_zero_node);
- tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_index_zero_node);
-
- *size = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, ubound, lbound);
- *size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- *size, gfc_index_one_node);
- *size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
- *size, gfc_index_zero_node);
- }
+ *size = gfc_tree_array_size (block, desc, expr, NULL);
elem = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
*size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
*size, fold_convert (gfc_array_index_type, elem));
@@ -8035,7 +8147,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
else
se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
if (size)
- array_parameter_size (tmp, expr, size);
+ array_parameter_size (&se->pre, tmp, expr, size);
return;
}
@@ -8047,7 +8159,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
tmp = se->expr;
}
if (size)
- array_parameter_size (tmp, expr, size);
+ array_parameter_size (&se->pre, tmp, expr, size);
se->expr = gfc_conv_array_data (tmp);
return;
}
@@ -8122,7 +8234,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
if (expr->ts.type == BT_CHARACTER && expr->expr_type != EXPR_FUNCTION)
se->string_length = expr->ts.u.cl->backend_decl;
if (size)
- array_parameter_size (se->expr, expr, size);
+ array_parameter_size (&se->pre, se->expr, expr, size);
se->expr = gfc_conv_array_data (se->expr);
return;
}
@@ -8132,7 +8244,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
/* Result of the enclosing function. */
gfc_conv_expr_descriptor (se, expr);
if (size)
- array_parameter_size (se->expr, expr, size);
+ array_parameter_size (&se->pre, se->expr, expr, size);
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
if (g77 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
@@ -8149,9 +8261,10 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
gfc_conv_expr_descriptor (se, expr);
if (size)
- array_parameter_size (build_fold_indirect_ref_loc (input_location,
- se->expr),
- expr, size);
+ array_parameter_size (&se->pre,
+ build_fold_indirect_ref_loc (input_location,
+ se->expr),
+ expr, size);
}
/* Deallocate the allocatable components of structures that are
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index e4d443d7118..85ff2161191 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -39,6 +39,8 @@ void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *);
/* Generate entry and exit code for g77 calling convention arrays. */
void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *);
+tree gfc_tree_array_size (stmtblock_t *, tree, gfc_expr *, tree);
+
tree gfc_full_array_size (stmtblock_t *, tree, int);
tree gfc_duplicate_allocatable (tree, tree, tree, int, tree);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 3bd8a0fe935..c758d26febf 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -214,8 +214,6 @@ tree gfor_fndecl_convert_char4_to_char1;
/* Other misc. runtime library functions. */
-tree gfor_fndecl_size0;
-tree gfor_fndecl_size1;
tree gfor_fndecl_iargc;
tree gfor_fndecl_kill;
tree gfor_fndecl_kill_sub;
@@ -3692,18 +3690,6 @@ gfc_build_intrinsic_function_decls (void)
}
/* Other functions. */
- gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("size0")), ". R ",
- gfc_array_index_type, 1, pvoid_type_node);
- DECL_PURE_P (gfor_fndecl_size0) = 1;
- TREE_NOTHROW (gfor_fndecl_size0) = 1;
-
- gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("size1")), ". R . ",
- gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
- DECL_PURE_P (gfor_fndecl_size1) = 1;
- TREE_NOTHROW (gfor_fndecl_size1) = 1;
-
gfor_fndecl_iargc = gfc_build_library_function_decl (
get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
TREE_NOTHROW (gfor_fndecl_iargc) = 1;
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 41d5452aecf..1c24556c299 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6450,6 +6450,29 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
parmse.force_tmp = 1;
}
+ /* Special case for assumed-rank arrays: when passing an
+ argument to a nonallocatable/nonpointer dummy, the bounds have
+ to be reset as otherwise a last-dim ubound of -1 is
+ indistinguishable from an assumed-size array in the callee. */
+ if (!sym->attr.is_bind_c && e && fsym && fsym->as
+ && fsym->as->type == AS_ASSUMED_RANK
+ && e->rank != -1
+ && e->expr_type == EXPR_VARIABLE
+ && ((fsym->ts.type == BT_CLASS
+ && !CLASS_DATA (fsym)->attr.class_pointer
+ && !CLASS_DATA (fsym)->attr.allocatable)
+ || (fsym->ts.type != BT_CLASS
+ && !fsym->attr.pointer && !fsym->attr.allocatable)))
+ {
+ /* Change AR_FULL to a (:,:,:) ref to force bounds update. */
+ gfc_ref *ref;
+ for (ref = e->ref; ref->next; ref = ref->next)
+ ;
+ if (ref->u.ar.type == AR_FULL
+ && ref->u.ar.as->type != AS_ASSUMED_SIZE)
+ ref->u.ar.type = AR_SECTION;
+ }
+
if (sym->attr.is_bind_c && e
&& (is_CFI_desc (fsym, NULL) || assumed_length_string))
/* Implement F2018, 18.3.6, list item (5), bullet point 2. */
@@ -6510,16 +6533,26 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
sym->name, NULL);
- /* Unallocated allocatable arrays and unassociated pointer arrays
- need their dtype setting if they are argument associated with
- assumed rank dummies, unless already assumed rank. */
+ /* Special case for assumed-rank arrays. */
if (!sym->attr.is_bind_c && e && fsym && fsym->as
&& fsym->as->type == AS_ASSUMED_RANK
&& e->rank != -1)
{
- if (gfc_expr_attr (e).pointer
+ if ((gfc_expr_attr (e).pointer
|| gfc_expr_attr (e).allocatable)
- set_dtype_for_unallocated (&parmse, e);
+ && ((fsym->ts.type == BT_CLASS
+ && (CLASS_DATA (fsym)->attr.class_pointer
+ || CLASS_DATA (fsym)->attr.allocatable))
+ || (fsym->ts.type != BT_CLASS
+ && (fsym->attr.pointer || fsym->attr.allocatable))))
+ {
+ /* Unallocated allocatable arrays and unassociated pointer
+ arrays need their dtype setting if they are argument
+ associated with assumed rank dummies. However, if the
+ dummy is nonallocate/nonpointer, the user may not
+ pass those. Hence, it can be skipped. */
+ set_dtype_for_unallocated (&parmse, e);
+ }
else if (e->expr_type == EXPR_VARIABLE
&& e->ref
&& e->ref->u.ar.type == AR_FULL
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 60e94f0bdc2..900a1a29817 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -6697,6 +6697,8 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
gfc_expr *e;
gfc_array_spec *as;
gfc_ss *ss;
+ symbol_attribute attr;
+ tree result_desc = se->expr;
/* Remove the KIND argument, if present. */
s = expr->value.function.actual;
@@ -6707,17 +6709,25 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
gfc_conv_intrinsic_funcall (se, expr);
- as = gfc_get_full_arrayspec_from_expr (s->expr);;
- ss = gfc_walk_expr (s->expr);
-
/* According to F2018 16.9.172, para 5, an assumed rank entity, argument
associated with an assumed size array, has the ubound of the final
dimension set to -1 and SHAPE must return this. */
- if (as && as->type == AS_ASSUMED_RANK
- && se->expr && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))
- && ss && ss->info->type == GFC_SS_SECTION)
+
+ as = gfc_get_full_arrayspec_from_expr (s->expr);
+ if (!as || as->type != AS_ASSUMED_RANK)
+ return;
+ attr = gfc_expr_attr (s->expr);
+ ss = gfc_walk_expr (s->expr);
+ if (attr.pointer || attr.allocatable
+ || !ss || ss->info->type != GFC_SS_SECTION)
+ return;
+ if (se->expr)
+ result_desc = se->expr;
+ if (POINTER_TYPE_P (TREE_TYPE (result_desc)))
+ result_desc = build_fold_indirect_ref_loc (input_location, result_desc);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (result_desc)))
{
- tree desc, rank, minus_one, cond, ubound, tmp;
+ tree rank, minus_one, cond, ubound, tmp;
stmtblock_t block;
gfc_se ase;
@@ -6745,8 +6755,7 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
/* Obtain the last element of the result from the library shape
intrinsic and set it to -1 if that is the value of ubound. */
- desc = se->expr;
- tmp = gfc_conv_array_data (desc);
+ tmp = gfc_conv_array_data (result_desc);
tmp = build_fold_indirect_ref_loc (input_location, tmp);
tmp = gfc_build_array_ref (tmp, rank, NULL, NULL);
@@ -6758,7 +6767,6 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->pre, cond);
}
-
}
static void
@@ -7968,8 +7976,7 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
gfc_actual_arglist *actual;
tree arg1;
tree type;
- tree fncall0;
- tree fncall1;
+ tree size;
gfc_se argse;
gfc_expr *e;
gfc_symbol *sym = NULL;
@@ -8046,37 +8053,31 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
/* For functions that return a class array conv_expr_descriptor is not
able to get the descriptor right. Therefore this special case. */
gfc_conv_expr_reference (&argse, e);
- argse.expr = gfc_build_addr_expr (NULL_TREE,
- gfc_class_data_get (argse.expr));
+ argse.expr = gfc_class_data_get (argse.expr);
}
else if (sym && sym->backend_decl)
{
gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (sym->backend_decl)));
- argse.expr = sym->backend_decl;
- argse.expr = gfc_build_addr_expr (NULL_TREE,
- gfc_class_data_get (argse.expr));
+ argse.expr = gfc_class_data_get (sym->backend_decl);
}
else
- {
- argse.want_pointer = 1;
- gfc_conv_expr_descriptor (&argse, actual->expr);
- }
+ gfc_conv_expr_descriptor (&argse, actual->expr);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
- arg1 = gfc_evaluate_now (argse.expr, &se->pre);
-
- /* Build the call to size0. */
- fncall0 = build_call_expr_loc (input_location,
- gfor_fndecl_size0, 1, arg1);
+ arg1 = argse.expr;
actual = actual->next;
-
if (actual->expr)
{
+ stmtblock_t block;
+ gfc_init_block (&block);
gfc_init_se (&argse, NULL);
gfc_conv_expr_type (&argse, actual->expr,
gfc_array_index_type);
- gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&block, &argse.pre);
+ tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ argse.expr, gfc_index_one_node);
+ size = gfc_tree_array_size (&block, arg1, e, tmp);
/* Unusually, for an intrinsic, size does not exclude
an optional arg2, so we must test for it. */
@@ -8084,59 +8085,35 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
&& actual->expr->symtree->n.sym->attr.dummy
&& actual->expr->symtree->n.sym->attr.optional)
{
- tree tmp;
- /* Build the call to size1. */
- fncall1 = build_call_expr_loc (input_location,
- gfor_fndecl_size1, 2,
- arg1, argse.expr);
-
+ tree cond;
+ stmtblock_t block2;
+ gfc_init_block (&block2);
gfc_init_se (&argse, NULL);
argse.want_pointer = 1;
argse.data_not_needed = 1;
gfc_conv_expr (&argse, actual->expr);
gfc_add_block_to_block (&se->pre, &argse.pre);
- tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
- argse.expr, null_pointer_node);
- tmp = gfc_evaluate_now (tmp, &se->pre);
- se->expr = fold_build3_loc (input_location, COND_EXPR,
- pvoid_type_node, tmp, fncall1, fncall0);
+ cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ argse.expr, null_pointer_node);
+ cond = gfc_evaluate_now (cond, &se->pre);
+ /* 'block2' contains the arg2 absent case, 'block' the arg2 present
+ case; size_var can be used in both blocks. */
+ tree size_var = gfc_tree_array_size (&block2, arg1, e, NULL_TREE);
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (size_var), size_var, size);
+ gfc_add_expr_to_block (&block, tmp);
+ tmp = build3_v (COND_EXPR, cond, gfc_finish_block (&block),
+ gfc_finish_block (&block2));
+ gfc_add_expr_to_block (&se->pre, tmp);
+ size = size_var;
}
else
- {
- se->expr = NULL_TREE;
- argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- argse.expr, gfc_index_one_node);
- }
- }
- else if (expr->value.function.actual->expr->rank == 1)
- {
- argse.expr = gfc_index_zero_node;
- se->expr = NULL_TREE;
+ gfc_add_block_to_block (&se->pre, &block);
}
else
- se->expr = fncall0;
-
- if (se->expr == NULL_TREE)
- {
- tree ubound, lbound;
-
- arg1 = build_fold_indirect_ref_loc (input_location,
- arg1);
- ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
- lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
- se->expr = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, ubound, lbound);
- se->expr = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- se->expr, gfc_index_one_node);
- se->expr = fold_build2_loc (input_location, MAX_EXPR,
- gfc_array_index_type, se->expr,
- gfc_index_zero_node);
- }
-
+ size = gfc_tree_array_size (&se->pre, arg1, e, NULL_TREE);
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = convert (type, se->expr);
+ se->expr = convert (type, size);
}
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 4d29834dc52..53f0f86b265 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -960,8 +960,6 @@ extern GTY(()) tree gfor_fndecl_convert_char1_to_char4;
extern GTY(()) tree gfor_fndecl_convert_char4_to_char1;
/* Other misc. runtime library functions. */
-extern GTY(()) tree gfor_fndecl_size0;
-extern GTY(()) tree gfor_fndecl_size1;
extern GTY(()) tree gfor_fndecl_iargc;
extern GTY(()) tree gfor_fndecl_kill;
extern GTY(()) tree gfor_fndecl_kill_sub;
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_22.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_22.f90
new file mode 100644
index 00000000000..8be0c106da6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_22.f90
@@ -0,0 +1,169 @@
+! { dg-do run }
+! { dg-additional-sources assumed_rank_22_aux.c }
+! { dg-additional-options "-fdump-tree-original" }
+!
+! FIXME: wrong extend in array descriptor, see C file.
+! { dg-output "c_assumed - 40 - OK" { xfail *-*-* } }
+! { dg-output "c_assumed - 100 - OK" { xfail *-*-* } }
+!
+! PR fortran/94070
+!
+! Contributed by Tobias Burnus
+! and José Rui Faustino de Sousa
+!
+program main
+ implicit none
+ integer :: A(5,4,2)
+ integer, allocatable :: B(:,:,:)
+ integer :: C(5,4,-2:-1)
+
+ interface
+ subroutine c_assumed (x, num) bind(C)
+ integer :: x(..)
+ integer, value :: num
+ end subroutine
+ subroutine c_allocated (x) bind(C)
+ integer, allocatable :: x(..)
+ end subroutine
+ end interface
+
+ allocate (B(-1:3,4,-1:-1))
+
+ call caller (a) ! num=0: assumed-size
+ call test (b, num=20) ! full array
+ call test (b(:,:,0:-1), num=40) ! zero-sized array
+ call test (c, num=60)
+ call test (c(:,:,:-1), num=80) ! full-size slice
+ call test (c(:,:,1:-1), num=100) !zero-size array
+
+ call test_alloc(b)
+
+ call c_assumed (b, num=20)
+ call c_assumed (b(:,:,0:-1), num=40)
+ call c_assumed (c, num=60)
+ call c_assumed (c(:,:,:-1), num=80)
+ call c_assumed (c(:,:,1:-1), num=100)
+
+ call c_allocated (b)
+contains
+ subroutine caller(y)
+ integer :: y(-1:3,4,*)
+ call test(y, num=0)
+ call c_assumed (y, num=0)
+ end
+ subroutine test (x, num)
+ integer :: x(..), num
+
+ ! SIZE (x)
+ if (num == 0) then
+ if (size (x) /= -20) stop 1
+ elseif (num == 20) then
+ if (size (x) /= 20) stop 21
+ elseif (num == 40) then
+ if (size (x) /= 0) stop 41
+ elseif (num == 60) then
+ if (size (x) /= 40) stop 61
+ elseif (num == 80) then
+ if (size (x) /= 40) stop 81
+ elseif (num == 100) then
+ if (size (x) /= 0) stop 101
+ else
+ stop 99 ! Invalid num
+ endif
+
+ ! SIZE (x, dim=...)
+ if (size (x, dim=1) /= 5) stop num + 2
+ if (size (x, dim=2) /= 4) stop num + 3
+
+ if (num == 0) then
+ if (size (x, dim=3) /= -1) stop 4
+ elseif (num == 20) then
+ if (size (x, dim=3) /= 1) stop 24
+ elseif (num == 40) then
+ if (size (x, dim=3) /= 0) stop 44
+ elseif (num == 60) then
+ if (size (x, dim=3) /= 2) stop 64
+ elseif (num == 80) then
+ if (size (x, dim=3) /= 2) stop 84
+ elseif (num == 100) then
+ if (size (x, dim=3) /= 0) stop 104
+ endif
+
+ ! SHAPE (x)
+ if (num == 0) then
+ if (any (shape (x) /= [5, 4, -1])) stop 5
+ elseif (num == 20) then
+ if (any (shape (x) /= [5, 4, 1])) stop 25
+ elseif (num == 40) then
+ if (any (shape (x) /= [5, 4, 0])) stop 45
+ elseif (num == 60) then
+ if (any (shape (x) /= [5, 4, 2])) stop 65
+ elseif (num == 80) then
+ if (any (shape (x) /= [5, 4, 2])) stop 85
+ elseif (num == 100) then
+ if (any (shape (x) /= [5, 4, 0])) stop 105
+ endif
+
+ ! LBOUND (X)
+ if (any (lbound (x) /= [1, 1, 1])) stop num + 6
+
+ ! LBOUND (X, dim=...)
+ if (lbound (x, dim=1) /= 1) stop num + 7
+ if (lbound (x, dim=2) /= 1) stop num + 8
+ if (lbound (x, dim=3) /= 1) stop num + 9
+
+ ! UBOUND (X)
+ if (num == 0) then
+ if (any (ubound (x) /= [5, 4, -1])) stop 11
+ elseif (num == 20) then
+ if (any (ubound (x) /= [5, 4, 1])) stop 31
+ elseif (num == 40) then
+ if (any (ubound (x) /= [5, 4, 0])) stop 51
+ elseif (num == 60) then
+ if (any (ubound (x) /= [5, 4, 2])) stop 71
+ elseif (num == 80) then
+ if (any (ubound (x) /= [5, 4, 2])) stop 91
+ elseif (num == 100) then
+ if (any (ubound (x) /= [5, 4, 0])) stop 111
+ endif
+
+ ! UBOUND (X, dim=...)
+ if (ubound (x, dim=1) /= 5) stop num + 12
+ if (ubound (x, dim=2) /= 4) stop num + 13
+ if (num == 0) then
+ if (ubound (x, dim=3) /= -1) stop 14
+ elseif (num == 20) then
+ if (ubound (x, dim=3) /= 1) stop 34
+ elseif (num == 40) then
+ if (ubound (x, dim=3) /= 0) stop 54
+ elseif (num == 60) then
+ if (ubound (x, dim=3) /= 2) stop 74
+ elseif (num == 80) then
+ if (ubound (x, dim=3) /= 2) stop 94
+ elseif (num == 100) then
+ if (ubound (x, dim=3) /= 0) stop 114
+ endif
+ end
+
+ subroutine test_alloc (x)
+ integer, allocatable :: x(..)
+
+ if (size (x) /= 20) stop 61
+ if (size (x, dim=1) /= 5) stop 62
+ if (size (x, dim=2) /= 4) stop 63
+ if (size (x, dim=3) /= 1) stop 64
+
+ if (any (shape (x) /= [5, 4, 1])) stop 65
+
+ if (any (lbound (x) /= [-1, 1, -1])) stop 66
+ if (lbound (x, dim=1) /= -1) stop 77
+ if (lbound (x, dim=2) /= 1) stop 78
+ if (lbound (x, dim=3) /= -1) stop 79
+
+ if (any (ubound (x) /= [3, 4, -1])) stop 80
+ if (ubound (x, dim=1) /= 3) stop 92
+ if (ubound (x, dim=2) /= 4) stop 93
+ if (ubound (x, dim=3) /= -1) stop 94
+ end
+end
+! { dg-final { scan-tree-dump-not "_gfortran_size" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c b/gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c
new file mode 100644
index 00000000000..2fbf83d649a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c
@@ -0,0 +1,68 @@
+/* Called by assumed_rank_22.f90. */
+
+#include <ISO_Fortran_binding.h>
+#include <assert.h>
+
+void
+c_assumed (CFI_cdesc_t *x, int num)
+{
+ assert (num == 0 || num == 20 || num == 40 || num == 60 || num == 80
+ || num == 100);
+ assert (x->elem_len == sizeof (int));
+ assert (x->rank == 3);
+ assert (x->type == CFI_type_int32_t);
+
+ assert (x->attribute == CFI_attribute_other);
+ assert (x->dim[0].lower_bound == 0);
+ assert (x->dim[1].lower_bound == 0);
+ assert (x->dim[2].lower_bound == 0);
+ assert (x->dim[0].extent == 5);
+ assert (x->dim[1].extent == 4);
+ if (num == 0)
+ assert (x->dim[2].extent == -1);
+ else if (num == 20)
+ assert (x->dim[2].extent == 1);
+ else if (num == 40)
+ {
+ /* FIXME: - dg-output = 'c_assumed ... OK' checked in .f90 file. */
+ /* assert (x->dim[2].extent == 0); */
+ if (x->dim[2].extent == 0)
+ __builtin_printf ("c_assumed - 40 - OK\n");
+ else
+ __builtin_printf ("ERROR: c_assumed num=%d: "
+ "x->dim[2].extent = %d != 0\n",
+ num, x->dim[2].extent);
+ }
+ else if (num == 60)
+ assert (x->dim[2].extent == 2);
+ else if (num == 80)
+ assert (x->dim[2].extent == 2);
+ else if (num == 100)
+ {
+ /* FIXME: - dg-output = 'c_assumed ... OK' checked in .f90 file. */
+ /* assert (x->dim[2].extent == 0); */
+ if (x->dim[2].extent == 0)
+ __builtin_printf ("c_assumed - 100 - OK\n");
+ else
+ __builtin_printf ("ERROR: c_assumed num=%d: "
+ "x->dim[2].extent = %d != 0\n",
+ num, x->dim[2].extent);
+ }
+ else
+ assert (0);
+}
+
+void
+c_allocated (CFI_cdesc_t *x)
+{
+ assert (x->elem_len == sizeof (int));
+ assert (x->rank == 3);
+ assert (x->type == CFI_type_int32_t);
+ assert (x->attribute == CFI_attribute_allocatable);
+ assert (x->dim[0].lower_bound == -1);
+ assert (x->dim[1].lower_bound == 1);
+ assert (x->dim[2].lower_bound == -1);
+ assert (x->dim[0].extent == 5);
+ assert (x->dim[1].extent == 4);
+ assert (x->dim[2].extent == 1);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90
index b1a8c53b3e8..bc19a71efa7 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90
@@ -1,5 +1,5 @@
! Reported as pr94070.
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "cf-out-descriptor-6-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
diff --git a/gcc/testsuite/gfortran.dg/c-interop/size.f90 b/gcc/testsuite/gfortran.dg/c-interop/size.f90
index 6c6699701bf..58b32b0d5e7 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/size.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/size.f90
@@ -1,5 +1,5 @@
! Reported as pr94070.
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
!
! TS 29113
! 6.4.2 SIZE
diff --git a/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 b/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90
index 923cbc3473d..afdf9b34d4b 100644
--- a/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90
+++ b/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90
@@ -22,4 +22,4 @@ program bug
stop
end program bug
-! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) MAX_EXPR <\\(D.\[0-9\]+->dim.0..ubound - D.\[0-9\]+->dim.0..lbound\\) \\+ 1, 0>;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) MAX_EXPR <\\(a.dim.0..ubound - a.dim.0..lbound\\) \\+ 1, 0>;" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/size_optional_dim_1.f90 b/gcc/testsuite/gfortran.dg/size_optional_dim_1.f90
index c6e8f761538..cbf4aa4812e 100644
--- a/gcc/testsuite/gfortran.dg/size_optional_dim_1.f90
+++ b/gcc/testsuite/gfortran.dg/size_optional_dim_1.f90
@@ -1,4 +1,5 @@
! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
! PR 30865 - passing a subroutine optional argument to size(dim=...)
! used to segfault.
program main
@@ -19,3 +20,6 @@ contains
ires = size (a1, dim=opt1)
end subroutine checkv
end program main
+
+! Ensure inline code is generated, cf. PR fortran/94070
+! { dg-final { scan-tree-dump-not "_gfortran_size" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90
index c49cd421058..54271b12bfa 100644
--- a/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90
+++ b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90
@@ -60,5 +60,5 @@ end
!
! The check below for temporaries gave 14 and 33 for "parm" and "atmp".
!
-! { dg-final { scan-tree-dump-times "parm" 72 "original" } }
+! { dg-final { scan-tree-dump-times "parm" 76 "original" } }
! { dg-final { scan-tree-dump-times "atmp" 13 "original" } }
diff --git a/libgfortran/intrinsics/size.c b/libgfortran/intrinsics/size.c
index e9d93861eff..f1a60ba7209 100644
--- a/libgfortran/intrinsics/size.c
+++ b/libgfortran/intrinsics/size.c
@@ -25,6 +25,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include "libgfortran.h"
+/* Note: This function is only used internally in libgfortran and old FE code,
+ new code generates the code inline. */
index_type
size0 (const array_t * array)
{
@@ -47,6 +49,8 @@ iexport(size0);
extern index_type size1 (const array_t * array, index_type dim);
export_proto(size1);
+/* Note: This function it is unused in libgfortran itself and the FE no longer
+ call it; however, old code might still call it. */
index_type
size1 (const array_t * array, index_type dim)
{
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90 b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
index baaee02b82c..2ff60226109 100644
--- a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
+++ b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
@@ -71,17 +71,16 @@ contains
! { dg-note {variable 'offset\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute }
! { dg-note {variable 'S\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute }
! { dg-note {variable 'test\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute }
- ! { dg-note {variable 'parm\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "" { target *-*-* } l_compute$c_compute }
- ! { dg-note {variable 'parm\.[0-9]+' ought to be adjusted for OpenACC privatization level: 'gang'} "" { target *-*-* } l_compute$c_compute }
- ! { dg-note {variable 'parm\.[0-9]+' adjusted for OpenACC privatization level: 'gang'} "" { target { ! { openacc_host_selected || openacc_nvidia_accel_selected } } } l_compute$c_compute }
+ ! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_compute$c_compute }
! { dg-note {variable 'A\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: static} "" { target *-*-* } l_compute$c_compute }
array = [(-2*i, i = 1, size(array))]
!$acc loop gang private(array) ! { dg-line l_loop[incr c_loop] }
- ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
- ! { dg-note {variable 'array\.[0-9]+' in 'private' clause is candidate for adjusting OpenACC privatization level} "" { target *-*-* } l_loop$c_loop }
- ! { dg-note {variable 'array\.[0-9]+' ought to be adjusted for OpenACC privatization level: 'gang'} "" { target *-*-* } l_loop$c_loop }
- ! { dg-note {variable 'array\.[0-9]+' adjusted for OpenACC privatization level: 'gang'} "" { target { ! { openacc_host_selected || openacc_nvidia_accel_selected } } } l_loop$c_loop }
+ ! { dg-message {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
+ ! { dg-message {variable 'array\.[0-9]+' in 'private' clause is candidate for adjusting OpenACC privatization level} "" { target *-*-* } l_loop$c_loop }
+ ! { dg-message {variable 'array\.[0-9]+' ought to be adjusted for OpenACC privatization level: 'gang'} "" { target *-*-* } l_loop$c_loop }
+
! { dg-message {sorry, unimplemented: target cannot support alloca} PR65181 { target openacc_nvidia_accel_selected } l_loop$c_loop }
+
do i = 1, 10
array(i) = 9*i
end do
^ permalink raw reply [flat|nested] 9+ messages in thread
* [committed] libgomp.oacc-fortran/privatized-ref-2.f90: Fix dg-note (was: [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070])
2021-09-27 12:07 ` Tobias Burnus
@ 2021-09-27 12:38 ` Tobias Burnus
2021-09-28 12:29 ` Thomas Schwinge
[not found] ` <sit6bi$sc3$1@ciao.gmane.io>
2021-09-28 12:30 ` Thomas Schwinge
2 siblings, 1 reply; 9+ messages in thread
From: Tobias Burnus @ 2021-09-27 12:38 UTC (permalink / raw)
To: gcc-patches, fortran
[-- Attachment #1: Type: text/plain, Size: 673 bytes --]
On 27.09.21 14:07, Tobias Burnus wrote:
> now committed r12-3897-g00f6de9c69119594f7dad3bd525937c94c8200d0
I accidentally changed dg-note to dg-message when updating the expected
output, as the dump has changed. (Copying seemingly the sorry line
instead of the dg-note lines as template.)
Changed back to dg-note & committed as
r12-3898-gda1f6391b7c255e4e2eea983832120eff4f7d3df.
Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
[-- Attachment #2: committed.diff --]
[-- Type: text/x-patch, Size: 2249 bytes --]
commit da1f6391b7c255e4e2eea983832120eff4f7d3df
Author: Tobias Burnus <tobias@codesourcery.com>
Date: Mon Sep 27 14:33:39 2021 +0200
libgomp.oacc-fortran/privatized-ref-2.f90: Fix dg-note
In my last commit, r12-3897-g00f6de9c69119594f7dad3bd525937c94c8200d0,
which inlined array-size code, I had to update the expected output. However,
in doing so, I accidentally (copy'n'paste) changed dg-note into dg-message.
libgomp/
* testsuite/libgomp.oacc-fortran/privatized-ref-2.f90: Change
dg-message back to dg-note.
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90 b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
index 2ff60226109..588f528b2d5 100644
--- a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
+++ b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
@@ -75,9 +75,9 @@ contains
! { dg-note {variable 'A\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: static} "" { target *-*-* } l_compute$c_compute }
array = [(-2*i, i = 1, size(array))]
!$acc loop gang private(array) ! { dg-line l_loop[incr c_loop] }
- ! { dg-message {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
- ! { dg-message {variable 'array\.[0-9]+' in 'private' clause is candidate for adjusting OpenACC privatization level} "" { target *-*-* } l_loop$c_loop }
- ! { dg-message {variable 'array\.[0-9]+' ought to be adjusted for OpenACC privatization level: 'gang'} "" { target *-*-* } l_loop$c_loop }
+ ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
+ ! { dg-note {variable 'array\.[0-9]+' in 'private' clause is candidate for adjusting OpenACC privatization level} "" { target *-*-* } l_loop$c_loop }
+ ! { dg-note {variable 'array\.[0-9]+' ought to be adjusted for OpenACC privatization level: 'gang'} "" { target *-*-* } l_loop$c_loop }
! { dg-message {sorry, unimplemented: target cannot support alloca} PR65181 { target openacc_nvidia_accel_selected } l_loop$c_loop }
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070]
[not found] ` <sit6bi$sc3$1@ciao.gmane.io>
@ 2021-09-28 6:40 ` Tobias Burnus
2021-09-28 19:15 ` Harald Anlauf
0 siblings, 1 reply; 9+ messages in thread
From: Tobias Burnus @ 2021-09-28 6:40 UTC (permalink / raw)
To: Harald Anlauf, gcc-patches; +Cc: fortran
Hi Harald, hi all,
On 27.09.21 21:34, Harald Anlauf via Gcc-patches wrote:
> [...] here is what I played with:
>
> program p
> implicit none
> integer, pointer :: x(:,:)
> allocate (x(-3:3,4:0))
> print *, "lbound =", lbound (x)
> call sub (x)
> contains
> subroutine sub (y)
> integer, pointer :: y(..)
> print *, "lbound =", lbound (y)
> print *, "ubound =", ubound (y)
> end subroutine sub
> end
(Slightly shortened)
> This prints:
>
> lbound = -3 1
> lbound = -3 1
> ubound = 3 0
>
> For some reason Intel prints different lbound
> lbound = -3 1
> lbound = -3 4
> ubound = 3 3
First, that should be rather unrelated to my patch as here
the dummy argument is a pointer (could be also allocatable),
where the argument is passed through "as is".
For the latter reason, the expectation is that, both in the
caller and callee, the result is the same - which ifort's
result isn't.
Otherwise, the quote from F2018 of my previous email applies:
F2018:16.9.109 LBOUND has for "case(i)", i.e. with a 'dim'
argument the following. The case without 'dim' just iterates
through case (i) for each dim. Thus:
"If DIM is present,
ARRAY is a whole array,
and either ARRAY is an assumed-size array of rank DIM
or dimension DIM of ARRAY has nonzero extent,
the result has a value equal to the lower bound for subscript DIM of ARRAY.
Otherwise, if DIM is present, the result value is 1."
Here, we assume dim=2 is present [either directly or via case(ii)],
ARRAY is a whole array but it neither is of assumed size nor has nonzero
extent.
Hence, the "otherwise" applies and the result is 1 - as gfortran has
and ifort has in the caller.
The ubound then follows – there is a long list of conditions which
are all not fulfilled (you could check to confirm this) and
remaining is then only:
"Otherwise, if DIM is present, the result has a value equal to the
number of elements in dimension DIM of ARRAY."
And following your quote, there are zero elements in dim=2 of your
array. → ubound(…, dim=2) == 0.
> So for the first dimension everything is fine, but for the
> second dim, which has extent zero, my question is: what should
> the lbound be? 1 or 4?
1
>> With BIND(C) applied to f and g, ubound remains the same but
>> lbound is now 0 instead of 1.
> I haven't check the BIND(C) complications.
There aren't real complications, except that with the C descriptor,
there is no lbound/ubound anymore but the descr->dim[i].lower_bound +
...[i].extent are directly referenced.
For GCC, the difference is that GCC uses lbound + ubound and CFI uses
lbound + extent. (The other difference is the use of stride in number of
elements vs. sm/stride multipler in number of bytes.)
The CFI array descriptor is IMHO more sensible than the GFC descriptor,
but for legacy reasons, we still carry it along.
> For "common" Fortran code, I looked at 9.7.1.2(1):
> ...
> It is the word "determine" in first sentence that made me stumble.
I think the Fortran standard does often not really tell what the bounds
are but just what lbound/ubound/size/shape produce. That's perfectly
fine – and permits different implementations in the background. (For C
interop, they had to specify, for obvious reasons, what's in the
descriptor itself.)
Cheers,
Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [committed] libgomp.oacc-fortran/privatized-ref-2.f90: Fix dg-note (was: [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070])
2021-09-27 12:38 ` [committed] libgomp.oacc-fortran/privatized-ref-2.f90: Fix dg-note (was: [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070]) Tobias Burnus
@ 2021-09-28 12:29 ` Thomas Schwinge
0 siblings, 0 replies; 9+ messages in thread
From: Thomas Schwinge @ 2021-09-28 12:29 UTC (permalink / raw)
To: Tobias Burnus, gcc-patches, fortran
[-- Attachment #1: Type: text/plain, Size: 1048 bytes --]
Hi!
On 2021-09-27T14:38:56+0200, Tobias Burnus <tobias@codesourcery.com> wrote:
> On 27.09.21 14:07, Tobias Burnus wrote:
>> now committed r12-3897-g00f6de9c69119594f7dad3bd525937c94c8200d0
>
> I accidentally changed dg-note to dg-message when updating the expected
> output, as the dump has changed. (Copying seemingly the sorry line
> instead of the dg-note lines as template.)
Strange. ;-P
> Changed back to dg-note & committed as
> r12-3898-gda1f6391b7c255e4e2eea983832120eff4f7d3df.
As shown by offloading testing, a bit more is necessary here; I've
pushed to master branch commit a43ae03a053faad871e6f48099d21e64b8e316cf
'Further test case adjustment re "Fortran: Fix assumed-size to
assumed-rank passing"', see attached.
Grüße
Thomas
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Further-test-case-adjustment-re-Fortran-Fix-assumed-.patch --]
[-- Type: text/x-diff, Size: 6188 bytes --]
From a43ae03a053faad871e6f48099d21e64b8e316cf Mon Sep 17 00:00:00 2001
From: Thomas Schwinge <thomas@codesourcery.com>
Date: Tue, 28 Sep 2021 08:05:28 +0200
Subject: [PATCH] Further test case adjustment re "Fortran: Fix assumed-size to
assumed-rank passing"
Fix-up for recent commit 00f6de9c69119594f7dad3bd525937c94c8200d0
"Fortran: Fix assumed-size to assumed-rank passing [PR94070]",
and commit da1f6391b7c255e4e2eea983832120eff4f7d3df
"libgomp.oacc-fortran/privatized-ref-2.f90: Fix dg-note".
Due to use of '#if !ACC_MEM_SHARED' conditionals in
'libgomp.oacc-fortran/if-1.f90', 'target { ! openacc_host_selected }'
needs some special care (ignoring the pre-existing mismatch of
'ACC_MEM_SHARED' vs. 'openacc_host_selected').
As seen with GCN offloading, we need to revert to another bit of the
original code in 'libgomp.oacc-fortran/privatized-ref-2.f90'.
libgomp/
* testsuite/libgomp.oacc-fortran/if-1.f90: Adjust.
* testsuite/libgomp.oacc-fortran/privatized-ref-2.f90: Likewise.
---
libgomp/testsuite/libgomp.oacc-fortran/if-1.f90 | 6 ++++++
libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90 | 3 +--
2 files changed, 7 insertions(+), 2 deletions(-)
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/if-1.f90 b/libgomp/testsuite/libgomp.oacc-fortran/if-1.f90
index 3089d6a0c43..9eadfcf9738 100644
--- a/libgomp/testsuite/libgomp.oacc-fortran/if-1.f90
+++ b/libgomp/testsuite/libgomp.oacc-fortran/if-1.f90
@@ -394,6 +394,7 @@ program main
!$acc data copyin (a(1:N)) copyout (b(1:N)) if (0 == 1)
! { dg-note {variable 'D\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target { ! openacc_host_selected } } .-1 }
+ ! { dg-note {variable 'parm\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "" { target { ! openacc_host_selected } } .-2 }
#if !ACC_MEM_SHARED
if (acc_is_present (a) .eqv. .TRUE.) STOP 21
@@ -408,6 +409,7 @@ program main
!$acc data copyin (a(1:N)) if (1 == 1)
! { dg-note {variable 'D\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-1 }
! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-2 }
+ ! { dg-note {variable 'parm\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "" { target { ! openacc_host_selected } } .-3 }
#if !ACC_MEM_SHARED
if (acc_is_present (a) .eqv. .FALSE.) STOP 23
@@ -416,6 +418,7 @@ program main
!$acc data copyout (b(1:N)) if (0 == 1)
! { dg-note {variable 'D\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-1 }
! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-2 }
+ ! { dg-note {variable 'parm\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "" { target { ! openacc_host_selected } } .-3 }
#if !ACC_MEM_SHARED
if (acc_is_present (b) .eqv. .TRUE.) STOP 24
#endif
@@ -864,6 +867,7 @@ program main
!$acc data copyin (a(1:N)) copyout (b(1:N)) if (0 == 1)
! { dg-note {variable 'D\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target { ! openacc_host_selected } } .-1 }
+ ! { dg-note {variable 'parm\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "" { target { ! openacc_host_selected } } .-2 }
#if !ACC_MEM_SHARED
if (acc_is_present (a) .eqv. .TRUE.) STOP 56
@@ -878,6 +882,7 @@ program main
!$acc data copyin (a(1:N)) if (1 == 1)
! { dg-note {variable 'D\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-1 }
! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-2 }
+ ! { dg-note {variable 'parm\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "" { target { ! openacc_host_selected } } .-3 }
#if !ACC_MEM_SHARED
if (acc_is_present (a) .eqv. .FALSE.) STOP 58
@@ -886,6 +891,7 @@ program main
!$acc data copyout (b(1:N)) if (0 == 1)
! { dg-note {variable 'D\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-1 }
! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-2 }
+ ! { dg-note {variable 'parm\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "" { target { ! openacc_host_selected } } .-3 }
#if !ACC_MEM_SHARED
if (acc_is_present (b) .eqv. .TRUE.) STOP 59
#endif
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90 b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
index 588f528b2d5..3f3a1b5966b 100644
--- a/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
+++ b/libgomp/testsuite/libgomp.oacc-fortran/privatized-ref-2.f90
@@ -78,9 +78,8 @@ contains
! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } l_loop$c_loop }
! { dg-note {variable 'array\.[0-9]+' in 'private' clause is candidate for adjusting OpenACC privatization level} "" { target *-*-* } l_loop$c_loop }
! { dg-note {variable 'array\.[0-9]+' ought to be adjusted for OpenACC privatization level: 'gang'} "" { target *-*-* } l_loop$c_loop }
-
+ ! { dg-note {variable 'array\.[0-9]+' adjusted for OpenACC privatization level: 'gang'} "" { target { ! { openacc_host_selected || openacc_nvidia_accel_selected } } } l_loop$c_loop }
! { dg-message {sorry, unimplemented: target cannot support alloca} PR65181 { target openacc_nvidia_accel_selected } l_loop$c_loop }
-
do i = 1, 10
array(i) = 9*i
end do
--
2.33.0
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070]
2021-09-27 12:07 ` Tobias Burnus
2021-09-27 12:38 ` [committed] libgomp.oacc-fortran/privatized-ref-2.f90: Fix dg-note (was: [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070]) Tobias Burnus
[not found] ` <sit6bi$sc3$1@ciao.gmane.io>
@ 2021-09-28 12:30 ` Thomas Schwinge
2 siblings, 0 replies; 9+ messages in thread
From: Thomas Schwinge @ 2021-09-28 12:30 UTC (permalink / raw)
To: Tobias Burnus, gcc-patches, fortran; +Cc: Thomas Koenig
[-- Attachment #1: Type: text/plain, Size: 2109 bytes --]
Hi!
On 2021-09-27T14:07:53+0200, Tobias Burnus <tobias@codesourcery.com> wrote:
> now committed r12-3897-g00f6de9c69119594f7dad3bd525937c94c8200d0
> Conclusion: Reviews are very helpful :-)
Ha! :-) (... and I wasn't even involed here!) ;-P
As testing showed here:
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c
> @@ -0,0 +1,68 @@
> +/* Called by assumed_rank_22.f90. */
> + if (num == 0)
> + assert (x->dim[2].extent == -1);
> + else if (num == 20)
> + assert (x->dim[2].extent == 1);
> + else if (num == 40)
> + {
> + /* FIXME: - dg-output = 'c_assumed ... OK' checked in .f90 file. */
> + /* assert (x->dim[2].extent == 0); */
> + if (x->dim[2].extent == 0)
> + __builtin_printf ("c_assumed - 40 - OK\n");
> + else
> + __builtin_printf ("ERROR: c_assumed num=%d: "
> + "x->dim[2].extent = %d != 0\n",
> + num, x->dim[2].extent);
> + }
> + else if (num == 60)
> + assert (x->dim[2].extent == 2);
> + else if (num == 80)
> + assert (x->dim[2].extent == 2);
> + else if (num == 100)
> + {
> + /* FIXME: - dg-output = 'c_assumed ... OK' checked in .f90 file. */
> + /* assert (x->dim[2].extent == 0); */
> + if (x->dim[2].extent == 0)
> + __builtin_printf ("c_assumed - 100 - OK\n");
> + else
> + __builtin_printf ("ERROR: c_assumed num=%d: "
> + "x->dim[2].extent = %d != 0\n",
> + num, x->dim[2].extent);
> + }
> + else
> + assert (0);
... the 'ERROR:' prefixes printed do confuse DejaGnu... As obvious,
pushed to master branch commit 95540a6d1d7b29cdd3ed06fbcb07465804504cfd
"'gfortran.dg/assumed_rank_22_aux.c' messages printed vs. DejaGnu", see
attached.
Grüße
Thomas
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-gfortran.dg-assumed_rank_22_aux.c-messages-printed-v.patch --]
[-- Type: text/x-diff, Size: 2122 bytes --]
From 95540a6d1d7b29cdd3ed06fbcb07465804504cfd Mon Sep 17 00:00:00 2001
From: Thomas Schwinge <thomas@codesourcery.com>
Date: Tue, 28 Sep 2021 09:02:56 +0200
Subject: [PATCH] 'gfortran.dg/assumed_rank_22_aux.c' messages printed vs.
DejaGnu
Print lower-case 'error: [...]' instead of upper-case 'ERROR: [...]', to not
confuse the DejaGnu log processing harness into thinking these are DejaGnu
harness ERRORs:
Running /scratch/tschwing/build2-trusty-cs/gcc/build/submit-big/source-gcc/gcc/testsuite/gfortran.dg/dg.exp ...
+ERROR: c_assumed num=100: x->dim[2].extent = -1 != 0
+ERROR: c_assumed num=100: x->dim[2].extent = -1 != 0
+ERROR: c_assumed num=100: x->dim[2].extent = -1 != 0
+ERROR: c_assumed num=100: x->dim[2].extent = -1 != 0
+ERROR: c_assumed num=100: x->dim[2].extent = -1 != 0
+ERROR: c_assumed num=100: x->dim[2].extent = -1 != 0
[...]
Fix-up for recent commit 00f6de9c69119594f7dad3bd525937c94c8200d0
"Fortran: Fix assumed-size to assumed-rank passing [PR94070]".
gcc/testsuite/
* gfortran.dg/assumed_rank_22_aux.c: Adjust messages printed.
---
gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c b/gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c
index 2fbf83d649a..e5fe02135e9 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_22_aux.c
@@ -29,7 +29,7 @@ c_assumed (CFI_cdesc_t *x, int num)
if (x->dim[2].extent == 0)
__builtin_printf ("c_assumed - 40 - OK\n");
else
- __builtin_printf ("ERROR: c_assumed num=%d: "
+ __builtin_printf ("error: c_assumed num=%d: "
"x->dim[2].extent = %d != 0\n",
num, x->dim[2].extent);
}
@@ -44,7 +44,7 @@ c_assumed (CFI_cdesc_t *x, int num)
if (x->dim[2].extent == 0)
__builtin_printf ("c_assumed - 100 - OK\n");
else
- __builtin_printf ("ERROR: c_assumed num=%d: "
+ __builtin_printf ("error: c_assumed num=%d: "
"x->dim[2].extent = %d != 0\n",
num, x->dim[2].extent);
}
--
2.33.0
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070]
2021-09-28 6:40 ` [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070] Tobias Burnus
@ 2021-09-28 19:15 ` Harald Anlauf
0 siblings, 0 replies; 9+ messages in thread
From: Harald Anlauf @ 2021-09-28 19:15 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc-patches, fortran
Hi Tobias,
let me first reach for my brown bag...
> Otherwise, the quote from F2018 of my previous email applies:
>
> F2018:16.9.109 LBOUND has for "case(i)", i.e. with a 'dim'
> argument the following. The case without 'dim' just iterates
> through case (i) for each dim. Thus:
>
> "If DIM is present,
> ARRAY is a whole array,
> and either ARRAY is an assumed-size array of rank DIM
> or dimension DIM of ARRAY has nonzero extent,
> the result has a value equal to the lower bound for subscript DIM of ARRAY.
> Otherwise, if DIM is present, the result value is 1."
It was probably too late, and I could no longer distinguish
"assumed-size" from "assumed-rank", and likely some more...
> Here, we assume dim=2 is present [either directly or via case(ii)],
> ARRAY is a whole array but it neither is of assumed size nor has nonzero
> extent.
> Hence, the "otherwise" applies and the result is 1 - as gfortran has
> and ifort has in the caller.
... which lead to my complete confusion and loss of focus.
Of course you are right. Sorry for that. Will now put that bag on...
Harald
^ permalink raw reply [flat|nested] 9+ messages in thread
end of thread, other threads:[~2021-09-28 19:15 UTC | newest]
Thread overview: 9+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-09-21 12:26 [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070] Tobias Burnus
2021-09-24 20:38 ` Thomas Koenig
2021-09-27 12:07 ` Tobias Burnus
2021-09-27 12:38 ` [committed] libgomp.oacc-fortran/privatized-ref-2.f90: Fix dg-note (was: [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070]) Tobias Burnus
2021-09-28 12:29 ` Thomas Schwinge
[not found] ` <sit6bi$sc3$1@ciao.gmane.io>
2021-09-28 6:40 ` [Patch] Fortran: Fix assumed-size to assumed-rank passing [PR94070] Tobias Burnus
2021-09-28 19:15 ` Harald Anlauf
2021-09-28 12:30 ` Thomas Schwinge
2021-09-24 21:12 ` Harald Anlauf
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).