diff mbox series

[fortran,committed] module support for UNSIGNED

Message ID 808d6397-e7d5-40ab-bb0d-eb1bb156a933@netcologne.de
State New
Headers show
Series [fortran,committed] module support for UNSIGNED | expand

Commit Message

Thomas Koenig Sept. 12, 2024, 7:39 p.m. UTC 
Hello world,

I just pushed Steve's patch for module support to trunk as obvious, as
https://gcc.gnu.org/g:2847a541c1f19b67ae84be8d0f6dc8e1f9371d16 .

Best regards

	Thomas

gcc/fortran/ChangeLog:

	* module.cc (bt_types): Add BT_UNSIGNED.

gcc/testsuite/ChangeLog:

	* gfortran.dg/unsigned_kiss.f90: New test.

+end program testkiss
diff mbox series

Patch

diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc
index c565b84d61b..8cf58ff5142 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 00000000000..46ee86ccd26
--- /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
+