gcc/testsuite/gfortran.dg/aliasing_dummy_1.f90

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