1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . V A L U E _ R --
9 -- Copyright (C) 2020-2024, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with System
.Val_Util
; use System
.Val_Util
;
34 package body System
.Value_R
is
36 subtype Char_As_Digit
is Unsigned
range 0 .. 17;
37 subtype Valid_Digit
is Char_As_Digit
range 0 .. 15;
38 E_Digit
: constant Char_As_Digit
:= 14;
39 Underscore
: constant Char_As_Digit
:= 16;
40 Not_A_Digit
: constant Char_As_Digit
:= 17;
42 function As_Digit
(C
: Character) return Char_As_Digit
;
43 -- Given a character return the digit it represents
46 (Digit
: Char_As_Digit
;
49 Scale
: in out Integer;
50 Extra
: in out Char_As_Digit
);
51 -- Round the triplet (Value, Scale, Extra) according to Digit in Base
53 procedure Scan_Decimal_Digits
55 Index
: in out Integer;
58 Base_Specified
: Boolean;
59 Value
: in out Value_Array
;
60 Scale
: in out Scale_Array
;
62 Extra
: in out Char_As_Digit
;
63 Base_Violation
: in out Boolean);
64 -- Scan the decimal part of a real (i.e. after decimal separator)
66 -- The string parsed is Str (Index .. Max) and after the call Index will
67 -- point to the first non-parsed character.
69 -- For each digit parsed, Value = Value * Base + Digit and Scale is
70 -- decremented by 1. If precision limit is reached, remaining digits are
71 -- still parsed but ignored, except for the first which is stored in Extra.
73 -- Base_Violation is set to True if a digit found is not part of the Base
75 -- If Base_Specified is set, then the base was specified in the real
77 procedure Scan_Integral_Digits
79 Index
: in out Integer;
82 Base_Specified
: Boolean;
83 Value
: out Value_Array
;
84 Scale
: out Scale_Array
;
86 Extra
: out Char_As_Digit
;
87 Base_Violation
: in out Boolean);
88 -- Scan the integral part of a real (i.e. before decimal separator)
90 -- The string parsed is Str (Index .. Max) and after the call Index will
91 -- point to the first non-parsed character.
93 -- For each digit parsed, either Value := Value * Base + Digit or Scale
94 -- is incremented by 1 if precision limit is reached, in which case the
95 -- remaining digits are still parsed but ignored, except for the first
96 -- which is stored in Extra.
98 -- Base_Violation is set to True if a digit found is not part of the Base
100 -- If Base_Specified is set, then the base was specified in the real
106 function As_Digit
(C
: Character) return Char_As_Digit
is
110 return Character'Pos (C
) - Character'Pos ('0');
112 return Character'Pos (C
) - (Character'Pos ('a') - 10);
114 return Character'Pos (C
) - (Character'Pos ('A') - 10);
126 procedure Round_Extra
127 (Digit
: Char_As_Digit
;
130 Scale
: in out Integer;
131 Extra
: in out Char_As_Digit
)
133 pragma Assert
(Base
in 2 .. 16);
135 B
: constant Uns
:= Uns
(Base
);
138 if Digit
>= Base
/ 2 then
140 -- If Extra is maximum, round Value
142 if Extra
= Base
- 1 then
144 -- If Value is maximum, scale it up
146 if Value
= Precision_Limit
then
147 Extra
:= Char_As_Digit
(Value
mod B
);
150 Round_Extra
(Digit
, Base
, Value
, Scale
, Extra
);
163 -------------------------
164 -- Scan_Decimal_Digits --
165 -------------------------
167 procedure Scan_Decimal_Digits
169 Index
: in out Integer;
172 Base_Specified
: Boolean;
173 Value
: in out Value_Array
;
174 Scale
: in out Scale_Array
;
176 Extra
: in out Char_As_Digit
;
177 Base_Violation
: in out Boolean)
180 pragma Assert
(Base
in 2 .. 16);
181 pragma Assert
(Index
in Str
'Range);
182 pragma Assert
(Max
<= Str
'Last);
184 Umax
: constant Uns
:= (Precision_Limit
- Uns
(Base
) + 1) / Uns
(Base
);
185 -- Max value which cannot overflow on accumulating next digit
187 UmaxB
: constant Uns
:= Precision_Limit
/ Uns
(Base
);
188 -- Numbers bigger than UmaxB overflow if multiplied by base
190 Precision_Limit_Reached
: Boolean;
191 -- Set to True if addition of a digit will cause Value to be superior
192 -- to Precision_Limit.
194 Precision_Limit_Just_Reached
: Boolean;
195 -- Set to True if Precision_Limit_Reached was just set to True, but only
196 -- used when Round is True.
198 Digit
: Char_As_Digit
;
204 Trailing_Zeros
: Natural;
205 -- Number of trailing zeros at a given point
208 -- If initial Scale is not 0 then it means that Precision_Limit was
209 -- reached during scanning of the integral part.
211 if Scale
(Data_Index
'Last) > 0 then
212 Precision_Limit_Reached
:= True;
215 Precision_Limit_Reached
:= False;
219 Precision_Limit_Just_Reached
:= False;
222 -- Initialize trailing zero counter
226 -- The function precondition is that the first character is a valid
229 Digit
:= As_Digit
(Str
(Index
));
232 -- Check if base is correct. If the base is not specified, the digit
233 -- E or e cannot be considered as a base violation as it can be used
234 -- for exponentiation.
236 if Digit
>= Base
then
237 if Base_Specified
then
238 Base_Violation
:= True;
239 elsif Digit
= E_Digit
then
242 Base_Violation
:= True;
246 -- If precision limit has been reached, just ignore any remaining
247 -- digits for the computation of Value and Scale, but store the
248 -- first in Extra and use the second to round Extra. The scanning
249 -- should continue only to assess the validity of the string.
251 if Precision_Limit_Reached
then
252 if Round
and then Precision_Limit_Just_Reached
then
253 Round_Extra
(Digit
, Base
, Value
(N
), Scale
(N
), Extra
);
254 Precision_Limit_Just_Reached
:= False;
258 -- Trailing '0' digits are ignored until a non-zero digit is found
261 Trailing_Zeros
:= Trailing_Zeros
+ 1;
264 -- Handle accumulated zeros
266 for J
in 1 .. Trailing_Zeros
loop
267 if Value
(N
) <= UmaxB
then
268 Value
(N
) := Value
(N
) * Uns
(Base
);
269 Scale
(N
) := Scale
(N
) - 1;
271 elsif Parts
> 1 and then N
< Data_Index
'Last then
273 Scale
(N
) := Scale
(N
- 1) - 1;
277 Precision_Limit_Reached
:= True;
278 if Round
and then J
= Trailing_Zeros
then
279 Round_Extra
(Digit
, Base
, Value
(N
), Scale
(N
), Extra
);
286 -- Reset trailing zero counter
290 -- Handle current non zero digit
292 Temp
:= Value
(N
) * Uns
(Base
) + Uns
(Digit
);
294 -- Precision_Limit_Reached may have been set above
296 if Precision_Limit_Reached
then
299 -- Check if Temp is larger than Precision_Limit, taking into
300 -- account that Temp may wrap around when Precision_Limit is
301 -- equal to the largest integer.
303 elsif Value
(N
) <= Umax
304 or else (Value
(N
) <= UmaxB
305 and then ((Precision_Limit
< Uns
'Last
306 and then Temp
<= Precision_Limit
)
307 or else (Precision_Limit
= Uns
'Last
308 and then Temp
>= Uns
(Base
))))
311 Scale
(N
) := Scale
(N
) - 1;
313 elsif Parts
> 1 and then N
< Data_Index
'Last then
315 Value
(N
) := Uns
(Digit
);
316 Scale
(N
) := Scale
(N
- 1) - 1;
320 Precision_Limit_Reached
:= True;
322 Precision_Limit_Just_Reached
:= True;
328 -- Check next character
336 Digit
:= As_Digit
(Str
(Index
));
338 if Digit
not in Valid_Digit
then
340 -- Underscore is only allowed if followed by a digit
342 if Digit
= Underscore
and Index
+ 1 <= Max
then
344 Digit
:= As_Digit
(Str
(Index
+ 1));
345 if Digit
in Valid_Digit
then
351 -- Neither a valid underscore nor a digit
358 end Scan_Decimal_Digits
;
360 --------------------------
361 -- Scan_Integral_Digits --
362 --------------------------
364 procedure Scan_Integral_Digits
366 Index
: in out Integer;
369 Base_Specified
: Boolean;
370 Value
: out Value_Array
;
371 Scale
: out Scale_Array
;
373 Extra
: out Char_As_Digit
;
374 Base_Violation
: in out Boolean)
376 pragma Assert
(Base
in 2 .. 16);
378 Umax
: constant Uns
:= (Precision_Limit
- Uns
(Base
) + 1) / Uns
(Base
);
379 -- Max value which cannot overflow on accumulating next digit
381 UmaxB
: constant Uns
:= Precision_Limit
/ Uns
(Base
);
382 -- Numbers bigger than UmaxB overflow if multiplied by base
384 Precision_Limit_Reached
: Boolean;
385 -- Set to True if addition of a digit will cause Value to be superior
386 -- to Precision_Limit.
388 Precision_Limit_Just_Reached
: Boolean;
389 -- Set to True if Precision_Limit_Reached was just set to True, but only
390 -- used when Round is True.
392 Digit
: Char_As_Digit
;
399 -- Initialize N, Value, Scale and Extra
402 Value
:= (others => 0);
403 Scale
:= (others => 0);
406 Precision_Limit_Reached
:= False;
409 Precision_Limit_Just_Reached
:= False;
412 pragma Assert
(Max
<= Str
'Last);
414 -- The function precondition is that the first character is a valid
417 Digit
:= As_Digit
(Str
(Index
));
420 -- Check if base is correct. If the base is not specified, the digit
421 -- E or e cannot be considered as a base violation as it can be used
422 -- for exponentiation.
424 if Digit
>= Base
then
425 if Base_Specified
then
426 Base_Violation
:= True;
427 elsif Digit
= E_Digit
then
430 Base_Violation
:= True;
434 -- If precision limit has been reached, just ignore any remaining
435 -- digits for the computation of Value and Scale, but store the
436 -- first in Extra and use the second to round Extra. The scanning
437 -- should continue only to assess the validity of the string.
439 if Precision_Limit_Reached
then
440 Scale
(N
) := Scale
(N
) + 1;
442 if Round
and then Precision_Limit_Just_Reached
then
443 Round_Extra
(Digit
, Base
, Value
(N
), Scale
(N
), Extra
);
444 Precision_Limit_Just_Reached
:= False;
448 Temp
:= Value
(N
) * Uns
(Base
) + Uns
(Digit
);
450 -- Check if Temp is larger than Precision_Limit, taking into
451 -- account that Temp may wrap around when Precision_Limit is
452 -- equal to the largest integer.
455 or else (Value
(N
) <= UmaxB
456 and then ((Precision_Limit
< Uns
'Last
457 and then Temp
<= Precision_Limit
)
458 or else (Precision_Limit
= Uns
'Last
459 and then Temp
>= Uns
(Base
))))
463 elsif Parts
> 1 and then N
< Data_Index
'Last then
465 Value
(N
) := Uns
(Digit
);
469 Precision_Limit_Reached
:= True;
471 Precision_Limit_Just_Reached
:= True;
473 Scale
(N
) := Scale
(N
) + 1;
477 -- Every parsed digit also scales the previous parts
479 for J
in 1 .. N
- 1 loop
480 Scale
(J
) := Scale
(J
) + 1;
483 -- Look for the next character
490 Digit
:= As_Digit
(Str
(Index
));
492 if Digit
not in Valid_Digit
then
494 -- Next character is not a digit. In that case stop scanning
495 -- unless the next chracter is an underscore followed by a digit.
497 if Digit
= Underscore
and Index
+ 1 <= Max
then
498 Digit
:= As_Digit
(Str
(Index
+ 1));
499 if Digit
in Valid_Digit
then
509 end Scan_Integral_Digits
;
515 function Scan_Raw_Real
517 Ptr
: not null access Integer;
520 Scale
: out Scale_Array
;
521 Extra
: out Unsigned
;
522 Minus
: out Boolean) return Value_Array
524 pragma Assert
(Max
<= Str
'Last);
526 After_Point
: Boolean;
527 -- True if a decimal should be parsed
529 Base_Char
: Character;
530 -- Character used to set the base. If it is Nul, this means that default
533 Base_Violation
: Boolean;
534 -- If True some digits where not in the base. The real is still scanned
535 -- till the end even if an error will be raised.
538 -- Index number of the current part
541 -- Exponent as an integer
544 -- Local copy of string pointer
547 -- Index of the first non-blank character
550 -- Mantissa as an array of integers
553 -- The default base is 10
556 Base_Char
:= ASCII
.NUL
;
557 Base_Violation
:= False;
559 -- We do not tolerate strings with Str'Last = Positive'Last
561 if Str
'Last = Positive'Last then
562 raise Program_Error
with
563 "string upper bound is Positive'Last, not supported";
566 -- Scan the optional sign
568 Scan_Sign
(Str
, Ptr
, Max
, Minus
, Start
);
571 pragma Assert
(Index
>= Str
'First);
573 pragma Annotate
(CodePeer
, Modified
, Str
(Index
));
575 -- First character can be either a decimal digit or a dot and for some
576 -- reason CodePeer incorrectly thinks it is always a digit.
578 if Str
(Index
) in '0' .. '9' then
579 After_Point
:= False;
581 -- If this is a digit it can indicates either the float decimal
582 -- part or the base to use.
585 (Str
, Index
, Max
, Base
, False, Value
, Scale
, N
,
586 Char_As_Digit
(Extra
), Base_Violation
);
588 -- A dot is allowed only if followed by a digit (RM 3.5(47))
590 elsif Str
(Index
) = '.'
592 and then Str
(Index
+ 1) in '0' .. '9'
597 Value
:= (others => 0);
598 Scale
:= (others => 0);
605 -- Check if the first number encountered is a base
607 pragma Assert
(Index
>= Str
'First);
610 and then (Str
(Index
) = '#' or else Str
(Index
) = ':')
612 Base_Char
:= Str
(Index
);
614 if N
= 1 and then Value
(1) in 2 .. 16 then
615 Base
:= Unsigned
(Value
(1));
617 Base_Violation
:= True;
625 and then As_Digit
(Str
(Index
+ 1)) in Valid_Digit
629 Value
:= (others => 0);
633 -- Scan the integral part if still necessary
635 if Base_Char
/= ASCII
.NUL
and then not After_Point
then
636 if Index
> Max
or else As_Digit
(Str
(Index
)) not in Valid_Digit
then
641 (Str
, Index
, Max
, Base
, Base_Char
/= ASCII
.NUL
, Value
, Scale
,
642 N
, Char_As_Digit
(Extra
), Base_Violation
);
647 pragma Assert
(Index
>= Str
'First);
649 if not After_Point
and then Index
<= Max
and then Str
(Index
) = '.' then
651 -- At this stage if After_Point was not set, this means that an
652 -- integral part has been found. Thus the dot is valid even if not
653 -- followed by a digit.
655 if Index
< Max
and then As_Digit
(Str
(Index
+ 1)) in Valid_Digit
then
662 -- Scan the decimal part
665 pragma Assert
(Index
<= Max
);
668 (Str
, Index
, Max
, Base
, Base_Char
/= ASCII
.NUL
, Value
, Scale
,
669 N
, Char_As_Digit
(Extra
), Base_Violation
);
672 -- If an explicit base was specified ensure that the delimiter is found
674 if Base_Char
/= ASCII
.NUL
then
675 pragma Assert
(Index
> Max
or else Index
in Str
'Range);
677 if Index
> Max
or else Str
(Index
) /= Base_Char
then
684 -- Update pointer and scan exponent
687 Scan_Exponent
(Str
, Ptr
, Max
, Expon
, Real
=> True);
689 -- Handle very large exponents like Scan_Exponent
691 if Expon
< Integer'First / 10 or else Expon
> Integer'Last / 10 then
693 for J
in 2 .. Data_Index
'Last loop
698 for J
in Data_Index
'Range loop
699 Scale
(J
) := Scale
(J
) + Expon
;
703 -- Here is where we check for a bad based number
705 if Base_Violation
then
716 function Value_Raw_Real
719 Scale
: out Scale_Array
;
720 Extra
: out Unsigned
;
721 Minus
: out Boolean) return Value_Array
727 -- We have to special case Str'Last = Positive'Last because the normal
728 -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We
729 -- deal with this by converting to a subtype which fixes the bounds.
731 if Str
'Last = Positive'Last then
733 subtype NT
is String (1 .. Str
'Length);
735 return Value_Raw_Real
(NT
(Str
), Base
, Scale
, Extra
, Minus
);
742 V
:= Scan_Raw_Real
(Str
, P
'Access, Str
'Last, Base
, Scale
, Extra
, Minus
);
743 Scan_Trailing_Blanks
(Str
, P
);