trans-intrinsic.c (gfc_conv_intrinsic_ishft): Change to logicalshift.
gcc/fortran/ * trans-intrinsic.c (gfc_conv_intrinsic_ishft): Change to logicalshift. Call fold. Remove 0-bit shift shortcut. (gfc_conv_intrinsic_ishftc): Convert first argument to at least 4 bytes bits. Convert 2nd and 3rd argument to 4 bytes. Convert result if width(arg 1) < 4 bytes. Call fold. libgfortran/ * libgfortran/libgfortran.h (GFC_UINTEGER_1, GFC_UINTEGER_2): Define. * intrinsics/ishftc.c: Update copyright years. (ishftc8): Change 'shift' and 'size' to GFC_INTEGER_4. * intrinsics/mvbits.c: Correcty non-ASCII character in my name. Add implementations for GFC_INTEGER_1 and GFC_INTEGER_2. gcc/testsuite/ * gfortran.dg/g77/f90-intrinsic-bit.f: New. From-SVN: r92642
This commit is contained in:
Tobias Schlüter
Tobias Schlüter
parent
64092f8bc2
commit
56746a0745
@ -1,3 +1,11 @@
|
||||
2004-12-27 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
|
||||
|
||||
* trans-intrinsic.c (gfc_conv_intrinsic_ishft): Change to
|
||||
logical shift. Call fold. Remove 0-bit shift shortcut.
|
||||
(gfc_conv_intrinsic_ishftc): Convert first argument to at least
|
||||
4 bytes bits. Convert 2nd and 3rd argument to 4 bytes. Convert
|
||||
result if width(arg 1) < 4 bytes. Call fold.
|
||||
|
||||
2004-12-23 Steven G. Kargl <kargls@comcast.net>
|
||||
|
||||
* gfortran.texi: Fix typo.
|
||||
|
||||
@ -1774,14 +1774,21 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
|
||||
se->expr = fold (build2 (BIT_AND_EXPR, type, tmp, mask));
|
||||
}
|
||||
|
||||
/* ISHFT (I, SHIFT) = (shift >= 0) ? i << shift : i >> -shift. */
|
||||
/* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
|
||||
? 0
|
||||
: ((shift >= 0) ? i << shift : i >> -shift)
|
||||
where all shifts are logical shifts. */
|
||||
static void
|
||||
gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
|
||||
{
|
||||
tree arg;
|
||||
tree arg2;
|
||||
tree type;
|
||||
tree utype;
|
||||
tree tmp;
|
||||
tree width;
|
||||
tree num_bits;
|
||||
tree cond;
|
||||
tree lshift;
|
||||
tree rshift;
|
||||
|
||||
@ -1789,23 +1796,36 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
|
||||
arg2 = TREE_VALUE (TREE_CHAIN (arg));
|
||||
arg = TREE_VALUE (arg);
|
||||
type = TREE_TYPE (arg);
|
||||
utype = gfc_unsigned_type (type);
|
||||
|
||||
/* We convert to an unsigned type because we want a logical shift.
|
||||
The standard doesn't define the case of shifting negative
|
||||
numbers, and we try to be compatible with other compilers, most
|
||||
notably g77, here. */
|
||||
arg = convert (utype, arg);
|
||||
width = fold (build1 (ABS_EXPR, TREE_TYPE (arg2), arg2));
|
||||
|
||||
/* Left shift if positive. */
|
||||
lshift = build2 (LSHIFT_EXPR, type, arg, arg2);
|
||||
lshift = fold (build2 (LSHIFT_EXPR, type, arg, width));
|
||||
|
||||
/* Right shift if negative. This will perform an arithmetic shift as
|
||||
we are dealing with signed integers. Section 13.5.7 allows this. */
|
||||
tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
|
||||
rshift = build2 (RSHIFT_EXPR, type, arg, tmp);
|
||||
/* Right shift if negative. */
|
||||
rshift = convert (type, fold (build2 (RSHIFT_EXPR, utype, arg, width)));
|
||||
|
||||
tmp = build2 (GT_EXPR, boolean_type_node, arg2,
|
||||
convert (TREE_TYPE (arg2), integer_zero_node));
|
||||
rshift = build3 (COND_EXPR, type, tmp, lshift, rshift);
|
||||
tmp = fold (build2 (GE_EXPR, boolean_type_node, arg2,
|
||||
convert (TREE_TYPE (arg2), integer_zero_node)));
|
||||
tmp = fold (build3 (COND_EXPR, type, tmp, lshift, rshift));
|
||||
|
||||
/* Do nothing if shift == 0. */
|
||||
tmp = build2 (EQ_EXPR, boolean_type_node, arg2,
|
||||
convert (TREE_TYPE (arg2), integer_zero_node));
|
||||
se->expr = build3 (COND_EXPR, type, tmp, arg, rshift);
|
||||
/* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
|
||||
gcc requires a shift width < BIT_SIZE(I), so we have to catch this
|
||||
special case. */
|
||||
num_bits = convert (TREE_TYPE (arg2),
|
||||
build_int_cst (NULL, TYPE_PRECISION (type)));
|
||||
cond = fold (build2 (GE_EXPR, boolean_type_node, width,
|
||||
convert (TREE_TYPE (arg2), num_bits)));
|
||||
|
||||
se->expr = fold (build3 (COND_EXPR, type, cond,
|
||||
convert (type, integer_zero_node),
|
||||
tmp));
|
||||
}
|
||||
|
||||
/* Circular shift. AKA rotate or barrel shift. */
|
||||
@ -1826,17 +1846,28 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
|
||||
if (arg3)
|
||||
{
|
||||
/* Use a library function for the 3 parameter version. */
|
||||
tree int4type = gfc_get_int_type (4);
|
||||
|
||||
type = TREE_TYPE (TREE_VALUE (arg));
|
||||
/* Convert all args to the same type otherwise we need loads of library
|
||||
functions. SIZE and SHIFT cannot have values > BIT_SIZE (I) so the
|
||||
conversion is safe. */
|
||||
tmp = convert (type, TREE_VALUE (arg2));
|
||||
TREE_VALUE (arg2) = tmp;
|
||||
tmp = convert (type, TREE_VALUE (arg3));
|
||||
TREE_VALUE (arg3) = tmp;
|
||||
/* We convert the first argument to at least 4 bytes, and
|
||||
convert back afterwards. This removes the need for library
|
||||
functions for all argument sizes, and function will be
|
||||
aligned to at least 32 bits, so there's no loss. */
|
||||
if (expr->ts.kind < 4)
|
||||
{
|
||||
tmp = convert (int4type, TREE_VALUE (arg));
|
||||
TREE_VALUE (arg) = tmp;
|
||||
}
|
||||
/* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
|
||||
need loads of library functions. They cannot have values >
|
||||
BIT_SIZE (I) so the conversion is safe. */
|
||||
TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
|
||||
TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));
|
||||
|
||||
switch (expr->ts.kind)
|
||||
{
|
||||
case 1:
|
||||
case 2:
|
||||
case 4:
|
||||
tmp = gfor_fndecl_math_ishftc4;
|
||||
break;
|
||||
@ -1847,6 +1878,11 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
|
||||
gcc_unreachable ();
|
||||
}
|
||||
se->expr = gfc_build_function_call (tmp, arg);
|
||||
/* Convert the result back to the original type, if we extended
|
||||
the first argument's width above. */
|
||||
if (expr->ts.kind < 4)
|
||||
se->expr = convert (type, se->expr);
|
||||
|
||||
return;
|
||||
}
|
||||
arg = TREE_VALUE (arg);
|
||||
@ -1854,20 +1890,20 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
|
||||
type = TREE_TYPE (arg);
|
||||
|
||||
/* Rotate left if positive. */
|
||||
lrot = build2 (LROTATE_EXPR, type, arg, arg2);
|
||||
lrot = fold (build2 (LROTATE_EXPR, type, arg, arg2));
|
||||
|
||||
/* Rotate right if negative. */
|
||||
tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
|
||||
rrot = build2 (RROTATE_EXPR, type, arg, tmp);
|
||||
tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2));
|
||||
rrot = fold (build2 (RROTATE_EXPR, type, arg, tmp));
|
||||
|
||||
tmp = build2 (GT_EXPR, boolean_type_node, arg2,
|
||||
convert (TREE_TYPE (arg2), integer_zero_node));
|
||||
rrot = build3 (COND_EXPR, type, tmp, lrot, rrot);
|
||||
tmp = fold (build2 (GT_EXPR, boolean_type_node, arg2,
|
||||
convert (TREE_TYPE (arg2), integer_zero_node)));
|
||||
rrot = fold (build3 (COND_EXPR, type, tmp, lrot, rrot));
|
||||
|
||||
/* Do nothing if shift == 0. */
|
||||
tmp = build2 (EQ_EXPR, boolean_type_node, arg2,
|
||||
convert (TREE_TYPE (arg2), integer_zero_node));
|
||||
se->expr = build3 (COND_EXPR, type, tmp, arg, rrot);
|
||||
tmp = fold (build2 (EQ_EXPR, boolean_type_node, arg2,
|
||||
convert (TREE_TYPE (arg2), integer_zero_node)));
|
||||
se->expr = fold (build3 (COND_EXPR, type, tmp, arg, rrot));
|
||||
}
|
||||
|
||||
/* The length of a character string. */
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
2004-12-27 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
|
||||
|
||||
* gfortran.dg/g77/f90-intrinsic-bit.f: New.
|
||||
|
||||
2004-12-27 Mark Mitchell <mark@codesourcery.com>
|
||||
|
||||
PR c++/19148
|
||||
|
||||
459
gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f
Normal file
459
gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f
Normal file
@ -0,0 +1,459 @@
|
||||
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 <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
|
||||
@ -1,3 +1,12 @@
|
||||
2004-12-27 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
|
||||
|
||||
* libgfortran/libgfortran.h (GFC_UINTEGER_1, GFC_UINTEGER_2):
|
||||
Define.
|
||||
* intrinsics/ishftc.c: Update copyright years.
|
||||
(ishftc8): Change 'shift' and 'size' to GFC_INTEGER_4.
|
||||
* intrinsics/mvbits.c: Correcty non-ASCII character in my name.
|
||||
Add implementations for GFC_INTEGER_1 and GFC_INTEGER_2.
|
||||
|
||||
2004-12-23 Bud Davis <bdavis9659@comcast.net>
|
||||
|
||||
PR fortran/19071
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
/* Implementation of ishftc intrinsic.
|
||||
Copyright 2002 Free Software Foundation, Inc.
|
||||
Copyright 2002, 2004 Free Software Foundation, Inc.
|
||||
Contributed by Paul Brook <paul@nowt.org>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfor).
|
||||
@ -41,11 +41,11 @@ ishftc4 (GFC_INTEGER_4 i, GFC_INTEGER_4 shift, GFC_INTEGER_4 size)
|
||||
return (i & mask) | (bits >> (size - shift)) | ((i << shift) & ~mask);
|
||||
}
|
||||
|
||||
extern GFC_INTEGER_8 ishftc8 (GFC_INTEGER_8, GFC_INTEGER_8, GFC_INTEGER_8);
|
||||
extern GFC_INTEGER_8 ishftc8 (GFC_INTEGER_8, GFC_INTEGER_4, GFC_INTEGER_4);
|
||||
export_proto(ishftc8);
|
||||
|
||||
GFC_INTEGER_8
|
||||
ishftc8 (GFC_INTEGER_8 i, GFC_INTEGER_8 shift, GFC_INTEGER_8 size)
|
||||
ishftc8 (GFC_INTEGER_8 i, GFC_INTEGER_4 shift, GFC_INTEGER_4 size)
|
||||
{
|
||||
GFC_INTEGER_8 mask;
|
||||
GFC_UINTEGER_8 bits;
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
/* Implementation of the MVBITS intrinsic
|
||||
Copyright (C) 2004 Free Software Foundation, Inc.
|
||||
Contributed by Tobias Schlüter
|
||||
Contributed by Tobias Schlüter
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
@ -48,6 +48,22 @@ SUB_NAME (const TYPE *from, const GFC_INTEGER_4 *frompos,
|
||||
#endif
|
||||
|
||||
#ifndef SUB_NAME
|
||||
# define TYPE GFC_INTEGER_1
|
||||
# define UTYPE GFC_UINTEGER_1
|
||||
# define SUB_NAME mvbits_i1
|
||||
# include "mvbits.c"
|
||||
# undef SUB_NAME
|
||||
# undef TYPE
|
||||
# undef UTYPE
|
||||
|
||||
# define TYPE GFC_INTEGER_2
|
||||
# define UTYPE GFC_UINTEGER_2
|
||||
# define SUB_NAME mvbits_i2
|
||||
# include "mvbits.c"
|
||||
# undef SUB_NAME
|
||||
# undef TYPE
|
||||
# undef UTYPE
|
||||
|
||||
# define TYPE GFC_INTEGER_4
|
||||
# define UTYPE GFC_UINTEGER_4
|
||||
# define SUB_NAME mvbits_i4
|
||||
|
||||
@ -189,6 +189,8 @@ typedef int8_t GFC_INTEGER_1;
|
||||
typedef int16_t GFC_INTEGER_2;
|
||||
typedef int32_t GFC_INTEGER_4;
|
||||
typedef int64_t GFC_INTEGER_8;
|
||||
typedef uint8_t GFC_UINTEGER_1;
|
||||
typedef uint16_t GFC_UINTEGER_2;
|
||||
typedef uint32_t GFC_UINTEGER_4;
|
||||
typedef uint64_t GFC_UINTEGER_8;
|
||||
typedef GFC_INTEGER_4 GFC_LOGICAL_4;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user