Patch to Bug 94022 - Array slices of assumed-size arrays.

Make sure that when passing array sections of assumed-size arrays to
procedures expecting an assumed-rank array the upper bound of the
last dimension of the array section does not get improperly reset
to -1 to mark it has an assumed size array.

gcc/fortran/ChangeLog:

2020-06-11  José Rui Faustino de Sousa  <jrfsousa@gmail.com>

	PR fortran/94022
	* trans-expr.c (gfc_conv_procedure_call): In the case of
	assumed-size arrays ensure that the reference is to a full array.

gcc/testsuite/ChangeLog:

2020-06-11  José Rui Faustino de Sousa  <jrfsousa@gmail.com>

	PR fortran/94022
	* gfortran.dg/PR94022.f90: New test.

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 8b2afd27fb3812e277ad930ece89c83f80ef66b2..b7c568e90e65bebe6f5ccd7103894ed6b55bd706 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6244,6 +6244,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                      || gfc_expr_attr (e).allocatable)
                    set_dtype_for_unallocated (&parmse, e);
                  else if (e->expr_type == EXPR_VARIABLE
+                          && e->ref
+                          && e->ref->u.ar.type == AR_FULL
                           && e->symtree->n.sym->attr.dummy
                           && e->symtree->n.sym->as
                           && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)

diff --git a/gcc/testsuite/gfortran.dg/PR94022.f90 b/gcc/testsuite/gfortran.dg/PR94022.f90
new file mode 100644 (file)
index 0000000..63b7d90
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/PR94022.f90
@@ -0,0 +1,132 @@
+! { dg-do run }
+!
+! Test the fix for PR94022
+!
+
+function isasa_f(a) result(s)
+  implicit none
+
+  integer, intent(in) :: a(..)
+  
+  logical :: s
+  
+  select rank(a)
+  rank(*)
+    s = .true.
+  rank default
+    s = .false.
+  end select
+  return
+end function isasa_f
+
+function isasa_c(a) result(s) bind(c)
+  use, intrinsic :: iso_c_binding, only: c_int, c_bool
+
+  implicit none
+
+  integer(kind=c_int), intent(in) :: a(..)
+  
+  logical(kind=c_bool) :: s
+  
+  select rank(a)
+  rank(*)
+    s = .true.
+  rank default
+    s = .false.
+  end select
+  return
+end function isasa_c
+
+program isasa_p
+
+  implicit none
+
+  interface
+    function isasa_f(a) result(s)
+      implicit none
+      integer, intent(in) :: a(..)
+      logical             :: s
+    end function isasa_f
+    function isasa_c(a) result(s) bind(c)
+      use, intrinsic :: iso_c_binding, only: c_int, c_bool
+      implicit none
+      integer(kind=c_int), intent(in) :: a(..)
+      logical(kind=c_bool)            :: s
+    end function isasa_c
+  end interface
+
+  integer, parameter :: sz = 7
+  integer, parameter :: lb = 3
+  integer, parameter :: ub = 9
+  integer, parameter :: ex = ub-lb+1
+
+  integer :: arr(sz,lb:ub)
+
+  arr = 1
+  if (asaf_a(arr, lb+1, ub-1)) stop 1
+  if (asaf_p(arr, lb+1, ub-1)) stop 2
+  if (asaf_a(arr, 2, ex-1))    stop 3
+  if (asaf_p(arr, 2, ex-1))    stop 4
+  if (asac_a(arr, lb+1, ub-1)) stop 5
+  if (asac_p(arr, lb+1, ub-1)) stop 6
+  if (asac_a(arr, 2, ex-1))    stop 7
+  if (asac_p(arr, 2, ex-1))    stop 8
+  
+  stop
+
+contains
+
+  function asaf_a(a, lb, ub) result(s)
+    integer, intent(in) :: lb
+    integer, target, intent(in) :: a(sz,lb:*)
+    integer, intent(in) :: ub
+
+    logical :: s
+
+    s = isasa_f(a(:,lb:ub))
+    return
+  end function asaf_a
+
+  function asaf_p(a, lb, ub) result(s)
+    integer,         intent(in) :: lb
+    integer, target, intent(in) :: a(sz,lb:*)
+    integer,         intent(in) :: ub
+
+    logical :: s
+
+    integer, pointer :: p(:,:)
+
+    p => a(:,lb:ub)
+    s = isasa_f(p)
+    return
+  end function asaf_p
+
+  function asac_a(a, lb, ub) result(s)
+    integer, intent(in) :: lb
+    integer, target, intent(in) :: a(sz,lb:*)
+    integer, intent(in) :: ub
+
+    logical :: s
+
+    s = logical(isasa_c(a(:,lb:ub)))
+    return
+  end function asac_a
+
+  function asac_p(a, lb, ub) result(s)
+    integer,         intent(in) :: lb
+    integer, target, intent(in) :: a(sz,lb:*)
+    integer,         intent(in) :: ub
+
+    logical :: s
+
+    integer, pointer :: p(:,:)
+
+    p => a(:,lb:ub)
+    s = logical(isasa_c(p))
+    return
+  end function asac_p
+
+end program isasa_p
+
+
+