gcc/testsuite/gfortran.dg/alloc_comp_assign_6.f90

   1 ! { dg-do run }
   2 ! Tests the fix for pr32880, in which 'res' was deallocated
   3 ! before it could be used in the concatenation.
   4 ! Adapted from vst28.f95, in Lawrie Schonfeld's iso_varying_string
   5 ! testsuite, by Tobias Burnus.
   6 !
   7 module iso_varying_string
   8   type varying_string
   9      character(LEN=1), dimension(:), allocatable :: chars
  10   end type varying_string
  11   interface assignment(=)
  12      module procedure op_assign_VS_CH
  13   end interface assignment(=)
  14   interface operator(//)
  15      module procedure op_concat_VS_CH
  16   end interface operator(//)
  17 contains
  18   elemental subroutine op_assign_VS_CH (var, exp)
  19     type(varying_string), intent(out) :: var
  20     character(LEN=*), intent(in)      :: exp
  21     integer                      :: length
  22     integer                      :: i_char
  23     length = len(exp)
  24     allocate(var%chars(length))
  25     forall(i_char = 1:length)
  26        var%chars(i_char) = exp(i_char:i_char)
  27     end forall
  28   end subroutine op_assign_VS_CH
  29   elemental function op_concat_VS_CH (string_a, string_b) result (concat_string)
  30     type(varying_string), intent(in) :: string_a
  31     character(LEN=*), intent(in)     :: string_b
  32     type(varying_string)             :: concat_string
  33     len_string_a = size(string_a%chars)
  34     allocate(concat_string%chars(len_string_a+len(string_b)))
  35     if (len_string_a >0) &
  36        concat_string%chars(:len_string_a) = string_a%chars
  37     if (len (string_b) > 0) &
  38        concat_string%chars(len_string_a+1:) = string_b
  39   end function op_concat_VS_CH
  40 end module iso_varying_string
  41
  42 program VST28
  43   use iso_varying_string
  44   character(len=10) :: char_a
  45   type(VARYING_STRING) :: res
  46   char_a = "abcdefghij"
  47   res = char_a(5:5)
  48   res = res//char_a(6:6)
  49   if(size(res%chars) /= 2 .or. any(res%chars /= ['e','f'])) then
  50     write(*,*) 'ERROR: should be ef, got: ', res%chars, size(res%chars)
  51     call abort ()
  52   end if
  53 end program VST28