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