OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [a-nuflra.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT RUN-TIME COMPONENTS                         --
4
--                                                                          --
5
--            A D A . N U M E R I C S . F L O A T _ R A N D O M             --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
-- GNAT was originally developed  by the GNAT team at  New York University. --
28
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29
--                                                                          --
30
------------------------------------------------------------------------------
31
 
32
with Ada.Calendar;
33
 
34
package body Ada.Numerics.Float_Random is
35
 
36
   -------------------------
37
   -- Implementation Note --
38
   -------------------------
39
 
40
   --  The design of this spec is very awkward, as a result of Ada 95 not
41
   --  permitting in-out parameters for function formals (most naturally
42
   --  Generator values would be passed this way). In pure Ada 95, the only
43
   --  solution is to use the heap and pointers, and, to avoid memory leaks,
44
   --  controlled types.
45
 
46
   --  This is awfully heavy, so what we do is to use Unrestricted_Access to
47
   --  get a pointer to the state in the passed Generator. This works because
48
   --  Generator is a limited type and will thus always be passed by reference.
49
 
50
   type Pointer is access all State;
51
 
52
   -----------------------
53
   -- Local Subprograms --
54
   -----------------------
55
 
56
   procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int);
57
 
58
   function  Euclid (P, Q : Int) return Int;
59
 
60
   function Square_Mod_N (X, N : Int) return Int;
61
 
62
   ------------
63
   -- Euclid --
64
   ------------
65
 
66
   procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int) is
67
 
68
      XT : Int := 1;
69
      YT : Int := 0;
70
 
71
      procedure Recur
72
        (P,  Q  : Int;                    --  a (i-1), a (i)
73
         X,  Y  : Int;                    --  x (i),   y (i)
74
         XP, YP : in out Int;             --  x (i-1), y (i-1)
75
         GCD    : out Int);
76
 
77
      procedure Recur
78
        (P,  Q  : Int;
79
         X,  Y  : Int;
80
         XP, YP : in out Int;
81
         GCD    : out Int)
82
      is
83
         Quo : Int := P / Q;              --  q <-- |_ a (i-1) / a (i) _|
84
         XT  : Int := X;                  --  x (i)
85
         YT  : Int := Y;                  --  y (i)
86
 
87
      begin
88
         if P rem Q = 0 then                 --  while does not divide
89
            GCD := Q;
90
            XP  := X;
91
            YP  := Y;
92
         else
93
            Recur (Q, P - Q * Quo, XP - Quo * X, YP - Quo * Y, XT, YT, Quo);
94
 
95
            --  a (i) <== a (i)
96
            --  a (i+1) <-- a (i-1) - q*a (i)
97
            --  x (i+1) <-- x (i-1) - q*x (i)
98
            --  y (i+1) <-- y (i-1) - q*y (i)
99
            --  x (i) <== x (i)
100
            --  y (i) <== y (i)
101
 
102
            XP  := XT;
103
            YP  := YT;
104
            GCD := Quo;
105
         end if;
106
      end Recur;
107
 
108
   --  Start of processing for Euclid
109
 
110
   begin
111
      Recur (P, Q, 0, 1, XT, YT, GCD);
112
      X := XT;
113
      Y := YT;
114
   end Euclid;
115
 
116
   function Euclid (P, Q : Int) return Int is
117
      X, Y, GCD : Int;
118
      pragma Unreferenced (Y, GCD);
119
   begin
120
      Euclid (P, Q, X, Y, GCD);
121
      return X;
122
   end Euclid;
123
 
124
   -----------
125
   -- Image --
126
   -----------
127
 
128
   function Image (Of_State : State) return String is
129
   begin
130
      return Int'Image (Of_State.X1) & ',' & Int'Image (Of_State.X2)
131
             & ',' &
132
             Int'Image (Of_State.P)  & ',' & Int'Image (Of_State.Q);
133
   end Image;
134
 
135
   ------------
136
   -- Random --
137
   ------------
138
 
139
   function Random  (Gen : Generator) return Uniformly_Distributed is
140
      Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access;
141
 
142
   begin
143
      Genp.X1 := Square_Mod_N (Genp.X1,  Genp.P);
144
      Genp.X2 := Square_Mod_N (Genp.X2,  Genp.Q);
145
      return
146
        Float ((Flt (((Genp.X2 - Genp.X1) * Genp.X)
147
                  mod Genp.Q) * Flt (Genp.P)
148
          + Flt (Genp.X1)) * Genp.Scl);
149
   end Random;
150
 
151
   -----------
152
   -- Reset --
153
   -----------
154
 
155
   --  Version that works from given initiator value
156
 
157
   procedure Reset (Gen : Generator; Initiator : Integer) is
158
      Genp   : constant Pointer := Gen.Gen_State'Unrestricted_Access;
159
      X1, X2 : Int;
160
 
161
   begin
162
      X1 := 2 + Int (Initiator) mod (K1 - 3);
163
      X2 := 2 + Int (Initiator) mod (K2 - 3);
164
 
165
      --  Eliminate effects of small initiators
166
 
167
      for J in 1 .. 5 loop
168
         X1 := Square_Mod_N (X1, K1);
169
         X2 := Square_Mod_N (X2, K2);
170
      end loop;
171
 
172
      Genp.all :=
173
        (X1  => X1,
174
         X2  => X2,
175
         P   => K1,
176
         Q   => K2,
177
         X   => 1,
178
         Scl => Scal);
179
   end Reset;
180
 
181
   --  Version that works from specific saved state
182
 
183
   procedure Reset (Gen : Generator; From_State : State) is
184
      Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access;
185
 
186
   begin
187
      Genp.all := From_State;
188
   end Reset;
189
 
190
   --  Version that works from calendar
191
 
192
   procedure Reset (Gen : Generator) is
193
      Genp   : constant Pointer       := Gen.Gen_State'Unrestricted_Access;
194
      Now    : constant Calendar.Time := Calendar.Clock;
195
      X1, X2 : Int;
196
 
197
   begin
198
      X1 := Int (Calendar.Year  (Now)) * 12 * 31 +
199
            Int (Calendar.Month (Now)) * 31 +
200
            Int (Calendar.Day   (Now));
201
 
202
      X2 := Int (Calendar.Seconds (Now) * Duration (1000.0));
203
 
204
      X1 := 2 + X1 mod (K1 - 3);
205
      X2 := 2 + X2 mod (K2 - 3);
206
 
207
      --  Eliminate visible effects of same day starts
208
 
209
      for J in 1 .. 5 loop
210
         X1 := Square_Mod_N (X1, K1);
211
         X2 := Square_Mod_N (X2, K2);
212
      end loop;
213
 
214
      Genp.all :=
215
        (X1  => X1,
216
         X2  => X2,
217
         P   => K1,
218
         Q   => K2,
219
         X   => 1,
220
         Scl => Scal);
221
 
222
   end Reset;
223
 
224
   ----------
225
   -- Save --
226
   ----------
227
 
228
   procedure Save (Gen : Generator; To_State : out State) is
229
   begin
230
      To_State := Gen.Gen_State;
231
   end Save;
232
 
233
   ------------------
234
   -- Square_Mod_N --
235
   ------------------
236
 
237
   function Square_Mod_N (X, N : Int) return Int is
238
      Temp : constant Flt := Flt (X) * Flt (X);
239
      Div  : Int;
240
 
241
   begin
242
      Div := Int (Temp / Flt (N));
243
      Div := Int (Temp - Flt (Div) * Flt (N));
244
 
245
      if Div < 0 then
246
         return Div + N;
247
      else
248
         return Div;
249
      end if;
250
   end Square_Mod_N;
251
 
252
   -----------
253
   -- Value --
254
   -----------
255
 
256
   function Value (Coded_State : String) return State is
257
      Last  : constant Natural := Coded_State'Last;
258
      Start : Positive := Coded_State'First;
259
      Stop  : Positive := Coded_State'First;
260
      Outs  : State;
261
 
262
   begin
263
      while Stop <= Last and then Coded_State (Stop) /= ',' loop
264
         Stop := Stop + 1;
265
      end loop;
266
 
267
      if Stop > Last then
268
         raise Constraint_Error;
269
      end if;
270
 
271
      Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1));
272
      Start := Stop + 1;
273
 
274
      loop
275
         Stop := Stop + 1;
276
         exit when Stop > Last or else Coded_State (Stop) = ',';
277
      end loop;
278
 
279
      if Stop > Last then
280
         raise Constraint_Error;
281
      end if;
282
 
283
      Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1));
284
      Start := Stop + 1;
285
 
286
      loop
287
         Stop := Stop + 1;
288
         exit when Stop > Last or else Coded_State (Stop) = ',';
289
      end loop;
290
 
291
      if Stop > Last then
292
         raise Constraint_Error;
293
      end if;
294
 
295
      Outs.P   := Int'Value (Coded_State (Start .. Stop - 1));
296
      Outs.Q   := Int'Value (Coded_State (Stop + 1 .. Last));
297
      Outs.X   := Euclid (Outs.P, Outs.Q);
298
      Outs.Scl := 1.0 / (Flt (Outs.P) * Flt (Outs.Q));
299
 
300
      --  Now do *some* sanity checks
301
 
302
      if Outs.Q < 31 or else Outs.P < 31
303
        or else Outs.X1 not in 2 .. Outs.P - 1
304
        or else Outs.X2 not in 2 .. Outs.Q - 1
305
      then
306
         raise Constraint_Error;
307
      end if;
308
 
309
      return Outs;
310
   end Value;
311
end Ada.Numerics.Float_Random;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.