1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                       S Y S T E M . V A L _ U N S                        --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2018, 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;
34
35package body System.Val_Uns is
36
37   -----------------------
38   -- Scan_Raw_Unsigned --
39   -----------------------
40
41   function Scan_Raw_Unsigned
42     (Str : String;
43      Ptr : not null access Integer;
44      Max : Integer) return Unsigned
45   is
46      P : Integer;
47      --  Local copy of the pointer
48
49      Uval : Unsigned;
50      --  Accumulated unsigned integer result
51
52      Expon : Integer;
53      --  Exponent value
54
55      Overflow : Boolean := False;
56      --  Set True if overflow is detected at any point
57
58      Base_Char : Character;
59      --  Base character (# or :) in based case
60
61      Base : Unsigned := 10;
62      --  Base value (reset in based case)
63
64      Digit : Unsigned;
65      --  Digit value
66
67   begin
68      --  We do not tolerate strings with Str'Last = Positive'Last
69
70      if Str'Last = Positive'Last then
71         raise Program_Error with
72           "string upper bound is Positive'Last, not supported";
73      end if;
74
75      P := Ptr.all;
76      Uval := Character'Pos (Str (P)) - Character'Pos ('0');
77      P := P + 1;
78
79      --  Scan out digits of what is either the number or the base.
80      --  In either case, we are definitely scanning out in base 10.
81
82      declare
83         Umax : constant := (Unsigned'Last - 9) / 10;
84         --  Max value which cannot overflow on accumulating next digit
85
86         Umax10 : constant := Unsigned'Last / 10;
87         --  Numbers bigger than Umax10 overflow if multiplied by 10
88
89      begin
90         --  Loop through decimal digits
91         loop
92            exit when P > Max;
93
94            Digit := Character'Pos (Str (P)) - Character'Pos ('0');
95
96            --  Non-digit encountered
97
98            if Digit > 9 then
99               if Str (P) = '_' then
100                  Scan_Underscore (Str, P, Ptr, Max, False);
101               else
102                  exit;
103               end if;
104
105            --  Accumulate result, checking for overflow
106
107            else
108               if Uval <= Umax then
109                  Uval := 10 * Uval + Digit;
110
111               elsif Uval > Umax10 then
112                  Overflow := True;
113
114               else
115                  Uval := 10 * Uval + Digit;
116
117                  if Uval < Umax10 then
118                     Overflow := True;
119                  end if;
120               end if;
121
122               P := P + 1;
123            end if;
124         end loop;
125      end;
126
127      Ptr.all := P;
128
129      --  Deal with based case. We recognize either the standard '#' or the
130      --  allowed alternative replacement ':' (see RM J.2(3)).
131
132      if P < Max and then (Str (P) = '#' or else Str (P) = ':') then
133         Base_Char := Str (P);
134         P := P + 1;
135         Base := Uval;
136         Uval := 0;
137
138         --  Check base value. Overflow is set True if we find a bad base, or
139         --  a digit that is out of range of the base. That way, we scan out
140         --  the numeral that is still syntactically correct, though illegal.
141         --  We use a safe base of 16 for this scan, to avoid zero divide.
142
143         if Base not in 2 .. 16 then
144            Overflow := True;
145            Base := 16;
146         end if;
147
148         --  Scan out based integer
149
150         declare
151            Umax : constant Unsigned := (Unsigned'Last - Base + 1) / Base;
152            --  Max value which cannot overflow on accumulating next digit
153
154            UmaxB : constant Unsigned := Unsigned'Last / Base;
155            --  Numbers bigger than UmaxB overflow if multiplied by base
156
157         begin
158            --  Loop to scan out based integer value
159
160            loop
161               --  We require a digit at this stage
162
163               if Str (P) in '0' .. '9' then
164                  Digit := Character'Pos (Str (P)) - Character'Pos ('0');
165
166               elsif Str (P) in 'A' .. 'F' then
167                  Digit :=
168                    Character'Pos (Str (P)) - (Character'Pos ('A') - 10);
169
170               elsif Str (P) in 'a' .. 'f' then
171                  Digit :=
172                    Character'Pos (Str (P)) - (Character'Pos ('a') - 10);
173
174               --  If we don't have a digit, then this is not a based number
175               --  after all, so we use the value we scanned out as the base
176               --  (now in Base), and the pointer to the base character was
177               --  already stored in Ptr.all.
178
179               else
180                  Uval := Base;
181                  exit;
182               end if;
183
184               --  If digit is too large, just signal overflow and continue.
185               --  The idea here is to keep scanning as long as the input is
186               --  syntactically valid, even if we have detected overflow
187
188               if Digit >= Base then
189                  Overflow := True;
190
191               --  Here we accumulate the value, checking overflow
192
193               elsif Uval <= Umax then
194                  Uval := Base * Uval + Digit;
195
196               elsif Uval > UmaxB then
197                  Overflow := True;
198
199               else
200                  Uval := Base * Uval + Digit;
201
202                  if Uval < UmaxB then
203                     Overflow := True;
204                  end if;
205               end if;
206
207               --  If at end of string with no base char, not a based number
208               --  but we signal Constraint_Error and set the pointer past
209               --  the end of the field, since this is what the ACVC tests
210               --  seem to require, see CE3704N, line 204.
211
212               P := P + 1;
213
214               if P > Max then
215                  Ptr.all := P;
216                  Bad_Value (Str);
217               end if;
218
219               --  If terminating base character, we are done with loop
220
221               if Str (P) = Base_Char then
222                  Ptr.all := P + 1;
223                  exit;
224
225               --  Deal with underscore
226
227               elsif Str (P) = '_' then
228                  Scan_Underscore (Str, P, Ptr, Max, True);
229               end if;
230
231            end loop;
232         end;
233      end if;
234
235      --  Come here with scanned unsigned value in Uval. The only remaining
236      --  required step is to deal with exponent if one is present.
237
238      Expon := Scan_Exponent (Str, Ptr, Max);
239
240      if Expon /= 0 and then Uval /= 0 then
241
242         --  For non-zero value, scale by exponent value. No need to do this
243         --  efficiently, since use of exponent in integer literals is rare,
244         --  and in any case the exponent cannot be very large.
245
246         declare
247            UmaxB : constant Unsigned := Unsigned'Last / Base;
248            --  Numbers bigger than UmaxB overflow if multiplied by base
249
250         begin
251            for J in 1 .. Expon loop
252               if Uval > UmaxB then
253                  Overflow := True;
254                  exit;
255               end if;
256
257               Uval := Uval * Base;
258            end loop;
259         end;
260      end if;
261
262      --  Return result, dealing with sign and overflow
263
264      if Overflow then
265         Bad_Value (Str);
266      else
267         return Uval;
268      end if;
269   end Scan_Raw_Unsigned;
270
271   -------------------
272   -- Scan_Unsigned --
273   -------------------
274
275   function Scan_Unsigned
276     (Str : String;
277      Ptr : not null access Integer;
278      Max : Integer) return Unsigned
279   is
280      Start : Positive;
281      --  Save location of first non-blank character
282
283   begin
284      Scan_Plus_Sign (Str, Ptr, Max, Start);
285
286      if Str (Ptr.all) not in '0' .. '9' then
287         Ptr.all := Start;
288         Bad_Value (Str);
289      end if;
290
291      return Scan_Raw_Unsigned (Str, Ptr, Max);
292   end Scan_Unsigned;
293
294   --------------------
295   -- Value_Unsigned --
296   --------------------
297
298   function Value_Unsigned (Str : String) return Unsigned is
299   begin
300      --  We have to special case Str'Last = Positive'Last because the normal
301      --  circuit ends up setting P to Str'Last + 1 which is out of bounds. We
302      --  deal with this by converting to a subtype which fixes the bounds.
303
304      if Str'Last = Positive'Last then
305         declare
306            subtype NT is String (1 .. Str'Length);
307         begin
308            return Value_Unsigned (NT (Str));
309         end;
310
311      --  Normal case where Str'Last < Positive'Last
312
313      else
314         declare
315            V : Unsigned;
316            P : aliased Integer := Str'First;
317         begin
318            V := Scan_Unsigned (Str, P'Access, Str'Last);
319            Scan_Trailing_Blanks (Str, P);
320            return V;
321         end;
322      end if;
323   end Value_Unsigned;
324
325end System.Val_Uns;
326