diff mbox series

[fortran] PR fortran/93308/93963/94327/94331/97046 problems raised by descriptor handling

Message ID d4ab0f10-f417-fe6a-bca2-c5a7a03b6225@gmail.com
State New
Headers show
Series [fortran] PR fortran/93308/93963/94327/94331/97046 problems raised by descriptor handling | expand

Commit Message

José Rui Faustino de Sousa May 19, 2021, 6:03 p.m. UTC
Hi all!

Proposed patch to:

Bug 93308 - bind(c) subroutine changes lower bound of array argument in 
caller
Bug 93963 - Select rank mishandling allocatable and pointer arguments 
with bind(c)
Bug 94327 - Bind(c) argument attributes are incorrectly set
Bug 94331 - Bind(C) corrupts array descriptors
Bug 97046 - Bad interaction between lbound/ubound, allocatable arrays 
and bind(C) subroutine with dimension(..) parameter

Patch tested only on x86_64-pc-linux-gnu.

Fix attribute handling, which reflect a prior intermediate version of 
the Fortran standard.

CFI descriptors, in most cases, should not be copied out has they can 
corrupt the Fortran descriptor. Bounds will vary and the original 
Fortran bounds are definitively lost on conversion.

Thank you very much.

Best regards,
José Rui

Fortran: Fix attributtes and bounds in ISO_Fortran_binding.

gcc/fortran/ChangeLog:

	PR fortran/93308
	PR fortran/93963
	PR fortran/94327
	PR fortran/94331
	PR fortran/97046
	* trans-decl.c (convert_CFI_desc): Only copy out the descriptor
	if necessary.
	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Updated attribute
	handling which reflect a previous intermediate version of the
	standard. Only copy out the descriptor if necessary.

libgfortran/ChangeLog:

	PR fortran/93308
	PR fortran/93963
	PR fortran/94327
	PR fortran/94331
	PR fortran/97046
	* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc): Add code
	to verify the descriptor. Correct bounds calculation.
	(gfc_desc_to_cfi_desc): Add code to verify the descriptor.

gcc/testsuite/ChangeLog:

	PR fortran/93308
	PR fortran/93963
	PR fortran/94327
	PR fortran/94331
	PR fortran/97046
	* gfortran.dg/ISO_Fortran_binding_1.f90: Add pointer attribute,
	this test is still erroneous but now it compiles.
	* gfortran.dg/bind_c_array_params_2.f90: Update regex to match
	code changes.
	* gfortran.dg/PR93308.f90: New test.
	* gfortran.dg/PR93963.f90: New test.
	* gfortran.dg/PR94327.c: New test.
	* gfortran.dg/PR94327.f90: New test.
	* gfortran.dg/PR94331.c: New test.
	* gfortran.dg/PR94331.f90: New test.
	* gfortran.dg/PR97046.f90: New test.
diff mbox series

Patch

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 406b4ae..9fb4ef9 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -4519,22 +4519,28 @@  convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
       gfc_add_expr_to_block (&outer_block, incoming);
       incoming = gfc_finish_block (&outer_block);
 
-
       /* Convert the gfc descriptor back to the CFI type before going
 	 out of scope, if the CFI type was present at entry.  */
-      gfc_init_block (&outer_block);
-      gfc_init_block (&tmpblock);
-
-      tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
-      outgoing = build_call_expr_loc (input_location,
-			gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
-      gfc_add_expr_to_block (&tmpblock, outgoing);
+      outgoing = NULL_TREE;
+      if ((sym->attr.pointer || sym->attr.allocatable)
+	  && !sym->attr.value
+	  && sym->attr.intent != INTENT_IN)
+	{
+	  gfc_init_block (&outer_block);
+	  gfc_init_block (&tmpblock);
 
-      outgoing = build3_v (COND_EXPR, present,
-			   gfc_finish_block (&tmpblock),
-			   build_empty_stmt (input_location));
-      gfc_add_expr_to_block (&outer_block, outgoing);
-      outgoing = gfc_finish_block (&outer_block);
+	  tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
+	  outgoing = build_call_expr_loc (input_location,
+					  gfor_fndecl_gfc_to_cfi, 2,
+					  tmp, gfc_desc_ptr);
+	  gfc_add_expr_to_block (&tmpblock, outgoing);
+
+	  outgoing = build3_v (COND_EXPR, present,
+			       gfc_finish_block (&tmpblock),
+			       build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&outer_block, outgoing);
+	  outgoing = gfc_finish_block (&outer_block);
+	}
 
       /* Add the lot to the procedure init and finally blocks.  */
       gfc_add_init_cleanup (block, incoming, outgoing);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index cce18d0..1f84d57 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5460,13 +5460,12 @@  gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
 	attribute = 1;
     }
 
-  /* If the formal argument is assumed shape and neither a pointer nor
-     allocatable, it is unconditionally CFI_attribute_other.  */
-  if (fsym->as->type == AS_ASSUMED_SHAPE
-      && !fsym->attr.pointer && !fsym->attr.allocatable)
-   cfi_attribute = 2;
+  if (fsym->attr.pointer)
+    cfi_attribute = 0;
+  else if (fsym->attr.allocatable)
+    cfi_attribute = 1;
   else
-   cfi_attribute = attribute;
+    cfi_attribute = 2;
 
   if (e->rank != 0)
     {
@@ -5574,10 +5573,15 @@  gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
   gfc_prepend_expr_to_block (&parmse->post, tmp);
 
   /* Transfer values back to gfc descriptor.  */
-  tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
-  tmp = build_call_expr_loc (input_location,
-			     gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
-  gfc_prepend_expr_to_block (&parmse->post, tmp);
+  if (cfi_attribute != 2
+      && !fsym->attr.value
+      && fsym->attr.intent != INTENT_IN)
+    {
+      tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+      tmp = build_call_expr_loc (input_location,
+				 gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
+      gfc_prepend_expr_to_block (&parmse->post, tmp);
+    }
 
   /* Deal with an optional dummy being passed to an optional formal arg
      by finishing the pre and post blocks and making their execution
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90
index 102bc60..0cf3b2c 100644
--- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90
@@ -39,7 +39,7 @@ 
       USE, INTRINSIC :: ISO_C_BINDING
       import
       INTEGER(C_INT) :: err
-      type (T), DIMENSION(..), intent(out) :: a
+      type (T), pointer, DIMENSION(..), intent(out) :: a
     END FUNCTION c_establish
 
     FUNCTION c_contiguous(a) BIND(C, NAME="contiguous_c") RESULT(err)
diff --git a/gcc/testsuite/gfortran.dg/PR93308.f90 b/gcc/testsuite/gfortran.dg/PR93308.f90
new file mode 100644
index 0000000..ee116f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR93308.f90
@@ -0,0 +1,52 @@ 
+! { dg-do run }
+!
+! Test the fix for PR94331
+!
+! Contributed by Robin Hogan <r.j.hogan@reading.ac.uk>
+!
+
+program test 
+
+  use, intrinsic :: iso_c_binding, only: &
+    c_int, c_float
+
+  implicit none
+
+  integer                       :: i
+  integer,            parameter :: n = 11
+  real(kind=c_float), parameter :: u(*) = [(real(i, kind=c_float), i=1,n)]
+  
+  real(kind=c_float), allocatable :: A(:)
+  real(kind=c_float)              :: E(n)
+  integer(kind=c_int)             :: l1, l2, l3
+
+  allocate(A, source=u)
+  l1 = lbound(A, 1)
+  call routine_bindc(A, l2) ! in gcc-9.2.1 this changes lbound of A...
+  l3 = lbound(A, 1)
+  if (l1 /= 1)                        stop 1
+  if (l1 /= l2)                       stop 2
+  if (l1 /= l3)                       stop 3
+  if (any(abs(A(1:n)-u)>0.0_c_float)) stop 4
+  deallocate(A)
+  !
+  E = u
+  l1 = lbound(E, 1)
+  call routine_bindc(E, l2) ! ...but does not change lbound of E
+  l3 = lbound(E, 1)
+  if (l1 /= 1)                        stop 5
+  if (l1 /= l2)                       stop 6
+  if (l1 /= l3)                       stop 7
+  if (any(abs(E(1:n)-u)>0.0_c_float)) stop 8
+
+contains
+
+  subroutine routine_bindc(v, l) bind(c)
+    real(kind=c_float),  intent(inout) :: v(:)
+    integer(kind=c_int), intent(out)   :: l
+    
+    l = lbound(v, 1)
+    if (any(abs(v(1:n)-u)>0.0_c_float)) stop 9
+  end subroutine routine_bindc
+  
+end program test
diff --git a/gcc/testsuite/gfortran.dg/PR93963.f90 b/gcc/testsuite/gfortran.dg/PR93963.f90
new file mode 100644
index 0000000..4e1b06f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR93963.f90
@@ -0,0 +1,150 @@ 
+! { dg-do run }
+!
+! Test the fix for PR93963
+!
+
+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(:)
+  integer(kind=c_int)              :: irnk
+
+  nullify(intp)
+  irnk = rank_p(intp)
+  if (irnk /= rnk)        stop 1
+  if (irnk /= rank(intp)) stop 2
+  !
+  irnk = rank_a(inta)
+  if (irnk /= rnk)        stop 3
+  if (irnk /= rank(inta)) stop 4
+  !
+  allocate(intp(siz))
+  irnk = rank_p(intp)
+  if (irnk /= rnk)        stop 5
+  if (irnk /= rank(intp)) stop 6
+  deallocate(intp)
+  nullify(intp)
+  !
+  allocate(inta(siz))
+  if (irnk /= rnk)        stop 7
+  if (irnk /= rank(inta)) stop 8
+  deallocate(inta)
+
+end program selr_p
diff --git a/gcc/testsuite/gfortran.dg/PR94327.c b/gcc/testsuite/gfortran.dg/PR94327.c
new file mode 100644
index 0000000..6791c37
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR94327.c
@@ -0,0 +1,70 @@ 
+/* Test the fix for PR94327.  */
+
+#include <assert.h>
+#include <stdbool.h>
+#include <stdlib.h>
+
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+
+bool c_vrfy (const CFI_cdesc_t *restrict);
+
+char get_attr (const CFI_cdesc_t*restrict, bool);
+
+bool
+c_vrfy (const CFI_cdesc_t *restrict auxp)
+{
+  CFI_index_t i, lb, ub, ex;
+  int *ip = NULL;
+
+  assert (auxp);
+  assert (auxp->base_addr);
+  lb = auxp->dim[0].lower_bound;
+  ex = auxp->dim[0].extent;
+  ub = ex + lb - 1;
+  ip = (int*)auxp->base_addr;
+  for (i=0; i<ex; i++)
+    if (*ip++ != i+1)
+      return false;
+  for (i=lb; i<ub+1; i++)
+    {
+      ip = (int*)CFI_address(auxp, &i);
+      if (*ip != i-lb+1)
+	return false;
+    }
+  return true;
+}
+
+char
+get_attr (const CFI_cdesc_t *restrict auxp, bool alloc)
+{
+  char attr;
+  
+  assert (auxp);
+  assert (auxp->elem_len == 4);
+  assert (auxp->rank == 1);
+  assert (auxp->type == CFI_type_int);
+  attr = '\0';
+  switch (auxp->attribute)
+    {
+    case CFI_attribute_pointer:
+      if (alloc && !c_vrfy (auxp))
+	break;
+      attr = 'p';
+      break;
+    case CFI_attribute_allocatable:
+      if (alloc && !c_vrfy (auxp))
+	break;
+      attr = 'a';
+      break;
+    case CFI_attribute_other:
+      assert (alloc);
+      if (!c_vrfy (auxp))
+	break;
+      attr = 'o';
+      break;
+    default:
+      break;
+    }
+  return attr;
+}
+
diff --git a/gcc/testsuite/gfortran.dg/PR94327.f90 b/gcc/testsuite/gfortran.dg/PR94327.f90
new file mode 100644
index 0000000..3cb3ac3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR94327.f90
@@ -0,0 +1,195 @@ 
+! { dg-do run }
+! { dg-additional-sources PR94327.c }
+!
+! Test the fix for PR94327
+!
+
+program attr_p
+  
+  use, intrinsic :: iso_c_binding, only: &
+    c_int, c_bool, c_char
+
+  implicit none
+
+  integer            :: i
+  integer, parameter :: n = 11
+  integer, parameter :: u(*) = [(i, i=1,n)]
+  
+  interface
+    function attr_p_as(a, s) result(c) &
+      bind(c, name="get_attr")
+      use, intrinsic :: iso_c_binding, only: &
+        c_int, c_bool, c_char
+      implicit none
+      integer(kind=c_int), pointer, intent(in) :: a(:)
+      logical(kind=c_bool),  value, intent(in) :: s
+      character(kind=c_char)                   :: c
+    end function attr_p_as
+    function attr_a_as(a, s) result(c) &
+      bind(c, name="get_attr")
+      use, intrinsic :: iso_c_binding, only: &
+        c_int, c_bool, c_char
+      implicit none
+      integer(kind=c_int), allocatable, intent(in) :: a(:)
+      logical(kind=c_bool),      value, intent(in) :: s
+      character(kind=c_char)                       :: c
+    end function attr_a_as
+    function attr_o_as(a, s) result(c) &
+      bind(c, name="get_attr")
+      use, intrinsic :: iso_c_binding, only: &
+        c_int, c_bool, c_char
+      implicit none
+      integer(kind=c_int),         intent(in) :: a(:)
+      logical(kind=c_bool), value, intent(in) :: s
+      character(kind=c_char)                  :: c
+    end function attr_o_as
+    function attr_p_ar(a, s) result(c) &
+      bind(c, name="get_attr")
+      use, intrinsic :: iso_c_binding, only: &
+        c_int, c_bool, c_char
+      implicit none
+      integer(kind=c_int), pointer, intent(in) :: a(..)
+      logical(kind=c_bool),  value, intent(in) :: s
+      character(kind=c_char)                   :: c
+    end function attr_p_ar
+    function attr_a_ar(a, s) result(c) &
+      bind(c, name="get_attr")
+      use, intrinsic :: iso_c_binding, only: &
+        c_int, c_bool, c_char
+      implicit none
+      integer(kind=c_int), allocatable, intent(in) :: a(..)
+      logical(kind=c_bool),      value, intent(in) :: s
+      character(kind=c_char)                       :: c
+    end function attr_a_ar
+    function attr_o_ar(a, s) result(c) &
+      bind(c, name="get_attr")
+      use, intrinsic :: iso_c_binding, only: &
+        c_int, c_bool, c_char
+      implicit none
+      integer(kind=c_int),         intent(in) :: a(..)
+      logical(kind=c_bool), value, intent(in) :: s
+      character(kind=c_char)                  :: c
+    end function attr_o_ar
+  end interface
+
+  integer(kind=c_int),              target :: a(n)
+  integer(kind=c_int), allocatable, target :: b(:)
+  integer(kind=c_int),             pointer :: p(:)
+  character(kind=c_char)                   :: c
+
+  a = u
+  c = attr_p_as(a, .true._c_bool)
+  if(c/='p')                stop 1
+  if(any(a/=u))             stop 2
+  !
+  a = u
+  c = attr_p_ar(a, .true._c_bool)
+  if(c/='p')                stop 3
+  if(any(a/=u))             stop 4
+  !
+  a = u
+  c = attr_o_as(a, .true._c_bool)
+  if(c/='o')                stop 5
+  if(any(a/=u))             stop 6
+  !
+  a = u
+  c = attr_o_ar(a, .true._c_bool)
+  if(c/='o')                stop 7
+  if(any(a/=u))             stop 8
+  !
+  allocate(b, source=u)
+  c = attr_p_as(b, .true._c_bool)
+  if(c/='p')                stop 9
+  if(.not.allocated(b))     stop 10
+  if(any(b/=u))             stop 11
+  !
+  deallocate(b)
+  allocate(b, source=u)
+  c = attr_p_ar(b, .true._c_bool)
+  if(c/='p')                stop 12
+  if(.not.allocated(b))     stop 13
+  if(any(b/=u))             stop 14
+  !
+  deallocate(b)
+  allocate(b, source=u)
+  c = attr_a_as(b, .true._c_bool)
+  if(c/='a')                stop 15
+  if(.not.allocated(b))     stop 16
+  if(any(b/=u))             stop 17
+  !
+  deallocate(b)
+  allocate(b, source=u)
+  c = attr_a_ar(b, .true._c_bool)
+  if(c/='a')                stop 18
+  if(.not.allocated(b))     stop 19
+  if(any(b/=u))             stop 20
+  !
+  deallocate(b)
+  allocate(b, source=u)
+  c = attr_o_as(b, .true._c_bool)
+  if(c/='o')                stop 21
+  if(.not.allocated(b))     stop 22
+  if(any(b/=u))             stop 23
+  !
+  deallocate(b)
+  allocate(b, source=u)
+  c = attr_o_ar(b, .true._c_bool)
+  if(c/='o')                stop 24
+  if(.not.allocated(b))     stop 25
+  if(any(b/=u))             stop 26
+  !
+  deallocate(b)
+  c = attr_a_as(b, .false._c_bool)
+  if(c/='a')                stop 27
+  if(allocated(b))          stop 28
+  !
+  c = attr_a_ar(b, .false._c_bool)
+  if(c/='a')                stop 29
+  if(allocated(b))          stop 30
+  !
+  nullify(p)
+  p => a
+  c = attr_p_as(p, .true._c_bool)
+  if(c/='p')                stop 31
+  if(.not.associated(p))    stop 32
+  if(.not.associated(p, a)) stop 33
+  if(any(p/=u))             stop 34
+  !
+  nullify(p)
+  p => a
+  c = attr_p_ar(p, .true._c_bool)
+  if(c/='p')                stop 35
+  if(.not.associated(p))    stop 36
+  if(.not.associated(p, a)) stop 37
+  if(any(p/=u))             stop 38
+  !
+  nullify(p)
+  p => a
+  c = attr_o_as(p, .true._c_bool)
+  if(c/='o')                stop 39
+  if(.not.associated(p))    stop 40
+  if(.not.associated(p, a)) stop 41
+  if(any(p/=u))             stop 42
+  !
+  nullify(p)
+  p => a
+  c = attr_o_ar(p, .true._c_bool)
+  if(c/='o')                stop 43
+  if(.not.associated(p))    stop 44
+  if(.not.associated(p, a)) stop 45
+  if(any(p/=u))             stop 46
+  !
+  nullify(p)
+  c = attr_p_as(p, .false._c_bool)
+  if(c/='p')                stop 47
+  if(associated(p))         stop 48
+  if(associated(p, a))      stop 49
+  !
+  nullify(p)
+  c = attr_p_ar(p, .false._c_bool)
+  if(c/='p')                stop 50
+  if(associated(p))         stop 51
+  if(associated(p, a))      stop 52
+  stop
+
+end program attr_p
diff --git a/gcc/testsuite/gfortran.dg/PR94331.c b/gcc/testsuite/gfortran.dg/PR94331.c
new file mode 100644
index 0000000..8ec71dd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR94331.c
@@ -0,0 +1,73 @@ 
+/* Test the fix for PR94331.  */
+
+#include <assert.h>
+#include <stdbool.h>
+#include <stdlib.h>
+
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+
+bool c_vrfy (const CFI_cdesc_t *restrict);
+
+bool check_bounds(const CFI_cdesc_t*restrict, const CFI_index_t, const CFI_index_t);
+
+bool
+c_vrfy (const CFI_cdesc_t *restrict auxp)
+{
+  CFI_index_t i, lb, ub, ex;
+  int *ip = NULL;
+
+  assert (auxp);
+  assert (auxp->base_addr);
+  lb = auxp->dim[0].lower_bound;
+  ex = auxp->dim[0].extent;
+  ub = ex + lb - 1;
+  ip = (int*)auxp->base_addr;
+  for (i=0; i<ex; i++)
+    if (*ip++ != i+1)
+      return false;
+  for (i=lb; i<ub+1; i++)
+    {
+      ip = (int*)CFI_address(auxp, &i);
+      if (*ip != i-lb+1)
+	return false;
+    }
+  return true;
+}
+
+bool
+check_bounds (const CFI_cdesc_t *restrict auxp, const CFI_index_t lb, const CFI_index_t ub)
+{
+  CFI_index_t ex = ub-lb+1;
+  size_t el;
+  bool is_ok = false;
+  
+  assert (auxp);
+  el = auxp->elem_len;
+  assert (auxp->rank==1);
+  assert (auxp->type==CFI_type_int);
+  assert (auxp->dim[0].sm>0);
+  assert ((size_t)auxp->dim[0].sm==el);
+  if (auxp->dim[0].extent==ex
+      && auxp->dim[0].lower_bound==lb)
+    {
+    switch(auxp->attribute)
+      {
+      case CFI_attribute_pointer:
+      case CFI_attribute_allocatable:
+	if (!c_vrfy (auxp))
+	  break;
+	is_ok = true;
+	break;
+      case CFI_attribute_other:
+	if (!c_vrfy (auxp))
+	  break;
+	is_ok = (lb==0);
+	break;
+      default:
+	assert (false);
+	break;
+      }
+    }
+  return is_ok;
+}
+
diff --git a/gcc/testsuite/gfortran.dg/PR94331.f90 b/gcc/testsuite/gfortran.dg/PR94331.f90
new file mode 100644
index 0000000..6185031
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR94331.f90
@@ -0,0 +1,252 @@ 
+! { dg-do run }
+! { dg-additional-sources PR94331.c }
+!
+! Test the fix for PR94331
+!
+
+program main_p
+  
+  use, intrinsic :: iso_c_binding, only: &
+    c_int
+
+  implicit none
+
+  integer            :: i
+  integer, parameter :: ex = 11
+  integer, parameter :: lb = 11
+  integer, parameter :: ub = ex+lb-1
+  integer, parameter :: u(*) = [(i, i=1,ex)]
+  
+  interface
+    function checkb_p_as(a, l, u) result(c) &
+      bind(c, name="check_bounds")
+      use, intrinsic :: iso_c_binding, only: &
+        c_int, c_bool
+      implicit none
+      integer(kind=c_int), pointer, intent(in) :: a(:)
+      integer(kind=c_int),   value, intent(in) :: l
+      integer(kind=c_int),   value, intent(in) :: u
+      logical(kind=c_bool)                     :: c
+    end function checkb_p_as
+    function checkb_a_as(a, l, u) result(c) &
+      bind(c, name="check_bounds")
+      use, intrinsic :: iso_c_binding, only: &
+        c_int, c_bool
+      implicit none
+      integer(kind=c_int), allocatable, intent(in) :: a(:)
+      integer(kind=c_int),       value, intent(in) :: l
+      integer(kind=c_int),       value, intent(in) :: u
+      logical(kind=c_bool)                         :: c
+    end function checkb_a_as
+    function checkb_o_as(a, l, u) result(c) &
+      bind(c, name="check_bounds")
+      use, intrinsic :: iso_c_binding, only: &
+        c_int, c_bool
+      implicit none
+      integer(kind=c_int),        intent(in) :: a(:)
+      integer(kind=c_int), value, intent(in) :: l
+      integer(kind=c_int), value, intent(in) :: u
+      logical(kind=c_bool)                   :: c
+    end function checkb_o_as
+    function checkb_p_ar(a, l, u) result(c) &
+      bind(c, name="check_bounds")
+      use, intrinsic :: iso_c_binding, only: &
+        c_int, c_bool
+      implicit none
+      integer(kind=c_int), pointer, intent(in) :: a(..)
+      integer(kind=c_int),   value, intent(in) :: l
+      integer(kind=c_int),   value, intent(in) :: u
+      logical(kind=c_bool)                     :: c
+    end function checkb_p_ar
+    function checkb_a_ar(a, l, u) result(c) &
+      bind(c, name="check_bounds")
+      use, intrinsic :: iso_c_binding, only: &
+        c_int, c_bool
+      implicit none
+      integer(kind=c_int), allocatable, intent(in) :: a(..)
+      integer(kind=c_int),       value, intent(in) :: l
+      integer(kind=c_int),       value, intent(in) :: u
+      logical(kind=c_bool)                         :: c
+    end function checkb_a_ar
+    function checkb_o_ar(a, l, u) result(c) &
+      bind(c, name="check_bounds")
+      use, intrinsic :: iso_c_binding, only: &
+        c_int, c_bool
+      implicit none
+      integer(kind=c_int),        intent(in) :: a(..)
+      integer(kind=c_int), value, intent(in) :: l
+      integer(kind=c_int), value, intent(in) :: u
+      logical(kind=c_bool)                   :: c
+    end function checkb_o_ar
+  end interface
+
+  integer(kind=c_int),              target :: a(lb:ub)
+  integer(kind=c_int), allocatable, target :: b(:)
+  integer(kind=c_int),             pointer :: p(:)
+
+  a = u
+  if(lbound(a,1)/=lb)             stop 1
+  if(ubound(a,1)/=ub)             stop 2
+  if(any(shape(a)/=[ex]))         stop 3
+  if(.not.checkb_p_as(a, lb, ub)) stop 4
+  if(lbound(a,1)/=lb)             stop 5
+  if(ubound(a,1)/=ub)             stop 6
+  if(any(shape(a)/=[ex]))         stop 7
+  if(any(a/=u))                   stop 8
+  !
+  a = u
+  if(lbound(a,1)/=lb)             stop 9
+  if(ubound(a,1)/=ub)             stop 10
+  if(any(shape(a)/=[ex]))         stop 11
+  if(.not.checkb_p_ar(a, lb, ub)) stop 12
+  if(lbound(a,1)/=lb)             stop 13
+  if(ubound(a,1)/=ub)             stop 14
+  if(any(shape(a)/=[ex]))         stop 15
+  if(any(a/=u))                   stop 16
+  !
+  a = u
+  if(lbound(a,1)/=lb)             stop 17
+  if(ubound(a,1)/=ub)             stop 18
+  if(any(shape(a)/=[ex]))         stop 19
+  if(.not.checkb_o_as(a, 0, ex-1))stop 20
+  if(lbound(a,1)/=lb)             stop 21
+  if(ubound(a,1)/=ub)             stop 22
+  if(any(shape(a)/=[ex]))         stop 23
+  if(any(a/=u))                   stop 24
+  !
+  a = u
+  if(lbound(a,1)/=lb)             stop 25
+  if(ubound(a,1)/=ub)             stop 26
+  if(any(shape(a)/=[ex]))         stop 27
+  if(.not.checkb_o_ar(a, 0, ex-1))stop 28
+  if(lbound(a,1)/=lb)             stop 29
+  if(ubound(a,1)/=ub)             stop 30
+  if(any(shape(a)/=[ex]))         stop 31
+  if(any(a/=u))                   stop 32
+  !
+  allocate(b(lb:ub), source=u)
+  if(lbound(b,1)/=lb)             stop 33
+  if(ubound(b,1)/=ub)             stop 34
+  if(any(shape(b)/=[ex]))         stop 35
+  if(.not.checkb_p_as(b, lb, ub)) stop 36
+  if(.not.allocated(b))           stop 37
+  if(lbound(b,1)/=lb)             stop 38
+  if(ubound(b,1)/=ub)             stop 39
+  if(any(shape(b)/=[ex]))         stop 40
+  if(any(b/=u))                   stop 41
+  !
+  deallocate(b)
+  allocate(b(lb:ub), source=u)
+  if(lbound(b,1)/=lb)             stop 42
+  if(ubound(b,1)/=ub)             stop 43
+  if(any(shape(b)/=[ex]))         stop 44
+  if(.not.checkb_p_ar(b, lb, ub)) stop 45
+  if(.not.allocated(b))           stop 46
+  if(lbound(b,1)/=lb)             stop 47
+  if(ubound(b,1)/=ub)             stop 48
+  if(any(shape(b)/=[ex]))         stop 49
+  if(any(b/=u))                   stop 50
+  !
+  deallocate(b)
+  allocate(b(lb:ub), source=u)
+  if(lbound(b,1)/=lb)             stop 51
+  if(ubound(b,1)/=ub)             stop 52
+  if(any(shape(b)/=[ex]))         stop 53
+  if(.not.checkb_a_as(b, lb, ub)) stop 54
+  if(.not.allocated(b))           stop 55
+  if(lbound(b,1)/=lb)             stop 56
+  if(ubound(b,1)/=ub)             stop 57
+  if(any(shape(b)/=[ex]))         stop 58
+  if(any(b/=u))                   stop 59
+  !
+  deallocate(b)
+  allocate(b(lb:ub), source=u)
+  if(lbound(b,1)/=lb)             stop 60
+  if(ubound(b,1)/=ub)             stop 61
+  if(any(shape(b)/=[ex]))         stop 62
+  if(.not.checkb_a_ar(b, lb, ub)) stop 63
+  if(.not.allocated(b))           stop 64
+  if(lbound(b,1)/=lb)             stop 65
+  if(ubound(b,1)/=ub)             stop 66
+  if(any(shape(b)/=[ex]))         stop 67
+  if(any(b/=u))                   stop 68
+  !
+  deallocate(b)
+  allocate(b(lb:ub), source=u)
+  if(lbound(b,1)/=lb)             stop 69
+  if(ubound(b,1)/=ub)             stop 70
+  if(any(shape(b)/=[ex]))         stop 71
+  if(.not.checkb_o_as(b, 0, ex-1))stop 72
+  if(.not.allocated(b))           stop 73
+  if(lbound(b,1)/=lb)             stop 74
+  if(ubound(b,1)/=ub)             stop 75
+  if(any(shape(b)/=[ex]))         stop 76
+  if(any(b/=u))                   stop 77
+  !
+  deallocate(b)
+  allocate(b(lb:ub), source=u)
+  if(lbound(b,1)/=lb)             stop 78
+  if(ubound(b,1)/=ub)             stop 79
+  if(any(shape(b)/=[ex]))         stop 80
+  if(.not.checkb_o_ar(b, 0, ex-1))stop 81
+  if(.not.allocated(b))           stop 82
+  if(lbound(b,1)/=lb)             stop 83
+  if(ubound(b,1)/=ub)             stop 84
+  if(any(shape(b)/=[ex]))         stop 85
+  if(any(b/=u))                   stop 86
+  deallocate(b)
+  !
+  p(lb:ub) => a
+  if(lbound(p,1)/=lb)             stop 87
+  if(ubound(p,1)/=ub)             stop 88
+  if(any(shape(p)/=[ex]))         stop 89
+  if(.not.checkb_p_as(p, lb, ub)) stop 90
+  if(.not.associated(p))          stop 91
+  if(.not.associated(p, a))       stop 92
+  if(lbound(p,1)/=lb)             stop 93
+  if(ubound(p,1)/=ub)             stop 94
+  if(any(shape(p)/=[ex]))         stop 95
+  if(any(p/=u))                   stop 96
+  !
+  nullify(p)
+  p(lb:ub) => a
+  if(lbound(p,1)/=lb)             stop 97
+  if(ubound(p,1)/=ub)             stop 98
+  if(any(shape(p)/=[ex]))         stop 99
+  if(.not.checkb_p_ar(p, lb, ub)) stop 100
+  if(.not.associated(p))          stop 101
+  if(.not.associated(p, a))       stop 102
+  if(lbound(p,1)/=lb)             stop 103
+  if(ubound(p,1)/=ub)             stop 104
+  if(any(shape(p)/=[ex]))         stop 105
+  if(any(p/=u))                   stop 106
+  !
+  nullify(p)
+  p(lb:ub) => a
+  if(lbound(p,1)/=lb)             stop 107
+  if(ubound(p,1)/=ub)             stop 108
+  if(any(shape(p)/=[ex]))         stop 109
+  if(.not.checkb_o_as(p, 0, ex-1))stop 110
+  if(.not.associated(p))          stop 111
+  if(.not.associated(p, a))       stop 112
+  if(lbound(p,1)/=lb)             stop 113
+  if(ubound(p,1)/=ub)             stop 114
+  if(any(shape(p)/=[ex]))         stop 115
+  if(any(p/=u))                   stop 116
+  !
+  nullify(p)
+  p(lb:ub) => a
+  if(lbound(p,1)/=lb)             stop 117
+  if(ubound(p,1)/=ub)             stop 118
+  if(any(shape(p)/=[ex]))         stop 119
+  if(.not.checkb_o_ar(p, 0, ex-1))stop 120
+  if(.not.associated(p))          stop 121
+  if(.not.associated(p, a))       stop 122
+  if(lbound(p,1)/=lb)             stop 123
+  if(ubound(p,1)/=ub)             stop 124
+  if(any(shape(p)/=[ex]))         stop 125
+  if(any(p/=u))                   stop 126
+  nullify(p)
+  stop
+  
+end program main_p
diff --git a/gcc/testsuite/gfortran.dg/PR97046.f90 b/gcc/testsuite/gfortran.dg/PR97046.f90
new file mode 100644
index 0000000..7d133a5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR97046.f90
@@ -0,0 +1,58 @@ 
+! { dg-do run }
+!
+! Test the fix for PR94331
+!
+! Contributed by Igor Gayday <igor.gayday@mu.edu>
+!
+
+MODULE FOO
+
+  implicit none
+  
+  INTEGER, parameter :: n = 11
+
+contains
+  
+  SUBROUTINE dummyc(x0) BIND(C)
+    type(*), dimension(..) :: x0
+    if(LBOUND(x0,1)/=1) stop 5
+    if(UBOUND(x0,1)/=n) stop 6
+    if(rank(x0)/=1)     stop 7
+  END SUBROUTINE dummyc
+  
+  SUBROUTINE dummy(x0)
+    type(*), dimension(..) :: x0
+    call dummyc(x0)
+  END SUBROUTINE dummy
+  
+END MODULE
+
+PROGRAM main
+    USE FOO
+    IMPLICIT NONE
+    integer :: before(2), after(2)
+
+    DOUBLE PRECISION, ALLOCATABLE :: buf(:)
+    DOUBLE PRECISION :: buf2(n)
+
+    ALLOCATE(buf(n))
+    before(1) = LBOUND(buf,1)
+    before(2) = UBOUND(buf,1)
+    CALL dummy (buf)
+    after(1) = LBOUND(buf,1)
+    after(2) = UBOUND(buf,1)
+    deallocate(buf)
+
+    if (before(1) .NE. after(1)) stop 1
+    if (before(2) .NE. after(2)) stop 2
+
+    before(1) = LBOUND(buf2,1)
+    before(2) = UBOUND(buf2,1)
+    CALL dummy (buf2)
+    after(1) = LBOUND(buf2,1)
+    after(2) = UBOUND(buf2,1)
+
+    if (before(1) .NE. after(1)) stop 3
+    if (before(2) .NE. after(2)) stop 4
+
+END PROGRAM
diff --git a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90
index 00628c1..ede6eff 100644
--- a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90
+++ b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90
@@ -22,4 +22,4 @@  end
 ! { dg-final { scan-assembler-times "brasl\t%r\[0-9\]*,myBindC" 1 { target { s390*-*-* } } } }
 ! { dg-final { scan-assembler-times "bl \.myBindC" 1 { target { powerpc-ibm-aix* } } } }
 ! { dg-final { scan-assembler-times "add_u32\t\[sv\]\[0-9\]*, \[sv\]\[0-9\]*, myBindC@rel32@lo" 1 { target { amdgcn*-*-* } } } }
-! { dg-final { scan-tree-dump-times "cfi_desc_to_gfc_desc \\\(&parm\\." 1 "original" } }
+! { dg-final { scan-tree-dump-times "gfc_desc_to_cfi_desc \\\(&cfi\\." 1 "original" } }
diff --git a/libgfortran/runtime/ISO_Fortran_binding.c b/libgfortran/runtime/ISO_Fortran_binding.c
index 20833ad..db9b32b 100644
--- a/libgfortran/runtime/ISO_Fortran_binding.c
+++ b/libgfortran/runtime/ISO_Fortran_binding.c
@@ -43,6 +43,20 @@  cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
   if (!s)
     return;
 
+  /* Verify descriptor.  */
+  switch(s->attribute)
+    {
+    case CFI_attribute_pointer:
+    case CFI_attribute_allocatable:
+      break;
+    case CFI_attribute_other:
+      if (s->base_addr)
+	break;
+      /* FALL THROUGH */
+    default:
+      internal_error (NULL, "INVALID CFI DESCRIPTOR");
+      break;
+    }
   GFC_DESCRIPTOR_DATA (d) = s->base_addr;
   GFC_DESCRIPTOR_TYPE (d) = (signed char)(s->type & CFI_type_mask);
   kind = (index_type)((s->type - (s->type & CFI_type_mask)) >> CFI_type_kind_shift);
@@ -74,14 +88,19 @@  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++)
+      {
+	CFI_index_t lb = 1;
+	
+	if (s->attribute != CFI_attribute_other)
+	  lb = s->dim[n].lower_bound;
+
+	GFC_DESCRIPTOR_LBOUND(d, n) = (index_type)lb;
+	GFC_DESCRIPTOR_UBOUND(d, n) = (index_type)(s->dim[n].extent + lb - 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 *);
@@ -102,6 +121,20 @@  gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s)
   else
     d = *d_ptr;
 
+  /* Verify descriptor.  */
+  switch (s->dtype.attribute)
+    {
+    case CFI_attribute_pointer:
+    case CFI_attribute_allocatable:
+      break;
+    case CFI_attribute_other:
+      if (s->base_addr)
+	break;
+      /* FALL THROUGH */
+    default:
+      internal_error (NULL, "INVALID GFC DESCRIPTOR");
+      break;
+    }
   d->base_addr = GFC_DESCRIPTOR_DATA (s);
   d->elem_len = GFC_DESCRIPTOR_SIZE (s);
   d->version = s->dtype.version;