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