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 --                            $Revision: 1.29 $                             --
  10 --                                                                          --
  11 --          Copyright (C) 1992-1999 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 Stringt; use Stringt;
  30
  31 separate (Scn)
  32 procedure Slit is
  33
  34    Delimiter : Character;
  35    --  Delimiter (first character of string)
  36
  37    C : Character;
  38    --  Current source program character
  39
  40    Code : Char_Code;
  41    --  Current character code value
  42
  43    Err : Boolean;
  44    --  Error flag for Scan_Wide call
  45
  46    String_Literal_Id : String_Id;
  47    --  Id for currently scanned string value
  48
  49    Wide_Character_Found : Boolean := False;
  50    --  Set True if wide character found
  51
  52    procedure Error_Bad_String_Char;
  53    --  Signal bad character in string/character literal. On entry Scan_Ptr
  54    --  points to the improper character encountered during the scan. Scan_Ptr
  55    --  is not modified, so it still points to the bad character on return.
  56
  57    procedure Error_Unterminated_String;
  58    --  Procedure called if a line terminator character is encountered during
  59    --  scanning a string, meaning that the string is not properly terminated.
  60
  61    procedure Set_String;
  62    --  Procedure used to distinguish between string and operator symbol.
  63    --  On entry the string has been scanned out, and its characters start
  64    --  at Token_Ptr and end one character before Scan_Ptr. On exit Token
  65    --  is set to Tok_String_Literal or Tok_Operator_Symbol as appropriate,
  66    --  and Token_Node is appropriately initialized. In addition, in the
  67    --  operator symbol case, Token_Name is appropriately set.
  68
  69    ---------------------------
  70    -- Error_Bad_String_Char --
  71    ---------------------------
  72
  73    procedure Error_Bad_String_Char is
  74       C : constant Character := Source (Scan_Ptr);
  75
  76    begin
  77       if C = HT then
  78          Error_Msg_S ("horizontal tab not allowed in string");
  79
  80       elsif C = VT or else C = FF then
  81          Error_Msg_S ("format effector not allowed in string");
  82
  83       elsif C in Upper_Half_Character then
  84          Error_Msg_S ("(Ada 83) upper half character not allowed");
  85
  86       else
  87          Error_Msg_S ("control character not allowed in string");
  88       end if;
  89    end Error_Bad_String_Char;
  90
  91    -------------------------------
  92    -- Error_Unterminated_String --
  93    -------------------------------
  94
  95    procedure Error_Unterminated_String is
  96    begin
  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          Set_Has_Wide_Character (Token_Node, Wide_Character_Found);
 273
 274       else
 275          Token := Tok_Operator_Symbol;
 276          Token_Node := New_Node (N_Operator_Symbol, Token_Ptr);
 277          Set_Chars (Token_Node, Token_Name);
 278       end if;
 279
 280       Set_Strval (Token_Node, String_Literal_Id);
 281
 282    end Set_String;
 283
 284 ----------
 285 -- Slit --
 286 ----------
 287
 288 begin
 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    Accumulate_Checksum (Delimiter);
 295    Start_String;
 296    Scan_Ptr := Scan_Ptr + 1;
 297
 298    --  Loop to scan out characters of string literal
 299
 300    loop
 301       C := Source (Scan_Ptr);
 302
 303       if C = Delimiter then
 304          Accumulate_Checksum (C);
 305          Scan_Ptr := Scan_Ptr + 1;
 306          exit when Source (Scan_Ptr) /= Delimiter;
 307          Code := Get_Char_Code (C);
 308          Accumulate_Checksum (C);
 309          Scan_Ptr := Scan_Ptr + 1;
 310
 311       else
 312          if C = '"' and then Delimiter = '%' then
 313             Error_Msg_S ("quote not allowed in percent delimited string");
 314             Code := Get_Char_Code (C);
 315             Scan_Ptr := Scan_Ptr + 1;
 316
 317          elsif (C = ESC
 318                  and then
 319                 Wide_Character_Encoding_Method in WC_ESC_Encoding_Method)
 320            or else
 321                (C in Upper_Half_Character
 322                  and then
 323                 Upper_Half_Encoding)
 324            or else
 325                (C = '['
 326                  and then
 327                 Source (Scan_Ptr + 1) = '"'
 328                  and then
 329                 Identifier_Char (Source (Scan_Ptr + 2)))
 330          then
 331             Scan_Wide (Source, Scan_Ptr, Code, Err);
 332             Accumulate_Checksum (Code);
 333
 334             if Err then
 335                Error_Illegal_Wide_Character;
 336                Code := Get_Char_Code (' ');
 337             end if;
 338
 339          else
 340             Accumulate_Checksum (C);
 341
 342             if C not in Graphic_Character then
 343                if C in Line_Terminator then
 344                   Error_Unterminated_String;
 345                   exit;
 346
 347                elsif C in Upper_Half_Character then
 348                   if Ada_83 then
 349                      Error_Bad_String_Char;
 350                   end if;
 351
 352                else
 353                   Error_Bad_String_Char;
 354                end if;
 355             end if;
 356
 357             Code := Get_Char_Code (C);
 358             Scan_Ptr := Scan_Ptr + 1;
 359          end if;
 360       end if;
 361
 362       Store_String_Char (Code);
 363
 364       if not In_Character_Range (Code) then
 365          Wide_Character_Found := True;
 366       end if;
 367    end loop;
 368
 369    String_Literal_Id := End_String;
 370    Set_String;
 371    return;
 372
 373 end Slit;