gcc/ada/scn-nlit.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S C N . N L I T                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --           Copyright (C) 1992-2001 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Uintp;  use Uintp;
  28 with Urealp; use Urealp;
  29
  30 separate (Scn)
  31 procedure Nlit is
  32
  33    C : Character;
  34    --  Current source program character
  35
  36    Base_Char : Character;
  37    --  Either # or : (character at start of based number)
  38
  39    Base : Int;
  40    --  Value of base
  41
  42    UI_Base : Uint;
  43    --  Value of base in Uint format
  44
  45    UI_Int_Value : Uint;
  46    --  Value of integer scanned by Scan_Integer in Uint format
  47
  48    UI_Num_Value : Uint;
  49    --  Value of integer in numeric value being scanned
  50
  51    Scale : Int;
  52    --  Scale value for real literal
  53
  54    UI_Scale : Uint;
  55    --  Scale in Uint format
  56
  57    Exponent_Is_Negative : Boolean;
  58    --  Set true for negative exponent
  59
  60    Extended_Digit_Value : Int;
  61    --  Extended digit value
  62
  63    Point_Scanned : Boolean;
  64    --  Flag for decimal point scanned in numeric literal
  65
  66    -----------------------
  67    -- Local Subprograms --
  68    -----------------------
  69
  70    procedure Error_Digit_Expected;
  71    --  Signal error of bad digit, Scan_Ptr points to the location at which
  72    --  the digit was expected on input, and is unchanged on return.
  73
  74    procedure Scan_Integer;
  75    --  Procedure to scan integer literal. On entry, Scan_Ptr points to a
  76    --  digit, on exit Scan_Ptr points past the last character of the integer.
  77    --  For each digit encountered, UI_Int_Value is multiplied by 10, and the
  78    --  value of the digit added to the result. In addition, the value in
  79    --  Scale is decremented by one for each actual digit scanned.
  80
  81    --------------------------
  82    -- Error_Digit_Expected --
  83    --------------------------
  84
  85    procedure Error_Digit_Expected is
  86    begin
  87       Error_Msg_S ("digit expected");
  88    end Error_Digit_Expected;
  89
  90    -------------------
  91    --  Scan_Integer --
  92    -------------------
  93
  94    procedure Scan_Integer is
  95       C : Character;
  96       --  Next character scanned
  97
  98    begin
  99       C := Source (Scan_Ptr);
 100
 101       --  Loop through digits (allowing underlines)
 102
 103       loop
 104          Accumulate_Checksum (C);
 105          UI_Int_Value :=
 106            UI_Int_Value * 10 + (Character'Pos (C) - Character'Pos ('0'));
 107          Scan_Ptr := Scan_Ptr + 1;
 108          Scale := Scale - 1;
 109          C := Source (Scan_Ptr);
 110
 111          if C = '_' then
 112             Accumulate_Checksum ('_');
 113
 114             loop
 115                Scan_Ptr := Scan_Ptr + 1;
 116                C := Source (Scan_Ptr);
 117                exit when C /= '_';
 118                Error_No_Double_Underline;
 119             end loop;
 120
 121             if C not in '0' .. '9' then
 122                Error_Digit_Expected;
 123                exit;
 124             end if;
 125
 126          else
 127             exit when C not in '0' .. '9';
 128          end if;
 129       end loop;
 130
 131    end Scan_Integer;
 132
 133 ----------------------------------
 134 -- Start of Processing for Nlit --
 135 ----------------------------------
 136
 137 begin
 138    Base := 10;
 139    UI_Base := Uint_10;
 140    UI_Int_Value := Uint_0;
 141    Scale := 0;
 142    Scan_Integer;
 143    Scale := 0;
 144    Point_Scanned := False;
 145    UI_Num_Value := UI_Int_Value;
 146
 147    --  Various possibilities now for continuing the literal are
 148    --  period, E/e (for exponent), or :/# (for based literal).
 149
 150    Scale := 0;
 151    C := Source (Scan_Ptr);
 152
 153    if C = '.' then
 154
 155       --  Scan out point, but do not scan past .. which is a range sequence,
 156       --  and must not be eaten up scanning a numeric literal.
 157
 158       while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop
 159          Accumulate_Checksum ('.');
 160
 161          if Point_Scanned then
 162             Error_Msg_S ("duplicate point ignored");
 163          end if;
 164
 165          Point_Scanned := True;
 166          Scan_Ptr := Scan_Ptr + 1;
 167          C := Source (Scan_Ptr);
 168
 169          if C not in '0' .. '9' then
 170             Error_Msg ("real literal cannot end with point", Scan_Ptr - 1);
 171          else
 172             Scan_Integer;
 173             UI_Num_Value := UI_Int_Value;
 174          end if;
 175       end loop;
 176
 177    --  Based literal case. The base is the value we already scanned.
 178    --  In the case of colon, we insist that the following character
 179    --  is indeed an extended digit or a period. This catches a number
 180    --  of common errors, as well as catching the well known tricky
 181    --  bug otherwise arising from "x : integer range 1 .. 10:= 6;"
 182
 183    elsif C = '#'
 184      or else (C = ':' and then
 185                         (Source (Scan_Ptr + 1) = '.'
 186                            or else
 187                          Source (Scan_Ptr + 1) in '0' .. '9'
 188                            or else
 189                          Source (Scan_Ptr + 1) in 'A' .. 'Z'
 190                            or else
 191                          Source (Scan_Ptr + 1) in 'a' .. 'z'))
 192    then
 193       Accumulate_Checksum (C);
 194       Base_Char := C;
 195       UI_Base := UI_Int_Value;
 196
 197       if UI_Base < 2 or else UI_Base > 16 then
 198          Error_Msg_SC ("base not 2-16");
 199          UI_Base := Uint_16;
 200       end if;
 201
 202       Base := UI_To_Int (UI_Base);
 203       Scan_Ptr := Scan_Ptr + 1;
 204
 205       --  Scan out extended integer [. integer]
 206
 207       C := Source (Scan_Ptr);
 208       UI_Int_Value := Uint_0;
 209       Scale := 0;
 210
 211       loop
 212          if C in '0' .. '9' then
 213             Accumulate_Checksum (C);
 214             Extended_Digit_Value :=
 215               Int'(Character'Pos (C)) - Int'(Character'Pos ('0'));
 216
 217          elsif C in 'A' .. 'F' then
 218             Accumulate_Checksum (Character'Val (Character'Pos (C) + 32));
 219             Extended_Digit_Value :=
 220               Int'(Character'Pos (C)) - Int'(Character'Pos ('A')) + 10;
 221
 222          elsif C in 'a' .. 'f' then
 223             Accumulate_Checksum (C);
 224             Extended_Digit_Value :=
 225               Int'(Character'Pos (C)) - Int'(Character'Pos ('a')) + 10;
 226
 227          else
 228             Error_Msg_S ("extended digit expected");
 229             exit;
 230          end if;
 231
 232          if Extended_Digit_Value >= Base then
 233             Error_Msg_S ("digit >= base");
 234          end if;
 235
 236          UI_Int_Value := UI_Int_Value * UI_Base + Extended_Digit_Value;
 237          Scale := Scale - 1;
 238          Scan_Ptr := Scan_Ptr + 1;
 239          C := Source (Scan_Ptr);
 240
 241          if C = '_' then
 242             loop
 243                Accumulate_Checksum ('_');
 244                Scan_Ptr := Scan_Ptr + 1;
 245                C := Source (Scan_Ptr);
 246                exit when C /= '_';
 247                Error_No_Double_Underline;
 248             end loop;
 249
 250          elsif C = '.' then
 251             Accumulate_Checksum ('.');
 252
 253             if Point_Scanned then
 254                Error_Msg_S ("duplicate point ignored");
 255             end if;
 256
 257             Scan_Ptr := Scan_Ptr + 1;
 258             C := Source (Scan_Ptr);
 259             Point_Scanned := True;
 260             Scale := 0;
 261
 262          elsif C = Base_Char then
 263             Accumulate_Checksum (C);
 264             Scan_Ptr := Scan_Ptr + 1;
 265             exit;
 266
 267          elsif C = '#' or else C = ':' then
 268             Error_Msg_S ("based number delimiters must match");
 269             Scan_Ptr := Scan_Ptr + 1;
 270             exit;
 271
 272          elsif not Identifier_Char (C) then
 273             if Base_Char = '#' then
 274                Error_Msg_S ("missing '#");
 275             else
 276                Error_Msg_S ("missing ':");
 277             end if;
 278
 279             exit;
 280          end if;
 281
 282       end loop;
 283
 284       UI_Num_Value := UI_Int_Value;
 285    end if;
 286
 287    --  Scan out exponent
 288
 289    if not Point_Scanned then
 290       Scale := 0;
 291       UI_Scale := Uint_0;
 292    else
 293       UI_Scale := UI_From_Int (Scale);
 294    end if;
 295
 296    if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then
 297       Accumulate_Checksum ('e');
 298       Scan_Ptr := Scan_Ptr + 1;
 299       Exponent_Is_Negative := False;
 300
 301       if Source (Scan_Ptr) = '+' then
 302          Accumulate_Checksum ('+');
 303          Scan_Ptr := Scan_Ptr + 1;
 304
 305       elsif Source (Scan_Ptr) = '-' then
 306          Accumulate_Checksum ('-');
 307
 308          if not Point_Scanned then
 309             Error_Msg_S ("negative exponent not allowed for integer literal");
 310          else
 311             Exponent_Is_Negative := True;
 312          end if;
 313
 314          Scan_Ptr := Scan_Ptr + 1;
 315       end if;
 316
 317       UI_Int_Value := Uint_0;
 318
 319       if Source (Scan_Ptr) in '0' .. '9' then
 320          Scan_Integer;
 321       else
 322          Error_Digit_Expected;
 323       end if;
 324
 325       if Exponent_Is_Negative then
 326          UI_Scale := UI_Scale - UI_Int_Value;
 327       else
 328          UI_Scale := UI_Scale + UI_Int_Value;
 329       end if;
 330    end if;
 331
 332    --  Case of real literal to be returned
 333
 334    if Point_Scanned then
 335       Token := Tok_Real_Literal;
 336       Token_Node := New_Node (N_Real_Literal, Token_Ptr);
 337       Set_Realval (Token_Node,
 338         UR_From_Components (
 339           Num   => UI_Num_Value,
 340           Den   => -UI_Scale,
 341           Rbase => Base));
 342
 343    --  Case of integer literal to be returned
 344
 345    else
 346       Token := Tok_Integer_Literal;
 347       Token_Node := New_Node (N_Integer_Literal, Token_Ptr);
 348
 349       if UI_Scale = 0 then
 350          Set_Intval (Token_Node, UI_Num_Value);
 351
 352       --  Avoid doing possibly expensive calculations in cases like
 353       --  parsing 163E800_000# when semantics will not be done anyway.
 354       --  This is especially useful when parsing garbled input.
 355
 356       elsif Operating_Mode /= Check_Syntax
 357         and then (Serious_Errors_Detected = 0 or else Try_Semantics)
 358       then
 359          Set_Intval (Token_Node, UI_Num_Value * UI_Base ** UI_Scale);
 360
 361       else
 362          Set_Intval (Token_Node, No_Uint);
 363       end if;
 364
 365    end if;
 366
 367    return;
 368
 369 end Nlit;