gcc/ada/par-prag.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             P A R . P R A G                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2004 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 --  Generally the parser checks the basic syntax of pragmas, but does not
  28 --  do specialized syntax checks for individual pragmas, these are deferred
  29 --  to semantic analysis time (see unit Sem_Prag). There are some pragmas
  30 --  which require recognition and either partial or complete processing
  31 --  during parsing, and this unit performs this required processing.
  32
  33 with Fname.UF; use Fname.UF;
  34 with Osint;    use Osint;
  35 with Stringt;  use Stringt;
  36 with Stylesw;  use Stylesw;
  37 with Uintp;    use Uintp;
  38 with Uname;    use Uname;
  39
  40 separate (Par)
  41
  42 function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
  43    Pragma_Name : constant Name_Id    := Chars (Pragma_Node);
  44    Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node);
  45    Arg_Count   : Nat;
  46    Arg_Node    : Node_Id;
  47
  48    -----------------------
  49    -- Local Subprograms --
  50    -----------------------
  51
  52    function Arg1 return Node_Id;
  53    function Arg2 return Node_Id;
  54    function Arg3 return Node_Id;
  55    --  Obtain specified Pragma_Argument_Association. It is allowable to call
  56    --  the routine for the argument one past the last present argument, but
  57    --  that is the only case in which a non-present argument can be referenced.
  58
  59    procedure Check_Arg_Count (Required : Int);
  60    --  Check argument count for pragma = Required.
  61    --  If not give error and raise Error_Resync.
  62
  63    procedure Check_Arg_Is_String_Literal (Arg : Node_Id);
  64    --  Check the expression of the specified argument to make sure that it
  65    --  is a string literal. If not give error and raise Error_Resync.
  66
  67    procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id);
  68    --  Check the expression of the specified argument to make sure that it
  69    --  is an identifier which is either ON or OFF, and if not, then issue
  70    --  an error message and raise Error_Resync.
  71
  72    procedure Check_No_Identifier (Arg : Node_Id);
  73    --  Checks that the given argument does not have an identifier. If
  74    --  an identifier is present, then an error message is issued, and
  75    --  Error_Resync is raised.
  76
  77    procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
  78    --  Checks if the given argument has an identifier, and if so, requires
  79    --  it to match the given identifier name. If there is a non-matching
  80    --  identifier, then an error message is given and Error_Resync raised.
  81
  82    procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id);
  83    --  Same as Check_Optional_Identifier, except that the name is required
  84    --  to be present and to match the given Id value.
  85
  86    ----------
  87    -- Arg1 --
  88    ----------
  89
  90    function Arg1 return Node_Id is
  91    begin
  92       return First (Pragma_Argument_Associations (Pragma_Node));
  93    end Arg1;
  94
  95    ----------
  96    -- Arg2 --
  97    ----------
  98
  99    function Arg2 return Node_Id is
 100    begin
 101       return Next (Arg1);
 102    end Arg2;
 103
 104    ----------
 105    -- Arg3 --
 106    ----------
 107
 108    function Arg3 return Node_Id is
 109    begin
 110       return Next (Arg2);
 111    end Arg3;
 112
 113    ---------------------
 114    -- Check_Arg_Count --
 115    ---------------------
 116
 117    procedure Check_Arg_Count (Required : Int) is
 118    begin
 119       if Arg_Count /= Required then
 120          Error_Msg ("wrong number of arguments for pragma%", Pragma_Sloc);
 121          raise Error_Resync;
 122       end if;
 123    end Check_Arg_Count;
 124
 125    ----------------------------
 126    -- Check_Arg_Is_On_Or_Off --
 127    ----------------------------
 128
 129    procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id) is
 130       Argx : constant Node_Id := Expression (Arg);
 131
 132    begin
 133       if Nkind (Expression (Arg)) /= N_Identifier
 134         or else (Chars (Argx) /= Name_On
 135                    and then
 136                  Chars (Argx) /= Name_Off)
 137       then
 138          Error_Msg_Name_2 := Name_On;
 139          Error_Msg_Name_3 := Name_Off;
 140
 141          Error_Msg
 142            ("argument for pragma% must be% or%", Sloc (Argx));
 143          raise Error_Resync;
 144       end if;
 145    end Check_Arg_Is_On_Or_Off;
 146
 147    ---------------------------------
 148    -- Check_Arg_Is_String_Literal --
 149    ---------------------------------
 150
 151    procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
 152    begin
 153       if Nkind (Expression (Arg)) /= N_String_Literal then
 154          Error_Msg
 155            ("argument for pragma% must be string literal",
 156              Sloc (Expression (Arg)));
 157          raise Error_Resync;
 158       end if;
 159    end Check_Arg_Is_String_Literal;
 160
 161    -------------------------
 162    -- Check_No_Identifier --
 163    -------------------------
 164
 165    procedure Check_No_Identifier (Arg : Node_Id) is
 166    begin
 167       if Chars (Arg) /= No_Name then
 168          Error_Msg_N ("pragma% does not permit named arguments", Arg);
 169          raise Error_Resync;
 170       end if;
 171    end Check_No_Identifier;
 172
 173    -------------------------------
 174    -- Check_Optional_Identifier --
 175    -------------------------------
 176
 177    procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
 178    begin
 179       if Present (Arg) and then Chars (Arg) /= No_Name then
 180          if Chars (Arg) /= Id then
 181             Error_Msg_Name_2 := Id;
 182             Error_Msg_N ("pragma% argument expects identifier%", Arg);
 183          end if;
 184       end if;
 185    end Check_Optional_Identifier;
 186
 187    -------------------------------
 188    -- Check_Required_Identifier --
 189    -------------------------------
 190
 191    procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id) is
 192    begin
 193       if Chars (Arg) /= Id then
 194          Error_Msg_Name_2 := Id;
 195          Error_Msg_N ("pragma% argument must have identifier%", Arg);
 196       end if;
 197    end Check_Required_Identifier;
 198
 199    ----------
 200    -- Prag --
 201    ----------
 202
 203 begin
 204    Error_Msg_Name_1 := Pragma_Name;
 205
 206    --  Ignore unrecognized pragma. We let Sem post the warning for this, since
 207    --  it is a semantic error, not a syntactic one (we have already checked
 208    --  the syntax for the unrecognized pragma as required by (RM 2.8(11)).
 209
 210    if not Is_Pragma_Name (Chars (Pragma_Node)) then
 211       return Pragma_Node;
 212    end if;
 213
 214    --  Count number of arguments. This loop also checks if any of the arguments
 215    --  are Error, indicating a syntax error as they were parsed. If so, we
 216    --  simply return, because we get into trouble with cascaded errors if we
 217    --  try to perform our error checks on junk arguments.
 218
 219    Arg_Count := 0;
 220
 221    if Present (Pragma_Argument_Associations (Pragma_Node)) then
 222       Arg_Node := Arg1;
 223
 224       while Arg_Node /= Empty loop
 225          Arg_Count := Arg_Count + 1;
 226
 227          if Expression (Arg_Node) = Error then
 228             return Error;
 229          end if;
 230
 231          Next (Arg_Node);
 232       end loop;
 233    end if;
 234
 235    --  Remaining processing is pragma dependent
 236
 237    case Get_Pragma_Id (Pragma_Name) is
 238
 239       ------------
 240       -- Ada_83 --
 241       ------------
 242
 243       --  This pragma must be processed at parse time, since we want to set
 244       --  the Ada version properly at parse time to recognize the appropriate
 245       --  Ada version syntax.
 246
 247       when Pragma_Ada_83 =>
 248          Ada_Version := Ada_83;
 249
 250       ------------
 251       -- Ada_95 --
 252       ------------
 253
 254       --  This pragma must be processed at parse time, since we want to set
 255       --  the Ada version properly at parse time to recognize the appropriate
 256       --  Ada version syntax.
 257
 258       when Pragma_Ada_95 =>
 259          Ada_Version := Ada_95;
 260
 261       ------------
 262       -- Ada_05 --
 263       ------------
 264
 265       --  This pragma must be processed at parse time, since we want to set
 266       --  the Ada version properly at parse time to recognize the appropriate
 267       --  Ada version syntax.
 268
 269       when Pragma_Ada_05 =>
 270          Ada_Version := Ada_05;
 271
 272       -----------
 273       -- Debug --
 274       -----------
 275
 276       --  pragma Debug (PROCEDURE_CALL_STATEMENT);
 277
 278       --  This has to be processed by the parser because of the very peculiar
 279       --  form of the second parameter, which is syntactically from a formal
 280       --  point of view a function call (since it must be an expression), but
 281       --  semantically we treat it as a procedure call (which has exactly the
 282       --  same syntactic form, so that's why we can get away with this!)
 283
 284       when Pragma_Debug =>
 285          Check_Arg_Count (1);
 286          Check_No_Identifier (Arg1);
 287
 288          declare
 289             Expr : constant Node_Id := New_Copy (Expression (Arg1));
 290
 291          begin
 292             if Nkind (Expr) /= N_Indexed_Component
 293               and then Nkind (Expr) /= N_Function_Call
 294               and then Nkind (Expr) /= N_Identifier
 295               and then Nkind (Expr) /= N_Selected_Component
 296             then
 297                Error_Msg
 298                  ("argument of pragma% is not procedure call", Sloc (Expr));
 299                raise Error_Resync;
 300             else
 301                Set_Debug_Statement
 302                  (Pragma_Node, P_Statement_Name (Expr));
 303             end if;
 304          end;
 305
 306       -------------------------------
 307       -- Extensions_Allowed (GNAT) --
 308       -------------------------------
 309
 310       --  pragma Extensions_Allowed (Off | On)
 311
 312       --  The processing for pragma Extensions_Allowed must be done at
 313       --  parse time, since extensions mode may affect what is accepted.
 314
 315       when Pragma_Extensions_Allowed =>
 316          Check_Arg_Count (1);
 317          Check_No_Identifier (Arg1);
 318          Check_Arg_Is_On_Or_Off (Arg1);
 319
 320          if Chars (Expression (Arg1)) = Name_On then
 321             Extensions_Allowed := True;
 322             Ada_Version := Ada_Version_Type'Last;
 323          else
 324             Extensions_Allowed := False;
 325             Ada_Version := Ada_Version_Type'Min (Ada_Version, Ada_95);
 326          end if;
 327
 328       ----------------
 329       -- List (2.8) --
 330       ----------------
 331
 332       --  pragma List (Off | On)
 333
 334       --  The processing for pragma List must be done at parse time,
 335       --  since a listing can be generated in parse only mode.
 336
 337       when Pragma_List =>
 338          Check_Arg_Count (1);
 339          Check_No_Identifier (Arg1);
 340          Check_Arg_Is_On_Or_Off (Arg1);
 341
 342          --  We unconditionally make a List_On entry for the pragma, so that
 343          --  in the List (Off) case, the pragma will print even in a region
 344          --  of code with listing turned off (this is required!)
 345
 346          List_Pragmas.Increment_Last;
 347          List_Pragmas.Table (List_Pragmas.Last) :=
 348            (Ptyp => List_On, Ploc => Sloc (Pragma_Node));
 349
 350          --  Now generate the list off entry for pragma List (Off)
 351
 352          if Chars (Expression (Arg1)) = Name_Off then
 353             List_Pragmas.Increment_Last;
 354             List_Pragmas.Table (List_Pragmas.Last) :=
 355               (Ptyp => List_Off, Ploc => Semi);
 356          end if;
 357
 358       ----------------
 359       -- Page (2.8) --
 360       ----------------
 361
 362       --  pragma Page;
 363
 364       --  Processing for this pragma must be done at parse time, since a
 365       --  listing can be generated in parse only mode with semantics off.
 366
 367       when Pragma_Page =>
 368          Check_Arg_Count (0);
 369          List_Pragmas.Increment_Last;
 370          List_Pragmas.Table (List_Pragmas.Last) := (Page, Semi);
 371
 372       ----------------------------------------------------------
 373       -- Source_File_Name and Source_File_Name_Project (GNAT) --
 374       ----------------------------------------------------------
 375
 376       --  These two pragmas have the same syntax and semantics.
 377       --  There are five forms of these pragmas:
 378
 379       --  pragma Source_File_Name[_Project] (
 380       --    [UNIT_NAME      =>] unit_NAME,
 381       --     BODY_FILE_NAME =>  STRING_LITERAL
 382       --    [, [INDEX =>] INTEGER_LITERAL]);
 383
 384       --  pragma Source_File_Name[_Project] (
 385       --    [UNIT_NAME      =>] unit_NAME,
 386       --     SPEC_FILE_NAME =>  STRING_LITERAL
 387       --    [, [INDEX =>] INTEGER_LITERAL]);
 388
 389       --  pragma Source_File_Name[_Project] (
 390       --     BODY_FILE_NAME  => STRING_LITERAL
 391       --  [, DOT_REPLACEMENT => STRING_LITERAL]
 392       --  [, CASING          => CASING_SPEC]);
 393
 394       --  pragma Source_File_Name[_Project] (
 395       --     SPEC_FILE_NAME  => STRING_LITERAL
 396       --  [, DOT_REPLACEMENT => STRING_LITERAL]
 397       --  [, CASING          => CASING_SPEC]);
 398
 399       --  pragma Source_File_Name[_Project] (
 400       --     SUBUNIT_FILE_NAME  => STRING_LITERAL
 401       --  [, DOT_REPLACEMENT    => STRING_LITERAL]
 402       --  [, CASING             => CASING_SPEC]);
 403
 404       --  CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
 405
 406       --  Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
 407       --  Source_File_Name (SFN), however their usage is exclusive:
 408       --  SFN can only be used when no project file is used, while
 409       --  SFNP can only be used when a project file is used.
 410
 411       --  The Project Manager produces a configuration pragmas file that
 412       --  is communicated to the compiler with -gnatec switch. This file
 413       --  contains only SFNP pragmas (at least two for the default naming
 414       --  scheme. As this configuration pragmas file is always the first
 415       --  processed by the compiler, it prevents the use of pragmas SFN in
 416       --  other config files when a project file is in use.
 417
 418       --  Note: we process this during parsing, since we need to have the
 419       --  source file names set well before the semantic analysis starts,
 420       --  since we load the spec and with'ed packages before analysis.
 421
 422       when Pragma_Source_File_Name | Pragma_Source_File_Name_Project =>
 423          Source_File_Name : declare
 424             Unam  : Unit_Name_Type;
 425             Expr1 : Node_Id;
 426             Pat   : String_Ptr;
 427             Typ   : Character;
 428             Dot   : String_Ptr;
 429             Cas   : Casing_Type;
 430             Nast  : Nat;
 431             Expr  : Node_Id;
 432             Index : Nat;
 433
 434             function Get_Fname (Arg : Node_Id) return Name_Id;
 435             --  Process file name from unit name form of pragma
 436
 437             function Get_String_Argument (Arg : Node_Id) return String_Ptr;
 438             --  Process string literal value from argument
 439
 440             procedure Process_Casing (Arg : Node_Id);
 441             --  Process Casing argument of pattern form of pragma
 442
 443             procedure Process_Dot_Replacement (Arg : Node_Id);
 444             --  Process Dot_Replacement argument of patterm form of pragma
 445
 446             ---------------
 447             -- Get_Fname --
 448             ---------------
 449
 450             function Get_Fname (Arg : Node_Id) return Name_Id is
 451             begin
 452                String_To_Name_Buffer (Strval (Expression (Arg)));
 453
 454                for J in 1 .. Name_Len loop
 455                   if Is_Directory_Separator (Name_Buffer (J)) then
 456                      Error_Msg
 457                        ("directory separator character not allowed",
 458                         Sloc (Expression (Arg)) + Source_Ptr (J));
 459                   end if;
 460                end loop;
 461
 462                return Name_Find;
 463             end Get_Fname;
 464
 465             -------------------------
 466             -- Get_String_Argument --
 467             -------------------------
 468
 469             function Get_String_Argument (Arg : Node_Id) return String_Ptr is
 470                Str : String_Id;
 471
 472             begin
 473                if Nkind (Expression (Arg)) /= N_String_Literal
 474                  and then
 475                   Nkind (Expression (Arg)) /= N_Operator_Symbol
 476                then
 477                   Error_Msg_N
 478                     ("argument for pragma% must be string literal", Arg);
 479                   raise Error_Resync;
 480                end if;
 481
 482                Str := Strval (Expression (Arg));
 483
 484                --  Check string has no wide chars
 485
 486                for J in 1 .. String_Length (Str) loop
 487                   if Get_String_Char (Str, J) > 255 then
 488                      Error_Msg
 489                        ("wide character not allowed in pattern for pragma%",
 490                         Sloc (Expression (Arg2)) + Text_Ptr (J) - 1);
 491                   end if;
 492                end loop;
 493
 494                --  Acquire string
 495
 496                String_To_Name_Buffer (Str);
 497                return new String'(Name_Buffer (1 .. Name_Len));
 498             end Get_String_Argument;
 499
 500             --------------------
 501             -- Process_Casing --
 502             --------------------
 503
 504             procedure Process_Casing (Arg : Node_Id) is
 505                Expr : constant Node_Id := Expression (Arg);
 506
 507             begin
 508                Check_Required_Identifier (Arg, Name_Casing);
 509
 510                if Nkind (Expr) = N_Identifier then
 511                   if Chars (Expr) = Name_Lowercase then
 512                      Cas := All_Lower_Case;
 513                      return;
 514                   elsif Chars (Expr) = Name_Uppercase then
 515                      Cas := All_Upper_Case;
 516                      return;
 517                   elsif Chars (Expr) = Name_Mixedcase then
 518                      Cas := Mixed_Case;
 519                      return;
 520                   end if;
 521                end if;
 522
 523                Error_Msg_N
 524                  ("Casing argument for pragma% must be " &
 525                   "one of Mixedcase, Lowercase, Uppercase",
 526                   Arg);
 527             end Process_Casing;
 528
 529             -----------------------------
 530             -- Process_Dot_Replacement --
 531             -----------------------------
 532
 533             procedure Process_Dot_Replacement (Arg : Node_Id) is
 534             begin
 535                Check_Required_Identifier (Arg, Name_Dot_Replacement);
 536                Dot := Get_String_Argument (Arg);
 537             end Process_Dot_Replacement;
 538
 539          --  Start of processing for Source_File_Name and
 540          --  Source_File_Name_Project pragmas.
 541
 542          begin
 543             if Get_Pragma_Id (Pragma_Name) = Pragma_Source_File_Name then
 544                if Project_File_In_Use = In_Use then
 545                   Error_Msg
 546                     ("pragma Source_File_Name cannot be used " &
 547                      "with a project file", Pragma_Sloc);
 548
 549                else
 550                   Project_File_In_Use := Not_In_Use;
 551                end if;
 552
 553             else
 554                if Project_File_In_Use = Not_In_Use then
 555                   Error_Msg
 556                     ("pragma Source_File_Name_Project should only be used " &
 557                      "with a project file", Pragma_Sloc);
 558                else
 559                   Project_File_In_Use := In_Use;
 560                end if;
 561             end if;
 562
 563             --  We permit from 1 to 3 arguments
 564
 565             if Arg_Count not in 1 .. 3 then
 566                Check_Arg_Count (1);
 567             end if;
 568
 569             Expr1 := Expression (Arg1);
 570
 571             --  If first argument is identifier or selected component, then
 572             --  we have the specific file case of the Source_File_Name pragma,
 573             --  and the first argument is a unit name.
 574
 575             if Nkind (Expr1) = N_Identifier
 576               or else
 577                 (Nkind (Expr1) = N_Selected_Component
 578                   and then
 579                  Nkind (Selector_Name (Expr1)) = N_Identifier)
 580             then
 581                if Nkind (Expr1) = N_Identifier
 582                  and then Chars (Expr1) = Name_System
 583                then
 584                   Error_Msg_N
 585                     ("pragma Source_File_Name may not be used for System",
 586                      Arg1);
 587                   return Error;
 588                end if;
 589
 590                --  Process index argument if present
 591
 592                if Arg_Count = 3 then
 593                   Expr := Expression (Arg3);
 594
 595                   if Nkind (Expr) /= N_Integer_Literal
 596                     or else not UI_Is_In_Int_Range (Intval (Expr))
 597                     or else Intval (Expr) > 999
 598                     or else Intval (Expr) <= 0
 599                   then
 600                      Error_Msg
 601                        ("pragma% index must be integer literal" &
 602                         " in range 1 .. 999", Sloc (Expr));
 603                      raise Error_Resync;
 604                   else
 605                      Index := UI_To_Int (Intval (Expr));
 606                   end if;
 607
 608                --  No index argument present
 609
 610                else
 611                   Check_Arg_Count (2);
 612                   Index := 0;
 613                end if;
 614
 615                Check_Optional_Identifier (Arg1, Name_Unit_Name);
 616                Unam := Get_Unit_Name (Expr1);
 617
 618                Check_Arg_Is_String_Literal (Arg2);
 619
 620                if Chars (Arg2) = Name_Spec_File_Name then
 621                   Set_File_Name
 622                     (Get_Spec_Name (Unam), Get_Fname (Arg2), Index);
 623
 624                elsif Chars (Arg2) = Name_Body_File_Name then
 625                   Set_File_Name
 626                     (Unam, Get_Fname (Arg2), Index);
 627
 628                else
 629                   Error_Msg_N
 630                     ("pragma% argument has incorrect identifier", Arg2);
 631                   return Pragma_Node;
 632                end if;
 633
 634             --  If the first argument is not an identifier, then we must have
 635             --  the pattern form of the pragma, and the first argument must be
 636             --  the pattern string with an appropriate name.
 637
 638             else
 639                if Chars (Arg1) = Name_Spec_File_Name then
 640                   Typ := 's';
 641
 642                elsif Chars (Arg1) = Name_Body_File_Name then
 643                   Typ := 'b';
 644
 645                elsif Chars (Arg1) = Name_Subunit_File_Name then
 646                   Typ := 'u';
 647
 648                elsif Chars (Arg1) = Name_Unit_Name then
 649                   Error_Msg_N
 650                     ("Unit_Name parameter for pragma% must be an identifier",
 651                      Arg1);
 652                   raise Error_Resync;
 653
 654                else
 655                   Error_Msg_N
 656                     ("pragma% argument has incorrect identifier", Arg1);
 657                   raise Error_Resync;
 658                end if;
 659
 660                Pat := Get_String_Argument (Arg1);
 661
 662                --  Check pattern has exactly one asterisk
 663
 664                Nast := 0;
 665                for J in Pat'Range loop
 666                   if Pat (J) = '*' then
 667                      Nast := Nast + 1;
 668                   end if;
 669                end loop;
 670
 671                if Nast /= 1 then
 672                   Error_Msg_N
 673                     ("file name pattern must have exactly one * character",
 674                      Arg1);
 675                   return Pragma_Node;
 676                end if;
 677
 678                --  Set defaults for Casing and Dot_Separator parameters
 679
 680                Cas := All_Lower_Case;
 681                Dot := new String'(".");
 682
 683                --  Process second and third arguments if present
 684
 685                if Arg_Count > 1 then
 686                   if Chars (Arg2) = Name_Casing then
 687                      Process_Casing (Arg2);
 688
 689                      if Arg_Count = 3 then
 690                         Process_Dot_Replacement (Arg3);
 691                      end if;
 692
 693                   else
 694                      Process_Dot_Replacement (Arg2);
 695
 696                      if Arg_Count = 3 then
 697                         Process_Casing (Arg3);
 698                      end if;
 699                   end if;
 700                end if;
 701
 702                Set_File_Name_Pattern (Pat, Typ, Dot, Cas);
 703             end if;
 704          end Source_File_Name;
 705
 706       -----------------------------
 707       -- Source_Reference (GNAT) --
 708       -----------------------------
 709
 710       --  pragma Source_Reference
 711       --    (INTEGER_LITERAL [, STRING_LITERAL] );
 712
 713       --  Processing for this pragma must be done at parse time, since error
 714       --  messages needing the proper line numbers can be generated in parse
 715       --  only mode with semantic checking turned off, and indeed we usually
 716       --  turn off semantic checking anyway if any parse errors are found.
 717
 718       when Pragma_Source_Reference => Source_Reference : declare
 719          Fname : Name_Id;
 720
 721       begin
 722          if Arg_Count /= 1 then
 723             Check_Arg_Count (2);
 724             Check_No_Identifier (Arg2);
 725          end if;
 726
 727          --  Check that this is first line of file. We skip this test if
 728          --  we are in syntax check only mode, since we may be dealing with
 729          --  multiple compilation units.
 730
 731          if Get_Physical_Line_Number (Pragma_Sloc) /= 1
 732            and then Num_SRef_Pragmas (Current_Source_File) = 0
 733            and then Operating_Mode /= Check_Syntax
 734          then
 735             Error_Msg
 736               ("first % pragma must be first line of file", Pragma_Sloc);
 737             raise Error_Resync;
 738          end if;
 739
 740          Check_No_Identifier (Arg1);
 741
 742          if Arg_Count = 1 then
 743             if Num_SRef_Pragmas (Current_Source_File) = 0 then
 744                Error_Msg
 745                  ("file name required for first % pragma in file",
 746                   Pragma_Sloc);
 747                raise Error_Resync;
 748             else
 749                Fname := No_Name;
 750             end if;
 751
 752          --  File name present
 753
 754          else
 755             Check_Arg_Is_String_Literal (Arg2);
 756             String_To_Name_Buffer (Strval (Expression (Arg2)));
 757             Fname := Name_Find;
 758
 759             if Num_SRef_Pragmas (Current_Source_File) > 0 then
 760                if Fname /= Full_Ref_Name (Current_Source_File) then
 761                   Error_Msg
 762                     ("file name must be same in all % pragmas", Pragma_Sloc);
 763                   raise Error_Resync;
 764                end if;
 765             end if;
 766          end if;
 767
 768          if Nkind (Expression (Arg1)) /= N_Integer_Literal then
 769             Error_Msg
 770               ("argument for pragma% must be integer literal",
 771                 Sloc (Expression (Arg1)));
 772             raise Error_Resync;
 773
 774          --  OK, this source reference pragma is effective, however, we
 775          --  ignore it if it is not in the first unit in the multiple unit
 776          --  case. This is because the only purpose in this case is to
 777          --  provide source pragmas for subsequent use by gnatchop.
 778
 779          else
 780             if Num_Library_Units = 1 then
 781                Register_Source_Ref_Pragma
 782                  (Fname,
 783                   Strip_Directory (Fname),
 784                   UI_To_Int (Intval (Expression (Arg1))),
 785                   Get_Physical_Line_Number (Pragma_Sloc) + 1);
 786             end if;
 787          end if;
 788       end Source_Reference;
 789
 790       -------------------------
 791       -- Style_Checks (GNAT) --
 792       -------------------------
 793
 794       --  pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
 795
 796       --  This is processed by the parser since some of the style
 797       --  checks take place during source scanning and parsing.
 798
 799       when Pragma_Style_Checks => Style_Checks : declare
 800          A  : Node_Id;
 801          S  : String_Id;
 802          C  : Char_Code;
 803          OK : Boolean := True;
 804
 805       begin
 806          --  Two argument case is only for semantics
 807
 808          if Arg_Count = 2 then
 809             null;
 810
 811          else
 812             Check_Arg_Count (1);
 813             Check_No_Identifier (Arg1);
 814             A := Expression (Arg1);
 815
 816             if Nkind (A) = N_String_Literal then
 817                S   := Strval (A);
 818
 819                declare
 820                   Slen    : constant Natural := Natural (String_Length (S));
 821                   Options : String (1 .. Slen);
 822                   J       : Natural;
 823                   Ptr     : Natural;
 824
 825                begin
 826                   J := 1;
 827                   loop
 828                      C := Get_String_Char (S, Int (J));
 829
 830                      if not In_Character_Range (C) then
 831                         OK := False;
 832                         Ptr := J;
 833                         exit;
 834
 835                      else
 836                         Options (J) := Get_Character (C);
 837                      end if;
 838
 839                      if J = Slen then
 840                         Set_Style_Check_Options (Options, OK, Ptr);
 841                         exit;
 842
 843                      else
 844                         J := J + 1;
 845                      end if;
 846                   end loop;
 847
 848                   if not OK then
 849                      Error_Msg
 850                        ("invalid style check option",
 851                         Sloc (Expression (Arg1)) + Source_Ptr (Ptr));
 852                      raise Error_Resync;
 853                   end if;
 854                end;
 855
 856             elsif Nkind (A) /= N_Identifier then
 857                OK := False;
 858
 859             elsif Chars (A) = Name_All_Checks then
 860                Stylesw.Set_Default_Style_Check_Options;
 861
 862             elsif Chars (A) = Name_On then
 863                Style_Check := True;
 864
 865             elsif Chars (A) = Name_Off then
 866                Style_Check := False;
 867
 868             else
 869                OK := False;
 870             end if;
 871
 872             if not OK then
 873                Error_Msg ("incorrect argument for pragma%", Sloc (A));
 874                raise Error_Resync;
 875             end if;
 876          end if;
 877       end Style_Checks;
 878
 879       ---------------------
 880       -- Warnings (GNAT) --
 881       ---------------------
 882
 883       --  pragma Warnings (On | Off, [LOCAL_NAME])
 884
 885       --  The one argument case is processed by the parser, since it may
 886       --  control parser warnings as well as semantic warnings, and in any
 887       --  case we want to be absolutely sure that the range in the warnings
 888       --  table is set well before any semantic analysis is performed.
 889
 890       when Pragma_Warnings =>
 891          if Arg_Count = 1 then
 892             Check_No_Identifier (Arg1);
 893             Check_Arg_Is_On_Or_Off (Arg1);
 894
 895             if Chars (Expression (Arg1)) = Name_On then
 896                Set_Warnings_Mode_On (Pragma_Sloc);
 897             else
 898                Set_Warnings_Mode_Off (Pragma_Sloc);
 899             end if;
 900          end if;
 901
 902       -----------------------
 903       -- All Other Pragmas --
 904       -----------------------
 905
 906       --  For all other pragmas, checking and processing is handled
 907       --  entirely in Sem_Prag, and no further checking is done by Par.
 908
 909       when Pragma_Abort_Defer                  |
 910            Pragma_AST_Entry                    |
 911            Pragma_All_Calls_Remote             |
 912            Pragma_Annotate                     |
 913            Pragma_Assert                       |
 914            Pragma_Asynchronous                 |
 915            Pragma_Atomic                       |
 916            Pragma_Atomic_Components            |
 917            Pragma_Attach_Handler               |
 918            Pragma_Compile_Time_Warning         |
 919            Pragma_Convention_Identifier        |
 920            Pragma_CPP_Class                    |
 921            Pragma_CPP_Constructor              |
 922            Pragma_CPP_Virtual                  |
 923            Pragma_CPP_Vtable                   |
 924            Pragma_C_Pass_By_Copy               |
 925            Pragma_Comment                      |
 926            Pragma_Common_Object                |
 927            Pragma_Complex_Representation       |
 928            Pragma_Component_Alignment          |
 929            Pragma_Controlled                   |
 930            Pragma_Convention                   |
 931            Pragma_Detect_Blocking              |
 932            Pragma_Discard_Names                |
 933            Pragma_Eliminate                    |
 934            Pragma_Elaborate                    |
 935            Pragma_Elaborate_All                |
 936            Pragma_Elaborate_Body               |
 937            Pragma_Elaboration_Checks           |
 938            Pragma_Explicit_Overriding          |
 939            Pragma_Export                       |
 940            Pragma_Export_Exception             |
 941            Pragma_Export_Function              |
 942            Pragma_Export_Object                |
 943            Pragma_Export_Procedure             |
 944            Pragma_Export_Value                 |
 945            Pragma_Export_Valued_Procedure      |
 946            Pragma_Extend_System                |
 947            Pragma_External                     |
 948            Pragma_External_Name_Casing         |
 949            Pragma_Finalize_Storage_Only        |
 950            Pragma_Float_Representation         |
 951            Pragma_Ident                        |
 952            Pragma_Import                       |
 953            Pragma_Import_Exception             |
 954            Pragma_Import_Function              |
 955            Pragma_Import_Object                |
 956            Pragma_Import_Procedure             |
 957            Pragma_Import_Valued_Procedure      |
 958            Pragma_Initialize_Scalars           |
 959            Pragma_Inline                       |
 960            Pragma_Inline_Always                |
 961            Pragma_Inline_Generic               |
 962            Pragma_Inspection_Point             |
 963            Pragma_Interface                    |
 964            Pragma_Interface_Name               |
 965            Pragma_Interrupt_Handler            |
 966            Pragma_Interrupt_State              |
 967            Pragma_Interrupt_Priority           |
 968            Pragma_Java_Constructor             |
 969            Pragma_Java_Interface               |
 970            Pragma_Keep_Names                   |
 971            Pragma_License                      |
 972            Pragma_Link_With                    |
 973            Pragma_Linker_Alias                 |
 974            Pragma_Linker_Options               |
 975            Pragma_Linker_Section               |
 976            Pragma_Locking_Policy               |
 977            Pragma_Long_Float                   |
 978            Pragma_Machine_Attribute            |
 979            Pragma_Main                         |
 980            Pragma_Main_Storage                 |
 981            Pragma_Memory_Size                  |
 982            Pragma_No_Return                    |
 983            Pragma_Obsolescent                  |
 984            Pragma_No_Run_Time                  |
 985            Pragma_No_Strict_Aliasing           |
 986            Pragma_Normalize_Scalars            |
 987            Pragma_Optimize                     |
 988            Pragma_Optional_Overriding          |
 989            Pragma_Overriding                   |
 990            Pragma_Pack                         |
 991            Pragma_Passive                      |
 992            Pragma_Polling                      |
 993            Pragma_Persistent_Data              |
 994            Pragma_Persistent_Object            |
 995            Pragma_Preelaborate                 |
 996            Pragma_Priority                     |
 997            Pragma_Profile                      |
 998            Pragma_Profile_Warnings             |
 999            Pragma_Propagate_Exceptions         |
1000            Pragma_Psect_Object                 |
1001            Pragma_Pure                         |
1002            Pragma_Pure_Function                |
1003            Pragma_Queuing_Policy               |
1004            Pragma_Remote_Call_Interface        |
1005            Pragma_Remote_Types                 |
1006            Pragma_Restrictions                 |
1007            Pragma_Restriction_Warnings         |
1008            Pragma_Restricted_Run_Time          |
1009            Pragma_Ravenscar                    |
1010            Pragma_Reviewable                   |
1011            Pragma_Share_Generic                |
1012            Pragma_Shared                       |
1013            Pragma_Shared_Passive               |
1014            Pragma_Storage_Size                 |
1015            Pragma_Storage_Unit                 |
1016            Pragma_Stream_Convert               |
1017            Pragma_Subtitle                     |
1018            Pragma_Suppress                     |
1019            Pragma_Suppress_All                 |
1020            Pragma_Suppress_Debug_Info          |
1021            Pragma_Suppress_Exception_Locations |
1022            Pragma_Suppress_Initialization      |
1023            Pragma_System_Name                  |
1024            Pragma_Task_Dispatching_Policy      |
1025            Pragma_Task_Info                    |
1026            Pragma_Task_Name                    |
1027            Pragma_Task_Storage                 |
1028            Pragma_Thread_Body                  |
1029            Pragma_Time_Slice                   |
1030            Pragma_Title                        |
1031            Pragma_Unchecked_Union              |
1032            Pragma_Unimplemented_Unit           |
1033            Pragma_Universal_Data               |
1034            Pragma_Unreferenced                 |
1035            Pragma_Unreserve_All_Interrupts     |
1036            Pragma_Unsuppress                   |
1037            Pragma_Use_VADS_Size                |
1038            Pragma_Volatile                     |
1039            Pragma_Volatile_Components          |
1040            Pragma_Weak_External                |
1041            Pragma_Validity_Checks              =>
1042          null;
1043
1044       --------------------
1045       -- Unknown_Pragma --
1046       --------------------
1047
1048       --  Should be impossible, since we excluded this case earlier on
1049
1050       when Unknown_Pragma =>
1051          raise Program_Error;
1052
1053    end case;
1054
1055    return Pragma_Node;
1056
1057    --------------------
1058    -- Error Handling --
1059    --------------------
1060
1061 exception
1062    when Error_Resync =>
1063       return Error;
1064
1065 end Prag;