Implement MATMUL and DOT_PRODUCT for unsigned.

gcc/fortran/ChangeLog:

	* arith.cc (gfc_arith_uminus): Fix warning.
	(gfc_arith_minus): Correctly truncate unsigneds.
	* check.cc (gfc_check_dot_product): Handle unsigned arguments.
	(gfc_check_matmul): Likewise.
	* expr.cc (gfc_get_unsigned_expr): New function.
	* gfortran.h (gfc_get_unsigned_expr): Add prototype.
	* iresolve.cc (gfc_resolve_matmul): If using UNSIGNED, use the
	signed integer version.
	* gfortran.texi: Document MATMUL and DOT_PRODUCT for unsigned.
	* simplify.cc (compute_dot_product): Handle unsigneds.

libgfortran/ChangeLog:

	* m4/iparm.m4: Add UNSIGED if type is m.
	* m4/matmul.m4: If type is GFC_INTEGER, use GFC_UINTEGER instead.
	Whitespace fixes.
	* m4/matmul_internal.m4: Whitespace fixes.

	* generated/matmul_c10.c: Regenerated.
	* generated/matmul_c16.c: Regenerated.
	* generated/matmul_c17.c: Regenerated.
	* generated/matmul_c4.c: Regenerated.
	* generated/matmul_c8.c: Regeneraated.
	* generated/matmul_i1.c: Regenerated.
	* generated/matmul_i16.c: Regenerated.
	* generated/matmul_i2.c: Regenerated.
	* generated/matmul_i4.c: Regenerated.
	* generated/matmul_i8.c: Regenerated.
	* generated/matmul_r10.c: Regenerated.
	* generated/matmul_r16.c: Regenerated.
	* generated/matmul_r17.c: Regenerated.
	* generated/matmul_r4.c: Regenerated.
	* generated/matmul_r8.c: Regenerated.
	* libgfortran.h: Add array types for unsiged.

gcc/testsuite/ChangeLog:

	* gfortran.dg/unsigned_25.f90: New test.
	* gfortran.dg/unsigned_26.f90: New test.

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