[PATCH] PR fortran/50573 -- Fix checking of dshift{lr} arguments

[Steve Kargl <sgk@troutmask.apl.washington.edu>]

[-- Attachment #1: Type: text/plain, Size: 539 bytes --]

The attached patch tightens the checking of the arguments
of the dshiftl and dshiftr argument.  It also does a kind
type conversion when either I or J is a BOZ to the kind 
type of the non-BOZ I or J.

OK for trunk?


2011-10-27  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/50573
	* check.c (gfc_check_dshift): Tighten the checks on I, J, and SHIFT.  If I or
 	J is a BOZ, convert to the kind type of the other.
 
2011-10-27  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/50573
	* gfortran.dg/dshift_3.f90: New test.


-- 
Steve

[-- Attachment #2: dshift.diff --]
[-- Type: text/x-diff, Size: 3731 bytes --]

Index: fortran/check.c
===================================================================
--- fortran/check.c	(revision 180567)
+++ fortran/check.c	(working copy)
@@ -934,7 +934,7 @@ null_arg:
 gfc_try
 gfc_check_atan_2 (gfc_expr *y, gfc_expr *x)
 {
-  /* gfc_notify_std would be a wast of time as the return value
+  /* gfc_notify_std would be a waste of time as the return value
      is seemingly used only for the generic resolution.  The error
      will be: Too many arguments.  */
   if ((gfc_option.allow_std & GFC_STD_F2008) == 0)
@@ -1483,7 +1483,14 @@ gfc_check_dshift (gfc_expr *i, gfc_expr 
   if (type_check (j, 1, BT_INTEGER) == FAILURE)
     return FAILURE;
 
-  if (same_type_check (i, 0, j, 1) == FAILURE)
+  if (i->is_boz && j->is_boz)
+    {
+      gfc_error ("'I' at %L and 'J' at %L cannot both be BOZ literal "
+		 "constants", &i->where, &j->where);
+      return FAILURE;
+    }
+
+  if (!i->is_boz && !j->is_boz && same_type_check (i, 0, j, 1) == FAILURE)
     return FAILURE;
 
   if (type_check (shift, 2, BT_INTEGER) == FAILURE)
@@ -1492,8 +1499,18 @@ gfc_check_dshift (gfc_expr *i, gfc_expr 
   if (nonnegative_check ("SHIFT", shift) == FAILURE)
     return FAILURE;
 
-  if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
-    return FAILURE;
+  if (i->is_boz)
+    {
+      if (less_than_bitsize1 ("J", j, "SHIFT", shift, true) == FAILURE)
+    	return FAILURE;
+      i->ts.kind = j->ts.kind;
+    }
+  else
+    {
+      if (less_than_bitsize1 ("I", i, "SHIFT", shift, true) == FAILURE)
+    	return FAILURE;
+      j->ts.kind = i->ts.kind;
+    }
 
   return SUCCESS;
 }
@@ -2710,6 +2727,16 @@ gfc_check_nearest (gfc_expr *x, gfc_expr
   if (type_check (s, 1, BT_REAL) == FAILURE)
     return FAILURE;
 
+  if (s->expr_type == EXPR_CONSTANT)
+    {
+      if (mpfr_sgn (s->value.real) == 0)
+	{
+	  gfc_error ("Argument 'S' of NEAREST at %L shall not be zero",
+		     &s->where);
+	  return FAILURE;
+	}
+    }
+
   return SUCCESS;
 }
 
Index: testsuite/gfortran.dg/dshift_3.f90
===================================================================
--- testsuite/gfortran.dg/dshift_3.f90	(revision 0)
+++ testsuite/gfortran.dg/dshift_3.f90	(revision 0)
@@ -0,0 +1,34 @@
+! { dg-do compile }
+! PR fortran/50753
+subroutine foo(i, j, k)
+
+   implicit none
+
+   integer(4), intent(in) :: i, j
+   integer(8), intent(in) :: k
+
+   print *, dshiftl(i,      j, 134)     ! { dg-error "must be less than or equal" }
+   print *, dshiftl(z'FFF', j, 134)     ! { dg-error "must be less than or equal" }
+   print *, dshiftl(i, j, -10)          ! { dg-error "must be nonnegative" }
+   print *, dshiftl(z'FFF', z'EEE', 10) ! { dg-error "cannot both be" }
+   print *, dshiftl(z'FFF', j, 10)
+   print *, dshiftl(i, z'EEE', 10)
+   print *, dshiftl(i, j, 10)
+   print *, dshiftl(i, k, 10)           ! { dg-error "must be the same type and kind" }
+   print *, dshiftl(k, j, 10)           ! { dg-error "must be the same type and kind" }
+   print *, dshiftl(i, j, k)
+   print *, dshiftl(i, j, z'd')
+
+   print *, dshiftr(i,      j, 134)     ! { dg-error "must be less than or equal" }
+   print *, dshiftr(z'FFF', j, 134)     ! { dg-error "must be less than or equal" }
+   print *, dshiftr(i, j, -10)          ! { dg-error "must be nonnegative" }
+   print *, dshiftr(z'FFF', z'EEE', 10) ! { dg-error "cannot both be" }
+   print *, dshiftr(z'FFF', j, 10)
+   print *, dshiftr(i, z'EEE', 10)
+   print *, dshiftr(i, j, 10)
+   print *, dshiftr(i, k, 10)           ! { dg-error "must be the same type and kind" }
+   print *, dshiftr(k, j, 10)           ! { dg-error "must be the same type and kind" }
+   print *, dshiftr(i, j, k)
+   print *, dshiftr(i, j, z'd')
+
+end subroutine foo