[multiple changes]

2001-07-20  David Billinghurst <David.Billinghurst@riotinto.org>

	* g77.f-torture/compile/pr3743.f:  New test

2001-07-20  David Billinghurst <David.Billinghurst@riotinto.com>

	* g77.f-torture/execute/f90-intrinsic-bit.f: New test

From-SVN: r44192
This commit is contained in:
Toon Moene 2001-07-20 10:52:06 +00:00
parent e8919ea425
commit 08f66b0485
3 changed files with 482 additions and 0 deletions

View File

@ -1,3 +1,11 @@
2001-07-20 David Billinghurst <David.Billinghurst@riotinto.org>
* g77.f-torture/compile/pr3743.f: New test
2001-07-20 David Billinghurst <David.Billinghurst@riotinto.com>
* g77.f-torture/execute/f90-intrinsic-bit.f: New test
2001-07-19 Rainer Orth <ro@TechFak.Uni-Bielefeld.DE>
* g++.old-deja/g++.pt/static3.C: Removed alpha*-*-osf* XFAIL.

View File

@ -0,0 +1,16 @@
program pr3743
c On mips-sgi-irix6.5 get
c
c i3 = ISHFT(i,BIT_SIZE(i))
c ^
c Reference to intrinsic `ISHFT' at (^) invalid --
c one or more arguments have incorrect type
c
c David Billinghurst <David.Billinghurst@riotinto.com>
c
integer i, i2, i3
i = 3
i2 = BIT_SIZE(i)
i3 = ISHFT(i,i2)
i3 = ISHFT(i,BIT_SIZE(i))
end

View File

@ -0,0 +1,458 @@
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 <David.Billinghurst@riotinto.com>
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*2 j, j2, j3, ja
integer*1 k, k2, k3, ka
integer*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*2 i equals j, and fail otherwise
integer*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*1 i equals j, and fail otherwise
integer*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*8 i equals j, and fail otherwise
integer*8 i,j
character*(*) label
if ( i .ne. j ) then
call failure(label)
write(6,*) 'Got ',i,' expected ', j
end if
end