gcc/ada/s-valllu.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                       S Y S T E M . V A L _ L L U                        --
   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 -- 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_LLU is
  36
  37    ---------------------------------
  38    -- Scan_Raw_Long_Long_Unsigned --
  39    ---------------------------------
  40
  41    function Scan_Raw_Long_Long_Unsigned
  42      (Str : String;
  43       Ptr : not null access Integer;
  44       Max : Integer) return Long_Long_Unsigned
  45    is
  46       P : Integer;
  47       --  Local copy of the pointer
  48
  49       Uval : Long_Long_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 : Long_Long_Unsigned := 10;
  62       --  Base value (reset in based case)
  63
  64       Digit : Long_Long_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 := (Long_Long_Unsigned'Last - 9) / 10;
  84          --  Max value which cannot overflow on accumulating next digit
  85
  86          Umax10 : constant := Long_Long_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 Long_Long_Unsigned :=
 152                      (Long_Long_Unsigned'Last - Base + 1) / Base;
 153             --  Max value which cannot overflow on accumulating next digit
 154
 155             UmaxB : constant Long_Long_Unsigned :=
 156                       Long_Long_Unsigned'Last / Base;
 157             --  Numbers bigger than UmaxB overflow if multiplied by base
 158
 159          begin
 160             --  Loop to scan out based integer value
 161
 162             loop
 163                --  We require a digit at this stage
 164
 165                if Str (P) in '0' .. '9' then
 166                   Digit := Character'Pos (Str (P)) - Character'Pos ('0');
 167
 168                elsif Str (P) in 'A' .. 'F' then
 169                   Digit :=
 170                     Character'Pos (Str (P)) - (Character'Pos ('A') - 10);
 171
 172                elsif Str (P) in 'a' .. 'f' then
 173                   Digit :=
 174                     Character'Pos (Str (P)) - (Character'Pos ('a') - 10);
 175
 176                --  If we don't have a digit, then this is not a based number
 177                --  after all, so we use the value we scanned out as the base
 178                --  (now in Base), and the pointer to the base character was
 179                --  already stored in Ptr.all.
 180
 181                else
 182                   Uval := Base;
 183                   exit;
 184                end if;
 185
 186                --  If digit is too large, just signal overflow and continue.
 187                --  The idea here is to keep scanning as long as the input is
 188                --  syntactically valid, even if we have detected overflow
 189
 190                if Digit >= Base then
 191                   Overflow := True;
 192
 193                --  Here we accumulate the value, checking overflow
 194
 195                elsif Uval <= Umax then
 196                   Uval := Base * Uval + Digit;
 197
 198                elsif Uval > UmaxB then
 199                   Overflow := True;
 200
 201                else
 202                   Uval := Base * Uval + Digit;
 203
 204                   if Uval < UmaxB then
 205                      Overflow := True;
 206                   end if;
 207                end if;
 208
 209                --  If at end of string with no base char, not a based number
 210                --  but we signal Constraint_Error and set the pointer past
 211                --  the end of the field, since this is what the ACVC tests
 212                --  seem to require, see CE3704N, line 204.
 213
 214                P := P + 1;
 215
 216                if P > Max then
 217                   Ptr.all := P;
 218                   Bad_Value (Str);
 219                end if;
 220
 221                --  If terminating base character, we are done with loop
 222
 223                if Str (P) = Base_Char then
 224                   Ptr.all := P + 1;
 225                   exit;
 226
 227                --  Deal with underscore
 228
 229                elsif Str (P) = '_' then
 230                   Scan_Underscore (Str, P, Ptr, Max, True);
 231                end if;
 232
 233             end loop;
 234          end;
 235       end if;
 236
 237       --  Come here with scanned unsigned value in Uval. The only remaining
 238       --  required step is to deal with exponent if one is present.
 239
 240       Expon := Scan_Exponent (Str, Ptr, Max);
 241
 242       if Expon /= 0 and then Uval /= 0 then
 243
 244          --  For non-zero value, scale by exponent value. No need to do this
 245          --  efficiently, since use of exponent in integer literals is rare,
 246          --  and in any case the exponent cannot be very large.
 247
 248          declare
 249             UmaxB : constant Long_Long_Unsigned :=
 250                       Long_Long_Unsigned'Last / Base;
 251             --  Numbers bigger than UmaxB overflow if multiplied by base
 252
 253          begin
 254             for J in 1 .. Expon loop
 255                if Uval > UmaxB then
 256                   Overflow := True;
 257                   exit;
 258                end if;
 259
 260                Uval := Uval * Base;
 261             end loop;
 262          end;
 263       end if;
 264
 265       --  Return result, dealing with sign and overflow
 266
 267       if Overflow then
 268          Bad_Value (Str);
 269       else
 270          return Uval;
 271       end if;
 272    end Scan_Raw_Long_Long_Unsigned;
 273
 274    -----------------------------
 275    -- Scan_Long_Long_Unsigned --
 276    -----------------------------
 277
 278    function Scan_Long_Long_Unsigned
 279      (Str : String;
 280       Ptr : not null access Integer;
 281       Max : Integer) return Long_Long_Unsigned
 282    is
 283       Start : Positive;
 284       --  Save location of first non-blank character
 285
 286    begin
 287       Scan_Plus_Sign (Str, Ptr, Max, Start);
 288
 289       if Str (Ptr.all) not in '0' .. '9' then
 290          Ptr.all := Start;
 291          raise Constraint_Error;
 292       end if;
 293
 294       return Scan_Raw_Long_Long_Unsigned (Str, Ptr, Max);
 295    end Scan_Long_Long_Unsigned;
 296
 297    ------------------------------
 298    -- Value_Long_Long_Unsigned --
 299    ------------------------------
 300
 301    function Value_Long_Long_Unsigned
 302      (Str : String) return Long_Long_Unsigned
 303    is
 304    begin
 305       --  We have to special case Str'Last = Positive'Last because the normal
 306       --  circuit ends up setting P to Str'Last + 1 which is out of bounds. We
 307       --  deal with this by converting to a subtype which fixes the bounds.
 308
 309       if Str'Last = Positive'Last then
 310          declare
 311             subtype NT is String (1 .. Str'Length);
 312          begin
 313             return Value_Long_Long_Unsigned (NT (Str));
 314          end;
 315
 316       --  Normal case where Str'Last < Positive'Last
 317
 318       else
 319          declare
 320             V : Long_Long_Unsigned;
 321             P : aliased Integer := Str'First;
 322          begin
 323             V := Scan_Long_Long_Unsigned (Str, P'Access, Str'Last);
 324             Scan_Trailing_Blanks (Str, P);
 325             return V;
 326          end;
 327       end if;
 328    end Value_Long_Long_Unsigned;
 329
 330 end System.Val_LLU;