gcc/testsuite/gfortran.dg/aliasing_dummy_1.f90

   1 ! { dg-do run }
   2 ! This tests the fix for PR24276, which originated from the Loren P. Meissner example,
   3 ! Array_List.  The PR concerns dummy argument aliassing of components of arrays of derived
   4 ! types as arrays of the type of the component.  gfortran would compile and run this
   5 ! example but the stride used did not match the actual argument.  This test case exercises
   6 ! a procedure call (to foo2, below) that is identical to Array_List's.
   7 !
   8 ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
   9
  10 program test_lex
  11   type :: dtype
  12     integer :: n
  13     character*5 :: word
  14   end type dtype
  15
  16   type :: list
  17     type(dtype), dimension(4) :: list
  18     integer :: l = 4
  19   end type list
  20
  21   type(list) :: table
  22   type(dtype) :: elist(2,2)
  23
  24   table%list = (/dtype (1 , "one  "), dtype (2 , "two  "), dtype (3 , "three"), dtype (4 , "four ")/)
  25
  26 ! Test 1D with assumed shape (original bug) and assumed size.
  27   call bar (table, 2, 4)
  28   if (any (table%list%word.ne.(/"one  ","i=  2","three","i=  4"/))) call abort ()
  29
  30   elist = reshape (table%list, (/2,2/))
  31
  32 ! Check 2D is OK with assumed shape and assumed size.
  33   call foo3 (elist%word, 1)
  34   call foo1 (elist%word, 3)
  35   if (any (elist%word.ne.reshape ((/"i=  1","i=  2","i=  3","i=  4"/), (/2,2/)))) call abort ()
  36
  37 contains
  38
  39   subroutine bar (table, n, m)
  40     type(list) :: table
  41     integer n, m
  42     call foo1 (table%list(:table%l)%word, n)
  43     call foo2 (table%list(:table%l)%word, m)
  44   end subroutine bar
  45
  46   subroutine foo1 (slist, i)
  47     character(*), dimension(*) :: slist
  48     integer i
  49     write (slist(i), '(2hi=,i3)') i
  50   end subroutine foo1
  51
  52   subroutine foo2 (slist, i)
  53     character(5), dimension(:) :: slist
  54     integer i
  55     write (slist(i), '(2hi=,i3)') i
  56   end subroutine foo2
  57
  58   subroutine foo3 (slist, i)
  59     character(5), dimension(:,:) :: slist
  60     integer i
  61     write (slist(1,1), '(2hi=,i3)') i
  62   end subroutine foo3
  63
  64 end program test_lex