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