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)
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);
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. */
--- /dev/null
+! { 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