|
111
|
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 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
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 System.Unsigned_Types; use System.Unsigned_Types;
|
|
|
33 with System.Val_Util; use System.Val_Util;
|
|
|
34
|
|
|
35 package 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
|
|
|
330 end System.Val_LLU;
|
