https://gcc.gnu.org/g:10c75e2a2a15e35bd6e70503ef7e3e119ae90775
commit r15-4865-g10c75e2a2a15e35bd6e70503ef7e3e119ae90775
Author: Thomas Koenig <tkoe...@gcc.gnu.org>
Date: Tue Oct 29 21:08:59 2024 +0100
Add UMASKR and UMASKL intrinsics.
gcc/fortran/ChangeLog:
* check.cc (gfc_check_mask): Handle BT_INSIGNED.
* gfortran.h (enum gfc_isym_id): Add GFC_ISYM_UMASKL and
GFC_ISYM_UMASKR.
* gfortran.texi: List UMASKL and UMASKR, remove unsigned future
unsigned arguments for MASKL and MASKR.
* intrinsic.cc (add_functions): Add UMASKL and UMASKR.
* intrinsic.h (gfc_simplify_umaskl): New function.
(gfc_simplify_umaskr): New function.
(gfc_resolve_umasklr): New function.
* intrinsic.texi: Document UMASKL and UMASKR.
* iresolve.cc (gfc_resolve_umasklr): New function.
* simplify.cc (gfc_simplify_umaskr): New function.
(gfc_simplify_umaskl): New function.
gcc/testsuite/ChangeLog:
* gfortran.dg/unsigned_39.f90: New test.
Diff:
---
gcc/fortran/check.cc | 9 +++-
gcc/fortran/gfortran.h | 2 +
gcc/fortran/gfortran.texi | 9 +---
gcc/fortran/intrinsic.cc | 16 +++++++
gcc/fortran/intrinsic.h | 3 ++
gcc/fortran/intrinsic.texi | 75 +++++++++++++++++++++++++++++
gcc/fortran/iresolve.cc | 14 ++++++
gcc/fortran/simplify.cc | 78 +++++++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/unsigned_39.f90 | 29 ++++++++++++
9 files changed, 226 insertions(+), 9 deletions(-)
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 304ca1b9ae82..2d4af8e7df33 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -4466,7 +4466,12 @@ gfc_check_mask (gfc_expr *i, gfc_expr *kind)
{
int k;
- if (!type_check (i, 0, BT_INTEGER))
+ if (flag_unsigned)
+ {
+ if (!type_check2 (i, 0, BT_INTEGER, BT_UNSIGNED))
+ return false;
+ }
+ else if (!type_check (i, 0, BT_INTEGER))
return false;
if (!nonnegative_check ("I", i))
@@ -4478,7 +4483,7 @@ gfc_check_mask (gfc_expr *i, gfc_expr *kind)
if (kind)
gfc_extract_int (kind, &k);
else
- k = gfc_default_integer_kind;
+ k = i->ts.type == BT_UNSIGNED ? gfc_default_unsigned_kind :
gfc_default_integer_kind;
if (!less_than_bitsizekind ("I", i, k))
return false;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index dd599bc97a26..309095d74d5c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -699,6 +699,8 @@ enum gfc_isym_id
GFC_ISYM_UBOUND,
GFC_ISYM_UCOBOUND,
GFC_ISYM_UMASK,
+ GFC_ISYM_UMASKL,
+ GFC_ISYM_UMASKR,
GFC_ISYM_UNLINK,
GFC_ISYM_UNPACK,
GFC_ISYM_VERIFY,
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 3b2691649b0e..429d8461f8f7 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -2825,16 +2825,11 @@ The following intrinsics take unsigned arguments:
The following intinsics are enabled with @option{-funsigned}:
@itemize @bullet
@item @code{UINT}, @pxref{UINT}
+@item @code{UMASKL}, @pxref{UMASKL}
+@item @code{UMASKR}, @pxref{UMASKR}
@item @code{SELECTED_UNSIGNED_KIND}, @pxref{SELECTED_UNSIGNED_KIND}
@end itemize
-The following intrinsics will take unsigned arguments
-in the future:
-@itemize @bullet
-@item @code{MASKL}, @pxref{MASKL}
-@item @code{MASKR}, @pxref{MASKR}
-@end itemize
-
The following intrinsics are not yet implemented in GNU Fortran,
but will take unsigned arguments once they have been:
@itemize @bullet
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 83b65d34e433..3fb1c63bbd42 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -2568,6 +2568,22 @@ add_functions (void)
make_generic ("maskr", GFC_ISYM_MASKR, GFC_STD_F2008);
+ add_sym_2 ("umaskl", GFC_ISYM_UMASKL, CLASS_ELEMENTAL, ACTUAL_NO,
+ BT_INTEGER, di, GFC_STD_F2008,
+ gfc_check_mask, gfc_simplify_umaskl, gfc_resolve_umasklr,
+ i, BT_INTEGER, di, REQUIRED,
+ kind, BT_INTEGER, di, OPTIONAL);
+
+ make_generic ("umaskl", GFC_ISYM_UMASKL, GFC_STD_F2008);
+
+ add_sym_2 ("umaskr", GFC_ISYM_UMASKR, CLASS_ELEMENTAL, ACTUAL_NO,
+ BT_INTEGER, di, GFC_STD_F2008,
+ gfc_check_mask, gfc_simplify_umaskr, gfc_resolve_umasklr,
+ i, BT_INTEGER, di, REQUIRED,
+ kind, BT_INTEGER, di, OPTIONAL);
+
+ make_generic ("umaskr", GFC_ISYM_UMASKR, GFC_STD_F2008);
+
add_sym_2 ("matmul", GFC_ISYM_MATMUL, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
BT_REAL, dr, GFC_STD_F95,
gfc_check_matmul, gfc_simplify_matmul, gfc_resolve_matmul,
ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED);
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index ea29219819d3..61d85eedc693 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -434,6 +434,8 @@ gfc_expr *gfc_simplify_transpose (gfc_expr *);
gfc_expr *gfc_simplify_trim (gfc_expr *);
gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ucobound (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_umaskl (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_umaskr (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_unpack (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_xor (gfc_expr *, gfc_expr *);
@@ -566,6 +568,7 @@ void gfc_resolve_maxval (gfc_expr *, gfc_expr *, gfc_expr
*, gfc_expr *);
void gfc_resolve_mclock (gfc_expr *);
void gfc_resolve_mclock8 (gfc_expr *);
void gfc_resolve_mask (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_umasklr (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_merge (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_min (gfc_expr *, gfc_actual_arglist *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index f47fa3bbd5e8..9d0b752670b4 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -323,6 +323,8 @@ Some basic guidelines for editing this document:
* @code{UCOBOUND}: UCOBOUND, Upper codimension bounds of an array
* @code{UINT}: UINT, Convert to an unsigned integer type
* @code{UMASK}: UMASK, Set the file creation mask
+* @code{UMASKL}: UMASKL, Unsigned left justified mask
+* @code{UMASKR}: UMASKR, Unsigned right justified mask
* @code{UNLINK}: UNLINK, Remove a file from the file system
* @code{UNPACK}: UNPACK, Unpack an array of rank one into an array
* @code{VERIFY}: VERIFY, Scan a string for the absence of a set of
characters
@@ -14964,6 +14966,79 @@ Subroutine, function
@end table
+@node UMASKL
+@section @code{UMASKL} --- Unsigned left justified mask
+@fnindex UMASKL
+@cindex mask, left justified
+
+@table @asis
+@item @emph{Description}:
+@code{UMASKL(I[, KIND])} has its leftmost @var{I} bits set to 1, and the
+remaining bits set to 0.
+
+@item @emph{Standard}:
+Extension (@pxref{Unsigned integers})
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = UMASKL(I[, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of type @code{UNSIGNED}.
+@item @var{KIND} @tab Shall be a scalar constant expression of type
+@code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{UNSIGNED}. If @var{KIND} is present, it
+specifies the kind value of the return type; otherwise, it is of the
+default unsigned kind.
+
+@item @emph{See also}:
+@ref{MASKL}, @*
+@ref{MASKR}, @*
+@ref{UMASKR}
+@end table
+
+@node UMASKR
+@section @code{UMASKR} --- Unsigned right justified mask
+@fnindex UMASKR
+@cindex mask, right justified
+
+@table @asis
+@item @emph{Description}:
+@code{UMASKL(I[, KIND])} has its rightmost @var{I} bits set to 1, and the
+remaining bits set to 0.
+
+@item @emph{Standard}:
+Extension (@pxref{Unsigned integers})
+
+@item @emph{Class}:
+Elemental function
+
+@item @emph{Syntax}:
+@code{RESULT = MASKR(I[, KIND])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{I} @tab Shall be of type @code{UNSIGNED}.
+@item @var{KIND} @tab Shall be a scalar constant expression of type
+@code{INTEGER}.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{UNSIGNED}. If @var{KIND} is present, it
+specifies the kind value of the return type; otherwise, it is of the
+default integer kind.
+
+@item @emph{See also}:
+@ref{MASKL}, @*
+@ref{MASKR}, @*
+@ref{UMASKL}
+@end table
@node UNLINK
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index d8b216bcc67c..6adc63043ebb 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -2012,6 +2012,20 @@ gfc_resolve_mask (gfc_expr *f, gfc_expr *i
ATTRIBUTE_UNUSED,
f->value.function.name = gfc_get_string ("__maskr_i%d", f->ts.kind);
}
+void
+gfc_resolve_umasklr (gfc_expr *f, gfc_expr *i ATTRIBUTE_UNUSED,
+ gfc_expr *kind)
+{
+ f->ts.type = BT_UNSIGNED;
+ f->ts.kind = kind ? mpz_get_si (kind->value.integer)
+ : gfc_default_unsigned_kind;
+
+ if (f->value.function.isym->id == GFC_ISYM_UMASKL)
+ f->value.function.name = gfc_get_string ("__maskl_m%d", f->ts.kind);
+ else
+ f->value.function.name = gfc_get_string ("__maskr_m%d", f->ts.kind);
+}
+
void
gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 1e2fa3eb8ea2..573ec6bd3a8b 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -5200,6 +5200,84 @@ gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
return result;
}
+/* Similar to gfc_simplify_maskr, but code paths are different enough to make
+ this into a separate function. */
+
+gfc_expr *
+gfc_simplify_umaskr (gfc_expr *i, gfc_expr *kind_arg)
+{
+ gfc_expr *result;
+ int kind, arg, k;
+
+ if (i->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ kind = get_kind (BT_UNSIGNED, kind_arg, "UMASKR", gfc_default_unsigned_kind);
+ if (kind == -1)
+ return &gfc_bad_expr;
+ k = gfc_validate_kind (BT_UNSIGNED, kind, false);
+
+ bool fail = gfc_extract_int (i, &arg);
+ gcc_assert (!fail);
+
+ if (!gfc_check_mask (i, kind_arg))
+ return &gfc_bad_expr;
+
+ result = gfc_get_constant_expr (BT_UNSIGNED, kind, &i->where);
+
+ /* MASKR(n) = 2^n - 1 */
+ mpz_set_ui (result->value.integer, 1);
+ mpz_mul_2exp (result->value.integer, result->value.integer, arg);
+ mpz_sub_ui (result->value.integer, result->value.integer, 1);
+
+ gfc_convert_mpz_to_unsigned (result->value.integer,
+ gfc_unsigned_kinds[k].bit_size,
+ false);
+
+ return result;
+}
+
+/* Likewise, similar to gfc_simplify_maskl. */
+
+gfc_expr *
+gfc_simplify_umaskl (gfc_expr *i, gfc_expr *kind_arg)
+{
+ gfc_expr *result;
+ int kind, arg, k;
+ mpz_t z;
+
+ if (i->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ kind = get_kind (BT_UNSIGNED, kind_arg, "UMASKL", gfc_default_integer_kind);
+ if (kind == -1)
+ return &gfc_bad_expr;
+ k = gfc_validate_kind (BT_UNSIGNED, kind, false);
+
+ bool fail = gfc_extract_int (i, &arg);
+ gcc_assert (!fail);
+
+ if (!gfc_check_mask (i, kind_arg))
+ return &gfc_bad_expr;
+
+ result = gfc_get_constant_expr (BT_UNSIGNED, kind, &i->where);
+
+ /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
+ mpz_init_set_ui (z, 1);
+ mpz_mul_2exp (z, z, gfc_unsigned_kinds[k].bit_size);
+ mpz_set_ui (result->value.integer, 1);
+ mpz_mul_2exp (result->value.integer, result->value.integer,
+ gfc_integer_kinds[k].bit_size - arg);
+ mpz_sub (result->value.integer, z, result->value.integer);
+ mpz_clear (z);
+
+ gfc_convert_mpz_to_unsigned (result->value.integer,
+ gfc_unsigned_kinds[k].bit_size,
+ false);
+
+ return result;
+}
+
gfc_expr *
gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
diff --git a/gcc/testsuite/gfortran.dg/unsigned_39.f90
b/gcc/testsuite/gfortran.dg/unsigned_39.f90
new file mode 100644
index 000000000000..47c2174b1cc1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_39.f90
@@ -0,0 +1,29 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+program memain
+ use iso_fortran_env, only : uint8, uint32
+ implicit none
+ call test1
+ call test2
+contains
+ subroutine test1
+ unsigned(uint32) :: u1, u2
+ unsigned(uint8), dimension(3,3) :: v1, v2
+ u1 = umaskr(3)
+ if (u1 /= 7u) error stop 1
+ u2 = umaskl(2)
+ if (u2 /= 3221225472u) error stop 2
+ v1 = umaskr(5,uint8)
+ if (any(v1 /= 31u)) error stop 3
+ v2 = umaskl(5,uint8)
+ if (any(v2 /= 248u_uint8)) error stop 4
+ end subroutine test1
+ subroutine test2
+ unsigned(uint32), parameter :: u1 = umaskr(3), u2=umaskl(2)
+ unsigned(uint8), dimension(3,3) :: v1 = umaskr(5,uint8), v2 =
umaskl(5,uint8)
+ if (u1 /= 7u) error stop 11
+ if (u2 /= 3221225472u) error stop 12
+ if (any(v1 /= 31u)) error stop 13
+ if (any(v2 /= 248u_uint8)) error stop 14
+ end subroutine test2
+end program memain
