procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: intrinsic ISHFTC and missing optional argument SIZE [PR67277]

Browse source 
gcc/fortran/ChangeLog:

	PR fortran/67277
	* trans-intrinsic.cc (gfc_conv_intrinsic_ishftc): Handle optional
	dummy argument for SIZE passed to ISHFTC.  Set default value to
	BIT_SIZE(I) when missing.

gcc/testsuite/ChangeLog:

	PR fortran/67277
	* gfortran.dg/ishftc_optional_size_1.f90: New test.
This commit is contained in:
Harald Anlauf 2024-01-13 22:00:21 +01:00
parent 3f235afacf
commit 20da561652
2 changed files with 111 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
gcc/fortran/trans-intrinsic.cc
View file

@ -6863,9 +6863,23 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
if (num_args == 3)
{
gfc_expr *size = expr->value.function.actual->next->next->expr;
/* Use a library function for the 3 parameter version. */
tree int4type = gfc_get_int_type (4);
/* Treat optional SIZE argument when it is passed as an optional
dummy. If SIZE is absent, the default value is BIT_SIZE(I). */
if (size->expr_type == EXPR_VARIABLE
&& size->symtree->n.sym->attr.dummy
&& size->symtree->n.sym->attr.optional)
{
tree type_of_size = TREE_TYPE (args[2]);
args[2] = build3_loc (input_location, COND_EXPR, type_of_size,
gfc_conv_expr_present (size->symtree->n.sym),
args[2], fold_convert (type_of_size, nbits));
}
/* We convert the first argument to at least 4 bytes, and
convert back afterwards. This removes the need for library
functions for all argument sizes, and function will be

97
gcc/testsuite/gfortran.dg/ishftc_optional_size_1.f90 Normal file
View file

@ -0,0 +1,97 @@
! { dg-do run }
!
! PR fortran/67277 - ISHFTC and missing optional argument SIZE
module m
implicit none
contains
! Optional argument passed by reference
elemental function ishftc4_ref (i, shift, size_) result(r)
integer(4), intent(in) :: i
integer, intent(in) :: shift
integer, intent(in), optional :: size_
integer :: r
r = ishftc (i, shift=shift, size=size_)
end
elemental function ishftc1_ref (i, shift, size_) result(r)
integer(1), intent(in) :: i
integer, intent(in) :: shift
integer(1), intent(in), optional :: size_
integer(1) :: r
r = ishftc (i, shift=shift, size=size_)
end
! Array valued argument i
function ishftc4_ref_4 (i, shift, size_) result(r)
integer(4), intent(in) :: i(4)
integer, intent(in) :: shift
integer, intent(in), optional :: size_
integer :: r(size(i))
r = ishftc (i, shift=shift, size=size_)
end
! Optional argument passed by value
elemental function ishftc4_val (i, shift, size_) result(r)
integer(4), intent(in) :: i
integer, intent(in) :: shift
integer, value, optional :: size_
integer :: r
r = ishftc (i, shift=shift, size=size_)
end
elemental function ishftc1_val (i, shift, size_) result(r)
integer(1), intent(in) :: i
integer, intent(in) :: shift
integer(1), value, optional :: size_
integer(1) :: r
r = ishftc (i, shift=shift, size=size_)
end
! Array valued argument i
function ishftc4_val_4 (i, shift, size_) result(r)
integer(4), intent(in) :: i(4)
integer, intent(in) :: shift
integer, value, optional :: size_
integer :: r(size(i))
r = ishftc (i, shift=shift, size=size_)
end
end module m
program p
use m
implicit none
integer :: shift = 1
integer(4) :: i4 = 127, j4(4), k4(4)
integer(1) :: i1 = 127
integer(4) :: expect4
integer(1) :: expect1
! Scalar variants
expect4 = 2*i4
if (ishftc (i4, shift) /= expect4) stop 1
if (ishftc4_ref (i4, shift) /= expect4) stop 2
if (ishftc4_val (i4, shift) /= expect4) stop 3
expect1 = -2_1
if (ishftc (i1, shift) /= expect1) stop 4
if (ishftc1_ref (i1, shift) /= expect1) stop 5
if (ishftc1_val (i1, shift) /= expect1) stop 6
! Array arguments
expect4 = 2*i4
j4 = i4
k4 = ishftc (j4, shift)
if (any (k4 /= expect4)) stop 7
! The following works on x86_64 but might currently fail on other systems:
! (see PR113377)
! k4 = ishftc4_val_4 (j4, shift)
! if (any (k4 /= expect4)) stop 8
! The following currently segfaults (might be a scalarizer issue):
! (see PR113377)
! k4 = ishftc4_ref_4 (j4, shift)
! print *, k4
! if (any (k4 /= expect4)) stop 9
end program p