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