gcc/testsuite/gfortran.dg/aliasing_dummy_4.f90

   1 ! { dg-do run }
   2 ! This tests the fix for PR29315, in which array components of derived type arrays were
   3 ! not correctly passed to procedures because of a fault in the function that detects
   4 ! these references that do not have the span of a natural type.
   5 !
   6 ! Contributed by Stephen Jeffrey  <stephen.jeffrey@nrm.qld.gov.au>
   7 !
   8 program  test_f90
   9
  10     integer, parameter :: N = 2
  11
  12     type test_type
  13         integer a(N, N)
  14     end type
  15
  16     type (test_type) s(N, N)
  17
  18     forall (l = 1:N, m = 1:N) &
  19         s(l, m)%a(:, :) = reshape ([((i*l + 10*j*m +100, i = 1, N), j = 1, N)], [N, N])
  20
  21     call test_sub(s%a(1, 1), 1000) ! Test the original problem.
  22
  23     if ( any (s(1, 1)%a(:, :) /= reshape ([1111, 112, 121, 122], [2, 2]))) call abort ()
  24     if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) call abort ()
  25     if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) call abort ()
  26     if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) call abort ()
  27
  28     call test_sub(s(1, 1)%a(:, :), 1000)  ! Check "normal" references.
  29
  30     if ( any (s(1, 1)%a(:, :) /= reshape ([2111,1112,1121,1122], [2, 2]))) call abort ()
  31     if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) call abort ()
  32     if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) call abort ()
  33     if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) call abort ()
  34 contains
  35   subroutine test_sub(array, offset)
  36     integer array(:, :), offset
  37
  38     forall (i = 1:N, j = 1:N) &
  39         array(i, j) = array(i, j) + offset
  40   end subroutine
  41 end program
  42