https://gcc.gnu.org/g:2847a541c1f19b67ae84be8d0f6dc8e1f9371d16
commit r15-3613-g2847a541c1f19b67ae84be8d0f6dc8e1f9371d16
Author: Steven G. Kargl <ka...@gcc.gnu.org>
Date: Thu Sep 12 21:33:31 2024 +0200
Implement modules for UNSIGNED.
gcc/fortran/ChangeLog:
* module.cc (bt_types): Add BT_UNSIGNED.
gcc/testsuite/ChangeLog:
* gfortran.dg/unsigned_kiss.f90: New test.
Diff:
---
gcc/fortran/module.cc | 1 +
gcc/testsuite/gfortran.dg/unsigned_kiss.f90 | 100 ++++++++++++++++++++++++++++
2 files changed, 101 insertions(+)
diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc
index c565b84d61b7..8cf58ff51429 100644
--- a/gcc/fortran/module.cc
+++ b/gcc/fortran/module.cc
@@ -2781,6 +2781,7 @@ static const mstring bt_types[] = {
minit ("UNKNOWN", BT_UNKNOWN),
minit ("VOID", BT_VOID),
minit ("ASSUMED", BT_ASSUMED),
+ minit ("UNSIGNED", BT_UNSIGNED),
minit (NULL, -1)
};
diff --git a/gcc/testsuite/gfortran.dg/unsigned_kiss.f90
b/gcc/testsuite/gfortran.dg/unsigned_kiss.f90
new file mode 100644
index 000000000000..46ee86ccd263
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unsigned_kiss.f90
@@ -0,0 +1,100 @@
+!
+! { dg-do run }
+! { dg-options "-funsigned" }
+!
+! Modern Fortran rewrite of Marsaglia's 64-bit KISS PRNG.
+! https://www.thecodingforums.com/threads/64-bit-kiss-rngs.673657/
+!
+module kissm
+
+ implicit none
+ private
+ public uk, kseed, kiss
+
+ integer, parameter :: uk = kind(1u_8) ! Check kind() works.
+
+ ! Default seeds. Checks unsigned with parameter attribute.
+ unsigned(uk), parameter :: seed(4) = [ &
+ & 1234567890987654321u_uk, 362436362436362436u_uk, &
+ & 1066149217761810u_uk, 123456123456123456u_uk ]
+
+ ! Seeds used during generation
+ unsigned(uk), save :: sd(4) = seed
+
+ contains
+
+ ! Tests unsigned in an internal function.
+ function s(x)
+ unsigned(uk) s
+ unsigned(uk), intent(in) :: x
+ s = ishft(x, -63) ! Tests ishft
+ end function
+
+ ! Poor seeding routine. Need to check v for entropy!
+ ! Tests intent(in) and optional attributes.
+ ! Tests ishftc() and array constructors.
+ subroutine kseed(v)
+ unsigned(uk), intent(in), optional :: v
+ if (present(v)) then
+ sd = seed + [ishftc(v,1), ishftc(v,15), ishftc(v,31), ishftc(v,44)]
+ else
+ sd = seed
+ end if
+ end subroutine kseed
+
+ function kiss()
+ unsigned(uk) kiss
+ unsigned(uk) m, t
+ integer k
+
+ ! Test unsigned in a statement function
+ m(t, k) = ieor(t, ishft(t, k))
+
+ t = ishft(sd(1), 58) + sd(4)
+ if (s(sd(1)) == s(t)) then
+ sd(4) = ishft(sd(1), -6) + s(sd(1))
+ else
+ sd(4) = ishft(sd(1), -6) + 1u_uk - s(sd(1) + t)
+ endif
+
+ sd(1) = t + sd(1)
+ sd(2) = m(m(m(sd(2), 13), -17), 43)
+ sd(3) = 6906969069u_uk * sd(3) + 1234567u_uk
+ kiss = sd(1) + sd(2) + sd(3)
+ end function kiss
+
+end module kissm
+
+program testkiss
+ use kissm
+ integer, parameter :: n = 4
+ unsigned(uk) prn(4)
+
+ ! Default sequence
+ unsigned(uk), parameter :: a(4) = [8932985056925012148u_uk, &
+ & 5710300428094272059u_uk, 18342510866933518593u_uk, &
+ & 14303636270573868250u_uk]
+
+ ! Sequence with the seed 123412341234u_uk
+ unsigned(uk), parameter :: b(4) = [4002508872477953753u_uk, &
+ & 18025327658415290923u_uk, 16058856976144281263u_uk, &
+ & 11842224026193909403u_uk]
+
+ do i = 1, n
+ prn(i) = kiss()
+ end do
+ if (any(prn /= a)) stop 1
+
+ call kseed(123412341234u_uk)
+ do i = 1, n
+ prn(i) = kiss()
+ end do
+ if (any(prn /= b)) stop 2
+
+ call kseed()
+ do i = 1, n
+ prn(i) = kiss()
+ end do
+ if (any(prn /= a)) stop 3
+
+end program testkiss
