From 291e20e86090e5940e2bd862ec83c7d5e0715dd5 Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Tue, 24 Sep 2024 22:57:42 +0200 Subject: Add random numbers and fix some bugs. This patch adds random number support for UNSIGNED, plus fixes two bugs, with array I/O where the type used to be set to BT_INTEGER, and for division with the divisor being a constant. gcc/fortran/ChangeLog: * check.cc (gfc_check_random_number): Adjust for unsigned. * iresolve.cc (gfc_resolve_random_number): Handle unsigned. * trans-expr.cc (gfc_conv_expr_op): Handle BT_UNSIGNED for divide. * trans-types.cc (gfc_get_dtype_rank_type): Handle BT_UNSIGNED. * gfortran.texi: Add RANDOM_NUMBER for UNSIGNED. libgfortran/ChangeLog: * gfortran.map: Add _gfortran_random_m1, _gfortran_random_m2, _gfortran_random_m4, _gfortran_random_m8 and _gfortran_random_m16. * intrinsics/random.c (random_m1): New function. (random_m2): New function. (random_m4): New function. (random_m8): New function. (random_m16): New function. (arandom_m1): New function. (arandom_m2): New function. (arandom_m4): New function. (arandom_m8): New funciton. (arandom_m16): New function. gcc/testsuite/ChangeLog: * gfortran.dg/unsigned_30.f90: New test. --- gcc/fortran/check.cc | 10 ++++- gcc/fortran/gfortran.texi | 1 + gcc/fortran/iresolve.cc | 6 ++- gcc/fortran/trans-expr.cc | 4 +- gcc/fortran/trans-types.cc | 7 +++- gcc/testsuite/gfortran.dg/unsigned_30.f90 | 63 +++++++++++++++++++++++++++++++ 6 files changed, 84 insertions(+), 7 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/unsigned_30.f90 (limited to 'gcc') diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 533c9d7..1851cfb 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -7007,8 +7007,14 @@ gfc_check_random_init (gfc_expr *repeatable, gfc_expr *image_distinct) bool gfc_check_random_number (gfc_expr *harvest) { - if (!type_check (harvest, 0, BT_REAL)) - return false; + if (flag_unsigned) + { + if (!type_check2 (harvest, 0, BT_REAL, BT_UNSIGNED)) + return false; + } + else + if (!type_check (harvest, 0, BT_REAL)) + return false; if (!variable_check (harvest, 0, false)) return false; diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 3eb8039..a5ebadff 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -2790,6 +2790,7 @@ As of now, the following intrinsics take unsigned arguments: @item @code{TRANSFER} @item @code{SUM}, @code{PRODUCT}, @code{MATMUL} and @code{DOT_PRODUCT} @item @code{IANY}, @code{IALL} and @code{IPARITY} +@item @code{RANDOM_NUMBER}. @end itemize This list will grow in the near future. @c --------------------------------------------------------------------- diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index b281ab7..5a1e0a6 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -3452,12 +3452,14 @@ gfc_resolve_random_number (gfc_code *c) { const char *name; int kind; + char type; kind = gfc_type_abi_kind (&c->ext.actual->expr->ts); + type = gfc_type_letter (c->ext.actual->expr->ts.type); if (c->ext.actual->expr->rank == 0) - name = gfc_get_string (PREFIX ("random_r%d"), kind); + name = gfc_get_string (PREFIX ("random_%c%d"), type, kind); else - name = gfc_get_string (PREFIX ("arandom_r%d"), kind); + name = gfc_get_string (PREFIX ("arandom_%c%d"), type, kind); c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index d0c7dfe..e4c491a 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -3973,9 +3973,9 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) case INTRINSIC_DIVIDE: /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is - an integer, we must round towards zero, so we use a + an integer or unsigned, we must round towards zero, so we use a TRUNC_DIV_EXPR. */ - if (expr->ts.type == BT_INTEGER) + if (expr->ts.type == BT_INTEGER || expr->ts.type == BT_UNSIGNED) code = TRUNC_DIV_EXPR; else code = RDIV_EXPR; diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index 96ef8b4..05e64b3 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -1651,7 +1651,12 @@ gfc_get_dtype_rank_type (int rank, tree etype) && TYPE_STRING_FLAG (ptype)) n = BT_CHARACTER; else - n = BT_INTEGER; + { + if (TYPE_UNSIGNED (etype)) + n = BT_UNSIGNED; + else + n = BT_INTEGER; + } break; case BOOLEAN_TYPE: diff --git a/gcc/testsuite/gfortran.dg/unsigned_30.f90 b/gcc/testsuite/gfortran.dg/unsigned_30.f90 new file mode 100644 index 0000000..b0a1555 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_30.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! { dg-options "-funsigned" } + +! The leading bytes of the unsigned sequences should be the same for +! kinds 1 to 8. This also tests array I/O for unsigneds. + +program memain + implicit none + integer, dimension(:), allocatable :: seed + integer :: n + call random_seed (size=n) + allocate(seed(n)) + call test1 + call test2 +contains + subroutine test1 + unsigned(1) :: u1 + unsigned(2) :: u2 + unsigned(4) :: u4 + unsigned(8) :: u8 + character (len=16) :: line1, line2, line4, line8 + integer :: i, n + do i=1,10 + call random_seed(get=seed) + call random_number(u1) + write (line1,'(Z2.2)') u1 + call random_seed(put=seed) + call random_number(u2) + write (line2,'(Z4.4)') u2 + call random_seed(put=seed) + call random_number(u4) + write (line4,'(Z8.8)') u4 + call random_seed(put=seed) + call random_number(u8) + write (line8,'(Z16.16)') u8 + if (line8(1:8) /= line4 (1:8)) error stop 1 + if (line4(1:4) /= line2 (1:4)) error stop 2 + if (line2(1:2) /= line1 (1:2)) error stop 3 + end do + end subroutine test1 + subroutine test2 + unsigned(1), dimension(2,2) :: v1 + unsigned(2), dimension(2,2) :: v2 + unsigned(4), dimension(2,2) :: v4 + unsigned(8), dimension(2,2) :: v8 + character(len=16), dimension(4) :: c1, c2, c4, c8 + call random_seed(put=seed) + call random_number (v1) + write (c1,'(Z2.2)') v1 + call random_seed(put=seed) + call random_number (v2) + write (c2,'(Z4.4)') v2 + call random_seed(put=seed) + call random_number (v4) + write (c4,'(Z8.8)') v4 + call random_seed(put=seed) + call random_number (v8) + write (c8,'(Z16.16)') v8 + if (any(c8(:)(1:8) /= c4(:)(1:8))) error stop 10 + if (any(c4(:)(1:4) /= c2(:)(1:4))) error stop 11 + if (any(c2(:)(1:2) /= c1(:)(1:2))) error stop 12 + end subroutine test2 +end program memain -- cgit v1.1