gcc/testsuite/gfortran.dg/interface_assignment_2.f90

   1 ! { dg-do run }
   2 ! Checks the fix for PR32842, in which the interface assignment
   3 ! below caused a segfault.  This testcase is reduced from vst_2.f95
   4 ! in the iso_varying_string testsuite, from Lawrie Schonfelder
   5 !
   6 ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
   7 !
   8 module iso_varying_string
   9   implicit none
  10   integer, parameter :: GET_BUFFER_LEN = 256
  11   type varying_string
  12      character(LEN=1), dimension(:), allocatable :: chars
  13   end type varying_string
  14   interface assignment(=)
  15      module procedure op_assign_VS_CH
  16   end interface assignment(=)
  17 contains
  18   elemental subroutine op_assign_VS_CH (var, expr)
  19     type(varying_string), intent(out) :: var
  20     character(LEN=*), intent(in)      :: expr
  21     var = var_str(expr)
  22   end subroutine op_assign_VS_CH
  23   elemental function var_str (chr) result (string)
  24     character(LEN=*), intent(in) :: chr
  25     type(varying_string)         :: string
  26     integer                      :: length
  27     integer                      :: i_char
  28     length = LEN(chr)
  29     ALLOCATE(string%chars(length))
  30     forall(i_char = 1:length)
  31        string%chars(i_char) = chr(i_char:i_char)
  32     end forall
  33   end function var_str
  34 end module iso_varying_string
  35
  36 PROGRAM VST_2
  37   USE ISO_VARYING_STRING
  38   IMPLICIT NONE
  39   CHARACTER(LEN=5)     :: char_arb(2)
  40   CHARACTER(LEN=1)     :: char_elm(10)
  41   equivalence (char_arb, char_elm)
  42   type(VARYING_STRING) :: str_ara(2)
  43   char_arb(1)= "Hello"
  44   char_arb(2)= "World"
  45   str_ara = char_arb
  46   if (any (str_ara(1)%chars(1:5) .ne. char_elm(1:5))) call abort
  47   if (any (str_ara(2)%chars(1:5) .ne. char_elm(6:10))) call abort
  48 END PROGRAM VST_2
  49 ! { dg-final { cleanup-modules "iso_varying_string" } }