gcc/testsuite/gfortran.dg/same_type_as_2.f03

   1 ! { dg-do run }
   2 !
   3 ! Verifying the runtime behavior of the intrinsic function SAME_TYPE_AS.
   4 !
   5 ! Contributed by Janus Weil <janus@gcc.gnu.org>
   6
   7  type :: t1
   8   integer :: i
   9  end type
  10
  11  type, extends(t1) :: t2
  12   integer :: j
  13  end type
  14
  15  CLASS(t1), pointer :: c1,c2
  16  TYPE(t1), target :: x1
  17  TYPE(t2) ,target :: x2
  18
  19  intrinsic :: SAME_TYPE_AS
  20  logical :: l
  21
  22  c1 => NULL()
  23
  24  l = SAME_TYPE_AS (x1,x1)
  25  print *,l
  26  if (.not.l) call abort()
  27  l = SAME_TYPE_AS (x1,x2)
  28  print *,l
  29  if (l) call abort()
  30
  31  c1 => x1
  32  l = SAME_TYPE_AS (c1,x1)
  33  print *,l
  34  if (.not.l) call abort()
  35  l = SAME_TYPE_AS (c1,x2)
  36  print *,l
  37  if (l) call abort()
  38
  39  c1 => x2
  40  c2 => x2
  41  l = SAME_TYPE_AS (c1,c2)
  42  print *,l
  43  if (.not.l) call abort()
  44
  45  c1 => x1
  46  c2 => x2
  47  l = SAME_TYPE_AS (c1,c2)
  48  print *,l
  49  if (l) call abort()
  50
  51 end