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

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index c32bd05..97aafe3 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -4526,22 +4526,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 de406ad..52e243b 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5501,13 +5501,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)
     {
@@ -5615,10 +5614,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..4e13051
--- /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 int, const int);
+
+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 int lb, const int 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;