1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                       S Y S T E M . V A L _ L L U                        --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2015, 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_LLU is
36
37   ---------------------------------
38   -- Scan_Raw_Long_Long_Unsigned --
39   ---------------------------------
40
41   function Scan_Raw_Long_Long_Unsigned
42     (Str : String;
43      Ptr : not null access Integer;
44      Max : Integer) return Long_Long_Unsigned
45   is
46      P : Integer;
47      --  Local copy of the pointer
48
49      Uval : Long_Long_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 : Long_Long_Unsigned := 10;
62      --  Base value (reset in based case)
63
64      Digit : Long_Long_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 := (Long_Long_Unsigned'Last - 9) / 10;
84         --  Max value which cannot overflow on accumulating next digit
85
86         Umax10 : constant := Long_Long_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 Long_Long_Unsigned :=
152                     (Long_Long_Unsigned'Last - Base + 1) / Base;
153            --  Max value which cannot overflow on accumulating next digit
154
155            UmaxB : constant Long_Long_Unsigned :=
156                      Long_Long_Unsigned'Last / Base;
157            --  Numbers bigger than UmaxB overflow if multiplied by base
158
159         begin
160            --  Loop to scan out based integer value
161
162            loop
163               --  We require a digit at this stage
164
165               if Str (P) in '0' .. '9' then
166                  Digit := Character'Pos (Str (P)) - Character'Pos ('0');
167
168               elsif Str (P) in 'A' .. 'F' then
169                  Digit :=
170                    Character'Pos (Str (P)) - (Character'Pos ('A') - 10);
171
172               elsif Str (P) in 'a' .. 'f' then
173                  Digit :=
174                    Character'Pos (Str (P)) - (Character'Pos ('a') - 10);
175
176               --  If we don't have a digit, then this is not a based number
177               --  after all, so we use the value we scanned out as the base
178               --  (now in Base), and the pointer to the base character was
179               --  already stored in Ptr.all.
180
181               else
182                  Uval := Base;
183                  exit;
184               end if;
185
186               --  If digit is too large, just signal overflow and continue.
187               --  The idea here is to keep scanning as long as the input is
188               --  syntactically valid, even if we have detected overflow
189
190               if Digit >= Base then
191                  Overflow := True;
192
193               --  Here we accumulate the value, checking overflow
194
195               elsif Uval <= Umax then
196                  Uval := Base * Uval + Digit;
197
198               elsif Uval > UmaxB then
199                  Overflow := True;
200
201               else
202                  Uval := Base * Uval + Digit;
203
204                  if Uval < UmaxB then
205                     Overflow := True;
206                  end if;
207               end if;
208
209               --  If at end of string with no base char, not a based number
210               --  but we signal Constraint_Error and set the pointer past
211               --  the end of the field, since this is what the ACVC tests
212               --  seem to require, see CE3704N, line 204.
213
214               P := P + 1;
215
216               if P > Max then
217                  Ptr.all := P;
218                  Bad_Value (Str);
219               end if;
220
221               --  If terminating base character, we are done with loop
222
223               if Str (P) = Base_Char then
224                  Ptr.all := P + 1;
225                  exit;
226
227               --  Deal with underscore
228
229               elsif Str (P) = '_' then
230                  Scan_Underscore (Str, P, Ptr, Max, True);
231               end if;
232
233            end loop;
234         end;
235      end if;
236
237      --  Come here with scanned unsigned value in Uval. The only remaining
238      --  required step is to deal with exponent if one is present.
239
240      Expon := Scan_Exponent (Str, Ptr, Max);
241
242      if Expon /= 0 and then Uval /= 0 then
243
244         --  For non-zero value, scale by exponent value. No need to do this
245         --  efficiently, since use of exponent in integer literals is rare,
246         --  and in any case the exponent cannot be very large.
247
248         declare
249            UmaxB : constant Long_Long_Unsigned :=
250                      Long_Long_Unsigned'Last / Base;
251            --  Numbers bigger than UmaxB overflow if multiplied by base
252
253         begin
254            for J in 1 .. Expon loop
255               if Uval > UmaxB then
256                  Overflow := True;
257                  exit;
258               end if;
259
260               Uval := Uval * Base;
261            end loop;
262         end;
263      end if;
264
265      --  Return result, dealing with sign and overflow
266
267      if Overflow then
268         Bad_Value (Str);
269      else
270         return Uval;
271      end if;
272   end Scan_Raw_Long_Long_Unsigned;
273
274   -----------------------------
275   -- Scan_Long_Long_Unsigned --
276   -----------------------------
277
278   function Scan_Long_Long_Unsigned
279     (Str : String;
280      Ptr : not null access Integer;
281      Max : Integer) return Long_Long_Unsigned
282   is
283      Start : Positive;
284      --  Save location of first non-blank character
285
286   begin
287      Scan_Plus_Sign (Str, Ptr, Max, Start);
288
289      if Str (Ptr.all) not in '0' .. '9' then
290         Ptr.all := Start;
291         raise Constraint_Error;
292      end if;
293
294      return Scan_Raw_Long_Long_Unsigned (Str, Ptr, Max);
295   end Scan_Long_Long_Unsigned;
296
297   ------------------------------
298   -- Value_Long_Long_Unsigned --
299   ------------------------------
300
301   function Value_Long_Long_Unsigned
302     (Str : String) return Long_Long_Unsigned
303   is
304   begin
305      --  We have to special case Str'Last = Positive'Last because the normal
306      --  circuit ends up setting P to Str'Last + 1 which is out of bounds. We
307      --  deal with this by converting to a subtype which fixes the bounds.
308
309      if Str'Last = Positive'Last then
310         declare
311            subtype NT is String (1 .. Str'Length);
312         begin
313            return Value_Long_Long_Unsigned (NT (Str));
314         end;
315
316      --  Normal case where Str'Last < Positive'Last
317
318      else
319         declare
320            V : Long_Long_Unsigned;
321            P : aliased Integer := Str'First;
322         begin
323            V := Scan_Long_Long_Unsigned (Str, P'Access, Str'Last);
324            Scan_Trailing_Blanks (Str, P);
325            return V;
326         end;
327      end if;
328   end Value_Long_Long_Unsigned;
329
330end System.Val_LLU;
331