File : s-valuns.adb
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 -- --
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 -- --
19 -- --
20 -- --
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;