gcc/testsuite/gfortran.dg/parent_result_ref_2.f90

   1 ! { dg-do run }
   2 ! Tests the fix for PR19546 in which an ICE would result from
   3 ! setting the parent result in a contained procedure.
   4 ! This case tests character results.
   5 !
   6 function f()
   7   character(4) :: f
   8   f = "efgh"
   9   call sub ()
  10   if (f.eq."iklm") f = "abcd"
  11   call sub ()
  12 contains
  13   subroutine sub
  14     f = "wxyz"
  15     if (f.eq."efgh") f = "iklm"
  16   end subroutine sub
  17 end function f
  18
  19 function g()              ! { dg-warning "Obsolescent feature" }
  20   character(*) :: g
  21   g = "efgh"
  22   call sub ()
  23   if (g.eq."iklm") g = "ABCD"
  24   call sub ()
  25 contains
  26   subroutine sub
  27     g = "WXYZ"
  28     if (g.eq."efgh") g = "iklm"
  29   end subroutine sub
  30 end function g
  31
  32   character(4), external :: f, g
  33   if (f ().ne."wxyz") call abort ()
  34   if (g ().ne."WXYZ") call abort ()
  35 end