From: Paul Thomas Date: Tue, 12 Mar 2019 13:40:51 +0000 (+0000) Subject: re PR fortran/89363 (RANK incorrect for unallocated allocatable) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=0e3088806577e8050d6cc10215196d5f57cb5aa4;p=gcc.git re PR fortran/89363 (RANK incorrect for unallocated allocatable) 2019-03-12 Paul Thomas 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-12 Paul Thomas PR fortran/89363 * gfortran.dg/assumed_rank_16.f90: New test. PR fortran/89364 * gfortran.dg/assumed_rank_17.f90: New test. From-SVN: r269612 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a3b47ac4980..9cefe39bfb8 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,19 @@ +2019-03-12 Paul Thomas + + 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 PR fortran/89651 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 07027139d04..1a48e73a9f8 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4919,6 +4919,52 @@ expr_may_alias_variables (gfc_expr *e, bool array_may_alias) } +/* 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. */ @@ -4958,6 +5004,15 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) 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) @@ -5953,6 +6008,30 @@ 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. */ + 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 diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 64d52588d6e..2eb5d1ae6f7 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -2873,7 +2873,7 @@ gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr) 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)); @@ -3103,6 +3103,29 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) 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); } @@ -6243,6 +6266,8 @@ 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; /* Remove the KIND argument, if present. */ s = expr->value.function.actual; @@ -6252,6 +6277,59 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr) 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 @@ -10390,7 +10468,7 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr) && maskexpr->symtree->n.sym->attr.dummy && maskexpr->symtree->n.sym->attr.optional) return false; - + return true; case GFC_ISYM_TRANSPOSE: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 9b20bdfe787..baba609ada1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2019-03-12 Paul Thomas + + 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 PR middle-end/89663 @@ -731,7 +739,7 @@ 2019-02-25 Dominique d'Humieres PR fortran/89282 - * gfortran.dg/overload_3.f90: New test. + * gfortran.dg/overload_3.f90: New test. 2019-02-25 Jakub Jelinek @@ -741,7 +749,7 @@ 2019-02-25 Dominique d'Humieres PR libfortran/89274 - * gfortran.dg/list_directed_large.f90: New test. + * gfortran.dg/list_directed_large.f90: New test. 2019-02-25 Jakub Jelinek diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_16.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_16.f90 new file mode 100644 index 00000000000..6d8797e0cde --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_16.f90 @@ -0,0 +1,45 @@ +! { 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 +! +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 diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_17.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_17.f90 new file mode 100644 index 00000000000..ec78bafd951 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assumed_rank_17.f90 @@ -0,0 +1,34 @@ +! { 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 +! +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