gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90

   1 ! { dg-do run }
   2 !
   3 ! Testing fix for PR fortran/60255
   4 !
   5 ! Author: Andre Vehreschild <vehre@gmx.de>
   6 !
   7 MODULE m
   8
   9 contains
  10   subroutine bar (arg, res)
  11     class(*) :: arg
  12     character(100) :: res
  13     select type (w => arg)
  14       type is (character(*))
  15         write (res, '(I2)') len(w)
  16     end select
  17   end subroutine
  18
  19 END MODULE
  20
  21 program test
  22     use m;
  23     implicit none
  24     character(LEN=:), allocatable, target :: S
  25     character(LEN=100) :: res
  26     class(*), pointer :: ucp, ucp2
  27     call sub1 ("long test string", 16)
  28     call sub2 ()
  29     S = "test"
  30     ucp => S
  31     call sub3 (ucp)
  32     allocate (ucp2, source=ucp)
  33     call sub3 (ucp2)
  34     call sub4 (S, 4)
  35     call sub4 ("This is a longer string.", 24)
  36     call bar (S, res)
  37     if (trim (res) .NE. " 4") call abort ()
  38     call bar(ucp, res)
  39     if (trim (res) .NE. " 4") call abort ()
  40
  41 contains
  42
  43     subroutine sub1(dcl, ilen)
  44         character(len=*), target :: dcl
  45         integer(4) :: ilen
  46         character(len=:), allocatable :: hlp
  47         class(*), pointer :: ucp
  48
  49         ucp => dcl
  50
  51         select type (ucp)
  52         type is (character(len=*))
  53             if (len(dcl) .NE. ilen) call abort ()
  54             if (len(ucp) .NE. ilen) call abort ()
  55             hlp = ucp
  56             if (len(hlp) .NE. ilen) call abort ()
  57         class default
  58             call abort()
  59         end select
  60     end subroutine
  61
  62     subroutine sub2
  63         character(len=:), allocatable, target :: dcl
  64         class(*), pointer :: ucp
  65
  66         dcl = "ttt"
  67         ucp => dcl
  68
  69         select type (ucp)
  70         type is (character(len=*))
  71             if (len(ucp) .ne. 3) call abort ()
  72         class default
  73             call abort()
  74         end select
  75     end subroutine
  76
  77     subroutine sub3(ucp)
  78         character(len=:), allocatable :: hlp
  79         class(*), pointer :: ucp
  80
  81         select type (ucp)
  82         type is (character(len=*))
  83             if (len(ucp) .ne. 4) call abort ()
  84             hlp = ucp
  85             if (len(hlp) .ne. 4) call abort ()
  86         class default
  87             call abort()
  88         end select
  89     end subroutine
  90
  91     subroutine sub4(ucp, ilen)
  92         character(len=:), allocatable :: hlp
  93         integer(4) :: ilen
  94         class(*) :: ucp
  95
  96         select type (ucp)
  97         type is (character(len=*))
  98             if (len(ucp) .ne. ilen) call abort ()
  99             hlp = ucp
 100             if (len(hlp) .ne. ilen) call abort ()
 101         class default
 102             call abort()
 103         end select
 104     end subroutine
 105 end program
 106