aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/arith.cc24
-rw-r--r--gcc/fortran/check.cc15
-rw-r--r--gcc/fortran/expr.cc13
-rw-r--r--gcc/fortran/gfortran.h1
-rw-r--r--gcc/fortran/gfortran.texi1
-rw-r--r--gcc/fortran/iresolve.cc11
-rw-r--r--gcc/fortran/simplify.cc10
-rw-r--r--gcc/testsuite/gfortran.dg/unsigned_25.f9035
-rw-r--r--gcc/testsuite/gfortran.dg/unsigned_26.f9040
9 files changed, 137 insertions, 13 deletions
diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index 66a3635..a214b8b 100644
--- a/gcc/fortran/arith.cc
+++ b/gcc/fortran/arith.cc
@@ -711,17 +711,9 @@ gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
case BT_UNSIGNED:
{
if (pedantic)
- return ARITH_UNSIGNED_NEGATIVE;
+ return check_result (ARITH_UNSIGNED_NEGATIVE, op1, result, resultp);
- arith neg_rc;
mpz_neg (result->value.integer, op1->value.integer);
- neg_rc = gfc_range_check (result);
- if (neg_rc != ARITH_OK)
- gfc_warning (0, gfc_arith_error (neg_rc), &result->where);
-
- gfc_reduce_unsigned (result);
- if (pedantic)
- rc = neg_rc;
}
break;
@@ -738,7 +730,15 @@ gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
}
rc = gfc_range_check (result);
-
+ if (op1->ts.type == BT_UNSIGNED)
+ {
+ if (rc != ARITH_OK)
+ {
+ gfc_warning (0, gfc_arith_error (rc), &op1->where);
+ rc = ARITH_OK;
+ }
+ gfc_reduce_unsigned (result);
+ }
return check_result (rc, op1, result, resultp);
}
@@ -799,8 +799,12 @@ gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
switch (op1->ts.type)
{
case BT_INTEGER:
+ mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
+ break;
+
case BT_UNSIGNED:
mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
+ gfc_reduce_unsigned (result);
break;
case BT_REAL:
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index cfafdb7..7c630dd 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -2804,6 +2804,10 @@ gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
return false;
break;
+ case BT_UNSIGNED:
+ /* Check comes later. */
+ break;
+
default:
gfc_error ("%qs argument of %qs intrinsic at %L must be numeric "
"or LOGICAL", gfc_current_intrinsic_arg[0]->name,
@@ -2811,6 +2815,14 @@ gfc_check_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
return false;
}
+ if (gfc_invalid_unsigned_ops (vector_a, vector_b))
+ {
+ gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
+ gfc_current_intrinsic, &vector_a->where,
+ gfc_typename(&vector_a->ts), gfc_typename(&vector_b->ts));
+ return false;
+ }
+
if (!rank_check (vector_a, 0, 1))
return false;
@@ -4092,7 +4104,8 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
}
if ((matrix_a->ts.type == BT_LOGICAL && gfc_numeric_ts (&matrix_b->ts))
- || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL))
+ || (gfc_numeric_ts (&matrix_a->ts) && matrix_b->ts.type == BT_LOGICAL)
+ || gfc_invalid_unsigned_ops (matrix_a, matrix_b))
{
gfc_error ("Argument types of %qs intrinsic at %L must match (%s/%s)",
gfc_current_intrinsic, &matrix_a->where,
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 81c641e..36baa9b 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -224,6 +224,19 @@ gfc_get_int_expr (int kind, locus *where, HOST_WIDE_INT value)
return p;
}
+/* Get a new expression node that is an unsigned constant. */
+
+gfc_expr *
+gfc_get_unsigned_expr (int kind, locus *where, HOST_WIDE_INT value)
+{
+ gfc_expr *p;
+ p = gfc_get_constant_expr (BT_UNSIGNED, kind,
+ where ? where : &gfc_current_locus);
+ const wide_int w = wi::shwi (value, kind * BITS_PER_UNIT);
+ wi::to_mpz (w, p->value.integer, UNSIGNED);
+
+ return p;
+}
/* Get a new expression node that is a logical constant. */
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 66c9736..917866a7 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3794,6 +3794,7 @@ gfc_expr *gfc_get_structure_constructor_expr (bt, int, locus *);
gfc_expr *gfc_get_constant_expr (bt, int, locus *);
gfc_expr *gfc_get_character_expr (int, locus *, const char *, gfc_charlen_t len);
gfc_expr *gfc_get_int_expr (int, locus *, HOST_WIDE_INT);
+gfc_expr *gfc_get_unsigned_expr (int, locus *, HOST_WIDE_INT);
gfc_expr *gfc_get_logical_expr (int, locus *, bool);
gfc_expr *gfc_get_iokind_expr (locus *, io_kind);
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 60c93d7..829ab00 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -2788,6 +2788,7 @@ As of now, the following intrinsics take unsigned arguments:
@item @code{MVBITS}
@item @code{RANGE}
@item @code{TRANSFER}
+@item @code{MATMUL} and @code{DOT_PRODUCT}
@end itemize
This list will grow in the near future.
@c ---------------------------------------------------------------------
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 4f1fa97..32b3143 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -1600,6 +1600,7 @@ void
gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
{
gfc_expr temp;
+ bt type;
if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL)
{
@@ -1648,8 +1649,16 @@ gfc_resolve_matmul (gfc_expr *f, gfc_expr *a, gfc_expr *b)
}
}
+ /* We use the same library version of matmul for INTEGER and UNSIGNED,
+ which we call as the INTEGER version. */
+
+ if (f->ts.type == BT_UNSIGNED)
+ type = BT_INTEGER;
+ else
+ type = f->ts.type;
+
f->value.function.name
- = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (f->ts.type),
+ = gfc_get_string (PREFIX ("matmul_%c%d"), gfc_type_letter (type),
gfc_type_abi_kind (&f->ts));
}
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index febf60e..83d0fdc 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -420,13 +420,20 @@ compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
{
gfc_expr *result, *a, *b, *c;
- /* Set result to an INTEGER(1) 0 for numeric types and .false. for
+ /* Set result to an UNSIGNED of correct kind for unsigned,
+ INTEGER(1) 0 for other numeric types, and .false. for
LOGICAL. Mixed-mode math in the loop will promote result to the
correct type and kind. */
if (matrix_a->ts.type == BT_LOGICAL)
result = gfc_get_logical_expr (gfc_default_logical_kind, NULL, false);
+ else if (matrix_a->ts.type == BT_UNSIGNED)
+ {
+ int kind = MAX (matrix_a->ts.kind, matrix_b->ts.kind);
+ result = gfc_get_unsigned_expr (kind, NULL, 0);
+ }
else
result = gfc_get_int_expr (1, NULL, 0);
+
result->where = matrix_a->where;
a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
@@ -446,6 +453,7 @@ compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
case BT_INTEGER:
case BT_REAL:
case BT_COMPLEX:
+ case BT_UNSIGNED:
if (conj_a && a->ts.type == BT_COMPLEX)
c = gfc_simplify_conjg (a);
else
diff --git a/gcc/testsuite/gfortran.dg/unsigned_25.f90 b/gcc/testsuite/gfortran.dg/unsigned_25.f90
new file mode 100644
index 0000000..f614498
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_25.f90
@@ -0,0 +1,35 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test matrix multiplication
+program memain
+ implicit none
+ call test1
+ call test2
+contains
+ subroutine test1
+ integer, parameter :: n = 10, m = 28
+ unsigned, dimension(n,n) :: u, v, w
+ integer(kind=8), dimension(n,n) :: i, j, k
+ real(8), dimension(n,n) :: a, b
+
+ call random_number(a)
+ call random_number(b)
+ u = uint(a*2.0**m)
+ v = uint(b*2.0**m)
+ i = int(a*2.0**m,8)
+ j = int(b*2.0**m,8)
+ w = matmul(u,v)
+ k = mod(matmul(i,j),2_8**32)
+ if (any(uint(k) /= w)) error stop 1
+ end subroutine test1
+ subroutine test2
+ unsigned, parameter :: u(3,3) = reshape ([1u, uint(-2), 3u, uint(-4), &
+ 5u, uint(-6), 7u, uint(-8), 9u],[3,3])
+ unsigned, parameter :: v(3,3) = 1u - u
+ unsigned, parameter :: w(3,3) = matmul(u,v)
+ integer(kind=16), dimension(3,3), parameter :: &
+ i = int(u,16), j = int(v,16)
+ integer(kind=16), dimension(3,3) :: k = matmul(i,j)
+ if (any(uint(k) /= w)) error stop 2
+ end subroutine test2
+end program memain
diff --git a/gcc/testsuite/gfortran.dg/unsigned_26.f90 b/gcc/testsuite/gfortran.dg/unsigned_26.f90
new file mode 100644
index 0000000..b8bad9d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_26.f90
@@ -0,0 +1,40 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test dot_product both for runtime and compile
+program memain
+ call test1
+ call test2
+contains
+ subroutine test1
+ integer, parameter :: n = 10
+ real(8), dimension(n) :: a, b
+ unsigned, dimension(n) :: u, v
+ integer(8), dimension(n) :: i, j
+ unsigned :: res_u
+ integer(8) :: res_i
+ integer :: k
+
+ do k=1,10
+ call random_number(a)
+ call random_number(b)
+ u = uint(a*2**32)
+ v = uint(b*2**32)
+ i = int(u,8)
+ j = int(v,8)
+ res_u = dot_product(u,v)
+ res_i = dot_product(i,j)
+ if (res_u /= uint(res_i)) error stop 1
+ end do
+ end subroutine test1
+
+ subroutine test2
+ integer, parameter :: n = 5
+ unsigned, parameter, dimension(n) :: &
+ u = [1149221887u, 214388752u, 724301838u, 1618160523u, 1783282425u], &
+ v = [1428464973u, 1887264271u, 1830319906u, 983537781u, 13514400u]
+ integer(8), parameter, dimension(n) :: i = int(u,8), j=int(v,8)
+ unsigned, parameter :: res_1 = dot_product(u,v)
+ integer(8), parameter :: res_2 = dot_product(i,j)
+ if (res_1 /= uint(res_2)) error stop 2
+ end subroutine test2
+end program
generated by cgit v1.1 at 2025-05-20 21:26:15 +0000