1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                       S Y S T E M . V A L U E _ D                        --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--            Copyright (C) 2020, 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
32with System.Unsigned_Types; use System.Unsigned_Types;
33with System.Val_Util;       use System.Val_Util;
34with System.Value_R;
35
36package body System.Value_D is
37
38   pragma Assert (Int'Size <= Uns'Size);
39   --  We need an unsigned type large enough to represent the mantissa
40
41   package Impl is new Value_R (Uns, 2**(Int'Size - 1), Round => False);
42   --  We do not use the Extra digit for decimal fixed-point types
43
44   function Integer_to_Decimal
45     (Str    : String;
46      Val    : Uns;
47      Base   : Unsigned;
48      ScaleB : Integer;
49      Minus  : Boolean;
50      Scale  : Integer) return Int;
51   --  Convert the real value from integer to decimal representation
52
53   ------------------------
54   -- Integer_to_Decimal --
55   ------------------------
56
57   function Integer_to_Decimal
58     (Str    : String;
59      Val    : Uns;
60      Base   : Unsigned;
61      ScaleB : Integer;
62      Minus  : Boolean;
63      Scale  : Integer) return Int
64   is
65      function Safe_Expont
66        (Base   : Int;
67         Exp    : in out Natural;
68         Factor : Int) return Int;
69      --  Return (Base ** Exp) * Factor if the computation does not overflow,
70      --  or else the number of the form (Base ** K) * Factor with the largest
71      --  magnitude if the former computation overflows. In both cases, Exp is
72      --  updated to contain the remaining power in the computation. Note that
73      --  Factor is expected to be positive in this context.
74
75      function Unsigned_To_Signed (Val : Uns) return Int;
76      --  Convert an integer value from unsigned to signed representation
77
78      -----------------
79      -- Safe_Expont --
80      -----------------
81
82      function Safe_Expont
83        (Base   : Int;
84         Exp    : in out Natural;
85         Factor : Int) return Int
86      is
87         pragma Assert (Base /= 0 and then Factor > 0);
88
89         Max : constant Int := Int'Last / Base;
90
91         Result : Int := Factor;
92
93      begin
94         while Exp > 0 and then Result <= Max loop
95            Result := Result * Base;
96            Exp    := Exp - 1;
97         end loop;
98
99         return Result;
100      end Safe_Expont;
101
102      ------------------------
103      -- Unsigned_To_Signed --
104      ------------------------
105
106      function Unsigned_To_Signed (Val : Uns) return Int is
107      begin
108         --  Deal with overflow cases, and also with largest negative number
109
110         if Val > Uns (Int'Last) then
111            if Minus and then Val = Uns (-(Int'First)) then
112               return Int'First;
113            else
114               Bad_Value (Str);
115            end if;
116
117         --  Negative values
118
119         elsif Minus then
120            return -(Int (Val));
121
122         --  Positive values
123
124         else
125            return Int (Val);
126         end if;
127      end Unsigned_To_Signed;
128
129   begin
130      --  If the base of the value is 10 or its scaling factor is zero, then
131      --  add the scales (they are defined in the opposite sense) and apply
132      --  the result to the value, checking for overflow in the process.
133
134      if Base = 10 or else ScaleB = 0 then
135         declare
136            S : Integer := ScaleB + Scale;
137            V : Uns     := Val;
138
139         begin
140            while S < 0 loop
141               V := V / 10;
142               S := S + 1;
143            end loop;
144
145            while S > 0 loop
146               if V <= Uns'Last / 10 then
147                  V := V * 10;
148                  S := S - 1;
149               else
150                  Bad_Value (Str);
151               end if;
152            end loop;
153
154            return Unsigned_To_Signed (V);
155         end;
156
157      --  If the base of the value is not 10, use a scaled divide operation
158      --  to compute Val * (Base ** ScaleB) * (10 ** Scale).
159
160      else
161         declare
162            B : constant Int     := Int (Base);
163            S : constant Integer := ScaleB;
164
165            V : Uns := Val;
166
167            Y, Z, Q, R : Int;
168
169         begin
170            --  If S is too negative, then drop trailing digits
171
172            if S < 0 then
173               declare
174                  LS : Integer := -S;
175
176               begin
177                  Y := 10 ** Integer'Max (0, Scale);
178                  Z := Safe_Expont (B, LS, 10 ** Integer'Max (0, -Scale));
179
180                  for J in 1 .. LS loop
181                     V := V / Uns (B);
182                  end loop;
183               end;
184
185            --  If S is too positive, then scale V up, which may then overflow
186
187            elsif S > 0 then
188               declare
189                  LS  : Integer := S;
190
191               begin
192                  Y := Safe_Expont (B, LS, 10 ** Integer'Max (0, Scale));
193                  Z := 10 ** Integer'Max (0, -Scale);
194
195                  for J in 1 .. LS loop
196                     if V <= Uns'Last / Uns (B) then
197                        V := V * Uns (B);
198                     else
199                        Bad_Value (Str);
200                     end if;
201                  end loop;
202               end;
203
204            --  The case S equal to zero should have been handled earlier
205
206            else
207               raise Program_Error;
208            end if;
209
210            --  Perform a scale divide operation with rounding to match 'Image
211
212            Scaled_Divide (Unsigned_To_Signed (V), Y, Z, Q, R, Round => True);
213
214            return Q;
215         end;
216      end if;
217
218   exception
219      when Constraint_Error => Bad_Value (Str);
220   end Integer_to_Decimal;
221
222   ------------------
223   -- Scan_Decimal --
224   ------------------
225
226   function Scan_Decimal
227     (Str   : String;
228      Ptr   : not null access Integer;
229      Max   : Integer;
230      Scale : Integer) return Int
231   is
232      Base   : Unsigned;
233      ScaleB : Integer;
234      Extra  : Unsigned;
235      pragma Unreferenced (Extra);
236      Minus  : Boolean;
237      Val    : Uns;
238
239   begin
240      Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus);
241
242      return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale);
243   end Scan_Decimal;
244
245   -------------------
246   -- Value_Decimal --
247   -------------------
248
249   function Value_Decimal (Str : String; Scale : Integer) return Int is
250      Base   : Unsigned;
251      ScaleB : Integer;
252      Extra  : Unsigned;
253      pragma Unreferenced (Extra);
254      Minus  : Boolean;
255      Val    : Uns;
256
257   begin
258      Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus);
259
260      return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale);
261   end Value_Decimal;
262
263end System.Value_D;
264