From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f | 468 ++++++++++++++++++++++ 1 file changed, 468 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f (limited to 'gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f') diff --git a/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f b/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f new file mode 100644 index 000000000..01436d197 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f @@ -0,0 +1,468 @@ +c { dg-do run } +c f90-intrinsic-bit.f +c +c Test Fortran 90 +c * intrinsic bit manipulation functions - Section 13.10.10 +c * bitcopy subroutine - Section 13.9.3 +c David Billinghurst +c +c Notes: +c * g77 only supports scalar arguments +c * third argument of ISHFTC is not optional in g77 + + logical fail + integer i, i2, ia, i3 + integer(kind=2) j, j2, j3, ja + integer(kind=1) k, k2, k3, ka + integer(kind=8) m, m2, m3, ma + + common /flags/ fail + fail = .false. + +c BIT_SIZE - Section 13.13.16 +c Determine BIT_SIZE by counting the bits + ia = 0 + i = 0 + i = not(i) + do while ( (i.ne.0) .and. (ia.lt.127) ) + ia = ia + 1 + i = ishft(i,-1) + end do + call c_i(BIT_SIZE(i),ia,'BIT_SIZE(integer)') + ja = 0 + j = 0 + j = not(j) + do while ( (j.ne.0) .and. (ja.lt.127) ) + ja = ja + 1 + j = ishft(j,-1) + end do + call c_i2(BIT_SIZE(j),ja,'BIT_SIZE(integer(2))') + ka = 0 + k = 0 + k = not(k) + do while ( (k.ne.0) .and. (ka.lt.127) ) + ka = ka + 1 + k = ishft(k,-1) + end do + call c_i1(BIT_SIZE(k),ka,'BIT_SIZE(integer(1))') + ma = 0 + m = 0 + m = not(m) + do while ( (m.ne.0) .and. (ma.lt.127) ) + ma = ma + 1 + m = ishft(m,-1) + end do + call c_i8(BIT_SIZE(m),ma,'BIT_SIZE(integer(8))') + +c BTEST - Section 13.13.17 + j = 7 + j2 = 3 + k = 7 + k2 = 3 + m = 7 + m2 = 3 + call c_l(BTEST(7,3),.true.,'BTEST(integer,integer)') + call c_l(BTEST(7,j2),.true.,'BTEST(integer,integer(2))') + call c_l(BTEST(7,k2),.true.,'BTEST(integer,integer(1))') + call c_l(BTEST(7,m2),.true.,'BTEST(integer,integer(8))') + call c_l(BTEST(j,3),.true.,'BTEST(integer(2),integer)') + call c_l(BTEST(j,j2),.true.,'BTEST(integer(2),integer(2))') + call c_l(BTEST(j,k2),.true.,'BTEST(integer(2),integer(1))') + call c_l(BTEST(j,m2),.true.,'BTEST(integer(2),integer(8))') + call c_l(BTEST(k,3),.true.,'BTEST(integer(1),integer)') + call c_l(BTEST(k,j2),.true.,'BTEST(integer(1),integer(2))') + call c_l(BTEST(k,k2),.true.,'BTEST(integer(1),integer(1))') + call c_l(BTEST(k,m2),.true.,'BTEST(integer(1),integer(8))') + call c_l(BTEST(m,3),.true.,'BTEST(integer(8),integer)') + call c_l(BTEST(m,j2),.true.,'BTEST(integer(8),integer(2))') + call c_l(BTEST(m,k2),.true.,'BTEST(integer(8),integer(1))') + call c_l(BTEST(m,m2),.true.,'BTEST(integer(8),integer(8))') + +c IAND - Section 13.13.40 + j = 3 + j2 = 1 + ja = 1 + k = 3 + k2 = 1 + ka = 1 + m = 3 + m2 = 1 + ma = 1 + call c_i(IAND(3,1),1,'IAND(integer,integer)') + call c_i2(IAND(j,j2),ja,'IAND(integer(2),integer(2)') + call c_i1(IAND(k,k2),ka,'IAND(integer(1),integer(1))') + call c_i8(IAND(m,m2),ma,'IAND(integer(8),integer(8))') + + +c IBCLR - Section 13.13.41 + j = 14 + j2 = 1 + ja = 12 + k = 14 + k2 = 1 + ka = 12 + m = 14 + m2 = 1 + ma = 12 + call c_i(IBCLR(14,1),12,'IBCLR(integer,integer)') + call c_i(IBCLR(14,j2),12,'IBCLR(integer,integer(2))') + call c_i(IBCLR(14,k2),12,'IBCLR(integer,integer(1))') + call c_i(IBCLR(14,m2),12,'IBCLR(integer,integer(8))') + call c_i2(IBCLR(j,1),ja,'IBCLR(integer(2),integer)') + call c_i2(IBCLR(j,j2),ja,'IBCLR(integer(2),integer(2))') + call c_i2(IBCLR(j,k2),ja,'IBCLR(integer(2),integer(1))') + call c_i2(IBCLR(j,m2),ja,'IBCLR(integer(2),integer(8))') + call c_i1(IBCLR(k,1),ka,'IBCLR(integer(1),integer)') + call c_i1(IBCLR(k,j2),ka,'IBCLR(integer(1),integer(2))') + call c_i1(IBCLR(k,k2),ka,'IBCLR(integer(1),integer(1))') + call c_i1(IBCLR(k,m2),ka,'IBCLR(integer(1),integer(8))') + call c_i8(IBCLR(m,1),ma,'IBCLR(integer(8),integer)') + call c_i8(IBCLR(m,j2),ma,'IBCLR(integer(8),integer(2))') + call c_i8(IBCLR(m,k2),ma,'IBCLR(integer(8),integer(1))') + call c_i8(IBCLR(m,m2),ma,'IBCLR(integer(8),integer(8))') + +c IBSET - Section 13.13.43 + j = 12 + j2 = 1 + ja = 14 + k = 12 + k2 = 1 + ka = 14 + m = 12 + m2 = 1 + ma = 14 + call c_i(IBSET(12,1),14,'IBSET(integer,integer)') + call c_i(IBSET(12,j2),14,'IBSET(integer,integer(2))') + call c_i(IBSET(12,k2),14,'IBSET(integer,integer(1))') + call c_i(IBSET(12,m2),14,'IBSET(integer,integer(8))') + call c_i2(IBSET(j,1),ja,'IBSET(integer(2),integer)') + call c_i2(IBSET(j,j2),ja,'IBSET(integer(2),integer(2))') + call c_i2(IBSET(j,k2),ja,'IBSET(integer(2),integer(1))') + call c_i2(IBSET(j,m2),ja,'IBSET(integer(2),integer(8))') + call c_i1(IBSET(k,1),ka,'IBSET(integer(1),integer)') + call c_i1(IBSET(k,j2),ka,'IBSET(integer(1),integer(2))') + call c_i1(IBSET(k,k2),ka,'IBSET(integer(1),integer(1))') + call c_i1(IBSET(k,m2),ka,'IBSET(integer(1),integer(8))') + call c_i8(IBSET(m,1),ma,'IBSET(integer(8),integer)') + call c_i8(IBSET(m,j2),ma,'IBSET(integer(8),integer(2))') + call c_i8(IBSET(m,k2),ma,'IBSET(integer(8),integer(1))') + call c_i8(IBSET(m,m2),ma,'IBSET(integer(8),integer(8))') + +c IEOR - Section 13.13.45 + j = 3 + j2 = 1 + ja = 2 + k = 3 + k2 = 1 + ka = 2 + m = 3 + m2 = 1 + ma = 2 + call c_i(IEOR(3,1),2,'IEOR(integer,integer)') + call c_i2(IEOR(j,j2),ja,'IEOR(integer(2),integer(2))') + call c_i1(IEOR(k,k2),ka,'IEOR(integer(1),integer(1))') + call c_i8(IEOR(m,m2),ma,'IEOR(integer(8),integer(8))') + +c ISHFT - Section 13.13.49 + i = 3 + i2 = 1 + i3 = 0 + ia = 6 + j = 3 + j2 = 1 + j3 = 0 + ja = 6 + k = 3 + k2 = 1 + k3 = 0 + ka = 6 + m = 3 + m2 = 1 + m3 = 0 + ma = 6 + call c_i(ISHFT(i,i2),ia,'ISHFT(integer,integer)') + call c_i(ISHFT(i,BIT_SIZE(i)),i3,'ISHFT(integer,integer) 2') + call c_i(ISHFT(i,-BIT_SIZE(i)),i3,'ISHFT(integer,integer) 3') + call c_i(ISHFT(i,0),i,'ISHFT(integer,integer) 4') + call c_i2(ISHFT(j,j2),ja,'ISHFT(integer(2),integer(2))') + call c_i2(ISHFT(j,BIT_SIZE(j)),j3, + $ 'ISHFT(integer(2),integer(2)) 2') + call c_i2(ISHFT(j,-BIT_SIZE(j)),j3, + $ 'ISHFT(integer(2),integer(2)) 3') + call c_i2(ISHFT(j,0),j,'ISHFT(integer(2),integer(2)) 4') + call c_i1(ISHFT(k,k2),ka,'ISHFT(integer(1),integer(1))') + call c_i1(ISHFT(k,BIT_SIZE(k)),k3, + $ 'ISHFT(integer(1),integer(1)) 2') + call c_i1(ISHFT(k,-BIT_SIZE(k)),k3, + $ 'ISHFT(integer(1),integer(1)) 3') + call c_i1(ISHFT(k,0),k,'ISHFT(integer(1),integer(1)) 4') + call c_i8(ISHFT(m,m2),ma,'ISHFT(integer(8),integer(8))') + call c_i8(ISHFT(m,BIT_SIZE(m)),m3, + $ 'ISHFT(integer(8),integer(8)) 2') + call c_i8(ISHFT(m,-BIT_SIZE(m)),m3, + $ 'ISHFT(integer(8),integer(8)) 3') + call c_i8(ISHFT(m,0),m,'ISHFT(integer(8),integer(8)) 4') + +c ISHFTC - Section 13.13.50 +c The third argument is not optional in g77 + i = 3 + i2 = 2 + i3 = 3 + ia = 5 + j = 3 + j2 = 2 + j3 = 3 + ja = 5 + k = 3 + k2 = 2 + k3 = 3 + ka = 5 + m2 = 2 + m3 = 3 + ma = 5 +c test all the combinations of arguments + call c_i(ISHFTC(i,i2,i3),5,'ISHFTC(integer,integer,integer)') + call c_i(ISHFTC(i,i2,j3),5,'ISHFTC(integer,integer,integer(2))') + call c_i(ISHFTC(i,i2,k3),5,'ISHFTC(integer,integer,integer(1))') + call c_i(ISHFTC(i,i2,m3),5,'ISHFTC(integer,integer,integer(8))') + call c_i(ISHFTC(i,j2,i3),5,'ISHFTC(integer,integer(2),integer)') + call c_i(ISHFTC(i,j2,j3),5, + & 'ISHFTC(integer,integer(2),integer(2))') + call c_i(ISHFTC(i,j2,k3),5, + & 'ISHFTC(integer,integer(2),integer(1))') + call c_i(ISHFTC(i,j2,m3),5, + & 'ISHFTC(integer,integer(2),integer(8))') + call c_i(ISHFTC(i,k2,i3),5,'ISHFTC(integer,integer(1),integer)') + call c_i(ISHFTC(i,k2,j3),5, + & 'ISHFTC(integer,integer(1),integer(2))') + call c_i(ISHFTC(i,k2,k3),5, + & 'ISHFTC(integer,integer(1),integer(1))') + call c_i(ISHFTC(i,k2,m3),5, + & 'ISHFTC(integer,integer(1),integer(8))') + call c_i(ISHFTC(i,m2,i3),5,'ISHFTC(integer,integer(8),integer)') + call c_i(ISHFTC(i,m2,j3),5, + & 'ISHFTC(integer,integer(8),integer(2))') + call c_i(ISHFTC(i,m2,k3),5, + & 'ISHFTC(integer,integer(8),integer(1))') + call c_i(ISHFTC(i,m2,m3),5, + & 'ISHFTC(integer,integer(8),integer(8))') + + call c_i2(ISHFTC(j,i2,i3),ja,'ISHFTC(integer(2),integer,integer)') + call c_i2(ISHFTC(j,i2,j3),ja, + $ 'ISHFTC(integer(2),integer,integer(2))') + call c_i2(ISHFTC(j,i2,k3),ja, + $ 'ISHFTC(integer(2),integer,integer(1))') + call c_i2(ISHFTC(j,i2,m3),ja, + $ 'ISHFTC(integer(2),integer,integer(8))') + call c_i2(ISHFTC(j,j2,i3),ja, + $ 'ISHFTC(integer(2),integer(2),integer)') + call c_i2(ISHFTC(j,j2,j3),ja, + $ 'ISHFTC(integer(2),integer(2),integer(2))') + call c_i2(ISHFTC(j,j2,k3),ja, + $ 'ISHFTC(integer(2),integer(2),integer(1))') + call c_i2(ISHFTC(j,j2,m3),ja, + $ 'ISHFTC(integer(2),integer(2),integer(8))') + call c_i2(ISHFTC(j,k2,i3),ja, + $ 'ISHFTC(integer(2),integer(1),integer)') + call c_i2(ISHFTC(j,k2,j3),ja, + $ 'ISHFTC(integer(2),integer(1),integer(2))') + call c_i2(ISHFTC(j,k2,k3),ja, + $ 'ISHFTC(integer(2),integer(1),integer(1))') + call c_i2(ISHFTC(j,k2,m3),ja, + $ 'ISHFTC(integer(2),integer(1),integer(8))') + call c_i2(ISHFTC(j,m2,i3),ja, + $ 'ISHFTC(integer(2),integer(8),integer)') + call c_i2(ISHFTC(j,m2,j3),ja, + $ 'ISHFTC(integer(2),integer(8),integer(2))') + call c_i2(ISHFTC(j,m2,k3),ja, + $ 'ISHFTC(integer(2),integer(8),integer(1))') + call c_i2(ISHFTC(j,m2,m3),ja, + $ 'ISHFTC(integer(2),integer(8),integer(8))') + + call c_i1(ISHFTC(k,i2,i3),ka,'ISHFTC(integer(1),integer,integer)') + call c_i1(ISHFTC(k,i2,j3),ka, + $ 'ISHFTC(integer(1),integer,integer(2))') + call c_i1(ISHFTC(k,i2,k3),ka, + $ 'ISHFTC(integer(1),integer,integer(1))') + call c_i1(ISHFTC(k,i2,m3),ka, + $ 'ISHFTC(integer(1),integer,integer(8))') + call c_i1(ISHFTC(k,j2,i3),ka, + $ 'ISHFTC(integer(1),integer(2),integer)') + call c_i1(ISHFTC(k,j2,j3),ka, + $ 'ISHFTC(integer(1),integer(2),integer(2))') + call c_i1(ISHFTC(k,j2,k3),ka, + $ 'ISHFTC(integer(1),integer(2),integer(1))') + call c_i1(ISHFTC(k,j2,m3),ka, + $ 'ISHFTC(integer(1),integer(2),integer(8))') + call c_i1(ISHFTC(k,k2,i3),ka, + $ 'ISHFTC(integer(1),integer(1),integer)') + call c_i1(ISHFTC(k,k2,j3),ka, + $ 'ISHFTC(integer(1),integer(1),integer(2))') + call c_i1(ISHFTC(k,k2,k3),ka, + $ 'ISHFTC(integer(1),integer(1),integer(1))') + call c_i1(ISHFTC(k,k2,m3),ka, + $ 'ISHFTC(integer(1),integer(1),integer(8))') + call c_i1(ISHFTC(k,m2,i3),ka, + $ 'ISHFTC(integer(1),integer(8),integer)') + call c_i1(ISHFTC(k,m2,j3),ka, + $ 'ISHFTC(integer(1),integer(8),integer(2))') + call c_i1(ISHFTC(k,m2,k3),ka, + $ 'ISHFTC(integer(1),integer(8),integer(1))') + call c_i1(ISHFTC(k,m2,m3),ka, + $ 'ISHFTC(integer(1),integer(8),integer(8))') + + call c_i8(ISHFTC(m,i2,i3),ma,'ISHFTC(integer(8),integer,integer)') + call c_i8(ISHFTC(m,i2,j3),ma, + $ 'ISHFTC(integer(8),integer,integer(2))') + call c_i8(ISHFTC(m,i2,k3),ma, + $ 'ISHFTC(integer(8),integer,integer(1))') + call c_i8(ISHFTC(m,i2,m3),ma, + $ 'ISHFTC(integer(8),integer,integer(8))') + call c_i8(ISHFTC(m,j2,i3),ma, + $ 'ISHFTC(integer(8),integer(2),integer)') + call c_i8(ISHFTC(m,j2,j3),ma, + $ 'ISHFTC(integer(8),integer(2),integer(2))') + call c_i8(ISHFTC(m,j2,k3),ma, + $ 'ISHFTC(integer(8),integer(2),integer(1))') + call c_i8(ISHFTC(m,j2,m3),ma, + $ 'ISHFTC(integer(8),integer(2),integer(8))') + call c_i8(ISHFTC(m,k2,i3),ma, + $ 'ISHFTC(integer(8),integer(1),integer)') + call c_i8(ISHFTC(m,k2,j3),ma, + $ 'ISHFTC(integer(1),integer(8),integer(2))') + call c_i8(ISHFTC(m,k2,k3),ma, + $ 'ISHFTC(integer(1),integer(8),integer(1))') + call c_i8(ISHFTC(m,k2,m3),ma, + $ 'ISHFTC(integer(1),integer(8),integer(8))') + call c_i8(ISHFTC(m,m2,i3),ma, + $ 'ISHFTC(integer(8),integer(8),integer)') + call c_i8(ISHFTC(m,m2,j3),ma, + $ 'ISHFTC(integer(8),integer(8),integer(2))') + call c_i8(ISHFTC(m,m2,k3),ma, + $ 'ISHFTC(integer(8),integer(8),integer(1))') + call c_i8(ISHFTC(m,m2,m3),ma, + $ 'ISHFTC(integer(8),integer(8),integer(8))') + +c test the corner cases + call c_i(ISHFTC(i,BIT_SIZE(i),BIT_SIZE(i)),i, + $ 'ISHFTC(i,BIT_SIZE(i),BIT_SIZE(i)) i = integer') + call c_i(ISHFTC(i,0,BIT_SIZE(i)),i, + $ 'ISHFTC(i,0,BIT_SIZE(i)) i = integer') + call c_i(ISHFTC(i,-BIT_SIZE(i),BIT_SIZE(i)),i, + $ 'ISHFTC(i,-BIT_SIZE(i),BIT_SIZE(i)) i = integer') + call c_i2(ISHFTC(j,BIT_SIZE(j),BIT_SIZE(j)),j, + $ 'ISHFTC(j,BIT_SIZE(j),BIT_SIZE(j)) j = integer(2)') + call c_i2(ISHFTC(j,0,BIT_SIZE(j)),j, + $ 'ISHFTC(j,0,BIT_SIZE(j)) j = integer(2)') + call c_i2(ISHFTC(j,-BIT_SIZE(j),BIT_SIZE(j)),j, + $ 'ISHFTC(j,-BIT_SIZE(j),BIT_SIZE(j)) j = integer(2)') + call c_i1(ISHFTC(k,BIT_SIZE(k),BIT_SIZE(k)),k, + $ 'ISHFTC(k,BIT_SIZE(k),BIT_SIZE(k)) k = integer(1)') + call c_i1(ISHFTC(k,0,BIT_SIZE(k)),k, + $ 'ISHFTC(k,0,BIT_SIZE(k)) k = integer(1)') + call c_i1(ISHFTC(k,-BIT_SIZE(k),BIT_SIZE(k)),k, + $ 'ISHFTC(k,-BIT_SIZE(k),BIT_SIZE(k)) k = integer(1)') + call c_i8(ISHFTC(m,BIT_SIZE(m),BIT_SIZE(m)),m, + $ 'ISHFTC(m,BIT_SIZE(m),BIT_SIZE(m)) m = integer(8)') + call c_i8(ISHFTC(m,0,BIT_SIZE(m)),m, + $ 'ISHFTC(m,0,BIT_SIZE(m)) m = integer(8)') + call c_i8(ISHFTC(m,-BIT_SIZE(m),BIT_SIZE(m)),m, + $ 'ISHFTC(m,-BIT_SIZE(m),BIT_SIZE(m)) m = integer(8)') + +c MVBITS - Section 13.13.74 + i = 6 + call MVBITS(7,2,2,i,0) + call c_i(i,5,'MVBITS 1') + j = 6 + j2 = 7 + ja = 5 + call MVBITS(j2,2,2,j,0) + call c_i2(j,ja,'MVBITS 2') + k = 6 + k2 = 7 + ka = 5 + call MVBITS(k2,2,2,k,0) + call c_i1(k,ka,'MVBITS 3') + m = 6 + m2 = 7 + ma = 5 + call MVBITS(m2,2,2,m,0) + call c_i8(m,ma,'MVBITS 4') + +c NOT - Section 13.13.77 +c Rather than assume integer sizes, mask off high bits + j = 21 + j2 = 31 + ja = 10 + k = 21 + k2 = 31 + ka = 10 + m = 21 + m2 = 31 + ma = 10 + call c_i(IAND(NOT(21),31),10,'NOT(integer)') + call c_i2(IAND(NOT(j),j2),ja,'NOT(integer(2))') + call c_i1(IAND(NOT(k),k2),ka,'NOT(integer(1))') + call c_i8(IAND(NOT(m),m2),ma,'NOT(integer(8))') + + if ( fail ) call abort() + end + + subroutine failure(label) +c Report failure and set flag + character*(*) label + logical fail + common /flags/ fail + write(6,'(a,a,a)') 'Test ',label,' FAILED' + fail = .true. + end + + subroutine c_l(i,j,label) +c Check if LOGICAL i equals j, and fail otherwise + logical i,j + character*(*) label + if ( i .eqv. j ) then + call failure(label) + write(6,*) 'Got ',i,' expected ', j + end if + end + + subroutine c_i(i,j,label) +c Check if INTEGER i equals j, and fail otherwise + integer i,j + character*(*) label + if ( i .ne. j ) then + call failure(label) + write(6,*) 'Got ',i,' expected ', j + end if + end + + subroutine c_i2(i,j,label) +c Check if INTEGER(kind=2) i equals j, and fail otherwise + integer(kind=2) i,j + character*(*) label + if ( i .ne. j ) then + call failure(label) + write(6,*) 'Got ',i,' expected ', j + end if + end + + subroutine c_i1(i,j,label) +c Check if INTEGER(kind=1) i equals j, and fail otherwise + integer(kind=1) i,j + character*(*) label + if ( i .ne. j ) then + call failure(label) + write(6,*) 'Got ',i,' expected ', j + end if + end + + subroutine c_i8(i,j,label) +c Check if INTEGER(kind=8) i equals j, and fail otherwise + integer(kind=8) i,j + character*(*) label + if ( i .ne. j ) then + call failure(label) + write(6,*) 'Got ',i,' expected ', j + end if + end -- cgit v1.2.3