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