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