This is the mail archive of the fortran@sources.redhat.com mailing list for the Fortran 95 project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[g77] patch for PR 17541


below patch fixes the PR, which is broken data statements with 
double precision constants.

this is a regression introduced into 3.4.2 by a previous patch
of mine. this regression was not detectable with the g77 test suite
or the NIST F77 compiler validation suite.

the test below verifies the problem in the PR, as well as checks
for this problem with all data types and sizes.

tested on i686/gnu/linux with no failures on test suite.



--bud davis 

        program test
! check all types of data statements
! pr 17541
        real r
        double precision s
        integer*1 ib
        integer*2 ih
        integer*4 iw
        integer*8 id
        logical*1 lb(2)
        logical*2 lh(2)
        logical*4 lw(2)
        logical*8 ld(2)
        character*1 a
        character*5 b
        complex c1
        complex*8 c2
        data r,s,ib,ih,iw,id,a,b / 1.0,2.d0,1,2,4,8,'a','xyz'/
        data c1,c2 /(1.0,2.0),(1.d0,2.d0)/
        data lb / .TRUE.,.FALSE. /
        data lh / .TRUE.,.FALSE. /
        data lw / .TRUE.,.FALSE. /
        data ld / .TRUE.,.FALSE. /
        logical dbug
        data dbug /.FALSE./
! check the reals first
        if (r.ne.1.0) then
           if (dbug) print*,r, ' should be 1.0 '
           call abort
        endif
        if (s.ne.2.d0) then
           if (dbug) print*,s, ' should be 2.d0 '
           call abort
        endif
! now the integers
        if (ib.ne.1) then
           if (dbug) print*,ib, ' should be 1 '
           call abort
        endif
        if (ih.ne.2) then
           if (dbug) print*,ih, ' should be 2 '
           call abort
        endif
        if (iw.ne.4) then
           if (dbug) print*,iw, ' should be 4 '
           call abort
        endif
        if (id.ne.8) then
           if (dbug) print*,id, ' should be 8 '
           call abort
        endif
! complex
        if (c1.ne.(1.0,2.0)) then
           if (dbug) print*,c1, ' should be (1.0,2.0) '
           call abort
        endif
        if (c2.ne.(1.d0,2.d0)) then
           if (dbug) print*,c2, ' should be (1.0,2.0) '
           call abort
        endif
! character
        if (a.ne.'a') then
           if (dbug) print*,a, ' should be a '
           call abort
        endif
        if (b.ne.'xyz') then
           if (dbug) print*,b, ' should be xyz '
           call abort
        endif
!logicals
        if (.NOT.lb(1)) then
           if (dbug) print*,lb(1), ' should be .T. '
           call abort
        endif
        if (lb(2)) then
           if (dbug) print*,lb(2), ' should be .F. '
           call abort
        endif
        if (.NOT.lh(1)) then
           if (dbug) print*,lh(1), ' should be .T. '
           call abort
        endif
        if (lh(2)) then
           if (dbug) print*,lh(2), ' should be .F. '
           call abort
        endif
        if (.NOT.lw(1)) then
           if (dbug) print*,lw(1), ' should be .T. '
           call abort
        endif
        if (lw(2)) then
           if (dbug) print*,lw(2), ' should be .F. '
           call abort
        endif
        if (.NOT.ld(1)) then
           if (dbug) print*,ld(1), ' should be .T. '
           call abort
        endif
        if (ld(2)) then
           if (dbug) print*,ld(2), ' should be .F. '
           call abort
        endif
        end

Index: gcc/gcc/f/bld.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/f/Attic/bld.c,v
retrieving revision 1.16.14.1
diff -c -3 -p -r1.16.14.1 bld.c
*** gcc/gcc/f/bld.c	12 Jul 2004 17:58:36 -0000	1.16.14.1
--- gcc/gcc/f/bld.c	19 Sep 2004 05:59:37 -0000
*************** ffebld_constant_new_real2_val (ffetarget
*** 1333,1339 ****
       nc = malloc_new_kp (ffebld_constant_pool(),
                           "FFEBLD_constREAL2",
                           sizeof (*nc));
!      nc->consttype = FFEBLD_constREAL1;
       nc->u.real2 = val;
       nc->hook = FFECOM_constantNULL;
       nc->llink = NULL;
--- 1333,1339 ----
       nc = malloc_new_kp (ffebld_constant_pool(),
                           "FFEBLD_constREAL2",
                           sizeof (*nc));
!      nc->consttype = FFEBLD_constREAL2;
       nc->u.real2 = val;
       nc->hook = FFECOM_constantNULL;
       nc->llink = NULL;



Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]