Commit 56746a07 by Tobias Schlüter Committed by Tobias Schlüter

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
parent 64092f8b
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> 2004-12-23 Steven G. Kargl <kargls@comcast.net>
* gfortran.texi: Fix typo. * gfortran.texi: Fix typo.
......
...@@ -1774,14 +1774,21 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr) ...@@ -1774,14 +1774,21 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
se->expr = fold (build2 (BIT_AND_EXPR, type, tmp, mask)); 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 static void
gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
{ {
tree arg; tree arg;
tree arg2; tree arg2;
tree type; tree type;
tree utype;
tree tmp; tree tmp;
tree width;
tree num_bits;
tree cond;
tree lshift; tree lshift;
tree rshift; tree rshift;
...@@ -1789,23 +1796,36 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) ...@@ -1789,23 +1796,36 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
arg2 = TREE_VALUE (TREE_CHAIN (arg)); arg2 = TREE_VALUE (TREE_CHAIN (arg));
arg = TREE_VALUE (arg); arg = TREE_VALUE (arg);
type = TREE_TYPE (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. */ /* 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 /* Right shift if negative. */
we are dealing with signed integers. Section 13.5.7 allows this. */ rshift = convert (type, fold (build2 (RSHIFT_EXPR, utype, arg, width)));
tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
rshift = build2 (RSHIFT_EXPR, type, arg, tmp);
tmp = build2 (GT_EXPR, boolean_type_node, arg2, tmp = fold (build2 (GE_EXPR, boolean_type_node, arg2,
convert (TREE_TYPE (arg2), integer_zero_node)); convert (TREE_TYPE (arg2), integer_zero_node)));
rshift = build3 (COND_EXPR, type, tmp, lshift, rshift); tmp = fold (build3 (COND_EXPR, type, tmp, lshift, rshift));
/* Do nothing if shift == 0. */ /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
tmp = build2 (EQ_EXPR, boolean_type_node, arg2, gcc requires a shift width < BIT_SIZE(I), so we have to catch this
convert (TREE_TYPE (arg2), integer_zero_node)); special case. */
se->expr = build3 (COND_EXPR, type, tmp, arg, rshift); 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. */ /* Circular shift. AKA rotate or barrel shift. */
...@@ -1826,17 +1846,28 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) ...@@ -1826,17 +1846,28 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
if (arg3) if (arg3)
{ {
/* Use a library function for the 3 parameter version. */ /* Use a library function for the 3 parameter version. */
tree int4type = gfc_get_int_type (4);
type = TREE_TYPE (TREE_VALUE (arg)); type = TREE_TYPE (TREE_VALUE (arg));
/* Convert all args to the same type otherwise we need loads of library /* We convert the first argument to at least 4 bytes, and
functions. SIZE and SHIFT cannot have values > BIT_SIZE (I) so the convert back afterwards. This removes the need for library
conversion is safe. */ functions for all argument sizes, and function will be
tmp = convert (type, TREE_VALUE (arg2)); aligned to at least 32 bits, so there's no loss. */
TREE_VALUE (arg2) = tmp; if (expr->ts.kind < 4)
tmp = convert (type, TREE_VALUE (arg3)); {
TREE_VALUE (arg3) = tmp; 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) switch (expr->ts.kind)
{ {
case 1:
case 2:
case 4: case 4:
tmp = gfor_fndecl_math_ishftc4; tmp = gfor_fndecl_math_ishftc4;
break; break;
...@@ -1847,6 +1878,11 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) ...@@ -1847,6 +1878,11 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
gcc_unreachable (); gcc_unreachable ();
} }
se->expr = gfc_build_function_call (tmp, arg); 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; return;
} }
arg = TREE_VALUE (arg); arg = TREE_VALUE (arg);
...@@ -1854,20 +1890,20 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) ...@@ -1854,20 +1890,20 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
type = TREE_TYPE (arg); type = TREE_TYPE (arg);
/* Rotate left if positive. */ /* Rotate left if positive. */
lrot = build2 (LROTATE_EXPR, type, arg, arg2); lrot = fold (build2 (LROTATE_EXPR, type, arg, arg2));
/* Rotate right if negative. */ /* Rotate right if negative. */
tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2); tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2));
rrot = build2 (RROTATE_EXPR, type, arg, tmp); rrot = fold (build2 (RROTATE_EXPR, type, arg, tmp));
tmp = build2 (GT_EXPR, boolean_type_node, arg2, tmp = fold (build2 (GT_EXPR, boolean_type_node, arg2,
convert (TREE_TYPE (arg2), integer_zero_node)); convert (TREE_TYPE (arg2), integer_zero_node)));
rrot = build3 (COND_EXPR, type, tmp, lrot, rrot); rrot = fold (build3 (COND_EXPR, type, tmp, lrot, rrot));
/* Do nothing if shift == 0. */ /* Do nothing if shift == 0. */
tmp = build2 (EQ_EXPR, boolean_type_node, arg2, tmp = fold (build2 (EQ_EXPR, boolean_type_node, arg2,
convert (TREE_TYPE (arg2), integer_zero_node)); convert (TREE_TYPE (arg2), integer_zero_node)));
se->expr = build3 (COND_EXPR, type, tmp, arg, rrot); se->expr = fold (build3 (COND_EXPR, type, tmp, arg, rrot));
} }
/* The length of a character string. */ /* The length of a character string. */
......
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> 2004-12-27 Mark Mitchell <mark@codesourcery.com>
PR c++/19148 PR c++/19148
......
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> 2004-12-23 Bud Davis <bdavis9659@comcast.net>
PR fortran/19071 PR fortran/19071
......
/* Implementation of ishftc intrinsic. /* Implementation of ishftc intrinsic.
Copyright 2002 Free Software Foundation, Inc. Copyright 2002, 2004 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org> Contributed by Paul Brook <paul@nowt.org>
This file is part of the GNU Fortran 95 runtime library (libgfor). 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) ...@@ -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); 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); export_proto(ishftc8);
GFC_INTEGER_8 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_INTEGER_8 mask;
GFC_UINTEGER_8 bits; GFC_UINTEGER_8 bits;
......
/* Implementation of the MVBITS intrinsic /* Implementation of the MVBITS intrinsic
Copyright (C) 2004 Free Software Foundation, Inc. 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). 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, ...@@ -48,6 +48,22 @@ SUB_NAME (const TYPE *from, const GFC_INTEGER_4 *frompos,
#endif #endif
#ifndef SUB_NAME #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 TYPE GFC_INTEGER_4
# define UTYPE GFC_UINTEGER_4 # define UTYPE GFC_UINTEGER_4
# define SUB_NAME mvbits_i4 # define SUB_NAME mvbits_i4
......
...@@ -189,6 +189,8 @@ typedef int8_t GFC_INTEGER_1; ...@@ -189,6 +189,8 @@ typedef int8_t GFC_INTEGER_1;
typedef int16_t GFC_INTEGER_2; typedef int16_t GFC_INTEGER_2;
typedef int32_t GFC_INTEGER_4; typedef int32_t GFC_INTEGER_4;
typedef int64_t GFC_INTEGER_8; 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 uint32_t GFC_UINTEGER_4;
typedef uint64_t GFC_UINTEGER_8; typedef uint64_t GFC_UINTEGER_8;
typedef GFC_INTEGER_4 GFC_LOGICAL_4; typedef GFC_INTEGER_4 GFC_LOGICAL_4;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment