{
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))
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;
GFC_ISYM_UBOUND,
GFC_ISYM_UCOBOUND,
GFC_ISYM_UMASK,
+ GFC_ISYM_UMASKL,
+ GFC_ISYM_UMASKR,
GFC_ISYM_UNLINK,
GFC_ISYM_UNPACK,
GFC_ISYM_VERIFY,
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
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);
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 *);
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 *);
* @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
@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
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,
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)
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
