scn-nlit.adb   [plain text]

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             S C N . N L I T                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                                                                          --
--           Copyright (C) 1992-2001 Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Uintp;  use Uintp;
with Urealp; use Urealp;

separate (Scn)
procedure Nlit is

   C : Character;
   --  Current source program character

   Base_Char : Character;
   --  Either # or : (character at start of based number)

   Base : Int;
   --  Value of base

   UI_Base : Uint;
   --  Value of base in Uint format

   UI_Int_Value : Uint;
   --  Value of integer scanned by Scan_Integer in Uint format

   UI_Num_Value : Uint;
   --  Value of integer in numeric value being scanned

   Scale : Int;
   --  Scale value for real literal

   UI_Scale : Uint;
   --  Scale in Uint format

   Exponent_Is_Negative : Boolean;
   --  Set true for negative exponent

   Extended_Digit_Value : Int;
   --  Extended digit value

   Point_Scanned : Boolean;
   --  Flag for decimal point scanned in numeric literal

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Error_Digit_Expected;
   --  Signal error of bad digit, Scan_Ptr points to the location at which
   --  the digit was expected on input, and is unchanged on return.

   procedure Scan_Integer;
   --  Procedure to scan integer literal. On entry, Scan_Ptr points to a
   --  digit, on exit Scan_Ptr points past the last character of the integer.
   --  For each digit encountered, UI_Int_Value is multiplied by 10, and the
   --  value of the digit added to the result. In addition, the value in
   --  Scale is decremented by one for each actual digit scanned.

   --------------------------
   -- Error_Digit_Expected --
   --------------------------

   procedure Error_Digit_Expected is
   begin
      Error_Msg_S ("digit expected");
   end Error_Digit_Expected;

   -------------------
   --  Scan_Integer --
   -------------------

   procedure Scan_Integer is
      C : Character;
      --  Next character scanned

   begin
      C := Source (Scan_Ptr);

      --  Loop through digits (allowing underlines)

      loop
         Accumulate_Checksum (C);
         UI_Int_Value :=
           UI_Int_Value * 10 + (Character'Pos (C) - Character'Pos ('0'));
         Scan_Ptr := Scan_Ptr + 1;
         Scale := Scale - 1;
         C := Source (Scan_Ptr);

         if C = '_' then
            Accumulate_Checksum ('_');

            loop
               Scan_Ptr := Scan_Ptr + 1;
               C := Source (Scan_Ptr);
               exit when C /= '_';
               Error_No_Double_Underline;
            end loop;

            if C not in '0' .. '9' then
               Error_Digit_Expected;
               exit;
            end if;

         else
            exit when C not in '0' .. '9';
         end if;
      end loop;

   end Scan_Integer;

----------------------------------
-- Start of Processing for Nlit --
----------------------------------

begin
   Base := 10;
   UI_Base := Uint_10;
   UI_Int_Value := Uint_0;
   Scale := 0;
   Scan_Integer;
   Scale := 0;
   Point_Scanned := False;
   UI_Num_Value := UI_Int_Value;

   --  Various possibilities now for continuing the literal are
   --  period, E/e (for exponent), or :/# (for based literal).

   Scale := 0;
   C := Source (Scan_Ptr);

   if C = '.' then

      --  Scan out point, but do not scan past .. which is a range sequence,
      --  and must not be eaten up scanning a numeric literal.

      while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop
         Accumulate_Checksum ('.');

         if Point_Scanned then
            Error_Msg_S ("duplicate point ignored");
         end if;

         Point_Scanned := True;
         Scan_Ptr := Scan_Ptr + 1;
         C := Source (Scan_Ptr);

         if C not in '0' .. '9' then
            Error_Msg ("real literal cannot end with point", Scan_Ptr - 1);
         else
            Scan_Integer;
            UI_Num_Value := UI_Int_Value;
         end if;
      end loop;

   --  Based literal case. The base is the value we already scanned.
   --  In the case of colon, we insist that the following character
   --  is indeed an extended digit or a period. This catches a number
   --  of common errors, as well as catching the well known tricky
   --  bug otherwise arising from "x : integer range 1 .. 10:= 6;"

   elsif C = '#'
     or else (C = ':' and then
                        (Source (Scan_Ptr + 1) = '.'
                           or else
                         Source (Scan_Ptr + 1) in '0' .. '9'
                           or else
                         Source (Scan_Ptr + 1) in 'A' .. 'Z'
                           or else
                         Source (Scan_Ptr + 1) in 'a' .. 'z'))
   then
      Accumulate_Checksum (C);
      Base_Char := C;
      UI_Base := UI_Int_Value;

      if UI_Base < 2 or else UI_Base > 16 then
         Error_Msg_SC ("base not 2-16");
         UI_Base := Uint_16;
      end if;

      Base := UI_To_Int (UI_Base);
      Scan_Ptr := Scan_Ptr + 1;

      --  Scan out extended integer [. integer]

      C := Source (Scan_Ptr);
      UI_Int_Value := Uint_0;
      Scale := 0;

      loop
         if C in '0' .. '9' then
            Accumulate_Checksum (C);
            Extended_Digit_Value :=
              Int'(Character'Pos (C)) - Int'(Character'Pos ('0'));

         elsif C in 'A' .. 'F' then
            Accumulate_Checksum (Character'Val (Character'Pos (C) + 32));
            Extended_Digit_Value :=
              Int'(Character'Pos (C)) - Int'(Character'Pos ('A')) + 10;

         elsif C in 'a' .. 'f' then
            Accumulate_Checksum (C);
            Extended_Digit_Value :=
              Int'(Character'Pos (C)) - Int'(Character'Pos ('a')) + 10;

         else
            Error_Msg_S ("extended digit expected");
            exit;
         end if;

         if Extended_Digit_Value >= Base then
            Error_Msg_S ("digit >= base");
         end if;

         UI_Int_Value := UI_Int_Value * UI_Base + Extended_Digit_Value;
         Scale := Scale - 1;
         Scan_Ptr := Scan_Ptr + 1;
         C := Source (Scan_Ptr);

         if C = '_' then
            loop
               Accumulate_Checksum ('_');
               Scan_Ptr := Scan_Ptr + 1;
               C := Source (Scan_Ptr);
               exit when C /= '_';
               Error_No_Double_Underline;
            end loop;

         elsif C = '.' then
            Accumulate_Checksum ('.');

            if Point_Scanned then
               Error_Msg_S ("duplicate point ignored");
            end if;

            Scan_Ptr := Scan_Ptr + 1;
            C := Source (Scan_Ptr);
            Point_Scanned := True;
            Scale := 0;

         elsif C = Base_Char then
            Accumulate_Checksum (C);
            Scan_Ptr := Scan_Ptr + 1;
            exit;

         elsif C = '#' or else C = ':' then
            Error_Msg_S ("based number delimiters must match");
            Scan_Ptr := Scan_Ptr + 1;
            exit;

         elsif not Identifier_Char (C) then
            if Base_Char = '#' then
               Error_Msg_S ("missing '#");
            else
               Error_Msg_S ("missing ':");
            end if;

            exit;
         end if;

      end loop;

      UI_Num_Value := UI_Int_Value;
   end if;

   --  Scan out exponent

   if not Point_Scanned then
      Scale := 0;
      UI_Scale := Uint_0;
   else
      UI_Scale := UI_From_Int (Scale);
   end if;

   if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then
      Accumulate_Checksum ('e');
      Scan_Ptr := Scan_Ptr + 1;
      Exponent_Is_Negative := False;

      if Source (Scan_Ptr) = '+' then
         Accumulate_Checksum ('+');
         Scan_Ptr := Scan_Ptr + 1;

      elsif Source (Scan_Ptr) = '-' then
         Accumulate_Checksum ('-');

         if not Point_Scanned then
            Error_Msg_S ("negative exponent not allowed for integer literal");
         else
            Exponent_Is_Negative := True;
         end if;

         Scan_Ptr := Scan_Ptr + 1;
      end if;

      UI_Int_Value := Uint_0;

      if Source (Scan_Ptr) in '0' .. '9' then
         Scan_Integer;
      else
         Error_Digit_Expected;
      end if;

      if Exponent_Is_Negative then
         UI_Scale := UI_Scale - UI_Int_Value;
      else
         UI_Scale := UI_Scale + UI_Int_Value;
      end if;
   end if;

   --  Case of real literal to be returned

   if Point_Scanned then
      Token := Tok_Real_Literal;
      Token_Node := New_Node (N_Real_Literal, Token_Ptr);
      Set_Realval (Token_Node,
        UR_From_Components (
          Num   => UI_Num_Value,
          Den   => -UI_Scale,
          Rbase => Base));

   --  Case of integer literal to be returned

   else
      Token := Tok_Integer_Literal;
      Token_Node := New_Node (N_Integer_Literal, Token_Ptr);

      if UI_Scale = 0 then
         Set_Intval (Token_Node, UI_Num_Value);

      --  Avoid doing possibly expensive calculations in cases like
      --  parsing 163E800_000# when semantics will not be done anyway.
      --  This is especially useful when parsing garbled input.

      elsif Operating_Mode /= Check_Syntax
        and then (Serious_Errors_Detected = 0 or else Try_Semantics)
      then
         Set_Intval (Token_Node, UI_Num_Value * UI_Base ** UI_Scale);

      else
         Set_Intval (Token_Node, No_Uint);
      end if;

   end if;

   return;

end Nlit;