# This makefile fragment is included in the ada Makefile (both Unix
# 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.
# Objects needed only for tasking
# Objects needed for non-tasking.
GNATRTL_NONTASKING_OBJS= \
+ a-assert$(objext) \
a-calari$(objext) \
a-caldel$(objext) \
a-calend$(objext) \
a-ngcefu$(objext) \
a-ngcoty$(objext) \
a-ngelfu$(objext) \
+ a-ngrear$(objext) \
a-nlcefu$(objext) \
a-nlcoty$(objext) \
a-nlelfu$(objext) \
a-zzunio$(objext) \
ada$(objext) \
calendar$(objext) \
+ directio$(objext) \
g-allein$(objext) \
g-alleve$(objext) \
g-altcon$(objext) \
g-moreex$(objext) \
g-os_lib$(objext) \
g-pehage$(objext) \
+ g-rannum$(objext) \
g-regexp$(objext) \
g-regpat$(objext) \
g-sestin$(objext) \
s-poosiz$(objext) \
s-powtab$(objext) \
s-purexc$(objext) \
+ s-rannum$(objext) \
s-regexp$(objext) \
s-regpat$(objext) \
s-restri$(objext) \
s-wwdcha$(objext) \
s-wwdenu$(objext) \
s-wwdwch$(objext) \
+ sequenio$(objext) \
system$(objext) \
- text_io$(objext) $(EXTRA_GNATRTL_NONTASKING_OBJS)
+ text_io$(objext) \
+ unchconv$(objext) \
+ unchdeal$(objext) \
+ $(EXTRA_GNATRTL_NONTASKING_OBJS)
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
"g-moreex", -- GNAT.Most_Recent_Exception
"g-os_lib", -- GNAT.Os_Lib
"g-pehage", -- GNAT.Perfect_Hash_Generators
+ "g-rannum", -- GNAT.Random_Numbers
"g-regexp", -- GNAT.Regexp
"g-regist", -- GNAT.Registry
"g-regpat", -- GNAT.Regpat
-- Ada Hierarchy Units from Ada 2005 Reference Manual --
--------------------------------------------------------
+ "a-assert", -- Ada.Assertions
"a-calari", -- Ada.Calendar.Arithmetic
"a-calfor", -- Ada.Calendar.Formatting
"a-catizo", -- Ada.Calendar.Time_Zones
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
OSDN Git Service
