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
This commit is contained in:
Francois-Xavier Coudert
Tobias Burnus
parent
2017c37012
commit
0a05c536a6
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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.
|
||||
|
||||
133
gcc/testsuite/gfortran.dg/leadz_trailz_1.f90
Normal file
133
gcc/testsuite/gfortran.dg/leadz_trailz_1.f90
Normal file
@ -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
|
||||
36
gcc/testsuite/gfortran.dg/leadz_trailz_2.f90
Normal file
36
gcc/testsuite/gfortran.dg/leadz_trailz_2.f90
Normal file
@ -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
|
||||
@ -1,3 +1,11 @@
|
||||
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 Janne Blomqvist <jb@gcc.gnu.org>
|
||||
|
||||
PR libfortran/40190
|
||||
|
||||
@ -62,6 +62,7 @@ intrinsics/associated.c \
|
||||
intrinsics/abort.c \
|
||||
intrinsics/access.c \
|
||||
intrinsics/args.c \
|
||||
intrinsics/bit_intrinsics.c \
|
||||
intrinsics/c99_functions.c \
|
||||
intrinsics/chdir.c \
|
||||
intrinsics/chmod.c \
|
||||
|
||||
@ -416,9 +416,9 @@ am__libgfortran_la_SOURCES_DIST = runtime/backtrace.c \
|
||||
io/size_from_kind.c io/transfer.c io/unit.c io/unix.c \
|
||||
io/write.c io/fbuf.c intrinsics/associated.c \
|
||||
intrinsics/abort.c intrinsics/access.c intrinsics/args.c \
|
||||
intrinsics/c99_functions.c intrinsics/chdir.c \
|
||||
intrinsics/chmod.c intrinsics/clock.c intrinsics/cpu_time.c \
|
||||
intrinsics/cshift0.c intrinsics/ctime.c \
|
||||
intrinsics/bit_intrinsics.c intrinsics/c99_functions.c \
|
||||
intrinsics/chdir.c intrinsics/chmod.c intrinsics/clock.c \
|
||||
intrinsics/cpu_time.c intrinsics/cshift0.c intrinsics/ctime.c \
|
||||
intrinsics/date_and_time.c intrinsics/dtime.c intrinsics/env.c \
|
||||
intrinsics/eoshift0.c intrinsics/eoshift2.c \
|
||||
intrinsics/erfc_scaled.c intrinsics/etime.c intrinsics/exit.c \
|
||||
@ -711,9 +711,9 @@ am__objects_35 = close.lo file_pos.lo format.lo inquire.lo \
|
||||
intrinsics.lo list_read.lo lock.lo open.lo read.lo \
|
||||
size_from_kind.lo transfer.lo unit.lo unix.lo write.lo fbuf.lo
|
||||
am__objects_36 = associated.lo abort.lo access.lo args.lo \
|
||||
c99_functions.lo chdir.lo chmod.lo clock.lo cpu_time.lo \
|
||||
cshift0.lo ctime.lo date_and_time.lo dtime.lo env.lo \
|
||||
eoshift0.lo eoshift2.lo erfc_scaled.lo etime.lo exit.lo \
|
||||
bit_intrinsics.lo c99_functions.lo chdir.lo chmod.lo clock.lo \
|
||||
cpu_time.lo cshift0.lo ctime.lo date_and_time.lo dtime.lo \
|
||||
env.lo eoshift0.lo eoshift2.lo erfc_scaled.lo etime.lo exit.lo \
|
||||
fnum.lo gerror.lo getcwd.lo getlog.lo getXid.lo hostnm.lo \
|
||||
ierrno.lo ishftc.lo iso_c_generated_procs.lo iso_c_binding.lo \
|
||||
kill.lo link.lo malloc.lo mvbits.lo move_alloc.lo \
|
||||
@ -990,6 +990,7 @@ intrinsics/associated.c \
|
||||
intrinsics/abort.c \
|
||||
intrinsics/access.c \
|
||||
intrinsics/args.c \
|
||||
intrinsics/bit_intrinsics.c \
|
||||
intrinsics/c99_functions.c \
|
||||
intrinsics/chdir.c \
|
||||
intrinsics/chmod.c \
|
||||
@ -1804,6 +1805,7 @@ distclean-compile:
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/args.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/associated.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/backtrace.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bit_intrinsics.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/c99_functions.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/chdir.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/chmod.Plo@am__quote@
|
||||
@ -5322,6 +5324,13 @@ args.lo: intrinsics/args.c
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o args.lo `test -f 'intrinsics/args.c' || echo '$(srcdir)/'`intrinsics/args.c
|
||||
|
||||
bit_intrinsics.lo: intrinsics/bit_intrinsics.c
|
||||
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT bit_intrinsics.lo -MD -MP -MF "$(DEPDIR)/bit_intrinsics.Tpo" -c -o bit_intrinsics.lo `test -f 'intrinsics/bit_intrinsics.c' || echo '$(srcdir)/'`intrinsics/bit_intrinsics.c; \
|
||||
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/bit_intrinsics.Tpo" "$(DEPDIR)/bit_intrinsics.Plo"; else rm -f "$(DEPDIR)/bit_intrinsics.Tpo"; exit 1; fi
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='intrinsics/bit_intrinsics.c' object='bit_intrinsics.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o bit_intrinsics.lo `test -f 'intrinsics/bit_intrinsics.c' || echo '$(srcdir)/'`intrinsics/bit_intrinsics.c
|
||||
|
||||
c99_functions.lo: intrinsics/c99_functions.c
|
||||
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT c99_functions.lo -MD -MP -MF "$(DEPDIR)/c99_functions.Tpo" -c -o c99_functions.lo `test -f 'intrinsics/c99_functions.c' || echo '$(srcdir)/'`intrinsics/c99_functions.c; \
|
||||
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/c99_functions.Tpo" "$(DEPDIR)/c99_functions.Plo"; else rm -f "$(DEPDIR)/c99_functions.Tpo"; exit 1; fi
|
||||
|
||||
@ -1090,6 +1090,13 @@ GFORTRAN_1.1 {
|
||||
_gfortran_unpack1_char4;
|
||||
} GFORTRAN_1.0;
|
||||
|
||||
|
||||
GFORTRAN_1.2 {
|
||||
global:
|
||||
_gfortran_clz128;
|
||||
_gfortran_ctz128;
|
||||
} GFORTRAN_1.1;
|
||||
|
||||
F2C_1.0 {
|
||||
global:
|
||||
_gfortran_f2c_specific__abs_c4;
|
||||
|
||||
138
libgfortran/intrinsics/bit_intrinsics.c
Normal file
138
libgfortran/intrinsics/bit_intrinsics.c
Normal file
@ -0,0 +1,138 @@
|
||||
/* Implementation of the bit intrinsics not implemented as GCC builtins.
|
||||
Copyright (C) 2009 Free Software Foundation, Inc.
|
||||
|
||||
This file is part of the GNU Fortran runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 3 of the License, or (at your option) any later version.
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
Under Section 7 of GPL version 3, you are granted additional
|
||||
permissions described in the GCC Runtime Library Exception, version
|
||||
3.1, as published by the Free Software Foundation.
|
||||
|
||||
You should have received a copy of the GNU General Public License and
|
||||
a copy of the GCC Runtime Library Exception along with this program;
|
||||
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
||||
<http://www.gnu.org/licenses/>. */
|
||||
|
||||
#include "libgfortran.h"
|
||||
|
||||
|
||||
#ifdef HAVE_GFC_INTEGER_16
|
||||
extern int clz128 (GFC_INTEGER_16);
|
||||
export_proto(clz128);
|
||||
|
||||
int
|
||||
clz128 (GFC_INTEGER_16 x)
|
||||
{
|
||||
int res = 127;
|
||||
|
||||
// We can't write 0xFFFFFFFFFFFFFFFF0000000000000000, so we work around it
|
||||
if (x & ((__uint128_t) 0xFFFFFFFFFFFFFFFF << 64))
|
||||
{
|
||||
res -= 64;
|
||||
x >>= 64;
|
||||
}
|
||||
|
||||
if (x & 0xFFFFFFFF00000000)
|
||||
{
|
||||
res -= 32;
|
||||
x >>= 32;
|
||||
}
|
||||
|
||||
if (x & 0xFFFF0000)
|
||||
{
|
||||
res -= 16;
|
||||
x >>= 16;
|
||||
}
|
||||
|
||||
if (x & 0xFF00)
|
||||
{
|
||||
res -= 8;
|
||||
x >>= 8;
|
||||
}
|
||||
|
||||
if (x & 0xF0)
|
||||
{
|
||||
res -= 4;
|
||||
x >>= 4;
|
||||
}
|
||||
|
||||
if (x & 0xC)
|
||||
{
|
||||
res -= 2;
|
||||
x >>= 2;
|
||||
}
|
||||
|
||||
if (x & 0x2)
|
||||
{
|
||||
res -= 1;
|
||||
x >>= 1;
|
||||
}
|
||||
|
||||
return res;
|
||||
}
|
||||
#endif
|
||||
|
||||
|
||||
#ifdef HAVE_GFC_INTEGER_16
|
||||
extern int ctz128 (GFC_INTEGER_16);
|
||||
export_proto(ctz128);
|
||||
|
||||
int
|
||||
ctz128 (GFC_INTEGER_16 x)
|
||||
{
|
||||
int res = 0;
|
||||
|
||||
if ((x & 0xFFFFFFFFFFFFFFFF) == 0)
|
||||
{
|
||||
res += 64;
|
||||
x >>= 64;
|
||||
}
|
||||
|
||||
if ((x & 0xFFFFFFFF) == 0)
|
||||
{
|
||||
res += 32;
|
||||
x >>= 32;
|
||||
}
|
||||
|
||||
if ((x & 0xFFFF) == 0)
|
||||
{
|
||||
res += 16;
|
||||
x >>= 16;
|
||||
}
|
||||
|
||||
if ((x & 0xFF) == 0)
|
||||
{
|
||||
res += 8;
|
||||
x >>= 8;
|
||||
}
|
||||
|
||||
if ((x & 0xF) == 0)
|
||||
{
|
||||
res += 4;
|
||||
x >>= 4;
|
||||
}
|
||||
|
||||
if ((x & 0x3) == 0)
|
||||
{
|
||||
res += 2;
|
||||
x >>= 2;
|
||||
}
|
||||
|
||||
if ((x & 0x1) == 0)
|
||||
{
|
||||
res += 1;
|
||||
x >>= 1;
|
||||
}
|
||||
|
||||
return res;
|
||||
}
|
||||
#endif
|
||||
Loading…
Reference in New Issue
Block a user