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));
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;
}
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;
}
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;
}
/* 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
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
/* 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);
/* 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;
}
/* 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;
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. */
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
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;
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;
/* 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);
build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->pre, cond);
}
-
}
static void
gfc_actual_arglist *actual;
tree arg1;
tree type;
- tree fncall0;
- tree fncall1;
+ tree size;
gfc_se argse;
gfc_expr *e;
gfc_symbol *sym = NULL;
/* 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. */
&& 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);
}
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;
--- /dev/null
+! { 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" } }
--- /dev/null
+/* 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);
+}
! 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" }
!
! Reported as pr94070.
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
!
! TS 29113
! 6.4.2 SIZE
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" } }
! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
! PR 30865 - passing a subroutine optional argument to size(dim=...)
! used to segfault.
program main
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" } }
!
! 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" } }
#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)
{
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)
{
! { 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
projects / platform / upstream / gcc.git / commitdiff