+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.
/* 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;
{
gfc_extract_int (expr2, &i2);
i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
- if (i2 >= gfc_integer_kinds[i3].bit_size)
+ if (or_equal)
{
- gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')",
- arg2, &expr2->where, arg1);
- return FAILURE;
+ 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')",
+ arg2, &expr2->where, arg1);
+ return FAILURE;
+ }
}
}
}
+/* 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;
+}
+
+
/* If expr2 and expr3 are constants, then check that the value is less than
or equal to bit_size(expr1). */
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)
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;
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)
{
/* 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)
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)
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)
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,
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,
GFC_ISYM_LSTAT,
GFC_ISYM_LTIME,
GFC_ISYM_MALLOC,
+ GFC_ISYM_MASKL,
+ GFC_ISYM_MASKR,
GFC_ISYM_MATMUL,
GFC_ISYM_MAX,
GFC_ISYM_MAXEXPONENT,
GFC_ISYM_MCLOCK,
GFC_ISYM_MCLOCK8,
GFC_ISYM_MERGE,
+ GFC_ISYM_MERGE_BITS,
GFC_ISYM_MIN,
GFC_ISYM_MINEXPONENT,
GFC_ISYM_MINLOC,
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,
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);
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);
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);
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);
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). */
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);
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
* @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
* @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
* @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
* @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
* @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
+@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
+@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
+@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
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
@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
+@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
+@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
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
@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
+@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
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)
{
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)
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);
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;
}
+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)
{
}
+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)
{
}
-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)
{
- gfc_error ("Magnitude of second argument of ISHFT exceeds bit size "
- "at %L", &s->where);
+ /* 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 ("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);
- for (i = 0; i < isize; i++)
+ bits = XCNEWVEC (int, bitsize);
+
+ 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);
}
else
{
- for (i = isize - 1; i >= isize - ashift; i--)
- mpz_clrbit (result->value.integer, 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);
}
}
- 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;
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
}
-/* 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)
}
}
+/* 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
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)
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))
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). */
}
+/* 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)
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);
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;
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:
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);
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);
+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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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" } }
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
projects / platform / upstream / gcc.git / commitdiff