===================================================================
*************** expr_may_alias_variables (gfc_expr *e, b
}
+ /* 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. */
*************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p
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_procedure_call (gfc_se * se, gf
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_conv_intrinsic_is_contiguous (gfc_se
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));
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));
*************** gfc_conv_intrinsic_bound (gfc_se * se, g
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_conv_intrinsic_shape (gfc_se *se, gf
{
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;
*************** gfc_conv_intrinsic_shape (gfc_se *se, gf
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
*************** gfc_inline_intrinsic_function_p (gfc_exp
&& maskexpr->symtree->n.sym->attr.dummy
&& maskexpr->symtree->n.sym->attr.optional)
return false;
!
return true;
case GFC_ISYM_TRANSPOSE:
&& maskexpr->symtree->n.sym->attr.dummy
&& maskexpr->symtree->n.sym->attr.optional)
return false;
!
return true;
case GFC_ISYM_TRANSPOSE:
===================================================================
***************
+ ! { 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
===================================================================
***************
+ ! { 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
The attached patch implements fixes for a couple of wrinkles with assumed rank: (i) PR89363 flagged the fact that the rank was not be set for assumed rank entities, associated with unallocated or unassociated arrays. The fix is straightforward, the work being done by trans-expr.c(set_dtype_for_unallocated). (ii) PR89364 points out that ubound and shape should be returning -1 for the final dimension and not 0, for assumed rank entities argument associated with assumed size arrays. The fix for this is bolted on to both intrinsics. BTW lbound seems lack a bit of fixing of intermediate expressions - the result is often overwhelmingly complicated. Is there some reason for this? Bootstrapped and regtested on FC29/x86_64 - OK for trunk? Paul PS I scoped out the select rank construct. It looks well doable but will have to await 10-branch opening. 2019-03-10 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-10 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.