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

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,11 +311,24 @@ 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 (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;
+	    }
 	}
     }
 
@@ -323,6 +336,31 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
 }
 
 
+/* 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).  */
 
@@ -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/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/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

+! 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

+! 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

+! 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

+! 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

+! 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

+! 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

+! 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

+! 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

+! 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

+! 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

+! 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