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