gcc/ada/libgnat/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-2017, 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 -- 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;