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