gcc/testsuite/gfortran.dg/func_derived_3.f90

   1 ! { dg-do run }
   2 ! This tests the "virtual fix" for PR19561, where pointers to derived
   3 ! types were not generating correct code.  This testcase is based on
   4 ! the original PR example.  This example not only tests the
   5 ! original problem but throughly tests derived types in modules,
   6 ! module interfaces and compound derived types.
   7 !
   8 ! Original by Martin Reinecke  martin@mpa-garching.mpg.de
   9 ! Submitted by Paul Thomas  pault@gcc.gnu.org
  10 ! Slightly modified by Tobias Schlüter
  11 module func_derived_3
  12   implicit none
  13   type objA
  14     private
  15     integer :: i
  16   end type objA
  17
  18   interface new
  19     module procedure oaInit
  20   end interface
  21
  22   interface print
  23     module procedure oaPrint
  24   end interface
  25
  26   private
  27   public objA,new,print
  28
  29 contains
  30
  31   subroutine oaInit(oa,i)
  32     integer :: i
  33     type(objA) :: oa
  34     oa%i=i
  35   end subroutine oaInit
  36
  37   subroutine oaPrint (oa)
  38     type (objA) :: oa
  39     write (10, '("simple  = ",i5)') oa%i
  40     end subroutine oaPrint
  41
  42 end module func_derived_3
  43
  44 module func_derived_3a
  45   use func_derived_3
  46   implicit none
  47
  48   type objB
  49     private
  50     integer :: i
  51     type(objA), pointer :: oa
  52   end type objB
  53
  54   interface new
  55     module procedure obInit
  56   end interface
  57
  58   interface print
  59     module procedure obPrint
  60   end interface
  61
  62   private
  63   public objB, new, print, getOa, getOa2
  64
  65 contains
  66
  67   subroutine obInit (ob,oa,i)
  68     integer :: i
  69     type(objA), target :: oa
  70     type(objB) :: ob
  71
  72     ob%i=i
  73     ob%oa=>oa
  74   end subroutine obInit
  75
  76   subroutine obPrint (ob)
  77     type (objB) :: ob
  78     write (10, '("derived = ",i5)') ob%i
  79     call print (ob%oa)
  80   end subroutine obPrint
  81
  82   function getOa (ob) result (oa)
  83     type (objB),target :: ob
  84     type (objA), pointer :: oa
  85
  86     oa=>ob%oa
  87   end function getOa
  88
  89 ! without a result clause
  90   function getOa2 (ob)
  91     type (objB),target :: ob
  92     type (objA), pointer :: getOa2
  93
  94     getOa2=>ob%oa
  95   end function getOa2
  96
  97 end module func_derived_3a
  98
  99   use func_derived_3
 100   use func_derived_3a
 101   implicit none
 102   type (objA),target :: oa
 103   type (objB),target :: ob
 104   character (len=80) :: line
 105
 106   open (10, status='scratch')
 107
 108   call new (oa,1)
 109   call new (ob, oa, 2)
 110
 111   call print (ob)
 112   call print (getOa (ob))
 113   call print (getOa2 (ob))
 114
 115   rewind (10)
 116   read (10, '(80a)') line
 117   if (trim (line).ne."derived =     2") call abort ()
 118   read (10,  '(80a)') line
 119   if (trim (line).ne."simple  =     1") call abort ()
 120   read (10,  '(80a)') line
 121   if (trim (line).ne."simple  =     1") call abort ()
 122   read (10,  '(80a)') line
 123   if (trim (line).ne."simple  =     1") call abort ()
 124   close (10)
 125 end program