+2008-10-02 Steven Bosscher <steven@gcc.gnu.org>
+
+ PR fortran/37635
+ * intrinsic.c (add_functions): Add LEADZ and TRAILZ as generics.
+ * intrinsic.h (gfc_simplify_leadz, gfc_simplify_trailz): New protos.
+ * gfortran.h <enum gfc_isym_id>: (GFC_ISYM_LEADZ, GFC_ISYM_TRAILZ): New.
+ * f95-lang (gfc_init_builtin_functions): Add BUILT_IN_CLZ,
+ BUILT_IN_CLZL, BUILT_IN_CLZLL, BUILT_IN_CTZ, BUILT_IN_CTZL, and
+ BUILT_IN_CTZLL.
+ * trans-intrinsic.c (gfc_conv_intrinsic_leadz,
+ gfc_conv_intrinsic_trails): New code-generation functions for LEADZ
+ and TRAILZ intrinsics.
+ (gfc_conv_intrinsic_function): Use them
+ * intrinsic.texi: Add documentation for LEADZ and TRAILZ.
+ * simplify.c (gfc_simplify_leadz, gfc_simplify_trailz): New functions.
+
2008-09-30 Janus Weil <janus@gcc.gnu.org>
PR fortran/36592
BUILT_IN_SINCOSF, "sincosf", false);
}
+ /* For LEADZ / TRAILZ. */
+ tmp = tree_cons (NULL_TREE, unsigned_type_node, void_list_node);
+ ftype = build_function_type (integer_type_node, tmp);
+ gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ,
+ "__builtin_clz", true);
+
+ tmp = tree_cons (NULL_TREE, long_unsigned_type_node, void_list_node);
+ ftype = build_function_type (integer_type_node, tmp);
+ gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL,
+ "__builtin_clzl", true);
+
+ tmp = tree_cons (NULL_TREE, long_long_unsigned_type_node, void_list_node);
+ ftype = build_function_type (integer_type_node, tmp);
+ gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL,
+ "__builtin_clzll", true);
+
+ tmp = tree_cons (NULL_TREE, unsigned_type_node, void_list_node);
+ ftype = build_function_type (integer_type_node, tmp);
+ gfc_define_builtin ("__builtin_ctz", ftype, BUILT_IN_CTZ,
+ "__builtin_ctz", true);
+
+ tmp = tree_cons (NULL_TREE, long_unsigned_type_node, void_list_node);
+ ftype = build_function_type (integer_type_node, tmp);
+ gfc_define_builtin ("__builtin_ctzl", ftype, BUILT_IN_CTZL,
+ "__builtin_ctzl", true);
+
+ tmp = tree_cons (NULL_TREE, long_long_unsigned_type_node, void_list_node);
+ ftype = build_function_type (integer_type_node, tmp);
+ gfc_define_builtin ("__builtin_ctzll", ftype, BUILT_IN_CTZLL,
+ "__builtin_ctzll", true);
+
/* Other builtin functions we use. */
tmp = tree_cons (NULL_TREE, long_integer_type_node, void_list_node);
GFC_ISYM_KILL,
GFC_ISYM_KIND,
GFC_ISYM_LBOUND,
+ GFC_ISYM_LEADZ,
GFC_ISYM_LEN,
GFC_ISYM_LEN_TRIM,
GFC_ISYM_LGAMMA,
GFC_ISYM_TIME,
GFC_ISYM_TIME8,
GFC_ISYM_TINY,
+ GFC_ISYM_TRAILZ,
GFC_ISYM_TRANSFER,
GFC_ISYM_TRANSPOSE,
GFC_ISYM_TRIM,
make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
+ add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO,
+ BT_INTEGER, di, GFC_STD_F2008,
+ gfc_check_i, gfc_simplify_leadz, NULL,
+ i, BT_INTEGER, di, REQUIRED);
+
+ make_generic ("leadz", GFC_ISYM_LEADZ, GFC_STD_F2008);
+
add_sym_2 ("len", GFC_ISYM_LEN, CLASS_INQUIRY, ACTUAL_YES,
BT_INTEGER, di, GFC_STD_F77,
gfc_check_len_lentrim, gfc_simplify_len, gfc_resolve_len,
make_generic ("tiny", GFC_ISYM_TINY, GFC_STD_F95);
+ add_sym_1 ("trailz", GFC_ISYM_TRAILZ, CLASS_ELEMENTAL, ACTUAL_NO,
+ BT_INTEGER, di, GFC_STD_F2008,
+ gfc_check_i, gfc_simplify_trailz, NULL,
+ i, BT_INTEGER, di, REQUIRED);
+
+ make_generic ("trailz", GFC_ISYM_TRAILZ, GFC_STD_F2008);
+
add_sym_3 ("transfer", GFC_ISYM_TRANSFER, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_transfer, gfc_simplify_transfer, gfc_resolve_transfer,
src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED,
gfc_expr *gfc_simplify_ishftc (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_kind (gfc_expr *);
gfc_expr *gfc_simplify_lbound (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_leadz (gfc_expr *);
gfc_expr *gfc_simplify_len (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_len_trim (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_lgamma (gfc_expr *);
gfc_expr *gfc_simplify_tan (gfc_expr *);
gfc_expr *gfc_simplify_tanh (gfc_expr *);
gfc_expr *gfc_simplify_tiny (gfc_expr *);
+gfc_expr *gfc_simplify_trailz (gfc_expr *);
gfc_expr *gfc_simplify_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_trim (gfc_expr *);
gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
* @code{KILL}: KILL, Send a signal to a process
* @code{KIND}: KIND, Kind of an entity
* @code{LBOUND}: LBOUND, Lower dimension bounds of an array
+* @code{LEADZ}: LEADZ, Number of leading zero bits of an integer
* @code{LEN}: LEN, Length of a character entity
* @code{LEN_TRIM}: LEN_TRIM, Length of a character entity without trailing blank characters
* @code{LOG_GAMMA}: LOG_GAMMA, Logarithm of the Gamma function
* @code{TIME}: TIME, Time function
* @code{TIME8}: TIME8, Time function (64-bit)
* @code{TINY}: TINY, Smallest positive number of a real kind
+* @code{TRAILZ}: TRAILZ, Number of trailing zero bits of an integer
* @code{TRANSFER}: TRANSFER, Transfer bit patterns
* @code{TRANSPOSE}: TRANSPOSE, Transpose an array of rank two
* @code{TRIM}: TRIM, Remove trailing blank characters of a string
+@node LEADZ
+@section @code{LEADZ} --- Number of leading zero bits of an integer
+@fnindex LEADZ
+@cindex zero bits
+
+@table @asis
+@item @emph{Description}:
+@code{LEADZ} returns the number of leading zero bits of an integer.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = LEADZ(I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of type @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The type of the return value is the default @code{INTEGER}.
+If all the bits of @code{I} are zero, the result value is @code{BIT_SIZE(I)}.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_leadz
+ WRITE (*,*) LEADZ(1) ! prints 8 if BITSIZE(I) has the value 32
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{BIT_SIZE}, @ref{TRAILZ}
+@end table
+
+
+
@node LEN
@section @code{LEN} --- Length of a character entity
@fnindex LEN
+@node TRAILZ
+@section @code{TRAILZ} --- Number of trailing zero bits of an integer
+@fnindex TRAILZ
+@cindex zero bits
+
+@table @asis
+@item @emph{Description}:
+@code{TRAILZ} returns the number of trailing zero bits of an integer.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = TRAILZ(I)}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of type @code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The type of the return value is the default @code{INTEGER}.
+If all the bits of @code{I} are zero, the result value is @code{BIT_SIZE(I)}.
+
+@item @emph{Example}:
+@smallexample
+PROGRAM test_trailz
+ WRITE (*,*) TRAILZ(8) ! prints 3
+END PROGRAM
+@end smallexample
+
+@item @emph{See also}:
+@ref{BIT_SIZE}, @ref{LEADZ}
+@end table
+
+
+
@node TRANSFER
@section @code{TRANSFER} --- Transfer bit patterns
@fnindex TRANSFER
gfc_expr *
+gfc_simplify_leadz (gfc_expr *e)
+{
+ gfc_expr *result;
+ unsigned long lz, bs;
+ int i;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ bs = gfc_integer_kinds[i].bit_size;
+ if (mpz_cmp_si (e->value.integer, 0) == 0)
+ lz = bs;
+ else
+ lz = bs - mpz_sizeinbase (e->value.integer, 2);
+
+ result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
+ mpz_set_ui (result->value.integer, lz);
+
+ return result;
+}
+
+
+gfc_expr *
gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
gfc_expr *
+gfc_simplify_trailz (gfc_expr *e)
+{
+ gfc_expr *result;
+ unsigned long tz, bs;
+ int i;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ bs = gfc_integer_kinds[i].bit_size;
+ tz = mpz_scan1 (e->value.integer, 0);
+
+ result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
+ mpz_set_ui (result->value.integer, MIN (tz, bs));
+
+ return result;
+}
+
+
+gfc_expr *
gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
{
gfc_expr *result;
se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
}
+/* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
+ : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
+
+ The conditional expression is necessary because the result of LEADZ(0)
+ is defined, but the result of __builtin_clz(0) is undefined for most
+ targets.
+
+ For INTEGER kinds smaller than the C 'int' type, we have to subtract the
+ difference in bit size between the argument of LEADZ and the C int. */
+
+static void
+gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
+{
+ tree arg;
+ tree arg_type;
+ tree cond;
+ tree result_type;
+ tree leadz;
+ tree bit_size;
+ tree tmp;
+ int arg_kind;
+ int i, n, s;
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+
+ /* 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)
+ {
+ 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 ();
+ }
+
+ /* Convert the actual argument to the proper argument type for the built-in
+ function. But the return type is of the default INTEGER kind. */
+ 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));
+ 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);
+
+ /* ??? 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);
+}
+
+/* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
+
+ The conditional expression is necessary because the result of TRAILZ(0)
+ is defined, but the result of __builtin_ctz(0) is undefined for most
+ targets. */
+
+static void
+gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
+{
+ tree arg;
+ tree arg_type;
+ tree cond;
+ tree result_type;
+ tree trailz;
+ tree bit_size;
+ int arg_kind;
+ int i, n;
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+
+ /* 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)
+ {
+ 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 ();
+ }
+
+ /* Convert the actual argument to the proper argument type for the built-in
+ function. But the return type is of the default INTEGER kind. */
+ 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));
+
+ /* Build BIT_SIZE. */
+ bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size);
+
+ /* ??? 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);
+}
/* Process an intrinsic with unspecified argument-types that has an optional
argument (which could be of type character), e.g. EOSHIFT. For those, we
gfc_conv_intrinsic_ishftc (se, expr);
break;
+ case GFC_ISYM_LEADZ:
+ gfc_conv_intrinsic_leadz (se, expr);
+ break;
+
+ case GFC_ISYM_TRAILZ:
+ gfc_conv_intrinsic_trailz (se, expr);
+ break;
+
case GFC_ISYM_LBOUND:
gfc_conv_intrinsic_bound (se, expr, 0);
break;
+2008-10-02 Steven Bosscher <steven@gcc.gnu.org>
+
+ PR fortran/37635
+ * gfortran.fortran-torture/execute/intrinsic_leadz.f90: New test.
+ * gfortran.fortran-torture/execute/intrinsic_trailz.f90: New test.
+
2008-10-02 Janis Johnson <janis187@us.ibm.com>
* gcc.dg/torture/pr36891.c: Ignore an irrelevant warning.
--- /dev/null
+program test_intrinsic_leadz
+ implicit none
+
+ call test_leadz(0_1,0_2,0_4,0_8,1_1,1_2,1_4,1_8,8_1,8_2,8_4,8_8)
+ stop
+
+ contains
+
+ subroutine test_leadz(z1,z2,z4,z8,i1,i2,i4,i8,e1,e2,e4,e8)
+ integer(kind=1) :: z1, i1, e1
+ integer(kind=2) :: z2, i2, e2
+ integer(kind=4) :: z4, i4, e4
+ integer(kind=8) :: z8, i8, e8
+
+ if (leadz(0_1) /= 8) call abort()
+ if (leadz(0_2) /= 16) call abort()
+ if (leadz(0_4) /= 32) call abort()
+ if (leadz(0_8) /= 64) call abort()
+
+ if (leadz(1_1) /= 7) call abort()
+ if (leadz(1_2) /= 15) call abort()
+ if (leadz(1_4) /= 31) call abort()
+ if (leadz(1_8) /= 63) call abort()
+
+ if (leadz(8_1) /= 4) call abort()
+ if (leadz(8_2) /= 12) call abort()
+ if (leadz(8_4) /= 28) call abort()
+ if (leadz(8_8) /= 60) call abort()
+
+ if (leadz(z1) /= 8) call abort()
+ if (leadz(z2) /= 16) call abort()
+ if (leadz(z4) /= 32) call abort()
+ if (leadz(z8) /= 64) call abort()
+
+ if (leadz(i1) /= 7) call abort()
+ if (leadz(i2) /= 15) call abort()
+ if (leadz(i4) /= 31) call abort()
+ if (leadz(i8) /= 63) call abort()
+
+ if (leadz(e1) /= 4) call abort()
+ if (leadz(e2) /= 12) call abort()
+ if (leadz(e4) /= 28) call abort()
+ if (leadz(e8) /= 60) call abort()
+ end subroutine test_leadz
+
+end program
--- /dev/null
+program test_intrinsic_trailz
+ implicit none
+
+ call test_trailz(0_1,0_2,0_4,0_8,1_1,1_2,1_4,1_8,8_1,8_2,8_4,8_8)
+ stop
+
+ contains
+
+ subroutine test_trailz(z1,z2,z4,z8,i1,i2,i4,i8,e1,e2,e4,e8)
+ integer(kind=1) :: z1, i1, e1
+ integer(kind=2) :: z2, i2, e2
+ integer(kind=4) :: z4, i4, e4
+ integer(kind=8) :: z8, i8, e8
+
+ if (trailz(0_1) /= 8) call abort()
+ if (trailz(0_2) /= 16) call abort()
+ if (trailz(0_4) /= 32) call abort()
+ if (trailz(0_8) /= 64) 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()
+
+ if (trailz(8_1) /= 3) call abort()
+ if (trailz(8_2) /= 3) call abort()
+ if (trailz(8_4) /= 3) call abort()
+ if (trailz(8_8) /= 3) call abort()
+
+ if (trailz(z1) /= 8) call abort()
+ if (trailz(z2) /= 16) call abort()
+ if (trailz(z4) /= 32) call abort()
+ if (trailz(z8) /= 64) 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 (trailz(e1) /= 3) call abort()
+ if (trailz(e2) /= 3) call abort()
+ if (trailz(e4) /= 3) call abort()
+ if (trailz(e8) /= 3) call abort()
+ end subroutine test_trailz
+
+end program
OSDN Git Service
