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