gcc/testsuite/gfortran.dg/deferred_type_component_3.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR87151 by exercising deferred length character
   4 ! array components.
   5 !
   6 ! Based on the contribution by Valery Weber <valeryweber@hotmail.com>
   7 !
   8 module bvec
   9     type, public :: bvec_t
  10      private
  11      character(:), dimension(:), allocatable :: vc
  12    contains
  13      PROCEDURE, PASS :: create
  14      PROCEDURE, PASS :: test_bvec
  15      PROCEDURE, PASS :: delete
  16   end type bvec_t
  17 contains
  18   subroutine create (this, switch)
  19     class(bvec_t), intent(inout) :: this
  20     logical :: switch
  21     if (switch) then
  22       allocate (character(2)::this%vc(3))
  23       if (len (this%vc) .ne. 2) stop 1     ! The orignal problem. Gave 0.
  24
  25 ! Check that reallocation on assign does what it should do as required by
  26 ! F2003 7.4.1.3. ie. reallocation occurs because LEN has changed.
  27       this%vc = ['abcd','efgh','ijkl']
  28     else
  29       allocate (this%vc, source = ['abcd','efgh','ijkl'])
  30     endif
  31   end subroutine create
  32
  33   subroutine test_bvec (this)
  34     class(bvec_t), intent(inout) :: this
  35     character(20) :: buffer
  36     if (allocated (this%vc)) then
  37       if (len (this%vc) .ne. 4) stop 2
  38       if (size (this%vc) .ne. 3) stop 3
  39 ! Check array referencing and scalarized array referencing
  40       if (this%vc(2) .ne. 'efgh') stop 4
  41       if (any (this%vc .ne. ['abcd','efgh','ijkl'])) stop 5
  42 ! Check full array io
  43       write (buffer, *) this%vc
  44       if (trim (buffer(2:)) .ne. 'abcdefghijkl') stop 6
  45 ! Make sure that substrings work correctly
  46       write (buffer, *) this%vc(:)(2:3)
  47       if (trim (buffer(2:)) .ne. 'bcfgjk') stop 7
  48       write (buffer, *) this%vc(2:)(2:3)
  49       if (trim (buffer(2:)) .ne. 'fgjk') stop 8
  50     endif
  51   end subroutine test_bvec
  52
  53   subroutine delete (this)
  54     class(bvec_t), intent(inout) :: this
  55     if (allocated (this%vc)) then
  56       deallocate (this%vc)
  57     endif
  58   end subroutine delete
  59 end module bvec
  60
  61 program test
  62   use bvec
  63   type(bvec_t) :: a
  64   call a%create (.false.)
  65   call a%test_bvec
  66   call a%delete
  67
  68   call a%create (.true.)
  69   call a%test_bvec
  70   call a%delete
  71 end program test