Skip to content

R
riscv-gcc-1
Commit 88a95a11 by Francois-Xavier Coudert Committed by François-Xavier Coudert
Options

re PR fortran/38282 (Bit intrinsics: ILEN and IBCHNG) 

	PR fortran/38282

	* intrinsic.c (add_functions): Add B{G,L}{E,T}, DSHIFT{L,R},
	MASK{L,R}, MERGE_BITS and SHIFT{A,L,R}.
	* gfortran.h: Define ISYM values for above intrinsics.
	* intrinsic.h (gfc_check_bge_bgt_ble_blt, gfc_check_dshift,
	gfc_check_mask, gfc_check_merge_bits, gfc_check_shift,
	gfc_simplify_bge, gfc_simplify_bgt, gfc_simplify_ble,
	gfc_simplify_blt, gfc_simplify_dshiftl, gfc_simplify_dshiftr,
	gfc_simplify_lshift, gfc_simplify_maskl, gfc_simplify_maskr,
	gfc_simplify_merge_bits, gfc_simplify_rshift,
	gfc_simplify_shifta, gfc_simplify_shiftl, gfc_simplify_shiftr,
	gfc_resolve_dshift, gfc_resolve_mask, gfc_resolve_merge_bits,
	gfc_resolve_shift): New prototypes.
	* iresolve.c (gfc_resolve_dshift, gfc_resolve_mask,
	gfc_resolve_merge_bits, gfc_resolve_shift): New functions.
	* check.c (gfc_check_bge_bgt_ble_blt, gfc_check_dshift,
	gfc_check_mask, gfc_check_merge_bits, gfc_check_shift): New
	functions.
	* trans-intrinsic.c (gfc_conv_intrinsic_dshift,
	gfc_conv_intrinsic_bitcomp, gfc_conv_intrinsic_shift,
	gfc_conv_intrinsic_merge_bits, gfc_conv_intrinsic_mask): New
	functions.
	(gfc_conv_intrinsic_function): Call above static functions.
	* intrinsic.texi: Document new intrinsics.
	* simplify.c (gfc_simplify_bge, gfc_simplify_bgt, gfc_simplify_ble,
        gfc_simplify_blt, gfc_simplify_dshiftl, gfc_simplify_dshiftr,
        gfc_simplify_lshift, gfc_simplify_maskl, gfc_simplify_maskr,
        gfc_simplify_merge_bits, gfc_simplify_rshift, 
        gfc_simplify_shifta, gfc_simplify_shiftl, gfc_simplify_shiftr):
	New functions.

	* gfortran.dg/bit_comparison_1.F90: New test.
	* gfortran.dg/leadz_trailz_3.f90: New test.
	* gfortran.dg/masklr_2.F90: New test.
	* gfortran.dg/shiftalr_1.F90: New test.
	* gfortran.dg/merge_bits_2.F90: New test.
	* gfortran.dg/dshift_2.F90: New test.
	* gfortran.dg/bit_comparison_2.F90: New test.
	* gfortran.dg/masklr_1.F90: New test.
	* gfortran.dg/merge_bits_1.F90: New test.
	* gfortran.dg/dshift_1.F90: New test.
	* gfortran.dg/shiftalr_2.F90: New test.

From-SVN: r164021
parent bd72fc7c
Showing with 2277 additions and 46 deletions
gcc/fortran/ChangeLog
2010-09-08 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/38282
* intrinsic.c (add_functions): Add B{G,L}{E,T}, DSHIFT{L,R},
MASK{L,R}, MERGE_BITS and SHIFT{A,L,R}.
* gfortran.h: Define ISYM values for above intrinsics.
* intrinsic.h (gfc_check_bge_bgt_ble_blt, gfc_check_dshift,
gfc_check_mask, gfc_check_merge_bits, gfc_check_shift,
gfc_simplify_bge, gfc_simplify_bgt, gfc_simplify_ble,
gfc_simplify_blt, gfc_simplify_dshiftl, gfc_simplify_dshiftr,
gfc_simplify_lshift, gfc_simplify_maskl, gfc_simplify_maskr,
gfc_simplify_merge_bits, gfc_simplify_rshift,
gfc_simplify_shifta, gfc_simplify_shiftl, gfc_simplify_shiftr,
gfc_resolve_dshift, gfc_resolve_mask, gfc_resolve_merge_bits,
gfc_resolve_shift): New prototypes.
* iresolve.c (gfc_resolve_dshift, gfc_resolve_mask,
gfc_resolve_merge_bits, gfc_resolve_shift): New functions.
* check.c (gfc_check_bge_bgt_ble_blt, gfc_check_dshift,
gfc_check_mask, gfc_check_merge_bits, gfc_check_shift): New
functions.
* trans-intrinsic.c (gfc_conv_intrinsic_dshift,
gfc_conv_intrinsic_bitcomp, gfc_conv_intrinsic_shift,
gfc_conv_intrinsic_merge_bits, gfc_conv_intrinsic_mask): New
functions.
(gfc_conv_intrinsic_function): Call above static functions.
* intrinsic.texi: Document new intrinsics.
* simplify.c (gfc_simplify_bge, gfc_simplify_bgt, gfc_simplify_ble,
gfc_simplify_blt, gfc_simplify_dshiftl, gfc_simplify_dshiftr,
gfc_simplify_lshift, gfc_simplify_maskl, gfc_simplify_maskr,
gfc_simplify_merge_bits, gfc_simplify_rshift,
gfc_simplify_shifta, gfc_simplify_shiftl, gfc_simplify_shiftr):
New functions.
2010-09-08 Jakub Jelinek <jakub@redhat.com>
* frontend-passes.c (optimize_code_node): Walk block chain by default.
......
gcc/fortran/check.c
......@@ -299,11 +299,11 @@ nonnegative_check (const char *arg, gfc_expr *expr)
/* If expr2 is constant, then check that the value is less than
bit_size(expr1). */
(less than or equal to, if 'or_equal' is true) bit_size(expr1). */
static gfc_try
less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
gfc_expr *expr2)
gfc_expr *expr2, bool or_equal)
{
int i2, i3;
......@@ -311,6 +311,18 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
{
gfc_extract_int (expr2, &i2);
i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
if (or_equal)
{
if (i2 > gfc_integer_kinds[i3].bit_size)
{
gfc_error ("'%s' at %L must be less than "
"or equal to BIT_SIZE('%s')",
arg2, &expr2->where, arg1);
return FAILURE;
}
}
else
{
if (i2 >= gfc_integer_kinds[i3].bit_size)
{
gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
......@@ -318,6 +330,32 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
return FAILURE;
}
}
}
return SUCCESS;
}
/* If expr is constant, then check that the value is less than or equal
to the bit_size of the kind k. */
static gfc_try
less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
{
int i, val;
if (expr->expr_type != EXPR_CONSTANT)
return SUCCESS;
i = gfc_validate_kind (BT_INTEGER, k, false);
gfc_extract_int (expr, &val);
if (val > gfc_integer_kinds[i].bit_size)
{
gfc_error ("'%s' at %L must be less than or equal to the BIT_SIZE of "
"INTEGER(KIND=%d)", arg, &expr->where, k);
return FAILURE;
}
return SUCCESS;
}
......@@ -929,6 +967,19 @@ gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
gfc_try
gfc_check_bge_bgt_ble_blt (gfc_expr *i, gfc_expr *j)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (j, 1, BT_INTEGER) == FAILURE)
return FAILURE;
return SUCCESS;
}
gfc_try
gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
......@@ -940,7 +991,7 @@ gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
if (nonnegative_check ("pos", pos) == FAILURE)
return FAILURE;
if (less_than_bitsize1 ("i", i, "pos", pos) == FAILURE)
if (less_than_bitsize1 ("i", i, "pos", pos, false) == FAILURE)
return FAILURE;
return SUCCESS;
......@@ -1317,6 +1368,31 @@ gfc_check_dprod (gfc_expr *x, gfc_expr *y)
gfc_try
gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (j, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (same_type_check (i, 0, j, 1) == FAILURE)
return FAILURE;
if (type_check (shift, 2, BT_INTEGER) == FAILURE)
return FAILURE;
if (nonnegative_check ("SHIFT", shift) == FAILURE)
return FAILURE;
if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
return FAILURE;
return SUCCESS;
}
gfc_try
gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
gfc_expr *dim)
{
......@@ -2356,6 +2432,32 @@ gfc_check_product_sum (gfc_actual_arglist *ap)
/* For IANY, IALL and IPARITY. */
gfc_try
gfc_check_mask (gfc_expr *i, gfc_expr *kind)
{
int k;
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (nonnegative_check ("I", i) == FAILURE)
return FAILURE;
if (kind_check (kind, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (kind)
gfc_extract_int (kind, &k);
else
k = gfc_default_integer_kind;
if (less_than_bitsizekind ("I", i, k) == FAILURE)
return FAILURE;
return SUCCESS;
}
gfc_try
gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
{
if (ap->expr->ts.type != BT_INTEGER)
......@@ -2390,6 +2492,28 @@ gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
gfc_try
gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (j, 1, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (mask, 2, BT_INTEGER) == FAILURE)
return FAILURE;
if (same_type_check (i, 0, j, 1) == FAILURE)
return FAILURE;
if (same_type_check (i, 0, mask, 2) == FAILURE)
return FAILURE;
return SUCCESS;
}
gfc_try
gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
{
if (variable_check (from, 0) == FAILURE)
......@@ -3118,6 +3242,25 @@ gfc_check_shape (gfc_expr *source)
gfc_try
gfc_check_shift (gfc_expr *i, gfc_expr *shift)
{
if (type_check (i, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (type_check (shift, 0, BT_INTEGER) == FAILURE)
return FAILURE;
if (nonnegative_check ("SHIFT", shift) == FAILURE)
return FAILURE;
if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
return FAILURE;
return SUCCESS;
}
gfc_try
gfc_check_sign (gfc_expr *a, gfc_expr *b)
{
if (int_or_real_check (a, 0) == FAILURE)
......
gcc/fortran/gfortran.h
......@@ -331,7 +331,11 @@ enum gfc_isym_id
GFC_ISYM_ATAN,
GFC_ISYM_ATAN2,
GFC_ISYM_ATANH,
GFC_ISYM_BGE,
GFC_ISYM_BGT,
GFC_ISYM_BIT_SIZE,
GFC_ISYM_BLE,
GFC_ISYM_BLT,
GFC_ISYM_BTEST,
GFC_ISYM_CEILING,
GFC_ISYM_CHAR,
......@@ -355,6 +359,8 @@ enum gfc_isym_id
GFC_ISYM_DIM,
GFC_ISYM_DOT_PRODUCT,
GFC_ISYM_DPROD,
GFC_ISYM_DSHIFTL,
GFC_ISYM_DSHIFTR,
GFC_ISYM_DTIME,
GFC_ISYM_EOSHIFT,
GFC_ISYM_EPSILON,
......@@ -449,6 +455,8 @@ enum gfc_isym_id
GFC_ISYM_LSTAT,
GFC_ISYM_LTIME,
GFC_ISYM_MALLOC,
GFC_ISYM_MASKL,
GFC_ISYM_MASKR,
GFC_ISYM_MATMUL,
GFC_ISYM_MAX,
GFC_ISYM_MAXEXPONENT,
......@@ -457,6 +465,7 @@ enum gfc_isym_id
GFC_ISYM_MCLOCK,
GFC_ISYM_MCLOCK8,
GFC_ISYM_MERGE,
GFC_ISYM_MERGE_BITS,
GFC_ISYM_MIN,
GFC_ISYM_MINEXPONENT,
GFC_ISYM_MINLOC,
......@@ -500,6 +509,9 @@ enum gfc_isym_id
GFC_ISYM_SECOND,
GFC_ISYM_SET_EXPONENT,
GFC_ISYM_SHAPE,
GFC_ISYM_SHIFTA,
GFC_ISYM_SHIFTL,
GFC_ISYM_SHIFTR,
GFC_ISYM_SIGN,
GFC_ISYM_SIGNAL,
GFC_ISYM_SI_KIND,
......
gcc/fortran/intrinsic.c
......@@ -1392,12 +1392,40 @@ add_functions (void)
make_generic ("bessel_yn", GFC_ISYM_YN, GFC_STD_F2008);
add_sym_2 ("bge", GFC_ISYM_BGE, CLASS_ELEMENTAL, ACTUAL_NO,
BT_LOGICAL, dl, GFC_STD_F2008,
gfc_check_bge_bgt_ble_blt, gfc_simplify_bge, NULL,
i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
make_generic ("bge", GFC_ISYM_BGE, GFC_STD_F2008);
add_sym_2 ("bgt", GFC_ISYM_BGT, CLASS_ELEMENTAL, ACTUAL_NO,
BT_LOGICAL, dl, GFC_STD_F2008,
gfc_check_bge_bgt_ble_blt, gfc_simplify_bgt, NULL,
i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
make_generic ("bgt", GFC_ISYM_BGT, GFC_STD_F2008);
add_sym_1 ("bit_size", GFC_ISYM_BIT_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
gfc_check_i, gfc_simplify_bit_size, NULL,
i, BT_INTEGER, di, REQUIRED);
make_generic ("bit_size", GFC_ISYM_BIT_SIZE, GFC_STD_F95);
add_sym_2 ("ble", GFC_ISYM_BLE, CLASS_ELEMENTAL, ACTUAL_NO,
BT_LOGICAL, dl, GFC_STD_F2008,
gfc_check_bge_bgt_ble_blt, gfc_simplify_ble, NULL,
i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
make_generic ("ble", GFC_ISYM_BLE, GFC_STD_F2008);
add_sym_2 ("blt", GFC_ISYM_BLT, CLASS_ELEMENTAL, ACTUAL_NO,
BT_LOGICAL, dl, GFC_STD_F2008,
gfc_check_bge_bgt_ble_blt, gfc_simplify_blt, NULL,
i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
make_generic ("blt", GFC_ISYM_BLT, GFC_STD_F2008);
add_sym_2 ("btest", GFC_ISYM_BTEST, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
gfc_check_bitfcn, gfc_simplify_btest, gfc_resolve_btest,
i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
......@@ -1561,10 +1589,28 @@ add_functions (void)
make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU);
add_sym_3 ("dshiftl", GFC_ISYM_DSHIFTL, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
gfc_check_dshift, gfc_simplify_dshiftl, gfc_resolve_dshift,
i, BT_INTEGER, di, REQUIRED,
j, BT_INTEGER, di, REQUIRED,
sh, BT_INTEGER, di, REQUIRED);
make_generic ("dshiftl", GFC_ISYM_DSHIFTL, GFC_STD_F2008);
add_sym_3 ("dshiftr", GFC_ISYM_DSHIFTR, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
gfc_check_dshift, gfc_simplify_dshiftr, gfc_resolve_dshift,
i, BT_INTEGER, di, REQUIRED,
j, BT_INTEGER, di, REQUIRED,
sh, BT_INTEGER, di, REQUIRED);
make_generic ("dshiftr", GFC_ISYM_DSHIFTR, GFC_STD_F2008);
add_sym_4 ("eoshift", GFC_ISYM_EOSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_eoshift, NULL, gfc_resolve_eoshift,
ar, BT_REAL, dr, 0, sh, BT_INTEGER, ii, REQUIRED,
bd, BT_REAL, dr, 1, dm, BT_INTEGER, ii, OPTIONAL);
ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, ii, REQUIRED,
bd, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL);
make_generic ("eoshift", GFC_ISYM_EOSHIFT, GFC_STD_F95);
......@@ -1940,14 +1986,16 @@ add_functions (void)
make_generic ("isnan", GFC_ISYM_ISNAN, GFC_STD_GNU);
add_sym_2 ("rshift", GFC_ISYM_RSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
gfc_check_ishft, NULL, gfc_resolve_rshift,
add_sym_2 ("rshift", GFC_ISYM_RSHIFT, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_GNU,
gfc_check_ishft, gfc_simplify_rshift, gfc_resolve_rshift,
i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
make_generic ("rshift", GFC_ISYM_RSHIFT, GFC_STD_GNU);
add_sym_2 ("lshift", GFC_ISYM_LSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
gfc_check_ishft, NULL, gfc_resolve_lshift,
add_sym_2 ("lshift", GFC_ISYM_LSHIFT, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_GNU,
gfc_check_ishft, gfc_simplify_lshift, gfc_resolve_lshift,
i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
make_generic ("lshift", GFC_ISYM_LSHIFT, GFC_STD_GNU);
......@@ -2120,6 +2168,22 @@ add_functions (void)
make_generic ("malloc", GFC_ISYM_MALLOC, GFC_STD_GNU);
add_sym_2 ("maskl", GFC_ISYM_MASKL, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
gfc_check_mask, gfc_simplify_maskl, gfc_resolve_mask,
i, BT_INTEGER, di, REQUIRED,
kind, BT_INTEGER, di, OPTIONAL);
make_generic ("maskl", GFC_ISYM_MASKL, GFC_STD_F2008);
add_sym_2 ("maskr", GFC_ISYM_MASKR, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
gfc_check_mask, gfc_simplify_maskr, gfc_resolve_mask,
i, BT_INTEGER, di, REQUIRED,
kind, BT_INTEGER, di, OPTIONAL);
make_generic ("maskr", GFC_ISYM_MASKR, GFC_STD_F2008);
add_sym_2 ("matmul", GFC_ISYM_MATMUL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_matmul, gfc_simplify_matmul, gfc_resolve_matmul,
ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED);
......@@ -2192,6 +2256,16 @@ add_functions (void)
make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95);
add_sym_3 ("merge_bits", GFC_ISYM_MERGE_BITS, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
gfc_check_merge_bits, gfc_simplify_merge_bits,
gfc_resolve_merge_bits,
i, BT_INTEGER, di, REQUIRED,
j, BT_INTEGER, di, REQUIRED,
msk, BT_INTEGER, di, REQUIRED);
make_generic ("merge_bits", GFC_ISYM_MERGE_BITS, GFC_STD_F2008);
/* Note: amin0 is equivalent to real(min), min1 is equivalent to
int(min). */
......@@ -2491,6 +2565,30 @@ add_functions (void)
make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95);
add_sym_2 ("shifta", GFC_ISYM_SHIFTA, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
gfc_check_shift, gfc_simplify_shifta, gfc_resolve_shift,
i, BT_INTEGER, di, REQUIRED,
sh, BT_INTEGER, di, REQUIRED);
make_generic ("shifta", GFC_ISYM_SHIFTA, GFC_STD_F2008);
add_sym_2 ("shiftl", GFC_ISYM_SHIFTL, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
gfc_check_shift, gfc_simplify_shiftl, gfc_resolve_shift,
i, BT_INTEGER, di, REQUIRED,
sh, BT_INTEGER, di, REQUIRED);
make_generic ("shiftl", GFC_ISYM_SHIFTL, GFC_STD_F2008);
add_sym_2 ("shiftr", GFC_ISYM_SHIFTR, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
gfc_check_shift, gfc_simplify_shiftr, gfc_resolve_shift,
i, BT_INTEGER, di, REQUIRED,
sh, BT_INTEGER, di, REQUIRED);
make_generic ("shiftr", GFC_ISYM_SHIFTR, GFC_STD_F2008);
add_sym_2 ("sign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign,
a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED);
......
gcc/fortran/intrinsic.h
......@@ -41,6 +41,7 @@ gfc_try gfc_check_atan_2 (gfc_expr *, gfc_expr *);
gfc_try gfc_check_atan2 (gfc_expr *, gfc_expr *);
gfc_try gfc_check_besn (gfc_expr *, gfc_expr *);
gfc_try gfc_check_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_bge_bgt_ble_blt (gfc_expr *, gfc_expr *);
gfc_try gfc_check_bitfcn (gfc_expr *, gfc_expr *);
gfc_try gfc_check_char (gfc_expr *, gfc_expr *);
gfc_try gfc_check_chdir (gfc_expr *);
......@@ -56,6 +57,7 @@ gfc_try gfc_check_dble (gfc_expr *);
gfc_try gfc_check_digits (gfc_expr *);
gfc_try gfc_check_dot_product (gfc_expr *, gfc_expr *);
gfc_try gfc_check_dprod (gfc_expr *, gfc_expr *);
gfc_try gfc_check_dshift (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_dtime_etime (gfc_expr *);
gfc_try gfc_check_fgetputc (gfc_expr *, gfc_expr *);
......@@ -102,8 +104,10 @@ gfc_try gfc_check_min_max_integer (gfc_actual_arglist *);
gfc_try gfc_check_min_max_real (gfc_actual_arglist *);
gfc_try gfc_check_min_max_double (gfc_actual_arglist *);
gfc_try gfc_check_malloc (gfc_expr *);
gfc_try gfc_check_mask (gfc_expr *, gfc_expr *);
gfc_try gfc_check_matmul (gfc_expr *, gfc_expr *);
gfc_try gfc_check_merge (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_minloc_maxloc (gfc_actual_arglist *);
gfc_try gfc_check_minval_maxval (gfc_actual_arglist *);
gfc_try gfc_check_nearest (gfc_expr *, gfc_expr *);
......@@ -132,6 +136,7 @@ gfc_try gfc_check_selected_int_kind (gfc_expr *);
gfc_try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_set_exponent (gfc_expr *, gfc_expr *);
gfc_try gfc_check_shape (gfc_expr *);
gfc_try gfc_check_shift (gfc_expr *, gfc_expr *);
gfc_try gfc_check_size (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_sign (gfc_expr *, gfc_expr *);
gfc_try gfc_check_signal (gfc_expr *, gfc_expr *);
......@@ -232,7 +237,11 @@ gfc_expr *gfc_simplify_bessel_y0 (gfc_expr *);
gfc_expr *gfc_simplify_bessel_y1 (gfc_expr *);
gfc_expr *gfc_simplify_bessel_yn (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_bessel_yn2 (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_bge (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_bgt (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_bit_size (gfc_expr *);
gfc_expr *gfc_simplify_ble (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_blt (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_btest (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ceiling (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_char (gfc_expr *, gfc_expr *);
......@@ -248,6 +257,8 @@ gfc_expr *gfc_simplify_digits (gfc_expr *);
gfc_expr *gfc_simplify_dim (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_dprod (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_dot_product (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_dshiftl (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_dshiftr (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_epsilon (gfc_expr *);
gfc_expr *gfc_simplify_erf (gfc_expr *);
gfc_expr *gfc_simplify_erfc (gfc_expr *);
......@@ -298,8 +309,12 @@ gfc_expr *gfc_simplify_llt (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_log (gfc_expr *);
gfc_expr *gfc_simplify_log10 (gfc_expr *);
gfc_expr *gfc_simplify_logical (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_lshift (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_matmul (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_maskl (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_maskr (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_merge (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_min (gfc_expr *);
gfc_expr *gfc_simplify_minval (gfc_expr *, gfc_expr*, gfc_expr*);
gfc_expr *gfc_simplify_max (gfc_expr *);
......@@ -333,6 +348,7 @@ gfc_expr *gfc_simplify_repeat (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_reshape (gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
gfc_expr *gfc_simplify_rrspacing (gfc_expr *);
gfc_expr *gfc_simplify_rshift (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_scale (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_selected_char_kind (gfc_expr *);
......@@ -341,6 +357,9 @@ gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_set_exponent (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_sign (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_shape (gfc_expr *);
gfc_expr *gfc_simplify_shifta (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_shiftl (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_shiftr (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_sin (gfc_expr *);
gfc_expr *gfc_simplify_sinh (gfc_expr *);
gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *, gfc_expr *);
......@@ -409,6 +428,7 @@ void gfc_resolve_dble (gfc_expr *, gfc_expr *);
void gfc_resolve_dim (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_dot_product (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_dprod (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_dshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_dtime_sub (gfc_code *);
void gfc_resolve_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
......@@ -478,7 +498,9 @@ void gfc_resolve_maxloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_maxval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_mclock (gfc_expr *);
void gfc_resolve_mclock8 (gfc_expr *);
void gfc_resolve_mask (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_merge (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_min (gfc_expr *, gfc_actual_arglist *);
void gfc_resolve_minloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_minval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
......@@ -506,6 +528,7 @@ void gfc_resolve_second_sub (gfc_code *);
void gfc_resolve_secnds (gfc_expr *, gfc_expr *);
void gfc_resolve_set_exponent (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_shape (gfc_expr *, gfc_expr *);
void gfc_resolve_shift (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_sign (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_signal (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_sin (gfc_expr *, gfc_expr *);
......
gcc/fortran/intrinsic.texi
......@@ -67,7 +67,11 @@ Some basic guidelines for editing this document:
* @code{BESSEL_Y0}: BESSEL_Y0, Bessel function of the second kind of order 0
* @code{BESSEL_Y1}: BESSEL_Y1, Bessel function of the second kind of order 1
* @code{BESSEL_YN}: BESSEL_YN, Bessel function of the second kind
* @code{BGE}: BGE, Bitwise greater than or equal to
* @code{BGT}: BGT, Bitwise greater than
* @code{BIT_SIZE}: BIT_SIZE, Bit size inquiry function
* @code{BLE}: BLE, Bitwise less than or equal to
* @code{BLT}: BLT, Bitwise less than
* @code{BTEST}: BTEST, Bit test function
* @code{C_ASSOCIATED}: C_ASSOCIATED, Status of a C pointer
* @code{C_F_POINTER}: C_F_POINTER, Convert C into Fortran pointer
......@@ -97,6 +101,8 @@ Some basic guidelines for editing this document:
* @code{DOT_PRODUCT}: DOT_PRODUCT, Dot product function
* @code{DPROD}: DPROD, Double product function
* @code{DREAL}: DREAL, Double real part function
* @code{DSHIFTL}: DSHIFTL, Combined left shift
* @code{DSHIFTR}: DSHIFTR, Combined right shift
* @code{DTIME}: DTIME, Execution time subroutine (or function)
* @code{EOSHIFT}: EOSHIFT, End-off shift elements of an array
* @code{EPSILON}: EPSILON, Epsilon function
......@@ -188,6 +194,8 @@ Some basic guidelines for editing this document:
* @code{LSTAT}: LSTAT, Get file status
* @code{LTIME}: LTIME, Convert time to local time info
* @code{MALLOC}: MALLOC, Dynamic memory allocation function
* @code{MASKL}: MASKL, Left justified mask
* @code{MASKR}: MASKR, Right justified mask
* @code{MATMUL}: MATMUL, matrix multiplication
* @code{MAX}: MAX, Maximum value of an argument list
* @code{MAXEXPONENT}: MAXEXPONENT, Maximum exponent of a real kind
......@@ -196,6 +204,7 @@ Some basic guidelines for editing this document:
* @code{MCLOCK}: MCLOCK, Time function
* @code{MCLOCK8}: MCLOCK8, Time function (64-bit)
* @code{MERGE}: MERGE, Merge arrays
* @code{MERGE_BITS}: MERGE_BITS, Merge of bits under mask
* @code{MIN}: MIN, Minimum value of an argument list
* @code{MINEXPONENT}: MINEXPONENT, Minimum exponent of a real kind
* @code{MINLOC}: MINLOC, Location of the minimum value within an array
......@@ -242,6 +251,9 @@ Some basic guidelines for editing this document:
* @code{SELECTED_REAL_KIND}: SELECTED_REAL_KIND, Choose real kind
* @code{SET_EXPONENT}: SET_EXPONENT, Set the exponent of the model
* @code{SHAPE}: SHAPE, Determine the shape of an array
* @code{SHIFTA}: SHIFTA, Right shift with fill
* @code{SHIFTL}: SHIFTL, Left shift
* @code{SHIFTR}: SHIFTR, Right shift
* @code{SIGN}: SIGN, Sign copying function
* @code{SIGNAL}: SIGNAL, Signal handling subroutine (or function)
* @code{SIN}: SIN, Sine function
......@@ -1851,6 +1863,75 @@ end program test_besyn
@node BGE
@section @code{BGE} --- Bitwise greater than or equal to
@fnindex BGE
@cindex bitwise comparison
@table @asis
@item @emph{Description}:
Determines whether an integral is a bitwise greater than or equal to
another.
@item @emph{Standard}:
Fortran 2008 and later
@item @emph{Class}:
Elemental function
@item @emph{Syntax}:
@code{RESULT = BGE(I, J)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{I} @tab Shall be of @code{INTEGER} type.
@item @var{J} @tab Shall be of @code{INTEGER} type, and of the same kind
as @var{I}.
@end multitable
@item @emph{Return value}:
The return value is of type @code{LOGICAL} and of the default kind.
@item @emph{See also}:
@ref{BGT}, @ref{BLE}, @ref{BLT}
@end table
@node BGT
@section @code{BGT} --- Bitwise greater than
@fnindex BGT
@cindex bitwise comparison
@table @asis
@item @emph{Description}:
Determines whether an integral is a bitwise greater than another.
@item @emph{Standard}:
Fortran 2008 and later
@item @emph{Class}:
Elemental function
@item @emph{Syntax}:
@code{RESULT = BGT(I, J)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{I} @tab Shall be of @code{INTEGER} type.
@item @var{J} @tab Shall be of @code{INTEGER} type, and of the same kind
as @var{I}.
@end multitable
@item @emph{Return value}:
The return value is of type @code{LOGICAL} and of the default kind.
@item @emph{See also}:
@ref{BGE}, @ref{BLE}, @ref{BLT}
@end table
@node BIT_SIZE
@section @code{BIT_SIZE} --- Bit size inquiry function
@fnindex BIT_SIZE
......@@ -1893,6 +1974,75 @@ end program test_bit_size
@node BLE
@section @code{BLE} --- Bitwise less than or equal to
@fnindex BLE
@cindex bitwise comparison
@table @asis
@item @emph{Description}:
Determines whether an integral is a bitwise less than or equal to
another.
@item @emph{Standard}:
Fortran 2008 and later
@item @emph{Class}:
Elemental function
@item @emph{Syntax}:
@code{RESULT = BLE(I, J)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{I} @tab Shall be of @code{INTEGER} type.
@item @var{J} @tab Shall be of @code{INTEGER} type, and of the same kind
as @var{I}.
@end multitable
@item @emph{Return value}:
The return value is of type @code{LOGICAL} and of the default kind.
@item @emph{See also}:
@ref{BGT}, @ref{BGE}, @ref{BLT}
@end table
@node BLT
@section @code{BLT} --- Bitwise less than
@fnindex BLT
@cindex bitwise comparison
@table @asis
@item @emph{Description}:
Determines whether an integral is a bitwise less than another.
@item @emph{Standard}:
Fortran 2008 and later
@item @emph{Class}:
Elemental function
@item @emph{Syntax}:
@code{RESULT = BLT(I, J)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{I} @tab Shall be of @code{INTEGER} type.
@item @var{J} @tab Shall be of @code{INTEGER} type, and of the same kind
as @var{I}.
@end multitable
@item @emph{Return value}:
The return value is of type @code{LOGICAL} and of the default kind.
@item @emph{See also}:
@ref{BGE}, @ref{BGT}, @ref{BLE}
@end table
@node BTEST
@section @code{BTEST} --- Bit test function
@fnindex BTEST
......@@ -3424,6 +3574,86 @@ end program test_dreal
@node DSHIFTL
@section @code{DSHIFTL} --- Combined left shift
@fnindex DSHIFTL
@cindex left shift, combined
@cindex shift, left
@table @asis
@item @emph{Description}:
@code{DSHIFTL(I, J, SHIFT)} combines bits of @var{I} and @var{J}. The
rightmost @var{SHIFT} bits of the result are the leftmost @var{SHIFT}
bits of @var{J}, and the remaining bits are the rightmost bits of
@var{I}.
@item @emph{Standard}:
Fortran 2008 and later
@item @emph{Class}:
Elemental function
@item @emph{Syntax}:
@code{RESULT = DSHIFTL(I, J, SHIFT)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{I} @tab Shall be of type @code{INTEGER}.
@item @var{J} @tab Shall be of type @code{INTEGER}, and of the same kind
as @var{I}.
@item @var{SHIFT} @tab Shall be of type @code{INTEGER}.
@end multitable
@item @emph{Return value}:
The return value has same type and kind as @var{I}.
@item @emph{See also}:
@ref{DSHIFTR}
@end table
@node DSHIFTR
@section @code{DSHIFTR} --- Combined right shift
@fnindex DSHIFTR
@cindex right shift, combined
@cindex shift, right
@table @asis
@item @emph{Description}:
@code{DSHIFTR(I, J, SHIFT)} combines bits of @var{I} and @var{J}. The
leftmost @var{SHIFT} bits of the result are the rightmost @var{SHIFT}
bits of @var{I}, and the remaining bits are the leftmost bits of
@var{J}.
@item @emph{Standard}:
Fortran 2008 and later
@item @emph{Class}:
Elemental function
@item @emph{Syntax}:
@code{RESULT = DSHIFTR(I, J, SHIFT)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{I} @tab Shall be of type @code{INTEGER}.
@item @var{J} @tab Shall be of type @code{INTEGER}, and of the same kind
as @var{I}.
@item @var{SHIFT} @tab Shall be of type @code{INTEGER}.
@end multitable
@item @emph{Return value}:
The return value has same type and kind as @var{I}.
@item @emph{See also}:
@ref{DSHIFTL}
@end table
@node DTIME
@section @code{DTIME} --- Execution time subroutine (or function)
@fnindex DTIME
......@@ -7644,7 +7874,8 @@ Bits shifted out from the left end are lost; zeros are shifted in from
the opposite end.
This function has been superseded by the @code{ISHFT} intrinsic, which
is standard in Fortran 95 and later.
is standard in Fortran 95 and later, and the @code{SHIFTL} intrinsic,
which is standard in Fortran 2008 and later.
@item @emph{Standard}:
GNU extension
......@@ -7666,7 +7897,8 @@ The return value is of type @code{INTEGER} and of the same kind as
@var{I}.
@item @emph{See also}:
@ref{ISHFT}, @ref{ISHFTC}, @ref{RSHIFT}
@ref{ISHFT}, @ref{ISHFTC}, @ref{RSHIFT}, @ref{SHIFTA}, @ref{SHIFTL},
@ref{SHIFTR}
@end table
......@@ -7829,6 +8061,80 @@ end program test_malloc
@node MASKL
@section @code{MASKL} --- Left justified mask
@fnindex MASKL
@cindex mask, left justified
@table @asis
@item @emph{Description}:
@code{MASKL(I[, KIND])} has its leftmost @var{I} bits set to 1, and the
remaining bits set to 0.
@item @emph{Standard}:
Fortran 2008 and later
@item @emph{Class}:
Elemental function
@item @emph{Syntax}:
@code{RESULT = MASKL(I[, KIND])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{I} @tab Shall be of type @code{INTEGER}.
@item @var{KIND} @tab Shall be a scalar constant expression of type
@code{INTEGER}.
@end multitable
@item @emph{Return value}:
The return value is of type @code{INTEGER}. If @var{KIND} is present, it
specifies the kind value of the return type; otherwise, it is of the
default integer kind.
@item @emph{See also}:
@ref{MASKR}
@end table
@node MASKR
@section @code{MASKR} --- Right justified mask
@fnindex MASKR
@cindex mask, right justified
@table @asis
@item @emph{Description}:
@code{MASKL(I[, KIND])} has its rightmost @var{I} bits set to 1, and the
remaining bits set to 0.
@item @emph{Standard}:
Fortran 2008 and later
@item @emph{Class}:
Elemental function
@item @emph{Syntax}:
@code{RESULT = MASKR(I[, KIND])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{I} @tab Shall be of type @code{INTEGER}.
@item @var{KIND} @tab Shall be a scalar constant expression of type
@code{INTEGER}.
@end multitable
@item @emph{Return value}:
The return value is of type @code{INTEGER}. If @var{KIND} is present, it
specifies the kind value of the return type; otherwise, it is of the
default integer kind.
@item @emph{See also}:
@ref{MASKL}
@end table
@node MATMUL
@section @code{MATMUL} --- matrix multiplication
@fnindex MATMUL
......@@ -8190,6 +8496,43 @@ The result is of the same type and type parameters as @var{TSOURCE}.
@node MERGE_BITS
@section @code{MERGE_BITS} --- Merge of bits under mask
@fnindex MERGE_BITS
@cindex bits, merge
@table @asis
@item @emph{Description}:
@code{MERGE_BITS(I, J, MASK)} merges the bits of @var{I} and @var{J}
as determined by the mask. The i-th bit of the result is equal to the
i-th bit of @var{I} if the i-th bit of @var{MASK} is 1; it is equal to
the i-th bit of @var{J} otherwise.
@item @emph{Standard}:
Fortran 2008 and later
@item @emph{Class}:
Elemental function
@item @emph{Syntax}:
@code{RESULT = MERGE_BITS(I, J, MASK)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{I} @tab Shall be of type @code{INTEGER}.
@item @var{J} @tab Shall be of type @code{INTEGER} and of the same
kind as @var{I}.
@item @var{MASK} @tab Shall be of type @code{INTEGER} and of the same
kind as @var{I}.
@end multitable
@item @emph{Return value}:
The result is of the same type and kind as @var{I}.
@end table
@node MIN
@section @code{MIN} --- Minimum value of an argument list
@fnindex MIN
......@@ -9895,8 +10238,8 @@ Bits shifted out from the right end are lost. The fill is arithmetic: the
bits shifted in from the left end are equal to the leftmost bit, which in
two's complement representation is the sign bit.
This function has been superseded by the @code{ISHFT} intrinsic, which
is standard in Fortran 95 and later.
This function has been superseded by the @code{SHIFTA} intrinsic, which
is standard in Fortran 2008 and later.
@item @emph{Standard}:
GNU extension
......@@ -9918,7 +10261,8 @@ The return value is of type @code{INTEGER} and of the same kind as
@var{I}.
@item @emph{See also}:
@ref{ISHFT}, @ref{ISHFTC}, @ref{LSHIFT}
@ref{ISHFT}, @ref{ISHFTC}, @ref{LSHIFT}, @ref{SHIFTA}, @ref{SHIFTR},
@ref{SHIFTL}
@end table
......@@ -10415,6 +10759,124 @@ END PROGRAM
@node SHIFTA
@section @code{SHIFTA} --- Right shift with fill
@fnindex SHIFTA
@cindex bits, shift right
@cindex shift, right with fill
@table @asis
@item @emph{Description}:
@code{SHIFTA} returns a value corresponding to @var{I} with all of the
bits shifted right by @var{SHIFT} places. If the absolute value of
@var{SHIFT} is greater than @code{BIT_SIZE(I)}, the value is undefined.
Bits shifted out from the right end are lost. The fill is arithmetic: the
bits shifted in from the left end are equal to the leftmost bit, which in
two's complement representation is the sign bit.
@item @emph{Standard}:
Fortran 2008 and later
@item @emph{Class}:
Elemental function
@item @emph{Syntax}:
@code{RESULT = SHIFTA(I, SHIFT)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{I} @tab The type shall be @code{INTEGER}.
@item @var{SHIFT} @tab The type shall be @code{INTEGER}.
@end multitable
@item @emph{Return value}:
The return value is of type @code{INTEGER} and of the same kind as
@var{I}.
@item @emph{See also}:
@ref{SHIFTL}, @ref{SHIFTR}
@end table
@node SHIFTL
@section @code{SHIFTL} --- Left shift
@fnindex SHIFTL
@cindex bits, shift left
@cindex shift, left
@table @asis
@item @emph{Description}:
@code{SHIFTL} returns a value corresponding to @var{I} with all of the
bits shifted left by @var{SHIFT} places. If the absolute value of
@var{SHIFT} is greater than @code{BIT_SIZE(I)}, the value is undefined.
Bits shifted out from the left end are lost, and bits shifted in from
the right end are set to 0.
@item @emph{Standard}:
Fortran 2008 and later
@item @emph{Class}:
Elemental function
@item @emph{Syntax}:
@code{RESULT = SHIFTL(I, SHIFT)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{I} @tab The type shall be @code{INTEGER}.
@item @var{SHIFT} @tab The type shall be @code{INTEGER}.
@end multitable
@item @emph{Return value}:
The return value is of type @code{INTEGER} and of the same kind as
@var{I}.
@item @emph{See also}:
@ref{SHIFTA}, @ref{SHIFTR}
@end table
@node SHIFTR
@section @code{SHIFTR} --- Right shift
@fnindex SHIFTR
@cindex bits, shift right
@cindex shift, right
@table @asis
@item @emph{Description}:
@code{SHIFTR} returns a value corresponding to @var{I} with all of the
bits shifted right by @var{SHIFT} places. If the absolute value of
@var{SHIFT} is greater than @code{BIT_SIZE(I)}, the value is undefined.
Bits shifted out from the right end are lost, and bits shifted in from
the left end are set to 0.
@item @emph{Standard}:
Fortran 2008 and later
@item @emph{Class}:
Elemental function
@item @emph{Syntax}:
@code{RESULT = SHIFTR(I, SHIFT)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{I} @tab The type shall be @code{INTEGER}.
@item @var{SHIFT} @tab The type shall be @code{INTEGER}.
@end multitable
@item @emph{Return value}:
The return value is of type @code{INTEGER} and of the same kind as
@var{I}.
@item @emph{See also}:
@ref{SHIFTA}, @ref{SHIFTL}
@end table
@node SIGN
@section @code{SIGN} --- Sign copying function
@fnindex SIGN
......
gcc/fortran/iresolve.c
......@@ -825,6 +825,20 @@ gfc_resolve_dprod (gfc_expr *f, gfc_expr *a ATTRIBUTE_UNUSED,
void
gfc_resolve_dshift (gfc_expr *f, gfc_expr *i, gfc_expr *j ATTRIBUTE_UNUSED,
gfc_expr *shift ATTRIBUTE_UNUSED)
{
f->ts = i->ts;
if (f->value.function.isym->id == GFC_ISYM_DSHIFTL)
f->value.function.name = gfc_get_string ("dshiftl_i%d", f->ts.kind);
else if (f->value.function.isym->id == GFC_ISYM_DSHIFTR)
f->value.function.name = gfc_get_string ("dshiftr_i%d", f->ts.kind);
else
gcc_unreachable ();
}
void
gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
gfc_expr *boundary, gfc_expr *dim)
{
......@@ -1689,6 +1703,21 @@ gfc_resolve_mclock8 (gfc_expr *f)
void
gfc_resolve_mask (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
gfc_expr *kind)
{
f->ts.type = BT_INTEGER;
f->ts.kind = kind ? mpz_get_si (kind->value.integer)
: gfc_default_integer_kind;
if (f->value.function.isym->id == GFC_ISYM_MASKL)
f->value.function.name = gfc_get_string ("__maskl_i%d", f->ts.kind);
else
f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind);
}
void
gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
gfc_expr *fsource ATTRIBUTE_UNUSED,
gfc_expr *mask ATTRIBUTE_UNUSED)
......@@ -1710,6 +1739,16 @@ gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
void
gfc_resolve_merge_bits (gfc_expr *f, gfc_expr *i,
gfc_expr *j ATTRIBUTE_UNUSED,
gfc_expr *mask ATTRIBUTE_UNUSED)
{
f->ts = i->ts;
f->value.function.name = gfc_get_string ("__merge_bits_i%d", i->ts.kind);
}
void
gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args)
{
gfc_resolve_minmax ("__min_%c%d", f, args);
......@@ -2158,6 +2197,21 @@ gfc_resolve_shape (gfc_expr *f, gfc_expr *array)
void
gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED)
{
f->ts = i->ts;
if (f->value.function.isym->id == GFC_ISYM_SHIFTA)
f->value.function.name = gfc_get_string ("shifta_i%d", f->ts.kind);
else if (f->value.function.isym->id == GFC_ISYM_SHIFTL)
f->value.function.name = gfc_get_string ("shiftl_i%d", f->ts.kind);
else if (f->value.function.isym->id == GFC_ISYM_SHIFTR)
f->value.function.name = gfc_get_string ("shiftr_i%d", f->ts.kind);
else
gcc_unreachable ();
}
void
gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED)
{
f->ts = a->ts;
......
gcc/fortran/simplify.c
......@@ -1464,6 +1464,74 @@ gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
}
static int
compare_bitwise (gfc_expr *i, gfc_expr *j)
{
mpz_t x, y;
int k, res;
gcc_assert (i->ts.type == BT_INTEGER);
gcc_assert (j->ts.type == BT_INTEGER);
mpz_init_set (x, i->value.integer);
k = gfc_validate_kind (i->ts.type, i->ts.kind, false);
convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
mpz_init_set (y, j->value.integer);
k = gfc_validate_kind (j->ts.type, j->ts.kind, false);
convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size);
res = mpz_cmp (x, y);
mpz_clear (x);
mpz_clear (y);
return res;
}
gfc_expr *
gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
{
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
return NULL;
return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
compare_bitwise (i, j) >= 0);
}
gfc_expr *
gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
{
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
return NULL;
return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
compare_bitwise (i, j) > 0);
}
gfc_expr *
gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
{
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
return NULL;
return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
compare_bitwise (i, j) <= 0);
}
gfc_expr *
gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
{
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
return NULL;
return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
compare_bitwise (i, j) < 0);
}
gfc_expr *
gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
{
......@@ -1814,6 +1882,64 @@ gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
}
static gfc_expr *
simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
bool right)
{
gfc_expr *result;
int i, k, size, shift;
if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
|| shiftarg->expr_type != EXPR_CONSTANT)
return NULL;
k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
size = gfc_integer_kinds[k].bit_size;
if (gfc_extract_int (shiftarg, &shift) != NULL)
{
gfc_error ("Invalid SHIFT argument of DSHIFTL at %L", &shiftarg->where);
return &gfc_bad_expr;
}
gcc_assert (shift >= 0 && shift <= size);
/* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
if (right)
shift = size - shift;
result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
mpz_set_ui (result->value.integer, 0);
for (i = 0; i < shift; i++)
if (mpz_tstbit (arg2->value.integer, size - shift + i))
mpz_setbit (result->value.integer, i);
for (i = 0; i < size - shift; i++)
if (mpz_tstbit (arg1->value.integer, i))
mpz_setbit (result->value.integer, shift + i);
/* Convert to a signed value. */
convert_mpz_to_signed (result->value.integer, size);
return result;
}
gfc_expr *
gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
{
return simplify_dshift (arg1, arg2, shiftarg, true);
}
gfc_expr *
gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
{
return simplify_dshift (arg1, arg2, shiftarg, false);
}
gfc_expr *
gfc_simplify_erf (gfc_expr *x)
{
......@@ -2776,56 +2902,75 @@ gfc_simplify_isnan (gfc_expr *x)
}
gfc_expr *
gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
/* Performs a shift on its first argument. Depending on the last
argument, the shift can be arithmetic, i.e. with filling from the
left like in the SHIFTA intrinsic. */
static gfc_expr *
simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
bool arithmetic, int direction)
{
gfc_expr *result;
int shift, ashift, isize, k, *bits, i;
int ashift, *bits, i, k, bitsize, shift;
if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
return NULL;
if (gfc_extract_int (s, &shift) != NULL)
{
gfc_error ("Invalid second argument of ISHFT at %L", &s->where);
gfc_error ("Invalid second argument of %s at %L", name, &s->where);
return &gfc_bad_expr;
}
k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
bitsize = gfc_integer_kinds[k].bit_size;
isize = gfc_integer_kinds[k].bit_size;
result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
if (shift >= 0)
ashift = shift;
else
ashift = -shift;
if (shift == 0)
{
mpz_set (result->value.integer, e->value.integer);
return result;
}
if (ashift > isize)
if (direction > 0 && shift < 0)
{
/* Left shift, as in SHIFTL. */
gfc_error ("Second argument of %s is negative at %L", name, &e->where);
return &gfc_bad_expr;
}
else if (direction < 0)
{
/* Right shift, as in SHIFTR or SHIFTA. */
if (shift < 0)
{
gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
"at %L", &s->where);
gfc_error ("Second argument of %s is negative at %L",
name, &e->where);
return &gfc_bad_expr;
}
result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
shift = -shift;
}
if (shift == 0)
ashift = (shift >= 0 ? shift : -shift);
if (ashift > bitsize)
{
mpz_set (result->value.integer, e->value.integer);
return range_check (result, "ISHFT");
gfc_error ("Magnitude of second argument of %s exceeds bit size "
"at %L", name, &e->where);
return &gfc_bad_expr;
}
bits = XCNEWVEC (int, isize);
bits = XCNEWVEC (int, bitsize);
for (i = 0; i < isize; i++)
for (i = 0; i < bitsize; i++)
bits[i] = mpz_tstbit (e->value.integer, i);
if (shift > 0)
{
/* Left shift. */
for (i = 0; i < shift; i++)
mpz_clrbit (result->value.integer, i);
for (i = 0; i < isize - shift; i++)
for (i = 0; i < bitsize - shift; i++)
{
if (bits[i] == 0)
mpz_clrbit (result->value.integer, i + shift);
......@@ -2835,10 +2980,15 @@ gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
}
else
{
for (i = isize - 1; i >= isize - ashift; i--)
/* Right shift. */
if (arithmetic && bits[bitsize - 1])
for (i = bitsize - 1; i >= bitsize - ashift; i--)
mpz_setbit (result->value.integer, i);
else
for (i = bitsize - 1; i >= bitsize - ashift; i--)
mpz_clrbit (result->value.integer, i);
for (i = isize - 1; i >= ashift; i--)
for (i = bitsize - 1; i >= ashift; i--)
{
if (bits[i] == 0)
mpz_clrbit (result->value.integer, i - ashift);
......@@ -2847,14 +2997,56 @@ gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
}
}
convert_mpz_to_signed (result->value.integer, isize);
convert_mpz_to_signed (result->value.integer, bitsize);
gfc_free (bits);
return result;
}
gfc_expr *
gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
{
return simplify_shift (e, s, "ISHFT", false, 0);
}
gfc_expr *
gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
{
return simplify_shift (e, s, "LSHIFT", false, 1);
}
gfc_expr *
gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
{
return simplify_shift (e, s, "RSHIFT", true, -1);
}
gfc_expr *
gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
{
return simplify_shift (e, s, "SHIFTA", true, -1);
}
gfc_expr *
gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
{
return simplify_shift (e, s, "SHIFTL", false, 1);
}
gfc_expr *
gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
{
return simplify_shift (e, s, "SHIFTR", false, -1);
}
gfc_expr *
gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
{
gfc_expr *result;
......@@ -3657,6 +3849,73 @@ gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
gfc_expr *
gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
{
gfc_expr *result;
int kind, arg, k;
const char *s;
if (i->expr_type != EXPR_CONSTANT)
return NULL;
kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
if (kind == -1)
return &gfc_bad_expr;
k = gfc_validate_kind (BT_INTEGER, kind, false);
s = gfc_extract_int (i, &arg);
gcc_assert (!s);
result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
/* MASKR(n) = 2^n - 1 */
mpz_set_ui (result->value.integer, 1);
mpz_mul_2exp (result->value.integer, result->value.integer, arg);
mpz_sub_ui (result->value.integer, result->value.integer, 1);
convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
return result;
}
gfc_expr *
gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
{
gfc_expr *result;
int kind, arg, k;
const char *s;
mpz_t z;
if (i->expr_type != EXPR_CONSTANT)
return NULL;
kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
if (kind == -1)
return &gfc_bad_expr;
k = gfc_validate_kind (BT_INTEGER, kind, false);
s = gfc_extract_int (i, &arg);
gcc_assert (!s);
result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
/* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
mpz_init_set_ui (z, 1);
mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
mpz_set_ui (result->value.integer, 1);
mpz_mul_2exp (result->value.integer, result->value.integer,
gfc_integer_kinds[k].bit_size - arg);
mpz_sub (result->value.integer, z, result->value.integer);
mpz_clear (z);
convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
return result;
}
gfc_expr *
gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
{
if (tsource->expr_type != EXPR_CONSTANT
......@@ -3668,7 +3927,38 @@ gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
}
/* Selects bewteen current value and extremum for simplify_min_max
gfc_expr *
gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
{
mpz_t arg1, arg2, mask;
gfc_expr *result;
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
|| mask_expr->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
/* Convert all argument to unsigned. */
mpz_init_set (arg1, i->value.integer);
mpz_init_set (arg2, j->value.integer);
mpz_init_set (mask, mask_expr->value.integer);
/* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
mpz_and (arg1, arg1, mask);
mpz_com (mask, mask);
mpz_and (arg2, arg2, mask);
mpz_ior (result->value.integer, arg1, arg2);
mpz_clear (arg1);
mpz_clear (arg2);
mpz_clear (mask);
return result;
}
/* Selects between current value and extremum for simplify_min_max
and simplify_minval_maxval. */
static void
min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
......
gcc/fortran/trans-intrinsic.c
......@@ -1288,6 +1288,62 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
}
}
/* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
where the right shifts are logical (i.e. 0's are shifted in).
Because SHIFT_EXPR's want shifts strictly smaller than the integral
type width, we have to special-case both S == 0 and S == BITSIZE(J):
DSHIFTL(I,J,0) = I
DSHIFTL(I,J,BITSIZE) = J
DSHIFTR(I,J,0) = J
DSHIFTR(I,J,BITSIZE) = I. */
static void
gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
{
tree type, utype, stype, arg1, arg2, shift, res, left, right;
tree args[3], cond, tmp;
int bitsize;
gfc_conv_intrinsic_function_args (se, expr, args, 3);
gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
type = TREE_TYPE (args[0]);
bitsize = TYPE_PRECISION (type);
utype = unsigned_type_for (type);
stype = TREE_TYPE (args[2]);
arg1 = gfc_evaluate_now (args[0], &se->pre);
arg2 = gfc_evaluate_now (args[1], &se->pre);
shift = gfc_evaluate_now (args[2], &se->pre);
/* The generic case. */
tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
build_int_cst (stype, bitsize), shift);
left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
arg1, dshiftl ? shift : tmp);
right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
fold_convert (utype, arg2), dshiftl ? tmp : shift);
right = fold_convert (type, right);
res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
/* Special cases. */
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
build_int_cst (stype, 0));
res = fold_build3_loc (input_location, COND_EXPR, type, cond,
dshiftl ? arg1 : arg2, res);
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
build_int_cst (stype, bitsize));
res = fold_build3_loc (input_location, COND_EXPR, type, cond,
dshiftl ? arg2 : arg1, res);
se->expr = res;
}
/* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
static void
......@@ -3209,6 +3265,33 @@ gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
se->expr = convert (type, tmp);
}
/* Generate code for BGE, BGT, BLE and BLT intrinsics. */
static void
gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
tree args[2];
gfc_conv_intrinsic_function_args (se, expr, args, 2);
/* Convert both arguments to the unsigned type of the same size. */
args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
/* If they have unequal type size, convert to the larger one. */
if (TYPE_PRECISION (TREE_TYPE (args[0]))
> TYPE_PRECISION (TREE_TYPE (args[1])))
args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
else if (TYPE_PRECISION (TREE_TYPE (args[1]))
> TYPE_PRECISION (TREE_TYPE (args[0])))
args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
/* Now, we compare them. */
se->expr = fold_build2_loc (input_location, op, boolean_type_node,
args[0], args[1]);
}
/* Generate code to perform the specified operation. */
static void
gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
......@@ -3277,18 +3360,39 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
}
/* RSHIFT (I, SHIFT) = I >> SHIFT
LSHIFT (I, SHIFT) = I << SHIFT */
static void
gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
bool arithmetic)
{
tree args[2];
tree args[2], type, num_bits, cond;
gfc_conv_intrinsic_function_args (se, expr, args, 2);
args[0] = gfc_evaluate_now (args[0], &se->pre);
args[1] = gfc_evaluate_now (args[1], &se->pre);
type = TREE_TYPE (args[0]);
if (!arithmetic)
args[0] = fold_convert (unsigned_type_for (type), args[0]);
else
gcc_assert (right_shift);
se->expr = fold_build2_loc (input_location,
right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
TREE_TYPE (args[0]), args[0], args[1]);
if (!arithmetic)
se->expr = fold_convert (type, se->expr);
/* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
gcc requires a shift width < BIT_SIZE(I), so we have to catch this
special case. */
num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
args[1], num_bits);
se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
build_int_cst (type, 0), se->expr);
}
/* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
......@@ -3510,7 +3614,6 @@ gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
return clzll ((unsigned long long) (x >> ULLSIZE));
else
return ULL_SIZE + clzll ((unsigned long long) x);
where ULL_MAX is the largest value that a ULL_MAX can hold
(0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
is the bit-size of the long long type (64 in this example). */
......@@ -4032,6 +4135,84 @@ gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
}
/* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
static void
gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
{
tree args[3], mask, type;
gfc_conv_intrinsic_function_args (se, expr, args, 3);
mask = gfc_evaluate_now (args[2], &se->pre);
type = TREE_TYPE (args[0]);
gcc_assert (TREE_TYPE (args[1]) == type);
gcc_assert (TREE_TYPE (mask) == type);
args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
fold_build1_loc (input_location, BIT_NOT_EXPR,
type, mask));
se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
args[0], args[1]);
}
/* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
static void
gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
{
tree arg, allones, type, utype, res, cond, bitsize;
int i;
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
arg = gfc_evaluate_now (arg, &se->pre);
type = gfc_get_int_type (expr->ts.kind);
utype = unsigned_type_for (type);
i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
build_int_cst (utype, 0));
if (left)
{
/* Left-justified mask. */
res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
bitsize, arg);
res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
fold_convert (utype, res));
/* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
smaller than type width. */
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
build_int_cst (TREE_TYPE (arg), 0));
res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
build_int_cst (utype, 0), res);
}
else
{
/* Right-justified mask. */
res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
fold_convert (utype, arg));
res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
/* Special case agr == bit_size, because SHIFT_EXPR wants a shift
strictly smaller than type width. */
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
arg, bitsize);
res = fold_build3_loc (input_location, COND_EXPR, utype,
cond, allones, res);
}
se->expr = fold_convert (type, res);
}
/* FRACTION (s) is translated into frexp (s, &dummy_int). */
static void
gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
......@@ -5548,6 +5729,22 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_btest (se, expr);
break;
case GFC_ISYM_BGE:
gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
break;
case GFC_ISYM_BGT:
gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
break;
case GFC_ISYM_BLE:
gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
break;
case GFC_ISYM_BLT:
gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
break;
case GFC_ISYM_ACHAR:
case GFC_ISYM_CHAR:
gfc_conv_intrinsic_char (se, expr);
......@@ -5625,6 +5822,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_dprod (se, expr);
break;
case GFC_ISYM_DSHIFTL:
gfc_conv_intrinsic_dshift (se, expr, true);
break;
case GFC_ISYM_DSHIFTR:
gfc_conv_intrinsic_dshift (se, expr, false);
break;
case GFC_ISYM_FDATE:
gfc_conv_intrinsic_fdate (se, expr);
break;
......@@ -5704,11 +5909,23 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
break;
case GFC_ISYM_LSHIFT:
gfc_conv_intrinsic_rlshift (se, expr, 0);
gfc_conv_intrinsic_shift (se, expr, false, false);
break;
case GFC_ISYM_RSHIFT:
gfc_conv_intrinsic_rlshift (se, expr, 1);
gfc_conv_intrinsic_shift (se, expr, true, true);
break;
case GFC_ISYM_SHIFTA:
gfc_conv_intrinsic_shift (se, expr, true, true);
break;
case GFC_ISYM_SHIFTL:
gfc_conv_intrinsic_shift (se, expr, false, false);
break;
case GFC_ISYM_SHIFTR:
gfc_conv_intrinsic_shift (se, expr, true, false);
break;
case GFC_ISYM_ISHFT:
......@@ -5773,6 +5990,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
break;
case GFC_ISYM_MASKL:
gfc_conv_intrinsic_mask (se, expr, 1);
break;
case GFC_ISYM_MASKR:
gfc_conv_intrinsic_mask (se, expr, 0);
break;
case GFC_ISYM_MAX:
if (expr->ts.type == BT_CHARACTER)
gfc_conv_intrinsic_minmax_char (se, expr, 1);
......@@ -5792,6 +6017,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_merge (se, expr);
break;
case GFC_ISYM_MERGE_BITS:
gfc_conv_intrinsic_merge_bits (se, expr);
break;
case GFC_ISYM_MIN:
if (expr->ts.type == BT_CHARACTER)
gfc_conv_intrinsic_minmax_char (se, expr, -1);
......
gcc/testsuite/ChangeLog
2010-09-08 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/38282
* gfortran.dg/bit_comparison_1.F90: New test.
* gfortran.dg/leadz_trailz_3.f90: New test.
* gfortran.dg/masklr_2.F90: New test.
* gfortran.dg/shiftalr_1.F90: New test.
* gfortran.dg/merge_bits_2.F90: New test.
* gfortran.dg/dshift_2.F90: New test.
* gfortran.dg/bit_comparison_2.F90: New test.
* gfortran.dg/masklr_1.F90: New test.
* gfortran.dg/merge_bits_1.F90: New test.
* gfortran.dg/dshift_1.F90: New test.
* gfortran.dg/shiftalr_2.F90: New test.
2010-09-06 Nicola Pero <nicola.pero@meta-innovation.com>
* objc.dg/type-stream-1.m: Replaced with a test that tests that
......
gcc/testsuite/gfortran.dg/bit_comparison_1.F90 0 → 100644
! Test the BGE, BGT, BLE and BLT intrinsics.
!
! { dg-do run }
! { dg-options "-ffree-line-length-none" }
interface run_bge
procedure run_bge1
procedure run_bge2
procedure run_bge4
procedure run_bge8
end interface
interface run_bgt
procedure run_bgt1
procedure run_bgt2
procedure run_bgt4
procedure run_bgt8
end interface
interface run_ble
procedure run_ble1
procedure run_ble2
procedure run_ble4
procedure run_ble8
end interface
interface run_blt
procedure run_blt1
procedure run_blt2
procedure run_blt4
procedure run_blt8
end interface
#define CHECK(I,J,RES) \
if (bge(I,J) .neqv. RES) call abort ; \
if (run_bge(I,J) .neqv. RES) call abort ; \
if (bgt(I,J) .neqv. (RES .and. (I/=J))) call abort ; \
if (run_bgt(I,J) .neqv. (RES .and. (I/=J))) call abort ; \
if (ble(J,I) .neqv. RES) call abort ; \
if (run_ble(J,I) .neqv. RES) call abort ; \
if (blt(J,I) .neqv. (RES .and. (I/=J))) call abort ; \
if (run_blt(J,I) .neqv. (RES .and. (I/=J))) call abort
#define T .true.
#define F .false.
CHECK(0_1, 0_1, T)
CHECK(1_1, 0_1, T)
CHECK(0_1, 107_1, F)
CHECK(5_1, huge(0_1) / 2_1, F)
CHECK(5_1, huge(0_1), F)
CHECK(-1_1, 0_1, T)
CHECK(0_1, -19_1, F)
CHECK(huge(0_1), -19_1, F)
CHECK(0_2, 0_2, T)
CHECK(1_2, 0_2, T)
CHECK(0_2, 107_2, F)
CHECK(5_2, huge(0_2) / 2_2, F)
CHECK(5_2, huge(0_2), F)
CHECK(-1_2, 0_2, T)
CHECK(0_2, -19_2, F)
CHECK(huge(0_2), -19_2, F)
CHECK(0_4, 0_4, T)
CHECK(1_4, 0_4, T)
CHECK(0_4, 107_4, F)
CHECK(5_4, huge(0_4) / 2_4, F)
CHECK(5_4, huge(0_4), F)
CHECK(-1_4, 0_4, T)
CHECK(0_4, -19_4, F)
CHECK(huge(0_4), -19_4, F)
CHECK(0_8, 0_8, T)
CHECK(1_8, 0_8, T)
CHECK(0_8, 107_8, F)
CHECK(5_8, huge(0_8) / 2_8, F)
CHECK(5_8, huge(0_8), F)
CHECK(-1_8, 0_8, T)
CHECK(0_8, -19_8, F)
CHECK(huge(0_8), -19_8, F)
contains
pure logical function run_bge1 (i, j) result(res)
integer(kind=1), intent(in) :: i, j
res = bge(i,j)
end function
pure logical function run_bgt1 (i, j) result(res)
integer(kind=1), intent(in) :: i, j
res = bgt(i,j)
end function
pure logical function run_ble1 (i, j) result(res)
integer(kind=1), intent(in) :: i, j
res = ble(i,j)
end function
pure logical function run_blt1 (i, j) result(res)
integer(kind=1), intent(in) :: i, j
res = blt(i,j)
end function
pure logical function run_bge2 (i, j) result(res)
integer(kind=2), intent(in) :: i, j
res = bge(i,j)
end function
pure logical function run_bgt2 (i, j) result(res)
integer(kind=2), intent(in) :: i, j
res = bgt(i,j)
end function
pure logical function run_ble2 (i, j) result(res)
integer(kind=2), intent(in) :: i, j
res = ble(i,j)
end function
pure logical function run_blt2 (i, j) result(res)
integer(kind=2), intent(in) :: i, j
res = blt(i,j)
end function
pure logical function run_bge4 (i, j) result(res)
integer(kind=4), intent(in) :: i, j
res = bge(i,j)
end function
pure logical function run_bgt4 (i, j) result(res)
integer(kind=4), intent(in) :: i, j
res = bgt(i,j)
end function
pure logical function run_ble4 (i, j) result(res)
integer(kind=4), intent(in) :: i, j
res = ble(i,j)
end function
pure logical function run_blt4 (i, j) result(res)
integer(kind=4), intent(in) :: i, j
res = blt(i,j)
end function
pure logical function run_bge8 (i, j) result(res)
integer(kind=8), intent(in) :: i, j
res = bge(i,j)
end function
pure logical function run_bgt8 (i, j) result(res)
integer(kind=8), intent(in) :: i, j
res = bgt(i,j)
end function
pure logical function run_ble8 (i, j) result(res)
integer(kind=8), intent(in) :: i, j
res = ble(i,j)
end function
pure logical function run_blt8 (i, j) result(res)
integer(kind=8), intent(in) :: i, j
res = blt(i,j)
end function
end
gcc/testsuite/gfortran.dg/bit_comparison_2.F90 0 → 100644
! Test the BGE, BGT, BLE and BLT intrinsics.
!
! { dg-do run }
! { dg-options "-ffree-line-length-none" }
! { dg-require-effective-target fortran_integer_16 }
#define CHECK(I,J,RES) \
if (bge(I,J) .neqv. RES) call abort ; \
if (run_bge(I,J) .neqv. RES) call abort ; \
if (bgt(I,J) .neqv. (RES .and. (I/=J))) call abort ; \
if (run_bgt(I,J) .neqv. (RES .and. (I/=J))) call abort ; \
if (ble(J,I) .neqv. RES) call abort ; \
if (run_ble(J,I) .neqv. RES) call abort ; \
if (blt(J,I) .neqv. (RES .and. (I/=J))) call abort ; \
if (run_blt(J,I) .neqv. (RES .and. (I/=J))) call abort
#define T .true.
#define F .false.
CHECK(0_16, 0_16, T)
CHECK(1_16, 0_16, T)
CHECK(0_16, 107_16, F)
CHECK(5_16, huge(0_16) / 2_16, F)
CHECK(5_16, huge(0_16), F)
CHECK(-1_16, 0_16, T)
CHECK(0_16, -19_16, F)
CHECK(huge(0_16), -19_16, F)
contains
pure logical function run_bge (i, j) result(res)
integer(kind=16), intent(in) :: i, j
res = bge(i,j)
end function
pure logical function run_bgt (i, j) result(res)
integer(kind=16), intent(in) :: i, j
res = bgt(i,j)
end function
pure logical function run_ble (i, j) result(res)
integer(kind=16), intent(in) :: i, j
res = ble(i,j)
end function
pure logical function run_blt (i, j) result(res)
integer(kind=16), intent(in) :: i, j
res = blt(i,j)
end function
end
gcc/testsuite/gfortran.dg/dshift_1.F90 0 → 100644
! Test the DSHIFTL and DSHIFTR intrinsics.
!
! { dg-do run }
! { dg-options "-ffree-line-length-none" }
implicit none
interface run_dshiftl
procedure dshiftl_1
procedure dshiftl_2
procedure dshiftl_4
procedure dshiftl_8
end interface
interface run_dshiftr
procedure dshiftr_1
procedure dshiftr_2
procedure dshiftr_4
procedure dshiftr_8
end interface
#define RESL(I,J,SHIFT) \
IOR(SHIFTL(I,SHIFT),SHIFTR(J,BIT_SIZE(J)-SHIFT))
#define RESR(I,J,SHIFT) \
IOR(SHIFTL(I,BIT_SIZE(I)-SHIFT),SHIFTR(J,SHIFT))
#define CHECK(I,J,SHIFT) \
if (dshiftl(I,J,SHIFT) /= RESL(I,J,SHIFT)) call abort ; \
if (dshiftr(I,J,SHIFT) /= RESR(I,J,SHIFT)) call abort ; \
if (run_dshiftl(I,J,SHIFT) /= RESL(I,J,SHIFT)) call abort ; \
if (run_dshiftr(I,J,SHIFT) /= RESR(I,J,SHIFT)) call abort
CHECK(0_1,0_1,0)
CHECK(0_1,0_1,1)
CHECK(0_1,0_1,7)
CHECK(0_1,0_1,8)
CHECK(28_1,79_1,0)
CHECK(28_1,79_1,1)
CHECK(28_1,79_1,5)
CHECK(28_1,79_1,7)
CHECK(28_1,79_1,8)
CHECK(-28_1,79_1,0)
CHECK(-28_1,79_1,1)
CHECK(-28_1,79_1,5)
CHECK(-28_1,79_1,7)
CHECK(-28_1,79_1,8)
CHECK(28_1,-79_1,0)
CHECK(28_1,-79_1,1)
CHECK(28_1,-79_1,5)
CHECK(28_1,-79_1,7)
CHECK(28_1,-79_1,8)
CHECK(-28_1,-79_1,0)
CHECK(-28_1,-79_1,1)
CHECK(-28_1,-79_1,5)
CHECK(-28_1,-79_1,7)
CHECK(-28_1,-79_1,8)
CHECK(0_2,0_2,0)
CHECK(0_2,0_2,1)
CHECK(0_2,0_2,7)
CHECK(0_2,0_2,8)
CHECK(28_2,79_2,0)
CHECK(28_2,79_2,1)
CHECK(28_2,79_2,5)
CHECK(28_2,79_2,7)
CHECK(28_2,79_2,8)
CHECK(-28_2,79_2,0)
CHECK(-28_2,79_2,1)
CHECK(-28_2,79_2,5)
CHECK(-28_2,79_2,7)
CHECK(-28_2,79_2,8)
CHECK(28_2,-79_2,0)
CHECK(28_2,-79_2,1)
CHECK(28_2,-79_2,5)
CHECK(28_2,-79_2,7)
CHECK(28_2,-79_2,8)
CHECK(-28_2,-79_2,0)
CHECK(-28_2,-79_2,1)
CHECK(-28_2,-79_2,5)
CHECK(-28_2,-79_2,7)
CHECK(-28_2,-79_2,8)
CHECK(0_4,0_4,0)
CHECK(0_4,0_4,1)
CHECK(0_4,0_4,7)
CHECK(0_4,0_4,8)
CHECK(28_4,79_4,0)
CHECK(28_4,79_4,1)
CHECK(28_4,79_4,5)
CHECK(28_4,79_4,7)
CHECK(28_4,79_4,8)
CHECK(-28_4,79_4,0)
CHECK(-28_4,79_4,1)
CHECK(-28_4,79_4,5)
CHECK(-28_4,79_4,7)
CHECK(-28_4,79_4,8)
CHECK(28_4,-79_4,0)
CHECK(28_4,-79_4,1)
CHECK(28_4,-79_4,5)
CHECK(28_4,-79_4,7)
CHECK(28_4,-79_4,8)
CHECK(-28_4,-79_4,0)
CHECK(-28_4,-79_4,1)
CHECK(-28_4,-79_4,5)
CHECK(-28_4,-79_4,7)
CHECK(-28_4,-79_4,8)
CHECK(0_8,0_8,0)
CHECK(0_8,0_8,1)
CHECK(0_8,0_8,7)
CHECK(0_8,0_8,8)
CHECK(28_8,79_8,0)
CHECK(28_8,79_8,1)
CHECK(28_8,79_8,5)
CHECK(28_8,79_8,7)
CHECK(28_8,79_8,8)
CHECK(-28_8,79_8,0)
CHECK(-28_8,79_8,1)
CHECK(-28_8,79_8,5)
CHECK(-28_8,79_8,7)
CHECK(-28_8,79_8,8)
CHECK(28_8,-79_8,0)
CHECK(28_8,-79_8,1)
CHECK(28_8,-79_8,5)
CHECK(28_8,-79_8,7)
CHECK(28_8,-79_8,8)
CHECK(-28_8,-79_8,0)
CHECK(-28_8,-79_8,1)
CHECK(-28_8,-79_8,5)
CHECK(-28_8,-79_8,7)
CHECK(-28_8,-79_8,8)
contains
function dshiftl_1 (i, j, shift) result(res)
integer(kind=1) :: i, j, res
integer :: shift
res = dshiftl(i,j,shift)
end function
function dshiftl_2 (i, j, shift) result(res)
integer(kind=2) :: i, j, res
integer :: shift
res = dshiftl(i,j,shift)
end function
function dshiftl_4 (i, j, shift) result(res)
integer(kind=4) :: i, j, res
integer :: shift
res = dshiftl(i,j,shift)
end function
function dshiftl_8 (i, j, shift) result(res)
integer(kind=8) :: i, j, res
integer :: shift
res = dshiftl(i,j,shift)
end function
function dshiftr_1 (i, j, shift) result(res)
integer(kind=1) :: i, j, res
integer :: shift
res = dshiftr(i,j,shift)
end function
function dshiftr_2 (i, j, shift) result(res)
integer(kind=2) :: i, j, res
integer :: shift
res = dshiftr(i,j,shift)
end function
function dshiftr_4 (i, j, shift) result(res)
integer(kind=4) :: i, j, res
integer :: shift
res = dshiftr(i,j,shift)
end function
function dshiftr_8 (i, j, shift) result(res)
integer(kind=8) :: i, j, res
integer :: shift
res = dshiftr(i,j,shift)
end function
end
gcc/testsuite/gfortran.dg/dshift_2.F90 0 → 100644
! Test the DSHIFTL and DSHIFTR intrinsics.
!
! { dg-do run }
! { dg-options "-ffree-line-length-none" }
! { dg-require-effective-target fortran_integer_16 }
implicit none
#define RESL(I,J,SHIFT) \
IOR(SHIFTL(I,SHIFT),SHIFTR(J,BIT_SIZE(J)-SHIFT))
#define RESR(I,J,SHIFT) \
IOR(SHIFTL(I,BIT_SIZE(I)-SHIFT),SHIFTR(J,SHIFT))
#define CHECK(I,J,SHIFT) \
if (dshiftl(I,J,SHIFT) /= RESL(I,J,SHIFT)) call abort ; \
if (dshiftr(I,J,SHIFT) /= RESR(I,J,SHIFT)) call abort ; \
if (run_dshiftl(I,J,SHIFT) /= RESL(I,J,SHIFT)) call abort ; \
if (run_dshiftr(I,J,SHIFT) /= RESR(I,J,SHIFT)) call abort
CHECK(0_16,0_16,0)
CHECK(0_16,0_16,1)
CHECK(0_16,0_16,7)
CHECK(0_16,0_16,8)
CHECK(28_16,79_16,0)
CHECK(28_16,79_16,1)
CHECK(28_16,79_16,5)
CHECK(28_16,79_16,7)
CHECK(28_16,79_16,8)
CHECK(-28_16,79_16,0)
CHECK(-28_16,79_16,1)
CHECK(-28_16,79_16,5)
CHECK(-28_16,79_16,7)
CHECK(-28_16,79_16,8)
CHECK(28_16,-79_16,0)
CHECK(28_16,-79_16,1)
CHECK(28_16,-79_16,5)
CHECK(28_16,-79_16,7)
CHECK(28_16,-79_16,8)
CHECK(-28_16,-79_16,0)
CHECK(-28_16,-79_16,1)
CHECK(-28_16,-79_16,5)
CHECK(-28_16,-79_16,7)
CHECK(-28_16,-79_16,8)
contains
function run_dshiftl (i, j, shift) result(res)
integer(kind=16) :: i, j, res
integer :: shift
res = dshiftl(i,j,shift)
end function
function run_dshiftr (i, j, shift) result(res)
integer(kind=16) :: i, j, res
integer :: shift
res = dshiftr(i,j,shift)
end function
end
gcc/testsuite/gfortran.dg/leadz_trailz_3.f90 0 → 100644
! We want to check that ISHFT evaluates its arguments only once
!
! { dg-do run }
! { dg-options "-fdump-tree-original" }
program test
if (leadz (foo()) /= bit_size(0) - 1) call abort
if (leadz (foo()) /= bit_size(0) - 2) call abort
if (trailz (foo()) /= 0) call abort
if (trailz (foo()) /= 2) call abort
if (trailz (foo()) /= 0) call abort
if (trailz (foo()) /= 1) call abort
contains
integer function foo ()
integer, save :: i = 0
i = i + 1
foo = i
end function
end program
! The regexp "foo ()" should be seen once in the dump:
! -- once in the function definition itself
! -- plus as many times as the function is called
!
! { dg-final { scan-tree-dump-times "foo *\\\(\\\)" 7 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
gcc/testsuite/gfortran.dg/masklr_1.F90 0 → 100644
! Test the MASKL and MASKR intrinsics.
!
! { dg-do run }
! { dg-options "-ffree-line-length-none" }
#define CHECK(I,KIND,FUNCL,FUNCR,RESL,RESR) \
if (maskl(I,KIND) /= RESL) call abort ; \
if (FUNCL(I) /= RESL) call abort ; \
if (maskr(I,KIND) /= RESR) call abort ; \
if (FUNCR(I) /= RESR) call abort
CHECK(0,1,run_maskl1,run_maskr1,0_1,0_1)
CHECK(1,1,run_maskl1,run_maskr1,-huge(0_1)-1_1,1_1)
CHECK(2,1,run_maskl1,run_maskr1,(-huge(0_1)-1_1)/2_1,3_1)
CHECK(3,1,run_maskl1,run_maskr1,(-huge(0_1)-1_1)/4_1,7_1)
CHECK(int(bit_size(0_1))-2,1,run_maskl1,run_maskr1,-4_1,huge(0_1)/2_1)
CHECK(int(bit_size(0_1))-1,1,run_maskl1,run_maskr1,-2_1,huge(0_1))
CHECK(int(bit_size(0_1)),1,run_maskl1,run_maskr1,-1_1,-1_1)
CHECK(0,2,run_maskl2,run_maskr2,0_2,0_2)
CHECK(1,2,run_maskl2,run_maskr2,-huge(0_2)-1_2,1_2)
CHECK(2,2,run_maskl2,run_maskr2,(-huge(0_2)-1_2)/2_2,3_2)
CHECK(3,2,run_maskl2,run_maskr2,(-huge(0_2)-1_2)/4_2,7_2)
CHECK(int(bit_size(0_2))-2,2,run_maskl2,run_maskr2,-4_2,huge(0_2)/2_2)
CHECK(int(bit_size(0_2))-1,2,run_maskl2,run_maskr2,-2_2,huge(0_2))
CHECK(int(bit_size(0_2)),2,run_maskl2,run_maskr2,-1_2,-1_2)
CHECK(0,4,run_maskl4,run_maskr4,0_4,0_4)
CHECK(1,4,run_maskl4,run_maskr4,-huge(0_4)-1_4,1_4)
CHECK(2,4,run_maskl4,run_maskr4,(-huge(0_4)-1_4)/2_4,3_4)
CHECK(3,4,run_maskl4,run_maskr4,(-huge(0_4)-1_4)/4_4,7_4)
CHECK(int(bit_size(0_4))-2,4,run_maskl4,run_maskr4,-4_4,huge(0_4)/2_4)
CHECK(int(bit_size(0_4))-1,4,run_maskl4,run_maskr4,-2_4,huge(0_4))
CHECK(int(bit_size(0_4)),4,run_maskl4,run_maskr4,-1_4,-1_4)
CHECK(0,8,run_maskl8,run_maskr8,0_8,0_8)
CHECK(1,8,run_maskl8,run_maskr8,-huge(0_8)-1_8,1_8)
CHECK(2,8,run_maskl8,run_maskr8,(-huge(0_8)-1_8)/2_8,3_8)
CHECK(3,8,run_maskl8,run_maskr8,(-huge(0_8)-1_8)/4_8,7_8)
CHECK(int(bit_size(0_8))-2,8,run_maskl8,run_maskr8,-4_8,huge(0_8)/2_8)
CHECK(int(bit_size(0_8))-1,8,run_maskl8,run_maskr8,-2_8,huge(0_8))
CHECK(int(bit_size(0_8)),8,run_maskl8,run_maskr8,-1_8,-1_8)
contains
pure integer(kind=1) function run_maskl1(i) result(res)
integer, intent(in) :: i
res = maskl(i,kind=1)
end function
pure integer(kind=1) function run_maskr1(i) result(res)
integer, intent(in) :: i
res = maskr(i,kind=1)
end function
pure integer(kind=2) function run_maskl2(i) result(res)
integer, intent(in) :: i
res = maskl(i,kind=2)
end function
pure integer(kind=2) function run_maskr2(i) result(res)
integer, intent(in) :: i
res = maskr(i,kind=2)
end function
pure integer(kind=4) function run_maskl4(i) result(res)
integer, intent(in) :: i
res = maskl(i,kind=4)
end function
pure integer(kind=4) function run_maskr4(i) result(res)
integer, intent(in) :: i
res = maskr(i,kind=4)
end function
pure integer(kind=8) function run_maskl8(i) result(res)
integer, intent(in) :: i
res = maskl(i,kind=8)
end function
pure integer(kind=8) function run_maskr8(i) result(res)
integer, intent(in) :: i
res = maskr(i,kind=8)
end function
end
gcc/testsuite/gfortran.dg/masklr_2.F90 0 → 100644
! Test the MASKL and MASKR intrinsics.
!
! { dg-do run }
! { dg-options "-ffree-line-length-none" }
! { dg-require-effective-target fortran_integer_16 }
#define CHECK(I,KIND,FUNCL,FUNCR,RESL,RESR) \
if (maskl(I,KIND) /= RESL) call abort ; \
if (FUNCL(I) /= RESL) call abort ; \
if (maskr(I,KIND) /= RESR) call abort ; \
if (FUNCR(I) /= RESR) call abort
CHECK(0,16,run_maskl16,run_maskr16,0_16,0_16)
CHECK(1,16,run_maskl16,run_maskr16,-huge(0_16)-1_16,1_16)
CHECK(2,16,run_maskl16,run_maskr16,(-huge(0_16)-1_16)/2_16,3_16)
CHECK(3,16,run_maskl16,run_maskr16,(-huge(0_16)-1_16)/4_16,7_16)
CHECK(int(bit_size(0_16))-2,16,run_maskl16,run_maskr16,-4_16,huge(0_16)/2_16)
CHECK(int(bit_size(0_16))-1,16,run_maskl16,run_maskr16,-2_16,huge(0_16))
CHECK(int(bit_size(0_16)),16,run_maskl16,run_maskr16,-1_16,-1_16)
contains
pure integer(kind=16) function run_maskl16(i) result(res)
integer, intent(in) :: i
res = maskl(i,kind=16)
end function
pure integer(kind=16) function run_maskr16(i) result(res)
integer, intent(in) :: i
res = maskr(i,kind=16)
end function
end
gcc/testsuite/gfortran.dg/merge_bits_1.F90 0 → 100644
! Test the MERGE_BITS intrinsic
!
! { dg-do run }
! { dg-options "-ffree-line-length-none" }
interface run_merge
procedure run_merge_1
procedure run_merge_2
procedure run_merge_4
procedure run_merge_8
end interface
#define CHECK(I,J,K) \
if (merge_bits(I,J,K) /= ior(iand(I,K),iand(J,not(K)))) call abort ; \
if (run_merge(I,J,K) /= merge_bits(I,J,K)) call abort
CHECK(13_1,18_1,22_1)
CHECK(-13_1,18_1,22_1)
CHECK(13_1,-18_1,22_1)
CHECK(13_1,18_1,-22_1)
CHECK(13_2,18_2,22_2)
CHECK(-13_2,18_2,22_2)
CHECK(13_2,-18_2,22_2)
CHECK(13_2,18_2,-22_2)
CHECK(13_4,18_4,22_4)
CHECK(-13_4,18_4,22_4)
CHECK(13_4,-18_4,22_4)
CHECK(13_4,18_4,-22_4)
CHECK(13_8,18_8,22_8)
CHECK(-13_8,18_8,22_8)
CHECK(13_8,-18_8,22_8)
CHECK(13_8,18_8,-22_8)
contains
function run_merge_1 (i, j, k) result(res)
integer(kind=1) :: i, j, k, res
res = merge_bits(i,j,k)
end function
function run_merge_2 (i, j, k) result(res)
integer(kind=2) :: i, j, k, res
res = merge_bits(i,j,k)
end function
function run_merge_4 (i, j, k) result(res)
integer(kind=4) :: i, j, k, res
res = merge_bits(i,j,k)
end function
function run_merge_8 (i, j, k) result(res)
integer(kind=8) :: i, j, k, res
res = merge_bits(i,j,k)
end function
end
gcc/testsuite/gfortran.dg/merge_bits_2.F90 0 → 100644
! Test the MERGE_BITS intrinsic
!
! { dg-do run }
! { dg-options "-ffree-line-length-none" }
! { dg-require-effective-target fortran_integer_16 }
#define CHECK(I,J,K) \
if (merge_bits(I,J,K) /= ior(iand(I,K),iand(J,not(K)))) call abort ; \
if (run_merge(I,J,K) /= merge_bits(I,J,K)) call abort
CHECK(13_16,18_16,22_16)
CHECK(-13_16,18_16,22_16)
CHECK(13_16,-18_16,22_16)
CHECK(13_16,18_16,-22_16)
contains
function run_merge (i, j, k) result(res)
integer(kind=16) :: i, j, k, res
res = merge_bits(i,j,k)
end function
end
gcc/testsuite/gfortran.dg/shiftalr_1.F90 0 → 100644
! Test the SHIFTA, SHIFTL and SHIFTR intrinsics.
!
! { dg-do run }
! { dg-options "-ffree-line-length-none" }
interface run_shifta
procedure shifta_1
procedure shifta_2
procedure shifta_4
procedure shifta_8
end interface
interface run_shiftl
procedure shiftl_1
procedure shiftl_2
procedure shiftl_4
procedure shiftl_8
end interface
interface run_shiftr
procedure shiftr_1
procedure shiftr_2
procedure shiftr_4
procedure shiftr_8
end interface
interface run_ishft
procedure ishft_1
procedure ishft_2
procedure ishft_4
procedure ishft_8
end interface
#define CHECK(I,SHIFT,RESA,RESL,RESR) \
if (shifta(I,SHIFT) /= RESA) call abort ; \
if (shiftr(I,SHIFT) /= RESR) call abort ; \
if (shiftl(I,SHIFT) /= RESL) call abort ; \
if (run_shifta(I,SHIFT) /= RESA) call abort ; \
if (run_shiftr(I,SHIFT) /= RESR) call abort ; \
if (run_shiftl(I,SHIFT) /= RESL) call abort ; \
if (ishft(I,SHIFT) /= RESL) call abort ; \
if (ishft(I,-SHIFT) /= RESR) call abort ; \
if (run_ishft(I,SHIFT) /= RESL) call abort ; \
if (run_ishft(I,-SHIFT) /= RESR) call abort
CHECK(0_1,0,0_1,0_1,0_1)
CHECK(11_1,0,11_1,11_1,11_1)
CHECK(-11_1,0,-11_1,-11_1,-11_1)
CHECK(0_1,1,0_1,0_1,0_1)
CHECK(11_1,1,5_1,22_1,5_1)
CHECK(11_1,2,2_1,44_1,2_1)
CHECK(-11_1,1,-6_1,-22_1,huge(0_1)-5_1)
CHECK(0_2,0,0_2,0_2,0_2)
CHECK(11_2,0,11_2,11_2,11_2)
CHECK(-11_2,0,-11_2,-11_2,-11_2)
CHECK(0_2,1,0_2,0_2,0_2)
CHECK(11_2,1,5_2,22_2,5_2)
CHECK(11_2,2,2_2,44_2,2_2)
CHECK(-11_2,1,-6_2,-22_2,huge(0_2)-5_2)
CHECK(0_4,0,0_4,0_4,0_4)
CHECK(11_4,0,11_4,11_4,11_4)
CHECK(-11_4,0,-11_4,-11_4,-11_4)
CHECK(0_4,1,0_4,0_4,0_4)
CHECK(11_4,1,5_4,22_4,5_4)
CHECK(11_4,2,2_4,44_4,2_4)
CHECK(-11_4,1,-6_4,-22_4,huge(0_4)-5_4)
CHECK(0_8,0,0_8,0_8,0_8)
CHECK(11_8,0,11_8,11_8,11_8)
CHECK(-11_8,0,-11_8,-11_8,-11_8)
CHECK(0_8,1,0_8,0_8,0_8)
CHECK(11_8,1,5_8,22_8,5_8)
CHECK(11_8,2,2_8,44_8,2_8)
CHECK(-11_8,1,-6_8,-22_8,huge(0_8)-5_8)
contains
function shifta_1 (i, shift) result(res)
integer(kind=1) :: i, res
integer :: shift
res = shifta(i,shift)
end function
function shiftl_1 (i, shift) result(res)
integer(kind=1) :: i, res
integer :: shift
res = shiftl(i,shift)
end function
function shiftr_1 (i, shift) result(res)
integer(kind=1) :: i, res
integer :: shift
res = shiftr(i,shift)
end function
function shifta_2 (i, shift) result(res)
integer(kind=2) :: i, res
integer :: shift
res = shifta(i,shift)
end function
function shiftl_2 (i, shift) result(res)
integer(kind=2) :: i, res
integer :: shift
res = shiftl(i,shift)
end function
function shiftr_2 (i, shift) result(res)
integer(kind=2) :: i, res
integer :: shift
res = shiftr(i,shift)
end function
function shifta_4 (i, shift) result(res)
integer(kind=4) :: i, res
integer :: shift
res = shifta(i,shift)
end function
function shiftl_4 (i, shift) result(res)
integer(kind=4) :: i, res
integer :: shift
res = shiftl(i,shift)
end function
function shiftr_4 (i, shift) result(res)
integer(kind=4) :: i, res
integer :: shift
res = shiftr(i,shift)
end function
function shifta_8 (i, shift) result(res)
integer(kind=8) :: i, res
integer :: shift
res = shifta(i,shift)
end function
function shiftl_8 (i, shift) result(res)
integer(kind=8) :: i, res
integer :: shift
res = shiftl(i,shift)
end function
function shiftr_8 (i, shift) result(res)
integer(kind=8) :: i, res
integer :: shift
res = shiftr(i,shift)
end function
function ishft_1 (i, shift) result(res)
integer(kind=1) :: i, res
integer :: shift
res = ishft(i,shift)
end function
function ishft_2 (i, shift) result(res)
integer(kind=2) :: i, res
integer :: shift
res = ishft(i,shift)
end function
function ishft_4 (i, shift) result(res)
integer(kind=4) :: i, res
integer :: shift
res = ishft(i,shift)
end function
function ishft_8 (i, shift) result(res)
integer(kind=8) :: i, res
integer :: shift
res = ishft(i,shift)
end function
end
gcc/testsuite/gfortran.dg/shiftalr_2.F90 0 → 100644
! Test the SHIFTA, SHIFTL and SHIFTR intrinsics.
!
! { dg-do run }
! { dg-options "-ffree-line-length-none" }
! { dg-require-effective-target fortran_integer_16 }
implicit none
#define CHECK(I,SHIFT,RESA,RESL,RESR) \
if (shifta(I,SHIFT) /= RESA) call abort ; \
if (shiftr(I,SHIFT) /= RESR) call abort ; \
if (shiftl(I,SHIFT) /= RESL) call abort ; \
if (run_shifta(I,SHIFT) /= RESA) call abort ; \
if (run_shiftr(I,SHIFT) /= RESR) call abort ; \
if (run_shiftl(I,SHIFT) /= RESL) call abort ; \
if (ishft(I,SHIFT) /= RESL) call abort ; \
if (ishft(I,-SHIFT) /= RESR) call abort ; \
if (run_ishft(I,SHIFT) /= RESL) call abort ; \
if (run_ishft(I,-SHIFT) /= RESR) call abort
CHECK(0_16,0,0_16,0_16,0_16)
CHECK(11_16,0,11_16,11_16,11_16)
CHECK(-11_16,0,-11_16,-11_16,-11_16)
CHECK(0_16,1,0_16,0_16,0_16)
CHECK(11_16,1,5_16,22_16,5_16)
CHECK(11_16,2,2_16,44_16,2_16)
CHECK(-11_16,1,-6_16,-22_16,huge(0_16)-5_16)
contains
function run_shifta (i, shift) result(res)
integer(kind=16) :: i, res
integer :: shift
res = shifta(i,shift)
end function
function run_shiftl (i, shift) result(res)
integer(kind=16) :: i, res
integer :: shift
res = shiftl(i,shift)
end function
function run_shiftr (i, shift) result(res)
integer(kind=16) :: i, res
integer :: shift
res = shiftr(i,shift)
end function
function run_ishft (i, shift) result(res)
integer(kind=16) :: i, res
integer :: shift
res = ishft(i,shift)
end function
end
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