URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [fmt_g0_6.f08] - Blame information for rev 694

Details | Compare with Previous | View Log


! { dg-do run }
! { dg-options "-ffloat-store" }
! PR48602 Invalid F conversion of G descriptor for values close to powers of 10
! Test case provided by Thomas Henlich
program test_g0fr
    use iso_fortran_env
    implicit none
    integer, parameter :: RT = REAL64
 
    call check_all(0.0_RT, 15, 2, 0)
    call check_all(0.991_RT, 15, 2, 0)
    call check_all(0.995_RT, 15, 2, 0)
    call check_all(0.996_RT, 15, 2, 0)
    call check_all(0.999_RT, 15, 2, 0)
contains
    subroutine check_all(val, w, d, e)
        real(kind=RT), intent(in) :: val
        integer, intent(in) :: w
        integer, intent(in) :: d
        integer, intent(in) :: e
 
        call check_f_fmt(val, 'C', w, d, e)
        call check_f_fmt(val, 'U', w, d, e)
        call check_f_fmt(val, 'D', w, d, e)
    end subroutine check_all
 
    subroutine check_f_fmt(val, roundmode, w, d, e)
        real(kind=RT), intent(in) :: val
        character, intent(in) :: roundmode
        integer, intent(in) :: w
        integer, intent(in) :: d
        integer, intent(in) :: e
        character(len=80) :: fmt_f, fmt_g
        character(len=80) :: s_f, s_g
        real(kind=RT) :: mag, lower, upper
        real(kind=RT) :: r
        integer :: n, dec
 
        mag = abs(val)
        if (e == 0) then
            n = 4
        else
            n = e + 2
        end if
        select case (roundmode)
            case('U')
                r = 1.0_RT
            case('D')
                r = 0.0_RT
            case('C')
                r = 0.5_RT
        end select
 
        if (mag == 0) then
            write(fmt_f, "('R', a, ',F', i0, '.', i0, ',', i0, 'X')") roundmode, w - n, d - 1, n
        else
            do dec = d, 0, -1
                lower = 10.0_RT ** (d - 1 - dec) - r * 10.0_RT ** (- dec - 1)
                upper = 10.0_RT ** (d - dec) - r * 10.0_RT ** (- dec)
                if (lower <= mag .and. mag < upper) then
                    write(fmt_f, "('R', a, ',F', i0, '.', i0, ',', i0, 'X')") roundmode, w - n, dec, n
                    exit
                end if
            end do
        end if
        if (len_trim(fmt_f) == 0) then
            ! e editing
            return
        end if
        if (e == 0) then
            write(fmt_g, "('R', a, ',G', i0, '.', i0)") roundmode, w, d
        else
            write(fmt_g, "('R', a, ',G', i0, '.', i0, 'e', i0)") roundmode, w, d, e
        end if
        write(s_g, "('''', " // trim(fmt_g) // ",'''')") val
        write(s_f, "('''', " // trim(fmt_f) // ",'''')") val
        if (s_g /= s_f) call abort
        !if (s_g /= s_f) then
            !print "(a,g0,a,g0)", "lower=", lower, " upper=", upper
           ! print "(a, ' /= ', a, ' ', a, '/', a, ':', g0)", trim(s_g), trim(s_f), trim(fmt_g), trim(fmt_f), val
        !end if
    end subroutine check_f_fmt
end program test_g0fr

Line No.	Rev	Author	Line
1	694	jeremybenn	`! { dg-do run }`
2			`! { dg-options "-ffloat-store" }`
3			`! PR48602 Invalid F conversion of G descriptor for values close to powers of 10`
4			`! Test case provided by Thomas Henlich`
5			`program test_g0fr`
6			`use iso_fortran_env`
7			`implicit none`
8			`integer, parameter :: RT = REAL64`
9
10			`call check_all(0.0_RT, 15, 2, 0)`
11			`call check_all(0.991_RT, 15, 2, 0)`
12			`call check_all(0.995_RT, 15, 2, 0)`
13			`call check_all(0.996_RT, 15, 2, 0)`
14			`call check_all(0.999_RT, 15, 2, 0)`
15			`contains`
16			`subroutine check_all(val, w, d, e)`
17			`real(kind=RT), intent(in) :: val`
18			`integer, intent(in) :: w`
19			`integer, intent(in) :: d`
20			`integer, intent(in) :: e`
21
22			`call check_f_fmt(val, 'C', w, d, e)`
23			`call check_f_fmt(val, 'U', w, d, e)`
24			`call check_f_fmt(val, 'D', w, d, e)`
25			`end subroutine check_all`
26
27			`subroutine check_f_fmt(val, roundmode, w, d, e)`
28			`real(kind=RT), intent(in) :: val`
29			`character, intent(in) :: roundmode`
30			`integer, intent(in) :: w`
31			`integer, intent(in) :: d`
32			`integer, intent(in) :: e`
33			`character(len=80) :: fmt_f, fmt_g`
34			`character(len=80) :: s_f, s_g`
35			`real(kind=RT) :: mag, lower, upper`
36			`real(kind=RT) :: r`
37			`integer :: n, dec`
38
39			`mag = abs(val)`
40			`if (e == 0) then`
41			`n = 4`
42			`else`
43			`n = e + 2`
44			`end if`
45			`select case (roundmode)`
46			`case('U')`
47			`r = 1.0_RT`
48			`case('D')`
49			`r = 0.0_RT`
50			`case('C')`
51			`r = 0.5_RT`
52			`end select`
53
54			`if (mag == 0) then`
55			`write(fmt_f, "('R', a, ',F', i0, '.', i0, ',', i0, 'X')") roundmode, w - n, d - 1, n`
56			`else`
57			`do dec = d, 0, -1`
58			`lower = 10.0_RT ** (d - 1 - dec) - r * 10.0_RT ** (- dec - 1)`
59			`upper = 10.0_RT ** (d - dec) - r * 10.0_RT ** (- dec)`
60			`if (lower <= mag .and. mag < upper) then`
61			`write(fmt_f, "('R', a, ',F', i0, '.', i0, ',', i0, 'X')") roundmode, w - n, dec, n`
62			`exit`
63			`end if`
64			`end do`
65			`end if`
66			`if (len_trim(fmt_f) == 0) then`
67			`! e editing`
68			`return`
69			`end if`
70			`if (e == 0) then`
71			`write(fmt_g, "('R', a, ',G', i0, '.', i0)") roundmode, w, d`
72			`else`
73			`write(fmt_g, "('R', a, ',G', i0, '.', i0, 'e', i0)") roundmode, w, d, e`
74			`end if`
75			`write(s_g, "('''', " // trim(fmt_g) // ",'''')") val`
76			`write(s_f, "('''', " // trim(fmt_f) // ",'''')") val`
77			`if (s_g /= s_f) call abort`
78			`!if (s_g /= s_f) then`
79			`!print "(a,g0,a,g0)", "lower=", lower, " upper=", upper`
80			`! print "(a, ' /= ', a, ' ', a, '/', a, ':', g0)", trim(s_g), trim(s_f), trim(fmt_g), trim(fmt_f), val`
81			`!end if`
82			`end subroutine check_f_fmt`
83			`end program test_g0fr`

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [fmt_g0_6.f08] - Blame information for rev 694