gcc/testsuite/gfortran.dg/elemental_subroutine_10.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/60066
   4 !
   5 ! Contributed by F Martinez Fadrique  <fmartinez@gmv.com>
   6 !
   7 ! Fixed by the patch for PR59906 but adds another, different test.
   8 !
   9 module m_assertion_character
  10   implicit none
  11   type :: t_assertion_character
  12     character(len=8) :: name
  13   contains
  14     procedure :: assertion_character
  15     procedure :: write => assertion_array_write
  16   end type t_assertion_character
  17 contains
  18   impure elemental subroutine assertion_character( ast, name )
  19     class(t_assertion_character), intent(out) :: ast
  20     character(len=*), intent(in) :: name
  21     ast%name = name
  22   end subroutine assertion_character
  23   subroutine assertion_array_write( ast, unit )
  24     class(t_assertion_character), intent(in) :: ast
  25     character(*), intent(inOUT) :: unit
  26     write(unit,*) trim (unit(2:len(unit)))//trim (ast%name)
  27   end subroutine assertion_array_write
  28 end module m_assertion_character
  29
  30 module m_assertion_array_character
  31   use m_assertion_character
  32   implicit none
  33   type :: t_assertion_array_character
  34     type(t_assertion_character), dimension(:), allocatable :: rast
  35   contains
  36     procedure :: assertion_array_character
  37     procedure :: write => assertion_array_character_write
  38   end type t_assertion_array_character
  39 contains
  40   subroutine assertion_array_character( ast, name, nast )
  41     class(t_assertion_array_character), intent(out) :: ast
  42     character(len=*), intent(in) :: name
  43     integer, intent(in) :: nast
  44     integer :: i
  45     allocate ( ast%rast(nast) )
  46     call ast%rast%assertion_character ( name )
  47   end subroutine assertion_array_character
  48   subroutine assertion_array_character_write( ast, unit )
  49     class(t_assertion_array_character), intent(in) :: ast
  50     CHARACTER(*), intent(inOUT) :: unit
  51     integer :: i
  52     do i = 1, size (ast%rast)
  53       call ast%rast(i)%write (unit)
  54     end do
  55   end subroutine assertion_array_character_write
  56 end module m_assertion_array_character
  57
  58 program main
  59   use m_assertion_array_character
  60   implicit none
  61   type(t_assertion_array_character) :: ast
  62   character(len=8) :: name
  63   character (26) :: line = ''
  64   name = 'test'
  65   call ast%assertion_array_character ( name, 5 )
  66   call ast%write (line)
  67   if (line(2:len (line)) .ne. "testtesttesttesttest") call abort
  68 end program main