Skip to content

R
riscv-gcc-1
Commit 6812b99b by Paul Hilfinger Committed by Arnaud Charlet
Options

impunit.adb: Re-organize System.Random_Numbers and GNAT.Random_Numbers and add to builds. 

2007-08-14  Paul Hilfinger  <hilfinger@adacore.com>

	* impunit.adb: Re-organize System.Random_Numbers and
	GNAT.Random_Numbers and add to builds.

	* Makefile.rtl: Add s-rannum.ad* and g-rannum.ad*, a-assert*

	* s-rannum.ads, s-rannum.adb, g-rannum.ads, g-rannum.adb: New files.

	* a-assert.ads, a-assert.adb: New files.

From-SVN: r127454
parent f86eb278
Showing with 1235 additions and 2 deletions
gcc/ada/Makefile.rtl
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
# This makefile fragment is included in the ada Makefile (both Unix # This makefile fragment is included in the ada Makefile (both Unix
# and NT and VMS versions). # and NT and VMS versions).
# It's purpose is to allow the separate maintainence of the list of # Its purpose is to allow the separate maintainence of the list of
# GNATRTL objects, which frequently changes. # GNATRTL objects, which frequently changes.
# Objects needed only for tasking # Objects needed only for tasking
...@@ -76,6 +76,7 @@ GNATRTL_TASKING_OBJS= \ ...@@ -76,6 +76,7 @@ GNATRTL_TASKING_OBJS= \
# Objects needed for non-tasking. # Objects needed for non-tasking.
GNATRTL_NONTASKING_OBJS= \ GNATRTL_NONTASKING_OBJS= \
a-assert$(objext) \
a-calari$(objext) \ a-calari$(objext) \
a-caldel$(objext) \ a-caldel$(objext) \
a-calend$(objext) \ a-calend$(objext) \
...@@ -158,6 +159,7 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -158,6 +159,7 @@ GNATRTL_NONTASKING_OBJS= \
a-ngcefu$(objext) \ a-ngcefu$(objext) \
a-ngcoty$(objext) \ a-ngcoty$(objext) \
a-ngelfu$(objext) \ a-ngelfu$(objext) \
a-ngrear$(objext) \
a-nlcefu$(objext) \ a-nlcefu$(objext) \
a-nlcoty$(objext) \ a-nlcoty$(objext) \
a-nlelfu$(objext) \ a-nlelfu$(objext) \
...@@ -303,6 +305,7 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -303,6 +305,7 @@ GNATRTL_NONTASKING_OBJS= \
a-zzunio$(objext) \ a-zzunio$(objext) \
ada$(objext) \ ada$(objext) \
calendar$(objext) \ calendar$(objext) \
directio$(objext) \
g-allein$(objext) \ g-allein$(objext) \
g-alleve$(objext) \ g-alleve$(objext) \
g-altcon$(objext) \ g-altcon$(objext) \
...@@ -350,6 +353,7 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -350,6 +353,7 @@ GNATRTL_NONTASKING_OBJS= \
g-moreex$(objext) \ g-moreex$(objext) \
g-os_lib$(objext) \ g-os_lib$(objext) \
g-pehage$(objext) \ g-pehage$(objext) \
g-rannum$(objext) \
g-regexp$(objext) \ g-regexp$(objext) \
g-regpat$(objext) \ g-regpat$(objext) \
g-sestin$(objext) \ g-sestin$(objext) \
...@@ -523,6 +527,7 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -523,6 +527,7 @@ GNATRTL_NONTASKING_OBJS= \
s-poosiz$(objext) \ s-poosiz$(objext) \
s-powtab$(objext) \ s-powtab$(objext) \
s-purexc$(objext) \ s-purexc$(objext) \
s-rannum$(objext) \
s-regexp$(objext) \ s-regexp$(objext) \
s-regpat$(objext) \ s-regpat$(objext) \
s-restri$(objext) \ s-restri$(objext) \
...@@ -584,5 +589,9 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -584,5 +589,9 @@ GNATRTL_NONTASKING_OBJS= \
s-wwdcha$(objext) \ s-wwdcha$(objext) \
s-wwdenu$(objext) \ s-wwdenu$(objext) \
s-wwdwch$(objext) \ s-wwdwch$(objext) \
sequenio$(objext) \
system$(objext) \ system$(objext) \
text_io$(objext) $(EXTRA_GNATRTL_NONTASKING_OBJS) text_io$(objext) \
unchconv$(objext) \
unchdeal$(objext) \
$(EXTRA_GNATRTL_NONTASKING_OBJS)
gcc/ada/a-assert.adb 0 → 100755
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . A S S E R T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body Ada.Assertions is
------------
-- Assert --
------------
procedure Assert (Check : Boolean) is
begin
if Check = False then
raise Ada.Assertions.Assertion_Error;
end if;
end Assert;
procedure Assert (Check : Boolean; Message : String) is
begin
if Check = False then
raise Ada.Assertions.Assertion_Error with Message;
end if;
end Assert;
end Ada.Assertions;
gcc/ada/a-assert.ads 0 → 100755
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . A S S E R T --
-- --
-- S p e c --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
-- We do a with of System.Assertions to get hold of the exception (following
-- the specific RM permission that lets' Assertion_Error being a renaming).
-- The suppression of Warnings stops the warning about bad categorization.
pragma Warnings (Off);
with System.Assertions;
pragma Warnings (On);
package Ada.Assertions is
pragma Pure (Assertions);
Assertion_Error : exception renames System.Assertions.Assert_Failure;
procedure Assert (Check : Boolean);
procedure Assert (Check : Boolean; Message : String);
end Ada.Assertions;
gcc/ada/g-rannum.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . R A N D O M _ N U M B E R S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Numerics.Long_Elementary_Functions;
use Ada.Numerics.Long_Elementary_Functions;
with Ada.Unchecked_Conversion;
with System.Random_Numbers; use System.Random_Numbers;
package body GNAT.Random_Numbers is
Sys_Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width;
subtype Image_String is String (1 .. Max_Image_Width);
-- Utility function declarations
procedure Insert_Image
(S : in out Image_String;
Index : Integer;
V : Integer_64);
-- Insert string representation of V in S starting at position Index
---------------
-- To_Signed --
---------------
function To_Signed is
new Ada.Unchecked_Conversion (Unsigned_32, Integer_32);
function To_Signed is
new Ada.Unchecked_Conversion (Unsigned_64, Integer_64);
------------------
-- Insert_Image --
------------------
procedure Insert_Image
(S : in out Image_String;
Index : Integer;
V : Integer_64)
is
Image : constant String := Integer_64'Image (V);
begin
S (Index .. Index + Image'Length - 1) := Image;
end Insert_Image;
---------------------
-- Random_Discrete --
---------------------
function Random_Discrete
(Gen : Generator;
Min : Result_Subtype := Default_Min;
Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype
is
function F is
new System.Random_Numbers.Random_Discrete
(Result_Subtype, Default_Min);
begin
return F (Gen.Rep, Min, Max);
end Random_Discrete;
------------
-- Random --
------------
function Random (Gen : Generator) return Float is
begin
return Random (Gen.Rep);
end Random;
function Random (Gen : Generator) return Long_Float is
begin
return Random (Gen.Rep);
end Random;
function Random (Gen : Generator) return Interfaces.Unsigned_32 is
begin
return Random (Gen.Rep);
end Random;
function Random (Gen : Generator) return Interfaces.Unsigned_64 is
begin
return Random (Gen.Rep);
end Random;
function Random (Gen : Generator) return Integer_64 is
begin
return To_Signed (Unsigned_64'(Random (Gen)));
end Random;
function Random (Gen : Generator) return Integer_32 is
begin
return To_Signed (Unsigned_32'(Random (Gen)));
end Random;
function Random (Gen : Generator) return Long_Integer is
function Random_Long_Integer is new Random_Discrete (Long_Integer);
begin
return Random_Long_Integer (Gen);
end Random;
function Random (Gen : Generator) return Integer is
function Random_Integer is new Random_Discrete (Integer);
begin
return Random_Integer (Gen);
end Random;
------------------
-- Random_Float --
------------------
function Random_Float (Gen : Generator) return Result_Subtype is
function F is new System.Random_Numbers.Random_Float (Result_Subtype);
begin
return F (Gen.Rep);
end Random_Float;
---------------------
-- Random_Gaussian --
---------------------
-- Generates pairs of normally distributed values using the polar method of
-- G. E. P. Box, M. E. Muller, and G. Marsaglia. See Donald E. Knuth, The
-- Art of Computer Programming, Vol 2: Seminumerical Algorithms, section
-- 3.4.1, subsection C, algorithm P. Returns half of the pair on each call,
-- using the Next_Gaussian field of Gen to hold the second member on
-- even-numbered calls.
function Random_Gaussian (Gen : Generator) return Long_Float is
G : Generator renames Gen'Unrestricted_Access.all;
V1, V2, Rad2, Mult : Long_Float;
begin
if G.Have_Gaussian then
G.Have_Gaussian := False;
return G.Next_Gaussian;
else
loop
V1 := 2.0 * Random (G) - 1.0;
V2 := 2.0 * Random (G) - 1.0;
Rad2 := V1 ** 2 + V2 ** 2;
exit when Rad2 < 1.0 and then Rad2 /= 0.0;
end loop;
-- Now V1 and V2 are coordinates in the unit circle
Mult := Sqrt (-2.0 * Log (Rad2) / Rad2);
G.Next_Gaussian := V2 * Mult;
G.Have_Gaussian := True;
return Long_Float'Machine (V1 * Mult);
end if;
end Random_Gaussian;
function Random_Gaussian (Gen : Generator) return Float is
V : constant Long_Float := Random_Gaussian (Gen);
begin
return Float'Machine (Float (V));
end Random_Gaussian;
-----------
-- Reset --
-----------
procedure Reset (Gen : out Generator) is
begin
Reset (Gen.Rep);
Gen.Have_Gaussian := False;
end Reset;
procedure Reset
(Gen : out Generator;
Initiator : Initialization_Vector)
is
begin
Reset (Gen.Rep, Initiator);
Gen.Have_Gaussian := False;
end Reset;
procedure Reset
(Gen : out Generator;
Initiator : Interfaces.Integer_32)
is
begin
Reset (Gen.Rep, Initiator);
Gen.Have_Gaussian := False;
end Reset;
procedure Reset
(Gen : out Generator;
Initiator : Interfaces.Unsigned_32)
is
begin
Reset (Gen.Rep, Initiator);
Gen.Have_Gaussian := False;
end Reset;
procedure Reset
(Gen : out Generator;
Initiator : Integer)
is
begin
Reset (Gen.Rep, Initiator);
Gen.Have_Gaussian := False;
end Reset;
procedure Reset
(Gen : out Generator;
From_State : Generator)
is
begin
Reset (Gen.Rep, From_State.Rep);
Gen.Have_Gaussian := From_State.Have_Gaussian;
Gen.Next_Gaussian := From_State.Next_Gaussian;
end Reset;
Frac_Scale : constant Long_Float :=
Long_Float
(Long_Float'Machine_Radix) ** Long_Float'Machine_Mantissa;
function Val64 (Image : String) return Integer_64;
-- Renames Integer64'Value
-- We cannot use a 'renames Integer64'Value' since for some strange
-- reason, this requires a dependency on s-auxdec.ads which not all
-- run-times support ???
function Val64 (Image : String) return Integer_64 is
begin
return Integer_64'Value (Image);
end Val64;
procedure Reset
(Gen : out Generator;
From_Image : String)
is
F0 : constant Integer := From_Image'First;
T0 : constant Integer := From_Image'First + Sys_Max_Image_Width;
begin
Reset (Gen.Rep, From_Image (F0 .. F0 + Sys_Max_Image_Width));
if From_Image (T0 + 1) = '1' then
Gen.Have_Gaussian := True;
Gen.Next_Gaussian :=
Long_Float (Val64 (From_Image (T0 + 3 .. T0 + 23))) / Frac_Scale
* Long_Float (Long_Float'Machine_Radix)
** Integer (Val64 (From_Image (T0 + 25 .. From_Image'Last)));
else
Gen.Have_Gaussian := False;
end if;
end Reset;
-----------
-- Image --
-----------
function Image (Gen : Generator) return String is
Result : Image_String;
begin
Result := (others => ' ');
Result (1 .. Sys_Max_Image_Width) := Image (Gen.Rep);
if Gen.Have_Gaussian then
Result (Sys_Max_Image_Width + 2) := '1';
Insert_Image (Result, Sys_Max_Image_Width + 4,
Integer_64 (Long_Float'Fraction (Gen.Next_Gaussian)
* Frac_Scale));
Insert_Image (Result, Sys_Max_Image_Width + 24,
Integer_64 (Long_Float'Exponent (Gen.Next_Gaussian)));
else
Result (Sys_Max_Image_Width + 2) := '0';
end if;
return Result;
end Image;
end GNAT.Random_Numbers;
gcc/ada/g-rannum.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . R A N D O M _ N U M B E R S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Extended pseudo-random number generation
-- This package provides a type representing pseudo-random number
-- generators, and subprograms to extract various distributions of numbers
-- from them. It also provides types for representing initialization values
-- and snapshots of internal generator state, which permit reproducible
-- pseudo-random streams.
-- The generator currently provided by this package has an extremely long
-- period (at least 2**19937-1), and passes the Big Crush test suite, with
-- the exception of the two linear complexity tests. Therefore, it is
-- suitable for simulations, but should not be used as a cryptographic
-- pseudo-random source without additional processing.
-- The design of this package effects some simplification from that of
-- the standard Ada.Numerics packages. There is no separate State type;
-- the Generator type itself suffices for this purpose. The parameter
-- modes on Reset procedures better reflect the effect of these routines.
with System.Random_Numbers;
with Interfaces; use Interfaces;
package GNAT.Random_Numbers is
type Generator is limited private;
subtype Initialization_Vector is
System.Random_Numbers.Initialization_Vector;
function Random (Gen : Generator) return Float;
function Random (Gen : Generator) return Long_Float;
-- Return pseudo-random numbers uniformly distributed on [0 .. 1)
function Random (Gen : Generator) return Interfaces.Integer_32;
function Random (Gen : Generator) return Interfaces.Unsigned_32;
function Random (Gen : Generator) return Interfaces.Integer_64;
function Random (Gen : Generator) return Interfaces.Unsigned_64;
function Random (Gen : Generator) return Integer;
function Random (Gen : Generator) return Long_Integer;
-- Return pseudo-random numbers uniformly distributed on T'First .. T'Last
-- for various builtin integer types.
generic
type Result_Subtype is (<>);
Default_Min : Result_Subtype := Result_Subtype'Val (0);
function Random_Discrete
(Gen : Generator;
Min : Result_Subtype := Default_Min;
Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype;
-- Returns pseudo-random numbers uniformly distributed on Min .. Max
generic
type Result_Subtype is digits <>;
function Random_Float (Gen : Generator) return Result_Subtype;
-- Returns pseudo-random numbers uniformly distributed on [0 .. 1)
function Random_Gaussian (Gen : Generator) return Long_Float;
function Random_Gaussian (Gen : Generator) return Float;
-- Returns pseudo-random numbers normally distributed value with mean 0
-- and standard deviation 1.0.
procedure Reset (Gen : out Generator);
-- Re-initialize the state of Gen from the time of day
procedure Reset
(Gen : out Generator;
Initiator : Initialization_Vector);
procedure Reset
(Gen : out Generator;
Initiator : Interfaces.Integer_32);
procedure Reset
(Gen : out Generator;
Initiator : Interfaces.Unsigned_32);
procedure Reset
(Gen : out Generator;
Initiator : Integer);
-- Re-initialize Gen based on the Initiator in various ways. Identical
-- values of Initiator cause identical sequences of values.
procedure Reset (Gen : out Generator; From_State : Generator);
-- Causes the state of Gen to be identical to that of From_State; Gen
-- and From_State will produce identical sequences of values subsequently.
procedure Reset (Gen : out Generator; From_Image : String);
function Image (Gen : Generator) return String;
-- The call
-- Reset (Gen2, Image (Gen1))
-- has the same effect as Reset (Gen2, Gen1);
Max_Image_Width : constant :=
System.Random_Numbers.Max_Image_Width + 2 + 20 + 5;
-- Maximum possible length of result of Image (...)
private
type Generator is limited record
Rep : System.Random_Numbers.Generator;
Have_Gaussian : Boolean;
-- The algorithm used for Random_Gaussian produces deviates in
-- pairs. Have_Gaussian is true iff Random_Gaussian has returned one
-- member of the pair and Next_Gaussian contains the other.
Next_Gaussian : Long_Float;
-- Next random deviate to be produced by Random_Gaussian, if
-- Have_Gaussian.
end record;
end GNAT.Random_Numbers;
gcc/ada/impunit.adb
...@@ -247,6 +247,7 @@ package body Impunit is ...@@ -247,6 +247,7 @@ package body Impunit is
"g-moreex", -- GNAT.Most_Recent_Exception "g-moreex", -- GNAT.Most_Recent_Exception
"g-os_lib", -- GNAT.Os_Lib "g-os_lib", -- GNAT.Os_Lib
"g-pehage", -- GNAT.Perfect_Hash_Generators "g-pehage", -- GNAT.Perfect_Hash_Generators
"g-rannum", -- GNAT.Random_Numbers
"g-regexp", -- GNAT.Regexp "g-regexp", -- GNAT.Regexp
"g-regist", -- GNAT.Registry "g-regist", -- GNAT.Registry
"g-regpat", -- GNAT.Regpat "g-regpat", -- GNAT.Regpat
...@@ -333,6 +334,7 @@ package body Impunit is ...@@ -333,6 +334,7 @@ package body Impunit is
-- Ada Hierarchy Units from Ada 2005 Reference Manual -- -- Ada Hierarchy Units from Ada 2005 Reference Manual --
-------------------------------------------------------- --------------------------------------------------------
"a-assert", -- Ada.Assertions
"a-calari", -- Ada.Calendar.Arithmetic "a-calari", -- Ada.Calendar.Arithmetic
"a-calfor", -- Ada.Calendar.Formatting "a-calfor", -- Ada.Calendar.Formatting
"a-catizo", -- Ada.Calendar.Time_Zones "a-catizo", -- Ada.Calendar.Time_Zones
......
gcc/ada/s-rannum.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . R A N D O M _ N U M B E R S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- --
-- The implementation here is derived from a C-program for MT19937, with --
-- initialization improved 2002/1/26. As required, the following notice is --
-- copied from the original program. --
-- --
-- Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura, --
-- All rights reserved. --
-- --
-- Redistribution and use in source and binary forms, with or without --
-- modification, are permitted provided that the following conditions --
-- are met: --
-- --
-- 1. Redistributions of source code must retain the above copyright --
-- notice, this list of conditions and the following disclaimer. --
-- --
-- 2. Redistributions in binary form must reproduce the above copyright --
-- notice, this list of conditions and the following disclaimer in the --
-- documentation and/or other materials provided with the distribution.--
-- --
-- 3. The names of its contributors may not be used to endorse or promote --
-- products derived from this software without specific prior written --
-- permission. --
-- --
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS --
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT --
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR --
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT --
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED --
-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --
-- --
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- --
-- This is an implementation of the Mersenne Twister, twisted generalized --
-- feedback shift register of rational normal form, with state-bit --
-- reflection and tempering. This version generates 32-bit integers with a --
-- period of 2**19937 - 1 (a Mersenne prime, hence the name). For --
-- applications requiring more than 32 bits (up to 64), we concatenate two --
-- 32-bit numbers. --
-- --
-- See http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html for --
-- details. --
-- --
-- In contrast to the original code, we do not generate random numbers in --
-- batches of N. Measurement seems to show this has very little if any --
-- effect on performance, and it may be marginally better for real-time --
-- applications with hard deadlines. --
-- --
------------------------------------------------------------------------------
with Ada.Calendar; use Ada.Calendar;
with Ada.Unchecked_Conversion;
with Interfaces; use Interfaces;
use Ada;
package body System.Random_Numbers is
-------------------------
-- Implementation Note --
-------------------------
-- The design of this spec is very awkward, as a result of Ada 95 not
-- permitting in-out parameters for function formals (most naturally,
-- Generator values would be passed this way). In pure Ada 95, the only
-- solution is to use the heap and pointers, and, to avoid memory leaks,
-- controlled types.
-- This is awfully heavy, so what we do is to use Unrestricted_Access to
-- get a pointer to the state in the passed Generator. This works because
-- Generator is a limited type and will thus always be passed by reference.
Low31_Mask : constant := 2**31-1;
Bit31_Mask : constant := 2**31;
Matrix_A_X : constant array (State_Val range 0 .. 1) of State_Val :=
(0, 16#9908b0df#);
Y2K : constant Calendar.Time :=
Calendar.Time_Of
(Year => 2000, Month => 1, Day => 1, Seconds => 0.0);
-- First Year 2000 day
subtype Image_String is String (1 .. Max_Image_Width);
-- Utility functions
procedure Init (Gen : out Generator; Initiator : Unsigned_32);
-- Perform a default initialization of the state of Gen. The resulting
-- state is identical for identical values of Initiator.
procedure Insert_Image
(S : in out Image_String;
Index : Integer;
V : State_Val);
-- Insert image of V into S, in the Index'th 11-character substring
function Extract_Value (S : String; Index : Integer) return State_Val;
-- Treat S as a sequence of 11-character decimal numerals and return
-- the result of converting numeral #Index (numbering from 0)
function To_Unsigned is
new Unchecked_Conversion (Integer_32, Unsigned_32);
function To_Unsigned is
new Unchecked_Conversion (Integer_64, Unsigned_64);
------------
-- Random --
------------
function Random (Gen : Generator) return Unsigned_32 is
G : Generator renames Gen'Unrestricted_Access.all;
Y : State_Val;
I : Integer;
begin
I := G.I;
if I < N - M then
Y := (G.S (I) and Bit31_Mask) or (G.S (I + 1) and Low31_Mask);
Y := G.S (I + M) xor Shift_Right (Y, 1) xor Matrix_A_X (Y and 1);
I := I + 1;
elsif I < N - 1 then
Y := (G.S (I) and Bit31_Mask) or (G.S (I + 1) and Low31_Mask);
Y := G.S (I + (M - N))
xor Shift_Right (Y, 1)
xor Matrix_A_X (Y and 1);
I := I + 1;
elsif I = N - 1 then
Y := (G.S (I) and Bit31_Mask) or (G.S (0) and Low31_Mask);
Y := G.S (M - 1) xor Shift_Right (Y, 1) xor Matrix_A_X (Y and 1);
I := 0;
else
Init (G, 5489);
return Random (Gen);
end if;
G.S (G.I) := Y;
G.I := I;
Y := Y xor Shift_Right (Y, 11);
Y := Y xor (Shift_Left (Y, 7) and 16#9d2c5680#);
Y := Y xor (Shift_Left (Y, 15) and 16#efc60000#);
Y := Y xor Shift_Right (Y, 18);
return Y;
end Random;
function Random (Gen : Generator) return Float is
-- Note: The application of Float'Machine (...) is necessary to avoid
-- returning extra significand bits. Without it, the function's value
-- will change if it is spilled, for example, causing
-- gratuitous nondeterminism.
Result : constant Float :=
Float'Machine
(Float (Unsigned_32'(Random (Gen))) * 2.0 ** (-32));
begin
if Result < 1.0 then
return Result;
else
return Float'Adjacent (1.0, 0.0);
end if;
end Random;
function Random (Gen : Generator) return Long_Float is
Result : constant Long_Float :=
Long_Float'Machine ((Long_Float (Unsigned_32'(Random (Gen)))
* 2.0 ** (-32))
+ (Long_Float (Unsigned_32'(Random (Gen))) * 2.0 ** (-64)));
begin
if Result < 1.0 then
return Result;
else
return Long_Float'Adjacent (1.0, 0.0);
end if;
end Random;
function Random (Gen : Generator) return Unsigned_64 is
begin
return Shift_Left (Unsigned_64 (Unsigned_32'(Random (Gen))), 32)
or Unsigned_64 (Unsigned_32'(Random (Gen)));
end Random;
---------------------
-- Random_Discrete --
---------------------
function Random_Discrete
(Gen : Generator;
Min : Result_Subtype := Default_Min;
Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype
is
begin
if Max = Min then
return Max;
elsif Max < Min then
raise Constraint_Error;
elsif Result_Subtype'Base'Size > 32 then
declare
-- In the 64-bit case, we have to be careful, since not all 64-bit
-- unsigned values are representable in GNAT's root_integer type.
-- Ignore different-size warnings here; since GNAT's handling
-- is correct.
pragma Warnings ("Z");
function Conv_To_Unsigned is
new Unchecked_Conversion (Result_Subtype'Base, Unsigned_64);
function Conv_To_Result is
new Unchecked_Conversion (Unsigned_64, Result_Subtype'Base);
pragma Warnings ("z");
N : constant Unsigned_64 :=
Conv_To_Unsigned (Max) - Conv_To_Unsigned (Min) + 1;
X, Slop : Unsigned_64;
begin
if N = 0 then
return Conv_To_Result (Conv_To_Unsigned (Min) + Random (Gen));
else
Slop := Unsigned_64'Last rem N + 1;
loop
X := Random (Gen);
exit when Slop = N or else X <= Unsigned_64'Last - Slop;
end loop;
return Conv_To_Result (Conv_To_Unsigned (Min) + X rem N);
end if;
end;
elsif Result_Subtype'Pos (Max) - Result_Subtype'Pos (Min) =
2 ** 32 - 1
then
return Result_Subtype'Val
(Result_Subtype'Pos (Min) + Unsigned_32'Pos (Random (Gen)));
else
declare
N : constant Unsigned_32 :=
Unsigned_32 (Result_Subtype'Pos (Max) -
Result_Subtype'Pos (Min) + 1);
Slop : constant Unsigned_32 := Unsigned_32'Last rem N + 1;
X : Unsigned_32;
begin
loop
X := Random (Gen);
exit when Slop = N or else X <= Unsigned_32'Last - Slop;
end loop;
return
Result_Subtype'Val
(Result_Subtype'Pos (Min) + Unsigned_32'Pos (X rem N));
end;
end if;
end Random_Discrete;
------------------
-- Random_Float --
------------------
function Random_Float (Gen : Generator) return Result_Subtype is
begin
if Result_Subtype'Base'Digits > Float'Digits then
return Result_Subtype'Machine (Result_Subtype
(Long_Float'(Random (Gen))));
else
return Result_Subtype'Machine (Result_Subtype
(Float'(Random (Gen))));
end if;
end Random_Float;
-----------
-- Reset --
-----------
procedure Reset (Gen : out Generator) is
X : constant Unsigned_32 := Unsigned_32 ((Calendar.Clock - Y2K) * 64.0);
begin
Init (Gen, X);
end Reset;
procedure Reset (Gen : out Generator; Initiator : Integer_32) is
begin
Init (Gen, To_Unsigned (Initiator));
end Reset;
procedure Reset (Gen : out Generator; Initiator : Unsigned_32) is
begin
Init (Gen, Initiator);
end Reset;
procedure Reset (Gen : out Generator; Initiator : Integer) is
begin
pragma Warnings ("C");
-- This is probably an unnecessary precaution against future change, but
-- since the test is a static expression, no extra code is involved.
if Integer'Size <= 32 then
Init (Gen, To_Unsigned (Integer_32 (Initiator)));
else
declare
Initiator1 : constant Unsigned_64 :=
To_Unsigned (Integer_64 (Initiator));
Init0 : constant Unsigned_32 :=
Unsigned_32 (Initiator1 mod 2 ** 32);
Init1 : constant Unsigned_32 :=
Unsigned_32 (Shift_Right (Initiator1, 32));
begin
Reset (Gen, Initialization_Vector'(Init0, Init1));
end;
end if;
pragma Warnings ("c");
end Reset;
procedure Reset (Gen : out Generator; Initiator : Initialization_Vector) is
I, J : Integer;
begin
Init (Gen, 19650218);
I := 1;
J := 0;
if Initiator'Length > 0 then
for K in reverse 1 .. Integer'Max (N, Initiator'Length) loop
Gen.S (I) :=
(Gen.S (I)
xor ((Gen.S (I - 1) xor Shift_Right (Gen.S (I - 1), 30))
* 1664525))
+ Initiator (J + Initiator'First) + Unsigned_32 (J);
I := I + 1;
J := J + 1;
if I >= N then
Gen.S (0) := Gen.S (N - 1);
I := 1;
end if;
if J >= Initiator'Length then
J := 0;
end if;
end loop;
end if;
for K in reverse 1 .. N - 1 loop
Gen.S (I) :=
(Gen.S (I) xor ((Gen.S (I - 1)
xor Shift_Right (Gen.S (I - 1), 30)) * 1566083941))
- Unsigned_32 (I);
I := I + 1;
if I >= N then
Gen.S (0) := Gen.S (N - 1);
I := 1;
end if;
end loop;
Gen.S (0) := Bit31_Mask;
end Reset;
procedure Reset (Gen : out Generator; From_State : Generator) is
begin
Gen.S := From_State.S;
Gen.I := From_State.I;
end Reset;
procedure Reset (Gen : out Generator; From_State : State) is
begin
Gen.I := 0;
Gen.S := From_State;
end Reset;
procedure Reset (Gen : out Generator; From_Image : String) is
begin
Gen.I := 0;
for J in 0 .. N - 1 loop
Gen.S (J) := Extract_Value (From_Image, J);
end loop;
end Reset;
----------
-- Save --
----------
procedure Save (Gen : Generator; To_State : out State) is
Gen2 : Generator;
begin
if Gen.I = N then
Init (Gen2, 5489);
To_State := Gen2.S;
else
To_State (0 .. N - 1 - Gen.I) := Gen.S (Gen.I .. N - 1);
To_State (N - Gen.I .. N - 1) := Gen.S (0 .. Gen.I - 1);
end if;
end Save;
-----------
-- Image --
-----------
function Image (Of_State : State) return String is
Result : Image_String;
begin
Result := (others => ' ');
for J in Of_State'Range loop
Insert_Image (Result, J, Of_State (J));
end loop;
return Result;
end Image;
function Image (Gen : Generator) return String is
Result : Image_String;
begin
Result := (others => ' ');
for J in 0 .. N - 1 loop
Insert_Image (Result, J, Gen.S ((J + Gen.I) mod N));
end loop;
return Result;
end Image;
-----------
-- Value --
-----------
function Value (Coded_State : String) return State is
Gen : Generator;
S : State;
begin
Reset (Gen, Coded_State);
Save (Gen, S);
return S;
end Value;
----------
-- Init --
----------
procedure Init (Gen : out Generator; Initiator : Unsigned_32) is
begin
Gen.S (0) := Initiator;
for I in 1 .. N - 1 loop
Gen.S (I) :=
1812433253
* (Gen.S (I - 1) xor Shift_Right (Gen.S (I - 1), 30))
+ Unsigned_32 (I);
end loop;
Gen.I := 0;
end Init;
------------------
-- Insert_Image --
------------------
procedure Insert_Image
(S : in out Image_String;
Index : Integer;
V : State_Val)
is
Value : constant String := State_Val'Image (V);
begin
S (Index * 11 + 1 .. Index * 11 + Value'Length) := Value;
end Insert_Image;
-------------------
-- Extract_Value --
-------------------
function Extract_Value (S : String; Index : Integer) return State_Val is
begin
return State_Val'Value (S (S'First + Index * 11 ..
S'First + Index * 11 + 11));
end Extract_Value;
end System.Random_Numbers;
gcc/ada/s-rannum.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . R A N D O M _ N U M B E R S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Extended pseudo-random number generation
-- This package provides a type representing pseudo-random number generators,
-- and subprograms to extract various uniform distributions of numbers
-- from them. It also provides types for representing initialization values
-- and snapshots of internal generator state, which permit reproducible
-- pseudo-random streams.
-- The generator currently provided by this package has an extremely long
-- period (at least 2**19937-1), and passes the Big Crush test suite, with the
-- exception of the two linear complexity tests. Therefore, it is suitable
-- for simulations, but should not be used as a cryptographic pseudo-random
-- source without additional processing.
-- Note: this package is in the System hierarchy so that it can be directly
-- used by other predefined packages. User access to this package is via
-- the package GNAT.Random_Numbers (file g-rannum.ads), which also extends
-- its capabilities. The interfaces are different so as to include in
-- System.Random_Numbers only the definitions necessary to implement the
-- standard random-number packages Ada.Numerics.Float_Random and
-- Ada.Numerics.Discrete_Random.
with Interfaces;
package System.Random_Numbers is
type Generator is limited private;
type State is private;
-- A non-limited version of a Generator's internal state
function Random (Gen : Generator) return Float;
function Random (Gen : Generator) return Long_Float;
-- Return pseudo-random numbers uniformly distributed on [0 .. 1)
function Random (Gen : Generator) return Interfaces.Unsigned_32;
function Random (Gen : Generator) return Interfaces.Unsigned_64;
-- Return pseudo-random numbers uniformly distributed on T'First .. T'Last
-- for builtin integer types.
generic
type Result_Subtype is (<>);
Default_Min : Result_Subtype := Result_Subtype'Val (0);
function Random_Discrete
(Gen : Generator;
Min : Result_Subtype := Default_Min;
Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype;
-- Returns pseudo-random numbers uniformly distributed on Min .. Max
generic
type Result_Subtype is digits <>;
function Random_Float (Gen : Generator) return Result_Subtype;
-- Returns pseudo-random numbers uniformly distributed on [0 .. 1)
type Initialization_Vector is
array (Integer range <>) of Interfaces.Unsigned_32;
-- Provides the most general initialization values for a generator (used
-- in Reset). In general, there is little point in providing more than
-- a certain number of values (currently 624).
procedure Reset (Gen : out Generator);
-- Re-initialize the state of Gen from the time of day
procedure Reset (Gen : out Generator; Initiator : Initialization_Vector);
procedure Reset (Gen : out Generator; Initiator : Interfaces.Integer_32);
procedure Reset (Gen : out Generator; Initiator : Interfaces.Unsigned_32);
procedure Reset (Gen : out Generator; Initiator : Integer);
-- Re-initialize Gen based on the Initiator in various ways. Identical
-- values of Initiator cause identical sequences of values.
procedure Reset (Gen : out Generator; From_State : Generator);
-- Causes the state of Gen to be identical to that of From_State; Gen
-- and From_State will produce identical sequences of values subsequently.
procedure Reset (Gen : out Generator; From_State : State);
procedure Save (Gen : Generator; To_State : out State);
-- The sequence
-- Save (Gen2, S); Reset (Gen1, S)
-- has the same effect as Reset (Gen2, Gen1).
procedure Reset (Gen : out Generator; From_Image : String);
function Image (Gen : Generator) return String;
-- The call
-- Reset (Gen2, Image (Gen1))
-- has the same effect as Reset (Gen2, Gen1);
Max_Image_Width : constant := 11 * 624;
-- Maximum possible length of result of Image (...)
function Image (Of_State : State) return String;
-- A String representation of Of_State. Identical to the result of
-- Image (Gen), if Of_State has been set with Save (Gen, Of_State).
function Value (Coded_State : String) return State;
-- Inverse of Image on States
private
N : constant := 624;
-- The number of 32-bit integers in the shift register
M : constant := 397;
-- Feedback distance from the current position
subtype State_Val is Interfaces.Unsigned_32;
type State is array (0 .. N - 1) of State_Val;
type Generator is limited record
S : State := (others => 0);
-- The shift register, a circular buffer
I : Integer := N;
-- Current starting position in shift register S
end record;
end System.Random_Numbers;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment