Hi all!
Proposed patch to Bug 93963 - Select rank mishandling allocatable and
pointer arguments with bind(c).
Patch tested only on x86_64-pc-linux-gnu.
cfi_desc_to_gfc_desc, in ISO_Fortran_binding.c, will likely store -1 (or
garbage) in the upper bound of the descriptor for unallocated, or
unassociated, allocatable, or pointer, arrays effectively marking them
as assumed size arrays.
gfc_trans_select_rank_cases, in trans-stmt.c, will check the upper bound
of arguments in order to check for assumed size arrays even if the array
is a pointer or an allocatable.
Thank you very much.
Best regards,
José Rui
2020-2-27 José Rui Faustino de Sousa <jrfso...@gmail.com>
PR fortran/93963
* trans-stmt.c (gfc_trans_select_rank_cases): Add if conditional
short circuiting the evaluation of rank for allocatable and pointer
arguments.
PR fortran/93963
* ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Add if conditional
guarding the calculation of dimensional bounds if the data pointer
is NULL.
2020-2-28 José Rui Faustino de Sousa <jrfso...@gmail.com>
PR fortran/93963
* PR93963.f90: New test.
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 4e9b5ad..6a39bda 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -3641,12 +3641,11 @@ gfc_trans_select_rank_cases (gfc_code * code)
tree low;
tree sexpr;
tree rank;
- tree rank_minus_one;
- tree minus_one;
gfc_se se;
gfc_se cse;
stmtblock_t block;
stmtblock_t body;
+ symbol_attribute attr;
bool def = false;
gfc_start_block (&block);
@@ -3655,25 +3654,35 @@ gfc_trans_select_rank_cases (gfc_code * code)
gfc_init_se (&se, NULL);
gfc_conv_expr_descriptor (&se, code->expr1);
rank = gfc_conv_descriptor_rank (se.expr);
- rank = gfc_evaluate_now (rank, &block);
- minus_one = build_int_cst (TREE_TYPE (rank), -1);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- fold_convert (gfc_array_index_type, rank),
- build_int_cst (gfc_array_index_type, 1));
- rank_minus_one = gfc_evaluate_now (tmp, &block);
- tmp = gfc_conv_descriptor_ubound_get (se.expr, rank_minus_one);
- cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
- tmp, build_int_cst (TREE_TYPE (tmp), -1));
- tmp = fold_build3_loc (input_location, COND_EXPR,
- TREE_TYPE (rank), cond,
- rank, minus_one);
- cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- rank, build_int_cst (TREE_TYPE (rank), 0));
- sexpr = fold_build3_loc (input_location, COND_EXPR,
- TREE_TYPE (rank), cond,
- rank, tmp);
- sexpr = gfc_evaluate_now (sexpr, &block);
+ attr = gfc_expr_attr (code->expr1);
+ if (attr.pointer || attr.allocatable)
+ sexpr = gfc_evaluate_now (rank, &block);
+ else
+ {
+ tree rank_minus_one;
+ tree minus_one;
+
+ rank = gfc_evaluate_now (rank, &block);
+ minus_one = build_int_cst (TREE_TYPE (rank), -1);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ fold_convert (gfc_array_index_type, rank),
+ build_int_cst (gfc_array_index_type, 1));
+ rank_minus_one = gfc_evaluate_now (tmp, &block);
+ tmp = gfc_conv_descriptor_ubound_get (se.expr, rank_minus_one);
+ cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ tmp, build_int_cst (TREE_TYPE (tmp), -1));
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (rank), cond,
+ rank, minus_one);
+ cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+ rank, build_int_cst (TREE_TYPE (rank), 0));
+ sexpr = fold_build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (rank), cond,
+ rank, tmp);
+ sexpr = gfc_evaluate_now (sexpr, &block);
+ }
+
TREE_USED (code->exit_label) = 0;
repeat:
diff --git a/gcc/testsuite/gfortran.dg/PR93963.f90
b/gcc/testsuite/gfortran.dg/PR93963.f90
new file mode 100644
index 0000000..15ab59a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR93963.f90
@@ -0,0 +1,146 @@
+! { dg-do run }
+!
+! PR fortran/93963
+!
+
+function rank_p(this) result(rnk) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_int
+
+ implicit none
+
+ integer(kind=c_int), pointer, intent(in) :: this(..)
+ integer(kind=c_int) :: rnk
+
+ select rank(this)
+ rank(0)
+ rnk = 0
+ rank(1)
+ rnk = 1
+ rank(2)
+ rnk = 2
+ rank(3)
+ rnk = 3
+ rank(4)
+ rnk = 4
+ rank(5)
+ rnk = 5
+ rank(6)
+ rnk = 6
+ rank(7)
+ rnk = 7
+ rank(8)
+ rnk = 8
+ rank(9)
+ rnk = 9
+ rank(10)
+ rnk = 10
+ rank(11)
+ rnk = 11
+ rank(12)
+ rnk = 12
+ rank(13)
+ rnk = 13
+ rank(14)
+ rnk = 14
+ rank(15)
+ rnk = 15
+ rank default
+ rnk = -1000
+ end select
+ return
+end function rank_p
+
+function rank_a(this) result(rnk) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_int
+
+ implicit none
+
+ integer(kind=c_int), allocatable, intent(in) :: this(..)
+ integer(kind=c_int) :: rnk
+
+ select rank(this)
+ rank(0)
+ rnk = 0
+ rank(1)
+ rnk = 1
+ rank(2)
+ rnk = 2
+ rank(3)
+ rnk = 3
+ rank(4)
+ rnk = 4
+ rank(5)
+ rnk = 5
+ rank(6)
+ rnk = 6
+ rank(7)
+ rnk = 7
+ rank(8)
+ rnk = 8
+ rank(9)
+ rnk = 9
+ rank(10)
+ rnk = 10
+ rank(11)
+ rnk = 11
+ rank(12)
+ rnk = 12
+ rank(13)
+ rnk = 13
+ rank(14)
+ rnk = 14
+ rank(15)
+ rnk = 15
+ rank default
+ rnk = -1000
+ end select
+ return
+end function rank_a
+
+program selr_p
+
+ use, intrinsic :: iso_c_binding, only: c_int
+
+ implicit none
+
+ interface
+ function rank_p(this) result(rnk) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(kind=c_int), pointer, intent(in) :: this(..)
+ integer(kind=c_int) :: rnk
+ end function rank_p
+ end interface
+
+ interface
+ function rank_a(this) result(rnk) bind(c)
+ use, intrinsic :: iso_c_binding, only: c_int
+ integer(kind=c_int), allocatable, intent(in) :: this(..)
+ integer(kind=c_int) :: rnk
+ end function rank_a
+ end interface
+
+ integer(kind=c_int), parameter :: siz = 7
+ integer(kind=c_int), parameter :: rnk = 1
+
+ integer(kind=c_int), pointer :: intp(:)
+ integer(kind=c_int), allocatable :: inta(:)
+
+ nullify(intp)
+ if(rank(intp)/=rnk) stop 1
+ if(rank_p(intp)/=rnk) stop 2
+ !
+ if(rank(inta)/=rnk) stop 3
+ if(rank_a(inta)/=rnk) stop 4
+ !
+ allocate(intp(siz))
+ if(rank(intp)/=rnk) stop 5
+ if(rank_p(intp)/=rnk) stop 6
+ deallocate(intp)
+ nullify(intp)
+ !
+ allocate(inta(siz))
+ if(rank(inta)/=rnk) stop 7
+ if(rank_a(inta)/=rnk) stop 8
+ deallocate(inta)
+
+end program selr_p
diff --git a/libgfortran/runtime/ISO_Fortran_binding.c
b/libgfortran/runtime/ISO_Fortran_binding.c
index a546b04..cd304f6 100644
--- a/libgfortran/runtime/ISO_Fortran_binding.c
+++ b/libgfortran/runtime/ISO_Fortran_binding.c
@@ -74,14 +74,15 @@ cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t
**s_ptr)
}
d->offset = 0;
- for (n = 0; n < GFC_DESCRIPTOR_RANK (d); n++)
- {
- GFC_DESCRIPTOR_LBOUND(d, n) = (index_type)s->dim[n].lower_bound;
- GFC_DESCRIPTOR_UBOUND(d, n) = (index_type)(s->dim[n].extent
- + s->dim[n].lower_bound - 1);
- GFC_DESCRIPTOR_STRIDE(d, n) = (index_type)(s->dim[n].sm /
s->elem_len);
- d->offset -= GFC_DESCRIPTOR_STRIDE(d, n) *
GFC_DESCRIPTOR_LBOUND(d, n);
- }
+ if (GFC_DESCRIPTOR_DATA (d))
+ for (n = 0; n < GFC_DESCRIPTOR_RANK (d); n++)
+ {
+ GFC_DESCRIPTOR_LBOUND(d, n) = (index_type)s->dim[n].lower_bound;
+ GFC_DESCRIPTOR_UBOUND(d, n) = (index_type)(s->dim[n].extent
+ + s->dim[n].lower_bound - 1);
+ GFC_DESCRIPTOR_STRIDE(d, n) = (index_type)(s->dim[n].sm / s->elem_len);
+ d->offset -= GFC_DESCRIPTOR_STRIDE(d, n) * GFC_DESCRIPTOR_LBOUND(d, n);
+ }
}
extern void gfc_desc_to_cfi_desc (CFI_cdesc_t **, const gfc_array_void *);
