[fortran] PR fortran/93963 Select rank mishandling allocatable and pointer arguments with bind(c)

Message ID 1c6f46f8-a826-497c-36fa-992286ef902f@gmail.com
State New
Headers show
Series
  • [fortran] PR fortran/93963 Select rank mishandling allocatable and pointer arguments with bind(c)
Related show

Commit Message

José Rui Faustino de Sousa Feb. 28, 2020, 12:20 p.m.
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  <jrfsousa@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  <jrfsousa@gmail.com>

  PR fortran/93963
  * PR93963.f90: New test.


  }

  extern void gfc_desc_to_cfi_desc (CFI_cdesc_t **, const gfc_array_void *);

Patch

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);
+      }