111
|
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 -- --
|
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_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
|
|
325 end System.Val_Uns;
|