Iplement conversions from unsigned to different data types.

6 files changed, 285 insertions, 3 deletions

diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index 1b304b11..73e0610 100644
--- a/gcc/fortran/arith.cc
+++ b/gcc/fortran/arith.cc
@@ -2258,7 +2258,8 @@ wprecision_int_real (mpz_t n, mpfr_t r)
   return ret;
 }
 
-/* Convert integers to integers.  */
+/* Convert integers to integers; we can reuse this for also converting
+   unsigneds.  */
 
 gfc_expr *
 gfc_int2int (gfc_expr *src, int kind)
@@ -2266,7 +2267,7 @@ gfc_int2int (gfc_expr *src, int kind)
   gfc_expr *result;
   arith rc;
 
-  if (src->ts.type != BT_INTEGER)
+  if (src->ts.type != BT_INTEGER && src->ts.type != BT_UNSIGNED)
     return NULL;
 
   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
@@ -2375,6 +2376,111 @@ gfc_int2complex (gfc_expr *src, int kind)
   return result;
 }
 
+/* Convert unsigned to unsigned, or integer to unsigned.  */
+
+gfc_expr *
+gfc_uint2uint (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  arith rc;
+  int k;
+
+  if (src->ts.type != BT_UNSIGNED && src->ts.type != BT_INTEGER)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_UNSIGNED, kind, &src->where);
+  mpz_set (result->value.integer, src->value.integer);
+
+  rc = gfc_range_check (result);
+  if (rc != ARITH_OK)
+    gfc_warning (0, gfc_arith_error (rc), &result->where);
+
+  k = gfc_validate_kind (BT_UNSIGNED, kind, false);
+  mpz_and (result->value.integer, result->value.integer,
+	   gfc_unsigned_kinds[k].huge);
+
+  return result;
+}
+
+gfc_expr *
+gfc_int2uint (gfc_expr *src, int kind)
+{
+  return gfc_uint2uint (src, kind);
+}
+
+gfc_expr *
+gfc_uint2int (gfc_expr *src, int kind)
+{
+  return gfc_int2int (src, kind);
+}
+
+/* Convert UNSIGNED to reals.  */
+
+gfc_expr *
+gfc_uint2real (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  arith rc;
+
+  if (src->ts.type != BT_UNSIGNED)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
+
+  mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
+
+  if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
+    {
+      arith_error (rc, &src->ts, &result->ts, &src->where);
+      gfc_free_expr (result);
+      return NULL;
+    }
+
+  if (warn_conversion
+      && wprecision_int_real (src->value.integer, result->value.real))
+    gfc_warning (OPT_Wconversion, "Change of value in conversion "
+		 "from %qs to %qs at %L",
+		 gfc_typename (&src->ts),
+		 gfc_typename (&result->ts),
+		 &src->where);
+
+  return result;
+}
+
+/* Convert default integer to default complex.  */
+
+gfc_expr *
+gfc_uint2complex (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  arith rc;
+
+  if (src->ts.type != BT_UNSIGNED)
+    return NULL;
+
+  result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
+
+  mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
+
+  if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
+      != ARITH_OK)
+    {
+      arith_error (rc, &src->ts, &result->ts, &src->where);
+      gfc_free_expr (result);
+      return NULL;
+    }
+
+  if (warn_conversion
+      && wprecision_int_real (src->value.integer,
+			      mpc_realref (result->value.complex)))
+      gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
+		       "from %qs to %qs at %L",
+		       gfc_typename (&src->ts),
+		       gfc_typename (&result->ts),
+		       &src->where);
+
+  return result;
+}
 
 /* Convert default real to default integer.  */
 
diff --git a/gcc/fortran/arith.h b/gcc/fortran/arith.h
index f2e63bc..e796d4d 100644
--- a/gcc/fortran/arith.h
+++ b/gcc/fortran/arith.h
@@ -63,6 +63,11 @@ gfc_expr *gfc_le (gfc_expr *, gfc_expr *, gfc_intrinsic_op);
 gfc_expr *gfc_int2int (gfc_expr *, int);
 gfc_expr *gfc_int2real (gfc_expr *, int);
 gfc_expr *gfc_int2complex (gfc_expr *, int);
+gfc_expr *gfc_int2uint (gfc_expr *, int);
+gfc_expr *gfc_uint2uint (gfc_expr *, int);
+gfc_expr *gfc_uint2int (gfc_expr *, int);
+gfc_expr *gfc_uint2real (gfc_expr *, int);
+gfc_expr *gfc_uint2complex (gfc_expr *, int);
 gfc_expr *gfc_real2int (gfc_expr *, int);
 gfc_expr *gfc_real2real (gfc_expr *, int);
 gfc_expr *gfc_real2complex (gfc_expr *, int);
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 9074fe3..65ca14a 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -95,6 +95,12 @@ gfc_type_letter (bt type, bool logical_equals_int)
       c = 'h';
       break;
 
+      /* 'u' would be the logical choice, but it is used for
+	 "unknown", see below.  */
+    case BT_UNSIGNED:
+      c = 'm';
+      break;
+
     default:
       c = 'u';
       break;
@@ -4053,6 +4059,15 @@ add_conversions (void)
 		  BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
       }
 
+  if (flag_unsigned)
+    {
+      for (i = 0; gfc_unsigned_kinds[i].kind != 0; i++)
+	for (j = 0; gfc_unsigned_kinds[j].kind != 0; j++)
+	  if (i != j)
+	    add_conv (BT_UNSIGNED, gfc_unsigned_kinds[i].kind,
+		      BT_UNSIGNED, gfc_unsigned_kinds[j].kind, GFC_STD_GNU);
+    }
+
   if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
     {
       /* Hollerith-Integer conversions.  */
@@ -5326,7 +5341,8 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag,
       else if (from_ts.type == ts->type
 	       || (from_ts.type == BT_INTEGER && ts->type == BT_REAL)
 	       || (from_ts.type == BT_INTEGER && ts->type == BT_COMPLEX)
-	       || (from_ts.type == BT_REAL && ts->type == BT_COMPLEX))
+	       || (from_ts.type == BT_REAL && ts->type == BT_COMPLEX)
+	       || (from_ts.type == BT_UNSIGNED && ts->type == BT_UNSIGNED))
 	{
 	  /* Larger kinds can hold values of smaller kinds without problems.
 	     Hence, only warn if target kind is smaller than the source
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 98ad7ae..8f70acf 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11549,6 +11549,13 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
       return false;
     }
 
+  if (flag_unsigned && gfc_invalid_unsigned_ops (lhs, rhs))
+    {
+      gfc_error (_("Cannot assign %s to %s at %L"), gfc_typename (rhs),
+		   gfc_typename (lhs), &rhs->where);
+      return false;
+    }
+
   /* Handle the case of a BOZ literal on the RHS.  */
   if (rhs->ts.type == BT_BOZ)
     {
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 919d9d5..8d62270 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -1798,6 +1798,7 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
   switch (x->ts.type)
     {
       case BT_INTEGER:
+      case BT_UNSIGNED:
 	mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
 	break;
 
@@ -1819,6 +1820,7 @@ simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
   switch (y->ts.type)
     {
       case BT_INTEGER:
+      case BT_UNSIGNED:
 	mpfr_set_z (mpc_imagref (result->value.complex),
 		    y->value.integer, GFC_RND_MODE);
 	break;
@@ -8816,6 +8818,9 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind)
 	case BT_INTEGER:
 	  f = gfc_int2int;
 	  break;
+	case BT_UNSIGNED:
+	  f = gfc_int2uint;
+	  break;
 	case BT_REAL:
 	  f = gfc_int2real;
 	  break;
@@ -8830,6 +8835,26 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind)
 	}
       break;
 
+    case BT_UNSIGNED:
+      switch (type)
+	{
+	case BT_INTEGER:
+	  f = gfc_uint2int;
+	  break;
+	case BT_UNSIGNED:
+	  f = gfc_uint2uint;
+	  break;
+	case BT_REAL:
+	  f = gfc_uint2real;
+	  break;
+	case BT_COMPLEX:
+	  f = gfc_uint2complex;
+	  break;
+	default:
+	  goto oops;
+	}
+      break;
+
     case BT_REAL:
       switch (type)
 	{
diff --git a/gcc/testsuite/gfortran.dg/unsigned_5.f90 b/gcc/testsuite/gfortran.dg/unsigned_5.f90
new file mode 100644
index 0000000..5fbd1b4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_5.f90
@@ -0,0 +1,123 @@
+! { dg-do run }
+! { dg-options "-funsigned" }
+! Test conversions from unsigned to different data types by
+! doing some I/O.
+program main
+  implicit none
+  integer :: vi,i
+  integer, parameter :: n_int = 16, n_real = 8
+  unsigned(kind=1) :: u1
+  unsigned(kind=2) :: u2
+  unsigned(kind=4) :: u4
+  unsigned(kind=8) :: u8
+  unsigned :: u
+  integer, dimension(n_int) :: ires
+  real(kind=8), dimension(n_real) :: rres
+  real(kind=8) :: vr
+  complex (kind=8) :: vc
+  data ires /11,12,14,18,21,22,24,28,41,42,44,48,81,82,84,88/
+  data rres /14., 18., 24., 28., 44., 48., 84., 88./
+  open (10,status="scratch")
+
+  write (10,*) int(11u_1,1)
+  write (10,*) int(12u_1,2)
+  write (10,*) int(14u_1,4)
+  write (10,*) int(18u_1,8)
+
+  write (10,*) int(21u_2,1)
+  write (10,*) int(22u_2,2)
+  write (10,*) int(24u_2,4)
+  write (10,*) int(28u_2,8)
+
+  write (10,*) int(41u_4,1)
+  write (10,*) int(42u_4,2)
+  write (10,*) int(44u_4,4)
+  write (10,*) int(48u_4,8)
+
+  write (10,*) int(81u_8,1)
+  write (10,*) int(82u_8,2)
+  write (10,*) int(84u_8,4)
+  write (10,*) int(88u_8,8)
+
+  rewind 10
+  do i=1,n_int
+     read (10,*) vi
+     if (vi /= ires(i)) stop 1
+  end do
+
+  rewind 10
+  u1 = 11u; write (10,*) int(u1,1)
+  u1 = 12u; write (10,*) int(u1,2)
+  u1 = 14u; write (10,*) int(u1,4)
+  u1 = 18u; write (10,*) int(u1,8)
+
+  u2 = 21u; write (10,*) int(u2,1)
+  u2 = 22u; write (10,*) int(u2,2)
+  u2 = 24u; write (10,*) int(u2,4)
+  u2 = 28u; write (10,*) int(u2,8)
+
+  u4 = 41u; write (10,*) int(u4,1)
+  u4 = 42u; write (10,*) int(u4,2)
+  u4 = 44u; write (10,*) int(u4,4)
+  u4 = 48u; write (10,*) int(u4,8)
+
+  u8 = 81u; write (10,*) int(u8,1)
+  u8 = 82u; write (10,*) int(u8,2)
+  u8 = 84u; write (10,*) int(u8,4)
+  u8 = 88u; write (10,*) int(u8,8)
+
+  rewind 10
+  do i=1,n_int
+     read (10,*) vi
+     if (vi /= ires(i)) stop 2
+  end do
+
+  rewind 10
+  write (10,*) real(14u_1,4)
+  write (10,*) real(18u_1,8)
+  write (10,*) real(24u_2,4)
+  write (10,*) real(28u_2,8)
+  write (10,*) real(44u_4,4)
+  write (10,*) real(48u_4,8)
+  write (10,*) real(84u_8,4)
+  write (10,*) real(88u_8,8)
+
+  rewind 10
+  do i=1, n_real
+     read (10, *) vr
+     if (vr /= rres(i)) stop 3
+  end do
+
+  rewind 10
+  u1 = 14u_1; write (10,*) real(u1,4)
+  u1 = 18u_1; write (10,*) real(u1,8)
+  u2 = 24u_2; write (10,*) real(u2,4)
+  u2 = 28u_2; write (10,*) real(u2,8)
+  u4 = 44u_4; write (10,*) real(u4,4)
+  u4 = 48u_4; write (10,*) real(u4,8)
+  u8 = 84u_4; write (10,*) real(u8,4)
+  u8 = 88u_4; write (10,*) real(u8,8)
+
+  rewind 10
+  do i=1, n_real
+     read (10, *) vr
+     if (vr /= rres(i)) stop 4
+  end do
+
+  rewind 10
+  u1 = 14u_1; write (10,*) cmplx(14u_1,u1,kind=4)
+  u1 = 18u_1; write (10,*) cmplx(18u_1,u1,kind=8)
+  u2 = 24u_2; write (10,*) cmplx(24u_2,u2,kind=4)
+  u2 = 28u_2; write (10,*) cmplx(28u_2,u2,kind=8)
+  u4 = 44u_4; write (10,*) cmplx(44u_4,u4,kind=4)
+  u4 = 48u_8; write (10,*) cmplx(48u_4,u4,kind=8)
+  u8 = 84u_8; write (10,*) cmplx(84u_8,u8,kind=4)
+  u8 = 88u_8; write (10,*) cmplx(88u_8,u8,kind=8)
+
+  rewind 10
+  do i=1,n_real
+     read (10, *) vc
+     if (real(vc) /= rres(i)) stop 5
+     if (aimag(vc) /= rres(i)) stop 6
+  end do
+end program main