diff mbox series

[fortran] Implement IANY, IALL and IPARITY for unsigned

Message ID 0b226d7d-f4cb-42e4-a3a5-8c4d56a987c3@netcologne.de
State New
Headers show
Series [fortran] Implement IANY, IALL and IPARITY for unsigned | expand

Commit Message

Thomas Koenig Sept. 18, 2024, 8:20 p.m. UTC 
OK for trunk?

This is based on the previous submissions. Again, this does not
generate a new library version; rather it re-uses the signed
integer version already present in the library.

OK for trunk?

Previous submissions (without which this will not work):

https://gcc.gnu.org/pipermail/fortran/2024-September/060975.html
https://gcc.gnu.org/pipermail/fortran/2024-September/060987.html

gcc/fortran/ChangeLog:

	* check.cc (gfc_check_transf_bit_intrins): Handle unsigned.
	* gfortran.texi: Docment IANY, IALL and IPARITY for unsigned.
	* iresolve.cc (gfc_resolve_iall): Set flag to use integer
	if type is BT_UNSIGNED.
	(gfc_resolve_iany): Likewise.
	(gfc_resolve_iparity): Likewise.
	* simplify.cc (do_bit_and): Adjust asserts for BT_UNSIGNED.
	(do_bit_ior): Likewise.
	(do_bit_xor): Likewise

gcc/testsuite/ChangeLog:

	* gfortran.dg/unsigned_29.f90: New test.

  gcc/fortran/check.cc                      | 14 ++++++-
  gcc/fortran/gfortran.texi                 |  1 +
  gcc/fortran/iresolve.cc                   |  6 +--
  gcc/fortran/simplify.cc                   | 51 +++++++++++++++++++----
  gcc/testsuite/gfortran.dg/unsigned_29.f90 | 40 ++++++++++++++++++
  5 files changed, 99 insertions(+), 13 deletions(-)
  create mode 100644 gcc/testsuite/gfortran.dg/unsigned_29.f90

+    if (any(v_any_2 /= [4291624908u, 4210752250u])) error stop 16
+    if (any(v_parity_1 /= [267390960u, 1717986918u])) error stop 17
+    if (any(v_parity_2 /= [869020620u, 1515870810u])) error stop 18
+  end subroutine test2
+end program memain

Comments

Andre Vehreschild Sept. 19, 2024, 10:01 a.m. UTC | #1 
Hi Thomas,

this look fine to. Ok for trunk.

Thanks for the patch,
	Andre

On Wed, 18 Sep 2024 22:20:44 +0200
Thomas Koenig <tkoenig@netcologne.de> wrote:

> OK for trunk?
>
> This is based on the previous submissions. Again, this does not
> generate a new library version; rather it re-uses the signed
> integer version already present in the library.
>
> OK for trunk?
>
> Previous submissions (without which this will not work):
>
> https://gcc.gnu.org/pipermail/fortran/2024-September/060975.html
> https://gcc.gnu.org/pipermail/fortran/2024-September/060987.html
>
> gcc/fortran/ChangeLog:
>
> 	* check.cc (gfc_check_transf_bit_intrins): Handle unsigned.
> 	* gfortran.texi: Docment IANY, IALL and IPARITY for unsigned.
> 	* iresolve.cc (gfc_resolve_iall): Set flag to use integer
> 	if type is BT_UNSIGNED.
> 	(gfc_resolve_iany): Likewise.
> 	(gfc_resolve_iparity): Likewise.
> 	* simplify.cc (do_bit_and): Adjust asserts for BT_UNSIGNED.
> 	(do_bit_ior): Likewise.
> 	(do_bit_xor): Likewise
>
> gcc/testsuite/ChangeLog:
>
> 	* gfortran.dg/unsigned_29.f90: New test.
>
>   gcc/fortran/check.cc                      | 14 ++++++-
>   gcc/fortran/gfortran.texi                 |  1 +
>   gcc/fortran/iresolve.cc                   |  6 +--
>   gcc/fortran/simplify.cc                   | 51 +++++++++++++++++++----
>   gcc/testsuite/gfortran.dg/unsigned_29.f90 | 40 ++++++++++++++++++
>   5 files changed, 99 insertions(+), 13 deletions(-)
>   create mode 100644 gcc/testsuite/gfortran.dg/unsigned_29.f90
>
> diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
> index 7c630dd73f4..533c9d7d343 100644
> --- a/gcc/fortran/check.cc
> +++ b/gcc/fortran/check.cc
> @@ -4430,7 +4430,19 @@ gfc_check_mask (gfc_expr *i, gfc_expr *kind)
>   bool
>   gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
>   {
> -  if (ap->expr->ts.type != BT_INTEGER)
> +  bt type = ap->expr->ts.type;
> +
> +  if (flag_unsigned)
> +    {
> +      if (type != BT_INTEGER && type != BT_UNSIGNED)
> +	{
> +	  gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
> +		     "or UNSIGNED", gfc_current_intrinsic_arg[0]->name,
> +		     gfc_current_intrinsic, &ap->expr->where);
> +	  return false;
> +	}
> +    }
> +  else if (ap->expr->ts.type != BT_INTEGER)
>       {
>         gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
>                    gfc_current_intrinsic_arg[0]->name,
> diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
> index e5ffe67eeee..3eb8039c09f 100644
> --- a/gcc/fortran/gfortran.texi
> +++ b/gcc/fortran/gfortran.texi
> @@ -2789,6 +2789,7 @@ As of now, the following intrinsics take unsigned
> arguments:
>   @item @code{RANGE}
>   @item @code{TRANSFER}
>   @item @code{SUM}, @code{PRODUCT}, @code{MATMUL} and @code{DOT_PRODUCT}
> +@item @code{IANY}, @code{IALL} and @code{IPARITY}
>   @end itemize
>   This list will grow in the near future.
>   @c ---------------------------------------------------------------------
> diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
> index 92a591cf6d7..58a1821ef10 100644
> --- a/gcc/fortran/iresolve.cc
> +++ b/gcc/fortran/iresolve.cc
> @@ -1195,7 +1195,7 @@ gfc_resolve_hypot (gfc_expr *f, gfc_expr *x,
> gfc_expr *y ATTRIBUTE_UNUSED)
>   void
>   gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
> gfc_expr *mask)
>   {
> -  resolve_transformational ("iall", f, array, dim, mask);
> +  resolve_transformational ("iall", f, array, dim, mask, true);
>   }
>
>
> @@ -1223,7 +1223,7 @@ gfc_resolve_iand (gfc_expr *f, gfc_expr *i,
> gfc_expr *j)
>   void
>   gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
> gfc_expr *mask)
>   {
> -  resolve_transformational ("iany", f, array, dim, mask);
> +  resolve_transformational ("iany", f, array, dim, mask, true);
>   }
>
>
> @@ -1429,7 +1429,7 @@ gfc_resolve_long (gfc_expr *f, gfc_expr *a)
>   void
>   gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
> gfc_expr *mask)
>   {
> -  resolve_transformational ("iparity", f, array, dim, mask);
> +  resolve_transformational ("iparity", f, array, dim, mask, true);
>   }
>
>
> diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
> index e5681c42a48..bd2f6485c95 100644
> --- a/gcc/fortran/simplify.cc
> +++ b/gcc/fortran/simplify.cc
> @@ -3401,9 +3401,20 @@ gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
>   static gfc_expr *
>   do_bit_and (gfc_expr *result, gfc_expr *e)
>   {
> -  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
> -  gcc_assert (result->ts.type == BT_INTEGER
> -	      && result->expr_type == EXPR_CONSTANT);
> +  if (flag_unsigned)
> +    {
> +      gcc_assert ((e->ts.type == BT_INTEGER || e->ts.type == BT_UNSIGNED)
> +		  && e->expr_type == EXPR_CONSTANT);
> +      gcc_assert ((result->ts.type == BT_INTEGER
> +		   || result->ts.type == BT_UNSIGNED)
> +		  && result->expr_type == EXPR_CONSTANT);
> +    }
> +  else
> +    {
> +      gcc_assert (e->ts.type == BT_INTEGER && e->expr_type ==
> EXPR_CONSTANT);
> +      gcc_assert (result->ts.type == BT_INTEGER
> +		  && result->expr_type == EXPR_CONSTANT);
> +    }
>
>     mpz_and (result->value.integer, result->value.integer,
> e->value.integer);
>     return result;
> @@ -3420,9 +3431,20 @@ gfc_simplify_iall (gfc_expr *array, gfc_expr
> *dim, gfc_expr *mask)
>   static gfc_expr *
>   do_bit_ior (gfc_expr *result, gfc_expr *e)
>   {
> -  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
> -  gcc_assert (result->ts.type == BT_INTEGER
> -	      && result->expr_type == EXPR_CONSTANT);
> +  if (flag_unsigned)
> +    {
> +      gcc_assert ((e->ts.type == BT_INTEGER || e->ts.type == BT_UNSIGNED)
> +		  && e->expr_type == EXPR_CONSTANT);
> +      gcc_assert ((result->ts.type == BT_INTEGER
> +		   || result->ts.type == BT_UNSIGNED)
> +		  && result->expr_type == EXPR_CONSTANT);
> +    }
> +  else
> +    {
> +      gcc_assert (e->ts.type == BT_INTEGER && e->expr_type ==
> EXPR_CONSTANT);
> +      gcc_assert (result->ts.type == BT_INTEGER
> +		  && result->expr_type == EXPR_CONSTANT);
> +    }
>
>     mpz_ior (result->value.integer, result->value.integer,
> e->value.integer);
>     return result;
> @@ -3884,9 +3906,20 @@ gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
>   static gfc_expr *
>   do_bit_xor (gfc_expr *result, gfc_expr *e)
>   {
> -  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
> -  gcc_assert (result->ts.type == BT_INTEGER
> -	      && result->expr_type == EXPR_CONSTANT);
> +  if (flag_unsigned)
> +    {
> +      gcc_assert ((e->ts.type == BT_INTEGER || e->ts.type == BT_UNSIGNED)
> +		  && e->expr_type == EXPR_CONSTANT);
> +      gcc_assert ((result->ts.type == BT_INTEGER
> +		   || result->ts.type == BT_UNSIGNED)
> +		  && result->expr_type == EXPR_CONSTANT);
> +    }
> +  else
> +    {
> +      gcc_assert (e->ts.type == BT_INTEGER && e->expr_type ==
> EXPR_CONSTANT);
> +      gcc_assert (result->ts.type == BT_INTEGER
> +		  && result->expr_type == EXPR_CONSTANT);
> +    }
>
>     mpz_xor (result->value.integer, result->value.integer,
> e->value.integer);
>     return result;
> diff --git a/gcc/testsuite/gfortran.dg/unsigned_29.f90
> b/gcc/testsuite/gfortran.dg/unsigned_29.f90
> new file mode 100644
> index 00000000000..fc648aa6f52
> --- /dev/null
> +++ b/gcc/testsuite/gfortran.dg/unsigned_29.f90
> @@ -0,0 +1,40 @@
> +! { dg-do run }
> +! { dg-options "-funsigned" }
> +program memain
> +  implicit none
> +  call test1
> +  call test2
> +contains
> +  subroutine test1
> +    unsigned, dimension(2,2) :: v
> +    integer(8), dimension(2,2) :: i
> +    v = reshape([4278255360u, 4042322160u, 3435973836u, 2863311530u],[2,2])
> +    i = int(v,8)
> +    if (iall(v) /= 2147516416u) error stop 1
> +    if (iany(v) /= 4294901758u) error stop 2
> +    if (iparity(v) /= 1771465110u) error stop 3
> +    if (any(iall(v,dim=1) /= [4026593280u, 2290649224u])) error stop 4
> +    if (any(iall(v,dim=2) /= [3422604288u, 2694881440u])) error stop 5
> +    if (any(iany(v,dim=1) /= [4293984240u, 4008636142u])) error stop 6
> +    if (any(iany(v,dim=2) /= [4291624908u, 4210752250u])) error stop 7
> +    if (any(iparity(v,dim=1) /= [267390960u, 1717986918u])) error stop 8
> +    if (any(iparity(v,dim=2) /= [869020620u, 1515870810u])) error stop 9
> +  end subroutine test1
> +  subroutine test2
> +    unsigned, dimension(2,2), parameter :: v &
> +         = reshape([4278255360u, 4042322160u, 3435973836u,
> 2863311530u],[2,2])
> +    unsigned, parameter :: v_all = iall(v), v_any = iany(v), v_parity =
> iparity(v)
> +    unsigned, parameter, dimension(2) :: v_all_1 = iall(v,dim=1),
> v_all_2 = iall(v,dim=2)
> +    unsigned, parameter, dimension(2) :: v_any_1 = iany(v,dim=1),
> v_any_2 = iany(v,dim=2)
> +    unsigned, parameter, dimension(2) :: v_parity_1 = iparity(v,dim=1),
> v_parity_2 = iparity(v,dim=2)
> +    if (v_all /= 2147516416u) error stop 10
> +    if (v_any /= 4294901758u) error stop 11
> +    if (v_parity /= 1771465110u) error stop 12
> +    if (any(v_all_1 /= [4026593280u, 2290649224u])) error stop 13
> +    if (any(v_all_2 /= [3422604288u, 2694881440u])) error stop 14
> +    if (any(v_any_1 /= [4293984240u, 4008636142u])) error stop 15
> +    if (any(v_any_2 /= [4291624908u, 4210752250u])) error stop 16
> +    if (any(v_parity_1 /= [267390960u, 1717986918u])) error stop 17
> +    if (any(v_parity_2 /= [869020620u, 1515870810u])) error stop 18
> +  end subroutine test2
> +end program memain
>
>
>


--
Andre Vehreschild * Email: vehre ad gmx dot de
diff mbox series

Patch

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 7c630dd73f4..533c9d7d343 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -4430,7 +4430,19 @@  gfc_check_mask (gfc_expr *i, gfc_expr *kind)
  bool
  gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
  {
-  if (ap->expr->ts.type != BT_INTEGER)
+  bt type = ap->expr->ts.type;
+
+  if (flag_unsigned)
+    {
+      if (type != BT_INTEGER && type != BT_UNSIGNED)
+	{
+	  gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER "
+		     "or UNSIGNED", gfc_current_intrinsic_arg[0]->name,
+		     gfc_current_intrinsic, &ap->expr->where);
+	  return false;
+	}
+    }
+  else if (ap->expr->ts.type != BT_INTEGER)
      {
        gfc_error ("%qs argument of %qs intrinsic at %L must be INTEGER",
                   gfc_current_intrinsic_arg[0]->name,
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index e5ffe67eeee..3eb8039c09f 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -2789,6 +2789,7 @@  As of now, the following intrinsics take unsigned 
arguments:
  @item @code{RANGE}
  @item @code{TRANSFER}
  @item @code{SUM}, @code{PRODUCT}, @code{MATMUL} and @code{DOT_PRODUCT}
+@item @code{IANY}, @code{IALL} and @code{IPARITY}
  @end itemize
  This list will grow in the near future.
  @c ---------------------------------------------------------------------
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 92a591cf6d7..58a1821ef10 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -1195,7 +1195,7 @@  gfc_resolve_hypot (gfc_expr *f, gfc_expr *x, 
gfc_expr *y ATTRIBUTE_UNUSED)
  void
  gfc_resolve_iall (gfc_expr *f, gfc_expr *array, gfc_expr *dim, 
gfc_expr *mask)
  {
-  resolve_transformational ("iall", f, array, dim, mask);
+  resolve_transformational ("iall", f, array, dim, mask, true);
  }


@@ -1223,7 +1223,7 @@  gfc_resolve_iand (gfc_expr *f, gfc_expr *i, 
gfc_expr *j)
  void
  gfc_resolve_iany (gfc_expr *f, gfc_expr *array, gfc_expr *dim, 
gfc_expr *mask)
  {
-  resolve_transformational ("iany", f, array, dim, mask);
+  resolve_transformational ("iany", f, array, dim, mask, true);
  }


@@ -1429,7 +1429,7 @@  gfc_resolve_long (gfc_expr *f, gfc_expr *a)
  void
  gfc_resolve_iparity (gfc_expr *f, gfc_expr *array, gfc_expr *dim, 
gfc_expr *mask)
  {
-  resolve_transformational ("iparity", f, array, dim, mask);
+  resolve_transformational ("iparity", f, array, dim, mask, true);
  }


diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index e5681c42a48..bd2f6485c95 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -3401,9 +3401,20 @@  gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
  static gfc_expr *
  do_bit_and (gfc_expr *result, gfc_expr *e)
  {
-  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
-  gcc_assert (result->ts.type == BT_INTEGER
-	      && result->expr_type == EXPR_CONSTANT);
+  if (flag_unsigned)
+    {
+      gcc_assert ((e->ts.type == BT_INTEGER || e->ts.type == BT_UNSIGNED)
+		  && e->expr_type == EXPR_CONSTANT);
+      gcc_assert ((result->ts.type == BT_INTEGER
+		   || result->ts.type == BT_UNSIGNED)
+		  && result->expr_type == EXPR_CONSTANT);
+    }
+  else
+    {
+      gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == 
EXPR_CONSTANT);
+      gcc_assert (result->ts.type == BT_INTEGER
+		  && result->expr_type == EXPR_CONSTANT);
+    }

    mpz_and (result->value.integer, result->value.integer, 
e->value.integer);
    return result;
@@ -3420,9 +3431,20 @@  gfc_simplify_iall (gfc_expr *array, gfc_expr 
*dim, gfc_expr *mask)
  static gfc_expr *
  do_bit_ior (gfc_expr *result, gfc_expr *e)
  {
-  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
-  gcc_assert (result->ts.type == BT_INTEGER
-	      && result->expr_type == EXPR_CONSTANT);
+  if (flag_unsigned)
+    {
+      gcc_assert ((e->ts.type == BT_INTEGER || e->ts.type == BT_UNSIGNED)
+		  && e->expr_type == EXPR_CONSTANT);
+      gcc_assert ((result->ts.type == BT_INTEGER
+		   || result->ts.type == BT_UNSIGNED)
+		  && result->expr_type == EXPR_CONSTANT);
+    }
+  else
+    {
+      gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == 
EXPR_CONSTANT);
+      gcc_assert (result->ts.type == BT_INTEGER
+		  && result->expr_type == EXPR_CONSTANT);
+    }

    mpz_ior (result->value.integer, result->value.integer, 
e->value.integer);
    return result;
@@ -3884,9 +3906,20 @@  gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
  static gfc_expr *
  do_bit_xor (gfc_expr *result, gfc_expr *e)
  {
-  gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
-  gcc_assert (result->ts.type == BT_INTEGER
-	      && result->expr_type == EXPR_CONSTANT);
+  if (flag_unsigned)
+    {
+      gcc_assert ((e->ts.type == BT_INTEGER || e->ts.type == BT_UNSIGNED)
+		  && e->expr_type == EXPR_CONSTANT);
+      gcc_assert ((result->ts.type == BT_INTEGER
+		   || result->ts.type == BT_UNSIGNED)
+		  && result->expr_type == EXPR_CONSTANT);
+    }
+  else
+    {
+      gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == 
EXPR_CONSTANT);
+      gcc_assert (result->ts.type == BT_INTEGER
+		  && result->expr_type == EXPR_CONSTANT);
+    }

    mpz_xor (result->value.integer, result->value.integer, 
e->value.integer);
    return result;
diff --git a/gcc/testsuite/gfortran.dg/unsigned_29.f90 
b/gcc/testsuite/gfortran.dg/unsigned_29.f90
new file mode 100644
index 00000000000..fc648aa6f52
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_29.f90
@@ -0,0 +1,40 @@ 
+! { dg-do run }
+! { dg-options "-funsigned" }
+program memain
+  implicit none
+  call test1
+  call test2
+contains
+  subroutine test1
+    unsigned, dimension(2,2) :: v
+    integer(8), dimension(2,2) :: i
+    v = reshape([4278255360u, 4042322160u, 3435973836u, 2863311530u],[2,2])
+    i = int(v,8)
+    if (iall(v) /= 2147516416u) error stop 1
+    if (iany(v) /= 4294901758u) error stop 2
+    if (iparity(v) /= 1771465110u) error stop 3
+    if (any(iall(v,dim=1) /= [4026593280u, 2290649224u])) error stop 4
+    if (any(iall(v,dim=2) /= [3422604288u, 2694881440u])) error stop 5
+    if (any(iany(v,dim=1) /= [4293984240u, 4008636142u])) error stop 6
+    if (any(iany(v,dim=2) /= [4291624908u, 4210752250u])) error stop 7
+    if (any(iparity(v,dim=1) /= [267390960u, 1717986918u])) error stop 8
+    if (any(iparity(v,dim=2) /= [869020620u, 1515870810u])) error stop 9
+  end subroutine test1
+  subroutine test2
+    unsigned, dimension(2,2), parameter :: v &
+         = reshape([4278255360u, 4042322160u, 3435973836u, 
2863311530u],[2,2])
+    unsigned, parameter :: v_all = iall(v), v_any = iany(v), v_parity = 
iparity(v)
+    unsigned, parameter, dimension(2) :: v_all_1 = iall(v,dim=1), 
v_all_2 = iall(v,dim=2)
+    unsigned, parameter, dimension(2) :: v_any_1 = iany(v,dim=1), 
v_any_2 = iany(v,dim=2)
+    unsigned, parameter, dimension(2) :: v_parity_1 = iparity(v,dim=1), 
v_parity_2 = iparity(v,dim=2)
+    if (v_all /= 2147516416u) error stop 10
+    if (v_any /= 4294901758u) error stop 11
+    if (v_parity /= 1771465110u) error stop 12
+    if (any(v_all_1 /= [4026593280u, 2290649224u])) error stop 13
+    if (any(v_all_2 /= [3422604288u, 2694881440u])) error stop 14
+    if (any(v_any_1 /= [4293984240u, 4008636142u])) error stop 15