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