diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 23e93396882..5f2707e6772 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2004-12-27 Tobias Schlueter + + * 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 * gfortran.texi: Fix typo. diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index e11aa302bfa..56def1a7373 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index d6366a46b20..929a3261fa9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2004-12-27 Tobias Schlueter + + * gfortran.dg/g77/f90-intrinsic-bit.f: New. + 2004-12-27 Mark Mitchell PR c++/19148 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 00000000000..b718a4cb41f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/g77/f90-intrinsic-bit.f @@ -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 +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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 749f5a3edbe..8b1b53a636b 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,12 @@ +2004-12-27 Tobias Schlueter + + * 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 PR fortran/19071 diff --git a/libgfortran/intrinsics/ishftc.c b/libgfortran/intrinsics/ishftc.c index 7d5767c9144..896faac06f7 100644 --- a/libgfortran/intrinsics/ishftc.c +++ b/libgfortran/intrinsics/ishftc.c @@ -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 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; diff --git a/libgfortran/intrinsics/mvbits.c b/libgfortran/intrinsics/mvbits.c index 140547bf482..e1e3e40313c 100644 --- a/libgfortran/intrinsics/mvbits.c +++ b/libgfortran/intrinsics/mvbits.c @@ -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 diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 06a68c6ef07..7ddc0ed7e93 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -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;