gcc/testsuite/gfortran.dg/realloc_on_assign_4.f03

   1 ! { dg-do run }
   2 ! Tests function return of deferred length scalars.
   3 !
   4 ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
   5 !
   6 module m
   7 contains
   8   function mfoo (carg) result(res)
   9     character (:), allocatable :: res
  10     character (*) :: carg
  11     res = carg(2:4)
  12   end function
  13   function mbar (carg)
  14     character (:), allocatable :: mbar
  15     character (*) :: carg
  16     mbar = carg(2:13)
  17   end function
  18 end module
  19
  20   use m
  21   character (:), allocatable :: lhs
  22   lhs = foo ("foo calling ")
  23   if (lhs .ne. "foo") call abort
  24   if (len (lhs) .ne. 3) call abort
  25   deallocate (lhs)
  26   lhs = bar ("bar calling - baaaa!")
  27   if (lhs .ne. "bar calling") call abort
  28   if (len (lhs) .ne. 12) call abort
  29   deallocate (lhs)
  30   lhs = mfoo ("mfoo calling ")
  31   if (lhs .ne. "foo") call abort
  32   if (len (lhs) .ne. 3) call abort
  33   deallocate (lhs)
  34   lhs = mbar ("mbar calling - baaaa!")
  35   if (lhs .ne. "bar calling") call abort
  36   if (len (lhs) .ne. 12) call abort
  37 contains
  38   function foo (carg) result(res)
  39     character (:), allocatable :: res
  40     character (*) :: carg
  41     res = carg(1:3)
  42   end function
  43   function bar (carg)
  44     character (:), allocatable :: bar
  45     character (*) :: carg
  46     bar = carg(1:12)
  47   end function
  48 end
  49
  50 ! { dg-final { cleanup-modules "m" } }
  51