diff options
author | Thomas Koenig <tkoenig@gcc.gnu.org> | 2024-09-28 22:29:56 +0200 |
---|---|---|
committer | Thomas Koenig <tkoenig@gcc.gnu.org> | 2024-09-28 22:29:56 +0200 |
commit | 786773d4c12fd78e94f58193ff303cba19ca1b19 (patch) | |
tree | 9292ff99082d665b9c07e8220fa7f16b9aa96030 /gcc | |
parent | 1c928004cf0bc2131b6199905d11133d23a7cef2 (diff) | |
download | gcc-786773d4c12fd78e94f58193ff303cba19ca1b19.zip gcc-786773d4c12fd78e94f58193ff303cba19ca1b19.tar.gz gcc-786773d4c12fd78e94f58193ff303cba19ca1b19.tar.bz2 |
Implement FINDLOC for UNSIGNED.
gcc/fortran/ChangeLog:
* check.cc (intrinsic_type_check): Handle unsigned.
(gfc_check_findloc): Likewise.
* gfortran.texi: Include FINDLOC in unsigned documentation.
* iresolve.cc (gfc_resolve_findloc): Use INTEGER version
for UNSIGNED.
gcc/testsuite/ChangeLog:
* gfortran.dg/unsigned_33.f90: New test.
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/fortran/check.cc | 5 | ||||
-rw-r--r-- | gcc/fortran/gfortran.texi | 3 | ||||
-rw-r--r-- | gcc/fortran/iresolve.cc | 9 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/unsigned_33.f90 | 76 |
4 files changed, 90 insertions, 3 deletions
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 1da269f..dd79a49 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -643,7 +643,7 @@ intrinsic_type_check (gfc_expr *e, int n) { if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL && e->ts.type != BT_COMPLEX && e->ts.type != BT_CHARACTER - && e->ts.type != BT_LOGICAL) + && e->ts.type != BT_LOGICAL && e->ts.type != BT_UNSIGNED) { gfc_error ("%qs argument of %qs intrinsic at %L must be of intrinsic type", gfc_current_intrinsic_arg[n]->name, @@ -4267,6 +4267,9 @@ gfc_check_findloc (gfc_actual_arglist *ap) if ((a1 && !v1) || (!a1 && v1)) goto incompat; + if (flag_unsigned && gfc_invalid_unsigned_ops (a,v)) + goto incompat; + /* Check the kind of the characters argument match. */ if (a1 && v1 && a->ts.kind != v->ts.kind) goto incompat; diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index b42d009..7aa1642 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -2791,7 +2791,8 @@ As of now, the following intrinsics take unsigned arguments: @item @code{SUM}, @code{PRODUCT}, @code{MATMUL} and @code{DOT_PRODUCT} @item @code{IANY}, @code{IALL} and @code{IPARITY} @item @code{RANDOM_NUMBER} -@item @code{CSHIFT} and @code{EOSHIFT}. +@item @code{CSHIFT} and @code{EOSHIFT} +@item @code{FINDLOC}. @end itemize This list will grow in the near future. @c --------------------------------------------------------------------- diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index 5a1e0a6..9fb2212 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -1819,6 +1819,7 @@ gfc_resolve_findloc (gfc_expr *f, gfc_expr *array, gfc_expr *value, int i, j, idim; int fkind; int d_num; + bt type; /* See at the end of the function for why this is necessary. */ @@ -1897,9 +1898,15 @@ gfc_resolve_findloc (gfc_expr *f, gfc_expr *array, gfc_expr *value, gfc_convert_type_warn (back, &ts, 2, 0); } + /* Use the INTEGER library function for UNSIGNED. */ + if (array->ts.type != BT_UNSIGNED) + type = array->ts.type; + else + type = BT_INTEGER; + f->value.function.name = gfc_get_string (PREFIX ("%s%d_%c%d"), name, d_num, - gfc_type_letter (array->ts.type, true), + gfc_type_letter (type, true), gfc_type_abi_kind (&array->ts)); /* We only have a single library function, so we need to convert diff --git a/gcc/testsuite/gfortran.dg/unsigned_33.f90 b/gcc/testsuite/gfortran.dg/unsigned_33.f90 new file mode 100644 index 0000000..7ff11e6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_33.f90 @@ -0,0 +1,76 @@ +! { dg-do run } +! { dg-options "-funsigned" } +! Check compile-time simplification of FINDLOC +! Mostly lifted from findloc_5.f90. +program memain + implicit none + call test1 + call test2 +contains + subroutine test1 + unsigned, dimension(4) :: a1 + integer :: i1, i2, i3, i4 + unsigned, dimension(2,2) :: a, b + integer, dimension(2) :: t8, t9, t10 + unsigned, dimension(2,3) :: c + integer, dimension(3) :: t13 + integer, dimension(2) :: t14 + + a1 = [1u, 2u, 3u, 1u] + i1 = findloc(a1, 1u, dim=1) + if (i1 /= 1) stop 1 + i2 = findloc(a1, 2u, dim=1) + if (i2 /= 2) stop 2 + i3 = findloc(a1,3u, dim=1) + if (i3 /= 3) stop 3 + i4 = findloc(a1, 1u, dim=1, back=.true.) + if (i4 /= 4) stop 4 + a = reshape([1u,2u,3u,4u], [2,2]) + b = reshape([1u,2u,1u,2u], [2,2]) + t8 = findloc(a,5u) + if (any(t8 /= [0,0])) stop 8 + t9 = findloc(a,5u,back=.true.) + if (any(t9 /= [0,0])) stop 9 + c = reshape([1u,2u,2u,2u,-9u,6u], [2,3]) + t13 = findloc (c, value=2u, dim=1) + if (any(t13 /= [2,1,0])) stop 13 + t14 = findloc (c, value=2u, dim=2) + if (any(t14 /= [2,1])) stop 14 + end subroutine test1 + subroutine test2 + unsigned, dimension(4), parameter :: a1 = [1u, 2u, 3u, 1u] + integer, parameter :: i1 = findloc(a1, 1u, dim=1) + integer, parameter :: i2 = findloc(a1, 2u, dim=1) + integer, parameter :: i3 = findloc(a1, 3u, dim=1) + integer, parameter :: i4 = findloc(a1, 1u, dim=1, back=.true.) + integer, parameter :: i0 = findloc(a1, -1u, dim=1) + logical, dimension(4), parameter :: msk = [.false., .true., .true., .true.] + integer, parameter :: i4a = findloc(a1, 1u, dim=1, mask=msk) + integer, parameter :: i4b = findloc(a1, 1u, dim=1, mask=msk, back=.true.) + unsigned, dimension(2,2), parameter :: a = reshape([1u,2u,3u,4u], [2,2]), & + b = reshape([1u,2u,1u,2u], [2,2]) + integer, parameter, dimension(2) :: t8 = findloc(a, 5u), t9 = findloc(a, 5u, back=.true.) + integer, parameter, dimension(2) :: t10= findloc(a, 2u), t11= findloc(a, 2u, back=.true.) + logical, dimension(2,2), parameter :: lo = reshape([.true., .false., .true., .true. ], [2,2]) + integer, parameter, dimension(2) :: t12 = findloc(b,2u, mask=lo) + + unsigned, dimension(2,3), parameter :: c = reshape([1u,2u,2u,2u,-9u,6u], [2,3]) + integer, parameter, dimension(3) :: t13 = findloc(c, value=2u, dim=1) + integer, parameter, dimension(2) :: t14 = findloc(c, value=2u, dim=2) + + if (i1 /= 1) stop 1 + if (i2 /= 2) stop 2 + if (i3 /= 3) stop 3 + if (i4 /= 4) stop 4 + if (i0 /= 0) stop 5 + if (i4a /= 4) stop 6 + if (i4b /= 4) stop 7 + if (any(t8 /= [0,0])) stop 8 + if (any(t9 /= [0,0])) stop 9 + if (any(t10 /= [2,1])) stop 10 + if (any(t11 /= [2,1])) stop 11 + if (any(t12 /= [2,2])) stop 12 + if (any(t13 /= [2,1,0])) stop 13 + if (any(t14 /= [2,1])) stop 14 + end subroutine test2 +end program memain |