Re: [PATCH] PR fortran/44346 -- check some values in ibits, mvbits

[Steve Kargl <sgk at troutmask dot apl dot washington dot edu>]

On Mon, May 31, 2010 at 08:04:48PM -0700, Steve Kargl wrote:
> On Mon, May 31, 2010 at 06:51:58PM -0700, Jerry DeLisle wrote:
> > On 05/31/2010 01:34 PM, Steve Kargl wrote:
> > >The attached patch was tested on i686-*-freebsd.  The patch with
> > >the testcases are obvious (to at least me).
> > >
> > >OK for trunk (and 4.5 after testing)?.
> > >
> > OK, thanks much.
> > 
> 
> I have a better patch, which I'll post later tonight.
> It deals with btest, ibclr, ibits, ibset, and mvbits.
> 

The better patch is attached.  Is this ok for
trunk (and 4.5 after testing).

2010-06-01  Steven G. Kargl  <kargl@gcc.gnu.org>

	* testsuite/gfortran.dg/mvbits_9.f90: New test.
	* testsuite/gfortran.dg/ibset_1.f90: Ditto.
	* testsuite/gfortran.dg/ibits_1.f90: Ditto.
	* testsuite/gfortran.dg/btest_1.f90: Ditto.
	* testsuite/gfortran.dg/ibclr_1.f90: Ditto.

2010-06-01  Steven G. Kargl  <kargl@gcc.gnu.org>

	* fortran/intrinsic.c (add_functions): Change gfc_check_btest,
	gfc_check_ibclr, and gfc_check_ibset to gfc_check_bitfcn.
	* fortran/intrinsic.h: Remove prototypes for gfc_check_btest,
	gfc_check_ibclr, and gfc_check_ibset.  Add prototype for
	gfc_check_bitfcn.
	* fortran/check.c (nonnegative_check, less_than_bitsize1, 
	less_than_bitsize2): New functions.
	(gfc_check_btest): Renamed to gfc_check_bitfcn.  Use
	nonnegative_check and less_than_bitsize1.
	(gfc_check_ibclr, gfc_check_ibset): Removed.
	(gfc_check_ibits,gfc_check_mvbits): Use nonnegative_check and
	less_than_bitsize1.

-- 
Steve

Index: gcc/testsuite/gfortran.dg/mvbits_9.f90
===================================================================
--- gcc/testsuite/gfortran.dg/mvbits_9.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/mvbits_9.f90	(revision 0)
@@ -0,0 +1,19 @@
+! { dg-do compile }
+!
+! PR fortran/44346
+! Original test sumbitted by Vittorio Zecca, zeccav at gmail dot com.
+! Modified by Steven G. Kargl for dejagnu testsuite.
+!
+program a
+   integer :: n = 42
+   ! 64 + 3 > bitsize(n) 
+   call mvbits(n, 64, 3, n, 1)   ! { dg-error "must be less than" }
+   ! 64 + 2 > bitsize(n)        
+   call mvbits(n, 30, 2, n, 64)  ! { dg-error "must be less than" }
+   ! LEN negative
+   call mvbits(n, 30, -2, n, 30) ! { dg-error "must be nonnegative" }
+   ! TOPOS negative
+   call mvbits(n, 30, 2, n, -3)  ! { dg-error "must be nonnegative" }
+   ! FROMPOS negative
+   call mvbits(n, -1, 2, n, 3)   ! { dg-error "must be nonnegative" }
+end program a
Index: gcc/testsuite/gfortran.dg/ibset_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ibset_1.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/ibset_1.f90	(revision 0)
@@ -0,0 +1,7 @@
+! { dg-do compile }
+program a
+   integer :: i = 42
+   integer l
+   l = ibset(i, -1)  ! { dg-error "must be nonnegative" }
+   l = ibset(i, 65)  ! { dg-error "must be less than" }
+end program a
Index: gcc/testsuite/gfortran.dg/ibits_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ibits_1.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/ibits_1.f90	(revision 0)
@@ -0,0 +1,13 @@
+! { dg-do compile }
+!
+! PR fortran/44346
+! Original test sumbitted by Vittorio Zecca, zeccav at gmail dot com.
+! Modified by Steven G. Kargl for dejagnu testsuite.
+!
+program a
+   integer :: j, i = 42
+   j = ibits(i, -1, 1)    ! { dg-error "must be nonnegative" }
+   j = ibits(i, 1, -1)    ! { dg-error "must be nonnegative" }
+   j = ibits(i, 100, 100) ! { dg-error "must be less than" }
+end program a
+
Index: gcc/testsuite/gfortran.dg/btest_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/btest_1.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/btest_1.f90	(revision 0)
@@ -0,0 +1,7 @@
+! { dg-do compile }
+program a
+   integer :: i = 42
+   logical l
+   l = btest(i, -1)  ! { dg-error "must be nonnegative" }
+   l = btest(i, 65)  ! { dg-error "must be less than" }
+end program a
Index: gcc/testsuite/gfortran.dg/ibclr_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/ibclr_1.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/ibclr_1.f90	(revision 0)
@@ -0,0 +1,7 @@
+! { dg-do compile }
+program a
+   integer :: i = 42
+   integer l
+   l = ibclr(i, -1)  ! { dg-error "must be nonnegative" }
+   l = ibclr(i, 65)  ! { dg-error "must be less than" }
+end program a
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c	(revision 160087)
+++ gcc/fortran/intrinsic.c	(working copy)
@@ -1354,7 +1354,7 @@ add_functions (void)
   make_generic ("bit_size", GFC_ISYM_BIT_SIZE, GFC_STD_F95);
 
   add_sym_2 ("btest", GFC_ISYM_BTEST, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
-	     gfc_check_btest, gfc_simplify_btest, gfc_resolve_btest,
+	     gfc_check_bitfcn, gfc_simplify_btest, gfc_resolve_btest,
 	     i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
 
   make_generic ("btest", GFC_ISYM_BTEST, GFC_STD_F95);
@@ -1738,7 +1738,7 @@ add_functions (void)
   make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU);
 
   add_sym_2 ("ibclr", GFC_ISYM_IBCLR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
-	     gfc_check_ibclr, gfc_simplify_ibclr, gfc_resolve_ibclr,
+	     gfc_check_bitfcn, gfc_simplify_ibclr, gfc_resolve_ibclr,
 	     i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
 
   make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95);
@@ -1751,7 +1751,7 @@ add_functions (void)
   make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95);
 
   add_sym_2 ("ibset", GFC_ISYM_IBSET, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
-	     gfc_check_ibset, gfc_simplify_ibset, gfc_resolve_ibset,
+	     gfc_check_bitfcn, gfc_simplify_ibset, gfc_resolve_ibset,
 	     i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
 
   make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95);
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 160087)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -3650,8 +3650,9 @@ gfc_trans_string_copy (stmtblock_t * blo
    The value of a statement function reference is obtained by evaluating the
    expression using the values of the actual arguments for the values of the
    corresponding dummy arguments.  */
+void gfc_conv_statement_function (gfc_se *, gfc_expr *);
 
-static void
+void
 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
 {
   gfc_symbol *sym;
Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h	(revision 160087)
+++ gcc/fortran/intrinsic.h	(working copy)
@@ -40,7 +40,7 @@ gfc_try gfc_check_associated (gfc_expr *
 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_btest (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_chmod (gfc_expr *, gfc_expr *);
@@ -74,9 +74,7 @@ gfc_try gfc_check_hypot (gfc_expr *, gfc
 gfc_try gfc_check_i (gfc_expr *);
 gfc_try gfc_check_iand (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_and (gfc_expr *, gfc_expr *);
-gfc_try gfc_check_ibclr (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
-gfc_try gfc_check_ibset (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_ichar_iachar (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_idnint (gfc_expr *);
 gfc_try gfc_check_ieor (gfc_expr *, gfc_expr *);
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c	(revision 160087)
+++ gcc/fortran/check.c	(working copy)
@@ -241,6 +241,80 @@ array_check (gfc_expr *e, int n)
 }
 
 
+/* If expr is a constant, then check to ensure that it is greater than
+   of equal to zero.  */
+
+static gfc_try
+nonnegative_check (const char *arg, gfc_expr *expr)
+{
+  int i;
+
+  if (expr->expr_type == EXPR_CONSTANT)
+    {
+      gfc_extract_int (expr, &i);
+      if (i < 0)
+	{
+	  gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where);
+	  return FAILURE;
+	}
+    }
+
+  return SUCCESS;
+}
+
+
+/* If expr2 is constant, then check that the value is less than
+   bit_size(expr1).  */
+
+static gfc_try
+less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
+	       gfc_expr *expr2)
+{
+  int i2, i3;
+
+  if (expr2->expr_type == EXPR_CONSTANT)
+    {
+      gfc_extract_int (expr2, &i2);
+      i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
+      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;
+	}
+    }
+
+  return SUCCESS;
+}
+
+
+/* If expr2 and expr3 are constants, then check that the value is less than
+   or equal to bit_size(expr1).  */
+
+static gfc_try
+less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2,
+	       gfc_expr *expr2, const char *arg3, gfc_expr *expr3)
+{
+  int i2, i3;
+
+  if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT)
+    {
+      gfc_extract_int (expr2, &i2);
+      gfc_extract_int (expr3, &i3);
+      i2 += i3;
+      i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
+      if (i2 > gfc_integer_kinds[i3].bit_size)
+	{
+	  gfc_error ("'%s + %s' at %L must be less than or equal "
+		     "to BIT_SIZE('%s')",
+		     arg2, arg3, &expr2->where, arg1);
+	  return FAILURE;
+	}
+    }
+
+  return SUCCESS;
+}
+
 /* Make sure two expressions have the same type.  */
 
 static gfc_try
@@ -766,13 +840,20 @@ gfc_check_besn (gfc_expr *n, gfc_expr *x
 
 
 gfc_try
-gfc_check_btest (gfc_expr *i, gfc_expr *pos)
+gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
 {
   if (type_check (i, 0, BT_INTEGER) == FAILURE)
     return FAILURE;
+
   if (type_check (pos, 1, BT_INTEGER) == FAILURE)
     return FAILURE;
 
+  if (nonnegative_check ("pos", pos) == FAILURE)
+    return FAILURE;
+
+  if (less_than_bitsize1 ("i", i, "pos", pos) == FAILURE)
+    return FAILURE;
+
   return SUCCESS;
 }
 
@@ -1389,19 +1470,6 @@ gfc_check_iand (gfc_expr *i, gfc_expr *j
 
 
 gfc_try
-gfc_check_ibclr (gfc_expr *i, gfc_expr *pos)
-{
-  if (type_check (i, 0, BT_INTEGER) == FAILURE)
-    return FAILURE;
-
-  if (type_check (pos, 1, BT_INTEGER) == FAILURE)
-    return FAILURE;
-
-  return SUCCESS;
-}
-
-
-gfc_try
 gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len)
 {
   if (type_check (i, 0, BT_INTEGER) == FAILURE)
@@ -1413,17 +1481,13 @@ gfc_check_ibits (gfc_expr *i, gfc_expr *
   if (type_check (len, 2, BT_INTEGER) == FAILURE)
     return FAILURE;
 
-  return SUCCESS;
-}
-
+  if (nonnegative_check ("pos", pos) == FAILURE)
+    return FAILURE;
 
-gfc_try
-gfc_check_ibset (gfc_expr *i, gfc_expr *pos)
-{
-  if (type_check (i, 0, BT_INTEGER) == FAILURE)
+  if (nonnegative_check ("len", len) == FAILURE)
     return FAILURE;
 
-  if (type_check (pos, 1, BT_INTEGER) == FAILURE)
+  if (less_than_bitsize2 ("i", i, "pos", pos, "len", len) == FAILURE)
     return FAILURE;
 
   return SUCCESS;
@@ -3646,6 +3710,22 @@ gfc_check_mvbits (gfc_expr *from, gfc_ex
   if (type_check (topos, 4, BT_INTEGER) == FAILURE)
     return FAILURE;
 
+  if (nonnegative_check ("frompos", frompos) == FAILURE)
+    return FAILURE;
+
+  if (nonnegative_check ("topos", topos) == FAILURE)
+    return FAILURE;
+
+  if (nonnegative_check ("len", len) == FAILURE)
+    return FAILURE;
+
+  if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len)
+      == FAILURE)
+    return FAILURE;
+
+  if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE)
+    return FAILURE;
+
   return SUCCESS;
 }