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

Message ID 0b4b1feb-aa45-31ab-9185-546bd0cc551a@gmail.com
State New
Headers show
Series
  • [fortran,V2] PR fortran/93308/93963/94327/94331/97046 problems raised by descriptor handling
Related show

Commit Message

Andrew Pinski via Gcc-patches June 14, 2021, 11:09 p.m.
Hi all!

Update to a 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

due to errors found in one of the tests by Dominique d'Humieres.

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.

Comments

Tobias Burnus June 21, 2021, 1:46 p.m. | #1
Hi José,

(in principle, I'd like to have the libgfortran function moved to the
compiler proper to avoid some issues, but that's admittedly a task
independent of your work.)

On 15.06.21 01:09, José Rui Faustino de Sousa via Fortran wrote:
> Update to a 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.


LGTM – except for one minor nit. In trans-expr.c's gfc_conv_gfc_desc_to_cfi_desc:

    /* Transfer values back to gfc descriptor.  */
+  if (cfi_attribute != 2
+      && !fsym->attr.value
+      && fsym->attr.intent != INTENT_IN)

Can you add after the '2' the string '  /* CFI_attribute_other.  */'
to make the number less magic.

Thanks,

Tobias


>

> 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.

-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank Thürauf
Andrew Pinski via Gcc-patches June 21, 2021, 3:51 p.m. | #2
On 21/06/21 13:46, Tobias Burnus wrote:
> Hi José,

> 

> (in principle, I'd like to have the libgfortran function moved to the

> compiler proper to avoid some issues, but that's admittedly a task

> independent of your work.)

> 


cfi_desc_to_gfc_desc and gfc_desc_to_cfi_desc from ISO_c_binding.c, right?

Since fixing:

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=100917

https://gcc.gnu.org/bugzilla/show_bug.cgi?id=100910

would very likely require passing an additional "kind" parameter (and 
future descriptor unification) that would be a good idea.

I had a patch to do this, passing the kind value, but AFAIR there were 
issues with kind values for C_PTR and C_FUNPTR (and I didn't want to 
mess with the ABI also in one go)... But I might have fixed that 
somewhere else afterwards...

So, I could look further into that. Were would you like them placed?

> LGTM – except for one minor nit. In trans-expr.c's 

> gfc_conv_gfc_desc_to_cfi_desc:

> 

>     /* Transfer values back to gfc descriptor.  */

> +  if (cfi_attribute != 2

> +      && !fsym->attr.value

> +      && fsym->attr.intent != INTENT_IN)

> 

> Can you add after the '2' the string '  /* CFI_attribute_other.  */'

> to make the number less magic.

> 


Yes... I had the same idea... :-) But all those constants are defined in 
"ISO_Fortran_binding.h"... And moving all those definitions would be a 
major change... So I left it as it was...

What do you suggest I do?

Best regards,
José Rui
Tobias Burnus June 21, 2021, 4:46 p.m. | #3
Hi José,

On 21.06.21 17:51, José Rui Faustino de Sousa via Fortran wrote:
> On 21/06/21 13:46, Tobias Burnus wrote:

>>

>> (in principle, I'd like to have the libgfortran function moved to the

>> compiler proper to avoid some issues, but that's admittedly a task

>> independent of your work.)

> cfi_desc_to_gfc_desc and gfc_desc_to_cfi_desc from ISO_c_binding.c,

> right?

Yes.
>

> So, I could look further into that. Were would you like them placed?

Well, as said: directly into the compiler where currently the call to
libgomp is.
>> LGTM – except for one minor nit.


Found a second tiny nit:

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

There is tailing whitespace in the otherwise empty line.

>> In trans-expr.c's gfc_conv_gfc_desc_to_cfi_desc:

>>

>>     /* Transfer values back to gfc descriptor.  */

>> +  if (cfi_attribute != 2

>> +      && !fsym->attr.value

>> +      && fsym->attr.intent != INTENT_IN)

>>

>> Can you add after the '2' the string '  /* CFI_attribute_other. */'

>> to make the number less magic.

>

> Yes... I had the same idea... :-) But all those constants are defined

> in "ISO_Fortran_binding.h"... And moving all those definitions would

> be a major change... So I left it as it was...


Well, I am currently only asking to add a comment after the "2;".

This fixing those two nits (removing tailing whitespace + adding a
comment) and is be trivial.

* * *

However, in the long run, I think we should put it into either a
separate file, which is included into ISO_Fortran_binding.h and the
proper compiler (and installed alongside ISO_Fortran_binding.h) - or
just in libgfortran.h and adding some check/(static)assert that it
matches to the value in ISO_Fortran_binding.h.

Or, possibly, we could also include ISO_Fortran_binding.h when building
the compiler itself, possibly adding some '#ifdef' code to disable parts
we do not want when we do #include. it.

(We already have '#include "libgfortran.h"' in gcc/fortran/gfortran.h.)

Tobias

-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank Thürauf
Andrew Pinski via Gcc-patches June 21, 2021, 5:52 p.m. | #4
Hi Tobias,

On 21/06/21 16:46, Tobias Burnus wrote:
> Well, as said: directly into the compiler where currently the call to

> libgomp is.

 >


I don't think I understand were you mean. You don't mean the includes in 
"f95-lang.c" do you?

Best regards,
José Rui
Tobias Burnus June 21, 2021, 8:29 p.m. | #5
Hi José,

On 21.06.21 19:52, José Rui Faustino de Sousa wrote:
> On 21/06/21 16:46, Tobias Burnus wrote:

>> Well, as said: directly into the compiler where currently the call to

>> libgomp is.


(should be libgfortran)

I meant converting the operation done
by the libgfortran/runtime/ISO_Fortran_binding.c functions
* cfi_desc_to_gfc_desc and
*gfc_desc_to_cfi_desc

into tree code, generated in place by the current callers
* gfor_fndecl_gfc_to_cfi (in trans-decl.c)
* gfc_conv_gfc_desc_to_cfi_desc (in trans-expr.c)

And then effectively retiring those functions (except for
old code which still calls them).

  * * *

However, that's independent from the patch you had submitted
and which is fine except for the two tiny nits.

Tobias
-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank Thürauf
Tobias Burnus June 22, 2021, 7:11 a.m. | #6
On 21.06.21 22:29, Tobias Burnus wrote:

> However, that's independent from the patch you had submitted

> and which is fine except for the two tiny nits.


As I just did run into a test, which does trigger the error, I think
it would be useful to have something like the following on top
of your patch – what do you think?

(Two of the changes are the nit changes I mentioned in the
LGTM approval.)

Tobias

-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstrasse 201, 80634 München Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Frank Thürauf
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 52e243bd463..73ce33185f1 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5616,3 +5616,3 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
   /* Transfer values back to gfc descriptor.  */
-  if (cfi_attribute != 2
+  if (cfi_attribute != 2  /* CFI_attribute_other.  */
       && !fsym->attr.value
diff --git a/libgfortran/runtime/ISO_Fortran_binding.c b/libgfortran/runtime/ISO_Fortran_binding.c
index 801b7556765..1b845df0e77 100644
--- a/libgfortran/runtime/ISO_Fortran_binding.c
+++ b/libgfortran/runtime/ISO_Fortran_binding.c
@@ -56,3 +56,4 @@ cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
     default:
-      internal_error (NULL, "INVALID CFI DESCRIPTOR");
+      runtime_error ("Unallocated, unassociated actual argument to "
+		     "BIND(C) with non-allocatable, non-pointer dummy");
       break;
@@ -94,3 +95,3 @@ cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
 	CFI_index_t lb = 1;
-	
+
 	if (s->attribute != CFI_attribute_other)
@@ -134,3 +135,4 @@ gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s)
     default:
-      internal_error (NULL, "INVALID GFC DESCRIPTOR");
+      runtime_error ("Unallocated, unassociated actual argument to "
+		     "BIND(C) with non-allocatable, non-pointer dummy");
       break;

Patch

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;