commit c74d3f5ae059b74a552428d6f1602885ca239094
Author: Sandra Loosemore <sandra@codesourcery.com>
Date: Tue Oct 19 21:11:15 2021 -0700
Fortran: Fixes and additional tests for shape/ubound/size [PR94070]
This patch reimplements the SHAPE intrinsic to be inlined similarly to
LBOUND and UBOUND, instead of as a library call, to avoid an
unnecessary array copy. Various bugs are also fixed.
gcc/fortran/
PR fortran/94070
* expr.c (gfc_simplify_expr): Handle GFC_ISYM_SHAPE along with
GFC_ISYM_LBOUND and GFC_ISYM_UBOUND.
* trans-array.c (gfc_conv_ss_startstride): Likewise.
(set_loop_bounds): Likewise.
(gfc_tree_array_size): Handle class arrays.
* trans-intrinsic.c (gfc_trans_intrinsic_bound): Extend to
handle SHAPE. Correct logic for zero-size special cases and
detecting assumed-rank arrays associated with an assumed-size
argument.
(gfc_conv_intrinsic_shape): Deleted.
(gfc_conv_intrinsic_function): Handle GFC_ISYM_SHAPE like
GFC_ISYM_LBOUND and GFC_ISYM_UBOUND.
(gfc_add_intrinsic_ss_code): Likewise.
(gfc_walk_intrinsic_bound): Likewise.
gcc/testsuite/gfortran.dg/
PR fortran/94070
* c-interop/shape-bindc.f90: New test.
* c-interop/shape-poly.f90: New test.
* c-interop/size-bindc.f90: New test.
* c-interop/size-poly.f90: New test.
* c-interop/ubound-bindc.f90: New test.
* c-interop/ubound-poly.f90: New test.
@@ -2205,7 +2205,8 @@ gfc_simplify_expr (gfc_expr *p, int type)
(p->value.function.isym->id == GFC_ISYM_LBOUND
|| p->value.function.isym->id == GFC_ISYM_UBOUND
|| p->value.function.isym->id == GFC_ISYM_LCOBOUND
- || p->value.function.isym->id == GFC_ISYM_UCOBOUND))
+ || p->value.function.isym->id == GFC_ISYM_UCOBOUND
+ || p->value.function.isym->id == GFC_ISYM_SHAPE))
ap = ap->next;
for ( ; ap; ap = ap->next)
@@ -4507,6 +4507,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
case GFC_ISYM_UBOUND:
case GFC_ISYM_LCOBOUND:
case GFC_ISYM_UCOBOUND:
+ case GFC_ISYM_SHAPE:
case GFC_ISYM_THIS_IMAGE:
loop->dimen = ss->dimen;
goto done;
@@ -4558,12 +4559,14 @@ done:
/* Fall through to supply start and stride. */
case GFC_ISYM_LBOUND:
case GFC_ISYM_UBOUND:
+ /* This is the variant without DIM=... */
+ gcc_assert (expr->value.function.actual->next->expr == NULL);
+ /* Fall through. */
+
+ case GFC_ISYM_SHAPE:
{
gfc_expr *arg;
- /* This is the variant without DIM=... */
- gcc_assert (expr->value.function.actual->next->expr == NULL);
-
arg = expr->value.function.actual->expr;
if (arg->rank == -1)
{
@@ -5350,10 +5353,13 @@ set_loop_bounds (gfc_loopinfo *loop)
gfc_expr *expr = loopspec[n]->info->expr;
/* The {l,u}bound of an assumed rank. */
- gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
- || expr->value.function.isym->id == GFC_ISYM_UBOUND)
- && expr->value.function.actual->next->expr == NULL
- && expr->value.function.actual->expr->rank == -1);
+ if (expr->value.function.isym->id == GFC_ISYM_SHAPE)
+ gcc_assert (expr->value.function.actual->expr->rank == -1);
+ else
+ gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
+ || expr->value.function.isym->id == GFC_ISYM_UBOUND)
+ && expr->value.function.actual->next->expr == NULL
+ && expr->value.function.actual->expr->rank == -1);
loop->to[n] = info->end[dim];
break;
@@ -8054,9 +8060,18 @@ gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
}
tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
- symbol_attribute attr = gfc_expr_attr (expr);
+ symbol_attribute attr;
gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
+
+ if (expr->ts.type == BT_CLASS)
+ {
+ attr = CLASS_DATA (expr->symtree->n.sym)->attr;
+ attr.pointer = attr.class_pointer;
+ }
+ else
+ attr = gfc_expr_attr (expr);
+
if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
|| !dim)
{
@@ -2922,7 +2922,7 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
/* TODO: bound intrinsic generates way too much unnecessary code. */
static void
-gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
+gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
{
gfc_actual_arglist *arg;
gfc_actual_arglist *arg2;
@@ -2930,9 +2930,10 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
tree type;
tree bound;
tree tmp;
- tree cond, cond1, cond3, cond4, size;
+ tree cond, cond1;
tree ubound;
tree lbound;
+ tree size;
gfc_se argse;
gfc_array_spec * as;
bool assumed_rank_lb_one;
@@ -2943,7 +2944,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
if (se->ss)
{
/* Create an implicit second parameter from the loop variable. */
- gcc_assert (!arg2->expr);
+ gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE);
gcc_assert (se->loop->dimen == 1);
gcc_assert (se->ss->info->expr == expr);
gfc_advance_se_ss_chain (se);
@@ -2979,12 +2980,14 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
if (INTEGER_CST_P (bound))
{
+ gcc_assert (op != GFC_ISYM_SHAPE);
if (((!as || as->type != AS_ASSUMED_RANK)
&& wi::geu_p (wi::to_wide (bound),
GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
|| wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS))
gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
- "dimension index", upper ? "UBOUND" : "LBOUND",
+ "dimension index",
+ (op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND",
&expr->where);
}
@@ -3008,8 +3011,8 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
}
}
- /* Take care of the lbound shift for assumed-rank arrays, which are
- nonallocatable and nonpointers. Those has a lbound of 1. */
+ /* Take care of the lbound shift for assumed-rank arrays that are
+ nonallocatable and nonpointers. Those have a lbound of 1. */
assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
&& ((arg->expr->ts.type != BT_CLASS
&& !arg->expr->symtree->n.sym->attr.allocatable
@@ -3020,6 +3023,10 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
ubound = gfc_conv_descriptor_ubound_get (desc, bound);
lbound = gfc_conv_descriptor_lbound_get (desc, bound);
+ 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);
/* 13.14.53: Result value for LBOUND
@@ -3042,106 +3049,82 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
not have size zero and has value zero if dimension DIM has
size zero. */
- if (!upper && assumed_rank_lb_one)
+ if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one)
se->expr = gfc_index_one_node;
else if (as)
{
- tree stride = gfc_conv_descriptor_stride_get (desc, bound);
-
- cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
- ubound, lbound);
- cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
- stride, gfc_index_zero_node);
- cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
- logical_type_node, cond3, cond1);
- cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
- stride, gfc_index_zero_node);
-
- if (upper)
+ if (op == GFC_ISYM_UBOUND)
{
- tree cond5;
- cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, cond3, cond4);
- cond5 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- gfc_index_one_node, lbound);
- cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
- logical_type_node, cond4, cond5);
-
- cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, cond, cond5);
-
- if (assumed_rank_lb_one)
+ cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
+ size, gfc_index_zero_node);
+ se->expr = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ (assumed_rank_lb_one ? size : ubound),
+ gfc_index_zero_node);
+ }
+ else if (op == GFC_ISYM_LBOUND)
+ {
+ cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
+ size, gfc_index_zero_node);
+ if (as->type == AS_ASSUMED_SIZE)
{
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, ubound, lbound);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, tmp, gfc_index_one_node);
+ cond1 = fold_build2_loc (input_location, EQ_EXPR,
+ logical_type_node, bound,
+ build_int_cst (TREE_TYPE (bound),
+ arg->expr->rank - 1));
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, cond, cond1);
}
- else
- tmp = ubound;
-
se->expr = fold_build3_loc (input_location, COND_EXPR,
gfc_array_index_type, cond,
- tmp, gfc_index_zero_node);
+ lbound, gfc_index_one_node);
}
+ else if (op == GFC_ISYM_SHAPE)
+ se->expr = size;
else
- {
- if (as->type == AS_ASSUMED_SIZE)
- cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- bound, build_int_cst (TREE_TYPE (bound),
- arg->expr->rank - 1));
- else
- cond = logical_false_node;
+ gcc_unreachable ();
- cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, cond3, cond4);
- cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ /* According to F2018 16.9.172, para 5, an assumed rank object,
+ argument associated with and assumed size array, has the ubound
+ of the final dimension set to -1 and UBOUND must return this.
+ Similarly for the SHAPE intrinsic. */
+ if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one)
+ {
+ tree minus_one = build_int_cst (gfc_array_index_type, -1);
+ tree rank = fold_convert (gfc_array_index_type,
+ gfc_conv_descriptor_rank (desc));
+ rank = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, rank, minus_one);
+
+ /* Fix the expression to stop it from becoming even more
+ complicated. */
+ se->expr = gfc_evaluate_now (se->expr, &se->pre);
+
+ /* Descriptors for assumed-size arrays have ubound = -1
+ in the last dimension. */
+ cond1 = fold_build2_loc (input_location, EQ_EXPR,
+ logical_type_node, ubound, minus_one);
+ cond = fold_build2_loc (input_location, EQ_EXPR,
+ logical_type_node, bound, rank);
+ cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
logical_type_node, cond, cond1);
-
se->expr = fold_build3_loc (input_location, COND_EXPR,
gfc_array_index_type, cond,
- lbound, gfc_index_one_node);
+ minus_one, se->expr);
}
}
- else
+ else /* as is null; this is an old-fashioned 1-based array. */
{
- if (upper)
+ if (op != GFC_ISYM_LBOUND)
{
- size = 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, size,
- gfc_index_one_node);
se->expr = fold_build2_loc (input_location, MAX_EXPR,
- gfc_array_index_type, se->expr,
+ gfc_array_index_type, size,
gfc_index_zero_node);
}
else
se->expr = gfc_index_one_node;
}
- /* According to F2018 16.9.172, para 5, an assumed rank object, argument
- associated with and assumed size array, has the ubound of the final
- dimension set to -1 and UBOUND must return this. */
- if (upper && as && as->type == AS_ASSUMED_RANK)
- {
- tree minus_one = build_int_cst (gfc_array_index_type, -1);
- tree rank = fold_convert (gfc_array_index_type,
- gfc_conv_descriptor_rank (desc));
- rank = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, rank, minus_one);
- /* Fix the expression to stop it from becoming even more complicated. */
- se->expr = gfc_evaluate_now (se->expr, &se->pre);
- cond = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, bound, rank);
- cond1 = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, ubound, minus_one);
- cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, cond, cond1);
- se->expr = fold_build3_loc (input_location, COND_EXPR,
- gfc_array_index_type, cond,
- se->expr, minus_one);
- }
type = gfc_typenode_for_spec (&expr->ts);
se->expr = convert (type, se->expr);
@@ -6691,85 +6674,6 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
}
static void
-gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
-{
- gfc_actual_arglist *s, *k;
- 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;
- k = s->next;
- e = k->expr;
- gfc_free_expr (e);
- k->expr = NULL;
-
- gfc_conv_intrinsic_funcall (se, 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. */
-
- 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 rank, minus_one, cond, ubound, tmp;
- stmtblock_t block;
- gfc_se ase;
-
- minus_one = build_int_cst (gfc_array_index_type, -1);
-
- /* Recover the descriptor for the array. */
- gfc_init_se (&ase, NULL);
- ase.descriptor_only = 1;
- gfc_conv_expr_lhs (&ase, ss->info->expr);
-
- /* Obtain rank-1 so that we can address both descriptors. */
- rank = gfc_conv_descriptor_rank (ase.expr);
- rank = fold_convert (gfc_array_index_type, rank);
- rank = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- rank, minus_one);
- rank = gfc_evaluate_now (rank, &se->pre);
-
- /* The ubound for the final dimension will be tested for being -1. */
- ubound = gfc_conv_descriptor_ubound_get (ase.expr, rank);
- ubound = gfc_evaluate_now (ubound, &se->pre);
- cond = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node,
- ubound, minus_one);
-
- /* Obtain the last element of the result from the library shape
- intrinsic and set it to -1 if that is the value of ubound. */
- 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);
-
- gfc_init_block (&block);
- gfc_add_modify (&block, tmp, build_int_cst (TREE_TYPE (tmp), -1));
-
- cond = build3_v (COND_EXPR, cond,
- gfc_finish_block (&block),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se->pre, cond);
- }
-}
-
-static void
gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
bool arithmetic)
{
@@ -10178,10 +10082,6 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
break;
- case GFC_ISYM_SHAPE:
- gfc_conv_intrinsic_shape (se, expr);
- break;
-
default:
gfc_conv_intrinsic_funcall (se, expr);
break;
@@ -10575,7 +10475,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
break;
case GFC_ISYM_LBOUND:
- gfc_conv_intrinsic_bound (se, expr, 0);
+ gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_LBOUND);
break;
case GFC_ISYM_LCOBOUND:
@@ -10710,6 +10610,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_scale (se, expr);
break;
+ case GFC_ISYM_SHAPE:
+ gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_SHAPE);
+ break;
+
case GFC_ISYM_SIGN:
gfc_conv_intrinsic_sign (se, expr);
break;
@@ -10756,7 +10660,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
break;
case GFC_ISYM_UBOUND:
- gfc_conv_intrinsic_bound (se, expr, 1);
+ gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_UBOUND);
break;
case GFC_ISYM_UCOBOUND:
@@ -11030,6 +10934,7 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
case GFC_ISYM_UCOBOUND:
case GFC_ISYM_LCOBOUND:
case GFC_ISYM_THIS_IMAGE:
+ case GFC_ISYM_SHAPE:
break;
default:
@@ -11038,8 +10943,8 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
}
-/* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
- are expanded into code inside the scalarization loop. */
+/* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with
+ one parameter are expanded into code inside the scalarization loop. */
static gfc_ss *
gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
@@ -11048,7 +10953,8 @@ gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
gfc_add_class_array_ref (expr->value.function.actual->expr);
/* The two argument version returns a scalar. */
- if (expr->value.function.actual->next->expr)
+ if (expr->value.function.isym->id != GFC_ISYM_SHAPE
+ && expr->value.function.actual->next->expr)
return ss;
return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
@@ -11148,7 +11054,6 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
case GFC_ISYM_PARITY:
case GFC_ISYM_PRODUCT:
case GFC_ISYM_SUM:
- case GFC_ISYM_SHAPE:
case GFC_ISYM_SPREAD:
case GFC_ISYM_YN2:
/* Ignore absent optional parameters. */
@@ -11198,6 +11103,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
case GFC_ISYM_UBOUND:
case GFC_ISYM_UCOBOUND:
case GFC_ISYM_THIS_IMAGE:
+ case GFC_ISYM_SHAPE:
return gfc_walk_intrinsic_bound (ss, expr);
case GFC_ISYM_TRANSFER:
new file mode 100644
@@ -0,0 +1,77 @@
+! { dg-do run }
+!
+! TS 29113
+! 6.4.1 SHAPE
+!
+! The description of the intrinsic function SHAPE in ISO/IEC 1539-1:2010
+! is changed for an assumed-rank array that is associated with an
+! assumed-size array; an assumed-size array has no shape, but in this
+! case the result has a value equal to
+! [ (SIZE (ARRAY, I, KIND), I=1,RANK (ARRAY)) ]
+! with KIND omitted from SIZE if it was omitted from SHAPE.
+!
+! The idea here is that the main program passes some arrays to a test
+! subroutine with an assumed-size dummy, which in turn passes that to a
+! subroutine with an assumed-rank dummy.
+
+program test
+
+ ! Define some arrays for testing.
+ integer, target :: x1(5)
+ integer :: y1(0:9)
+ integer, pointer :: p1(:)
+ integer, allocatable :: a1(:)
+ integer, target :: x3(2,3,4)
+ integer :: y3(0:1,-3:-1,4)
+ integer, pointer :: p3(:,:,:)
+ integer, allocatable :: a3(:,:,:)
+
+ ! Test the 1-dimensional arrays.
+ call test1 (x1)
+ call test1 (y1)
+ p1 => x1
+ call test1 (p1)
+ allocate (a1(5))
+ call test1 (a1)
+
+ ! Test the multi-dimensional arrays.
+ call test3 (x3, 1, 2, 1, 3)
+ call test3 (y3, 0, 1, -3, -1)
+ p3 => x3
+ call test3 (p3, 1, 2, 1, 3)
+ allocate (a3(2,3,4))
+ call test3 (a3, 1, 2, 1, 3)
+
+contains
+
+ subroutine testit (a) bind(c)
+ integer :: a(..)
+
+ integer :: r
+ r = rank(a)
+
+ block
+ integer :: s(r)
+ s = shape(a)
+ do i = 1, r
+ if (s(i) .ne. size(a,i)) stop 101
+ end do
+ end block
+
+ end subroutine
+
+ subroutine test1 (a) bind(c)
+ integer :: a(*)
+
+ call testit (a)
+ end subroutine
+
+ subroutine test3 (a, l1, u1, l2, u2) bind(c)
+ implicit none
+ integer :: l1, u1, l2, u2
+ integer :: a(l1:u1, l2:u2, *)
+
+ call testit (a)
+ end subroutine
+
+end program
new file mode 100644
@@ -0,0 +1,89 @@
+! { dg-do run }
+!
+! TS 29113
+! 6.4.1 SHAPE
+!
+! The description of the intrinsic function SHAPE in ISO/IEC 1539-1:2010
+! is changed for an assumed-rank array that is associated with an
+! assumed-size array; an assumed-size array has no shape, but in this
+! case the result has a value equal to
+! [ (SIZE (ARRAY, I, KIND), I=1,RANK (ARRAY)) ]
+! with KIND omitted from SIZE if it was omitted from SHAPE.
+!
+! The idea here is that the main program passes some arrays to a test
+! subroutine with an assumed-size dummy, which in turn passes that to a
+! subroutine with an assumed-rank dummy.
+!
+! This is the polymorphic version of shape.f90.
+
+module m
+ type :: t
+ integer :: id
+ real :: xyz(3)
+ end type
+end module
+
+program test
+ use m
+
+ ! Define some arrays for testing.
+ type(t), target :: x1(5)
+ type(t) :: y1(0:9)
+ class(t), pointer :: p1(:)
+ class(t), allocatable :: a1(:)
+ type(t), target :: x3(2,3,4)
+ type(t) :: y3(0:1,-3:-1,4)
+ class(t), pointer :: p3(:,:,:)
+ type(t), allocatable :: a3(:,:,:)
+
+ ! Test the 1-dimensional arrays.
+ call test1 (x1)
+ call test1 (y1)
+ p1 => x1
+ call test1 (p1)
+ allocate (a1(5))
+ call test1 (a1)
+
+ ! Test the multi-dimensional arrays.
+ call test3 (x3, 1, 2, 1, 3)
+ call test3 (y3, 0, 1, -3, -1)
+ p3 => x3
+ call test3 (p3, 1, 2, 1, 3)
+ allocate (a3(2,3,4))
+ call test3 (a3, 1, 2, 1, 3)
+
+contains
+
+ subroutine testit (a)
+ use m
+ class(t) :: a(..)
+
+ integer :: r
+ r = rank(a)
+
+ block
+ integer :: s(r)
+ s = shape(a)
+ do i = 1, r
+ if (s(i) .ne. size(a,i)) stop 101
+ end do
+ end block
+
+ end subroutine
+
+ subroutine test1 (a)
+ use m
+ class(t) :: a(*)
+
+ call testit (a)
+ end subroutine
+
+ subroutine test3 (a, l1, u1, l2, u2)
+ use m
+ integer :: l1, u1, l2, u2
+ class(t) :: a(l1:u1, l2:u2, *)
+
+ call testit (a)
+ end subroutine
+
+end program
new file mode 100644
@@ -0,0 +1,106 @@
+! Reported as pr94070.
+! { dg-do run }
+!
+! TS 29113
+! 6.4.2 SIZE
+!
+! The description of the intrinsic function SIZE in ISO/IEC 1539-1:2010
+! is changed in the following cases:
+!
+! (1) for an assumed-rank object that is associated with an assumed-size
+! array, the result has the value −1 if DIM is present and equal to the
+! rank of ARRAY, and a negative value that is equal to
+! PRODUCT ( [ (SIZE (ARRAY, I, KIND), I=1, RANK (ARRAY)) ] )
+! if DIM is not present;
+!
+! (2) for an assumed-rank object that is associated with a scalar, the
+! result has the value 1.
+!
+! The idea here is that the main program passes some arrays to a test
+! subroutine with an assumed-size dummy, which in turn passes that to a
+! subroutine with an assumed-rank dummy.
+
+program test
+
+ ! Define some arrays for testing.
+ integer, target :: x1(5)
+ integer :: y1(0:9)
+ integer, pointer :: p1(:)
+ integer, allocatable :: a1(:)
+ integer, target :: x3(2,3,4)
+ integer :: y3(0:1,-3:-1,4)
+ integer, pointer :: p3(:,:,:)
+ integer, allocatable :: a3(:,:,:)
+ integer :: x
+
+ ! Test the 1-dimensional arrays.
+ call test1 (x1)
+ call test1 (y1)
+ p1 => x1
+ call test1 (p1)
+ allocate (a1(5))
+ call test1 (a1)
+
+ ! Test the multi-dimensional arrays.
+ call test3 (x3, 1, 2, 1, 3)
+ call test3 (y3, 0, 1, -3, -1)
+ p3 => x3
+ call test3 (p3, 1, 2, 1, 3)
+ allocate (a3(2,3,4))
+ call test3 (a3, 1, 2, 1, 3)
+
+ ! Test scalars.
+ call test0 (x)
+ call test0 (-1)
+ call test0 (x1(1))
+
+contains
+
+ subroutine testit (a, r, sizes) bind(c)
+ integer :: a(..)
+ integer :: r
+ integer :: sizes(r)
+
+ integer :: totalsize, thissize
+ totalsize = 1
+
+ if (r .ne. rank(a)) stop 101
+
+ do i = 1, r
+ thissize = size (a, i)
+ print *, 'got size ', thissize, ' expected ', sizes(i)
+ if (thissize .ne. sizes(i)) stop 102
+ totalsize = totalsize * thissize
+ end do
+
+ if (size(a) .ne. totalsize) stop 103
+ end subroutine
+
+ subroutine test0 (a) bind(c)
+ integer :: a(..)
+
+ if (size (a) .ne. 1) stop 103
+ end subroutine
+
+ subroutine test1 (a) bind(c)
+ integer :: a(*)
+
+ integer :: sizes(1)
+ sizes(1) = -1
+ call testit (a, 1, sizes)
+ end subroutine
+
+ subroutine test3 (a, l1, u1, l2, u2) bind(c)
+ implicit none
+ integer :: l1, u1, l2, u2
+ integer :: a(l1:u1, l2:u2, *)
+
+ integer :: sizes(3)
+ sizes(1) = u1 - l1 + 1
+ sizes(2) = u2 - l2 + 1
+ sizes(3) = -1
+
+ call testit (a, 3, sizes)
+ end subroutine
+
+end program
new file mode 100644
@@ -0,0 +1,118 @@
+! Reported as pr94070.
+! { dg-do run }
+!
+! TS 29113
+! 6.4.2 SIZE
+!
+! The description of the intrinsic function SIZE in ISO/IEC 1539-1:2010
+! is changed in the following cases:
+!
+! (1) for an assumed-rank object that is associated with an assumed-size
+! array, the result has the value −1 if DIM is present and equal to the
+! rank of ARRAY, and a negative value that is equal to
+! PRODUCT ( [ (SIZE (ARRAY, I, KIND), I=1, RANK (ARRAY)) ] )
+! if DIM is not present;
+!
+! (2) for an assumed-rank object that is associated with a scalar, the
+! result has the value 1.
+!
+! The idea here is that the main program passes some arrays to a test
+! subroutine with an assumed-size dummy, which in turn passes that to a
+! subroutine with an assumed-rank dummy.
+!
+! This is the polymorphic version of size.f90.
+
+module m
+ type :: t
+ integer :: id
+ real :: xyz(3)
+ end type
+end module
+
+program test
+ use m
+
+ ! Define some arrays for testing.
+ type(t), target :: x1(5)
+ type(t) :: y1(0:9)
+ class(t), pointer :: p1(:)
+ class(t), allocatable :: a1(:)
+ type(t), target :: x3(2,3,4)
+ type(t) :: y3(0:1,-3:-1,4)
+ class(t), pointer :: p3(:,:,:)
+ type(t), allocatable :: a3(:,:,:)
+ type(t) :: x
+
+ ! Test the 1-dimensional arrays.
+ call test1 (x1)
+ call test1 (y1)
+ p1 => x1
+ call test1 (p1)
+ allocate (a1(5))
+ call test1 (a1)
+
+ ! Test the multi-dimensional arrays.
+ call test3 (x3, 1, 2, 1, 3)
+ call test3 (y3, 0, 1, -3, -1)
+ p3 => x3
+ call test3 (p3, 1, 2, 1, 3)
+ allocate (a3(2,3,4))
+ call test3 (a3, 1, 2, 1, 3)
+
+ ! Test scalars.
+ call test0 (x)
+ call test0 (x1(1))
+
+contains
+
+ subroutine testit (a, r, sizes)
+ use m
+ class(t) :: a(..)
+ integer :: r
+ integer :: sizes(r)
+
+ integer :: totalsize, thissize
+ totalsize = 1
+
+ if (r .ne. rank(a)) stop 101
+
+ do i = 1, r
+ thissize = size (a, i)
+ print *, 'got size ', thissize, ' expected ', sizes(i)
+ if (thissize .ne. sizes(i)) stop 102
+ totalsize = totalsize * thissize
+ end do
+
+ if (size(a) .ne. totalsize) stop 103
+ end subroutine
+
+ subroutine test0 (a)
+ use m
+ class(t) :: a(..)
+
+ if (size (a) .ne. 1) stop 103
+ end subroutine
+
+ subroutine test1 (a)
+ use m
+ class(t) :: a(*)
+
+ integer :: sizes(1)
+ sizes(1) = -1
+ call testit (a, 1, sizes)
+ end subroutine
+
+ subroutine test3 (a, l1, u1, l2, u2)
+ use m
+ integer :: l1, u1, l2, u2
+ class(t) :: a(l1:u1, l2:u2, *)
+
+ integer :: sizes(3)
+ sizes(1) = u1 - l1 + 1
+ sizes(2) = u2 - l2 + 1
+ sizes(3) = -1
+
+ call testit (a, 3, sizes)
+ end subroutine
+
+end program
new file mode 100644
@@ -0,0 +1,129 @@
+! { dg-do run }
+!
+! TS 29113
+! 6.4.3 UBOUND
+!
+! The description of the intrinsic function UBOUND in ISO/IEC
+! 1539-1:2010 is changed for an assumed-rank object that is associated
+! with an assumed-size array; the result of UBOUND (ARRAY, RANK(ARRAY),
+! KIND) has a value equal to LBOUND (ARRAY, RANK (ARRAY), KIND) −2 with
+! KIND omitted from LBOUND if it was omitted from UBOUND.
+!
+! NOTE 6.2
+! If LBOUND or UBOUND is invoked for an assumed-rank object that is
+! associated with a scalar and DIM is absent, the result is a zero-sized
+! array. LBOUND or UBOUND cannot be invoked for an assumed-rank object
+! that is associated with a scalar if DIM is present because the rank of
+! a scalar is zero and DIM must be ≥ 1.
+!
+! The idea here is that the main program passes some arrays to a test
+! subroutine with an assumed-size dummy, which in turn passes that to a
+! subroutine with an assumed-rank dummy.
+
+program test
+
+ ! Define some arrays for testing.
+ integer, target :: x1(5)
+ integer :: y1(0:9)
+ integer, pointer :: p1(:)
+ integer, allocatable :: a1(:)
+ integer, target :: x3(2,3,4)
+ integer :: y3(0:1,-3:-1,4)
+ integer, pointer :: p3(:,:,:)
+ integer, allocatable :: a3(:,:,:)
+ integer :: x
+
+ ! Test the 1-dimensional arrays.
+ call test1 (x1)
+ call testit2(x1, shape(x1))
+ call test1 (y1)
+ call testit2(y1, shape(y1))
+ p1 => x1
+ call testit2(p1, shape(p1))
+ call testit2p(p1, lbound(p1), shape(p1))
+ call test1 (p1)
+ p1(77:) => x1
+ call testit2p(p1, [77], shape(p1))
+ allocate (a1(5))
+ call testit2(a1, shape(a1))
+ call testit2a(a1, lbound(a1), shape(a1))
+ call test1 (a1)
+ deallocate(a1)
+ allocate (a1(-38:5))
+ call test1 (a1)
+ call testit2(a1, shape(a1))
+ call testit2a(a1, [-38], shape(a1))
+
+ ! Test the multi-dimensional arrays.
+ call test3 (x3, 1, 2, 1, 3)
+ call test3 (y3, 0, 1, -3, -1)
+ p3 => x3
+ call test3 (p3, 1, 2, 1, 3)
+ allocate (a3(2,3,4))
+ call test3 (a3, 1, 2, 1, 3)
+
+ ! Test some scalars.
+ call test0 (x)
+ call test0 (-1)
+ call test0 (x1(1))
+
+contains
+
+ subroutine testit (a) bind(c)
+ integer :: a(..)
+ integer :: r
+ r = rank(a)
+ if (any (lbound (a) .ne. 1)) stop 101
+ if (ubound (a, r) .ne. -1) stop 102
+ end subroutine
+
+ subroutine testit2(a, shape) bind(c)
+ integer :: a(..)
+ integer :: shape(:)
+ if (rank(a) /= size(shape)) stop 111
+ if (any (lbound(a) /= 1)) stop 112
+ if (any (ubound(a) /= shape)) stop 113
+ end subroutine
+
+ subroutine testit2a(a,lbound2, shape2) bind(c)
+ integer, allocatable :: a(..)
+ integer :: lbound2(:), shape2(:)
+ if (rank(a) /= size(shape2)) stop 121
+ if (any (lbound(a) /= lbound2)) stop 122
+ if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 123
+ if (any (shape(a) /= shape2)) stop 124
+ if (sum (shape(a)) /= size(a)) stop 125
+ end subroutine
+
+ subroutine testit2p(a, lbound2, shape2) bind(c)
+ integer, pointer :: a(..)
+ integer :: lbound2(:), shape2(:)
+ if (rank(a) /= size(shape2)) stop 131
+ if (any (lbound(a) /= lbound2)) stop 132
+ if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 133
+ if (any (shape(a) /= shape2)) stop 134
+ if (sum (shape(a)) /= size(a)) stop 135
+ end subroutine
+
+ subroutine test0 (a) bind(c)
+ integer :: a(..)
+ if (rank (a) .ne. 0) stop 141
+ if (size (lbound (a)) .ne. 0) stop 142
+ if (size (ubound (a)) .ne. 0) stop 143
+ end subroutine
+
+ subroutine test1 (a) bind(c)
+ integer :: a(*)
+
+ call testit (a)
+ end subroutine
+
+ subroutine test3 (a, l1, u1, l2, u2) bind(c)
+ implicit none
+ integer :: l1, u1, l2, u2
+ integer :: a(l1:u1, l2:u2, *)
+
+ call testit (a)
+ end subroutine
+
+end program
new file mode 100644
@@ -0,0 +1,145 @@
+! { dg-do run }
+!
+! TS 29113
+! 6.4.3 UBOUND
+!
+! The description of the intrinsic function UBOUND in ISO/IEC
+! 1539-1:2010 is changed for an assumed-rank object that is associated
+! with an assumed-size array; the result of UBOUND (ARRAY, RANK(ARRAY),
+! KIND) has a value equal to LBOUND (ARRAY, RANK (ARRAY), KIND) −2 with
+! KIND omitted from LBOUND if it was omitted from UBOUND.
+!
+! NOTE 6.2
+! If LBOUND or UBOUND is invoked for an assumed-rank object that is
+! associated with a scalar and DIM is absent, the result is a zero-sized
+! array. LBOUND or UBOUND cannot be invoked for an assumed-rank object
+! that is associated with a scalar if DIM is present because the rank of
+! a scalar is zero and DIM must be ≥ 1.
+!
+! The idea here is that the main program passes some arrays to a test
+! subroutine with an assumed-size dummy, which in turn passes that to a
+! subroutine with an assumed-rank dummy.
+!
+! This is like ubound.f90, but using polymorphic arrays instead of integer
+! arrays.
+
+module m
+ type :: t
+ integer :: id
+ real :: xyz(3)
+ end type
+end module
+
+program test
+ use m
+
+ ! Define some arrays for testing.
+ type(t), target :: x1(5)
+ type(t) :: y1(0:9)
+ class(t), pointer :: p1(:)
+ class(t), allocatable :: a1(:)
+ type(t), target :: x3(2,3,4)
+ type(t) :: y3(0:1,-3:-1,4)
+ class(t), pointer :: p3(:,:,:)
+ type(t), allocatable :: a3(:,:,:)
+ type(t) :: x
+
+ ! Test the 1-dimensional arrays.
+ call test1 (x1)
+ call testit2(x1, shape(x1))
+ call test1 (y1)
+ call testit2(y1, shape(y1))
+ p1 => x1
+ call testit2(p1, shape(p1))
+ call testit2p(p1, lbound(p1), shape(p1))
+ call test1 (p1)
+ p1(77:) => x1
+ call testit2p(p1, [77], shape(p1))
+ allocate (a1(5))
+ call testit2(a1, shape(a1))
+ call testit2a(a1, lbound(a1), shape(a1))
+ call test1 (a1)
+ deallocate(a1)
+ allocate (a1(-38:5))
+ call test1 (a1)
+ call testit2(a1, shape(a1))
+ call testit2a(a1, [-38], shape(a1))
+
+ ! Test the multi-dimensional arrays.
+ call test3 (x3, 1, 2, 1, 3)
+ call test3 (y3, 0, 1, -3, -1)
+ p3 => x3
+ call test3 (p3, 1, 2, 1, 3)
+ allocate (a3(2,3,4))
+ call test3 (a3, 1, 2, 1, 3)
+
+ ! Test some scalars.
+ call test0 (x)
+ call test0 (x1(1))
+
+contains
+
+ subroutine testit (a)
+ use m
+ class(t) :: a(..)
+ integer :: r
+ r = rank(a)
+ if (any (lbound (a) .ne. 1)) stop 101
+ if (ubound (a, r) .ne. -1) stop 102
+ end subroutine
+
+ subroutine testit2(a, shape)
+ use m
+ class(t) :: a(..)
+ integer :: shape(:)
+ if (rank(a) /= size(shape)) stop 111
+ if (any (lbound(a) /= 1)) stop 112
+ if (any (ubound(a) /= shape)) stop 113
+ end subroutine
+
+ subroutine testit2a(a,lbound2, shape2)
+ use m
+ class(t), allocatable :: a(..)
+ integer :: lbound2(:), shape2(:)
+ if (rank(a) /= size(shape2)) stop 121
+ if (any (lbound(a) /= lbound2)) stop 122
+ if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 123
+ if (any (shape(a) /= shape2)) stop 124
+ if (sum (shape(a)) /= size(a)) stop 125
+ end subroutine
+
+ subroutine testit2p(a, lbound2, shape2)
+ use m
+ class(t), pointer :: a(..)
+ integer :: lbound2(:), shape2(:)
+ if (rank(a) /= size(shape2)) stop 131
+ if (any (lbound(a) /= lbound2)) stop 132
+ if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 133
+ if (any (shape(a) /= shape2)) stop 134
+ if (sum (shape(a)) /= size(a)) stop 135
+ end subroutine
+
+ subroutine test0 (a)
+ use m
+ class(t) :: a(..)
+ if (rank (a) .ne. 0) stop 141
+ if (size (lbound (a)) .ne. 0) stop 142
+ if (size (ubound (a)) .ne. 0) stop 143
+ end subroutine
+
+ subroutine test1 (a)
+ use m
+ class(t) :: a(*)
+
+ call testit (a)
+ end subroutine
+
+ subroutine test3 (a, l1, u1, l2, u2)
+ use m
+ integer :: l1, u1, l2, u2
+ class(t) :: a(l1:u1, l2:u2, *)
+
+ call testit (a)
+ end subroutine
+
+end program