From 6a07010b774cb5a0b1790b857e69d3d8534eebd2 Mon Sep 17 00:00:00 2001
From: =?utf8?q?Jos=C3=A9=20Rui=20Faustino=20de=20Sousa?=
 <jrfsousa@gmail.com>
Date: Thu, 11 Jun 2020 13:24:55 +0200
Subject: [PATCH] Patch to Bug 94022 - Array slices of assumed-size arrays.
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

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.
---
 gcc/fortran/trans-expr.c              |   2 +
 gcc/testsuite/gfortran.dg/PR94022.f90 | 132 ++++++++++++++++++++++++++++++++++
 2 files changed, 134 insertions(+)
 create mode 100644 gcc/testsuite/gfortran.dg/PR94022.f90

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 8b2afd2..b7c568e 100644
--- 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
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
+
+
+  
-- 
2.7.4