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-2012, 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.  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 --  Generally the parser checks the basic syntax of pragmas, but does not
  27 --  do specialized syntax checks for individual pragmas, these are deferred
  28 --  to semantic analysis time (see unit Sem_Prag). There are some pragmas
  29 --  which require recognition and either partial or complete processing
  30 --  during parsing, and this unit performs this required processing.
  31
  32 with Fname.UF; use Fname.UF;
  33 with Osint;    use Osint;
  34 with Rident;   use Rident;
  35 with Restrict; use Restrict;
  36 with Stringt;  use Stringt;
  37 with Stylesw;  use Stylesw;
  38 with Uintp;    use Uintp;
  39 with Uname;    use Uname;
  40
  41 with System.WCh_Con; use System.WCh_Con;
  42
  43 separate (Par)
  44
  45 function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
  46    Prag_Name   : constant Name_Id    := Pragma_Name (Pragma_Node);
  47    Prag_Id     : constant Pragma_Id  := Get_Pragma_Id (Prag_Name);
  48    Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node);
  49    Arg_Count   : Nat;
  50    Arg_Node    : Node_Id;
  51
  52    -----------------------
  53    -- Local Subprograms --
  54    -----------------------
  55
  56    function Arg1 return Node_Id;
  57    function Arg2 return Node_Id;
  58    function Arg3 return Node_Id;
  59    --  Obtain specified Pragma_Argument_Association. It is allowable to call
  60    --  the routine for the argument one past the last present argument, but
  61    --  that is the only case in which a non-present argument can be referenced.
  62
  63    procedure Check_Arg_Count (Required : Int);
  64    --  Check argument count for pragma = Required. If not give error and raise
  65    --  Error_Resync.
  66
  67    procedure Check_Arg_Is_String_Literal (Arg : Node_Id);
  68    --  Check the expression of the specified argument to make sure that it
  69    --  is a string literal. If not give error and raise Error_Resync.
  70
  71    procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id);
  72    --  Check the expression of the specified argument to make sure that it
  73    --  is an identifier which is either ON or OFF, and if not, then issue
  74    --  an error message and raise Error_Resync.
  75
  76    procedure Check_No_Identifier (Arg : Node_Id);
  77    --  Checks that the given argument does not have an identifier. If
  78    --  an identifier is present, then an error message is issued, and
  79    --  Error_Resync is raised.
  80
  81    procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
  82    --  Checks if the given argument has an identifier, and if so, requires
  83    --  it to match the given identifier name. If there is a non-matching
  84    --  identifier, then an error message is given and Error_Resync raised.
  85
  86    procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id);
  87    --  Same as Check_Optional_Identifier, except that the name is required
  88    --  to be present and to match the given Id value.
  89
  90    procedure Process_Restrictions_Or_Restriction_Warnings;
  91    --  Common processing for Restrictions and Restriction_Warnings pragmas.
  92    --  For the most part, restrictions need not be processed at parse time,
  93    --  since they only affect semantic processing. This routine handles the
  94    --  exceptions as follows
  95    --
  96    --    No_Obsolescent_Features must be processed at parse time, since there
  97    --    are some obsolescent features (e.g. character replacements) which are
  98    --    handled at parse time.
  99    --
 100    --    SPARK must be processed at parse time, since this restriction controls
 101    --    whether the scanner recognizes a spark HIDE directive formatted as an
 102    --    Ada comment (and generates a Tok_SPARK_Hide token for the directive).
 103    --
 104    --    No_Dependence must be processed at parse time, since otherwise it gets
 105    --    handled too late.
 106    --
 107    --  Note that we don't need to do full error checking for badly formed cases
 108    --  of restrictions, since these will be caught during semantic analysis.
 109
 110    ----------
 111    -- Arg1 --
 112    ----------
 113
 114    function Arg1 return Node_Id is
 115    begin
 116       return First (Pragma_Argument_Associations (Pragma_Node));
 117    end Arg1;
 118
 119    ----------
 120    -- Arg2 --
 121    ----------
 122
 123    function Arg2 return Node_Id is
 124    begin
 125       return Next (Arg1);
 126    end Arg2;
 127
 128    ----------
 129    -- Arg3 --
 130    ----------
 131
 132    function Arg3 return Node_Id is
 133    begin
 134       return Next (Arg2);
 135    end Arg3;
 136
 137    ---------------------
 138    -- Check_Arg_Count --
 139    ---------------------
 140
 141    procedure Check_Arg_Count (Required : Int) is
 142    begin
 143       if Arg_Count /= Required then
 144          Error_Msg ("wrong number of arguments for pragma%", Pragma_Sloc);
 145          raise Error_Resync;
 146       end if;
 147    end Check_Arg_Count;
 148
 149    ----------------------------
 150    -- Check_Arg_Is_On_Or_Off --
 151    ----------------------------
 152
 153    procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id) is
 154       Argx : constant Node_Id := Expression (Arg);
 155
 156    begin
 157       if Nkind (Expression (Arg)) /= N_Identifier
 158         or else (Chars (Argx) /= Name_On
 159                    and then
 160                  Chars (Argx) /= Name_Off)
 161       then
 162          Error_Msg_Name_2 := Name_On;
 163          Error_Msg_Name_3 := Name_Off;
 164
 165          Error_Msg ("argument for pragma% must be% or%", Sloc (Argx));
 166          raise Error_Resync;
 167       end if;
 168    end Check_Arg_Is_On_Or_Off;
 169
 170    ---------------------------------
 171    -- Check_Arg_Is_String_Literal --
 172    ---------------------------------
 173
 174    procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
 175    begin
 176       if Nkind (Expression (Arg)) /= N_String_Literal then
 177          Error_Msg
 178            ("argument for pragma% must be string literal",
 179              Sloc (Expression (Arg)));
 180          raise Error_Resync;
 181       end if;
 182    end Check_Arg_Is_String_Literal;
 183
 184    -------------------------
 185    -- Check_No_Identifier --
 186    -------------------------
 187
 188    procedure Check_No_Identifier (Arg : Node_Id) is
 189    begin
 190       if Chars (Arg) /= No_Name then
 191          Error_Msg_N ("pragma% does not permit named arguments", Arg);
 192          raise Error_Resync;
 193       end if;
 194    end Check_No_Identifier;
 195
 196    -------------------------------
 197    -- Check_Optional_Identifier --
 198    -------------------------------
 199
 200    procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
 201    begin
 202       if Present (Arg) and then Chars (Arg) /= No_Name then
 203          if Chars (Arg) /= Id then
 204             Error_Msg_Name_2 := Id;
 205             Error_Msg_N ("pragma% argument expects identifier%", Arg);
 206          end if;
 207       end if;
 208    end Check_Optional_Identifier;
 209
 210    -------------------------------
 211    -- Check_Required_Identifier --
 212    -------------------------------
 213
 214    procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id) is
 215    begin
 216       if Chars (Arg) /= Id then
 217          Error_Msg_Name_2 := Id;
 218          Error_Msg_N ("pragma% argument must have identifier%", Arg);
 219       end if;
 220    end Check_Required_Identifier;
 221
 222    --------------------------------------------------
 223    -- Process_Restrictions_Or_Restriction_Warnings --
 224    --------------------------------------------------
 225
 226    procedure Process_Restrictions_Or_Restriction_Warnings is
 227       Arg  : Node_Id;
 228       Id   : Name_Id;
 229       Expr : Node_Id;
 230
 231    begin
 232       Arg := Arg1;
 233       while Present (Arg) loop
 234          Id := Chars (Arg);
 235          Expr := Expression (Arg);
 236
 237          if Id = No_Name
 238            and then Nkind (Expr) = N_Identifier
 239          then
 240             case Get_Restriction_Id (Chars (Expr)) is
 241                when No_Obsolescent_Features =>
 242                   Set_Restriction (No_Obsolescent_Features, Pragma_Node);
 243                   Restriction_Warnings (No_Obsolescent_Features) :=
 244                     Prag_Id = Pragma_Restriction_Warnings;
 245
 246                when SPARK =>
 247                   Set_Restriction (SPARK, Pragma_Node);
 248                   Restriction_Warnings (SPARK) :=
 249                     Prag_Id = Pragma_Restriction_Warnings;
 250
 251                when others =>
 252                   null;
 253             end case;
 254
 255          elsif Id = Name_No_Dependence then
 256             Set_Restriction_No_Dependence
 257               (Unit => Expr,
 258                Warn => Prag_Id = Pragma_Restriction_Warnings
 259                          or else Treat_Restrictions_As_Warnings);
 260          end if;
 261
 262          Next (Arg);
 263       end loop;
 264    end Process_Restrictions_Or_Restriction_Warnings;
 265
 266 --  Start of processing for Prag
 267
 268 begin
 269    Error_Msg_Name_1 := Prag_Name;
 270
 271    --  Ignore unrecognized pragma. We let Sem post the warning for this, since
 272    --  it is a semantic error, not a syntactic one (we have already checked
 273    --  the syntax for the unrecognized pragma as required by (RM 2.8(11)).
 274
 275    if Prag_Id = Unknown_Pragma then
 276       return Pragma_Node;
 277    end if;
 278
 279    --  Count number of arguments. This loop also checks if any of the arguments
 280    --  are Error, indicating a syntax error as they were parsed. If so, we
 281    --  simply return, because we get into trouble with cascaded errors if we
 282    --  try to perform our error checks on junk arguments.
 283
 284    Arg_Count := 0;
 285
 286    if Present (Pragma_Argument_Associations (Pragma_Node)) then
 287       Arg_Node := Arg1;
 288       while Arg_Node /= Empty loop
 289          Arg_Count := Arg_Count + 1;
 290
 291          if Expression (Arg_Node) = Error then
 292             return Error;
 293          end if;
 294
 295          Next (Arg_Node);
 296       end loop;
 297    end if;
 298
 299    --  Remaining processing is pragma dependent
 300
 301    case Prag_Id is
 302
 303       ------------
 304       -- Ada_83 --
 305       ------------
 306
 307       --  This pragma must be processed at parse time, since we want to set
 308       --  the Ada version properly at parse time to recognize the appropriate
 309       --  Ada version syntax.
 310
 311       when Pragma_Ada_83 =>
 312          Ada_Version := Ada_83;
 313          Ada_Version_Explicit := Ada_Version;
 314
 315       ------------
 316       -- Ada_95 --
 317       ------------
 318
 319       --  This pragma must be processed at parse time, since we want to set
 320       --  the Ada version properly at parse time to recognize the appropriate
 321       --  Ada version syntax.
 322
 323       when Pragma_Ada_95 =>
 324          Ada_Version := Ada_95;
 325          Ada_Version_Explicit := Ada_Version;
 326
 327       ---------------------
 328       -- Ada_05/Ada_2005 --
 329       ---------------------
 330
 331       --  These pragmas must be processed at parse time, since we want to set
 332       --  the Ada version properly at parse time to recognize the appropriate
 333       --  Ada version syntax. However, it is only the zero argument form that
 334       --  must be processed at parse time.
 335
 336       when Pragma_Ada_05 | Pragma_Ada_2005 =>
 337          if Arg_Count = 0 then
 338             Ada_Version := Ada_2005;
 339             Ada_Version_Explicit := Ada_2005;
 340          end if;
 341
 342       ---------------------
 343       -- Ada_12/Ada_2012 --
 344       ---------------------
 345
 346       --  These pragmas must be processed at parse time, since we want to set
 347       --  the Ada version properly at parse time to recognize the appropriate
 348       --  Ada version syntax. However, it is only the zero argument form that
 349       --  must be processed at parse time.
 350
 351       when Pragma_Ada_12 | Pragma_Ada_2012 =>
 352          if Arg_Count = 0 then
 353             Ada_Version := Ada_2012;
 354             Ada_Version_Explicit := Ada_2012;
 355          end if;
 356
 357       -----------
 358       -- Debug --
 359       -----------
 360
 361       --  pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
 362
 363       when Pragma_Debug =>
 364          Check_No_Identifier (Arg1);
 365
 366          if Arg_Count = 2 then
 367             Check_No_Identifier (Arg2);
 368          else
 369             Check_Arg_Count (1);
 370          end if;
 371
 372       -------------------------------
 373       -- Extensions_Allowed (GNAT) --
 374       -------------------------------
 375
 376       --  pragma Extensions_Allowed (Off | On)
 377
 378       --  The processing for pragma Extensions_Allowed must be done at
 379       --  parse time, since extensions mode may affect what is accepted.
 380
 381       when Pragma_Extensions_Allowed =>
 382          Check_Arg_Count (1);
 383          Check_No_Identifier (Arg1);
 384          Check_Arg_Is_On_Or_Off (Arg1);
 385
 386          if Chars (Expression (Arg1)) = Name_On then
 387             Extensions_Allowed := True;
 388             Ada_Version := Ada_2012;
 389          else
 390             Extensions_Allowed := False;
 391             Ada_Version := Ada_Version_Explicit;
 392          end if;
 393
 394       ----------------
 395       -- List (2.8) --
 396       ----------------
 397
 398       --  pragma List (Off | On)
 399
 400       --  The processing for pragma List must be done at parse time,
 401       --  since a listing can be generated in parse only mode.
 402
 403       when Pragma_List =>
 404          Check_Arg_Count (1);
 405          Check_No_Identifier (Arg1);
 406          Check_Arg_Is_On_Or_Off (Arg1);
 407
 408          --  We unconditionally make a List_On entry for the pragma, so that
 409          --  in the List (Off) case, the pragma will print even in a region
 410          --  of code with listing turned off (this is required!)
 411
 412          List_Pragmas.Increment_Last;
 413          List_Pragmas.Table (List_Pragmas.Last) :=
 414            (Ptyp => List_On, Ploc => Sloc (Pragma_Node));
 415
 416          --  Now generate the list off entry for pragma List (Off)
 417
 418          if Chars (Expression (Arg1)) = Name_Off then
 419             List_Pragmas.Increment_Last;
 420             List_Pragmas.Table (List_Pragmas.Last) :=
 421               (Ptyp => List_Off, Ploc => Semi);
 422          end if;
 423
 424       ----------------
 425       -- Page (2.8) --
 426       ----------------
 427
 428       --  pragma Page;
 429
 430       --  Processing for this pragma must be done at parse time, since a
 431       --  listing can be generated in parse only mode with semantics off.
 432
 433       when Pragma_Page =>
 434          Check_Arg_Count (0);
 435          List_Pragmas.Increment_Last;
 436          List_Pragmas.Table (List_Pragmas.Last) := (Page, Semi);
 437
 438       ------------------
 439       -- Restrictions --
 440       ------------------
 441
 442       --  pragma Restrictions (RESTRICTION {, RESTRICTION});
 443
 444       --  RESTRICTION ::=
 445       --    restriction_IDENTIFIER
 446       --  | restriction_parameter_IDENTIFIER => EXPRESSION
 447
 448       --  We process the case of No_Obsolescent_Features, since this has
 449       --  a syntactic effect that we need to detect at parse time (the use
 450       --  of replacement characters such as colon for pound sign).
 451
 452       when Pragma_Restrictions =>
 453          Process_Restrictions_Or_Restriction_Warnings;
 454
 455       --------------------------
 456       -- Restriction_Warnings --
 457       --------------------------
 458
 459       --  pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
 460
 461       --  RESTRICTION ::=
 462       --    restriction_IDENTIFIER
 463       --  | restriction_parameter_IDENTIFIER => EXPRESSION
 464
 465       --  See above comment for pragma Restrictions
 466
 467       when Pragma_Restriction_Warnings =>
 468          Process_Restrictions_Or_Restriction_Warnings;
 469
 470       ----------------------------------------------------------
 471       -- Source_File_Name and Source_File_Name_Project (GNAT) --
 472       ----------------------------------------------------------
 473
 474       --  These two pragmas have the same syntax and semantics.
 475       --  There are five forms of these pragmas:
 476
 477       --  pragma Source_File_Name[_Project] (
 478       --    [UNIT_NAME      =>] unit_NAME,
 479       --     BODY_FILE_NAME =>  STRING_LITERAL
 480       --    [, [INDEX =>] INTEGER_LITERAL]);
 481
 482       --  pragma Source_File_Name[_Project] (
 483       --    [UNIT_NAME      =>] unit_NAME,
 484       --     SPEC_FILE_NAME =>  STRING_LITERAL
 485       --    [, [INDEX =>] INTEGER_LITERAL]);
 486
 487       --  pragma Source_File_Name[_Project] (
 488       --     BODY_FILE_NAME  => STRING_LITERAL
 489       --  [, DOT_REPLACEMENT => STRING_LITERAL]
 490       --  [, CASING          => CASING_SPEC]);
 491
 492       --  pragma Source_File_Name[_Project] (
 493       --     SPEC_FILE_NAME  => STRING_LITERAL
 494       --  [, DOT_REPLACEMENT => STRING_LITERAL]
 495       --  [, CASING          => CASING_SPEC]);
 496
 497       --  pragma Source_File_Name[_Project] (
 498       --     SUBUNIT_FILE_NAME  => STRING_LITERAL
 499       --  [, DOT_REPLACEMENT    => STRING_LITERAL]
 500       --  [, CASING             => CASING_SPEC]);
 501
 502       --  CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
 503
 504       --  Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
 505       --  Source_File_Name (SFN), however their usage is exclusive:
 506       --  SFN can only be used when no project file is used, while
 507       --  SFNP can only be used when a project file is used.
 508
 509       --  The Project Manager produces a configuration pragmas file that
 510       --  is communicated to the compiler with -gnatec switch. This file
 511       --  contains only SFNP pragmas (at least two for the default naming
 512       --  scheme. As this configuration pragmas file is always the first
 513       --  processed by the compiler, it prevents the use of pragmas SFN in
 514       --  other config files when a project file is in use.
 515
 516       --  Note: we process this during parsing, since we need to have the
 517       --  source file names set well before the semantic analysis starts,
 518       --  since we load the spec and with'ed packages before analysis.
 519
 520       when Pragma_Source_File_Name | Pragma_Source_File_Name_Project =>
 521          Source_File_Name : declare
 522             Unam  : Unit_Name_Type;
 523             Expr1 : Node_Id;
 524             Pat   : String_Ptr;
 525             Typ   : Character;
 526             Dot   : String_Ptr;
 527             Cas   : Casing_Type;
 528             Nast  : Nat;
 529             Expr  : Node_Id;
 530             Index : Nat;
 531
 532             function Get_Fname (Arg : Node_Id) return File_Name_Type;
 533             --  Process file name from unit name form of pragma
 534
 535             function Get_String_Argument (Arg : Node_Id) return String_Ptr;
 536             --  Process string literal value from argument
 537
 538             procedure Process_Casing (Arg : Node_Id);
 539             --  Process Casing argument of pattern form of pragma
 540
 541             procedure Process_Dot_Replacement (Arg : Node_Id);
 542             --  Process Dot_Replacement argument of pattern form of pragma
 543
 544             ---------------
 545             -- Get_Fname --
 546             ---------------
 547
 548             function Get_Fname (Arg : Node_Id) return File_Name_Type is
 549             begin
 550                String_To_Name_Buffer (Strval (Expression (Arg)));
 551
 552                for J in 1 .. Name_Len loop
 553                   if Is_Directory_Separator (Name_Buffer (J)) then
 554                      Error_Msg
 555                        ("directory separator character not allowed",
 556                         Sloc (Expression (Arg)) + Source_Ptr (J));
 557                   end if;
 558                end loop;
 559
 560                return Name_Find;
 561             end Get_Fname;
 562
 563             -------------------------
 564             -- Get_String_Argument --
 565             -------------------------
 566
 567             function Get_String_Argument (Arg : Node_Id) return String_Ptr is
 568                Str : String_Id;
 569
 570             begin
 571                if Nkind (Expression (Arg)) /= N_String_Literal
 572                  and then
 573                   Nkind (Expression (Arg)) /= N_Operator_Symbol
 574                then
 575                   Error_Msg_N
 576                     ("argument for pragma% must be string literal", Arg);
 577                   raise Error_Resync;
 578                end if;
 579
 580                Str := Strval (Expression (Arg));
 581
 582                --  Check string has no wide chars
 583
 584                for J in 1 .. String_Length (Str) loop
 585                   if Get_String_Char (Str, J) > 255 then
 586                      Error_Msg
 587                        ("wide character not allowed in pattern for pragma%",
 588                         Sloc (Expression (Arg2)) + Text_Ptr (J) - 1);
 589                   end if;
 590                end loop;
 591
 592                --  Acquire string
 593
 594                String_To_Name_Buffer (Str);
 595                return new String'(Name_Buffer (1 .. Name_Len));
 596             end Get_String_Argument;
 597
 598             --------------------
 599             -- Process_Casing --
 600             --------------------
 601
 602             procedure Process_Casing (Arg : Node_Id) is
 603                Expr : constant Node_Id := Expression (Arg);
 604
 605             begin
 606                Check_Required_Identifier (Arg, Name_Casing);
 607
 608                if Nkind (Expr) = N_Identifier then
 609                   if Chars (Expr) = Name_Lowercase then
 610                      Cas := All_Lower_Case;
 611                      return;
 612                   elsif Chars (Expr) = Name_Uppercase then
 613                      Cas := All_Upper_Case;
 614                      return;
 615                   elsif Chars (Expr) = Name_Mixedcase then
 616                      Cas := Mixed_Case;
 617                      return;
 618                   end if;
 619                end if;
 620
 621                Error_Msg_N
 622                  ("Casing argument for pragma% must be " &
 623                   "one of Mixedcase, Lowercase, Uppercase",
 624                   Arg);
 625             end Process_Casing;
 626
 627             -----------------------------
 628             -- Process_Dot_Replacement --
 629             -----------------------------
 630
 631             procedure Process_Dot_Replacement (Arg : Node_Id) is
 632             begin
 633                Check_Required_Identifier (Arg, Name_Dot_Replacement);
 634                Dot := Get_String_Argument (Arg);
 635             end Process_Dot_Replacement;
 636
 637          --  Start of processing for Source_File_Name and
 638          --  Source_File_Name_Project pragmas.
 639
 640          begin
 641             if Prag_Id = Pragma_Source_File_Name then
 642                if Project_File_In_Use = In_Use then
 643                   Error_Msg
 644                     ("pragma Source_File_Name cannot be used " &
 645                      "with a project file", Pragma_Sloc);
 646
 647                else
 648                   Project_File_In_Use := Not_In_Use;
 649                end if;
 650
 651             else
 652                if Project_File_In_Use = Not_In_Use then
 653                   Error_Msg
 654                     ("pragma Source_File_Name_Project should only be used " &
 655                      "with a project file", Pragma_Sloc);
 656                else
 657                   Project_File_In_Use := In_Use;
 658                end if;
 659             end if;
 660
 661             --  We permit from 1 to 3 arguments
 662
 663             if Arg_Count not in 1 .. 3 then
 664                Check_Arg_Count (1);
 665             end if;
 666
 667             Expr1 := Expression (Arg1);
 668
 669             --  If first argument is identifier or selected component, then
 670             --  we have the specific file case of the Source_File_Name pragma,
 671             --  and the first argument is a unit name.
 672
 673             if Nkind (Expr1) = N_Identifier
 674               or else
 675                 (Nkind (Expr1) = N_Selected_Component
 676                   and then
 677                  Nkind (Selector_Name (Expr1)) = N_Identifier)
 678             then
 679                if Nkind (Expr1) = N_Identifier
 680                  and then Chars (Expr1) = Name_System
 681                then
 682                   Error_Msg_N
 683                     ("pragma Source_File_Name may not be used for System",
 684                      Arg1);
 685                   return Error;
 686                end if;
 687
 688                --  Process index argument if present
 689
 690                if Arg_Count = 3 then
 691                   Expr := Expression (Arg3);
 692
 693                   if Nkind (Expr) /= N_Integer_Literal
 694                     or else not UI_Is_In_Int_Range (Intval (Expr))
 695                     or else Intval (Expr) > 999
 696                     or else Intval (Expr) <= 0
 697                   then
 698                      Error_Msg
 699                        ("pragma% index must be integer literal" &
 700                         " in range 1 .. 999", Sloc (Expr));
 701                      raise Error_Resync;
 702                   else
 703                      Index := UI_To_Int (Intval (Expr));
 704                   end if;
 705
 706                --  No index argument present
 707
 708                else
 709                   Check_Arg_Count (2);
 710                   Index := 0;
 711                end if;
 712
 713                Check_Optional_Identifier (Arg1, Name_Unit_Name);
 714                Unam := Get_Unit_Name (Expr1);
 715
 716                Check_Arg_Is_String_Literal (Arg2);
 717
 718                if Chars (Arg2) = Name_Spec_File_Name then
 719                   Set_File_Name
 720                     (Get_Spec_Name (Unam), Get_Fname (Arg2), Index);
 721
 722                elsif Chars (Arg2) = Name_Body_File_Name then
 723                   Set_File_Name
 724                     (Unam, Get_Fname (Arg2), Index);
 725
 726                else
 727                   Error_Msg_N
 728                     ("pragma% argument has incorrect identifier", Arg2);
 729                   return Pragma_Node;
 730                end if;
 731
 732             --  If the first argument is not an identifier, then we must have
 733             --  the pattern form of the pragma, and the first argument must be
 734             --  the pattern string with an appropriate name.
 735
 736             else
 737                if Chars (Arg1) = Name_Spec_File_Name then
 738                   Typ := 's';
 739
 740                elsif Chars (Arg1) = Name_Body_File_Name then
 741                   Typ := 'b';
 742
 743                elsif Chars (Arg1) = Name_Subunit_File_Name then
 744                   Typ := 'u';
 745
 746                elsif Chars (Arg1) = Name_Unit_Name then
 747                   Error_Msg_N
 748                     ("Unit_Name parameter for pragma% must be an identifier",
 749                      Arg1);
 750                   raise Error_Resync;
 751
 752                else
 753                   Error_Msg_N
 754                     ("pragma% argument has incorrect identifier", Arg1);
 755                   raise Error_Resync;
 756                end if;
 757
 758                Pat := Get_String_Argument (Arg1);
 759
 760                --  Check pattern has exactly one asterisk
 761
 762                Nast := 0;
 763                for J in Pat'Range loop
 764                   if Pat (J) = '*' then
 765                      Nast := Nast + 1;
 766                   end if;
 767                end loop;
 768
 769                if Nast /= 1 then
 770                   Error_Msg_N
 771                     ("file name pattern must have exactly one * character",
 772                      Arg1);
 773                   return Pragma_Node;
 774                end if;
 775
 776                --  Set defaults for Casing and Dot_Separator parameters
 777
 778                Cas := All_Lower_Case;
 779                Dot := new String'(".");
 780
 781                --  Process second and third arguments if present
 782
 783                if Arg_Count > 1 then
 784                   if Chars (Arg2) = Name_Casing then
 785                      Process_Casing (Arg2);
 786
 787                      if Arg_Count = 3 then
 788                         Process_Dot_Replacement (Arg3);
 789                      end if;
 790
 791                   else
 792                      Process_Dot_Replacement (Arg2);
 793
 794                      if Arg_Count = 3 then
 795                         Process_Casing (Arg3);
 796                      end if;
 797                   end if;
 798                end if;
 799
 800                Set_File_Name_Pattern (Pat, Typ, Dot, Cas);
 801             end if;
 802          end Source_File_Name;
 803
 804       -----------------------------
 805       -- Source_Reference (GNAT) --
 806       -----------------------------
 807
 808       --  pragma Source_Reference
 809       --    (INTEGER_LITERAL [, STRING_LITERAL] );
 810
 811       --  Processing for this pragma must be done at parse time, since error
 812       --  messages needing the proper line numbers can be generated in parse
 813       --  only mode with semantic checking turned off, and indeed we usually
 814       --  turn off semantic checking anyway if any parse errors are found.
 815
 816       when Pragma_Source_Reference => Source_Reference : declare
 817          Fname : File_Name_Type;
 818
 819       begin
 820          if Arg_Count /= 1 then
 821             Check_Arg_Count (2);
 822             Check_No_Identifier (Arg2);
 823          end if;
 824
 825          --  Check that this is first line of file. We skip this test if
 826          --  we are in syntax check only mode, since we may be dealing with
 827          --  multiple compilation units.
 828
 829          if Get_Physical_Line_Number (Pragma_Sloc) /= 1
 830            and then Num_SRef_Pragmas (Current_Source_File) = 0
 831            and then Operating_Mode /= Check_Syntax
 832          then
 833             Error_Msg -- CODEFIX
 834               ("first % pragma must be first line of file", Pragma_Sloc);
 835             raise Error_Resync;
 836          end if;
 837
 838          Check_No_Identifier (Arg1);
 839
 840          if Arg_Count = 1 then
 841             if Num_SRef_Pragmas (Current_Source_File) = 0 then
 842                Error_Msg
 843                  ("file name required for first % pragma in file",
 844                   Pragma_Sloc);
 845                raise Error_Resync;
 846             else
 847                Fname := No_File;
 848             end if;
 849
 850          --  File name present
 851
 852          else
 853             Check_Arg_Is_String_Literal (Arg2);
 854             String_To_Name_Buffer (Strval (Expression (Arg2)));
 855             Fname := Name_Find;
 856
 857             if Num_SRef_Pragmas (Current_Source_File) > 0 then
 858                if Fname /= Full_Ref_Name (Current_Source_File) then
 859                   Error_Msg
 860                     ("file name must be same in all % pragmas", Pragma_Sloc);
 861                   raise Error_Resync;
 862                end if;
 863             end if;
 864          end if;
 865
 866          if Nkind (Expression (Arg1)) /= N_Integer_Literal then
 867             Error_Msg
 868               ("argument for pragma% must be integer literal",
 869                 Sloc (Expression (Arg1)));
 870             raise Error_Resync;
 871
 872          --  OK, this source reference pragma is effective, however, we
 873          --  ignore it if it is not in the first unit in the multiple unit
 874          --  case. This is because the only purpose in this case is to
 875          --  provide source pragmas for subsequent use by gnatchop.
 876
 877          else
 878             if Num_Library_Units = 1 then
 879                Register_Source_Ref_Pragma
 880                  (Fname,
 881                   Strip_Directory (Fname),
 882                   UI_To_Int (Intval (Expression (Arg1))),
 883                   Get_Physical_Line_Number (Pragma_Sloc) + 1);
 884             end if;
 885          end if;
 886       end Source_Reference;
 887
 888       -------------------------
 889       -- Style_Checks (GNAT) --
 890       -------------------------
 891
 892       --  pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
 893
 894       --  This is processed by the parser since some of the style
 895       --  checks take place during source scanning and parsing.
 896
 897       when Pragma_Style_Checks => Style_Checks : declare
 898          A  : Node_Id;
 899          S  : String_Id;
 900          C  : Char_Code;
 901          OK : Boolean := True;
 902
 903       begin
 904          --  Two argument case is only for semantics
 905
 906          if Arg_Count = 2 then
 907             null;
 908
 909          else
 910             Check_Arg_Count (1);
 911             Check_No_Identifier (Arg1);
 912             A := Expression (Arg1);
 913
 914             if Nkind (A) = N_String_Literal then
 915                S := Strval (A);
 916
 917                declare
 918                   Slen    : constant Natural := Natural (String_Length (S));
 919                   Options : String (1 .. Slen);
 920                   J       : Natural;
 921                   Ptr     : Natural;
 922
 923                begin
 924                   J := 1;
 925                   loop
 926                      C := Get_String_Char (S, Int (J));
 927
 928                      if not In_Character_Range (C) then
 929                         OK := False;
 930                         Ptr := J;
 931                         exit;
 932
 933                      else
 934                         Options (J) := Get_Character (C);
 935                      end if;
 936
 937                      if J = Slen then
 938                         Set_Style_Check_Options (Options, OK, Ptr);
 939                         exit;
 940
 941                      else
 942                         J := J + 1;
 943                      end if;
 944                   end loop;
 945
 946                   if not OK then
 947                      Error_Msg
 948                        (Style_Msg_Buf (1 .. Style_Msg_Len),
 949                         Sloc (Expression (Arg1)) + Source_Ptr (Ptr));
 950                      raise Error_Resync;
 951                   end if;
 952                end;
 953
 954             elsif Nkind (A) /= N_Identifier then
 955                OK := False;
 956
 957             elsif Chars (A) = Name_All_Checks then
 958                if GNAT_Mode then
 959                   Stylesw.Set_GNAT_Style_Check_Options;
 960                else
 961                   Stylesw.Set_Default_Style_Check_Options;
 962                end if;
 963
 964             elsif Chars (A) = Name_On then
 965                Style_Check := True;
 966
 967             elsif Chars (A) = Name_Off then
 968                Style_Check := False;
 969
 970             else
 971                OK := False;
 972             end if;
 973
 974             if not OK then
 975                Error_Msg ("incorrect argument for pragma%", Sloc (A));
 976                raise Error_Resync;
 977             end if;
 978          end if;
 979       end Style_Checks;
 980
 981       -------------------------
 982       -- Suppress_All (GNAT) --
 983       -------------------------
 984
 985       --  pragma Suppress_All
 986
 987       --  This is a rather odd pragma, because other compilers allow it in
 988       --  strange places. DEC allows it at the end of units, and Rational
 989       --  allows it as a program unit pragma, when it would be more natural
 990       --  if it were a configuration pragma.
 991
 992       --  Since the reason we provide this pragma is for compatibility with
 993       --  these other compilers, we want to accommodate these strange placement
 994       --  rules, and the easiest thing is simply to allow it anywhere in a
 995       --  unit. If this pragma appears anywhere within a unit, then the effect
 996       --  is as though a pragma Suppress (All_Checks) had appeared as the first
 997       --  line of the current file, i.e. as the first configuration pragma in
 998       --  the current unit.
 999
1000       --  To get this effect, we set the flag Has_Pragma_Suppress_All in the
1001       --  compilation unit node for the current source file then in the last
1002       --  stage of parsing a file, if this flag is set, we materialize the
1003       --  Suppress (All_Checks) pragma, marked as not coming from Source.
1004
1005       when Pragma_Suppress_All =>
1006          Set_Has_Pragma_Suppress_All (Cunit (Current_Source_Unit));
1007
1008       ---------------------
1009       -- Warnings (GNAT) --
1010       ---------------------
1011
1012       --  pragma Warnings (On | Off);
1013       --  pragma Warnings (On | Off, LOCAL_NAME);
1014       --  pragma Warnings (static_string_EXPRESSION);
1015       --  pragma Warnings (On | Off, static_string_EXPRESSION);
1016
1017       --  The one argument ON/OFF case is processed by the parser, since it may
1018       --  control parser warnings as well as semantic warnings, and in any case
1019       --  we want to be absolutely sure that the range in the warnings table is
1020       --  set well before any semantic analysis is performed. Note that we
1021       --  ignore this pragma if debug flag -gnatd.i is set.
1022
1023       when Pragma_Warnings =>
1024          if Arg_Count = 1 and then not Debug_Flag_Dot_I then
1025             Check_No_Identifier (Arg1);
1026
1027             declare
1028                Argx : constant Node_Id := Expression (Arg1);
1029             begin
1030                if Nkind (Argx) = N_Identifier then
1031                   if Chars (Argx) = Name_On then
1032                      Set_Warnings_Mode_On (Pragma_Sloc);
1033                   elsif Chars (Argx) = Name_Off then
1034                      Set_Warnings_Mode_Off (Pragma_Sloc);
1035                   end if;
1036                end if;
1037             end;
1038          end if;
1039
1040       -----------------------------
1041       -- Wide_Character_Encoding --
1042       -----------------------------
1043
1044       --  pragma Wide_Character_Encoding (IDENTIFIER | CHARACTER_LITERAL);
1045
1046       --  This is processed by the parser, since the scanner is affected
1047
1048       when Pragma_Wide_Character_Encoding => Wide_Character_Encoding : declare
1049          A : Node_Id;
1050
1051       begin
1052          Check_Arg_Count (1);
1053          Check_No_Identifier (Arg1);
1054          A := Expression (Arg1);
1055
1056          if Nkind (A) = N_Identifier then
1057             Get_Name_String (Chars (A));
1058             Wide_Character_Encoding_Method :=
1059               Get_WC_Encoding_Method (Name_Buffer (1 .. Name_Len));
1060
1061          elsif Nkind (A) = N_Character_Literal then
1062             declare
1063                R : constant Char_Code :=
1064                      Char_Code (UI_To_Int (Char_Literal_Value (A)));
1065             begin
1066                if In_Character_Range (R) then
1067                   Wide_Character_Encoding_Method :=
1068                     Get_WC_Encoding_Method (Get_Character (R));
1069                else
1070                   raise Constraint_Error;
1071                end if;
1072             end;
1073
1074          else
1075             raise Constraint_Error;
1076          end if;
1077
1078          Upper_Half_Encoding :=
1079            Wide_Character_Encoding_Method in
1080              WC_Upper_Half_Encoding_Method;
1081
1082       exception
1083          when Constraint_Error =>
1084             Error_Msg_N ("invalid argument for pragma%", Arg1);
1085       end Wide_Character_Encoding;
1086
1087       -----------------------
1088       -- All Other Pragmas --
1089       -----------------------
1090
1091       --  For all other pragmas, checking and processing is handled
1092       --  entirely in Sem_Prag, and no further checking is done by Par.
1093
1094       when Pragma_Abort_Defer                    |
1095            Pragma_Assertion_Policy               |
1096            Pragma_Assume_No_Invalid_Values       |
1097            Pragma_AST_Entry                      |
1098            Pragma_All_Calls_Remote               |
1099            Pragma_Annotate                       |
1100            Pragma_Assert                         |
1101            Pragma_Asynchronous                   |
1102            Pragma_Atomic                         |
1103            Pragma_Atomic_Components              |
1104            Pragma_Attach_Handler                 |
1105            Pragma_Check                          |
1106            Pragma_Check_Name                     |
1107            Pragma_Check_Policy                   |
1108            Pragma_CIL_Constructor                |
1109            Pragma_Compile_Time_Error             |
1110            Pragma_Compile_Time_Warning           |
1111            Pragma_Compiler_Unit                  |
1112            Pragma_Convention_Identifier          |
1113            Pragma_CPP_Class                      |
1114            Pragma_CPP_Constructor                |
1115            Pragma_CPP_Virtual                    |
1116            Pragma_CPP_Vtable                     |
1117            Pragma_CPU                            |
1118            Pragma_C_Pass_By_Copy                 |
1119            Pragma_Comment                        |
1120            Pragma_Common_Object                  |
1121            Pragma_Complete_Representation        |
1122            Pragma_Complex_Representation         |
1123            Pragma_Component_Alignment            |
1124            Pragma_Controlled                     |
1125            Pragma_Convention                     |
1126            Pragma_Debug_Policy                   |
1127            Pragma_Detect_Blocking                |
1128            Pragma_Default_Storage_Pool           |
1129            Pragma_Disable_Atomic_Synchronization |
1130            Pragma_Discard_Names                  |
1131            Pragma_Dispatching_Domain             |
1132            Pragma_Eliminate                      |
1133            Pragma_Elaborate                      |
1134            Pragma_Elaborate_All                  |
1135            Pragma_Elaborate_Body                 |
1136            Pragma_Elaboration_Checks             |
1137            Pragma_Enable_Atomic_Synchronization  |
1138            Pragma_Export                         |
1139            Pragma_Export_Exception               |
1140            Pragma_Export_Function                |
1141            Pragma_Export_Object                  |
1142            Pragma_Export_Procedure               |
1143            Pragma_Export_Value                   |
1144            Pragma_Export_Valued_Procedure        |
1145            Pragma_Extend_System                  |
1146            Pragma_External                       |
1147            Pragma_External_Name_Casing           |
1148            Pragma_Favor_Top_Level                |
1149            Pragma_Fast_Math                      |
1150            Pragma_Finalize_Storage_Only          |
1151            Pragma_Float_Representation           |
1152            Pragma_Ident                          |
1153            Pragma_Implementation_Defined         |
1154            Pragma_Implemented                    |
1155            Pragma_Implicit_Packing               |
1156            Pragma_Import                         |
1157            Pragma_Import_Exception               |
1158            Pragma_Import_Function                |
1159            Pragma_Import_Object                  |
1160            Pragma_Import_Procedure               |
1161            Pragma_Import_Valued_Procedure        |
1162            Pragma_Independent                    |
1163            Pragma_Independent_Components         |
1164            Pragma_Initialize_Scalars             |
1165            Pragma_Inline                         |
1166            Pragma_Inline_Always                  |
1167            Pragma_Inline_Generic                 |
1168            Pragma_Inspection_Point               |
1169            Pragma_Interface                      |
1170            Pragma_Interface_Name                 |
1171            Pragma_Interrupt_Handler              |
1172            Pragma_Interrupt_State                |
1173            Pragma_Interrupt_Priority             |
1174            Pragma_Invariant                      |
1175            Pragma_Java_Constructor               |
1176            Pragma_Java_Interface                 |
1177            Pragma_Keep_Names                     |
1178            Pragma_License                        |
1179            Pragma_Link_With                      |
1180            Pragma_Linker_Alias                   |
1181            Pragma_Linker_Constructor             |
1182            Pragma_Linker_Destructor              |
1183            Pragma_Linker_Options                 |
1184            Pragma_Linker_Section                 |
1185            Pragma_Locking_Policy                 |
1186            Pragma_Long_Float                     |
1187            Pragma_Machine_Attribute              |
1188            Pragma_Main                           |
1189            Pragma_Main_Storage                   |
1190            Pragma_Memory_Size                    |
1191            Pragma_No_Body                        |
1192            Pragma_No_Return                      |
1193            Pragma_No_Run_Time                    |
1194            Pragma_No_Strict_Aliasing             |
1195            Pragma_Normalize_Scalars              |
1196            Pragma_Obsolescent                    |
1197            Pragma_Ordered                        |
1198            Pragma_Optimize                       |
1199            Pragma_Optimize_Alignment             |
1200            Pragma_Pack                           |
1201            Pragma_Passive                        |
1202            Pragma_Preelaborable_Initialization   |
1203            Pragma_Polling                        |
1204            Pragma_Persistent_BSS                 |
1205            Pragma_Postcondition                  |
1206            Pragma_Precondition                   |
1207            Pragma_Predicate                      |
1208            Pragma_Preelaborate                   |
1209            Pragma_Preelaborate_05                |
1210            Pragma_Priority                       |
1211            Pragma_Priority_Specific_Dispatching  |
1212            Pragma_Profile                        |
1213            Pragma_Profile_Warnings               |
1214            Pragma_Propagate_Exceptions           |
1215            Pragma_Psect_Object                   |
1216            Pragma_Pure                           |
1217            Pragma_Pure_05                        |
1218            Pragma_Pure_12                        |
1219            Pragma_Pure_Function                  |
1220            Pragma_Queuing_Policy                 |
1221            Pragma_Relative_Deadline              |
1222            Pragma_Remote_Access_Type             |
1223            Pragma_Remote_Call_Interface          |
1224            Pragma_Remote_Types                   |
1225            Pragma_Restricted_Run_Time            |
1226            Pragma_Ravenscar                      |
1227            Pragma_Reviewable                     |
1228            Pragma_Share_Generic                  |
1229            Pragma_Shared                         |
1230            Pragma_Shared_Passive                 |
1231            Pragma_Short_Circuit_And_Or           |
1232            Pragma_Short_Descriptors              |
1233            Pragma_Simple_Storage_Pool_Type       |
1234            Pragma_Storage_Size                   |
1235            Pragma_Storage_Unit                   |
1236            Pragma_Static_Elaboration_Desired     |
1237            Pragma_Stream_Convert                 |
1238            Pragma_Subtitle                       |
1239            Pragma_Suppress                       |
1240            Pragma_Suppress_Debug_Info            |
1241            Pragma_Suppress_Exception_Locations   |
1242            Pragma_Suppress_Initialization        |
1243            Pragma_System_Name                    |
1244            Pragma_Task_Dispatching_Policy        |
1245            Pragma_Task_Info                      |
1246            Pragma_Task_Name                      |
1247            Pragma_Task_Storage                   |
1248            Pragma_Test_Case                      |
1249            Pragma_Thread_Local_Storage           |
1250            Pragma_Time_Slice                     |
1251            Pragma_Title                          |
1252            Pragma_Unchecked_Union                |
1253            Pragma_Unimplemented_Unit             |
1254            Pragma_Universal_Aliasing             |
1255            Pragma_Universal_Data                 |
1256            Pragma_Unmodified                     |
1257            Pragma_Unreferenced                   |
1258            Pragma_Unreferenced_Objects           |
1259            Pragma_Unreserve_All_Interrupts       |
1260            Pragma_Unsuppress                     |
1261            Pragma_Use_VADS_Size                  |
1262            Pragma_Volatile                       |
1263            Pragma_Volatile_Components            |
1264            Pragma_Weak_External                  |
1265            Pragma_Validity_Checks                =>
1266          null;
1267
1268       --------------------
1269       -- Unknown_Pragma --
1270       --------------------
1271
1272       --  Should be impossible, since we excluded this case earlier on
1273
1274       when Unknown_Pragma =>
1275          raise Program_Error;
1276
1277    end case;
1278
1279    return Pragma_Node;
1280
1281    --------------------
1282    -- Error Handling --
1283    --------------------
1284
1285 exception
1286    when Error_Resync =>
1287       return Error;
1288
1289 end Prag;