gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_fraction_exponent.f90

!Program to test EXPONENT and FRACTION intrinsic function.

program test_exponent_fraction
  real x
  integer*4 i
  real*8 y
  integer*8 j
  equivalence (x, i), (y, j)

  x = 3.
  call test_4(x)

  x = 0.
  call test_4(x)

  i = int(o'00000000001')
  call test_4(x)

  i = int(o'00010000000')
  call test_4(x)

  i = int(o'17700000000')
  call test_4(x)

  i = int(o'00004000001')
  call test_4(x)

  i = int(o'17737777777')
  call test_4(x)

  i = int(o'10000000000')
  call test_4(x)

  i = int(o'0000010000')
  call test_4(x)

  y = 0.5
  call test_8(y)

  y = 0.
  call test_8(y)

  j = int(o'00000000001',8)
  call test_8(y)

  y = 0.2938735877D-38
  call test_8(y)

  y = -1.469369D-39
  call test_8(y)

  y = real(z'7fe00000',8)
  call test_8(y)

  y = -5.739719D+42
  call test_8(y)
end

subroutine test_4(x)
real*4 x,y
integer z
y = fraction (x)
z = exponent(x)
if (z .gt. 0) then
  y = (y * 2.) * (2. ** (z - 1))
else
  y = (y / 2.) * (2. ** (z + 1))
end if
if (abs (x - y) .gt. spacing (max (abs (x), abs (y)))) STOP 1
end

subroutine test_8(x)
real*8 x, y
integer z
y = fraction (x)
z = exponent(x)
if (z .gt. 0) then
  y = (y * 2._8) * (2._8 ** (z - 1))
else
  y = (y / 2._8) * (2._8 ** (z + 1))
end if
if (abs (x - y) .gt. spacing (max (abs (x), abs(y)))) STOP 2
end