diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index fb3e52bbbbf9..40d2a304bd56 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2011-10-30 Steven G. Kargl + + PR fortran/50573 + * check.c (gfc_check_dshift): Update argument checking for BOZ. + Update checking SHIFT against BITSIZE of I or J. + * intrinsic.texi: Update docs for DSHIFTL and DSHIFTR. + 2011-10-28 Steven G. Kargl * check.c (gfc_check_atan_2): Typo in comment. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 0f54ccd4b632..d9b9a9cd5800 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1483,7 +1483,14 @@ gfc_check_dshift (gfc_expr *i, gfc_expr *j, gfc_expr *shift) 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 *j, gfc_expr *shift) 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; } diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 084cd15ea6f4..24af4d5ac7d5 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -3794,22 +3794,27 @@ Elemental function @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}. +@item @var{I} @tab Shall be of type @code{INTEGER} or a BOZ constant. +@item @var{J} @tab Shall be of type @code{INTEGER} or a BOZ constant. +If both @var{I} and @var{J} have integer type, then they shall have +the same kind type parameter. @var{I} and @var{J} shall not both be +BOZ constants. +@item @var{SHIFT} @tab Shall be of type @code{INTEGER}. It shall +be nonnegative. If @var{I} is not a BOZ constant, then @var{SHIFT} +shall be less than or equal to @code{BIT_SIZE(I)}; otherwise, +@var{SHIFT} shall be less than or equal to @code{BIT_SIZE(J)}. @end multitable @item @emph{Return value}: -The return value has same type and kind as @var{I}. +If either @var{I} or @var{J} is a BOZ constant, it is first converted +as if by the intrinsic function @code{INT} to an integer type with the +kind type parameter of the other. @item @emph{See also}: @ref{DSHIFTR} - @end table - @node DSHIFTR @section @code{DSHIFTR} --- Combined right shift @fnindex DSHIFTR @@ -3834,22 +3839,27 @@ Elemental function @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}. +@item @var{I} @tab Shall be of type @code{INTEGER} or a BOZ constant. +@item @var{J} @tab Shall be of type @code{INTEGER} or a BOZ constant. +If both @var{I} and @var{J} have integer type, then they shall have +the same kind type parameter. @var{I} and @var{J} shall not both be +BOZ constants. +@item @var{SHIFT} @tab Shall be of type @code{INTEGER}. It shall +be nonnegative. If @var{I} is not a BOZ constant, then @var{SHIFT} +shall be less than or equal to @code{BIT_SIZE(I)}; otherwise, +@var{SHIFT} shall be less than or equal to @code{BIT_SIZE(J)}. @end multitable @item @emph{Return value}: -The return value has same type and kind as @var{I}. +If either @var{I} or @var{J} is a BOZ constant, it is first converted +as if by the intrinsic function @code{INT} to an integer type with the +kind type parameter of the other. @item @emph{See also}: @ref{DSHIFTL} - @end table - @node DTIME @section @code{DTIME} --- Execution time subroutine (or function) @fnindex DTIME diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b1088ace33dd..0828817cee53 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-10-30 Steven G. Kargl + + PR fortran/50753 + * gfortran.dg/dshift_3.f90: New test. + 2011-10-30 John David Anglin * gcc.dg/scal-to-vec2.c (dg-options): Add -fno-common to options on diff --git a/gcc/testsuite/gfortran.dg/dshift_3.f90 b/gcc/testsuite/gfortran.dg/dshift_3.f90 new file mode 100644 index 000000000000..1f214c7d1c76 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dshift_3.f90 @@ -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