diff mbox series

[fortran] PR fortran/94022 - Array slices of assumed-size arrays

Message ID e4c3140a-4f93-6c5b-ab56-b3b4ac83e4af@gmail.com
State New
Headers show
Series [fortran] PR fortran/94022 - Array slices of assumed-size arrays | expand

Commit Message

José Rui Faustino de Sousa June 3, 2020, 11:42 a.m. UTC 
Hi All!

Proposed patch to Bug 94022 - Array slices of assumed-size arrays.

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

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.

Best regards,
José Rui


2020-6-3  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.

2020-6-3  José Rui Faustino de Sousa  <jrfsousa@gmail.com>

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

Comments

Thomas Koenig June 11, 2020, 11:54 a.m. UTC | #1 
Hi Jose,


> Proposed patch to Bug 94022 - Array slices of assumed-size arrays.
> 
> Patch tested only on x86_64-pc-linux-gnu.

Reviewed, regression-tested and commited as
r11-1228-g6a07010b774cb5a0b1790b857e69d3d8534eebd2 .

Thanks for the patch!

Regards

	Thomas
diff mbox series

Patch

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 33fc061..2e221b5 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6243,6 +6243,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
+
+
+