gcc/ada/scn-slit.adb

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