gcc/testsuite/gfortran.dg/extends_type_of_1.f03

   1 ! { dg-do run }
   2 !
   3 ! Verifying the runtime behavior of the intrinsic function EXTENDS_TYPE_OF.
   4 !
   5 ! Contributed by Janus Weil <janus@gcc.gnu.org>
   6
   7  implicit none
   8
   9  intrinsic :: extends_type_of
  10
  11  type :: t1
  12    integer :: i = 42
  13  end type
  14
  15  type, extends(t1) :: t2
  16    integer :: j = 43
  17  end type
  18
  19  type, extends(t2) :: t3
  20    class(t1),pointer :: cc
  21  end type
  22
  23  class(t1), pointer :: c1,c2
  24  type(t1), target :: x
  25  type(t2), target :: y
  26  type(t3), target :: z
  27
  28  c1 => x
  29  c2 => y
  30  z%cc => y
  31
  32  if (.not. extends_type_of (c1, c1)) call abort()
  33  if (      extends_type_of (c1, c2)) call abort()
  34  if (.not. extends_type_of (c2, c1)) call abort()
  35
  36  if (.not. extends_type_of (x, x)) call abort()
  37  if (      extends_type_of (x, y)) call abort()
  38  if (.not. extends_type_of (y, x)) call abort()
  39
  40  if (.not. extends_type_of (c1, x)) call abort()
  41  if (      extends_type_of (c1, y)) call abort()
  42  if (.not. extends_type_of (x, c1)) call abort()
  43  if (.not. extends_type_of (y, c1)) call abort()
  44
  45  if (.not. extends_type_of (z,   c1)) call abort()
  46  if (      extends_type_of (z%cc, z)) call abort()
  47
  48 end