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-2012, 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      P := Ptr.all;
69      Uval := Character'Pos (Str (P)) - Character'Pos ('0');
70      P := P + 1;
71
72      --  Scan out digits of what is either the number or the base.
73      --  In either case, we are definitely scanning out in base 10.
74
75      declare
76         Umax : constant := (Long_Long_Unsigned'Last - 9) / 10;
77         --  Max value which cannot overflow on accumulating next digit
78
79         Umax10 : constant := Long_Long_Unsigned'Last / 10;
80         --  Numbers bigger than Umax10 overflow if multiplied by 10
81
82      begin
83         --  Loop through decimal digits
84         loop
85            exit when P > Max;
86
87            Digit := Character'Pos (Str (P)) - Character'Pos ('0');
88
89            --  Non-digit encountered
90
91            if Digit > 9 then
92               if Str (P) = '_' then
93                  Scan_Underscore (Str, P, Ptr, Max, False);
94               else
95                  exit;
96               end if;
97
98            --  Accumulate result, checking for overflow
99
100            else
101               if Uval <= Umax then
102                  Uval := 10 * Uval + Digit;
103
104               elsif Uval > Umax10 then
105                  Overflow := True;
106
107               else
108                  Uval := 10 * Uval + Digit;
109
110                  if Uval < Umax10 then
111                     Overflow := True;
112                  end if;
113               end if;
114
115               P := P + 1;
116            end if;
117         end loop;
118      end;
119
120      Ptr.all := P;
121
122      --  Deal with based case
123
124      if P < Max and then (Str (P) = ':' or else Str (P) = '#') then
125         Base_Char := Str (P);
126         P := P + 1;
127         Base := Uval;
128         Uval := 0;
129
130         --  Check base value. Overflow is set True if we find a bad base, or
131         --  a digit that is out of range of the base. That way, we scan out
132         --  the numeral that is still syntactically correct, though illegal.
133         --  We use a safe base of 16 for this scan, to avoid zero divide.
134
135         if Base not in 2 .. 16 then
136            Overflow := True;
137            Base :=  16;
138         end if;
139
140         --  Scan out based integer
141
142         declare
143            Umax : constant Long_Long_Unsigned :=
144                     (Long_Long_Unsigned'Last - Base + 1) / Base;
145            --  Max value which cannot overflow on accumulating next digit
146
147            UmaxB : constant Long_Long_Unsigned :=
148                      Long_Long_Unsigned'Last / Base;
149            --  Numbers bigger than UmaxB overflow if multiplied by base
150
151         begin
152            --  Loop to scan out based integer value
153
154            loop
155               --  We require a digit at this stage
156
157               if Str (P) in '0' .. '9' then
158                  Digit := Character'Pos (Str (P)) - Character'Pos ('0');
159
160               elsif Str (P) in 'A' .. 'F' then
161                  Digit :=
162                    Character'Pos (Str (P)) - (Character'Pos ('A') - 10);
163
164               elsif Str (P) in 'a' .. 'f' then
165                  Digit :=
166                    Character'Pos (Str (P)) - (Character'Pos ('a') - 10);
167
168               --  If we don't have a digit, then this is not a based number
169               --  after all, so we use the value we scanned out as the base
170               --  (now in Base), and the pointer to the base character was
171               --  already stored in Ptr.all.
172
173               else
174                  Uval := Base;
175                  exit;
176               end if;
177
178               --  If digit is too large, just signal overflow and continue.
179               --  The idea here is to keep scanning as long as the input is
180               --  syntactically valid, even if we have detected overflow
181
182               if Digit >= Base then
183                  Overflow := True;
184
185               --  Here we accumulate the value, checking overflow
186
187               elsif Uval <= Umax then
188                  Uval := Base * Uval + Digit;
189
190               elsif Uval > UmaxB then
191                  Overflow := True;
192
193               else
194                  Uval := Base * Uval + Digit;
195
196                  if Uval < UmaxB then
197                     Overflow := True;
198                  end if;
199               end if;
200
201               --  If at end of string with no base char, not a based number
202               --  but we signal Constraint_Error and set the pointer past
203               --  the end of the field, since this is what the ACVC tests
204               --  seem to require, see CE3704N, line 204.
205
206               P := P + 1;
207
208               if P > Max then
209                  Ptr.all := P;
210                  Bad_Value (Str);
211               end if;
212
213               --  If terminating base character, we are done with loop
214
215               if Str (P) = Base_Char then
216                  Ptr.all := P + 1;
217                  exit;
218
219               --  Deal with underscore
220
221               elsif Str (P) = '_' then
222                  Scan_Underscore (Str, P, Ptr, Max, True);
223               end if;
224
225            end loop;
226         end;
227      end if;
228
229      --  Come here with scanned unsigned value in Uval. The only remaining
230      --  required step is to deal with exponent if one is present.
231
232      Expon := Scan_Exponent (Str, Ptr, Max);
233
234      if Expon /= 0 and then Uval /= 0 then
235
236         --  For non-zero value, scale by exponent value. No need to do this
237         --  efficiently, since use of exponent in integer literals is rare,
238         --  and in any case the exponent cannot be very large.
239
240         declare
241            UmaxB : constant Long_Long_Unsigned :=
242                      Long_Long_Unsigned'Last / Base;
243            --  Numbers bigger than UmaxB overflow if multiplied by base
244
245         begin
246            for J in 1 .. Expon loop
247               if Uval > UmaxB then
248                  Overflow := True;
249                  exit;
250               end if;
251
252               Uval := Uval * Base;
253            end loop;
254         end;
255      end if;
256
257      --  Return result, dealing with sign and overflow
258
259      if Overflow then
260         Bad_Value (Str);
261      else
262         return Uval;
263      end if;
264   end Scan_Raw_Long_Long_Unsigned;
265
266   -----------------------------
267   -- Scan_Long_Long_Unsigned --
268   -----------------------------
269
270   function Scan_Long_Long_Unsigned
271     (Str : String;
272      Ptr : not null access Integer;
273      Max : Integer) return Long_Long_Unsigned
274   is
275      Start : Positive;
276      --  Save location of first non-blank character
277
278   begin
279      Scan_Plus_Sign (Str, Ptr, Max, Start);
280
281      if Str (Ptr.all) not in '0' .. '9' then
282         Ptr.all := Start;
283         raise Constraint_Error;
284      end if;
285
286      return Scan_Raw_Long_Long_Unsigned (Str, Ptr, Max);
287   end Scan_Long_Long_Unsigned;
288
289   ------------------------------
290   -- Value_Long_Long_Unsigned --
291   ------------------------------
292
293   function Value_Long_Long_Unsigned
294     (Str : String) return Long_Long_Unsigned
295   is
296      V : Long_Long_Unsigned;
297      P : aliased Integer := Str'First;
298   begin
299      V := Scan_Long_Long_Unsigned (Str, P'Access, Str'Last);
300      Scan_Trailing_Blanks (Str, P);
301      return V;
302   end Value_Long_Long_Unsigned;
303
304end System.Val_LLU;
305