home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / scn-nlit.adb < prev    next >
Text File  |  1996-09-28  |  10KB  |  334 lines
  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.27 $                             --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  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, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. with Uintp;  use Uintp;
  26. with Urealp; use Urealp;
  27.  
  28. separate (Scn)
  29. procedure Nlit is
  30.  
  31.    C : Character;
  32.    --  Current source program character
  33.  
  34.    Base_Char : Character;
  35.    --  Either # or : (character at start of based number)
  36.  
  37.    Base : Int;
  38.    --  Value of base
  39.  
  40.    UI_Base : Uint;
  41.    --  Value of base in Uint format
  42.  
  43.    UI_Int_Value : Uint;
  44.    --  Value of integer scanned by Scan_Integer in Uint format
  45.  
  46.    UI_Num_Value : Uint;
  47.    --  Value of integer in numeric value being scanned
  48.  
  49.    Scale : Int;
  50.    --  Scale value for real literal
  51.  
  52.    UI_Scale : Uint;
  53.    --  Scale in Uint format
  54.  
  55.    Scanp : Source_Ptr;
  56.    --  Used to save scan pointer values
  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.          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.  
  113.             loop
  114.                Scan_Ptr := Scan_Ptr + 1;
  115.                C := Source (Scan_Ptr);
  116.                exit when C /= '_';
  117.                Error_No_Double_Underline;
  118.             end loop;
  119.  
  120.             if C not in '0' .. '9' then
  121.                Error_Digit_Expected;
  122.                exit;
  123.             end if;
  124.  
  125.          else
  126.             exit when C not in '0' .. '9';
  127.          end if;
  128.       end loop;
  129.  
  130.    end Scan_Integer;
  131.  
  132. ----------------------------------
  133. -- Start of Processing for Nlit --
  134. ----------------------------------
  135.  
  136. begin
  137.    Base := 10;
  138.    UI_Base := Uint_10;
  139.    UI_Int_Value := Uint_0;
  140.    Scale := 0;
  141.    Scan_Integer;
  142.    Scale := 0;
  143.    Point_Scanned := False;
  144.    UI_Num_Value := UI_Int_Value;
  145.  
  146.    --  Various possibilities now for continuing the literal are
  147.    --  period, E/e (for exponent), or :/# (for based literal).
  148.  
  149.    Scale := 0;
  150.    C := Source (Scan_Ptr);
  151.  
  152.    if C = '.' then
  153.  
  154.       while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop
  155.          if Point_Scanned then
  156.             Error_Msg_S ("duplicate point ignored");
  157.          end if;
  158.  
  159.          Point_Scanned := True;
  160.          Scan_Ptr := Scan_Ptr + 1;
  161.          C := Source (Scan_Ptr);
  162.  
  163.          if C not in '0' .. '9' then
  164.             Error_Msg ("real literal cannot end with point", Scan_Ptr - 1);
  165.          else
  166.             Scan_Integer;
  167.             UI_Num_Value := UI_Int_Value;
  168.          end if;
  169.       end loop;
  170.  
  171.    --  Based literal case. The base is the value we already scanned.
  172.    --  Note also the check for := to catch the well known tricky
  173.    --  bug otherwise arising from "x : integer range 1 .. 10:= 6;"
  174.  
  175.    elsif C = '#'
  176.      or else (C = ':' and then Source (Scan_Ptr + 1) /= '=')
  177.    then
  178.       Base_Char := C;
  179.       UI_Base := UI_Int_Value;
  180.  
  181.       if UI_Base < 2 or else UI_Base > 16 then
  182.          Error_Msg_SC ("base not 2-16");
  183.          UI_Base := Uint_16;
  184.       end if;
  185.  
  186.       Base := UI_To_Int (UI_Base);
  187.       Scan_Ptr := Scan_Ptr + 1;
  188.  
  189.       --  Scan out extended integer [. integer]
  190.  
  191.       C := Source (Scan_Ptr);
  192.       UI_Int_Value := Uint_0;
  193.       Scale := 0;
  194.  
  195.       loop
  196.          if C in '0' .. '9' then
  197.             Extended_Digit_Value :=
  198.               Int'(Character'Pos (C)) - Int'(Character'Pos ('0'));
  199.          elsif C in 'A' .. 'F' then
  200.             Extended_Digit_Value :=
  201.               Int'(Character'Pos (C)) - Int'(Character'Pos ('A')) + 10;
  202.          elsif C in 'a' .. 'f' then
  203.             Extended_Digit_Value :=
  204.               Int'(Character'Pos (C)) - Int'(Character'Pos ('a')) + 10;
  205.          else
  206.             Error_Msg_S ("extended digit expected");
  207.             exit;
  208.          end if;
  209.  
  210.          if Extended_Digit_Value >= Base then
  211.             Error_Msg_S ("digit >= base");
  212.          end if;
  213.  
  214.          UI_Int_Value := UI_Int_Value * UI_Base + Extended_Digit_Value;
  215.          Scale := Scale - 1;
  216.          Scan_Ptr := Scan_Ptr + 1;
  217.          C := Source (Scan_Ptr);
  218.  
  219.          if C = '_' then
  220.             Scan_Ptr := Scan_Ptr + 1;
  221.             C := Source (Scan_Ptr);
  222.  
  223.             if C = '_' then
  224.                Error_No_Double_Underline;
  225.                Scan_Ptr := Scan_Ptr + 1;
  226.                C := Source (Scan_Ptr);
  227.             end if;
  228.  
  229.          elsif C = '.' then
  230.             if Point_Scanned then
  231.                Error_Msg_S ("duplicate point ignored");
  232.             end if;
  233.  
  234.             Scan_Ptr := Scan_Ptr + 1;
  235.             C := Source (Scan_Ptr);
  236.             Point_Scanned := True;
  237.             Scale := 0;
  238.  
  239.  
  240.          elsif C = Base_Char then
  241.             Scan_Ptr := Scan_Ptr + 1;
  242.             exit;
  243.  
  244.          elsif C = '#' or else C = ':' then
  245.             Error_Msg_S ("based number delimiters must match");
  246.             Scan_Ptr := Scan_Ptr + 1;
  247.             exit;
  248.  
  249.          elsif not Identifier_Char (C) then
  250.             if Base_Char = '#' then
  251.                Error_Msg_S ("missing '#");
  252.             else
  253.                Error_Msg_S ("missing ':");
  254.             end if;
  255.  
  256.             exit;
  257.          end if;
  258.  
  259.       end loop;
  260.  
  261.       UI_Num_Value := UI_Int_Value;
  262.    end if;
  263.  
  264.    --  Scan out exponent
  265.  
  266.    if not Point_Scanned then
  267.       Scale := 0;
  268.       UI_Scale := Uint_0;
  269.    else
  270.       UI_Scale := UI_From_Int (Scale);
  271.    end if;
  272.  
  273.    if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then
  274.       Scan_Ptr := Scan_Ptr + 1;
  275.       Exponent_Is_Negative := False;
  276.  
  277.       if Source (Scan_Ptr) = '+' then
  278.          Scan_Ptr := Scan_Ptr + 1;
  279.  
  280.       elsif Source (Scan_Ptr) = '-' then
  281.  
  282.          if not Point_Scanned then
  283.             Error_Msg_S ("negative exponent not allowed for integer literal");
  284.          else
  285.             Exponent_Is_Negative := True;
  286.          end if;
  287.  
  288.          Scan_Ptr := Scan_Ptr + 1;
  289.       end if;
  290.  
  291.       UI_Int_Value := Uint_0;
  292.  
  293.       if Source (Scan_Ptr) in '0' .. '9' then
  294.          Scan_Integer;
  295.       else
  296.          Error_Digit_Expected;
  297.       end if;
  298.  
  299.       if Exponent_Is_Negative then
  300.          UI_Scale := UI_Scale - UI_Int_Value;
  301.       else
  302.          UI_Scale := UI_Scale + UI_Int_Value;
  303.       end if;
  304.    end if;
  305.  
  306.    --  Case of real literal to be returned
  307.  
  308.    if Point_Scanned then
  309.       Token := Tok_Real_Literal;
  310.       Token_Node := New_Node (N_Real_Literal, Token_Ptr);
  311.       Set_Realval (Token_Node,
  312.         UR_From_Components (
  313.           Num   => UI_Num_Value,
  314.           Den   => -UI_Scale,
  315.           Rbase => Base));
  316.  
  317.    --  Case of integer literal to be returned
  318.  
  319.    else
  320.       Token := Tok_Integer_Literal;
  321.       Token_Node := New_Node (N_Integer_Literal, Token_Ptr);
  322.  
  323.       if UI_Scale /= 0 then
  324.          Set_Intval (Token_Node, UI_Num_Value * UI_Base ** UI_Scale);
  325.       else
  326.          Set_Intval (Token_Node, UI_Num_Value);
  327.       end if;
  328.  
  329.    end if;
  330.  
  331.    return;
  332.  
  333. end Nlit;
  334.