gcc/ada/sfn_scan.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S F N _ S C A N                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2000-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 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Exceptions; use Ada.Exceptions;
  35
  36 package body SFN_Scan is
  37
  38    use ASCII;
  39    --  Allow easy access to control character definitions
  40
  41    type String_Ptr is access String;
  42
  43    S : String_Ptr;
  44    --  Points to the gnat.adc input file
  45
  46    P : Natural;
  47    --  Subscript of next character to process in S
  48
  49    Line_Num : Natural;
  50    --  Current line number
  51
  52    Start_Of_Line : Natural;
  53    --  Subscript of first character at start of current line
  54
  55    ----------------------
  56    -- Local Procedures --
  57    ----------------------
  58
  59    function Acquire_String (B : Natural; E : Natural) return String;
  60    --  This function takes a string scanned out by Scan_String, strips
  61    --  the enclosing quote characters and any internal doubled quote
  62    --  characters, and returns the result as a String. The arguments
  63    --  B and E are as returned from a call to Scan_String. The lower
  64    --  bound of the string returned is always 1.
  65
  66    function Acquire_Unit_Name return String;
  67    --  Skips white space, and then scans and returns a unit name. The
  68    --  unit name is cased exactly as it appears in the source file.
  69    --  The terminating character must be white space, or a comma or
  70    --  a right parenthesis or end of file.
  71
  72    function At_EOF return Boolean;
  73    pragma Inline (At_EOF);
  74    --  Returns True if at end of file, False if not. Note that this
  75    --  function does NOT skip white space, so P is always unchanged.
  76
  77    procedure Check_Not_At_EOF;
  78    pragma Inline (Check_Not_At_EOF);
  79    --  Skips past white space if any, and then raises Error if at
  80    --  end of file. Otherwise returns with P skipped past whitespace.
  81
  82    function Check_File_Type return Character;
  83    --  Skips white space if any, and then looks for any of the tokens
  84    --  Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one
  85    --  of these is found then the value returned is 's', 'b' or 'u'
  86    --  respectively, and P is bumped past the token. If none of
  87    --  these tokens is found, then P is unchanged (except for
  88    --  possible skip of white space), and a space is returned.
  89
  90    function Check_Token (T : String) return Boolean;
  91    --  Skips white space if any, and then checks if the string at the
  92    --  current location matches the given string T, and the character
  93    --  immediately following is non-alphabetic, non-numeric. If so,
  94    --  P is stepped past the token, and True is returned. If not,
  95    --  P is unchanged (except for possibly skipping past whitespace),
  96    --  and False is returned. S may contain only lower-case letters
  97    --  ('a' .. 'z').
  98
  99    procedure Error (Err : String);
 100    --  Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC
 101    --  with a message of the form gnat.adc:line:col: xxx, where xxx is
 102    --  the string Err passed as a parameter.
 103
 104    procedure Require_Token (T : String);
 105    --  Skips white space if any, and then requires the given string
 106    --  to be present. If it is, the P is stepped past it, otherwise
 107    --  Error is raised, since this is a syntax error. Require_Token
 108    --  is used only for sequences of special characters, so there
 109    --  is no issue of terminators, or casing of letters.
 110
 111    procedure Scan_String (B : out Natural; E : out Natural);
 112    --  Skips white space if any, then requires that a double quote
 113    --  or percent be present (start of string). Raises error if
 114    --  neither of these two characters is found. Otherwise scans
 115    --  out the string, and returns with P pointing past the
 116    --  closing quote and S (B .. E) contains the characters of the
 117    --  string (including the enclosing quotes, with internal quotes
 118    --  still doubled). Raises Error if the string is malformed.
 119
 120    procedure Skip_WS;
 121    --  Skips P past any white space characters (end of line
 122    --  characters, spaces, comments, horizontal tab characters).
 123
 124    --------------------
 125    -- Acquire_String --
 126    --------------------
 127
 128    function Acquire_String (B : Natural; E : Natural) return String is
 129       Str : String (1 .. E - B - 1);
 130       Q   : constant Character := S (B);
 131       J   : Natural;
 132       Ptr : Natural;
 133
 134    begin
 135       Ptr := B + 1;
 136       J := 0;
 137       while Ptr < E loop
 138          J := J + 1;
 139          Str (J) := S (Ptr);
 140
 141          if S (Ptr) = Q and then S (Ptr + 1) = Q then
 142             Ptr := Ptr + 2;
 143          else
 144             Ptr := Ptr + 1;
 145          end if;
 146       end loop;
 147
 148       return Str (1 .. J);
 149    end Acquire_String;
 150
 151    -----------------------
 152    -- Acquire_Unit_Name --
 153    -----------------------
 154
 155    function Acquire_Unit_Name return String is
 156       B : Natural;
 157
 158    begin
 159       Check_Not_At_EOF;
 160       B := P;
 161
 162       while not At_EOF loop
 163          exit when S (P) not in '0' .. '9'
 164            and then S (P) /= '.'
 165            and then S (P) /= '_'
 166            and then not (S (P) = '[' and then S (P + 1) = '"')
 167            and then not (S (P) = '"' and then S (P - 1) = '[')
 168            and then not (S (P) = '"' and then S (P + 1) = ']')
 169            and then not (S (P) = ']' and then S (P - 1) = '"')
 170            and then S (P) < 'A';
 171          P := P + 1;
 172       end loop;
 173
 174       if P = B then
 175          Error ("null unit name");
 176       end if;
 177
 178       return S (B .. P - 1);
 179    end Acquire_Unit_Name;
 180
 181    ------------
 182    -- At_EOF --
 183    ------------
 184
 185    function At_EOF return Boolean is
 186    begin
 187       return P > S'Last;
 188    end At_EOF;
 189
 190    ---------------------
 191    -- Check_File_Type --
 192    ---------------------
 193
 194    function Check_File_Type return Character is
 195    begin
 196       if Check_Token ("spec_file_name") then
 197          return 's';
 198       elsif Check_Token ("body_file_name") then
 199          return 'b';
 200       elsif Check_Token ("subunit_file_name") then
 201          return 'u';
 202       else
 203          return ' ';
 204       end if;
 205    end Check_File_Type;
 206
 207    ----------------------
 208    -- Check_Not_At_EOF --
 209    ----------------------
 210
 211    procedure Check_Not_At_EOF is
 212    begin
 213       Skip_WS;
 214
 215       if At_EOF then
 216          Error ("unexpected end of file");
 217       end if;
 218
 219       return;
 220    end Check_Not_At_EOF;
 221
 222    -----------------
 223    -- Check_Token --
 224    -----------------
 225
 226    function Check_Token (T : String) return Boolean is
 227       Save_P : Natural;
 228       C : Character;
 229
 230    begin
 231       Skip_WS;
 232       Save_P := P;
 233
 234       for K in T'Range loop
 235          if At_EOF then
 236             P := Save_P;
 237             return False;
 238          end if;
 239
 240          C := S (P);
 241
 242          if C in 'A' .. 'Z' then
 243             C := Character'Val (Character'Pos (C) +
 244                                  (Character'Pos ('a') - Character'Pos ('A')));
 245          end if;
 246
 247          if C /= T (K) then
 248             P := Save_P;
 249             return False;
 250          end if;
 251
 252          P := P + 1;
 253       end loop;
 254
 255       if At_EOF then
 256          return True;
 257       end if;
 258
 259       C := S (P);
 260
 261       if C in '0' .. '9'
 262         or else C in 'a' .. 'z'
 263         or else C in 'A' .. 'Z'
 264         or else C > Character'Val (127)
 265       then
 266          P := Save_P;
 267          return False;
 268
 269       else
 270          return True;
 271       end if;
 272    end Check_Token;
 273
 274    -----------
 275    -- Error --
 276    -----------
 277
 278    procedure Error (Err : String) is
 279       C : Natural := 0;
 280       --  Column number
 281
 282       M : String (1 .. 80);
 283       --  Buffer used to build resulting error msg
 284
 285       LM : Natural := 0;
 286       --  Pointer to last set location in M
 287
 288       procedure Add_Nat (N : Natural);
 289       --  Add chars of integer to error msg buffer
 290
 291       procedure Add_Nat (N : Natural) is
 292       begin
 293          if N > 9 then
 294             Add_Nat (N / 10);
 295          end if;
 296
 297          LM := LM + 1;
 298          M (LM) := Character'Val (N mod 10 + Character'Pos ('0'));
 299       end Add_Nat;
 300
 301    --  Start of processing for Error
 302
 303    begin
 304       M (1 .. 9) := "gnat.adc:";
 305       LM := 9;
 306       Add_Nat (Line_Num);
 307       LM := LM + 1;
 308       M (LM) := ':';
 309
 310       --  Determine column number
 311
 312       for X in Start_Of_Line .. P loop
 313          C := C + 1;
 314
 315          if S (X) = HT then
 316             C := (C + 7) / 8 * 8;
 317          end if;
 318       end loop;
 319
 320       Add_Nat (C);
 321       M (LM + 1) := ':';
 322       LM := LM + 1;
 323       M (LM + 1) := ' ';
 324       LM := LM + 1;
 325
 326       M (LM + 1 .. LM + Err'Length) := Err;
 327       LM := LM + Err'Length;
 328
 329       Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM));
 330    end Error;
 331
 332    -------------------
 333    -- Require_Token --
 334    -------------------
 335
 336    procedure Require_Token (T : String) is
 337       SaveP : Natural;
 338
 339    begin
 340       Skip_WS;
 341       SaveP := P;
 342
 343       for J in T'Range loop
 344
 345          if At_EOF or else S (P) /= T (J) then
 346             declare
 347                S : String (1 .. T'Length + 10);
 348
 349             begin
 350                S (1 .. 9) := "missing """;
 351                S (10 .. T'Length + 9) := T;
 352                S (T'Length + 10) := '"';
 353                P := SaveP;
 354                Error (S);
 355             end;
 356
 357          else
 358             P := P + 1;
 359          end if;
 360       end loop;
 361    end Require_Token;
 362
 363    ----------------------
 364    -- Scan_SFN_Pragmas --
 365    ----------------------
 366
 367    procedure Scan_SFN_Pragmas
 368      (Source   : String;
 369       SFN_Ptr  : Set_File_Name_Ptr;
 370       SFNP_Ptr : Set_File_Name_Pattern_Ptr)
 371    is
 372       B, E : Natural;
 373       Typ  : Character;
 374       Cas  : Character;
 375
 376    begin
 377       Line_Num := 1;
 378       S := Source'Unrestricted_Access;
 379       P := Source'First;
 380       Start_Of_Line := P;
 381
 382       --  Loop through pragmas in file
 383
 384       Main_Scan_Loop : loop
 385          Skip_WS;
 386          exit Main_Scan_Loop when At_EOF;
 387
 388          --  Error if something other than pragma
 389
 390          if not Check_Token ("pragma") then
 391             Error ("non pragma encountered");
 392          end if;
 393
 394          --  Source_File_Name pragma case
 395
 396          if Check_Token ("source_file_name") then
 397             Require_Token ("(");
 398
 399             Typ := Check_File_Type;
 400
 401             --  First format, with unit name first
 402
 403             if Typ = ' ' then
 404                if Check_Token ("unit_name") then
 405                   Require_Token ("=>");
 406                end if;
 407
 408                declare
 409                   U : constant String := Acquire_Unit_Name;
 410
 411                begin
 412                   Require_Token (",");
 413                   Typ := Check_File_Type;
 414
 415                   if Typ /= 's' and then Typ /= 'b' then
 416                      Error ("bad pragma");
 417                   end if;
 418
 419                   Require_Token ("=>");
 420                   Scan_String (B, E);
 421
 422                   declare
 423                      F : constant String := Acquire_String (B, E);
 424
 425                   begin
 426                      Require_Token (")");
 427                      Require_Token (";");
 428                      SFN_Ptr.all (Typ, U, F);
 429                   end;
 430                end;
 431
 432             --  Second format with pattern string
 433
 434             else
 435                Require_Token ("=>");
 436                Scan_String (B, E);
 437
 438                declare
 439                   Pat : constant String := Acquire_String (B, E);
 440                   Nas : Natural := 0;
 441
 442                begin
 443                   --  Check exactly one asterisk
 444
 445                   for J in Pat'Range loop
 446                      if Pat (J) = '*' then
 447                         Nas := Nas + 1;
 448                      end if;
 449                   end loop;
 450
 451                   if Nas /= 1 then
 452                      Error ("** not allowed");
 453                   end if;
 454
 455                   B := 0;
 456                   E := 0;
 457                   Cas := ' ';
 458
 459                   --  Loop to scan out Casing or Dot_Replacement parameters
 460
 461                   loop
 462                      Check_Not_At_EOF;
 463                      exit when S (P) = ')';
 464                      Require_Token (",");
 465
 466                      if Check_Token ("casing") then
 467                         Require_Token ("=>");
 468
 469                         if Cas /= ' ' then
 470                            Error ("duplicate casing argument");
 471                         elsif Check_Token ("lowercase") then
 472                            Cas := 'l';
 473                         elsif Check_Token ("uppercase") then
 474                            Cas := 'u';
 475                         elsif Check_Token ("mixedcase") then
 476                            Cas := 'm';
 477                         else
 478                            Error ("invalid casing argument");
 479                         end if;
 480
 481                      elsif Check_Token ("dot_replacement") then
 482                         Require_Token ("=>");
 483
 484                         if E /= 0 then
 485                            Error ("duplicate dot_replacement");
 486                         else
 487                            Scan_String (B, E);
 488                         end if;
 489
 490                      else
 491                         Error ("invalid argument");
 492                      end if;
 493                   end loop;
 494
 495                   Require_Token (")");
 496                   Require_Token (";");
 497
 498                   if Cas = ' ' then
 499                      Cas := 'l';
 500                   end if;
 501
 502                   if E = 0 then
 503                      SFNP_Ptr.all (Pat, Typ, ".", Cas);
 504
 505                   else
 506                      declare
 507                         Dot : constant String := Acquire_String (B, E);
 508
 509                      begin
 510                         SFNP_Ptr.all (Pat, Typ, Dot, Cas);
 511                      end;
 512                   end if;
 513                end;
 514             end if;
 515
 516          --  Some other pragma, scan to semicolon at end of pragma
 517
 518          else
 519             Skip_Loop : loop
 520                exit Main_Scan_Loop when At_EOF;
 521                exit Skip_Loop when S (P) = ';';
 522
 523                if S (P) = '"' or else S (P) = '%' then
 524                   Scan_String (B, E);
 525                else
 526                   P := P + 1;
 527                end if;
 528             end loop Skip_Loop;
 529
 530             --  We successfuly skipped to semicolon, so skip past it
 531
 532             P := P + 1;
 533          end if;
 534       end loop Main_Scan_Loop;
 535
 536    exception
 537       when others =>
 538          Cursor := P - S'First + 1;
 539          raise;
 540    end Scan_SFN_Pragmas;
 541
 542    -----------------
 543    -- Scan_String --
 544    -----------------
 545
 546    procedure Scan_String (B : out Natural; E : out Natural) is
 547       Q : Character;
 548
 549    begin
 550       Check_Not_At_EOF;
 551
 552       if S (P) = '"' then
 553          Q := '"';
 554       elsif S (P) = '%' then
 555          Q := '%';
 556       else
 557          Error ("bad string");
 558          Q := '"';
 559       end if;
 560
 561       --  Scan out the string, B points to first char
 562
 563       B := P;
 564       P := P + 1;
 565
 566       loop
 567          if At_EOF or else S (P) = LF or else S (P) = CR then
 568             Error ("missing string quote");
 569
 570          elsif S (P) = HT then
 571             Error ("tab character in string");
 572
 573          elsif S (P) /= Q then
 574             P := P + 1;
 575
 576          --  We have a quote
 577
 578          else
 579             P := P + 1;
 580
 581             --  Check for doubled quote
 582
 583             if not At_EOF and then S (P) = Q then
 584                P := P + 1;
 585
 586             --  Otherwise this is the terminating quote
 587
 588             else
 589                E := P - 1;
 590                return;
 591             end if;
 592          end if;
 593       end loop;
 594    end Scan_String;
 595
 596    -------------
 597    -- Skip_WS --
 598    -------------
 599
 600    procedure Skip_WS is
 601    begin
 602       WS_Scan : while not At_EOF loop
 603          case S (P) is
 604
 605             --  End of physical line
 606
 607             when CR | LF =>
 608                Line_Num := Line_Num + 1;
 609                P := P + 1;
 610
 611                while not At_EOF
 612                  and then (S (P) = CR or else S (P) = LF)
 613                loop
 614                   Line_Num := Line_Num + 1;
 615                   P := P + 1;
 616                end loop;
 617
 618                Start_Of_Line := P;
 619
 620             --  All other cases of white space characters
 621
 622             when ' ' | FF | VT | HT =>
 623                P := P + 1;
 624
 625             --  Comment
 626
 627             when '-' =>
 628                P := P + 1;
 629
 630                if At_EOF then
 631                   Error ("bad comment");
 632
 633                elsif S (P) = '-' then
 634                   P := P + 1;
 635
 636                   while not At_EOF loop
 637                      case S (P) is
 638                         when CR | LF | FF | VT =>
 639                            exit;
 640                         when others =>
 641                            P := P + 1;
 642                      end case;
 643                   end loop;
 644
 645                else
 646                   P := P - 1;
 647                   exit WS_Scan;
 648                end if;
 649
 650             when others =>
 651                exit WS_Scan;
 652
 653          end case;
 654       end loop WS_Scan;
 655    end Skip_WS;
 656
 657 end SFN_Scan;