gcc/testsuite/gfortran.dg/realloc_on_assign_3.f03

   1 ! { dg-do run }
   2 ! Test (re)allocation on assignment of scalars
   3 !
   4 ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
   5 !
   6   call test_real
   7   call test_derived
   8   call test_char1
   9   call test_char4
  10   call test_deferred_char1
  11   call test_deferred_char4
  12 contains
  13   subroutine test_real
  14     real, allocatable :: x
  15     real :: y = 42
  16     x = 42.0
  17     if (x .ne. y) call abort
  18     deallocate (x)
  19     x = y
  20     if (x .ne. y) call abort
  21   end subroutine
  22   subroutine test_derived
  23     type :: mytype
  24       real :: x
  25       character(4) :: c
  26     end type
  27     type (mytype), allocatable :: t
  28     t = mytype (99.0, "abcd")
  29     if (t%c .ne. "abcd") call abort
  30   end subroutine
  31   subroutine test_char1
  32     character(len = 8), allocatable :: c1
  33     character(len = 8) :: c2 = "abcd1234"
  34     c1 = "abcd1234"
  35     if (c1 .ne. c2) call abort
  36     deallocate (c1)
  37     c1 = c2
  38     if (c1 .ne. c2) call abort
  39   end subroutine
  40   subroutine test_char4
  41     character(len = 8, kind = 4), allocatable :: c1
  42     character(len = 8, kind = 4) :: c2 = 4_"abcd1234"
  43     c1 = 4_"abcd1234"
  44     if (c1 .ne. c2) call abort
  45     deallocate (c1)
  46     c1 = c2
  47     if (c1 .ne. c2) call abort
  48   end subroutine
  49   subroutine test_deferred_char1
  50     character(:), allocatable :: c
  51     c = "Hello"
  52     if (c .ne. "Hello") call abort
  53     if (len(c) .ne. 5) call abort
  54     c = "Goodbye"
  55     if (c .ne. "Goodbye") call abort
  56     if (len(c) .ne. 7) call abort
  57 ! Check that the hidden LEN dummy is passed by reference
  58     call test_pass_c1 (c)
  59     if (c .ne. "Made in test!") print *, c
  60     if (len(c) .ne. 13) call abort
  61   end subroutine
  62   subroutine test_pass_c1 (carg)
  63     character(:), allocatable :: carg
  64     if (carg .ne. "Goodbye") call abort
  65     if (len(carg) .ne. 7) call abort
  66     carg = "Made in test!"
  67   end subroutine
  68   subroutine test_deferred_char4
  69     character(:, kind = 4), allocatable :: c
  70     c = 4_"Hello"
  71     if (c .ne. 4_"Hello") call abort
  72     if (len(c) .ne. 5) call abort
  73     c = 4_"Goodbye"
  74     if (c .ne. 4_"Goodbye") call abort
  75     if (len(c) .ne. 7) call abort
  76 ! Check that the hidden LEN dummy is passed by reference
  77     call test_pass_c4 (c)
  78     if (c .ne. 4_"Made in test!") print *, c
  79     if (len(c) .ne. 13) call abort
  80   end subroutine
  81   subroutine test_pass_c4 (carg)
  82     character(:, kind = 4), allocatable :: carg
  83     if (carg .ne. 4_"Goodbye") call abort
  84     if (len(carg) .ne. 7) call abort
  85     carg = 4_"Made in test!"
  86   end subroutine
  87 end
  88