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-slit.adb < prev    next >
Text File  |  1996-09-28  |  12KB  |  363 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                             S C N . S L I T                              --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.21 $                             --
  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 Stringt; use Stringt;
  26.  
  27. separate (Scn)
  28. procedure Slit is
  29.  
  30.    Delimiter : Character;
  31.    --  Delimiter (first character of string)
  32.  
  33.    C : Character;
  34.    --  Current source program character
  35.  
  36.    Code : Char_Code;
  37.    --  Current character code value
  38.  
  39.    Err : Boolean;
  40.    --  Error flag for Scan_Wide call
  41.  
  42.    Latin_1_Noted : Boolean := False;
  43.    --  Avoid multiple Feature calls for Latin_1 for a single string
  44.  
  45.    Wide_Noted : Boolean := False;
  46.    --  Avoid multiple Feature calls for wide characters for a single string
  47.  
  48.    String_Literal_Id : String_Id;
  49.    --  Id for currently scanned string value
  50.  
  51.    procedure Error_Bad_String_Char;
  52.    --  Signal bad character in string/character constant. On entry Scan_Ptr
  53.    --  points to the improper character encountered during the scan. Scan_Ptr
  54.    --  is not modified, so it still points to the bad character on return.
  55.  
  56.    procedure Error_Unterminated_String;
  57.    --  Procedure called if a line terminator character is encountered during
  58.    --  scanning a string, meaning that the string is not properly terminated.
  59.  
  60.    procedure Set_String;
  61.    --  Procedure used to distinguish between string and operator symbol.
  62.    --  On entry the string has been scanned out, and its characters start
  63.    --  at Token_Ptr and end one character before Scan_Ptr. On exit Token
  64.    --  is set to Tok_String_Literal or Tok_Operator_Symbol as appropriate,
  65.    --  and Token_Node is appropriately initialized. In addition, in the
  66.    --  operator symbol case, Token_Name is appropriately set.
  67.  
  68.    ---------------------------
  69.    -- Error_Bad_String_Char --
  70.    ---------------------------
  71.  
  72.    procedure Error_Bad_String_Char is
  73.       C : constant Character := Source (Scan_Ptr);
  74.  
  75.    begin
  76.       if C = HT then
  77.          Error_Msg_S ("horizontal tab not allowed in string");
  78.  
  79.       elsif C = VT or else C = FF then
  80.          Error_Msg_S ("format effector not allowed in string");
  81.  
  82.       elsif C in Upper_Half_Character then
  83.          Error_Msg_S ("(Ada 83) upper half character not allowed");
  84.  
  85.       else
  86.          Error_Msg_S ("control character not allowed in string");
  87.       end if;
  88.    end Error_Bad_String_Char;
  89.  
  90.    -------------------------------
  91.    -- Error_Unterminated_String --
  92.    -------------------------------
  93.  
  94.    procedure Error_Unterminated_String is
  95.    begin
  96.  
  97.       --  An interesting little refinement. Consider the following examples:
  98.  
  99.       --     A := "this is an unterminated string;
  100.       --     A := "this is an unterminated string &
  101.       --     P(A, "this is a parameter that didn't get terminated);
  102.  
  103.       --  We fiddle a little to do slightly better placement in these cases
  104.       --  also if there is white space at the end of the line we place the
  105.       --  flag at the start of this white space, not at the end. Note that
  106.       --  we only have to test for blanks, since tabs aren't allowed in
  107.       --  strings in the first place and would have caused an error message.
  108.  
  109.       --  Two more cases that we treat specially are:
  110.  
  111.       --     A := "this string uses the wrong terminator'
  112.       --     A := "this string uses the wrong terminator' &
  113.  
  114.       --  In these cases we give a different error message as well
  115.  
  116.       --  We actually reposition the scan pointer to the point where we
  117.       --  place the flag in these cases, since it seems a better bet on
  118.       --  the original intention.
  119.  
  120.       while Source (Scan_Ptr - 1) = ' '
  121.         or else Source (Scan_Ptr - 1) = '&'
  122.       loop
  123.          Scan_Ptr := Scan_Ptr - 1;
  124.          Unstore_String_Char;
  125.       end loop;
  126.  
  127.       --  Check for case of incorrect string terminator, but single quote is
  128.       --  not considered incorrect if the opening terminator misused a single
  129.       --  quote (error message already given).
  130.  
  131.       if Delimiter /= '''
  132.         and then Source (Scan_Ptr - 1) = '''
  133.       then
  134.          Unstore_String_Char;
  135.          Error_Msg ("incorrect string terminator character", Scan_Ptr - 1);
  136.          return;
  137.       end if;
  138.  
  139.       if Source (Scan_Ptr - 1) = ';' then
  140.          Scan_Ptr := Scan_Ptr - 1;
  141.          Unstore_String_Char;
  142.  
  143.          if Source (Scan_Ptr - 1) = ')' then
  144.             Scan_Ptr := Scan_Ptr - 1;
  145.             Unstore_String_Char;
  146.          end if;
  147.       end if;
  148.  
  149.       Error_Msg_S ("missing string quote");
  150.    end Error_Unterminated_String;
  151.  
  152.    ----------------
  153.    -- Set_String --
  154.    ----------------
  155.  
  156.    procedure Set_String is
  157.       Slen : Int := Int (Scan_Ptr - Token_Ptr - 2);
  158.       C1   : Character;
  159.       C2   : Character;
  160.       C3   : Character;
  161.  
  162.    begin
  163.       --  Token_Name is currently set to Error_Name. The following section of
  164.       --  code resets Token_Name to the proper Name_Op_xx value if the string
  165.       --  is a valid operator symbol, otherwise it is left set to Error_Name.
  166.  
  167.       if Slen = 1 then
  168.          C1 := Source (Token_Ptr + 1);
  169.  
  170.          case C1 is
  171.             when '=' =>
  172.                Token_Name := Name_Op_Eq;
  173.  
  174.             when '>' =>
  175.                Token_Name := Name_Op_Gt;
  176.  
  177.             when '<' =>
  178.                Token_Name := Name_Op_Lt;
  179.  
  180.             when '+' =>
  181.                Token_Name := Name_Op_Add;
  182.  
  183.             when '-' =>
  184.                Token_Name := Name_Op_Subtract;
  185.  
  186.             when '&' =>
  187.                Token_Name := Name_Op_Concat;
  188.  
  189.             when '*' =>
  190.                Token_Name := Name_Op_Multiply;
  191.  
  192.             when '/' =>
  193.                Token_Name := Name_Op_Divide;
  194.  
  195.             when others =>
  196.                null;
  197.          end case;
  198.  
  199.       elsif Slen = 2 then
  200.          C1 := Source (Token_Ptr + 1);
  201.          C2 := Source (Token_Ptr + 2);
  202.  
  203.          if C1 = '*' and then C2 = '*' then
  204.             Token_Name := Name_Op_Expon;
  205.  
  206.          elsif C2 = '=' then
  207.  
  208.             if C1 = '/' then
  209.                Token_Name := Name_Op_Ne;
  210.             elsif C1 = '<' then
  211.                Token_Name := Name_Op_Le;
  212.             elsif C1 = '>' then
  213.                Token_Name := Name_Op_Ge;
  214.             end if;
  215.  
  216.          elsif (C1 = 'O' or else C1 = 'o') and then    -- OR
  217.                (C2 = 'R' or else C2 = 'r')
  218.          then
  219.             Token_Name := Name_Op_Or;
  220.          end if;
  221.  
  222.       elsif Slen = 3 then
  223.          C1 := Source (Token_Ptr + 1);
  224.          C2 := Source (Token_Ptr + 2);
  225.          C3 := Source (Token_Ptr + 3);
  226.  
  227.          if (C1 = 'A' or else C1 = 'a') and then       -- AND
  228.             (C2 = 'N' or else C2 = 'n') and then
  229.             (C3 = 'D' or else C3 = 'd')
  230.          then
  231.             Token_Name := Name_Op_And;
  232.  
  233.          elsif (C1 = 'A' or else C1 = 'a') and then    -- ABS
  234.                (C2 = 'B' or else C2 = 'b') and then
  235.                (C3 = 'S' or else C3 = 's')
  236.          then
  237.             Token_Name := Name_Op_Abs;
  238.  
  239.          elsif (C1 = 'M' or else C1 = 'm') and then    -- MOD
  240.                (C2 = 'O' or else C2 = 'o') and then
  241.                (C3 = 'D' or else C3 = 'd')
  242.          then
  243.             Token_Name := Name_Op_Mod;
  244.  
  245.          elsif (C1 = 'N' or else C1 = 'n') and then    -- NOT
  246.                (C2 = 'O' or else C2 = 'o') and then
  247.                (C3 = 'T' or else C3 = 't')
  248.          then
  249.             Token_Name := Name_Op_Not;
  250.  
  251.          elsif (C1 = 'R' or else C1 = 'r') and then    -- REM
  252.                (C2 = 'E' or else C2 = 'e') and then
  253.                (C3 = 'M' or else C3 = 'm')
  254.          then
  255.             Token_Name := Name_Op_Rem;
  256.  
  257.          elsif (C1 = 'X' or else C1 = 'x') and then    -- XOR
  258.                (C2 = 'O' or else C2 = 'o') and then
  259.                (C3 = 'R' or else C3 = 'r')
  260.          then
  261.             Token_Name := Name_Op_Xor;
  262.          end if;
  263.  
  264.       end if;
  265.  
  266.       --  If it is an operator symbol, then Token_Name is set. If it is some
  267.       --  other string value, then Token_Name still contains Error_Name.
  268.  
  269.       if Token_Name = Error_Name then
  270.          Token := Tok_String_Literal;
  271.          Token_Node := New_Node (N_String_Literal, Token_Ptr);
  272.  
  273.       else
  274.          Token := Tok_Operator_Symbol;
  275.          Token_Node := New_Node (N_Operator_Symbol, Token_Ptr);
  276.          Set_Chars (Token_Node, Token_Name);
  277.       end if;
  278.  
  279.       Set_Strval (Token_Node, String_Literal_Id);
  280.  
  281.    end Set_String;
  282.  
  283. ----------
  284. -- Slit --
  285. ----------
  286.  
  287. begin
  288.  
  289.    --  On entry, Scan_Ptr points to the opening character of the string which
  290.    --  is either a percent, double quote, or apostrophe (single quote). The
  291.    --  latter case is an error detected by the character literal circuit.
  292.  
  293.    Delimiter := Source (Scan_Ptr);
  294.    Start_String;
  295.    Scan_Ptr := Scan_Ptr + 1;
  296.  
  297.    --  Loop to scan out characters of string constant
  298.  
  299.    loop
  300.       C := Source (Scan_Ptr);
  301.  
  302.       if C = Delimiter then
  303.          Scan_Ptr := Scan_Ptr + 1;
  304.          exit when Source (Scan_Ptr) /= Delimiter;
  305.          Code := Get_Char_Code (C);
  306.          Scan_Ptr := Scan_Ptr + 1;
  307.  
  308.       else
  309.          if C = '"' and then Delimiter = '%' then
  310.             Error_Msg_S ("quote not allowed in percent delimited string");
  311.             Code := Get_Char_Code (C);
  312.             Scan_Ptr := Scan_Ptr + 1;
  313.  
  314.          elsif C = ESC
  315.            or else (C in Upper_Half_Character and then Upper_Half_Encoding)
  316.          then
  317.             if not Wide_Noted then
  318.                Note_Feature (Wide_Characters_And_Strings, Scan_Ptr);
  319.                Wide_Noted := True;
  320.             end if;
  321.  
  322.             Scan_Wide (Source, Scan_Ptr, Code, Err);
  323.  
  324.             if Err then
  325.                Error_Illegal_Wide_Character;
  326.                Code := Get_Char_Code (' ');
  327.             end if;
  328.  
  329.          else
  330.             if C not in Graphic_Character then
  331.                if C in Line_Terminator then
  332.                   Error_Unterminated_String;
  333.                   exit;
  334.  
  335.                elsif C in Upper_Half_Character then
  336.                   if not Latin_1_Noted then
  337.                      Note_Feature (Latin_1, Scan_Ptr);
  338.                      Latin_1_Noted := True;
  339.                   end if;
  340.  
  341.                   if Ada_83 then
  342.                      Error_Bad_String_Char;
  343.                   end if;
  344.  
  345.                else
  346.                   Error_Bad_String_Char;
  347.                end if;
  348.             end if;
  349.  
  350.             Code := Get_Char_Code (C);
  351.             Scan_Ptr := Scan_Ptr + 1;
  352.          end if;
  353.       end if;
  354.  
  355.       Store_String_Char (Code);
  356.    end loop;
  357.  
  358.    String_Literal_Id := End_String;
  359.    Set_String;
  360.    return;
  361.  
  362. end Slit;
  363.