+2007-01-20 Roger Sayle <roger@eyesopen.com>
+
+ * trans-intrinsic.c (gfc_conv_intrinsic_sign): New branchless
+ implementation for the SIGN intrinsic with integral operands.
+ (gfc_conv_intrinsic_minmax): Fix whitespace.
+
2007-01-20 Francois-Xavier Coudert <coudert@clipper.ens.fr>
* gfortran.h (gfc_options_t): Add flag_allow_leading_underscore.
/* Intrinsic translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
/* SIGN(A, B) is absolute value of A times sign of B.
The real value versions use library functions to ensure the correct
handling of negative zero. Integer case implemented as:
- SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
+ SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
*/
static void
tree arg;
tree arg2;
tree type;
- tree zero;
- tree testa;
- tree testb;
-
arg = gfc_conv_intrinsic_function_args (se, expr);
if (expr->ts.type == BT_REAL)
return;
}
+ /* Having excluded floating point types, we know we are now dealing
+ with signed integer types. */
arg2 = TREE_VALUE (TREE_CHAIN (arg));
arg = TREE_VALUE (arg);
type = TREE_TYPE (arg);
- zero = gfc_build_const (type, integer_zero_node);
- testa = fold_build2 (GE_EXPR, boolean_type_node, arg, zero);
- testb = fold_build2 (GE_EXPR, boolean_type_node, arg2, zero);
- tmp = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb);
- se->expr = fold_build3 (COND_EXPR, type, tmp,
- build1 (NEGATE_EXPR, type, arg), arg);
+ /* Arg is used multiple times below. */
+ arg = gfc_evaluate_now (arg, &se->pre);
+
+ /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
+ the signs of A and B are the same, and of all ones if they differ. */
+ tmp = fold_build2 (BIT_XOR_EXPR, type, arg, arg2);
+ tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
+ build_int_cst (type, TYPE_PRECISION (type) - 1));
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+
+ /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
+ is all ones (i.e. -1). */
+ se->expr = fold_build2 (BIT_XOR_EXPR, type,
+ fold_build2 (PLUS_EXPR, type, arg, tmp),
+ tmp);
}
limit = convert (type, limit);
/* Only evaluate the argument once. */
if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
- limit = gfc_evaluate_now(limit, &se->pre);
+ limit = gfc_evaluate_now (limit, &se->pre);
mvar = gfc_create_var (type, "M");
elsecase = build2_v (MODIFY_EXPR, mvar, limit);
/* Only evaluate the argument once. */
if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
- val = gfc_evaluate_now(val, &se->pre);
+ val = gfc_evaluate_now (val, &se->pre);
thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
+2007-01-20 Roger Sayle <roger@eyesopen.com>
+ Brooks Moses <brooks.moses@codesourcery.com>
+ Francois-Xavier Coudert <coudert@clipper.ens.fr>
+
+ * gfortran.dg/intrinsic_sign_1.f90: New test case.
+ * gfortran.dg/intrinsic_sign_2.f90: Likewise.
+
2007-01-19 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
* gcc.dg/torture/builtin-math-3.c: Test fdim.
--- /dev/null
+! { dg-do run }
+! At one point, SIGN() evaluated its first argument twice.
+! Contributed by Brooks Moses <brooks.moses@codesourcery.com>
+program sign1
+ integer :: i
+ i = 1
+ if (sign(foo(i), 1) /= 1) call abort
+ i = 1
+ if (sign(foo(i), -1) /= -1) call abort
+contains
+ integer function foo(i)
+ integer :: i
+ foo = i
+ i = i + 1
+ end function
+end
--- /dev/null
+! { dg-do run }
+! Testcase for SIGN() with integer arguments
+! Check that:
+! + SIGN() evaluates its arguments only once
+! + SIGN() works on large values
+! + SIGN() works with parameter arguments
+! Contributed by FX Coudert <fxcoudert@gmail.com>
+program sign1
+ implicit none
+ integer(kind=1), parameter :: one1 = 1_1, mone1 = -1_1
+ integer(kind=2), parameter :: one2 = 1_2, mone2 = -1_2
+ integer(kind=4), parameter :: one4 = 1_4, mone4 = -1_4
+ integer(kind=8), parameter :: one8 = 1_8, mone8 = -1_8
+ integer(kind=1) :: i1, j1
+ integer(kind=2) :: i2, j2
+ integer(kind=4) :: i4, j4
+ integer(kind=8) :: i8, j8
+ integer :: i = 1
+
+ i1 = huge(0_1) ; j1 = -huge(0_1)
+ if (sign(i1, j1) /= j1) call abort()
+ if (sign(j1, i1) /= i1) call abort()
+ if (sign(i1,one1) /= i1 .or. sign(j1,one1) /= i1) call abort()
+ if (sign(i1,mone1) /= j1 .or. sign(j1,mone1) /= j1) call abort()
+
+ i2 = huge(0_2) ; j2 = -huge(0_2)
+ if (sign(i2, j2) /= j2) call abort()
+ if (sign(j2, i2) /= i2) call abort()
+ if (sign(i2,one2) /= i2 .or. sign(j2,one2) /= i2) call abort()
+ if (sign(i2,mone2) /= j2 .or. sign(j2,mone2) /= j2) call abort()
+
+ i4 = huge(0_4) ; j4 = -huge(0_4)
+ if (sign(i4, j4) /= j4) call abort()
+ if (sign(j4, i4) /= i4) call abort()
+ if (sign(i4,one4) /= i4 .or. sign(j4,one4) /= i4) call abort()
+ if (sign(i4,mone4) /= j4 .or. sign(j4,mone4) /= j4) call abort()
+
+ i8 = huge(0_8) ; j8 = -huge(0_8)
+ if (sign(i8, j8) /= j8) call abort()
+ if (sign(j8, i8) /= i8) call abort()
+ if (sign(i8,one8) /= i8 .or. sign(j8,one8) /= i8) call abort()
+ if (sign(i8,mone8) /= j8 .or. sign(j8,mone8) /= j8) call abort()
+
+ if (sign(foo(i), 1) /= 1) call abort
+ if (sign(foo(i), -1) /= -2) call abort
+ if (sign(42, foo(i)) /= 42) call abort
+ if (sign(42, -foo(i)) /= -42) call abort
+ if (i /= 5) call abort
+
+ if (sign(bar(), 1) /= 1) call abort
+ if (sign(bar(), -1) /= -2) call abort
+ if (sign(17, bar()) /= 17) call abort
+ if (sign(17, -bar()) /= -17) call abort
+ if (bar() /= 5) call abort
+
+contains
+
+ integer function foo(i)
+ integer :: i
+ foo = i
+ i = i + 1
+ end function
+
+ integer function bar()
+ integer, save :: i = 0
+ i = i + 1
+ bar = i
+ end function
+end