+2019-03-12 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/89363
+ PR fortran/89364
+ * trans-expr.c (set_dtype_for_unallocated): New function.
+ (gfc_conv_gfc_desc_to_cfi_desc): Call it for allocatable and
+ pointer arguments.
+ (gfc_conv_procedure_call): Likewise. Also, set the ubound of
+ the final dimension to -1 for assumed rank formal args that are
+ associated with assumed size arrays.
+ * trans-intrinsic.c (gfc_conv_intrinsic_bound): Return -1 for
+ the final dimension of assumed rank entities that are argument
+ associated with assumed size arrays.
+ (gfc_conv_intrinsic_shape): Likewise return -1 for the final
+ dimension of the shape intrinsic.
+
2019-03-11 Jakub Jelinek <jakub@redhat.com>
PR fortran/89651
}
+/* A helper function to set the dtype for unallocated or unassociated
+ entities. */
+
+static void
+set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
+{
+ tree tmp;
+ tree desc;
+ tree cond;
+ tree type;
+ stmtblock_t block;
+
+ /* TODO Figure out how to handle optional dummies. */
+ if (e && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ return;
+
+ desc = parmse->expr;
+ if (desc == NULL_TREE)
+ return;
+
+ if (POINTER_TYPE_P (TREE_TYPE (desc)))
+ desc = build_fold_indirect_ref_loc (input_location, desc);
+
+ if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ return;
+
+ gfc_init_block (&block);
+ tmp = gfc_conv_descriptor_data_get (desc);
+ cond = fold_build2_loc (input_location, EQ_EXPR,
+ logical_type_node, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+ tmp = gfc_conv_descriptor_dtype (desc);
+ type = gfc_get_element_type (TREE_TYPE (desc));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (tmp), tmp,
+ gfc_get_dtype_rank_type (e->rank, type));
+ gfc_add_expr_to_block (&block, tmp);
+ cond = build3_v (COND_EXPR, cond,
+ gfc_finish_block (&block),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&parmse->pre, cond);
+}
+
+
+
/* Provide an interface between gfortran array descriptors and the F2018:18.4
ISO_Fortran_binding array descriptors. */
parmse->expr = build_fold_indirect_ref_loc (input_location,
parmse->expr);
+ /* Unallocated allocatable arrays and unassociated pointer arrays
+ need their dtype setting if they are argument associated with
+ assumed rank dummies. */
+ if (fsym && fsym->as
+ && fsym->as->type == AS_ASSUMED_RANK
+ && (gfc_expr_attr (e).pointer
+ || gfc_expr_attr (e).allocatable))
+ set_dtype_for_unallocated (parmse, e);
+
/* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
the expression type is different from the descriptor type, then
the offset must be found (eg. to a component ref or substring)
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. */
+ if (!sym->attr.is_bind_c && e && fsym && fsym->as
+ && fsym->as->type == AS_ASSUMED_RANK)
+ {
+ if (gfc_expr_attr (e).pointer
+ || gfc_expr_attr (e).allocatable)
+ set_dtype_for_unallocated (&parmse, e);
+ else if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.dummy
+ && e->symtree->n.sym->as
+ && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
+ {
+ tree minus_one;
+ tmp = build_fold_indirect_ref_loc (input_location,
+ parmse.expr);
+ minus_one = build_int_cst (gfc_array_index_type, -1);
+ gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
+ gfc_rank_cst[e->rank - 1],
+ minus_one);
+ }
+ }
+
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
if (fsym && fsym->attr.allocatable
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
desc = gfc_evaluate_now (argse.expr, &se->pre);
-
+
stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
stride, build_int_cst (TREE_TYPE (stride), 1));
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);
}
{
gfc_actual_arglist *s, *k;
gfc_expr *e;
+ gfc_array_spec *as;
+ gfc_ss *ss;
/* Remove the KIND argument, if present. */
s = expr->value.function.actual;
k->expr = NULL;
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)
+ {
+ tree desc, 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. */
+ desc = se->expr;
+ tmp = gfc_conv_array_data (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
&& maskexpr->symtree->n.sym->attr.dummy
&& maskexpr->symtree->n.sym->attr.optional)
return false;
-
+
return true;
case GFC_ISYM_TRANSPOSE:
+2019-03-12 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/89363
+ * gfortran.dg/assumed_rank_16.f90: New test.
+
+ PR fortran/89364
+ * gfortran.dg/assumed_rank_17.f90: New test.
+
2019-03-12 Jakub Jelinek <jakub@redhat.com>
PR middle-end/89663
2019-02-25 Dominique d'Humieres <dominiq@gcc.gnu.org>
PR fortran/89282
- * gfortran.dg/overload_3.f90: New test.
+ * gfortran.dg/overload_3.f90: New test.
2019-02-25 Jakub Jelinek <jakub@redhat.com>
2019-02-25 Dominique d'Humieres <dominiq@gcc.gnu.org>
PR libfortran/89274
- * gfortran.dg/list_directed_large.f90: New test.
+ * gfortran.dg/list_directed_large.f90: New test.
2019-02-25 Jakub Jelinek <jakub@redhat.com>
--- /dev/null
+! { dg-do run }
+!
+! Tests the fix for PR89363, in which the rank of unallocated or unassociated
+! entities, argument associated with assumed rank dummies, was not being set.
+!
+! Contributed by Reinhold Bader <Bader@lrz.de>
+!
+module mod_ass_rank_02
+ implicit none
+contains
+ subroutine procr(this,flag)
+ real, allocatable :: this(..)
+ logical :: flag
+ if (rank(this) /= 2 .or. allocated(this)) then
+ write(*,*) 'FAIL procr', rank(this), allocated(this)
+ flag = .FALSE.
+ end if
+ end subroutine procr
+ subroutine procs(this,flag)
+ real, allocatable :: this(..)
+ logical :: flag
+ if (rank(this) /= 2 .or. .not. allocated(this)) then
+ write(*,*) 'FAIL procs status', rank(this), allocated(this)
+ flag = .FALSE.
+ end if
+ if (size(this,1) /= 2 .and. size(this,2) /= 5) then
+ write(*,*) 'FAIL procs shape', size(this)
+ flag = .FALSE.
+ end if
+ end subroutine procs
+end module mod_ass_rank_02
+program ass_rank_02
+ use mod_ass_rank_02
+ implicit none
+ real, allocatable :: x(:,:)
+ logical :: flag
+
+ flag = .TRUE.
+ call procr(x,flag)
+ if (.not.flag) stop 1
+ allocate(x(2,5))
+ call procs(x,flag)
+ if (.not.flag) stop 2
+ deallocate(x)
+end program ass_rank_02
--- /dev/null
+! { dg-do run }
+!
+! Tests the fix for PR89364, in which the ubound and the last element of
+! shape were note returning -1 for assumed rank entities, argument
+! associated with assumed size dummies.
+!
+! Contributed by Reinhold Bader <Bader@lrz.de>
+!
+module mod_ass_rank_04
+ implicit none
+contains
+ subroutine si(this)
+ real :: this(4, *)
+ call sa(this)
+ end subroutine si
+ subroutine sa(this)
+ real :: this(..)
+ if (rank(this) /= 2) then
+ stop 1
+ end if
+ if (maxval(abs(shape(this) - [4,-1])) > 0) then
+ stop 2
+ end if
+ if (ubound(this,2) /= lbound(this,2) - 2) then
+ stop 3
+ end if
+ end subroutine sa
+end module mod_ass_rank_04
+program ass_rank_04
+ use mod_ass_rank_04
+ implicit none
+ real :: y(9)
+ call si(y(2))
+end program ass_rank_04
projects / platform / upstream / gcc.git / commitdiff