re PR fortran/40019 (LEADZ and TRAILZ give wrong results)

2009-05-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>

        PR fortran/40019
        * trans-types.c (gfc_build_uint_type): Make nonstatic.
        * trans.h (gfor_fndecl_clz128, gfor_fndecl_ctz128): New
        * prototypes.
        * trans-types.h (gfc_build_uint_type): Add prototype.
        * trans-decl.c (gfc_build_intrinsic_function_decls): Build
        gfor_fndecl_clz128 and gfor_fndecl_ctz128.
        * trans-intrinsic.c (gfc_conv_intrinsic_leadz,
        gfc_conv_intrinsic_trailz): Call the right builtins or library
        functions, and cast arguments to unsigned types first.
        * simplify.c (gfc_simplify_leadz): Deal with negative arguments.

2009-05-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>

        PR fortran/40019
        * intrinsics/bit_intrinsics.c: New file.
        * gfortran.map (GFORTRAN_1.2): New list.
        * Makefile.am: Add intrinsics/bit_intrinsics.c.
        * Makefile.in: Regenerate.

2009-05-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>

        PR fortran/40019
        * gfortran.dg/leadz_trailz_1.f90: New test.
        * gfortran.dg/leadz_trailz_2.f90: New test.

From-SVN: r147987

10 files changed, 267 insertions, 62 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6f9e424..c94b7d7 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,16 @@
+2009-05-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/40019
+	* trans-types.c (gfc_build_uint_type): Make nonstatic.
+	* trans.h (gfor_fndecl_clz128, gfor_fndecl_ctz128): New prototypes.
+	* trans-types.h (gfc_build_uint_type): Add prototype.
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Build
+	gfor_fndecl_clz128 and gfor_fndecl_ctz128.
+	* trans-intrinsic.c (gfc_conv_intrinsic_leadz,
+	gfc_conv_intrinsic_trailz): Call the right builtins or library
+	functions, and cast arguments to unsigned types first.
+	* simplify.c (gfc_simplify_leadz): Deal with negative arguments.
+
 2009-05-27  Ian Lance Taylor  <iant@google.com>
 
 	* Make-lang.in (gfortran$(exeext)): Change $(COMPILER) to
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 4dd114b..51a3c51 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -2579,10 +2579,13 @@ gfc_simplify_leadz (gfc_expr *e)
   bs = gfc_integer_kinds[i].bit_size;
   if (mpz_cmp_si (e->value.integer, 0) == 0)
     lz = bs;
+  else if (mpz_cmp_si (e->value.integer, 0) < 0)
+    lz = 0;
   else
     lz = bs - mpz_sizeinbase (e->value.integer, 2);
 
-  result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
+  result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
+				&e->where);
   mpz_set_ui (result->value.integer, lz);
 
   return result;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index ba85edd..a036aeb 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -145,6 +145,8 @@ tree gfor_fndecl_convert_char4_to_char1;
 tree gfor_fndecl_size0;
 tree gfor_fndecl_size1;
 tree gfor_fndecl_iargc;
+tree gfor_fndecl_clz128;
+tree gfor_fndecl_ctz128;
 
 /* Intrinsic functions implemented in Fortran.  */
 tree gfor_fndecl_sc_kind;
@@ -2570,6 +2572,19 @@ gfc_build_intrinsic_function_decls (void)
     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
 				     gfc_int4_type_node,
 				     0);
+
+  if (gfc_type_for_size (128, true))
+    {
+      tree uint128 = gfc_type_for_size (128, true);
+
+      gfor_fndecl_clz128 =
+	gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
+					 integer_type_node, 1, uint128);
+
+      gfor_fndecl_ctz128 =
+	gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
+					 integer_type_node, 1, uint128);
+    }
 }
 
 
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 33cc7f5..c140957 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -2710,53 +2710,51 @@ gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
   tree leadz;
   tree bit_size;
   tree tmp;
-  int arg_kind;
-  int i, n, s;
+  tree func;
+  int s, argsize;
 
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  argsize = TYPE_PRECISION (TREE_TYPE (arg));
 
   /* Which variant of __builtin_clz* should we call?  */
-  arg_kind = expr->value.function.actual->expr->ts.kind;
-  i = gfc_validate_kind (BT_INTEGER, arg_kind, false);
-  switch (arg_kind)
+  if (argsize <= INT_TYPE_SIZE)
     {
-      case 1:
-      case 2:
-      case 4:
-        arg_type = unsigned_type_node;
-	n = BUILT_IN_CLZ;
-	break;
-
-      case 8:
-        arg_type = long_unsigned_type_node;
-	n = BUILT_IN_CLZL;
-	break;
-
-      case 16:
-        arg_type = long_long_unsigned_type_node;
-	n = BUILT_IN_CLZLL;
-	break;
-
-      default:
-        gcc_unreachable ();
+      arg_type = unsigned_type_node;
+      func = built_in_decls[BUILT_IN_CLZ];
+    }
+  else if (argsize <= LONG_TYPE_SIZE)
+    {
+      arg_type = long_unsigned_type_node;
+      func = built_in_decls[BUILT_IN_CLZL];
+    }
+  else if (argsize <= LONG_LONG_TYPE_SIZE)
+    {
+      arg_type = long_long_unsigned_type_node;
+      func = built_in_decls[BUILT_IN_CLZLL];
+    }
+  else
+    {
+      gcc_assert (argsize == 128);
+      arg_type = gfc_build_uint_type (argsize);
+      func = gfor_fndecl_clz128;
     }
 
-  /* Convert the actual argument to the proper argument type for the built-in
+  /* Convert the actual argument twice: first, to the unsigned type of the
+     same size; then, to the proper argument type for the built-in
      function.  But the return type is of the default INTEGER kind.  */
+  arg = fold_convert (gfc_build_uint_type (argsize), arg);
   arg = fold_convert (arg_type, arg);
   result_type = gfc_get_int_type (gfc_default_integer_kind);
 
   /* Compute LEADZ for the case i .ne. 0.  */
-  s = TYPE_PRECISION (arg_type) - gfc_integer_kinds[i].bit_size;
-  tmp = fold_convert (result_type, build_call_expr (built_in_decls[n], 1, arg));
+  s = TYPE_PRECISION (arg_type) - argsize;
+  tmp = fold_convert (result_type, build_call_expr (func, 1, arg));
   leadz = fold_build2 (MINUS_EXPR, result_type,
 		       tmp, build_int_cst (result_type, s));
 
   /* Build BIT_SIZE.  */
-  bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size);
+  bit_size = build_int_cst (result_type, argsize);
 
-  /* ??? For some combinations of targets and integer kinds, the condition
-	 can be avoided if CLZ_DEFINED_VALUE_AT_ZERO is used.  Later.  */
   cond = fold_build2 (EQ_EXPR, boolean_type_node,
 		      arg, build_int_cst (arg_type, 0));
   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
@@ -2777,50 +2775,48 @@ gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
   tree result_type;
   tree trailz;
   tree bit_size;
-  int arg_kind;
-  int i, n;
+  tree func;
+  int argsize;
 
   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+  argsize = TYPE_PRECISION (TREE_TYPE (arg));
 
-  /* Which variant of __builtin_clz* should we call?  */
-  arg_kind = expr->value.function.actual->expr->ts.kind;
-  i = gfc_validate_kind (BT_INTEGER, arg_kind, false);
-  switch (expr->ts.kind)
+  /* Which variant of __builtin_ctz* should we call?  */
+  if (argsize <= INT_TYPE_SIZE)
     {
-      case 1:
-      case 2:
-      case 4:
-        arg_type = unsigned_type_node;
-	n = BUILT_IN_CTZ;
-	break;
-
-      case 8:
-        arg_type = long_unsigned_type_node;
-	n = BUILT_IN_CTZL;
-	break;
-
-      case 16:
-        arg_type = long_long_unsigned_type_node;
-	n = BUILT_IN_CTZLL;
-	break;
-
-      default:
-        gcc_unreachable ();
+      arg_type = unsigned_type_node;
+      func = built_in_decls[BUILT_IN_CTZ];
+    }
+  else if (argsize <= LONG_TYPE_SIZE)
+    {
+      arg_type = long_unsigned_type_node;
+      func = built_in_decls[BUILT_IN_CTZL];
+    }
+  else if (argsize <= LONG_LONG_TYPE_SIZE)
+    {
+      arg_type = long_long_unsigned_type_node;
+      func = built_in_decls[BUILT_IN_CTZLL];
+    }
+  else
+    {
+      gcc_assert (argsize == 128);
+      arg_type = gfc_build_uint_type (argsize);
+      func = gfor_fndecl_ctz128;
     }
 
-  /* Convert the actual argument to the proper argument type for the built-in
+  /* Convert the actual argument twice: first, to the unsigned type of the
+     same size; then, to the proper argument type for the built-in
      function.  But the return type is of the default INTEGER kind.  */
+  arg = fold_convert (gfc_build_uint_type (argsize), arg);
   arg = fold_convert (arg_type, arg);
   result_type = gfc_get_int_type (gfc_default_integer_kind);
 
   /* Compute TRAILZ for the case i .ne. 0.  */
-  trailz = fold_convert (result_type, build_call_expr (built_in_decls[n], 1, arg));
+  trailz = fold_convert (result_type, build_call_expr (func, 1, arg));
 
   /* Build BIT_SIZE.  */
-  bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size);
+  bit_size = build_int_cst (result_type, argsize);
 
-  /* ??? For some combinations of targets and integer kinds, the condition
-	 can be avoided if CTZ_DEFINED_VALUE_AT_ZERO is used.  Later.  */
   cond = fold_build2 (EQ_EXPR, boolean_type_node,
 		      arg, build_int_cst (arg_type, 0));
   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index e945fcb..0c43993 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -686,7 +686,7 @@ gfc_build_int_type (gfc_integer_info *info)
   return make_signed_type (mode_precision);
 }
 
-static tree
+tree
 gfc_build_uint_type (int size)
 {
   if (size == CHAR_TYPE_SIZE)
diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index c3e51a1..283d577 100644
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -68,6 +68,7 @@ tree gfc_get_function_type (gfc_symbol *);
 
 tree gfc_type_for_size (unsigned, int);
 tree gfc_type_for_mode (enum machine_mode, int);
+tree gfc_build_uint_type (int);
 
 tree gfc_get_element_type (tree);
 tree gfc_get_array_type_bounds (tree, int, tree *, tree *, int,
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 4846af2..90689698 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -590,6 +590,8 @@ extern GTY(()) tree gfor_fndecl_convert_char4_to_char1;
 extern GTY(()) tree gfor_fndecl_size0;
 extern GTY(()) tree gfor_fndecl_size1;
 extern GTY(()) tree gfor_fndecl_iargc;
+extern GTY(()) tree gfor_fndecl_clz128;
+extern GTY(()) tree gfor_fndecl_ctz128;
 
 /* Implemented in Fortran.  */
 extern GTY(()) tree gfor_fndecl_sc_kind;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 7479c1a..214cf74 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2009-05-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/40019
+	* gfortran.dg/leadz_trailz_1.f90: New test.
+	* gfortran.dg/leadz_trailz_2.f90: New test.
+
 2009-05-29  Martin Jambor  <mjambor@suse.cz>
 
 	* gfortran.dg/pr25923.f90: XFAIL warning expectation.
diff --git a/gcc/testsuite/gfortran.dg/leadz_trailz_1.f90 b/gcc/testsuite/gfortran.dg/leadz_trailz_1.f90
new file mode 100644
index 0000000..a0cd197
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/leadz_trailz_1.f90
@@ -0,0 +1,133 @@
+! { dg-do run }
+
+  integer(kind=1) :: i1
+  integer(kind=2) :: i2
+  integer(kind=4) :: i4
+  integer(kind=8) :: i8
+
+  i1 = -1
+  i2 = -1
+  i4 = -1
+  i8 = -1
+
+  if (leadz(i1) /= 0) call abort
+  if (leadz(i2) /= 0) call abort
+  if (leadz(i4) /= 0) call abort
+  if (leadz(i8) /= 0) call abort
+
+  if (trailz(i1) /= 0) call abort
+  if (trailz(i2) /= 0) call abort
+  if (trailz(i4) /= 0) call abort
+  if (trailz(i8) /= 0) call abort
+
+  if (leadz(-1_1) /= 0) call abort
+  if (leadz(-1_2) /= 0) call abort
+  if (leadz(-1_4) /= 0) call abort
+  if (leadz(-1_8) /= 0) call abort
+
+  if (trailz(-1_1) /= 0) call abort
+  if (trailz(-1_2) /= 0) call abort
+  if (trailz(-1_4) /= 0) call abort
+  if (trailz(-1_8) /= 0) call abort
+
+  i1 = -64
+  i2 = -64
+  i4 = -64
+  i8 = -64
+
+  if (leadz(i1) /= 0) call abort
+  if (leadz(i2) /= 0) call abort
+  if (leadz(i4) /= 0) call abort
+  if (leadz(i8) /= 0) call abort
+
+  if (trailz(i1) /= 6) call abort
+  if (trailz(i2) /= 6) call abort
+  if (trailz(i4) /= 6) call abort
+  if (trailz(i8) /= 6) call abort
+
+  if (leadz(-64_1) /= 0) call abort
+  if (leadz(-64_2) /= 0) call abort
+  if (leadz(-64_4) /= 0) call abort
+  if (leadz(-64_8) /= 0) call abort
+
+  if (trailz(-64_1) /= 6) call abort
+  if (trailz(-64_2) /= 6) call abort
+  if (trailz(-64_4) /= 6) call abort
+  if (trailz(-64_8) /= 6) call abort
+
+  i1 = -108
+  i2 = -108
+  i4 = -108
+  i8 = -108
+
+  if (leadz(i1) /= 0) call abort
+  if (leadz(i2) /= 0) call abort
+  if (leadz(i4) /= 0) call abort
+  if (leadz(i8) /= 0) call abort
+
+  if (trailz(i1) /= 2) call abort
+  if (trailz(i2) /= 2) call abort
+  if (trailz(i4) /= 2) call abort
+  if (trailz(i8) /= 2) call abort
+
+  if (leadz(-108_1) /= 0) call abort
+  if (leadz(-108_2) /= 0) call abort
+  if (leadz(-108_4) /= 0) call abort
+  if (leadz(-108_8) /= 0) call abort
+
+  if (trailz(-108_1) /= 2) call abort
+  if (trailz(-108_2) /= 2) call abort
+  if (trailz(-108_4) /= 2) call abort
+  if (trailz(-108_8) /= 2) call abort
+
+  i1 = 1
+  i2 = 1
+  i4 = 1
+  i8 = 1
+
+  if (leadz(i1) /= bit_size(i1) - 1) call abort
+  if (leadz(i2) /= bit_size(i2) - 1) call abort
+  if (leadz(i4) /= bit_size(i4) - 1) call abort
+  if (leadz(i8) /= bit_size(i8) - 1) call abort
+
+  if (trailz(i1) /= 0) call abort
+  if (trailz(i2) /= 0) call abort
+  if (trailz(i4) /= 0) call abort
+  if (trailz(i8) /= 0) call abort
+
+  if (leadz(1_1) /= bit_size(1_1) - 1) call abort
+  if (leadz(1_2) /= bit_size(1_2) - 1) call abort
+  if (leadz(1_4) /= bit_size(1_4) - 1) call abort
+  if (leadz(1_8) /= bit_size(1_8) - 1) call abort
+
+  if (trailz(1_1) /= 0) call abort
+  if (trailz(1_2) /= 0) call abort
+  if (trailz(1_4) /= 0) call abort
+  if (trailz(1_8) /= 0) call abort
+
+  i1 = 64
+  i2 = 64
+  i4 = 64
+  i8 = 64
+
+  if (leadz(i1) /= 1) call abort
+  if (leadz(i2) /= 9) call abort
+  if (leadz(i4) /= 25) call abort
+  if (leadz(i8) /= 57) call abort
+
+  if (trailz(i1) /= 6) call abort
+  if (trailz(i2) /= 6) call abort
+  if (trailz(i4) /= 6) call abort
+  if (trailz(i8) /= 6) call abort
+
+  if (leadz(64_1) /= 1) call abort
+  if (leadz(64_2) /= 9) call abort
+  if (leadz(64_4) /= 25) call abort
+  if (leadz(64_8) /= 57) call abort
+
+  if (trailz(64_1) /= 6) call abort
+  if (trailz(64_2) /= 6) call abort
+  if (trailz(64_4) /= 6) call abort
+  if (trailz(64_8) /= 6) call abort
+
+end
diff --git a/gcc/testsuite/gfortran.dg/leadz_trailz_2.f90 b/gcc/testsuite/gfortran.dg/leadz_trailz_2.f90
new file mode 100644
index 0000000..08701d8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/leadz_trailz_2.f90
@@ -0,0 +1,36 @@
+! { dg-do run }
+! { dg-require-effective-target fortran_large_int }
+
+  integer(kind=16) :: i16
+
+  i16 = -1
+  if (leadz(i16) /= 0) call abort
+  if (trailz(i16) /= 0) call abort
+  if (leadz(-1_16) /= 0) call abort
+  if (trailz(-1_16) /= 0) call abort
+
+  i16 = -64
+  if (leadz(i16) /= 0) call abort
+  if (trailz(i16) /= 6) call abort
+  if (leadz(-64_16) /= 0) call abort
+  if (trailz(-64_16) /= 6) call abort
+
+  i16 = -108
+  if (leadz(i16) /= 0) call abort
+  if (trailz(i16) /= 2) call abort
+  if (leadz(-108_16) /= 0) call abort
+  if (trailz(-108_16) /= 2) call abort
+
+  i16 = 1
+  if (leadz(i16) /= bit_size(i16) - 1) call abort
+  if (trailz(i16) /= 0) call abort
+  if (leadz(1_16) /= bit_size(1_16) - 1) call abort
+  if (trailz(1_16) /= 0) call abort
+
+  i16 = 64
+  if (leadz(i16) /= 121) call abort
+  if (trailz(i16) /= 6) call abort
+  if (leadz(64_16) /= 121) call abort
+  if (trailz(64_16) /= 6) call abort
+
+end