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