gcc/testsuite/gfortran.dg/transfer_simplify_2.f90

   1 ! { dg-do run }
   2 ! { dg-options "-O2" }
   3 ! Tests the fix for the meta-bug PR31237 (TRANSFER intrinsic)
   4 ! Exercises gfc_simplify_transfer a random walk through types and shapes
   5 ! and compares its results with the middle-end version that operates on
   6 ! variables.
   7 !
   8   implicit none
   9   call integer4_to_real4
  10   call real4_to_integer8
  11   call integer4_to_integer8
  12   call logical4_to_real8
  13   call real8_to_integer4
  14   call integer8_to_real4
  15   call integer8_to_complex4
  16   call character16_to_complex8
  17   call character16_to_real8
  18   call real8_to_character2
  19   call dt_to_integer1
  20   call character16_to_dt
  21 contains
  22   subroutine integer4_to_real4
  23     integer(4), parameter ::  i1 = 11111_4
  24     integer(4)            ::  i2 = i1
  25     real(4), parameter    ::  r1 = transfer (i1, 1.0_4)
  26     real(4)               ::  r2
  27
  28     r2 = transfer (i2, r2);
  29     if (r1 .ne. r2) call abort ()
  30   end subroutine integer4_to_real4
  31
  32   subroutine real4_to_integer8
  33     real(4), parameter    ::  r1(2) = (/3.14159_4, 0.0_4/)
  34     real(4)               ::  r2(2) = r1
  35     integer(8), parameter ::  i1 = transfer (r1, 1_8)
  36     integer(8)            ::  i2
  37
  38     i2 = transfer (r2, 1_8);
  39     if (i1 .ne. i2) call abort ()
  40   end subroutine real4_to_integer8
  41
  42   subroutine integer4_to_integer8
  43     integer(4), parameter ::  i1(2) = (/11111_4, 22222_4/)
  44     integer(4)            ::  i2(2) = i1
  45     integer(8), parameter ::  i3 = transfer (i1, 1_8)
  46     integer(8)            ::  i4
  47
  48     i4 = transfer (i2, 1_8);
  49     if (i3 .ne. i4) call abort ()
  50   end subroutine integer4_to_integer8
  51
  52   subroutine logical4_to_real8
  53     logical(4), parameter ::  l1(2) = (/.false., .true./)
  54     logical(4)            ::  l2(2) = l1
  55     real(8), parameter    ::  r1 = transfer (l1, 1_8)
  56     real(8)               ::  r2
  57
  58     r2 = transfer (l2, 1_8);
  59     if (r1 .ne. r2) call abort ()
  60   end subroutine logical4_to_real8
  61
  62   subroutine real8_to_integer4
  63     real(8), parameter    ::  r1 = 3.14159_8
  64     real(8)               ::  r2 = r1
  65     integer(4), parameter ::  i1(2) = transfer (r1, 1_4, 2)
  66     integer(4)            ::  i2(2)
  67
  68     i2 = transfer (r2, i2, 2);
  69     if (any (i1 .ne. i2)) call abort ()
  70   end subroutine real8_to_integer4
  71
  72   subroutine integer8_to_real4
  73     integer               ::  k
  74     integer(8), parameter ::  i1(2) = transfer ((/asin (1.0_8), log (1.0_8)/), 0_8)
  75     integer(8)            ::  i2(2) = i1
  76     real(4), parameter    ::  r1(4) = transfer (i1, (/(1.0_4,k=1,4)/))
  77     real(4)               ::  r2(4)
  78
  79     r2 = transfer (i2, r2);
  80     if (any (r1 .ne. r2)) call abort ()
  81   end subroutine integer8_to_real4
  82
  83   subroutine integer8_to_complex4
  84     integer               ::  k
  85     integer(8), parameter ::  i1(2) = transfer ((/asin (1.0_8), log (1.0_8)/), 0_8)
  86     integer(8)            ::  i2(2) = i1
  87     complex(4), parameter ::  z1(2) = transfer (i1, (/((1.0_4,2.0_4),k=1,2)/))
  88     complex(4)            ::  z2(2)
  89
  90     z2 = transfer (i2, z2);
  91     if (any (z1 .ne. z2)) call abort ()
  92   end subroutine integer8_to_complex4
  93
  94   subroutine character16_to_complex8
  95     character(16), parameter ::  c1(2) = (/"abcdefghijklmnop","qrstuvwxyz1234567890"/)
  96     character(16)            ::  c2(2) = c1
  97     complex(8), parameter    ::  z1(2) = transfer (c1, (1.0_8,1.0_8), 2)
  98     complex(8)               ::  z2(2)
  99
 100     z2 = transfer (c2, z2, 2);
 101     if (any (z1 .ne. z2)) call abort ()
 102   end subroutine character16_to_complex8
 103
 104   subroutine character16_to_real8
 105     character(16), parameter ::  c1 = "abcdefghijklmnop"
 106     character(16)            ::  c2 = c1
 107     real(8), parameter    ::  r1(2) = transfer (c1, 1.0_8, 2)
 108     real(8)               ::  r2(2)
 109
 110     r2 = transfer (c2, r2, 2);
 111     if (any (r1 .ne. r2)) call abort ()
 112   end subroutine character16_to_real8
 113
 114   subroutine real8_to_character2
 115     real(8), parameter    ::  r1 = 3.14159_8
 116     real(8)               ::  r2 = r1
 117     character(2), parameter ::  c1(4) = transfer (r1, "ab", 4)
 118     character(2)            ::  c2(4)
 119
 120     c2 = transfer (r2, "ab", 4);
 121     if (any (c1 .ne. c2)) call abort ()
 122   end subroutine real8_to_character2
 123
 124   subroutine dt_to_integer1
 125     integer, parameter    :: i1(4) = (/1_4,2_4,3_4,4_4/)
 126     real, parameter       :: r1(4) = (/1.0_4,2.0_4,3.0_4,4.0_4/)
 127     type :: mytype
 128       integer(4) :: i(4)
 129       real(4) :: x(4)
 130     end type mytype
 131     type (mytype), parameter :: dt1 = mytype (i1, r1)
 132     type (mytype)            :: dt2 = dt1
 133     integer(1), parameter :: i2(32) = transfer (dt1, 1_1, 32)
 134     integer(1)            :: i3(32)
 135
 136     i3 = transfer (dt2, 1_1, 32);
 137     if (any (i2 .ne. i3)) call abort ()
 138   end subroutine dt_to_integer1
 139
 140   subroutine character16_to_dt
 141     character(16), parameter ::  c1 = "abcdefghijklmnop"
 142     character(16)            ::  c2 = c1
 143     type :: mytype
 144       real(4) :: x(2)
 145     end type mytype
 146
 147     type (mytype), parameter :: dt1(2) = transfer (c1, mytype ((/1.0,2.0,3.0,4.0/)), 2)
 148     type (mytype)            :: dt2(2)
 149
 150     dt2 = transfer (c2, dt2);
 151     if (any (dt1(1)%x .ne. dt2(1)%x)) call abort ()
 152     if (any (dt1(2)%x .ne. dt2(2)%x)) call abort ()
 153   end subroutine character16_to_dt
 154
 155 end