gcc/ada/sem_prag.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ P R A G                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2009, 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 --  This unit contains the semantic processing for all pragmas, both language
  27 --  and implementation defined. For most pragmas, the parser only does the
  28 --  most basic job of checking the syntax, so Sem_Prag also contains the code
  29 --  to complete the syntax checks. Certain pragmas are handled partially or
  30 --  completely by the parser (see Par.Prag for further details).
  31
  32 with Atree;    use Atree;
  33 with Casing;   use Casing;
  34 with Checks;   use Checks;
  35 with Csets;    use Csets;
  36 with Debug;    use Debug;
  37 with Einfo;    use Einfo;
  38 with Elists;   use Elists;
  39 with Errout;   use Errout;
  40 with Exp_Dist; use Exp_Dist;
  41 with Lib;      use Lib;
  42 with Lib.Writ; use Lib.Writ;
  43 with Lib.Xref; use Lib.Xref;
  44 with Namet.Sp; use Namet.Sp;
  45 with Nlists;   use Nlists;
  46 with Nmake;    use Nmake;
  47 with Opt;      use Opt;
  48 with Output;   use Output;
  49 with Restrict; use Restrict;
  50 with Rident;   use Rident;
  51 with Rtsfind;  use Rtsfind;
  52 with Sem;      use Sem;
  53 with Sem_Aux;  use Sem_Aux;
  54 with Sem_Ch3;  use Sem_Ch3;
  55 with Sem_Ch6;  use Sem_Ch6;
  56 with Sem_Ch8;  use Sem_Ch8;
  57 with Sem_Ch12; use Sem_Ch12;
  58 with Sem_Ch13; use Sem_Ch13;
  59 with Sem_Dist; use Sem_Dist;
  60 with Sem_Elim; use Sem_Elim;
  61 with Sem_Eval; use Sem_Eval;
  62 with Sem_Intr; use Sem_Intr;
  63 with Sem_Mech; use Sem_Mech;
  64 with Sem_Res;  use Sem_Res;
  65 with Sem_Type; use Sem_Type;
  66 with Sem_Util; use Sem_Util;
  67 with Sem_VFpt; use Sem_VFpt;
  68 with Sem_Warn; use Sem_Warn;
  69 with Stand;    use Stand;
  70 with Sinfo;    use Sinfo;
  71 with Sinfo.CN; use Sinfo.CN;
  72 with Sinput;   use Sinput;
  73 with Snames;   use Snames;
  74 with Stringt;  use Stringt;
  75 with Stylesw;  use Stylesw;
  76 with Table;
  77 with Targparm; use Targparm;
  78 with Tbuild;   use Tbuild;
  79 with Ttypes;
  80 with Uintp;    use Uintp;
  81 with Uname;    use Uname;
  82 with Urealp;   use Urealp;
  83 with Validsw;  use Validsw;
  84
  85 package body Sem_Prag is
  86
  87    ----------------------------------------------
  88    -- Common Handling of Import-Export Pragmas --
  89    ----------------------------------------------
  90
  91    --  In the following section, a number of Import_xxx and Export_xxx
  92    --  pragmas are defined by GNAT. These are compatible with the DEC
  93    --  pragmas of the same name, and all have the following common
  94    --  form and processing:
  95
  96    --  pragma Export_xxx
  97    --        [Internal                 =>] LOCAL_NAME
  98    --     [, [External                 =>] EXTERNAL_SYMBOL]
  99    --     [, other optional parameters   ]);
 100
 101    --  pragma Import_xxx
 102    --        [Internal                 =>] LOCAL_NAME
 103    --     [, [External                 =>] EXTERNAL_SYMBOL]
 104    --     [, other optional parameters   ]);
 105
 106    --   EXTERNAL_SYMBOL ::=
 107    --     IDENTIFIER
 108    --   | static_string_EXPRESSION
 109
 110    --  The internal LOCAL_NAME designates the entity that is imported or
 111    --  exported, and must refer to an entity in the current declarative
 112    --  part (as required by the rules for LOCAL_NAME).
 113
 114    --  The external linker name is designated by the External parameter if
 115    --  given, or the Internal parameter if not (if there is no External
 116    --  parameter, the External parameter is a copy of the Internal name).
 117
 118    --  If the External parameter is given as a string, then this string is
 119    --  treated as an external name (exactly as though it had been given as an
 120    --  External_Name parameter for a normal Import pragma).
 121
 122    --  If the External parameter is given as an identifier (or there is no
 123    --  External parameter, so that the Internal identifier is used), then
 124    --  the external name is the characters of the identifier, translated
 125    --  to all upper case letters for OpenVMS versions of GNAT, and to all
 126    --  lower case letters for all other versions
 127
 128    --  Note: the external name specified or implied by any of these special
 129    --  Import_xxx or Export_xxx pragmas override an external or link name
 130    --  specified in a previous Import or Export pragma.
 131
 132    --  Note: these and all other DEC-compatible GNAT pragmas allow full use of
 133    --  named notation, following the standard rules for subprogram calls, i.e.
 134    --  parameters can be given in any order if named notation is used, and
 135    --  positional and named notation can be mixed, subject to the rule that all
 136    --  positional parameters must appear first.
 137
 138    --  Note: All these pragmas are implemented exactly following the DEC design
 139    --  and implementation and are intended to be fully compatible with the use
 140    --  of these pragmas in the DEC Ada compiler.
 141
 142    --------------------------------------------
 143    -- Checking for Duplicated External Names --
 144    --------------------------------------------
 145
 146    --  It is suspicious if two separate Export pragmas use the same external
 147    --  name. The following table is used to diagnose this situation so that
 148    --  an appropriate warning can be issued.
 149
 150    --  The Node_Id stored is for the N_String_Literal node created to hold
 151    --  the value of the external name. The Sloc of this node is used to
 152    --  cross-reference the location of the duplication.
 153
 154    package Externals is new Table.Table (
 155      Table_Component_Type => Node_Id,
 156      Table_Index_Type     => Int,
 157      Table_Low_Bound      => 0,
 158      Table_Initial        => 100,
 159      Table_Increment      => 100,
 160      Table_Name           => "Name_Externals");
 161
 162    -------------------------------------
 163    -- Local Subprograms and Variables --
 164    -------------------------------------
 165
 166    function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
 167    --  This routine is used for possible casing adjustment of an explicit
 168    --  external name supplied as a string literal (the node N), according to
 169    --  the casing requirement of Opt.External_Name_Casing. If this is set to
 170    --  As_Is, then the string literal is returned unchanged, but if it is set
 171    --  to Uppercase or Lowercase, then a new string literal with appropriate
 172    --  casing is constructed.
 173
 174    function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
 175    --  If Def_Id refers to a renamed subprogram, then the base subprogram (the
 176    --  original one, following the renaming chain) is returned. Otherwise the
 177    --  entity is returned unchanged. Should be in Einfo???
 178
 179    function Get_Pragma_Arg (Arg : Node_Id) return Node_Id;
 180    --  All the routines that check pragma arguments take either a pragma
 181    --  argument association (in which case the expression of the argument
 182    --  association is checked), or the expression directly. The function
 183    --  Get_Pragma_Arg is a utility used to deal with these two cases. If Arg
 184    --  is a pragma argument association node, then its expression is returned,
 185    --  otherwise Arg is returned unchanged.
 186
 187    procedure rv;
 188    --  This is a dummy function called by the processing for pragma Reviewable.
 189    --  It is there for assisting front end debugging. By placing a Reviewable
 190    --  pragma in the source program, a breakpoint on rv catches this place in
 191    --  the source, allowing convenient stepping to the point of interest.
 192
 193    procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
 194    --  Place semantic information on the argument of an Elaborate/Elaborate_All
 195    --  pragma. Entity name for unit and its parents is taken from item in
 196    --  previous with_clause that mentions the unit.
 197
 198    -------------------------------
 199    -- Adjust_External_Name_Case --
 200    -------------------------------
 201
 202    function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
 203       CC : Char_Code;
 204
 205    begin
 206       --  Adjust case of literal if required
 207
 208       if Opt.External_Name_Exp_Casing = As_Is then
 209          return N;
 210
 211       else
 212          --  Copy existing string
 213
 214          Start_String;
 215
 216          --  Set proper casing
 217
 218          for J in 1 .. String_Length (Strval (N)) loop
 219             CC := Get_String_Char (Strval (N), J);
 220
 221             if Opt.External_Name_Exp_Casing = Uppercase
 222               and then CC >= Get_Char_Code ('a')
 223               and then CC <= Get_Char_Code ('z')
 224             then
 225                Store_String_Char (CC - 32);
 226
 227             elsif Opt.External_Name_Exp_Casing = Lowercase
 228               and then CC >= Get_Char_Code ('A')
 229               and then CC <= Get_Char_Code ('Z')
 230             then
 231                Store_String_Char (CC + 32);
 232
 233             else
 234                Store_String_Char (CC);
 235             end if;
 236          end loop;
 237
 238          return
 239            Make_String_Literal (Sloc (N),
 240              Strval => End_String);
 241       end if;
 242    end Adjust_External_Name_Case;
 243
 244    ------------------------------
 245    -- Analyze_PPC_In_Decl_Part --
 246    ------------------------------
 247
 248    procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
 249       Arg1 : constant Node_Id :=
 250                First (Pragma_Argument_Associations (N));
 251       Arg2 : constant Node_Id := Next (Arg1);
 252
 253    begin
 254       --  Install formals and push subprogram spec onto scope stack so that we
 255       --  can see the formals from the pragma.
 256
 257       Install_Formals (S);
 258       Push_Scope (S);
 259
 260       --  Preanalyze the boolean expression, we treat this as a spec expression
 261       --  (i.e. similar to a default expression).
 262
 263       Preanalyze_Spec_Expression
 264         (Get_Pragma_Arg (Arg1), Standard_Boolean);
 265
 266       --  If there is a message argument, analyze it the same way
 267
 268       if Present (Arg2) then
 269          Preanalyze_Spec_Expression
 270            (Get_Pragma_Arg (Arg2), Standard_String);
 271       end if;
 272
 273       --  Remove the subprogram from the scope stack now that the pre-analysis
 274       --  of the precondition/postcondition is done.
 275
 276       End_Scope;
 277    end Analyze_PPC_In_Decl_Part;
 278
 279    --------------------
 280    -- Analyze_Pragma --
 281    --------------------
 282
 283    procedure Analyze_Pragma (N : Node_Id) is
 284       Loc     : constant Source_Ptr := Sloc (N);
 285       Pname   : constant Name_Id    := Pragma_Name (N);
 286       Prag_Id : Pragma_Id;
 287
 288       Pragma_Exit : exception;
 289       --  This exception is used to exit pragma processing completely. It is
 290       --  used when an error is detected, and no further processing is
 291       --  required. It is also used if an earlier error has left the tree in
 292       --  a state where the pragma should not be processed.
 293
 294       Arg_Count : Nat;
 295       --  Number of pragma argument associations
 296
 297       Arg1 : Node_Id;
 298       Arg2 : Node_Id;
 299       Arg3 : Node_Id;
 300       Arg4 : Node_Id;
 301       --  First four pragma arguments (pragma argument association nodes, or
 302       --  Empty if the corresponding argument does not exist).
 303
 304       type Name_List is array (Natural range <>) of Name_Id;
 305       type Args_List is array (Natural range <>) of Node_Id;
 306       --  Types used for arguments to Check_Arg_Order and Gather_Associations
 307
 308       procedure Ada_2005_Pragma;
 309       --  Called for pragmas defined in Ada 2005, that are not in Ada 95. In
 310       --  Ada 95 mode, these are implementation defined pragmas, so should be
 311       --  caught by the No_Implementation_Pragmas restriction
 312
 313       procedure Check_Ada_83_Warning;
 314       --  Issues a warning message for the current pragma if operating in Ada
 315       --  83 mode (used for language pragmas that are not a standard part of
 316       --  Ada 83). This procedure does not raise Error_Pragma. Also notes use
 317       --  of 95 pragma.
 318
 319       procedure Check_Arg_Count (Required : Nat);
 320       --  Check argument count for pragma is equal to given parameter. If not,
 321       --  then issue an error message and raise Pragma_Exit.
 322
 323       --  Note: all routines whose name is Check_Arg_Is_xxx take an argument
 324       --  Arg which can either be a pragma argument association, in which case
 325       --  the check is applied to the expression of the association or an
 326       --  expression directly.
 327
 328       procedure Check_Arg_Is_External_Name (Arg : Node_Id);
 329       --  Check that an argument has the right form for an EXTERNAL_NAME
 330       --  parameter of an extended import/export pragma. The rule is that the
 331       --  name must be an identifier or string literal (in Ada 83 mode) or a
 332       --  static string expression (in Ada 95 mode).
 333
 334       procedure Check_Arg_Is_Identifier (Arg : Node_Id);
 335       --  Check the specified argument Arg to make sure that it is an
 336       --  identifier. If not give error and raise Pragma_Exit.
 337
 338       procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
 339       --  Check the specified argument Arg to make sure that it is an integer
 340       --  literal. If not give error and raise Pragma_Exit.
 341
 342       procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
 343       --  Check the specified argument Arg to make sure that it has the proper
 344       --  syntactic form for a local name and meets the semantic requirements
 345       --  for a local name. The local name is analyzed as part of the
 346       --  processing for this call. In addition, the local name is required
 347       --  to represent an entity at the library level.
 348
 349       procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
 350       --  Check the specified argument Arg to make sure that it has the proper
 351       --  syntactic form for a local name and meets the semantic requirements
 352       --  for a local name. The local name is analyzed as part of the
 353       --  processing for this call.
 354
 355       procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
 356       --  Check the specified argument Arg to make sure that it is a valid
 357       --  locking policy name. If not give error and raise Pragma_Exit.
 358
 359       procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
 360       procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id);
 361       procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3, N4 : Name_Id);
 362       --  Check the specified argument Arg to make sure that it is an
 363       --  identifier whose name matches either N1 or N2 (or N3 if present).
 364       --  If not then give error and raise Pragma_Exit.
 365
 366       procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
 367       --  Check the specified argument Arg to make sure that it is a valid
 368       --  queuing policy name. If not give error and raise Pragma_Exit.
 369
 370       procedure Check_Arg_Is_Static_Expression
 371         (Arg : Node_Id;
 372          Typ : Entity_Id := Empty);
 373       --  Check the specified argument Arg to make sure that it is a static
 374       --  expression of the given type (i.e. it will be analyzed and resolved
 375       --  using this type, which can be any valid argument to Resolve, e.g.
 376       --  Any_Integer is OK). If not, given error and raise Pragma_Exit. If
 377       --  Typ is left Empty, then any static expression is allowed.
 378
 379       procedure Check_Arg_Is_String_Literal (Arg : Node_Id);
 380       --  Check the specified argument Arg to make sure that it is a string
 381       --  literal. If not give error and raise Pragma_Exit
 382
 383       procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
 384       --  Check the specified argument Arg to make sure that it is a valid task
 385       --  dispatching policy name. If not give error and raise Pragma_Exit.
 386
 387       procedure Check_Arg_Order (Names : Name_List);
 388       --  Checks for an instance of two arguments with identifiers for the
 389       --  current pragma which are not in the sequence indicated by Names,
 390       --  and if so, generates a fatal message about bad order of arguments.
 391
 392       procedure Check_At_Least_N_Arguments (N : Nat);
 393       --  Check there are at least N arguments present
 394
 395       procedure Check_At_Most_N_Arguments (N : Nat);
 396       --  Check there are no more than N arguments present
 397
 398       procedure Check_Component (Comp : Node_Id);
 399       --  Examine Unchecked_Union component for correct use of per-object
 400       --  constrained subtypes, and for restrictions on finalizable components.
 401
 402       procedure Check_Duplicated_Export_Name (Nam : Node_Id);
 403       --  Nam is an N_String_Literal node containing the external name set by
 404       --  an Import or Export pragma (or extended Import or Export pragma).
 405       --  This procedure checks for possible duplications if this is the export
 406       --  case, and if found, issues an appropriate error message.
 407
 408       procedure Check_First_Subtype (Arg : Node_Id);
 409       --  Checks that Arg, whose expression is an entity name referencing a
 410       --  subtype, does not reference a type that is not a first subtype.
 411
 412       procedure Check_In_Main_Program;
 413       --  Common checks for pragmas that appear within a main program
 414       --  (Priority, Main_Storage, Time_Slice, Relative_Deadline).
 415
 416       procedure Check_Interrupt_Or_Attach_Handler;
 417       --  Common processing for first argument of pragma Interrupt_Handler or
 418       --  pragma Attach_Handler.
 419
 420       procedure Check_Is_In_Decl_Part_Or_Package_Spec;
 421       --  Check that pragma appears in a declarative part, or in a package
 422       --  specification, i.e. that it does not occur in a statement sequence
 423       --  in a body.
 424
 425       procedure Check_No_Identifier (Arg : Node_Id);
 426       --  Checks that the given argument does not have an identifier. If
 427       --  an identifier is present, then an error message is issued, and
 428       --  Pragma_Exit is raised.
 429
 430       procedure Check_No_Identifiers;
 431       --  Checks that none of the arguments to the pragma has an identifier.
 432       --  If any argument has an identifier, then an error message is issued,
 433       --  and Pragma_Exit is raised.
 434
 435       procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
 436       --  Checks if the given argument has an identifier, and if so, requires
 437       --  it to match the given identifier name. If there is a non-matching
 438       --  identifier, then an error message is given and Error_Pragmas raised.
 439
 440       procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
 441       --  Checks if the given argument has an identifier, and if so, requires
 442       --  it to match the given identifier name. If there is a non-matching
 443       --  identifier, then an error message is given and Error_Pragmas raised.
 444       --  In this version of the procedure, the identifier name is given as
 445       --  a string with lower case letters.
 446
 447       procedure Check_Precondition_Postcondition (In_Body : out Boolean);
 448       --  Called to process a precondition or postcondition pragma. There are
 449       --  three cases:
 450       --
 451       --    The pragma appears after a subprogram spec
 452       --
 453       --      If the corresponding check is not enabled, the pragma is analyzed
 454       --      but otherwise ignored and control returns with In_Body set False.
 455       --
 456       --      If the check is enabled, then the first step is to analyze the
 457       --      pragma, but this is skipped if the subprogram spec appears within
 458       --      a package specification (because this is the case where we delay
 459       --      analysis till the end of the spec). Then (whether or not it was
 460       --      analyzed), the pragma is chained to the subprogram in question
 461       --      (using Spec_PPC_List and Next_Pragma) and control returns to the
 462       --      caller with In_Body set False.
 463       --
 464       --    The pragma appears at the start of subprogram body declarations
 465       --
 466       --      In this case an immediate return to the caller is made with
 467       --      In_Body set True, and the pragma is NOT analyzed.
 468       --
 469       --    In all other cases, an error message for bad placement is given
 470
 471       procedure Check_Static_Constraint (Constr : Node_Id);
 472       --  Constr is a constraint from an N_Subtype_Indication node from a
 473       --  component constraint in an Unchecked_Union type. This routine checks
 474       --  that the constraint is static as required by the restrictions for
 475       --  Unchecked_Union.
 476
 477       procedure Check_Valid_Configuration_Pragma;
 478       --  Legality checks for placement of a configuration pragma
 479
 480       procedure Check_Valid_Library_Unit_Pragma;
 481       --  Legality checks for library unit pragmas. A special case arises for
 482       --  pragmas in generic instances that come from copies of the original
 483       --  library unit pragmas in the generic templates. In the case of other
 484       --  than library level instantiations these can appear in contexts which
 485       --  would normally be invalid (they only apply to the original template
 486       --  and to library level instantiations), and they are simply ignored,
 487       --  which is implemented by rewriting them as null statements.
 488
 489       procedure Check_Variant (Variant : Node_Id);
 490       --  Check Unchecked_Union variant for lack of nested variants and
 491       --  presence of at least one component.
 492
 493       procedure Error_Pragma (Msg : String);
 494       pragma No_Return (Error_Pragma);
 495       --  Outputs error message for current pragma. The message contains a %
 496       --  that will be replaced with the pragma name, and the flag is placed
 497       --  on the pragma itself. Pragma_Exit is then raised.
 498
 499       procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
 500       pragma No_Return (Error_Pragma_Arg);
 501       --  Outputs error message for current pragma. The message may contain
 502       --  a % that will be replaced with the pragma name. The parameter Arg
 503       --  may either be a pragma argument association, in which case the flag
 504       --  is placed on the expression of this association, or an expression,
 505       --  in which case the flag is placed directly on the expression. The
 506       --  message is placed using Error_Msg_N, so the message may also contain
 507       --  an & insertion character which will reference the given Arg value.
 508       --  After placing the message, Pragma_Exit is raised.
 509
 510       procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
 511       pragma No_Return (Error_Pragma_Arg);
 512       --  Similar to above form of Error_Pragma_Arg except that two messages
 513       --  are provided, the second is a continuation comment starting with \.
 514
 515       procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
 516       pragma No_Return (Error_Pragma_Arg_Ident);
 517       --  Outputs error message for current pragma. The message may contain
 518       --  a % that will be replaced with the pragma name. The parameter Arg
 519       --  must be a pragma argument association with a non-empty identifier
 520       --  (i.e. its Chars field must be set), and the error message is placed
 521       --  on the identifier. The message is placed using Error_Msg_N so
 522       --  the message may also contain an & insertion character which will
 523       --  reference the identifier. After placing the message, Pragma_Exit
 524       --  is raised.
 525
 526       procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
 527       pragma No_Return (Error_Pragma_Ref);
 528       --  Outputs error message for current pragma. The message may contain
 529       --  a % that will be replaced with the pragma name. The parameter Ref
 530       --  must be an entity whose name can be referenced by & and sloc by #.
 531       --  After placing the message, Pragma_Exit is raised.
 532
 533       function Find_Lib_Unit_Name return Entity_Id;
 534       --  Used for a library unit pragma to find the entity to which the
 535       --  library unit pragma applies, returns the entity found.
 536
 537       procedure Find_Program_Unit_Name (Id : Node_Id);
 538       --  If the pragma is a compilation unit pragma, the id must denote the
 539       --  compilation unit in the same compilation, and the pragma must appear
 540       --  in the list of preceding or trailing pragmas. If it is a program
 541       --  unit pragma that is not a compilation unit pragma, then the
 542       --  identifier must be visible.
 543
 544       function Find_Unique_Parameterless_Procedure
 545         (Name : Entity_Id;
 546          Arg  : Node_Id) return Entity_Id;
 547       --  Used for a procedure pragma to find the unique parameterless
 548       --  procedure identified by Name, returns it if it exists, otherwise
 549       --  errors out and uses Arg as the pragma argument for the message.
 550
 551       procedure Gather_Associations
 552         (Names : Name_List;
 553          Args  : out Args_List);
 554       --  This procedure is used to gather the arguments for a pragma that
 555       --  permits arbitrary ordering of parameters using the normal rules
 556       --  for named and positional parameters. The Names argument is a list
 557       --  of Name_Id values that corresponds to the allowed pragma argument
 558       --  association identifiers in order. The result returned in Args is
 559       --  a list of corresponding expressions that are the pragma arguments.
 560       --  Note that this is a list of expressions, not of pragma argument
 561       --  associations (Gather_Associations has completely checked all the
 562       --  optional identifiers when it returns). An entry in Args is Empty
 563       --  on return if the corresponding argument is not present.
 564
 565       procedure GNAT_Pragma;
 566       --  Called for all GNAT defined pragmas to check the relevant restriction
 567       --  (No_Implementation_Pragmas).
 568
 569       function Is_Before_First_Decl
 570         (Pragma_Node : Node_Id;
 571          Decls       : List_Id) return Boolean;
 572       --  Return True if Pragma_Node is before the first declarative item in
 573       --  Decls where Decls is the list of declarative items.
 574
 575       function Is_Configuration_Pragma return Boolean;
 576       --  Determines if the placement of the current pragma is appropriate
 577       --  for a configuration pragma.
 578
 579       function Is_In_Context_Clause return Boolean;
 580       --  Returns True if pragma appears within the context clause of a unit,
 581       --  and False for any other placement (does not generate any messages).
 582
 583       function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
 584       --  Analyzes the argument, and determines if it is a static string
 585       --  expression, returns True if so, False if non-static or not String.
 586
 587       procedure Pragma_Misplaced;
 588       pragma No_Return (Pragma_Misplaced);
 589       --  Issue fatal error message for misplaced pragma
 590
 591       procedure Process_Atomic_Shared_Volatile;
 592       --  Common processing for pragmas Atomic, Shared, Volatile. Note that
 593       --  Shared is an obsolete Ada 83 pragma, treated as being identical
 594       --  in effect to pragma Atomic.
 595
 596       procedure Process_Compile_Time_Warning_Or_Error;
 597       --  Common processing for Compile_Time_Error and Compile_Time_Warning
 598
 599       procedure Process_Convention
 600         (C : out Convention_Id; Ent : out Entity_Id);
 601       --  Common processing for Convention, Interface, Import and Export.
 602       --  Checks first two arguments of pragma, and sets the appropriate
 603       --  convention value in the specified entity or entities. On return
 604       --  C is the convention, Ent is the referenced entity.
 605
 606       procedure Process_Extended_Import_Export_Exception_Pragma
 607         (Arg_Internal : Node_Id;
 608          Arg_External : Node_Id;
 609          Arg_Form     : Node_Id;
 610          Arg_Code     : Node_Id);
 611       --  Common processing for the pragmas Import/Export_Exception. The three
 612       --  arguments correspond to the three named parameters of the pragma. An
 613       --  argument is empty if the corresponding parameter is not present in
 614       --  the pragma.
 615
 616       procedure Process_Extended_Import_Export_Object_Pragma
 617         (Arg_Internal : Node_Id;
 618          Arg_External : Node_Id;
 619          Arg_Size     : Node_Id);
 620       --  Common processing for the pragmas Import/Export_Object. The three
 621       --  arguments correspond to the three named parameters of the pragmas. An
 622       --  argument is empty if the corresponding parameter is not present in
 623       --  the pragma.
 624
 625       procedure Process_Extended_Import_Export_Internal_Arg
 626         (Arg_Internal : Node_Id := Empty);
 627       --  Common processing for all extended Import and Export pragmas. The
 628       --  argument is the pragma parameter for the Internal argument. If
 629       --  Arg_Internal is empty or inappropriate, an error message is posted.
 630       --  Otherwise, on normal return, the Entity_Field of Arg_Internal is
 631       --  set to identify the referenced entity.
 632
 633       procedure Process_Extended_Import_Export_Subprogram_Pragma
 634         (Arg_Internal                 : Node_Id;
 635          Arg_External                 : Node_Id;
 636          Arg_Parameter_Types          : Node_Id;
 637          Arg_Result_Type              : Node_Id := Empty;
 638          Arg_Mechanism                : Node_Id;
 639          Arg_Result_Mechanism         : Node_Id := Empty;
 640          Arg_First_Optional_Parameter : Node_Id := Empty);
 641       --  Common processing for all extended Import and Export pragmas applying
 642       --  to subprograms. The caller omits any arguments that do not apply to
 643       --  the pragma in question (for example, Arg_Result_Type can be non-Empty
 644       --  only in the Import_Function and Export_Function cases). The argument
 645       --  names correspond to the allowed pragma association identifiers.
 646
 647       procedure Process_Generic_List;
 648       --  Common processing for Share_Generic and Inline_Generic
 649
 650       procedure Process_Import_Or_Interface;
 651       --  Common processing for Import of Interface
 652
 653       procedure Process_Inline (Active : Boolean);
 654       --  Common processing for Inline and Inline_Always. The parameter
 655       --  indicates if the inline pragma is active, i.e. if it should actually
 656       --  cause inlining to occur.
 657
 658       procedure Process_Interface_Name
 659         (Subprogram_Def : Entity_Id;
 660          Ext_Arg        : Node_Id;
 661          Link_Arg       : Node_Id);
 662       --  Given the last two arguments of pragma Import, pragma Export, or
 663       --  pragma Interface_Name, performs validity checks and sets the
 664       --  Interface_Name field of the given subprogram entity to the
 665       --  appropriate external or link name, depending on the arguments given.
 666       --  Ext_Arg is always present, but Link_Arg may be missing. Note that
 667       --  Ext_Arg may represent the Link_Name if Link_Arg is missing, and
 668       --  appropriate named notation is used for Ext_Arg. If neither Ext_Arg
 669       --  nor Link_Arg is present, the interface name is set to the default
 670       --  from the subprogram name.
 671
 672       procedure Process_Interrupt_Or_Attach_Handler;
 673       --  Common processing for Interrupt and Attach_Handler pragmas
 674
 675       procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
 676       --  Common processing for Restrictions and Restriction_Warnings pragmas.
 677       --  Warn is True for Restriction_Warnings, or for Restrictions if the
 678       --  flag Treat_Restrictions_As_Warnings is set, and False if this flag
 679       --  is not set in the Restrictions case.
 680
 681       procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
 682       --  Common processing for Suppress and Unsuppress. The boolean parameter
 683       --  Suppress_Case is True for the Suppress case, and False for the
 684       --  Unsuppress case.
 685
 686       procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
 687       --  This procedure sets the Is_Exported flag for the given entity,
 688       --  checking that the entity was not previously imported. Arg is
 689       --  the argument that specified the entity. A check is also made
 690       --  for exporting inappropriate entities.
 691
 692       procedure Set_Extended_Import_Export_External_Name
 693         (Internal_Ent : Entity_Id;
 694          Arg_External : Node_Id);
 695       --  Common processing for all extended import export pragmas. The first
 696       --  argument, Internal_Ent, is the internal entity, which has already
 697       --  been checked for validity by the caller. Arg_External is from the
 698       --  Import or Export pragma, and may be null if no External parameter
 699       --  was present. If Arg_External is present and is a non-null string
 700       --  (a null string is treated as the default), then the Interface_Name
 701       --  field of Internal_Ent is set appropriately.
 702
 703       procedure Set_Imported (E : Entity_Id);
 704       --  This procedure sets the Is_Imported flag for the given entity,
 705       --  checking that it is not previously exported or imported.
 706
 707       procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
 708       --  Mech is a parameter passing mechanism (see Import_Function syntax
 709       --  for MECHANISM_NAME). This routine checks that the mechanism argument
 710       --  has the right form, and if not issues an error message. If the
 711       --  argument has the right form then the Mechanism field of Ent is
 712       --  set appropriately.
 713
 714       procedure Set_Ravenscar_Profile (N : Node_Id);
 715       --  Activate the set of configuration pragmas and restrictions that make
 716       --  up the Ravenscar Profile. N is the corresponding pragma node, which
 717       --  is used for error messages on any constructs that violate the
 718       --  profile.
 719
 720       ---------------------
 721       -- Ada_2005_Pragma --
 722       ---------------------
 723
 724       procedure Ada_2005_Pragma is
 725       begin
 726          if Ada_Version <= Ada_95 then
 727             Check_Restriction (No_Implementation_Pragmas, N);
 728          end if;
 729       end Ada_2005_Pragma;
 730
 731       --------------------------
 732       -- Check_Ada_83_Warning --
 733       --------------------------
 734
 735       procedure Check_Ada_83_Warning is
 736       begin
 737          if Ada_Version = Ada_83 and then Comes_From_Source (N) then
 738             Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
 739          end if;
 740       end Check_Ada_83_Warning;
 741
 742       ---------------------
 743       -- Check_Arg_Count --
 744       ---------------------
 745
 746       procedure Check_Arg_Count (Required : Nat) is
 747       begin
 748          if Arg_Count /= Required then
 749             Error_Pragma ("wrong number of arguments for pragma%");
 750          end if;
 751       end Check_Arg_Count;
 752
 753       --------------------------------
 754       -- Check_Arg_Is_External_Name --
 755       --------------------------------
 756
 757       procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
 758          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 759
 760       begin
 761          if Nkind (Argx) = N_Identifier then
 762             return;
 763
 764          else
 765             Analyze_And_Resolve (Argx, Standard_String);
 766
 767             if Is_OK_Static_Expression (Argx) then
 768                return;
 769
 770             elsif Etype (Argx) = Any_Type then
 771                raise Pragma_Exit;
 772
 773             --  An interesting special case, if we have a string literal and
 774             --  we are in Ada 83 mode, then we allow it even though it will
 775             --  not be flagged as static. This allows expected Ada 83 mode
 776             --  use of external names which are string literals, even though
 777             --  technically these are not static in Ada 83.
 778
 779             elsif Ada_Version = Ada_83
 780               and then Nkind (Argx) = N_String_Literal
 781             then
 782                return;
 783
 784             --  Static expression that raises Constraint_Error. This has
 785             --  already been flagged, so just exit from pragma processing.
 786
 787             elsif Is_Static_Expression (Argx) then
 788                raise Pragma_Exit;
 789
 790             --  Here we have a real error (non-static expression)
 791
 792             else
 793                Error_Msg_Name_1 := Pname;
 794                Flag_Non_Static_Expr
 795                  ("argument for pragma% must be a identifier or " &
 796                   "static string expression!", Argx);
 797                raise Pragma_Exit;
 798             end if;
 799          end if;
 800       end Check_Arg_Is_External_Name;
 801
 802       -----------------------------
 803       -- Check_Arg_Is_Identifier --
 804       -----------------------------
 805
 806       procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
 807          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 808       begin
 809          if Nkind (Argx) /= N_Identifier then
 810             Error_Pragma_Arg
 811               ("argument for pragma% must be identifier", Argx);
 812          end if;
 813       end Check_Arg_Is_Identifier;
 814
 815       ----------------------------------
 816       -- Check_Arg_Is_Integer_Literal --
 817       ----------------------------------
 818
 819       procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
 820          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 821       begin
 822          if Nkind (Argx) /= N_Integer_Literal then
 823             Error_Pragma_Arg
 824               ("argument for pragma% must be integer literal", Argx);
 825          end if;
 826       end Check_Arg_Is_Integer_Literal;
 827
 828       -------------------------------------------
 829       -- Check_Arg_Is_Library_Level_Local_Name --
 830       -------------------------------------------
 831
 832       --  LOCAL_NAME ::=
 833       --    DIRECT_NAME
 834       --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
 835       --  | library_unit_NAME
 836
 837       procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
 838       begin
 839          Check_Arg_Is_Local_Name (Arg);
 840
 841          if not Is_Library_Level_Entity (Entity (Expression (Arg)))
 842            and then Comes_From_Source (N)
 843          then
 844             Error_Pragma_Arg
 845               ("argument for pragma% must be library level entity", Arg);
 846          end if;
 847       end Check_Arg_Is_Library_Level_Local_Name;
 848
 849       -----------------------------
 850       -- Check_Arg_Is_Local_Name --
 851       -----------------------------
 852
 853       --  LOCAL_NAME ::=
 854       --    DIRECT_NAME
 855       --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
 856       --  | library_unit_NAME
 857
 858       procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
 859          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 860
 861       begin
 862          Analyze (Argx);
 863
 864          if Nkind (Argx) not in N_Direct_Name
 865            and then (Nkind (Argx) /= N_Attribute_Reference
 866                       or else Present (Expressions (Argx))
 867                       or else Nkind (Prefix (Argx)) /= N_Identifier)
 868            and then (not Is_Entity_Name (Argx)
 869                       or else not Is_Compilation_Unit (Entity (Argx)))
 870          then
 871             Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
 872          end if;
 873
 874          if Is_Entity_Name (Argx)
 875            and then Scope (Entity (Argx)) /= Current_Scope
 876          then
 877             Error_Pragma_Arg
 878               ("pragma% argument must be in same declarative part", Arg);
 879          end if;
 880       end Check_Arg_Is_Local_Name;
 881
 882       ---------------------------------
 883       -- Check_Arg_Is_Locking_Policy --
 884       ---------------------------------
 885
 886       procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
 887          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 888
 889       begin
 890          Check_Arg_Is_Identifier (Argx);
 891
 892          if not Is_Locking_Policy_Name (Chars (Argx)) then
 893             Error_Pragma_Arg
 894               ("& is not a valid locking policy name", Argx);
 895          end if;
 896       end Check_Arg_Is_Locking_Policy;
 897
 898       -------------------------
 899       -- Check_Arg_Is_One_Of --
 900       -------------------------
 901
 902       procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
 903          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 904
 905       begin
 906          Check_Arg_Is_Identifier (Argx);
 907
 908          if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then
 909             Error_Msg_Name_2 := N1;
 910             Error_Msg_Name_3 := N2;
 911             Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
 912          end if;
 913       end Check_Arg_Is_One_Of;
 914
 915       procedure Check_Arg_Is_One_Of
 916         (Arg        : Node_Id;
 917          N1, N2, N3 : Name_Id)
 918       is
 919          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 920
 921       begin
 922          Check_Arg_Is_Identifier (Argx);
 923
 924          if Chars (Argx) /= N1
 925            and then Chars (Argx) /= N2
 926            and then Chars (Argx) /= N3
 927          then
 928             Error_Pragma_Arg ("invalid argument for pragma%", Argx);
 929          end if;
 930       end Check_Arg_Is_One_Of;
 931
 932       procedure Check_Arg_Is_One_Of
 933         (Arg            : Node_Id;
 934          N1, N2, N3, N4 : Name_Id)
 935       is
 936          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 937
 938       begin
 939          Check_Arg_Is_Identifier (Argx);
 940
 941          if Chars (Argx) /= N1
 942            and then Chars (Argx) /= N2
 943            and then Chars (Argx) /= N3
 944            and then Chars (Argx) /= N4
 945          then
 946             Error_Pragma_Arg ("invalid argument for pragma%", Argx);
 947          end if;
 948       end Check_Arg_Is_One_Of;
 949
 950       ---------------------------------
 951       -- Check_Arg_Is_Queuing_Policy --
 952       ---------------------------------
 953
 954       procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
 955          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 956
 957       begin
 958          Check_Arg_Is_Identifier (Argx);
 959
 960          if not Is_Queuing_Policy_Name (Chars (Argx)) then
 961             Error_Pragma_Arg
 962               ("& is not a valid queuing policy name", Argx);
 963          end if;
 964       end Check_Arg_Is_Queuing_Policy;
 965
 966       ------------------------------------
 967       -- Check_Arg_Is_Static_Expression --
 968       ------------------------------------
 969
 970       procedure Check_Arg_Is_Static_Expression
 971         (Arg : Node_Id;
 972          Typ : Entity_Id := Empty)
 973       is
 974          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 975
 976       begin
 977          if Present (Typ) then
 978             Analyze_And_Resolve (Argx, Typ);
 979          else
 980             Analyze_And_Resolve (Argx);
 981          end if;
 982
 983          if Is_OK_Static_Expression (Argx) then
 984             return;
 985
 986          elsif Etype (Argx) = Any_Type then
 987             raise Pragma_Exit;
 988
 989          --  An interesting special case, if we have a string literal and we
 990          --  are in Ada 83 mode, then we allow it even though it will not be
 991          --  flagged as static. This allows the use of Ada 95 pragmas like
 992          --  Import in Ada 83 mode. They will of course be flagged with
 993          --  warnings as usual, but will not cause errors.
 994
 995          elsif Ada_Version = Ada_83
 996            and then Nkind (Argx) = N_String_Literal
 997          then
 998             return;
 999
1000          --  Static expression that raises Constraint_Error. This has already
1001          --  been flagged, so just exit from pragma processing.
1002
1003          elsif Is_Static_Expression (Argx) then
1004             raise Pragma_Exit;
1005
1006          --  Finally, we have a real error
1007
1008          else
1009             Error_Msg_Name_1 := Pname;
1010             Flag_Non_Static_Expr
1011               ("argument for pragma% must be a static expression!", Argx);
1012             raise Pragma_Exit;
1013          end if;
1014       end Check_Arg_Is_Static_Expression;
1015
1016       ---------------------------------
1017       -- Check_Arg_Is_String_Literal --
1018       ---------------------------------
1019
1020       procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
1021          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1022       begin
1023          if Nkind (Argx) /= N_String_Literal then
1024             Error_Pragma_Arg
1025               ("argument for pragma% must be string literal", Argx);
1026          end if;
1027       end Check_Arg_Is_String_Literal;
1028
1029       ------------------------------------------
1030       -- Check_Arg_Is_Task_Dispatching_Policy --
1031       ------------------------------------------
1032
1033       procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
1034          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1035
1036       begin
1037          Check_Arg_Is_Identifier (Argx);
1038
1039          if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
1040             Error_Pragma_Arg
1041               ("& is not a valid task dispatching policy name", Argx);
1042          end if;
1043       end Check_Arg_Is_Task_Dispatching_Policy;
1044
1045       ---------------------
1046       -- Check_Arg_Order --
1047       ---------------------
1048
1049       procedure Check_Arg_Order (Names : Name_List) is
1050          Arg : Node_Id;
1051
1052          Highest_So_Far : Natural := 0;
1053          --  Highest index in Names seen do far
1054
1055       begin
1056          Arg := Arg1;
1057          for J in 1 .. Arg_Count loop
1058             if Chars (Arg) /= No_Name then
1059                for K in Names'Range loop
1060                   if Chars (Arg) = Names (K) then
1061                      if K < Highest_So_Far then
1062                         Error_Msg_Name_1 := Pname;
1063                         Error_Msg_N
1064                           ("parameters out of order for pragma%", Arg);
1065                         Error_Msg_Name_1 := Names (K);
1066                         Error_Msg_Name_2 := Names (Highest_So_Far);
1067                         Error_Msg_N ("\% must appear before %", Arg);
1068                         raise Pragma_Exit;
1069
1070                      else
1071                         Highest_So_Far := K;
1072                      end if;
1073                   end if;
1074                end loop;
1075             end if;
1076
1077             Arg := Next (Arg);
1078          end loop;
1079       end Check_Arg_Order;
1080
1081       --------------------------------
1082       -- Check_At_Least_N_Arguments --
1083       --------------------------------
1084
1085       procedure Check_At_Least_N_Arguments (N : Nat) is
1086       begin
1087          if Arg_Count < N then
1088             Error_Pragma ("too few arguments for pragma%");
1089          end if;
1090       end Check_At_Least_N_Arguments;
1091
1092       -------------------------------
1093       -- Check_At_Most_N_Arguments --
1094       -------------------------------
1095
1096       procedure Check_At_Most_N_Arguments (N : Nat) is
1097          Arg : Node_Id;
1098       begin
1099          if Arg_Count > N then
1100             Arg := Arg1;
1101             for J in 1 .. N loop
1102                Next (Arg);
1103                Error_Pragma_Arg ("too many arguments for pragma%", Arg);
1104             end loop;
1105          end if;
1106       end Check_At_Most_N_Arguments;
1107
1108       ---------------------
1109       -- Check_Component --
1110       ---------------------
1111
1112       procedure Check_Component (Comp : Node_Id) is
1113       begin
1114          if Nkind (Comp) = N_Component_Declaration then
1115             declare
1116                Sindic : constant Node_Id :=
1117                           Subtype_Indication (Component_Definition (Comp));
1118                Typ    : constant Entity_Id :=
1119                           Etype (Defining_Identifier (Comp));
1120             begin
1121                if Nkind (Sindic) = N_Subtype_Indication then
1122
1123                   --  Ada 2005 (AI-216): If a component subtype is subject to
1124                   --  a per-object constraint, then the component type shall
1125                   --  be an Unchecked_Union.
1126
1127                   if Has_Per_Object_Constraint (Defining_Identifier (Comp))
1128                     and then
1129                       not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
1130                   then
1131                      Error_Msg_N ("component subtype subject to per-object" &
1132                        " constraint must be an Unchecked_Union", Comp);
1133                   end if;
1134                end if;
1135
1136                if Is_Controlled (Typ) then
1137                   Error_Msg_N
1138                    ("component of unchecked union cannot be controlled", Comp);
1139
1140                elsif Has_Task (Typ) then
1141                   Error_Msg_N
1142                    ("component of unchecked union cannot have tasks", Comp);
1143                end if;
1144             end;
1145          end if;
1146       end Check_Component;
1147
1148       ----------------------------------
1149       -- Check_Duplicated_Export_Name --
1150       ----------------------------------
1151
1152       procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
1153          String_Val : constant String_Id := Strval (Nam);
1154
1155       begin
1156          --  We are only interested in the export case, and in the case of
1157          --  generics, it is the instance, not the template, that is the
1158          --  problem (the template will generate a warning in any case).
1159
1160          if not Inside_A_Generic
1161            and then (Prag_Id = Pragma_Export
1162                        or else
1163                      Prag_Id = Pragma_Export_Procedure
1164                        or else
1165                      Prag_Id = Pragma_Export_Valued_Procedure
1166                        or else
1167                      Prag_Id = Pragma_Export_Function)
1168          then
1169             for J in Externals.First .. Externals.Last loop
1170                if String_Equal (String_Val, Strval (Externals.Table (J))) then
1171                   Error_Msg_Sloc := Sloc (Externals.Table (J));
1172                   Error_Msg_N ("external name duplicates name given#", Nam);
1173                   exit;
1174                end if;
1175             end loop;
1176
1177             Externals.Append (Nam);
1178          end if;
1179       end Check_Duplicated_Export_Name;
1180
1181       -------------------------
1182       -- Check_First_Subtype --
1183       -------------------------
1184
1185       procedure Check_First_Subtype (Arg : Node_Id) is
1186          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1187       begin
1188          if not Is_First_Subtype (Entity (Argx)) then
1189             Error_Pragma_Arg
1190               ("pragma% cannot apply to subtype", Argx);
1191          end if;
1192       end Check_First_Subtype;
1193
1194       ---------------------------
1195       -- Check_In_Main_Program --
1196       ---------------------------
1197
1198       procedure Check_In_Main_Program is
1199          P : constant Node_Id := Parent (N);
1200
1201       begin
1202          --  Must be at in subprogram body
1203
1204          if Nkind (P) /= N_Subprogram_Body then
1205             Error_Pragma ("% pragma allowed only in subprogram");
1206
1207          --  Otherwise warn if obviously not main program
1208
1209          elsif Present (Parameter_Specifications (Specification (P)))
1210            or else not Is_Compilation_Unit (Defining_Entity (P))
1211          then
1212             Error_Msg_Name_1 := Pname;
1213             Error_Msg_N
1214               ("?pragma% is only effective in main program", N);
1215          end if;
1216       end Check_In_Main_Program;
1217
1218       ---------------------------------------
1219       -- Check_Interrupt_Or_Attach_Handler --
1220       ---------------------------------------
1221
1222       procedure Check_Interrupt_Or_Attach_Handler is
1223          Arg1_X : constant Node_Id := Expression (Arg1);
1224          Handler_Proc, Proc_Scope : Entity_Id;
1225
1226       begin
1227          Analyze (Arg1_X);
1228
1229          if Prag_Id = Pragma_Interrupt_Handler then
1230             Check_Restriction (No_Dynamic_Attachment, N);
1231          end if;
1232
1233          Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
1234          Proc_Scope := Scope (Handler_Proc);
1235
1236          --  On AAMP only, a pragma Interrupt_Handler is supported for
1237          --  nonprotected parameterless procedures.
1238
1239          if not AAMP_On_Target
1240            or else Prag_Id = Pragma_Attach_Handler
1241          then
1242             if Ekind (Proc_Scope) /= E_Protected_Type then
1243                Error_Pragma_Arg
1244                  ("argument of pragma% must be protected procedure", Arg1);
1245             end if;
1246
1247             if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
1248                Error_Pragma ("pragma% must be in protected definition");
1249             end if;
1250          end if;
1251
1252          if not Is_Library_Level_Entity (Proc_Scope)
1253            or else (AAMP_On_Target
1254                      and then not Is_Library_Level_Entity (Handler_Proc))
1255          then
1256             Error_Pragma_Arg
1257               ("argument for pragma% must be library level entity", Arg1);
1258          end if;
1259       end Check_Interrupt_Or_Attach_Handler;
1260
1261       -------------------------------------------
1262       -- Check_Is_In_Decl_Part_Or_Package_Spec --
1263       -------------------------------------------
1264
1265       procedure Check_Is_In_Decl_Part_Or_Package_Spec is
1266          P : Node_Id;
1267
1268       begin
1269          P := Parent (N);
1270          loop
1271             if No (P) then
1272                exit;
1273
1274             elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
1275                exit;
1276
1277             elsif Nkind_In (P, N_Package_Specification,
1278                                N_Block_Statement)
1279             then
1280                return;
1281
1282             --  Note: the following tests seem a little peculiar, because
1283             --  they test for bodies, but if we were in the statement part
1284             --  of the body, we would already have hit the handled statement
1285             --  sequence, so the only way we get here is by being in the
1286             --  declarative part of the body.
1287
1288             elsif Nkind_In (P, N_Subprogram_Body,
1289                                N_Package_Body,
1290                                N_Task_Body,
1291                                N_Entry_Body)
1292             then
1293                return;
1294             end if;
1295
1296             P := Parent (P);
1297          end loop;
1298
1299          Error_Pragma ("pragma% is not in declarative part or package spec");
1300       end Check_Is_In_Decl_Part_Or_Package_Spec;
1301
1302       -------------------------
1303       -- Check_No_Identifier --
1304       -------------------------
1305
1306       procedure Check_No_Identifier (Arg : Node_Id) is
1307       begin
1308          if Chars (Arg) /= No_Name then
1309             Error_Pragma_Arg_Ident
1310               ("pragma% does not permit identifier& here", Arg);
1311          end if;
1312       end Check_No_Identifier;
1313
1314       --------------------------
1315       -- Check_No_Identifiers --
1316       --------------------------
1317
1318       procedure Check_No_Identifiers is
1319          Arg_Node : Node_Id;
1320       begin
1321          if Arg_Count > 0 then
1322             Arg_Node := Arg1;
1323             while Present (Arg_Node) loop
1324                Check_No_Identifier (Arg_Node);
1325                Next (Arg_Node);
1326             end loop;
1327          end if;
1328       end Check_No_Identifiers;
1329
1330       -------------------------------
1331       -- Check_Optional_Identifier --
1332       -------------------------------
1333
1334       procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
1335       begin
1336          if Present (Arg) and then Chars (Arg) /= No_Name then
1337             if Chars (Arg) /= Id then
1338                Error_Msg_Name_1 := Pname;
1339                Error_Msg_Name_2 := Id;
1340                Error_Msg_N ("pragma% argument expects identifier%", Arg);
1341                raise Pragma_Exit;
1342             end if;
1343          end if;
1344       end Check_Optional_Identifier;
1345
1346       procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
1347       begin
1348          Name_Buffer (1 .. Id'Length) := Id;
1349          Name_Len := Id'Length;
1350          Check_Optional_Identifier (Arg, Name_Find);
1351       end Check_Optional_Identifier;
1352
1353       --------------------------------------
1354       -- Check_Precondition_Postcondition --
1355       --------------------------------------
1356
1357       procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
1358          P  : Node_Id;
1359          PO : Node_Id;
1360
1361          procedure Chain_PPC (PO : Node_Id);
1362          --  If PO is a subprogram declaration node (or a generic subprogram
1363          --  declaration node), then the precondition/postcondition applies
1364          --  to this subprogram and the processing for the pragma is completed.
1365          --  Otherwise the pragma is misplaced.
1366
1367          ---------------
1368          -- Chain_PPC --
1369          ---------------
1370
1371          procedure Chain_PPC (PO : Node_Id) is
1372             S : Node_Id;
1373
1374          begin
1375             if not Nkind_In (PO, N_Subprogram_Declaration,
1376                                  N_Generic_Subprogram_Declaration)
1377             then
1378                Pragma_Misplaced;
1379             end if;
1380
1381             --  Here if we have subprogram or generic subprogram declaration
1382
1383             S := Defining_Unit_Name (Specification (PO));
1384
1385             --  Analyze the pragma unless it appears within a package spec,
1386             --  which is the case where we delay the analysis of the PPC until
1387             --  the end of the package declarations (for details, see
1388             --  Analyze_Package_Specification.Analyze_PPCs).
1389
1390             if not Is_Package_Or_Generic_Package (Scope (S)) then
1391                Analyze_PPC_In_Decl_Part (N, S);
1392             end if;
1393
1394             --  Chain spec PPC pragma to list for subprogram
1395
1396             Set_Next_Pragma (N, Spec_PPC_List (S));
1397             Set_Spec_PPC_List (S, N);
1398
1399             --  Return indicating spec case
1400
1401             In_Body := False;
1402             return;
1403          end Chain_PPC;
1404
1405          --  Start of processing for Check_Precondition_Postcondition
1406
1407       begin
1408          if not Is_List_Member (N) then
1409             Pragma_Misplaced;
1410          end if;
1411
1412          --  Record whether pragma is enabled
1413
1414          Set_PPC_Enabled (N, Check_Enabled (Pname));
1415
1416          --  If we are within an inlined body, the legality of the pragma
1417          --  has been checked already.
1418
1419          if In_Inlined_Body then
1420             In_Body := True;
1421             return;
1422          end if;
1423
1424          --  Search prior declarations
1425
1426          P := N;
1427          while Present (Prev (P)) loop
1428             P := Prev (P);
1429
1430             --  If the previous node is a generic subprogram, do not go to to
1431             --  the original node, which is the unanalyzed tree: we need to
1432             --  attach the pre/postconditions to the analyzed version at this
1433             --  point. They get propagated to the original tree when analyzing
1434             --  the corresponding body.
1435
1436             if Nkind (P) not in N_Generic_Declaration then
1437                PO := Original_Node (P);
1438             else
1439                PO := P;
1440             end if;
1441
1442             --  Skip past prior pragma
1443
1444             if Nkind (PO) = N_Pragma then
1445                null;
1446
1447             --  Skip stuff not coming from source
1448
1449             elsif not Comes_From_Source (PO) then
1450                null;
1451
1452             --  Only remaining possibility is subprogram declaration
1453
1454             else
1455                Chain_PPC (PO);
1456                return;
1457             end if;
1458          end loop;
1459
1460          --  If we fall through loop, pragma is at start of list, so see if it
1461          --  is at the start of declarations of a subprogram body.
1462
1463          if Nkind (Parent (N)) = N_Subprogram_Body
1464            and then List_Containing (N) = Declarations (Parent (N))
1465          then
1466             if Operating_Mode /= Generate_Code
1467               or else Inside_A_Generic
1468             then
1469
1470                --  Analyze expression in pragma, for correctness
1471                --  and for ASIS use.
1472
1473                Preanalyze_Spec_Expression
1474                  (Get_Pragma_Arg (Arg1), Standard_Boolean);
1475             end if;
1476
1477             In_Body := True;
1478             return;
1479
1480          --  See if it is in the pragmas after a library level subprogram
1481
1482          elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then
1483             Chain_PPC (Unit (Parent (Parent (N))));
1484             return;
1485          end if;
1486
1487          --  If we fall through, pragma was misplaced
1488
1489          Pragma_Misplaced;
1490       end Check_Precondition_Postcondition;
1491
1492       -----------------------------
1493       -- Check_Static_Constraint --
1494       -----------------------------
1495
1496       --  Note: for convenience in writing this procedure, in addition to
1497       --  the officially (i.e. by spec) allowed argument which is always a
1498       --  constraint, it also allows ranges and discriminant associations.
1499       --  Above is not clear ???
1500
1501       procedure Check_Static_Constraint (Constr : Node_Id) is
1502
1503          procedure Require_Static (E : Node_Id);
1504          --  Require given expression to be static expression
1505
1506          --------------------
1507          -- Require_Static --
1508          --------------------
1509
1510          procedure Require_Static (E : Node_Id) is
1511          begin
1512             if not Is_OK_Static_Expression (E) then
1513                Flag_Non_Static_Expr
1514                  ("non-static constraint not allowed in Unchecked_Union!", E);
1515                raise Pragma_Exit;
1516             end if;
1517          end Require_Static;
1518
1519       --  Start of processing for Check_Static_Constraint
1520
1521       begin
1522          case Nkind (Constr) is
1523             when N_Discriminant_Association =>
1524                Require_Static (Expression (Constr));
1525
1526             when N_Range =>
1527                Require_Static (Low_Bound (Constr));
1528                Require_Static (High_Bound (Constr));
1529
1530             when N_Attribute_Reference =>
1531                Require_Static (Type_Low_Bound  (Etype (Prefix (Constr))));
1532                Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
1533
1534             when N_Range_Constraint =>
1535                Check_Static_Constraint (Range_Expression (Constr));
1536
1537             when N_Index_Or_Discriminant_Constraint =>
1538                declare
1539                   IDC : Entity_Id;
1540                begin
1541                   IDC := First (Constraints (Constr));
1542                   while Present (IDC) loop
1543                      Check_Static_Constraint (IDC);
1544                      Next (IDC);
1545                   end loop;
1546                end;
1547
1548             when others =>
1549                null;
1550          end case;
1551       end Check_Static_Constraint;
1552
1553       --------------------------------------
1554       -- Check_Valid_Configuration_Pragma --
1555       --------------------------------------
1556
1557       --  A configuration pragma must appear in the context clause of a
1558       --  compilation unit, and only other pragmas may precede it. Note that
1559       --  the test also allows use in a configuration pragma file.
1560
1561       procedure Check_Valid_Configuration_Pragma is
1562       begin
1563          if not Is_Configuration_Pragma then
1564             Error_Pragma ("incorrect placement for configuration pragma%");
1565          end if;
1566       end Check_Valid_Configuration_Pragma;
1567
1568       -------------------------------------
1569       -- Check_Valid_Library_Unit_Pragma --
1570       -------------------------------------
1571
1572       procedure Check_Valid_Library_Unit_Pragma is
1573          Plist       : List_Id;
1574          Parent_Node : Node_Id;
1575          Unit_Name   : Entity_Id;
1576          Unit_Kind   : Node_Kind;
1577          Unit_Node   : Node_Id;
1578          Sindex      : Source_File_Index;
1579
1580       begin
1581          if not Is_List_Member (N) then
1582             Pragma_Misplaced;
1583
1584          else
1585             Plist := List_Containing (N);
1586             Parent_Node := Parent (Plist);
1587
1588             if Parent_Node = Empty then
1589                Pragma_Misplaced;
1590
1591             --  Case of pragma appearing after a compilation unit. In this case
1592             --  it must have an argument with the corresponding name and must
1593             --  be part of the following pragmas of its parent.
1594
1595             elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
1596                if Plist /= Pragmas_After (Parent_Node) then
1597                   Pragma_Misplaced;
1598
1599                elsif Arg_Count = 0 then
1600                   Error_Pragma
1601                     ("argument required if outside compilation unit");
1602
1603                else
1604                   Check_No_Identifiers;
1605                   Check_Arg_Count (1);
1606                   Unit_Node := Unit (Parent (Parent_Node));
1607                   Unit_Kind := Nkind (Unit_Node);
1608
1609                   Analyze (Expression (Arg1));
1610
1611                   if Unit_Kind = N_Generic_Subprogram_Declaration
1612                     or else Unit_Kind = N_Subprogram_Declaration
1613                   then
1614                      Unit_Name := Defining_Entity (Unit_Node);
1615
1616                   elsif Unit_Kind in N_Generic_Instantiation then
1617                      Unit_Name := Defining_Entity (Unit_Node);
1618
1619                   else
1620                      Unit_Name := Cunit_Entity (Current_Sem_Unit);
1621                   end if;
1622
1623                   if Chars (Unit_Name) /=
1624                      Chars (Entity (Expression (Arg1)))
1625                   then
1626                      Error_Pragma_Arg
1627                        ("pragma% argument is not current unit name", Arg1);
1628                   end if;
1629
1630                   if Ekind (Unit_Name) = E_Package
1631                     and then Present (Renamed_Entity (Unit_Name))
1632                   then
1633                      Error_Pragma ("pragma% not allowed for renamed package");
1634                   end if;
1635                end if;
1636
1637             --  Pragma appears other than after a compilation unit
1638
1639             else
1640                --  Here we check for the generic instantiation case and also
1641                --  for the case of processing a generic formal package. We
1642                --  detect these cases by noting that the Sloc on the node
1643                --  does not belong to the current compilation unit.
1644
1645                Sindex := Source_Index (Current_Sem_Unit);
1646
1647                if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
1648                   Rewrite (N, Make_Null_Statement (Loc));
1649                   return;
1650
1651                --  If before first declaration, the pragma applies to the
1652                --  enclosing unit, and the name if present must be this name.
1653
1654                elsif Is_Before_First_Decl (N, Plist) then
1655                   Unit_Node := Unit_Declaration_Node (Current_Scope);
1656                   Unit_Kind := Nkind (Unit_Node);
1657
1658                   if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
1659                      Pragma_Misplaced;
1660
1661                   elsif Unit_Kind = N_Subprogram_Body
1662                     and then not Acts_As_Spec (Unit_Node)
1663                   then
1664                      Pragma_Misplaced;
1665
1666                   elsif Nkind (Parent_Node) = N_Package_Body then
1667                      Pragma_Misplaced;
1668
1669                   elsif Nkind (Parent_Node) = N_Package_Specification
1670                     and then Plist = Private_Declarations (Parent_Node)
1671                   then
1672                      Pragma_Misplaced;
1673
1674                   elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
1675                            or else Nkind (Parent_Node) =
1676                                              N_Generic_Subprogram_Declaration)
1677                     and then Plist = Generic_Formal_Declarations (Parent_Node)
1678                   then
1679                      Pragma_Misplaced;
1680
1681                   elsif Arg_Count > 0 then
1682                      Analyze (Expression (Arg1));
1683
1684                      if Entity (Expression (Arg1)) /= Current_Scope then
1685                         Error_Pragma_Arg
1686                           ("name in pragma% must be enclosing unit", Arg1);
1687                      end if;
1688
1689                   --  It is legal to have no argument in this context
1690
1691                   else
1692                      return;
1693                   end if;
1694
1695                --  Error if not before first declaration. This is because a
1696                --  library unit pragma argument must be the name of a library
1697                --  unit (RM 10.1.5(7)), but the only names permitted in this
1698                --  context are (RM 10.1.5(6)) names of subprogram declarations,
1699                --  generic subprogram declarations or generic instantiations.
1700
1701                else
1702                   Error_Pragma
1703                     ("pragma% misplaced, must be before first declaration");
1704                end if;
1705             end if;
1706          end if;
1707       end Check_Valid_Library_Unit_Pragma;
1708
1709       -------------------
1710       -- Check_Variant --
1711       -------------------
1712
1713       procedure Check_Variant (Variant : Node_Id) is
1714          Clist : constant Node_Id := Component_List (Variant);
1715          Comp  : Node_Id;
1716
1717       begin
1718          if not Is_Non_Empty_List (Component_Items (Clist)) then
1719             Error_Msg_N
1720               ("Unchecked_Union may not have empty component list",
1721                Variant);
1722             return;
1723          end if;
1724
1725          Comp := First (Component_Items (Clist));
1726          while Present (Comp) loop
1727             Check_Component (Comp);
1728             Next (Comp);
1729          end loop;
1730       end Check_Variant;
1731
1732       ------------------
1733       -- Error_Pragma --
1734       ------------------
1735
1736       procedure Error_Pragma (Msg : String) is
1737       begin
1738          Error_Msg_Name_1 := Pname;
1739          Error_Msg_N (Msg, N);
1740          raise Pragma_Exit;
1741       end Error_Pragma;
1742
1743       ----------------------
1744       -- Error_Pragma_Arg --
1745       ----------------------
1746
1747       procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
1748       begin
1749          Error_Msg_Name_1 := Pname;
1750          Error_Msg_N (Msg, Get_Pragma_Arg (Arg));
1751          raise Pragma_Exit;
1752       end Error_Pragma_Arg;
1753
1754       procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
1755       begin
1756          Error_Msg_Name_1 := Pname;
1757          Error_Msg_N (Msg1, Get_Pragma_Arg (Arg));
1758          Error_Pragma_Arg (Msg2, Arg);
1759       end Error_Pragma_Arg;
1760
1761       ----------------------------
1762       -- Error_Pragma_Arg_Ident --
1763       ----------------------------
1764
1765       procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
1766       begin
1767          Error_Msg_Name_1 := Pname;
1768          Error_Msg_N (Msg, Arg);
1769          raise Pragma_Exit;
1770       end Error_Pragma_Arg_Ident;
1771
1772       ----------------------
1773       -- Error_Pragma_Ref --
1774       ----------------------
1775
1776       procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
1777       begin
1778          Error_Msg_Name_1 := Pname;
1779          Error_Msg_Sloc   := Sloc (Ref);
1780          Error_Msg_NE (Msg, N, Ref);
1781          raise Pragma_Exit;
1782       end Error_Pragma_Ref;
1783
1784       ------------------------
1785       -- Find_Lib_Unit_Name --
1786       ------------------------
1787
1788       function Find_Lib_Unit_Name return Entity_Id is
1789       begin
1790          --  Return inner compilation unit entity, for case of nested
1791          --  categorization pragmas. This happens in generic unit.
1792
1793          if Nkind (Parent (N)) = N_Package_Specification
1794            and then Defining_Entity (Parent (N)) /= Current_Scope
1795          then
1796             return Defining_Entity (Parent (N));
1797          else
1798             return Current_Scope;
1799          end if;
1800       end Find_Lib_Unit_Name;
1801
1802       ----------------------------
1803       -- Find_Program_Unit_Name --
1804       ----------------------------
1805
1806       procedure Find_Program_Unit_Name (Id : Node_Id) is
1807          Unit_Name : Entity_Id;
1808          Unit_Kind : Node_Kind;
1809          P         : constant Node_Id := Parent (N);
1810
1811       begin
1812          if Nkind (P) = N_Compilation_Unit then
1813             Unit_Kind := Nkind (Unit (P));
1814
1815             if Unit_Kind = N_Subprogram_Declaration
1816               or else Unit_Kind = N_Package_Declaration
1817               or else Unit_Kind in N_Generic_Declaration
1818             then
1819                Unit_Name := Defining_Entity (Unit (P));
1820
1821                if Chars (Id) = Chars (Unit_Name) then
1822                   Set_Entity (Id, Unit_Name);
1823                   Set_Etype (Id, Etype (Unit_Name));
1824                else
1825                   Set_Etype (Id, Any_Type);
1826                   Error_Pragma
1827                     ("cannot find program unit referenced by pragma%");
1828                end if;
1829
1830             else
1831                Set_Etype (Id, Any_Type);
1832                Error_Pragma ("pragma% inapplicable to this unit");
1833             end if;
1834
1835          else
1836             Analyze (Id);
1837          end if;
1838       end Find_Program_Unit_Name;
1839
1840       -----------------------------------------
1841       -- Find_Unique_Parameterless_Procedure --
1842       -----------------------------------------
1843
1844       function Find_Unique_Parameterless_Procedure
1845         (Name : Entity_Id;
1846          Arg  : Node_Id) return Entity_Id
1847       is
1848          Proc : Entity_Id := Empty;
1849
1850       begin
1851          --  The body of this procedure needs some comments ???
1852
1853          if not Is_Entity_Name (Name) then
1854             Error_Pragma_Arg
1855               ("argument of pragma% must be entity name", Arg);
1856
1857          elsif not Is_Overloaded (Name) then
1858             Proc := Entity (Name);
1859
1860             if Ekind (Proc) /= E_Procedure
1861                  or else Present (First_Formal (Proc)) then
1862                Error_Pragma_Arg
1863                  ("argument of pragma% must be parameterless procedure", Arg);
1864             end if;
1865
1866          else
1867             declare
1868                Found : Boolean := False;
1869                It    : Interp;
1870                Index : Interp_Index;
1871
1872             begin
1873                Get_First_Interp (Name, Index, It);
1874                while Present (It.Nam) loop
1875                   Proc := It.Nam;
1876
1877                   if Ekind (Proc) = E_Procedure
1878                     and then No (First_Formal (Proc))
1879                   then
1880                      if not Found then
1881                         Found := True;
1882                         Set_Entity (Name, Proc);
1883                         Set_Is_Overloaded (Name, False);
1884                      else
1885                         Error_Pragma_Arg
1886                           ("ambiguous handler name for pragma% ", Arg);
1887                      end if;
1888                   end if;
1889
1890                   Get_Next_Interp (Index, It);
1891                end loop;
1892
1893                if not Found then
1894                   Error_Pragma_Arg
1895                     ("argument of pragma% must be parameterless procedure",
1896                      Arg);
1897                else
1898                   Proc := Entity (Name);
1899                end if;
1900             end;
1901          end if;
1902
1903          return Proc;
1904       end Find_Unique_Parameterless_Procedure;
1905
1906       -------------------------
1907       -- Gather_Associations --
1908       -------------------------
1909
1910       procedure Gather_Associations
1911         (Names : Name_List;
1912          Args  : out Args_List)
1913       is
1914          Arg : Node_Id;
1915
1916       begin
1917          --  Initialize all parameters to Empty
1918
1919          for J in Args'Range loop
1920             Args (J) := Empty;
1921          end loop;
1922
1923          --  That's all we have to do if there are no argument associations
1924
1925          if No (Pragma_Argument_Associations (N)) then
1926             return;
1927          end if;
1928
1929          --  Otherwise first deal with any positional parameters present
1930
1931          Arg := First (Pragma_Argument_Associations (N));
1932          for Index in Args'Range loop
1933             exit when No (Arg) or else Chars (Arg) /= No_Name;
1934             Args (Index) := Expression (Arg);
1935             Next (Arg);
1936          end loop;
1937
1938          --  Positional parameters all processed, if any left, then we
1939          --  have too many positional parameters.
1940
1941          if Present (Arg) and then Chars (Arg) = No_Name then
1942             Error_Pragma_Arg
1943               ("too many positional associations for pragma%", Arg);
1944          end if;
1945
1946          --  Process named parameters if any are present
1947
1948          while Present (Arg) loop
1949             if Chars (Arg) = No_Name then
1950                Error_Pragma_Arg
1951                  ("positional association cannot follow named association",
1952                   Arg);
1953
1954             else
1955                for Index in Names'Range loop
1956                   if Names (Index) = Chars (Arg) then
1957                      if Present (Args (Index)) then
1958                         Error_Pragma_Arg
1959                           ("duplicate argument association for pragma%", Arg);
1960                      else
1961                         Args (Index) := Expression (Arg);
1962                         exit;
1963                      end if;
1964                   end if;
1965
1966                   if Index = Names'Last then
1967                      Error_Msg_Name_1 := Pname;
1968                      Error_Msg_N ("pragma% does not allow & argument", Arg);
1969
1970                      --  Check for possible misspelling
1971
1972                      for Index1 in Names'Range loop
1973                         if Is_Bad_Spelling_Of
1974                              (Chars (Arg), Names (Index1))
1975                         then
1976                            Error_Msg_Name_1 := Names (Index1);
1977                            Error_Msg_N -- CODEFIX
1978                              ("\possible misspelling of%", Arg);
1979                            exit;
1980                         end if;
1981                      end loop;
1982
1983                      raise Pragma_Exit;
1984                   end if;
1985                end loop;
1986             end if;
1987
1988             Next (Arg);
1989          end loop;
1990       end Gather_Associations;
1991
1992       -----------------
1993       -- GNAT_Pragma --
1994       -----------------
1995
1996       procedure GNAT_Pragma is
1997       begin
1998          Check_Restriction (No_Implementation_Pragmas, N);
1999       end GNAT_Pragma;
2000
2001       --------------------------
2002       -- Is_Before_First_Decl --
2003       --------------------------
2004
2005       function Is_Before_First_Decl
2006         (Pragma_Node : Node_Id;
2007          Decls       : List_Id) return Boolean
2008       is
2009          Item : Node_Id := First (Decls);
2010
2011       begin
2012          --  Only other pragmas can come before this pragma
2013
2014          loop
2015             if No (Item) or else Nkind (Item) /= N_Pragma then
2016                return False;
2017
2018             elsif Item = Pragma_Node then
2019                return True;
2020             end if;
2021
2022             Next (Item);
2023          end loop;
2024       end Is_Before_First_Decl;
2025
2026       -----------------------------
2027       -- Is_Configuration_Pragma --
2028       -----------------------------
2029
2030       --  A configuration pragma must appear in the context clause of a
2031       --  compilation unit, and only other pragmas may precede it. Note that
2032       --  the test below also permits use in a configuration pragma file.
2033
2034       function Is_Configuration_Pragma return Boolean is
2035          Lis : constant List_Id := List_Containing (N);
2036          Par : constant Node_Id := Parent (N);
2037          Prg : Node_Id;
2038
2039       begin
2040          --  If no parent, then we are in the configuration pragma file,
2041          --  so the placement is definitely appropriate.
2042
2043          if No (Par) then
2044             return True;
2045
2046          --  Otherwise we must be in the context clause of a compilation unit
2047          --  and the only thing allowed before us in the context list is more
2048          --  configuration pragmas.
2049
2050          elsif Nkind (Par) = N_Compilation_Unit
2051            and then Context_Items (Par) = Lis
2052          then
2053             Prg := First (Lis);
2054
2055             loop
2056                if Prg = N then
2057                   return True;
2058                elsif Nkind (Prg) /= N_Pragma then
2059                   return False;
2060                end if;
2061
2062                Next (Prg);
2063             end loop;
2064
2065          else
2066             return False;
2067          end if;
2068       end Is_Configuration_Pragma;
2069
2070       --------------------------
2071       -- Is_In_Context_Clause --
2072       --------------------------
2073
2074       function Is_In_Context_Clause return Boolean is
2075          Plist       : List_Id;
2076          Parent_Node : Node_Id;
2077
2078       begin
2079          if not Is_List_Member (N) then
2080             return False;
2081
2082          else
2083             Plist := List_Containing (N);
2084             Parent_Node := Parent (Plist);
2085
2086             if Parent_Node = Empty
2087               or else Nkind (Parent_Node) /= N_Compilation_Unit
2088               or else Context_Items (Parent_Node) /= Plist
2089             then
2090                return False;
2091             end if;
2092          end if;
2093
2094          return True;
2095       end Is_In_Context_Clause;
2096
2097       ---------------------------------
2098       -- Is_Static_String_Expression --
2099       ---------------------------------
2100
2101       function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
2102          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2103
2104       begin
2105          Analyze_And_Resolve (Argx);
2106          return Is_OK_Static_Expression (Argx)
2107            and then Nkind (Argx) = N_String_Literal;
2108       end Is_Static_String_Expression;
2109
2110       ----------------------
2111       -- Pragma_Misplaced --
2112       ----------------------
2113
2114       procedure Pragma_Misplaced is
2115       begin
2116          Error_Pragma ("incorrect placement of pragma%");
2117       end Pragma_Misplaced;
2118
2119       ------------------------------------
2120       -- Process Atomic_Shared_Volatile --
2121       ------------------------------------
2122
2123       procedure Process_Atomic_Shared_Volatile is
2124          E_Id : Node_Id;
2125          E    : Entity_Id;
2126          D    : Node_Id;
2127          K    : Node_Kind;
2128          Utyp : Entity_Id;
2129
2130          procedure Set_Atomic (E : Entity_Id);
2131          --  Set given type as atomic, and if no explicit alignment was given,
2132          --  set alignment to unknown, since back end knows what the alignment
2133          --  requirements are for atomic arrays. Note: this step is necessary
2134          --  for derived types.
2135
2136          ----------------
2137          -- Set_Atomic --
2138          ----------------
2139
2140          procedure Set_Atomic (E : Entity_Id) is
2141          begin
2142             Set_Is_Atomic (E);
2143
2144             if not Has_Alignment_Clause (E) then
2145                Set_Alignment (E, Uint_0);
2146             end if;
2147          end Set_Atomic;
2148
2149       --  Start of processing for Process_Atomic_Shared_Volatile
2150
2151       begin
2152          Check_Ada_83_Warning;
2153          Check_No_Identifiers;
2154          Check_Arg_Count (1);
2155          Check_Arg_Is_Local_Name (Arg1);
2156          E_Id := Expression (Arg1);
2157
2158          if Etype (E_Id) = Any_Type then
2159             return;
2160          end if;
2161
2162          E := Entity (E_Id);
2163          D := Declaration_Node (E);
2164          K := Nkind (D);
2165
2166          if Is_Type (E) then
2167             if Rep_Item_Too_Early (E, N)
2168                  or else
2169                Rep_Item_Too_Late (E, N)
2170             then
2171                return;
2172             else
2173                Check_First_Subtype (Arg1);
2174             end if;
2175
2176             if Prag_Id /= Pragma_Volatile then
2177                Set_Atomic (E);
2178                Set_Atomic (Underlying_Type (E));
2179                Set_Atomic (Base_Type (E));
2180             end if;
2181
2182             --  Attribute belongs on the base type. If the view of the type is
2183             --  currently private, it also belongs on the underlying type.
2184
2185             Set_Is_Volatile (Base_Type (E));
2186             Set_Is_Volatile (Underlying_Type (E));
2187
2188             Set_Treat_As_Volatile (E);
2189             Set_Treat_As_Volatile (Underlying_Type (E));
2190
2191          elsif K = N_Object_Declaration
2192            or else (K = N_Component_Declaration
2193                      and then Original_Record_Component (E) = E)
2194          then
2195             if Rep_Item_Too_Late (E, N) then
2196                return;
2197             end if;
2198
2199             if Prag_Id /= Pragma_Volatile then
2200                Set_Is_Atomic (E);
2201
2202                --  If the object declaration has an explicit initialization, a
2203                --  temporary may have to be created to hold the expression, to
2204                --  ensure that access to the object remain atomic.
2205
2206                if Nkind (Parent (E)) = N_Object_Declaration
2207                  and then Present (Expression (Parent (E)))
2208                then
2209                   Set_Has_Delayed_Freeze (E);
2210                end if;
2211
2212                --  An interesting improvement here. If an object of type X is
2213                --  declared atomic, and the type X is not atomic, that's a
2214                --  pity, since it may not have appropriate alignment etc. We
2215                --  can rescue this in the special case where the object and
2216                --  type are in the same unit by just setting the type as
2217                --  atomic, so that the back end will process it as atomic.
2218
2219                Utyp := Underlying_Type (Etype (E));
2220
2221                if Present (Utyp)
2222                  and then Sloc (E) > No_Location
2223                  and then Sloc (Utyp) > No_Location
2224                  and then
2225                    Get_Source_File_Index (Sloc (E)) =
2226                    Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
2227                then
2228                   Set_Is_Atomic (Underlying_Type (Etype (E)));
2229                end if;
2230             end if;
2231
2232             Set_Is_Volatile (E);
2233             Set_Treat_As_Volatile (E);
2234
2235          else
2236             Error_Pragma_Arg
2237               ("inappropriate entity for pragma%", Arg1);
2238          end if;
2239       end Process_Atomic_Shared_Volatile;
2240
2241       -------------------------------------------
2242       -- Process_Compile_Time_Warning_Or_Error --
2243       -------------------------------------------
2244
2245       procedure Process_Compile_Time_Warning_Or_Error is
2246          Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
2247
2248       begin
2249          Check_Arg_Count (2);
2250          Check_No_Identifiers;
2251          Check_Arg_Is_Static_Expression (Arg2, Standard_String);
2252          Analyze_And_Resolve (Arg1x, Standard_Boolean);
2253
2254          if Compile_Time_Known_Value (Arg1x) then
2255             if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
2256                declare
2257                   Str   : constant String_Id :=
2258                             Strval (Get_Pragma_Arg (Arg2));
2259                   Len   : constant Int := String_Length (Str);
2260                   Cont  : Boolean;
2261                   Ptr   : Nat;
2262                   CC    : Char_Code;
2263                   C     : Character;
2264                   Cent  : constant Entity_Id :=
2265                             Cunit_Entity (Current_Sem_Unit);
2266
2267                   Force : constant Boolean :=
2268                             Prag_Id = Pragma_Compile_Time_Warning
2269                               and then
2270                                 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
2271                               and then (Ekind (Cent) /= E_Package
2272                                           or else not In_Private_Part (Cent));
2273                   --  Set True if this is the warning case, and we are in the
2274                   --  visible part of a package spec, or in a subprogram spec,
2275                   --  in which case we want to force the client to see the
2276                   --  warning, even though it is not in the main unit.
2277
2278                begin
2279                   --  Loop through segments of message separated by line feeds.
2280                   --  We output these segments as separate messages with
2281                   --  continuation marks for all but the first.
2282
2283                   Cont := False;
2284                   Ptr := 1;
2285                   loop
2286                      Error_Msg_Strlen := 0;
2287
2288                      --  Loop to copy characters from argument to error message
2289                      --  string buffer.
2290
2291                      loop
2292                         exit when Ptr > Len;
2293                         CC := Get_String_Char (Str, Ptr);
2294                         Ptr := Ptr + 1;
2295
2296                         --  Ignore wide chars ??? else store character
2297
2298                         if In_Character_Range (CC) then
2299                            C := Get_Character (CC);
2300                            exit when C = ASCII.LF;
2301                            Error_Msg_Strlen := Error_Msg_Strlen + 1;
2302                            Error_Msg_String (Error_Msg_Strlen) := C;
2303                         end if;
2304                      end loop;
2305
2306                      --  Here with one line ready to go
2307
2308                      Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
2309
2310                      --  If this is a warning in a spec, then we want clients
2311                      --  to see the warning, so mark the message with the
2312                      --  special sequence !! to force the warning. In the case
2313                      --  of a package spec, we do not force this if we are in
2314                      --  the private part of the spec.
2315
2316                      if Force then
2317                         if Cont = False then
2318                            Error_Msg_N ("<~!!", Arg1);
2319                            Cont := True;
2320                         else
2321                            Error_Msg_N ("\<~!!", Arg1);
2322                         end if;
2323
2324                      --  Error, rather than warning, or in a body, so we do not
2325                      --  need to force visibility for client (error will be
2326                      --  output in any case, and this is the situation in which
2327                      --  we do not want a client to get a warning, since the
2328                      --  warning is in the body or the spec private part.
2329
2330                      else
2331                         if Cont = False then
2332                            Error_Msg_N ("<~", Arg1);
2333                            Cont := True;
2334                         else
2335                            Error_Msg_N ("\<~", Arg1);
2336                         end if;
2337                      end if;
2338
2339                      exit when Ptr > Len;
2340                   end loop;
2341                end;
2342             end if;
2343          end if;
2344       end Process_Compile_Time_Warning_Or_Error;
2345
2346       ------------------------
2347       -- Process_Convention --
2348       ------------------------
2349
2350       procedure Process_Convention
2351         (C   : out Convention_Id;
2352          Ent : out Entity_Id)
2353       is
2354          Id        : Node_Id;
2355          E         : Entity_Id;
2356          E1        : Entity_Id;
2357          Cname     : Name_Id;
2358          Comp_Unit : Unit_Number_Type;
2359
2360          procedure Set_Convention_From_Pragma (E : Entity_Id);
2361          --  Set convention in entity E, and also flag that the entity has a
2362          --  convention pragma. If entity is for a private or incomplete type,
2363          --  also set convention and flag on underlying type. This procedure
2364          --  also deals with the special case of C_Pass_By_Copy convention.
2365
2366          --------------------------------
2367          -- Set_Convention_From_Pragma --
2368          --------------------------------
2369
2370          procedure Set_Convention_From_Pragma (E : Entity_Id) is
2371          begin
2372             --  Ada 2005 (AI-430): Check invalid attempt to change convention
2373             --  for an overridden dispatching operation. Technically this is
2374             --  an amendment and should only be done in Ada 2005 mode. However,
2375             --  this is clearly a mistake, since the problem that is addressed
2376             --  by this AI is that there is a clear gap in the RM!
2377
2378             if Is_Dispatching_Operation (E)
2379               and then Present (Overridden_Operation (E))
2380               and then C /= Convention (Overridden_Operation (E))
2381             then
2382                Error_Pragma_Arg
2383                  ("cannot change convention for " &
2384                   "overridden dispatching operation",
2385                   Arg1);
2386             end if;
2387
2388             --  Set the convention
2389
2390             Set_Convention (E, C);
2391             Set_Has_Convention_Pragma (E);
2392
2393             if Is_Incomplete_Or_Private_Type (E) then
2394                Set_Convention            (Underlying_Type (E), C);
2395                Set_Has_Convention_Pragma (Underlying_Type (E), True);
2396             end if;
2397
2398             --  A class-wide type should inherit the convention of the specific
2399             --  root type (although this isn't specified clearly by the RM).
2400
2401             if Is_Type (E) and then Present (Class_Wide_Type (E)) then
2402                Set_Convention (Class_Wide_Type (E), C);
2403             end if;
2404
2405             --  If the entity is a record type, then check for special case of
2406             --  C_Pass_By_Copy, which is treated the same as C except that the
2407             --  special record flag is set. This convention is only permitted
2408             --  on record types (see AI95-00131).
2409
2410             if Cname = Name_C_Pass_By_Copy then
2411                if Is_Record_Type (E) then
2412                   Set_C_Pass_By_Copy (Base_Type (E));
2413                elsif Is_Incomplete_Or_Private_Type (E)
2414                  and then Is_Record_Type (Underlying_Type (E))
2415                then
2416                   Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
2417                else
2418                   Error_Pragma_Arg
2419                     ("C_Pass_By_Copy convention allowed only for record type",
2420                      Arg2);
2421                end if;
2422             end if;
2423
2424             --  If the entity is a derived boolean type, check for the special
2425             --  case of convention C, C++, or Fortran, where we consider any
2426             --  nonzero value to represent true.
2427
2428             if Is_Discrete_Type (E)
2429               and then Root_Type (Etype (E)) = Standard_Boolean
2430               and then
2431                 (C = Convention_C
2432                    or else
2433                  C = Convention_CPP
2434                    or else
2435                  C = Convention_Fortran)
2436             then
2437                Set_Nonzero_Is_True (Base_Type (E));
2438             end if;
2439          end Set_Convention_From_Pragma;
2440
2441       --  Start of processing for Process_Convention
2442
2443       begin
2444          Check_At_Least_N_Arguments (2);
2445          Check_Optional_Identifier (Arg1, Name_Convention);
2446          Check_Arg_Is_Identifier (Arg1);
2447          Cname := Chars (Expression (Arg1));
2448
2449          --  C_Pass_By_Copy is treated as a synonym for convention C (this is
2450          --  tested again below to set the critical flag).
2451          if Cname = Name_C_Pass_By_Copy then
2452             C := Convention_C;
2453
2454          --  Otherwise we must have something in the standard convention list
2455
2456          elsif Is_Convention_Name (Cname) then
2457             C := Get_Convention_Id (Chars (Expression (Arg1)));
2458
2459          --  In DEC VMS, it seems that there is an undocumented feature that
2460          --  any unrecognized convention is treated as the default, which for
2461          --  us is convention C. It does not seem so terrible to do this
2462          --  unconditionally, silently in the VMS case, and with a warning
2463          --  in the non-VMS case.
2464
2465          else
2466             if Warn_On_Export_Import and not OpenVMS_On_Target then
2467                Error_Msg_N
2468                  ("?unrecognized convention name, C assumed",
2469                   Expression (Arg1));
2470             end if;
2471
2472             C := Convention_C;
2473          end if;
2474
2475          Check_Optional_Identifier (Arg2, Name_Entity);
2476          Check_Arg_Is_Local_Name (Arg2);
2477
2478          Id := Expression (Arg2);
2479          Analyze (Id);
2480
2481          if not Is_Entity_Name (Id) then
2482             Error_Pragma_Arg ("entity name required", Arg2);
2483          end if;
2484
2485          E := Entity (Id);
2486
2487          --  Set entity to return
2488
2489          Ent := E;
2490
2491          --  Go to renamed subprogram if present, since convention applies to
2492          --  the actual renamed entity, not to the renaming entity. If the
2493          --  subprogram is inherited, go to parent subprogram.
2494
2495          if Is_Subprogram (E)
2496            and then Present (Alias (E))
2497          then
2498             if Nkind (Parent (Declaration_Node (E))) =
2499                                        N_Subprogram_Renaming_Declaration
2500             then
2501                if Scope (E) /= Scope (Alias (E)) then
2502                   Error_Pragma_Ref
2503                     ("cannot apply pragma% to non-local entity&#", E);
2504                end if;
2505
2506                E := Alias (E);
2507
2508             elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
2509                                         N_Private_Extension_Declaration)
2510               and then Scope (E) = Scope (Alias (E))
2511             then
2512                E := Alias (E);
2513
2514                --  Return the parent subprogram the entity was inherited from
2515
2516                Ent := E;
2517             end if;
2518          end if;
2519
2520          --  Check that we are not applying this to a specless body
2521
2522          if Is_Subprogram (E)
2523            and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
2524          then
2525             Error_Pragma
2526               ("pragma% requires separate spec and must come before body");
2527          end if;
2528
2529          --  Check that we are not applying this to a named constant
2530
2531          if Ekind (E) = E_Named_Integer
2532               or else
2533             Ekind (E) = E_Named_Real
2534          then
2535             Error_Msg_Name_1 := Pname;
2536             Error_Msg_N
2537               ("cannot apply pragma% to named constant!",
2538                Get_Pragma_Arg (Arg2));
2539             Error_Pragma_Arg
2540               ("\supply appropriate type for&!", Arg2);
2541          end if;
2542
2543          if Ekind (E) = E_Enumeration_Literal then
2544             Error_Pragma ("enumeration literal not allowed for pragma%");
2545          end if;
2546
2547          --  Check for rep item appearing too early or too late
2548
2549          if Etype (E) = Any_Type
2550            or else Rep_Item_Too_Early (E, N)
2551          then
2552             raise Pragma_Exit;
2553          else
2554             E := Underlying_Type (E);
2555          end if;
2556
2557          if Rep_Item_Too_Late (E, N) then
2558             raise Pragma_Exit;
2559          end if;
2560
2561          if Has_Convention_Pragma (E) then
2562             Error_Pragma_Arg
2563               ("at most one Convention/Export/Import pragma is allowed", Arg2);
2564
2565          elsif Convention (E) = Convention_Protected
2566            or else Ekind (Scope (E)) = E_Protected_Type
2567          then
2568             Error_Pragma_Arg
2569               ("a protected operation cannot be given a different convention",
2570                 Arg2);
2571          end if;
2572
2573          --  For Intrinsic, a subprogram is required
2574
2575          if C = Convention_Intrinsic
2576            and then not Is_Subprogram (E)
2577            and then not Is_Generic_Subprogram (E)
2578          then
2579             Error_Pragma_Arg
2580               ("second argument of pragma% must be a subprogram", Arg2);
2581          end if;
2582
2583          --  For Stdcall, a subprogram, variable or subprogram type is required
2584
2585          if C = Convention_Stdcall
2586            and then not Is_Subprogram (E)
2587            and then not Is_Generic_Subprogram (E)
2588            and then Ekind (E) /= E_Variable
2589            and then not
2590              (Is_Access_Type (E)
2591                 and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
2592          then
2593             Error_Pragma_Arg
2594               ("second argument of pragma% must be subprogram (type)",
2595                Arg2);
2596          end if;
2597
2598          if not Is_Subprogram (E)
2599            and then not Is_Generic_Subprogram (E)
2600          then
2601             Set_Convention_From_Pragma (E);
2602
2603             if Is_Type (E) then
2604
2605                Check_First_Subtype (Arg2);
2606                Set_Convention_From_Pragma (Base_Type (E));
2607
2608                --  For subprograms, we must set the convention on the
2609                --  internally generated directly designated type as well.
2610
2611                if Ekind (E) = E_Access_Subprogram_Type then
2612                   Set_Convention_From_Pragma (Directly_Designated_Type (E));
2613                end if;
2614             end if;
2615
2616          --  For the subprogram case, set proper convention for all homonyms
2617          --  in same scope and the same declarative part, i.e. the same
2618          --  compilation unit.
2619
2620          else
2621             Comp_Unit := Get_Source_Unit (E);
2622             Set_Convention_From_Pragma (E);
2623
2624             --  Treat a pragma Import as an implicit body, for GPS use
2625
2626             if Prag_Id = Pragma_Import then
2627                Generate_Reference (E, Id, 'b');
2628             end if;
2629
2630             --  Loop through the homonyms of the pragma argument's entity
2631
2632             E1 := Ent;
2633             loop
2634                E1 := Homonym (E1);
2635                exit when No (E1) or else Scope (E1) /= Current_Scope;
2636
2637                --  Do not set the pragma on inherited operations or on formal
2638                --  subprograms.
2639
2640                if Comes_From_Source (E1)
2641                  and then Comp_Unit = Get_Source_Unit (E1)
2642                  and then not Is_Formal_Subprogram (E1)
2643                  and then Nkind (Original_Node (Parent (E1))) /=
2644                                                     N_Full_Type_Declaration
2645                then
2646                   if Present (Alias (E1))
2647                     and then Scope (E1) /= Scope (Alias (E1))
2648                   then
2649                      Error_Pragma_Ref
2650                        ("cannot apply pragma% to non-local entity& declared#",
2651                         E1);
2652                   end if;
2653
2654                   Set_Convention_From_Pragma (E1);
2655
2656                   if Prag_Id = Pragma_Import then
2657                      Generate_Reference (E1, Id, 'b');
2658                   end if;
2659                end if;
2660             end loop;
2661          end if;
2662       end Process_Convention;
2663
2664       -----------------------------------------------------
2665       -- Process_Extended_Import_Export_Exception_Pragma --
2666       -----------------------------------------------------
2667
2668       procedure Process_Extended_Import_Export_Exception_Pragma
2669         (Arg_Internal : Node_Id;
2670          Arg_External : Node_Id;
2671          Arg_Form     : Node_Id;
2672          Arg_Code     : Node_Id)
2673       is
2674          Def_Id   : Entity_Id;
2675          Code_Val : Uint;
2676
2677       begin
2678          if not OpenVMS_On_Target then
2679             Error_Pragma
2680               ("?pragma% ignored (applies only to Open'V'M'S)");
2681          end if;
2682
2683          Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
2684          Def_Id := Entity (Arg_Internal);
2685
2686          if Ekind (Def_Id) /= E_Exception then
2687             Error_Pragma_Arg
2688               ("pragma% must refer to declared exception", Arg_Internal);
2689          end if;
2690
2691          Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
2692
2693          if Present (Arg_Form) then
2694             Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
2695          end if;
2696
2697          if Present (Arg_Form)
2698            and then Chars (Arg_Form) = Name_Ada
2699          then
2700             null;
2701          else
2702             Set_Is_VMS_Exception (Def_Id);
2703             Set_Exception_Code (Def_Id, No_Uint);
2704          end if;
2705
2706          if Present (Arg_Code) then
2707             if not Is_VMS_Exception (Def_Id) then
2708                Error_Pragma_Arg
2709                  ("Code option for pragma% not allowed for Ada case",
2710                   Arg_Code);
2711             end if;
2712
2713             Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
2714             Code_Val := Expr_Value (Arg_Code);
2715
2716             if not UI_Is_In_Int_Range (Code_Val) then
2717                Error_Pragma_Arg
2718                  ("Code option for pragma% must be in 32-bit range",
2719                   Arg_Code);
2720
2721             else
2722                Set_Exception_Code (Def_Id, Code_Val);
2723             end if;
2724          end if;
2725       end Process_Extended_Import_Export_Exception_Pragma;
2726
2727       -------------------------------------------------
2728       -- Process_Extended_Import_Export_Internal_Arg --
2729       -------------------------------------------------
2730
2731       procedure Process_Extended_Import_Export_Internal_Arg
2732         (Arg_Internal : Node_Id := Empty)
2733       is
2734       begin
2735          if No (Arg_Internal) then
2736             Error_Pragma ("Internal parameter required for pragma%");
2737          end if;
2738
2739          if Nkind (Arg_Internal) = N_Identifier then
2740             null;
2741
2742          elsif Nkind (Arg_Internal) = N_Operator_Symbol
2743            and then (Prag_Id = Pragma_Import_Function
2744                        or else
2745                      Prag_Id = Pragma_Export_Function)
2746          then
2747             null;
2748
2749          else
2750             Error_Pragma_Arg
2751               ("wrong form for Internal parameter for pragma%", Arg_Internal);
2752          end if;
2753
2754          Check_Arg_Is_Local_Name (Arg_Internal);
2755       end Process_Extended_Import_Export_Internal_Arg;
2756
2757       --------------------------------------------------
2758       -- Process_Extended_Import_Export_Object_Pragma --
2759       --------------------------------------------------
2760
2761       procedure Process_Extended_Import_Export_Object_Pragma
2762         (Arg_Internal : Node_Id;
2763          Arg_External : Node_Id;
2764          Arg_Size     : Node_Id)
2765       is
2766          Def_Id : Entity_Id;
2767
2768       begin
2769          Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
2770          Def_Id := Entity (Arg_Internal);
2771
2772          if Ekind (Def_Id) /= E_Constant
2773            and then Ekind (Def_Id) /= E_Variable
2774          then
2775             Error_Pragma_Arg
2776               ("pragma% must designate an object", Arg_Internal);
2777          end if;
2778
2779          if Has_Rep_Pragma (Def_Id, Name_Common_Object)
2780               or else
2781             Has_Rep_Pragma (Def_Id, Name_Psect_Object)
2782          then
2783             Error_Pragma_Arg
2784               ("previous Common/Psect_Object applies, pragma % not permitted",
2785                Arg_Internal);
2786          end if;
2787
2788          if Rep_Item_Too_Late (Def_Id, N) then
2789             raise Pragma_Exit;
2790          end if;
2791
2792          Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
2793
2794          if Present (Arg_Size) then
2795             Check_Arg_Is_External_Name (Arg_Size);
2796          end if;
2797
2798          --  Export_Object case
2799
2800          if Prag_Id = Pragma_Export_Object then
2801             if not Is_Library_Level_Entity (Def_Id) then
2802                Error_Pragma_Arg
2803                  ("argument for pragma% must be library level entity",
2804                   Arg_Internal);
2805             end if;
2806
2807             if Ekind (Current_Scope) = E_Generic_Package then
2808                Error_Pragma ("pragma& cannot appear in a generic unit");
2809             end if;
2810
2811             if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
2812                Error_Pragma_Arg
2813                  ("exported object must have compile time known size",
2814                   Arg_Internal);
2815             end if;
2816
2817             if Warn_On_Export_Import and then Is_Exported (Def_Id) then
2818                Error_Msg_N ("?duplicate Export_Object pragma", N);
2819             else
2820                Set_Exported (Def_Id, Arg_Internal);
2821             end if;
2822
2823          --  Import_Object case
2824
2825          else
2826             if Is_Concurrent_Type (Etype (Def_Id)) then
2827                Error_Pragma_Arg
2828                  ("cannot use pragma% for task/protected object",
2829                   Arg_Internal);
2830             end if;
2831
2832             if Ekind (Def_Id) = E_Constant then
2833                Error_Pragma_Arg
2834                  ("cannot import a constant", Arg_Internal);
2835             end if;
2836
2837             if Warn_On_Export_Import
2838               and then Has_Discriminants (Etype (Def_Id))
2839             then
2840                Error_Msg_N
2841                  ("imported value must be initialized?", Arg_Internal);
2842             end if;
2843
2844             if Warn_On_Export_Import
2845               and then Is_Access_Type (Etype (Def_Id))
2846             then
2847                Error_Pragma_Arg
2848                  ("cannot import object of an access type?", Arg_Internal);
2849             end if;
2850
2851             if Warn_On_Export_Import
2852               and then Is_Imported (Def_Id)
2853             then
2854                Error_Msg_N
2855                  ("?duplicate Import_Object pragma", N);
2856
2857             --  Check for explicit initialization present. Note that an
2858             --  initialization generated by the code generator, e.g. for an
2859             --  access type, does not count here.
2860
2861             elsif Present (Expression (Parent (Def_Id)))
2862                and then
2863                  Comes_From_Source
2864                    (Original_Node (Expression (Parent (Def_Id))))
2865             then
2866                Error_Msg_Sloc := Sloc (Def_Id);
2867                Error_Pragma_Arg
2868                  ("imported entities cannot be initialized (RM B.1(24))",
2869                   "\no initialization allowed for & declared#", Arg1);
2870             else
2871                Set_Imported (Def_Id);
2872                Note_Possible_Modification (Arg_Internal, Sure => False);
2873             end if;
2874          end if;
2875       end Process_Extended_Import_Export_Object_Pragma;
2876
2877       ------------------------------------------------------
2878       -- Process_Extended_Import_Export_Subprogram_Pragma --
2879       ------------------------------------------------------
2880
2881       procedure Process_Extended_Import_Export_Subprogram_Pragma
2882         (Arg_Internal                 : Node_Id;
2883          Arg_External                 : Node_Id;
2884          Arg_Parameter_Types          : Node_Id;
2885          Arg_Result_Type              : Node_Id := Empty;
2886          Arg_Mechanism                : Node_Id;
2887          Arg_Result_Mechanism         : Node_Id := Empty;
2888          Arg_First_Optional_Parameter : Node_Id := Empty)
2889       is
2890          Ent       : Entity_Id;
2891          Def_Id    : Entity_Id;
2892          Hom_Id    : Entity_Id;
2893          Formal    : Entity_Id;
2894          Ambiguous : Boolean;
2895          Match     : Boolean;
2896          Dval      : Node_Id;
2897
2898          function Same_Base_Type
2899           (Ptype  : Node_Id;
2900            Formal : Entity_Id) return Boolean;
2901          --  Determines if Ptype references the type of Formal. Note that only
2902          --  the base types need to match according to the spec. Ptype here is
2903          --  the argument from the pragma, which is either a type name, or an
2904          --  access attribute.
2905
2906          --------------------
2907          -- Same_Base_Type --
2908          --------------------
2909
2910          function Same_Base_Type
2911            (Ptype  : Node_Id;
2912             Formal : Entity_Id) return Boolean
2913          is
2914             Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
2915             Pref : Node_Id;
2916
2917          begin
2918             --  Case where pragma argument is typ'Access
2919
2920             if Nkind (Ptype) = N_Attribute_Reference
2921               and then Attribute_Name (Ptype) = Name_Access
2922             then
2923                Pref := Prefix (Ptype);
2924                Find_Type (Pref);
2925
2926                if not Is_Entity_Name (Pref)
2927                  or else Entity (Pref) = Any_Type
2928                then
2929                   raise Pragma_Exit;
2930                end if;
2931
2932                --  We have a match if the corresponding argument is of an
2933                --  anonymous access type, and its designated type matches the
2934                --  type of the prefix of the access attribute
2935
2936                return Ekind (Ftyp) = E_Anonymous_Access_Type
2937                  and then Base_Type (Entity (Pref)) =
2938                             Base_Type (Etype (Designated_Type (Ftyp)));
2939
2940             --  Case where pragma argument is a type name
2941
2942             else
2943                Find_Type (Ptype);
2944
2945                if not Is_Entity_Name (Ptype)
2946                  or else Entity (Ptype) = Any_Type
2947                then
2948                   raise Pragma_Exit;
2949                end if;
2950
2951                --  We have a match if the corresponding argument is of the type
2952                --  given in the pragma (comparing base types)
2953
2954                return Base_Type (Entity (Ptype)) = Ftyp;
2955             end if;
2956          end Same_Base_Type;
2957
2958       --  Start of processing for
2959       --  Process_Extended_Import_Export_Subprogram_Pragma
2960
2961       begin
2962          Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
2963          Ent := Empty;
2964          Ambiguous := False;
2965
2966          --  Loop through homonyms (overloadings) of the entity
2967
2968          Hom_Id := Entity (Arg_Internal);
2969          while Present (Hom_Id) loop
2970             Def_Id := Get_Base_Subprogram (Hom_Id);
2971
2972             --  We need a subprogram in the current scope
2973
2974             if not Is_Subprogram (Def_Id)
2975               or else Scope (Def_Id) /= Current_Scope
2976             then
2977                null;
2978
2979             else
2980                Match := True;
2981
2982                --  Pragma cannot apply to subprogram body
2983
2984                if Is_Subprogram (Def_Id)
2985                  and then Nkind (Parent (Declaration_Node (Def_Id))) =
2986                                                              N_Subprogram_Body
2987                then
2988                   Error_Pragma
2989                     ("pragma% requires separate spec"
2990                       & " and must come before body");
2991                end if;
2992
2993                --  Test result type if given, note that the result type
2994                --  parameter can only be present for the function cases.
2995
2996                if Present (Arg_Result_Type)
2997                  and then not Same_Base_Type (Arg_Result_Type, Def_Id)
2998                then
2999                   Match := False;
3000
3001                elsif Etype (Def_Id) /= Standard_Void_Type
3002                  and then
3003                    (Pname = Name_Export_Procedure
3004                       or else
3005                     Pname = Name_Import_Procedure)
3006                then
3007                   Match := False;
3008
3009                --  Test parameter types if given. Note that this parameter
3010                --  has not been analyzed (and must not be, since it is
3011                --  semantic nonsense), so we get it as the parser left it.
3012
3013                elsif Present (Arg_Parameter_Types) then
3014                   Check_Matching_Types : declare
3015                      Formal : Entity_Id;
3016                      Ptype  : Node_Id;
3017
3018                   begin
3019                      Formal := First_Formal (Def_Id);
3020
3021                      if Nkind (Arg_Parameter_Types) = N_Null then
3022                         if Present (Formal) then
3023                            Match := False;
3024                         end if;
3025
3026                      --  A list of one type, e.g. (List) is parsed as
3027                      --  a parenthesized expression.
3028
3029                      elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
3030                        and then Paren_Count (Arg_Parameter_Types) = 1
3031                      then
3032                         if No (Formal)
3033                           or else Present (Next_Formal (Formal))
3034                         then
3035                            Match := False;
3036                         else
3037                            Match :=
3038                              Same_Base_Type (Arg_Parameter_Types, Formal);
3039                         end if;
3040
3041                      --  A list of more than one type is parsed as a aggregate
3042
3043                      elsif Nkind (Arg_Parameter_Types) = N_Aggregate
3044                        and then Paren_Count (Arg_Parameter_Types) = 0
3045                      then
3046                         Ptype := First (Expressions (Arg_Parameter_Types));
3047                         while Present (Ptype) or else Present (Formal) loop
3048                            if No (Ptype)
3049                              or else No (Formal)
3050                              or else not Same_Base_Type (Ptype, Formal)
3051                            then
3052                               Match := False;
3053                               exit;
3054                            else
3055                               Next_Formal (Formal);
3056                               Next (Ptype);
3057                            end if;
3058                         end loop;
3059
3060                      --  Anything else is of the wrong form
3061
3062                      else
3063                         Error_Pragma_Arg
3064                           ("wrong form for Parameter_Types parameter",
3065                            Arg_Parameter_Types);
3066                      end if;
3067                   end Check_Matching_Types;
3068                end if;
3069
3070                --  Match is now False if the entry we found did not match
3071                --  either a supplied Parameter_Types or Result_Types argument
3072
3073                if Match then
3074                   if No (Ent) then
3075                      Ent := Def_Id;
3076
3077                   --  Ambiguous case, the flag Ambiguous shows if we already
3078                   --  detected this and output the initial messages.
3079
3080                   else
3081                      if not Ambiguous then
3082                         Ambiguous := True;
3083                         Error_Msg_Name_1 := Pname;
3084                         Error_Msg_N
3085                           ("pragma% does not uniquely identify subprogram!",
3086                            N);
3087                         Error_Msg_Sloc := Sloc (Ent);
3088                         Error_Msg_N ("matching subprogram #!", N);
3089                         Ent := Empty;
3090                      end if;
3091
3092                      Error_Msg_Sloc := Sloc (Def_Id);
3093                      Error_Msg_N ("matching subprogram #!", N);
3094                   end if;
3095                end if;
3096             end if;
3097
3098             Hom_Id := Homonym (Hom_Id);
3099          end loop;
3100
3101          --  See if we found an entry
3102
3103          if No (Ent) then
3104             if not Ambiguous then
3105                if Is_Generic_Subprogram (Entity (Arg_Internal)) then
3106                   Error_Pragma
3107                     ("pragma% cannot be given for generic subprogram");
3108                else
3109                   Error_Pragma
3110                     ("pragma% does not identify local subprogram");
3111                end if;
3112             end if;
3113
3114             return;
3115          end if;
3116
3117          --  Import pragmas must be for imported entities
3118
3119          if Prag_Id = Pragma_Import_Function
3120               or else
3121             Prag_Id = Pragma_Import_Procedure
3122               or else
3123             Prag_Id = Pragma_Import_Valued_Procedure
3124          then
3125             if not Is_Imported (Ent) then
3126                Error_Pragma -- CODEFIX???
3127                  ("pragma Import or Interface must precede pragma%");
3128             end if;
3129
3130          --  Here we have the Export case which can set the entity as exported
3131
3132          --  But does not do so if the specified external name is null, since
3133          --  that is taken as a signal in DEC Ada 83 (with which we want to be
3134          --  compatible) to request no external name.
3135
3136          elsif Nkind (Arg_External) = N_String_Literal
3137            and then String_Length (Strval (Arg_External)) = 0
3138          then
3139             null;
3140
3141          --  In all other cases, set entity as exported
3142
3143          else
3144             Set_Exported (Ent, Arg_Internal);
3145          end if;
3146
3147          --  Special processing for Valued_Procedure cases
3148
3149          if Prag_Id = Pragma_Import_Valued_Procedure
3150            or else
3151             Prag_Id = Pragma_Export_Valued_Procedure
3152          then
3153             Formal := First_Formal (Ent);
3154
3155             if No (Formal) then
3156                Error_Pragma ("at least one parameter required for pragma%");
3157
3158             elsif Ekind (Formal) /= E_Out_Parameter then
3159                Error_Pragma ("first parameter must have mode out for pragma%");
3160
3161             else
3162                Set_Is_Valued_Procedure (Ent);
3163             end if;
3164          end if;
3165
3166          Set_Extended_Import_Export_External_Name (Ent, Arg_External);
3167
3168          --  Process Result_Mechanism argument if present. We have already
3169          --  checked that this is only allowed for the function case.
3170
3171          if Present (Arg_Result_Mechanism) then
3172             Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
3173          end if;
3174
3175          --  Process Mechanism parameter if present. Note that this parameter
3176          --  is not analyzed, and must not be analyzed since it is semantic
3177          --  nonsense, so we get it in exactly as the parser left it.
3178
3179          if Present (Arg_Mechanism) then
3180             declare
3181                Formal : Entity_Id;
3182                Massoc : Node_Id;
3183                Mname  : Node_Id;
3184                Choice : Node_Id;
3185
3186             begin
3187                --  A single mechanism association without a formal parameter
3188                --  name is parsed as a parenthesized expression. All other
3189                --  cases are parsed as aggregates, so we rewrite the single
3190                --  parameter case as an aggregate for consistency.
3191
3192                if Nkind (Arg_Mechanism) /= N_Aggregate
3193                  and then Paren_Count (Arg_Mechanism) = 1
3194                then
3195                   Rewrite (Arg_Mechanism,
3196                     Make_Aggregate (Sloc (Arg_Mechanism),
3197                       Expressions => New_List (
3198                         Relocate_Node (Arg_Mechanism))));
3199                end if;
3200
3201                --  Case of only mechanism name given, applies to all formals
3202
3203                if Nkind (Arg_Mechanism) /= N_Aggregate then
3204                   Formal := First_Formal (Ent);
3205                   while Present (Formal) loop
3206                      Set_Mechanism_Value (Formal, Arg_Mechanism);
3207                      Next_Formal (Formal);
3208                   end loop;
3209
3210                --  Case of list of mechanism associations given
3211
3212                else
3213                   if Null_Record_Present (Arg_Mechanism) then
3214                      Error_Pragma_Arg
3215                        ("inappropriate form for Mechanism parameter",
3216                         Arg_Mechanism);
3217                   end if;
3218
3219                   --  Deal with positional ones first
3220
3221                   Formal := First_Formal (Ent);
3222
3223                   if Present (Expressions (Arg_Mechanism)) then
3224                      Mname := First (Expressions (Arg_Mechanism));
3225                      while Present (Mname) loop
3226                         if No (Formal) then
3227                            Error_Pragma_Arg
3228                              ("too many mechanism associations", Mname);
3229                         end if;
3230
3231                         Set_Mechanism_Value (Formal, Mname);
3232                         Next_Formal (Formal);
3233                         Next (Mname);
3234                      end loop;
3235                   end if;
3236
3237                   --  Deal with named entries
3238
3239                   if Present (Component_Associations (Arg_Mechanism)) then
3240                      Massoc := First (Component_Associations (Arg_Mechanism));
3241                      while Present (Massoc) loop
3242                         Choice := First (Choices (Massoc));
3243
3244                         if Nkind (Choice) /= N_Identifier
3245                           or else Present (Next (Choice))
3246                         then
3247                            Error_Pragma_Arg
3248                              ("incorrect form for mechanism association",
3249                               Massoc);
3250                         end if;
3251
3252                         Formal := First_Formal (Ent);
3253                         loop
3254                            if No (Formal) then
3255                               Error_Pragma_Arg
3256                                 ("parameter name & not present", Choice);
3257                            end if;
3258
3259                            if Chars (Choice) = Chars (Formal) then
3260                               Set_Mechanism_Value
3261                                 (Formal, Expression (Massoc));
3262
3263                               --  Set entity on identifier for ASIS
3264
3265                               Set_Entity (Choice, Formal);
3266
3267                               exit;
3268                            end if;
3269
3270                            Next_Formal (Formal);
3271                         end loop;
3272
3273                         Next (Massoc);
3274                      end loop;
3275                   end if;
3276                end if;
3277             end;
3278          end if;
3279
3280          --  Process First_Optional_Parameter argument if present. We have
3281          --  already checked that this is only allowed for the Import case.
3282
3283          if Present (Arg_First_Optional_Parameter) then
3284             if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
3285                Error_Pragma_Arg
3286                  ("first optional parameter must be formal parameter name",
3287                   Arg_First_Optional_Parameter);
3288             end if;
3289
3290             Formal := First_Formal (Ent);
3291             loop
3292                if No (Formal) then
3293                   Error_Pragma_Arg
3294                     ("specified formal parameter& not found",
3295                      Arg_First_Optional_Parameter);
3296                end if;
3297
3298                exit when Chars (Formal) =
3299                          Chars (Arg_First_Optional_Parameter);
3300
3301                Next_Formal (Formal);
3302             end loop;
3303
3304             Set_First_Optional_Parameter (Ent, Formal);
3305
3306             --  Check specified and all remaining formals have right form
3307
3308             while Present (Formal) loop
3309                if Ekind (Formal) /= E_In_Parameter then
3310                   Error_Msg_NE
3311                     ("optional formal& is not of mode in!",
3312                      Arg_First_Optional_Parameter, Formal);
3313
3314                else
3315                   Dval := Default_Value (Formal);
3316
3317                   if No (Dval) then
3318                      Error_Msg_NE
3319                        ("optional formal& does not have default value!",
3320                         Arg_First_Optional_Parameter, Formal);
3321
3322                   elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
3323                      null;
3324
3325                   else
3326                      Error_Msg_FE
3327                        ("default value for optional formal& is non-static!",
3328                         Arg_First_Optional_Parameter, Formal);
3329                   end if;
3330                end if;
3331
3332                Set_Is_Optional_Parameter (Formal);
3333                Next_Formal (Formal);
3334             end loop;
3335          end if;
3336       end Process_Extended_Import_Export_Subprogram_Pragma;
3337
3338       --------------------------
3339       -- Process_Generic_List --
3340       --------------------------
3341
3342       procedure Process_Generic_List is
3343          Arg : Node_Id;
3344          Exp : Node_Id;
3345
3346       begin
3347          Check_No_Identifiers;
3348          Check_At_Least_N_Arguments (1);
3349
3350          Arg := Arg1;
3351          while Present (Arg) loop
3352             Exp := Expression (Arg);
3353             Analyze (Exp);
3354
3355             if not Is_Entity_Name (Exp)
3356               or else
3357                 (not Is_Generic_Instance (Entity (Exp))
3358                   and then
3359                  not Is_Generic_Unit (Entity (Exp)))
3360             then
3361                Error_Pragma_Arg
3362                  ("pragma% argument must be name of generic unit/instance",
3363                   Arg);
3364             end if;
3365
3366             Next (Arg);
3367          end loop;
3368       end Process_Generic_List;
3369
3370       ---------------------------------
3371       -- Process_Import_Or_Interface --
3372       ---------------------------------
3373
3374       procedure Process_Import_Or_Interface is
3375          C      : Convention_Id;
3376          Def_Id : Entity_Id;
3377          Hom_Id : Entity_Id;
3378
3379       begin
3380          Process_Convention (C, Def_Id);
3381          Kill_Size_Check_Code (Def_Id);
3382          Note_Possible_Modification (Expression (Arg2), Sure => False);
3383
3384          if Ekind (Def_Id) = E_Variable
3385               or else
3386             Ekind (Def_Id) = E_Constant
3387          then
3388             --  We do not permit Import to apply to a renaming declaration
3389
3390             if Present (Renamed_Object (Def_Id)) then
3391                Error_Pragma_Arg
3392                  ("pragma% not allowed for object renaming", Arg2);
3393
3394             --  User initialization is not allowed for imported object, but
3395             --  the object declaration may contain a default initialization,
3396             --  that will be discarded. Note that an explicit initialization
3397             --  only counts if it comes from source, otherwise it is simply
3398             --  the code generator making an implicit initialization explicit.
3399
3400             elsif Present (Expression (Parent (Def_Id)))
3401               and then Comes_From_Source (Expression (Parent (Def_Id)))
3402             then
3403                Error_Msg_Sloc := Sloc (Def_Id);
3404                Error_Pragma_Arg
3405                  ("no initialization allowed for declaration of& #",
3406                   "\imported entities cannot be initialized (RM B.1(24))",
3407                   Arg2);
3408
3409             else
3410                Set_Imported (Def_Id);
3411                Process_Interface_Name (Def_Id, Arg3, Arg4);
3412
3413                --  Note that we do not set Is_Public here. That's because we
3414                --  only want to set it if there is no address clause, and we
3415                --  don't know that yet, so we delay that processing till
3416                --  freeze time.
3417
3418                --  pragma Import completes deferred constants
3419
3420                if Ekind (Def_Id) = E_Constant then
3421                   Set_Has_Completion (Def_Id);
3422                end if;
3423
3424                --  It is not possible to import a constant of an unconstrained
3425                --  array type (e.g. string) because there is no simple way to
3426                --  write a meaningful subtype for it.
3427
3428                if Is_Array_Type (Etype (Def_Id))
3429                  and then not Is_Constrained (Etype (Def_Id))
3430                then
3431                   Error_Msg_NE
3432                     ("imported constant& must have a constrained subtype",
3433                       N, Def_Id);
3434                end if;
3435             end if;
3436
3437          elsif Is_Subprogram (Def_Id)
3438            or else Is_Generic_Subprogram (Def_Id)
3439          then
3440             --  If the name is overloaded, pragma applies to all of the
3441             --  denoted entities in the same declarative part.
3442
3443             Hom_Id := Def_Id;
3444             while Present (Hom_Id) loop
3445                Def_Id := Get_Base_Subprogram (Hom_Id);
3446
3447                --  Ignore inherited subprograms because the pragma will
3448                --  apply to the parent operation, which is the one called.
3449
3450                if Is_Overloadable (Def_Id)
3451                  and then Present (Alias (Def_Id))
3452                then
3453                   null;
3454
3455                --  If it is not a subprogram, it must be in an outer scope and
3456                --  pragma does not apply.
3457
3458                elsif not Is_Subprogram (Def_Id)
3459                  and then not Is_Generic_Subprogram (Def_Id)
3460                then
3461                   null;
3462
3463                --  Verify that the homonym is in the same declarative part (not
3464                --  just the same scope).
3465
3466                elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
3467                  and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
3468                then
3469                   exit;
3470
3471                else
3472                   Set_Imported (Def_Id);
3473
3474                   --  Reject an Import applied to an abstract subprogram
3475
3476                   if Is_Subprogram (Def_Id)
3477                     and then Is_Abstract_Subprogram (Def_Id)
3478                   then
3479                      Error_Msg_Sloc := Sloc (Def_Id);
3480                      Error_Msg_NE
3481                        ("cannot import abstract subprogram& declared#",
3482                         Arg2, Def_Id);
3483                   end if;
3484
3485                   --  Special processing for Convention_Intrinsic
3486
3487                   if C = Convention_Intrinsic then
3488
3489                      --  Link_Name argument not allowed for intrinsic
3490
3491                      if Present (Arg3)
3492                        and then Chars (Arg3) = Name_Link_Name
3493                      then
3494                         Arg4 := Arg3;
3495                      end if;
3496
3497                      if Present (Arg4) then
3498                         Error_Pragma_Arg
3499                           ("Link_Name argument not allowed for " &
3500                            "Import Intrinsic",
3501                            Arg4);
3502                      end if;
3503
3504                      Set_Is_Intrinsic_Subprogram (Def_Id);
3505
3506                      --  If no external name is present, then check that this
3507                      --  is a valid intrinsic subprogram. If an external name
3508                      --  is present, then this is handled by the back end.
3509
3510                      if No (Arg3) then
3511                         Check_Intrinsic_Subprogram (Def_Id, Expression (Arg2));
3512                      end if;
3513                   end if;
3514
3515                   --  All interfaced procedures need an external symbol created
3516                   --  for them since they are always referenced from another
3517                   --  object file.
3518
3519                   Set_Is_Public (Def_Id);
3520
3521                   --  Verify that the subprogram does not have a completion
3522                   --  through a renaming declaration. For other completions the
3523                   --  pragma appears as a too late representation.
3524
3525                   declare
3526                      Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
3527
3528                   begin
3529                      if Present (Decl)
3530                        and then Nkind (Decl) = N_Subprogram_Declaration
3531                        and then Present (Corresponding_Body (Decl))
3532                        and then Nkind (Unit_Declaration_Node
3533                                         (Corresponding_Body (Decl))) =
3534                                              N_Subprogram_Renaming_Declaration
3535                      then
3536                         Error_Msg_Sloc := Sloc (Def_Id);
3537                         Error_Msg_NE
3538                           ("cannot import&, renaming already provided for " &
3539                            "declaration #", N, Def_Id);
3540                      end if;
3541                   end;
3542
3543                   Set_Has_Completion (Def_Id);
3544                   Process_Interface_Name (Def_Id, Arg3, Arg4);
3545                end if;
3546
3547                if Is_Compilation_Unit (Hom_Id) then
3548
3549                   --  Its possible homonyms are not affected by the pragma.
3550                   --  Such homonyms might be present in the context of other
3551                   --  units being compiled.
3552
3553                   exit;
3554
3555                else
3556                   Hom_Id := Homonym (Hom_Id);
3557                end if;
3558             end loop;
3559
3560          --  When the convention is Java or CIL, we also allow Import to be
3561          --  given for packages, generic packages, exceptions, record
3562          --  components, and access to subprograms.
3563
3564          elsif (C = Convention_Java or else C = Convention_CIL)
3565            and then
3566              (Is_Package_Or_Generic_Package (Def_Id)
3567                or else Ekind (Def_Id) = E_Exception
3568                or else Ekind (Def_Id) = E_Access_Subprogram_Type
3569                or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
3570          then
3571             Set_Imported (Def_Id);
3572             Set_Is_Public (Def_Id);
3573             Process_Interface_Name (Def_Id, Arg3, Arg4);
3574
3575          --  Import a CPP class
3576
3577          elsif Is_Record_Type (Def_Id)
3578            and then C = Convention_CPP
3579          then
3580             --  Types treated as CPP classes are treated as limited, but we
3581             --  don't require them to be declared this way. A warning is
3582             --  issued to encourage the user to declare them as limited.
3583             --  This is not an error, for compatibility reasons, because
3584             --  these types have been supported this way for some time.
3585
3586             if not Is_Limited_Type (Def_Id) then
3587                Error_Msg_N
3588                  ("imported 'C'P'P type should be " &
3589                     "explicitly declared limited?",
3590                   Get_Pragma_Arg (Arg2));
3591                Error_Msg_N
3592                  ("\type will be considered limited",
3593                   Get_Pragma_Arg (Arg2));
3594             end if;
3595
3596             Set_Is_CPP_Class (Def_Id);
3597             Set_Is_Limited_Record (Def_Id);
3598
3599             --  Imported CPP types must not have discriminants (because C++
3600             --  classes do not have discriminants).
3601
3602             if Has_Discriminants (Def_Id) then
3603                Error_Msg_N
3604                  ("imported 'C'P'P type cannot have discriminants",
3605                   First (Discriminant_Specifications
3606                           (Declaration_Node (Def_Id))));
3607             end if;
3608
3609             --  Components of imported CPP types must not have default
3610             --  expressions because the constructor (if any) is on the
3611             --  C++ side.
3612
3613             declare
3614                Tdef  : constant Node_Id :=
3615                          Type_Definition (Declaration_Node (Def_Id));
3616                Clist : Node_Id;
3617                Comp  : Node_Id;
3618
3619             begin
3620                if Nkind (Tdef) = N_Record_Definition then
3621                   Clist := Component_List (Tdef);
3622
3623                else
3624                   pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
3625                   Clist := Component_List (Record_Extension_Part (Tdef));
3626                end if;
3627
3628                if Present (Clist) then
3629                   Comp := First (Component_Items (Clist));
3630                   while Present (Comp) loop
3631                      if Present (Expression (Comp)) then
3632                         Error_Msg_N
3633                           ("component of imported 'C'P'P type cannot have" &
3634                            " default expression", Expression (Comp));
3635                      end if;
3636
3637                      Next (Comp);
3638                   end loop;
3639                end if;
3640             end;
3641
3642          else
3643             Error_Pragma_Arg
3644               ("second argument of pragma% must be object or subprogram",
3645                Arg2);
3646          end if;
3647
3648          --  If this pragma applies to a compilation unit, then the unit, which
3649          --  is a subprogram, does not require (or allow) a body. We also do
3650          --  not need to elaborate imported procedures.
3651
3652          if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
3653             declare
3654                Cunit : constant Node_Id := Parent (Parent (N));
3655             begin
3656                Set_Body_Required (Cunit, False);
3657             end;
3658          end if;
3659       end Process_Import_Or_Interface;
3660
3661       --------------------
3662       -- Process_Inline --
3663       --------------------
3664
3665       procedure Process_Inline (Active : Boolean) is
3666          Assoc     : Node_Id;
3667          Decl      : Node_Id;
3668          Subp_Id   : Node_Id;
3669          Subp      : Entity_Id;
3670          Applies   : Boolean;
3671          Effective : Boolean := False;
3672
3673          procedure Make_Inline (Subp : Entity_Id);
3674          --  Subp is the defining unit name of the subprogram declaration. Set
3675          --  the flag, as well as the flag in the corresponding body, if there
3676          --  is one present.
3677
3678          procedure Set_Inline_Flags (Subp : Entity_Id);
3679          --  Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
3680          --  Has_Pragma_Inline_Always for the Inline_Always case.
3681
3682          function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
3683          --  Returns True if it can be determined at this stage that inlining
3684          --  is not possible, for example if the body is available and contains
3685          --  exception handlers, we prevent inlining, since otherwise we can
3686          --  get undefined symbols at link time. This function also emits a
3687          --  warning if front-end inlining is enabled and the pragma appears
3688          --  too late.
3689          --
3690          --  ??? is business with link symbols still valid, or does it relate
3691          --  to front end ZCX which is being phased out ???
3692
3693          ---------------------------
3694          -- Inlining_Not_Possible --
3695          ---------------------------
3696
3697          function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
3698             Decl  : constant Node_Id := Unit_Declaration_Node (Subp);
3699             Stats : Node_Id;
3700
3701          begin
3702             if Nkind (Decl) = N_Subprogram_Body then
3703                Stats := Handled_Statement_Sequence (Decl);
3704                return Present (Exception_Handlers (Stats))
3705                  or else Present (At_End_Proc (Stats));
3706
3707             elsif Nkind (Decl) = N_Subprogram_Declaration
3708               and then Present (Corresponding_Body (Decl))
3709             then
3710                if Front_End_Inlining
3711                  and then Analyzed (Corresponding_Body (Decl))
3712                then
3713                   Error_Msg_N ("pragma appears too late, ignored?", N);
3714                   return True;
3715
3716                --  If the subprogram is a renaming as body, the body is just a
3717                --  call to the renamed subprogram, and inlining is trivially
3718                --  possible.
3719
3720                elsif
3721                  Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
3722                                              N_Subprogram_Renaming_Declaration
3723                then
3724                   return False;
3725
3726                else
3727                   Stats :=
3728                     Handled_Statement_Sequence
3729                         (Unit_Declaration_Node (Corresponding_Body (Decl)));
3730
3731                   return
3732                     Present (Exception_Handlers (Stats))
3733                       or else Present (At_End_Proc (Stats));
3734                end if;
3735
3736             else
3737                --  If body is not available, assume the best, the check is
3738                --  performed again when compiling enclosing package bodies.
3739
3740                return False;
3741             end if;
3742          end Inlining_Not_Possible;
3743
3744          -----------------
3745          -- Make_Inline --
3746          -----------------
3747
3748          procedure Make_Inline (Subp : Entity_Id) is
3749             Kind       : constant Entity_Kind := Ekind (Subp);
3750             Inner_Subp : Entity_Id   := Subp;
3751
3752          begin
3753             --  Ignore if bad type, avoid cascaded error
3754
3755             if Etype (Subp) = Any_Type then
3756                Applies := True;
3757                return;
3758
3759             --  Ignore if all inlining is suppressed
3760
3761             elsif Suppress_All_Inlining then
3762                Applies := True;
3763                return;
3764
3765             --  If inlining is not possible, for now do not treat as an error
3766
3767             elsif Inlining_Not_Possible (Subp) then
3768                Applies := True;
3769                return;
3770
3771             --  Here we have a candidate for inlining, but we must exclude
3772             --  derived operations. Otherwise we would end up trying to inline
3773             --  a phantom declaration, and the result would be to drag in a
3774             --  body which has no direct inlining associated with it. That
3775             --  would not only be inefficient but would also result in the
3776             --  backend doing cross-unit inlining in cases where it was
3777             --  definitely inappropriate to do so.
3778
3779             --  However, a simple Comes_From_Source test is insufficient, since
3780             --  we do want to allow inlining of generic instances which also do
3781             --  not come from source. We also need to recognize specs generated
3782             --  by the front-end for bodies that carry the pragma. Finally,
3783             --  predefined operators do not come from source but are not
3784             --  inlineable either.
3785
3786             elsif Is_Generic_Instance (Subp)
3787               or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
3788             then
3789                null;
3790
3791             elsif not Comes_From_Source (Subp)
3792               and then Scope (Subp) /= Standard_Standard
3793             then
3794                Applies := True;
3795                return;
3796             end if;
3797
3798             --  The referenced entity must either be the enclosing entity, or
3799             --  an entity declared within the current open scope.
3800
3801             if Present (Scope (Subp))
3802               and then Scope (Subp) /= Current_Scope
3803               and then Subp /= Current_Scope
3804             then
3805                Error_Pragma_Arg
3806                  ("argument of% must be entity in current scope", Assoc);
3807                return;
3808             end if;
3809
3810             --  Processing for procedure, operator or function. If subprogram
3811             --  is aliased (as for an instance) indicate that the renamed
3812             --  entity (if declared in the same unit) is inlined.
3813
3814             if Is_Subprogram (Subp) then
3815                while Present (Alias (Inner_Subp)) loop
3816                   Inner_Subp := Alias (Inner_Subp);
3817                end loop;
3818
3819                if In_Same_Source_Unit (Subp, Inner_Subp) then
3820                   Set_Inline_Flags (Inner_Subp);
3821
3822                   Decl := Parent (Parent (Inner_Subp));
3823
3824                   if Nkind (Decl) = N_Subprogram_Declaration
3825                     and then Present (Corresponding_Body (Decl))
3826                   then
3827                      Set_Inline_Flags (Corresponding_Body (Decl));
3828
3829                   elsif Is_Generic_Instance (Subp) then
3830
3831                      --  Indicate that the body needs to be created for
3832                      --  inlining subsequent calls. The instantiation node
3833                      --  follows the declaration of the wrapper package
3834                      --  created for it.
3835
3836                      if Scope (Subp) /= Standard_Standard
3837                        and then
3838                          Need_Subprogram_Instance_Body
3839                           (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
3840                               Subp)
3841                      then
3842                         null;
3843                      end if;
3844                   end if;
3845                end if;
3846
3847                Applies := True;
3848
3849             --  For a generic subprogram set flag as well, for use at the point
3850             --  of instantiation, to determine whether the body should be
3851             --  generated.
3852
3853             elsif Is_Generic_Subprogram (Subp) then
3854                Set_Inline_Flags (Subp);
3855                Applies := True;
3856
3857             --  Literals are by definition inlined
3858
3859             elsif Kind = E_Enumeration_Literal then
3860                null;
3861
3862             --  Anything else is an error
3863
3864             else
3865                Error_Pragma_Arg
3866                  ("expect subprogram name for pragma%", Assoc);
3867             end if;
3868          end Make_Inline;
3869
3870          ----------------------
3871          -- Set_Inline_Flags --
3872          ----------------------
3873
3874          procedure Set_Inline_Flags (Subp : Entity_Id) is
3875          begin
3876             if Active then
3877                Set_Is_Inlined (Subp, True);
3878             end if;
3879
3880             if not Has_Pragma_Inline (Subp) then
3881                Set_Has_Pragma_Inline (Subp);
3882                Effective := True;
3883             end if;
3884
3885             if Prag_Id = Pragma_Inline_Always then
3886                Set_Has_Pragma_Inline_Always (Subp);
3887             end if;
3888          end Set_Inline_Flags;
3889
3890       --  Start of processing for Process_Inline
3891
3892       begin
3893          Check_No_Identifiers;
3894          Check_At_Least_N_Arguments (1);
3895
3896          if Active then
3897             Inline_Processing_Required := True;
3898          end if;
3899
3900          Assoc := Arg1;
3901          while Present (Assoc) loop
3902             Subp_Id := Expression (Assoc);
3903             Analyze (Subp_Id);
3904             Applies := False;
3905
3906             if Is_Entity_Name (Subp_Id) then
3907                Subp := Entity (Subp_Id);
3908
3909                if Subp = Any_Id then
3910
3911                   --  If previous error, avoid cascaded errors
3912
3913                   Applies := True;
3914                   Effective := True;
3915
3916                else
3917                   Make_Inline (Subp);
3918
3919                   while Present (Homonym (Subp))
3920                     and then Scope (Homonym (Subp)) = Current_Scope
3921                   loop
3922                      Make_Inline (Homonym (Subp));
3923                      Subp := Homonym (Subp);
3924                   end loop;
3925                end if;
3926             end if;
3927
3928             if not Applies then
3929                Error_Pragma_Arg
3930                  ("inappropriate argument for pragma%", Assoc);
3931
3932             elsif not Effective
3933               and then Warn_On_Redundant_Constructs
3934               and then not Suppress_All_Inlining
3935             then
3936                if Inlining_Not_Possible (Subp) then
3937                   Error_Msg_NE
3938                     ("pragma Inline for& is ignored?", N, Entity (Subp_Id));
3939                else
3940                   Error_Msg_NE
3941                     ("pragma Inline for& is redundant?", N, Entity (Subp_Id));
3942                end if;
3943             end if;
3944
3945             Next (Assoc);
3946          end loop;
3947       end Process_Inline;
3948
3949       ----------------------------
3950       -- Process_Interface_Name --
3951       ----------------------------
3952
3953       procedure Process_Interface_Name
3954         (Subprogram_Def : Entity_Id;
3955          Ext_Arg        : Node_Id;
3956          Link_Arg       : Node_Id)
3957       is
3958          Ext_Nam    : Node_Id;
3959          Link_Nam   : Node_Id;
3960          String_Val : String_Id;
3961
3962          procedure Check_Form_Of_Interface_Name
3963            (SN            : Node_Id;
3964             Ext_Name_Case : Boolean);
3965          --  SN is a string literal node for an interface name. This routine
3966          --  performs some minimal checks that the name is reasonable. In
3967          --  particular that no spaces or other obviously incorrect characters
3968          --  appear. This is only a warning, since any characters are allowed.
3969          --  Ext_Name_Case is True for an External_Name, False for a Link_Name.
3970
3971          ----------------------------------
3972          -- Check_Form_Of_Interface_Name --
3973          ----------------------------------
3974
3975          procedure Check_Form_Of_Interface_Name
3976            (SN            : Node_Id;
3977             Ext_Name_Case : Boolean)
3978          is
3979             S  : constant String_Id := Strval (Expr_Value_S (SN));
3980             SL : constant Nat       := String_Length (S);
3981             C  : Char_Code;
3982
3983          begin
3984             if SL = 0 then
3985                Error_Msg_N ("interface name cannot be null string", SN);
3986             end if;
3987
3988             for J in 1 .. SL loop
3989                C := Get_String_Char (S, J);
3990
3991                --  Look for dubious character and issue unconditional warning.
3992                --  Definitely dubious if not in character range.
3993
3994                if not In_Character_Range (C)
3995
3996                   --  For all cases except CLI target,
3997                   --  commas, spaces and slashes are dubious (in CLI, we use
3998                   --  commas and backslashes in external names to specify
3999                   --  assembly version and public key, while slashes and spaces
4000                   --  can be used in names to mark nested classes and
4001                   --  valuetypes).
4002
4003                   or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
4004                              and then (Get_Character (C) = ','
4005                                          or else
4006                                        Get_Character (C) = '\'))
4007                  or else (VM_Target /= CLI_Target
4008                             and then (Get_Character (C) = ' '
4009                                         or else
4010                                       Get_Character (C) = '/'))
4011                then
4012                   Error_Msg
4013                     ("?interface name contains illegal character",
4014                      Sloc (SN) + Source_Ptr (J));
4015                end if;
4016             end loop;
4017          end Check_Form_Of_Interface_Name;
4018
4019       --  Start of processing for Process_Interface_Name
4020
4021       begin
4022          if No (Link_Arg) then
4023             if No (Ext_Arg) then
4024                if VM_Target = CLI_Target
4025                  and then Ekind (Subprogram_Def) = E_Package
4026                  and then Nkind (Parent (Subprogram_Def)) =
4027                                                  N_Package_Specification
4028                  and then Present (Generic_Parent (Parent (Subprogram_Def)))
4029                then
4030                   Set_Interface_Name
4031                      (Subprogram_Def,
4032                       Interface_Name
4033                         (Generic_Parent (Parent (Subprogram_Def))));
4034                end if;
4035
4036                return;
4037
4038             elsif Chars (Ext_Arg) = Name_Link_Name then
4039                Ext_Nam  := Empty;
4040                Link_Nam := Expression (Ext_Arg);
4041
4042             else
4043                Check_Optional_Identifier (Ext_Arg, Name_External_Name);
4044                Ext_Nam  := Expression (Ext_Arg);
4045                Link_Nam := Empty;
4046             end if;
4047
4048          else
4049             Check_Optional_Identifier (Ext_Arg,  Name_External_Name);
4050             Check_Optional_Identifier (Link_Arg, Name_Link_Name);
4051             Ext_Nam  := Expression (Ext_Arg);
4052             Link_Nam := Expression (Link_Arg);
4053          end if;
4054
4055          --  Check expressions for external name and link name are static
4056
4057          if Present (Ext_Nam) then
4058             Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
4059             Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
4060
4061             --  Verify that external name is not the name of a local entity,
4062             --  which would hide the imported one and could lead to run-time
4063             --  surprises. The problem can only arise for entities declared in
4064             --  a package body (otherwise the external name is fully qualified
4065             --  and will not conflict).
4066
4067             declare
4068                Nam : Name_Id;
4069                E   : Entity_Id;
4070                Par : Node_Id;
4071
4072             begin
4073                if Prag_Id = Pragma_Import then
4074                   String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
4075                   Nam := Name_Find;
4076                   E   := Entity_Id (Get_Name_Table_Info (Nam));
4077
4078                   if Nam /= Chars (Subprogram_Def)
4079                     and then Present (E)
4080                     and then not Is_Overloadable (E)
4081                     and then Is_Immediately_Visible (E)
4082                     and then not Is_Imported (E)
4083                     and then Ekind (Scope (E)) = E_Package
4084                   then
4085                      Par := Parent (E);
4086                      while Present (Par) loop
4087                         if Nkind (Par) = N_Package_Body then
4088                            Error_Msg_Sloc := Sloc (E);
4089                            Error_Msg_NE
4090                              ("imported entity is hidden by & declared#",
4091                               Ext_Arg, E);
4092                            exit;
4093                         end if;
4094
4095                         Par := Parent (Par);
4096                      end loop;
4097                   end if;
4098                end if;
4099             end;
4100          end if;
4101
4102          if Present (Link_Nam) then
4103             Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
4104             Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
4105          end if;
4106
4107          --  If there is no link name, just set the external name
4108
4109          if No (Link_Nam) then
4110             Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
4111
4112          --  For the Link_Name case, the given literal is preceded by an
4113          --  asterisk, which indicates to GCC that the given name should be
4114          --  taken literally, and in particular that no prepending of
4115          --  underlines should occur, even in systems where this is the
4116          --  normal default.
4117
4118          else
4119             Start_String;
4120
4121             if VM_Target = No_VM then
4122                Store_String_Char (Get_Char_Code ('*'));
4123             end if;
4124
4125             String_Val := Strval (Expr_Value_S (Link_Nam));
4126             Store_String_Chars (String_Val);
4127             Link_Nam :=
4128               Make_String_Literal (Sloc (Link_Nam),
4129                 Strval => End_String);
4130          end if;
4131
4132          Set_Encoded_Interface_Name
4133            (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
4134          Check_Duplicated_Export_Name (Link_Nam);
4135       end Process_Interface_Name;
4136
4137       -----------------------------------------
4138       -- Process_Interrupt_Or_Attach_Handler --
4139       -----------------------------------------
4140
4141       procedure Process_Interrupt_Or_Attach_Handler is
4142          Arg1_X       : constant Node_Id   := Expression (Arg1);
4143          Handler_Proc : constant Entity_Id := Entity (Arg1_X);
4144          Proc_Scope   : constant Entity_Id := Scope (Handler_Proc);
4145
4146       begin
4147          Set_Is_Interrupt_Handler (Handler_Proc);
4148
4149          --  If the pragma is not associated with a handler procedure within a
4150          --  protected type, then it must be for a nonprotected procedure for
4151          --  the AAMP target, in which case we don't associate a representation
4152          --  item with the procedure's scope.
4153
4154          if Ekind (Proc_Scope) = E_Protected_Type then
4155             if Prag_Id = Pragma_Interrupt_Handler
4156                  or else
4157                Prag_Id = Pragma_Attach_Handler
4158             then
4159                Record_Rep_Item (Proc_Scope, N);
4160             end if;
4161          end if;
4162       end Process_Interrupt_Or_Attach_Handler;
4163
4164       --------------------------------------------------
4165       -- Process_Restrictions_Or_Restriction_Warnings --
4166       --------------------------------------------------
4167
4168       --  Note: some of the simple identifier cases were handled in par-prag,
4169       --  but it is harmless (and more straightforward) to simply handle all
4170       --  cases here, even if it means we repeat a bit of work in some cases.
4171
4172       procedure Process_Restrictions_Or_Restriction_Warnings
4173         (Warn : Boolean)
4174       is
4175          Arg   : Node_Id;
4176          R_Id  : Restriction_Id;
4177          Id    : Name_Id;
4178          Expr  : Node_Id;
4179          Val   : Uint;
4180
4181          procedure Check_Unit_Name (N : Node_Id);
4182          --  Checks unit name parameter for No_Dependence. Returns if it has
4183          --  an appropriate form, otherwise raises pragma argument error.
4184
4185          ---------------------
4186          -- Check_Unit_Name --
4187          ---------------------
4188
4189          procedure Check_Unit_Name (N : Node_Id) is
4190          begin
4191             if Nkind (N) = N_Selected_Component then
4192                Check_Unit_Name (Prefix (N));
4193                Check_Unit_Name (Selector_Name (N));
4194
4195             elsif Nkind (N) = N_Identifier then
4196                return;
4197
4198             else
4199                Error_Pragma_Arg
4200                  ("wrong form for unit name for No_Dependence", N);
4201             end if;
4202          end Check_Unit_Name;
4203
4204       --  Start of processing for Process_Restrictions_Or_Restriction_Warnings
4205
4206       begin
4207          Check_Ada_83_Warning;
4208          Check_At_Least_N_Arguments (1);
4209          Check_Valid_Configuration_Pragma;
4210
4211          Arg := Arg1;
4212          while Present (Arg) loop
4213             Id := Chars (Arg);
4214             Expr := Expression (Arg);
4215
4216             --  Case of no restriction identifier present
4217
4218             if Id = No_Name then
4219                if Nkind (Expr) /= N_Identifier then
4220                   Error_Pragma_Arg
4221                     ("invalid form for restriction", Arg);
4222                end if;
4223
4224                R_Id :=
4225                  Get_Restriction_Id
4226                    (Process_Restriction_Synonyms (Expr));
4227
4228                if R_Id not in All_Boolean_Restrictions then
4229                   Error_Msg_Name_1 := Pname;
4230                   Error_Msg_N
4231                     ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
4232
4233                   --  Check for possible misspelling
4234
4235                   for J in Restriction_Id loop
4236                      declare
4237                         Rnm : constant String := Restriction_Id'Image (J);
4238
4239                      begin
4240                         Name_Buffer (1 .. Rnm'Length) := Rnm;
4241                         Name_Len := Rnm'Length;
4242                         Set_Casing (All_Lower_Case);
4243
4244                         if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
4245                            Set_Casing
4246                              (Identifier_Casing (Current_Source_File));
4247                            Error_Msg_String (1 .. Rnm'Length) :=
4248                              Name_Buffer (1 .. Name_Len);
4249                            Error_Msg_Strlen := Rnm'Length;
4250                            Error_Msg_N -- CODEFIX
4251                              ("\possible misspelling of ""~""",
4252                               Get_Pragma_Arg (Arg));
4253                            exit;
4254                         end if;
4255                      end;
4256                   end loop;
4257
4258                   raise Pragma_Exit;
4259                end if;
4260
4261                if Implementation_Restriction (R_Id) then
4262                   Check_Restriction (No_Implementation_Restrictions, Arg);
4263                end if;
4264
4265                --  If this is a warning, then set the warning unless we already
4266                --  have a real restriction active (we never want a warning to
4267                --  override a real restriction).
4268
4269                if Warn then
4270                   if not Restriction_Active (R_Id) then
4271                      Set_Restriction (R_Id, N);
4272                      Restriction_Warnings (R_Id) := True;
4273                   end if;
4274
4275                --  If real restriction case, then set it and make sure that the
4276                --  restriction warning flag is off, since a real restriction
4277                --  always overrides a warning.
4278
4279                else
4280                   Set_Restriction (R_Id, N);
4281                   Restriction_Warnings (R_Id) := False;
4282                end if;
4283
4284                --  A very special case that must be processed here: pragma
4285                --  Restrictions (No_Exceptions) turns off all run-time
4286                --  checking. This is a bit dubious in terms of the formal
4287                --  language definition, but it is what is intended by RM
4288                --  H.4(12). Restriction_Warnings never affects generated code
4289                --  so this is done only in the real restriction case.
4290
4291                if R_Id = No_Exceptions and then not Warn then
4292                   Scope_Suppress := (others => True);
4293                end if;
4294
4295             --  Case of No_Dependence => unit-name. Note that the parser
4296             --  already made the necessary entry in the No_Dependence table.
4297
4298             elsif Id = Name_No_Dependence then
4299                Check_Unit_Name (Expr);
4300
4301             --  All other cases of restriction identifier present
4302
4303             else
4304                R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
4305                Analyze_And_Resolve (Expr, Any_Integer);
4306
4307                if R_Id not in All_Parameter_Restrictions then
4308                   Error_Pragma_Arg
4309                     ("invalid restriction parameter identifier", Arg);
4310
4311                elsif not Is_OK_Static_Expression (Expr) then
4312                   Flag_Non_Static_Expr
4313                     ("value must be static expression!", Expr);
4314                   raise Pragma_Exit;
4315
4316                elsif not Is_Integer_Type (Etype (Expr))
4317                  or else Expr_Value (Expr) < 0
4318                then
4319                   Error_Pragma_Arg
4320                     ("value must be non-negative integer", Arg);
4321                end if;
4322
4323                --  Restriction pragma is active
4324
4325                Val := Expr_Value (Expr);
4326
4327                if not UI_Is_In_Int_Range (Val) then
4328                   Error_Pragma_Arg
4329                     ("pragma ignored, value too large?", Arg);
4330                end if;
4331
4332                --  Warning case. If the real restriction is active, then we
4333                --  ignore the request, since warning never overrides a real
4334                --  restriction. Otherwise we set the proper warning. Note that
4335                --  this circuit sets the warning again if it is already set,
4336                --  which is what we want, since the constant may have changed.
4337
4338                if Warn then
4339                   if not Restriction_Active (R_Id) then
4340                      Set_Restriction
4341                        (R_Id, N, Integer (UI_To_Int (Val)));
4342                      Restriction_Warnings (R_Id) := True;
4343                   end if;
4344
4345                --  Real restriction case, set restriction and make sure warning
4346                --  flag is off since real restriction always overrides warning.
4347
4348                else
4349                   Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
4350                   Restriction_Warnings (R_Id) := False;
4351                end if;
4352             end if;
4353
4354             Next (Arg);
4355          end loop;
4356       end Process_Restrictions_Or_Restriction_Warnings;
4357
4358       ---------------------------------
4359       -- Process_Suppress_Unsuppress --
4360       ---------------------------------
4361
4362       --  Note: this procedure makes entries in the check suppress data
4363       --  structures managed by Sem. See spec of package Sem for full
4364       --  details on how we handle recording of check suppression.
4365
4366       procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
4367          C    : Check_Id;
4368          E_Id : Node_Id;
4369          E    : Entity_Id;
4370
4371          In_Package_Spec : constant Boolean :=
4372                              Is_Package_Or_Generic_Package (Current_Scope)
4373                                and then not In_Package_Body (Current_Scope);
4374
4375          procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
4376          --  Used to suppress a single check on the given entity
4377
4378          --------------------------------
4379          -- Suppress_Unsuppress_Echeck --
4380          --------------------------------
4381
4382          procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
4383          begin
4384             Set_Checks_May_Be_Suppressed (E);
4385
4386             if In_Package_Spec then
4387                Push_Global_Suppress_Stack_Entry
4388                  (Entity   => E,
4389                   Check    => C,
4390                   Suppress => Suppress_Case);
4391
4392             else
4393                Push_Local_Suppress_Stack_Entry
4394                  (Entity   => E,
4395                   Check    => C,
4396                   Suppress => Suppress_Case);
4397             end if;
4398
4399             --  If this is a first subtype, and the base type is distinct,
4400             --  then also set the suppress flags on the base type.
4401
4402             if Is_First_Subtype (E)
4403               and then Etype (E) /= E
4404             then
4405                Suppress_Unsuppress_Echeck (Etype (E), C);
4406             end if;
4407          end Suppress_Unsuppress_Echeck;
4408
4409       --  Start of processing for Process_Suppress_Unsuppress
4410
4411       begin
4412          --  Suppress/Unsuppress can appear as a configuration pragma, or in a
4413          --  declarative part or a package spec (RM 11.5(5)).
4414
4415          if not Is_Configuration_Pragma then
4416             Check_Is_In_Decl_Part_Or_Package_Spec;
4417          end if;
4418
4419          Check_At_Least_N_Arguments (1);
4420          Check_At_Most_N_Arguments (2);
4421          Check_No_Identifier (Arg1);
4422          Check_Arg_Is_Identifier (Arg1);
4423
4424          C := Get_Check_Id (Chars (Expression (Arg1)));
4425
4426          if C = No_Check_Id then
4427             Error_Pragma_Arg
4428               ("argument of pragma% is not valid check name", Arg1);
4429          end if;
4430
4431          if not Suppress_Case
4432            and then (C = All_Checks or else C = Overflow_Check)
4433          then
4434             Opt.Overflow_Checks_Unsuppressed := True;
4435          end if;
4436
4437          if Arg_Count = 1 then
4438
4439             --  Make an entry in the local scope suppress table. This is the
4440             --  table that directly shows the current value of the scope
4441             --  suppress check for any check id value.
4442
4443             if C = All_Checks then
4444
4445                --  For All_Checks, we set all specific predefined checks with
4446                --  the exception of Elaboration_Check, which is handled
4447                --  specially because of not wanting All_Checks to have the
4448                --  effect of deactivating static elaboration order processing.
4449
4450                for J in Scope_Suppress'Range loop
4451                   if J /= Elaboration_Check then
4452                      Scope_Suppress (J) := Suppress_Case;
4453                   end if;
4454                end loop;
4455
4456             --  If not All_Checks, and predefined check, then set appropriate
4457             --  scope entry. Note that we will set Elaboration_Check if this
4458             --  is explicitly specified.
4459
4460             elsif C in Predefined_Check_Id then
4461                Scope_Suppress (C) := Suppress_Case;
4462             end if;
4463
4464             --  Also make an entry in the Local_Entity_Suppress table
4465
4466             Push_Local_Suppress_Stack_Entry
4467               (Entity   => Empty,
4468                Check    => C,
4469                Suppress => Suppress_Case);
4470
4471          --  Case of two arguments present, where the check is suppressed for
4472          --  a specified entity (given as the second argument of the pragma)
4473
4474          else
4475             Check_Optional_Identifier (Arg2, Name_On);
4476             E_Id := Expression (Arg2);
4477             Analyze (E_Id);
4478
4479             if not Is_Entity_Name (E_Id) then
4480                Error_Pragma_Arg
4481                  ("second argument of pragma% must be entity name", Arg2);
4482             end if;
4483
4484             E := Entity (E_Id);
4485
4486             if E = Any_Id then
4487                return;
4488             end if;
4489
4490             --  Enforce RM 11.5(7) which requires that for a pragma that
4491             --  appears within a package spec, the named entity must be
4492             --  within the package spec. We allow the package name itself
4493             --  to be mentioned since that makes sense, although it is not
4494             --  strictly allowed by 11.5(7).
4495
4496             if In_Package_Spec
4497               and then E /= Current_Scope
4498               and then Scope (E) /= Current_Scope
4499             then
4500                Error_Pragma_Arg
4501                  ("entity in pragma% is not in package spec (RM 11.5(7))",
4502                   Arg2);
4503             end if;
4504
4505             --  Loop through homonyms. As noted below, in the case of a package
4506             --  spec, only homonyms within the package spec are considered.
4507
4508             loop
4509                Suppress_Unsuppress_Echeck (E, C);
4510
4511                if Is_Generic_Instance (E)
4512                  and then Is_Subprogram (E)
4513                  and then Present (Alias (E))
4514                then
4515                   Suppress_Unsuppress_Echeck (Alias (E), C);
4516                end if;
4517
4518                --  Move to next homonym
4519
4520                E := Homonym (E);
4521                exit when No (E);
4522
4523                --  If we are within a package specification, the pragma only
4524                --  applies to homonyms in the same scope.
4525
4526                exit when In_Package_Spec
4527                  and then Scope (E) /= Current_Scope;
4528             end loop;
4529          end if;
4530       end Process_Suppress_Unsuppress;
4531
4532       ------------------
4533       -- Set_Exported --
4534       ------------------
4535
4536       procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
4537       begin
4538          if Is_Imported (E) then
4539             Error_Pragma_Arg
4540               ("cannot export entity& that was previously imported", Arg);
4541
4542          elsif Present (Address_Clause (E)) then
4543             Error_Pragma_Arg
4544               ("cannot export entity& that has an address clause", Arg);
4545          end if;
4546
4547          Set_Is_Exported (E);
4548
4549          --  Generate a reference for entity explicitly, because the
4550          --  identifier may be overloaded and name resolution will not
4551          --  generate one.
4552
4553          Generate_Reference (E, Arg);
4554
4555          --  Deal with exporting non-library level entity
4556
4557          if not Is_Library_Level_Entity (E) then
4558
4559             --  Not allowed at all for subprograms
4560
4561             if Is_Subprogram (E) then
4562                Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
4563
4564             --  Otherwise set public and statically allocated
4565
4566             else
4567                Set_Is_Public (E);
4568                Set_Is_Statically_Allocated (E);
4569
4570                --  Warn if the corresponding W flag is set and the pragma comes
4571                --  from source. The latter may not be true e.g. on VMS where we
4572                --  expand export pragmas for exception codes associated with
4573                --  imported or exported exceptions. We do not want to generate
4574                --  a warning for something that the user did not write.
4575
4576                if Warn_On_Export_Import
4577                  and then Comes_From_Source (Arg)
4578                then
4579                   Error_Msg_NE
4580                     ("?& has been made static as a result of Export", Arg, E);
4581                   Error_Msg_N
4582                     ("\this usage is non-standard and non-portable", Arg);
4583                end if;
4584             end if;
4585          end if;
4586
4587          if Warn_On_Export_Import and then Is_Type (E) then
4588             Error_Msg_NE
4589               ("exporting a type has no effect?", Arg, E);
4590          end if;
4591
4592          if Warn_On_Export_Import and Inside_A_Generic then
4593             Error_Msg_NE
4594               ("all instances of& will have the same external name?", Arg, E);
4595          end if;
4596       end Set_Exported;
4597
4598       ----------------------------------------------
4599       -- Set_Extended_Import_Export_External_Name --
4600       ----------------------------------------------
4601
4602       procedure Set_Extended_Import_Export_External_Name
4603         (Internal_Ent : Entity_Id;
4604          Arg_External : Node_Id)
4605       is
4606          Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
4607          New_Name : Node_Id;
4608
4609       begin
4610          if No (Arg_External) then
4611             return;
4612          end if;
4613
4614          Check_Arg_Is_External_Name (Arg_External);
4615
4616          if Nkind (Arg_External) = N_String_Literal then
4617             if String_Length (Strval (Arg_External)) = 0 then
4618                return;
4619             else
4620                New_Name := Adjust_External_Name_Case (Arg_External);
4621             end if;
4622
4623          elsif Nkind (Arg_External) = N_Identifier then
4624             New_Name := Get_Default_External_Name (Arg_External);
4625
4626          --  Check_Arg_Is_External_Name should let through only identifiers and
4627          --  string literals or static string expressions (which are folded to
4628          --  string literals).
4629
4630          else
4631             raise Program_Error;
4632          end if;
4633
4634          --  If we already have an external name set (by a prior normal Import
4635          --  or Export pragma), then the external names must match
4636
4637          if Present (Interface_Name (Internal_Ent)) then
4638             Check_Matching_Internal_Names : declare
4639                S1 : constant String_Id := Strval (Old_Name);
4640                S2 : constant String_Id := Strval (New_Name);
4641
4642                procedure Mismatch;
4643                --  Called if names do not match
4644
4645                --------------
4646                -- Mismatch --
4647                --------------
4648
4649                procedure Mismatch is
4650                begin
4651                   Error_Msg_Sloc := Sloc (Old_Name);
4652                   Error_Pragma_Arg
4653                     ("external name does not match that given #",
4654                      Arg_External);
4655                end Mismatch;
4656
4657             --  Start of processing for Check_Matching_Internal_Names
4658
4659             begin
4660                if String_Length (S1) /= String_Length (S2) then
4661                   Mismatch;
4662
4663                else
4664                   for J in 1 .. String_Length (S1) loop
4665                      if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
4666                         Mismatch;
4667                      end if;
4668                   end loop;
4669                end if;
4670             end Check_Matching_Internal_Names;
4671
4672          --  Otherwise set the given name
4673
4674          else
4675             Set_Encoded_Interface_Name (Internal_Ent, New_Name);
4676             Check_Duplicated_Export_Name (New_Name);
4677          end if;
4678       end Set_Extended_Import_Export_External_Name;
4679
4680       ------------------
4681       -- Set_Imported --
4682       ------------------
4683
4684       procedure Set_Imported (E : Entity_Id) is
4685       begin
4686          --  Error message if already imported or exported
4687
4688          if Is_Exported (E) or else Is_Imported (E) then
4689             if Is_Exported (E) then
4690                Error_Msg_NE ("entity& was previously exported", N, E);
4691             else
4692                Error_Msg_NE ("entity& was previously imported", N, E);
4693             end if;
4694
4695             Error_Msg_Name_1 := Pname;
4696             Error_Msg_N
4697               ("\(pragma% applies to all previous entities)", N);
4698
4699             Error_Msg_Sloc  := Sloc (E);
4700             Error_Msg_NE ("\import not allowed for& declared#", N, E);
4701
4702          --  Here if not previously imported or exported, OK to import
4703
4704          else
4705             Set_Is_Imported (E);
4706
4707             --  If the entity is an object that is not at the library level,
4708             --  then it is statically allocated. We do not worry about objects
4709             --  with address clauses in this context since they are not really
4710             --  imported in the linker sense.
4711
4712             if Is_Object (E)
4713               and then not Is_Library_Level_Entity (E)
4714               and then No (Address_Clause (E))
4715             then
4716                Set_Is_Statically_Allocated (E);
4717             end if;
4718          end if;
4719       end Set_Imported;
4720
4721       -------------------------
4722       -- Set_Mechanism_Value --
4723       -------------------------
4724
4725       --  Note: the mechanism name has not been analyzed (and cannot indeed be
4726       --  analyzed, since it is semantic nonsense), so we get it in the exact
4727       --  form created by the parser.
4728
4729       procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
4730          Class : Node_Id;
4731          Param : Node_Id;
4732          Mech_Name_Id : Name_Id;
4733
4734          procedure Bad_Class;
4735          --  Signal bad descriptor class name
4736
4737          procedure Bad_Mechanism;
4738          --  Signal bad mechanism name
4739
4740          ---------------
4741          -- Bad_Class --
4742          ---------------
4743
4744          procedure Bad_Class is
4745          begin
4746             Error_Pragma_Arg ("unrecognized descriptor class name", Class);
4747          end Bad_Class;
4748
4749          -------------------------
4750          -- Bad_Mechanism_Value --
4751          -------------------------
4752
4753          procedure Bad_Mechanism is
4754          begin
4755             Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
4756          end Bad_Mechanism;
4757
4758       --  Start of processing for Set_Mechanism_Value
4759
4760       begin
4761          if Mechanism (Ent) /= Default_Mechanism then
4762             Error_Msg_NE
4763               ("mechanism for & has already been set", Mech_Name, Ent);
4764          end if;
4765
4766          --  MECHANISM_NAME ::= value | reference | descriptor |
4767          --                     short_descriptor
4768
4769          if Nkind (Mech_Name) = N_Identifier then
4770             if Chars (Mech_Name) = Name_Value then
4771                Set_Mechanism (Ent, By_Copy);
4772                return;
4773
4774             elsif Chars (Mech_Name) = Name_Reference then
4775                Set_Mechanism (Ent, By_Reference);
4776                return;
4777
4778             elsif Chars (Mech_Name) = Name_Descriptor then
4779                Check_VMS (Mech_Name);
4780                Set_Mechanism (Ent, By_Descriptor);
4781                return;
4782
4783             elsif Chars (Mech_Name) = Name_Short_Descriptor then
4784                Check_VMS (Mech_Name);
4785                Set_Mechanism (Ent, By_Short_Descriptor);
4786                return;
4787
4788             elsif Chars (Mech_Name) = Name_Copy then
4789                Error_Pragma_Arg
4790                  ("bad mechanism name, Value assumed", Mech_Name);
4791
4792             else
4793                Bad_Mechanism;
4794             end if;
4795
4796          --  MECHANISM_NAME ::= descriptor (CLASS_NAME) |
4797          --                     short_descriptor (CLASS_NAME)
4798          --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
4799
4800          --  Note: this form is parsed as an indexed component
4801
4802          elsif Nkind (Mech_Name) = N_Indexed_Component then
4803
4804             Class := First (Expressions (Mech_Name));
4805
4806             if Nkind (Prefix (Mech_Name)) /= N_Identifier
4807              or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else
4808                           Chars (Prefix (Mech_Name)) = Name_Short_Descriptor)
4809              or else Present (Next (Class))
4810             then
4811                Bad_Mechanism;
4812             else
4813                Mech_Name_Id := Chars (Prefix (Mech_Name));
4814             end if;
4815
4816          --  MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
4817          --                     short_descriptor (Class => CLASS_NAME)
4818          --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
4819
4820          --  Note: this form is parsed as a function call
4821
4822          elsif Nkind (Mech_Name) = N_Function_Call then
4823
4824             Param := First (Parameter_Associations (Mech_Name));
4825
4826             if Nkind (Name (Mech_Name)) /= N_Identifier
4827               or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else
4828                            Chars (Name (Mech_Name)) = Name_Short_Descriptor)
4829               or else Present (Next (Param))
4830               or else No (Selector_Name (Param))
4831               or else Chars (Selector_Name (Param)) /= Name_Class
4832             then
4833                Bad_Mechanism;
4834             else
4835                Class := Explicit_Actual_Parameter (Param);
4836                Mech_Name_Id := Chars (Name (Mech_Name));
4837             end if;
4838
4839          else
4840             Bad_Mechanism;
4841          end if;
4842
4843          --  Fall through here with Class set to descriptor class name
4844
4845          Check_VMS (Mech_Name);
4846
4847          if Nkind (Class) /= N_Identifier then
4848             Bad_Class;
4849
4850          elsif Mech_Name_Id = Name_Descriptor
4851                and then Chars (Class) = Name_UBS
4852          then
4853             Set_Mechanism (Ent, By_Descriptor_UBS);
4854
4855          elsif Mech_Name_Id = Name_Descriptor
4856                and then Chars (Class) = Name_UBSB
4857          then
4858             Set_Mechanism (Ent, By_Descriptor_UBSB);
4859
4860          elsif Mech_Name_Id = Name_Descriptor
4861                and then Chars (Class) = Name_UBA
4862          then
4863             Set_Mechanism (Ent, By_Descriptor_UBA);
4864
4865          elsif Mech_Name_Id = Name_Descriptor
4866                and then Chars (Class) = Name_S
4867          then
4868             Set_Mechanism (Ent, By_Descriptor_S);
4869
4870          elsif Mech_Name_Id = Name_Descriptor
4871                and then Chars (Class) = Name_SB
4872          then
4873             Set_Mechanism (Ent, By_Descriptor_SB);
4874
4875          elsif Mech_Name_Id = Name_Descriptor
4876                and then Chars (Class) = Name_A
4877          then
4878             Set_Mechanism (Ent, By_Descriptor_A);
4879
4880          elsif Mech_Name_Id = Name_Descriptor
4881                and then Chars (Class) = Name_NCA
4882          then
4883             Set_Mechanism (Ent, By_Descriptor_NCA);
4884
4885          elsif Mech_Name_Id = Name_Short_Descriptor
4886                and then Chars (Class) = Name_UBS
4887          then
4888             Set_Mechanism (Ent, By_Short_Descriptor_UBS);
4889
4890          elsif Mech_Name_Id = Name_Short_Descriptor
4891                and then Chars (Class) = Name_UBSB
4892          then
4893             Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
4894
4895          elsif Mech_Name_Id = Name_Short_Descriptor
4896                and then Chars (Class) = Name_UBA
4897          then
4898             Set_Mechanism (Ent, By_Short_Descriptor_UBA);
4899
4900          elsif Mech_Name_Id = Name_Short_Descriptor
4901                and then Chars (Class) = Name_S
4902          then
4903             Set_Mechanism (Ent, By_Short_Descriptor_S);
4904
4905          elsif Mech_Name_Id = Name_Short_Descriptor
4906                and then Chars (Class) = Name_SB
4907          then
4908             Set_Mechanism (Ent, By_Short_Descriptor_SB);
4909
4910          elsif Mech_Name_Id = Name_Short_Descriptor
4911                and then Chars (Class) = Name_A
4912          then
4913             Set_Mechanism (Ent, By_Short_Descriptor_A);
4914
4915          elsif Mech_Name_Id = Name_Short_Descriptor
4916                and then Chars (Class) = Name_NCA
4917          then
4918             Set_Mechanism (Ent, By_Short_Descriptor_NCA);
4919
4920          else
4921             Bad_Class;
4922          end if;
4923       end Set_Mechanism_Value;
4924
4925       ---------------------------
4926       -- Set_Ravenscar_Profile --
4927       ---------------------------
4928
4929       --  The tasks to be done here are
4930
4931       --    Set required policies
4932
4933       --      pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
4934       --      pragma Locking_Policy (Ceiling_Locking)
4935
4936       --    Set Detect_Blocking mode
4937
4938       --    Set required restrictions (see System.Rident for detailed list)
4939
4940       procedure Set_Ravenscar_Profile (N : Node_Id) is
4941       begin
4942          --  pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
4943
4944          if Task_Dispatching_Policy /= ' '
4945            and then Task_Dispatching_Policy /= 'F'
4946          then
4947             Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
4948             Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
4949
4950          --  Set the FIFO_Within_Priorities policy, but always preserve
4951          --  System_Location since we like the error message with the run time
4952          --  name.
4953
4954          else
4955             Task_Dispatching_Policy := 'F';
4956
4957             if Task_Dispatching_Policy_Sloc /= System_Location then
4958                Task_Dispatching_Policy_Sloc := Loc;
4959             end if;
4960          end if;
4961
4962          --  pragma Locking_Policy (Ceiling_Locking)
4963
4964          if Locking_Policy /= ' '
4965            and then Locking_Policy /= 'C'
4966          then
4967             Error_Msg_Sloc := Locking_Policy_Sloc;
4968             Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
4969
4970          --  Set the Ceiling_Locking policy, but preserve System_Location since
4971          --  we like the error message with the run time name.
4972
4973          else
4974             Locking_Policy := 'C';
4975
4976             if Locking_Policy_Sloc /= System_Location then
4977                Locking_Policy_Sloc := Loc;
4978             end if;
4979          end if;
4980
4981          --  pragma Detect_Blocking
4982
4983          Detect_Blocking := True;
4984
4985          --  Set the corresponding restrictions
4986
4987          Set_Profile_Restrictions
4988            (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
4989       end Set_Ravenscar_Profile;
4990
4991    --  Start of processing for Analyze_Pragma
4992
4993    begin
4994       --  Deal with unrecognized pragma
4995
4996       if not Is_Pragma_Name (Pname) then
4997          if Warn_On_Unrecognized_Pragma then
4998             Error_Msg_Name_1 := Pname;
4999             Error_Msg_N ("?unrecognized pragma%!", Pragma_Identifier (N));
5000
5001             for PN in First_Pragma_Name .. Last_Pragma_Name loop
5002                if Is_Bad_Spelling_Of (Pname, PN) then
5003                   Error_Msg_Name_1 := PN;
5004                   Error_Msg_N -- CODEFIX
5005                     ("\?possible misspelling of %!", Pragma_Identifier (N));
5006                   exit;
5007                end if;
5008             end loop;
5009          end if;
5010
5011          return;
5012       end if;
5013
5014       --  Here to start processing for recognized pragma
5015
5016       Prag_Id := Get_Pragma_Id (Pname);
5017
5018       --  Preset arguments
5019
5020       Arg1 := Empty;
5021       Arg2 := Empty;
5022       Arg3 := Empty;
5023       Arg4 := Empty;
5024
5025       if Present (Pragma_Argument_Associations (N)) then
5026          Arg1 := First (Pragma_Argument_Associations (N));
5027
5028          if Present (Arg1) then
5029             Arg2 := Next (Arg1);
5030
5031             if Present (Arg2) then
5032                Arg3 := Next (Arg2);
5033
5034                if Present (Arg3) then
5035                   Arg4 := Next (Arg3);
5036                end if;
5037             end if;
5038          end if;
5039       end if;
5040
5041       --  Count number of arguments
5042
5043       declare
5044          Arg_Node : Node_Id;
5045       begin
5046          Arg_Count := 0;
5047          Arg_Node := Arg1;
5048          while Present (Arg_Node) loop
5049             Arg_Count := Arg_Count + 1;
5050             Next (Arg_Node);
5051          end loop;
5052       end;
5053
5054       --  An enumeration type defines the pragmas that are supported by the
5055       --  implementation. Get_Pragma_Id (in package Prag) transforms a name
5056       --  into the corresponding enumeration value for the following case.
5057
5058       case Prag_Id is
5059
5060          -----------------
5061          -- Abort_Defer --
5062          -----------------
5063
5064          --  pragma Abort_Defer;
5065
5066          when Pragma_Abort_Defer =>
5067             GNAT_Pragma;
5068             Check_Arg_Count (0);
5069
5070             --  The only required semantic processing is to check the
5071             --  placement. This pragma must appear at the start of the
5072             --  statement sequence of a handled sequence of statements.
5073
5074             if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
5075               or else N /= First (Statements (Parent (N)))
5076             then
5077                Pragma_Misplaced;
5078             end if;
5079
5080          ------------
5081          -- Ada_83 --
5082          ------------
5083
5084          --  pragma Ada_83;
5085
5086          --  Note: this pragma also has some specific processing in Par.Prag
5087          --  because we want to set the Ada version mode during parsing.
5088
5089          when Pragma_Ada_83 =>
5090             GNAT_Pragma;
5091             Check_Arg_Count (0);
5092
5093             --  We really should check unconditionally for proper configuration
5094             --  pragma placement, since we really don't want mixed Ada modes
5095             --  within a single unit, and the GNAT reference manual has always
5096             --  said this was a configuration pragma, but we did not check and
5097             --  are hesitant to add the check now.
5098
5099             --  However, we really cannot tolerate mixing Ada 2005 with Ada 83
5100             --  or Ada 95, so we must check if we are in Ada 2005 mode.
5101
5102             if Ada_Version >= Ada_05 then
5103                Check_Valid_Configuration_Pragma;
5104             end if;
5105
5106             --  Now set Ada 83 mode
5107
5108             Ada_Version := Ada_83;
5109             Ada_Version_Explicit := Ada_Version;
5110
5111          ------------
5112          -- Ada_95 --
5113          ------------
5114
5115          --  pragma Ada_95;
5116
5117          --  Note: this pragma also has some specific processing in Par.Prag
5118          --  because we want to set the Ada 83 version mode during parsing.
5119
5120          when Pragma_Ada_95 =>
5121             GNAT_Pragma;
5122             Check_Arg_Count (0);
5123
5124             --  We really should check unconditionally for proper configuration
5125             --  pragma placement, since we really don't want mixed Ada modes
5126             --  within a single unit, and the GNAT reference manual has always
5127             --  said this was a configuration pragma, but we did not check and
5128             --  are hesitant to add the check now.
5129
5130             --  However, we really cannot tolerate mixing Ada 2005 with Ada 83
5131             --  or Ada 95, so we must check if we are in Ada 2005 mode.
5132
5133             if Ada_Version >= Ada_05 then
5134                Check_Valid_Configuration_Pragma;
5135             end if;
5136
5137             --  Now set Ada 95 mode
5138
5139             Ada_Version := Ada_95;
5140             Ada_Version_Explicit := Ada_Version;
5141
5142          ---------------------
5143          -- Ada_05/Ada_2005 --
5144          ---------------------
5145
5146          --  pragma Ada_05;
5147          --  pragma Ada_05 (LOCAL_NAME);
5148
5149          --  pragma Ada_2005;
5150          --  pragma Ada_2005 (LOCAL_NAME):
5151
5152          --  Note: these pragma also have some specific processing in Par.Prag
5153          --  because we want to set the Ada 2005 version mode during parsing.
5154
5155          when Pragma_Ada_05 | Pragma_Ada_2005 => declare
5156             E_Id : Node_Id;
5157
5158          begin
5159             GNAT_Pragma;
5160
5161             if Arg_Count = 1 then
5162                Check_Arg_Is_Local_Name (Arg1);
5163                E_Id := Expression (Arg1);
5164
5165                if Etype (E_Id) = Any_Type then
5166                   return;
5167                end if;
5168
5169                Set_Is_Ada_2005_Only (Entity (E_Id));
5170
5171             else
5172                Check_Arg_Count (0);
5173
5174                --  For Ada_2005 we unconditionally enforce the documented
5175                --  configuration pragma placement, since we do not want to
5176                --  tolerate mixed modes in a unit involving Ada 2005. That
5177                --  would cause real difficulties for those cases where there
5178                --  are incompatibilities between Ada 95 and Ada 2005.
5179
5180                Check_Valid_Configuration_Pragma;
5181
5182                --  Now set Ada 2005 mode
5183
5184                Ada_Version := Ada_05;
5185                Ada_Version_Explicit := Ada_05;
5186             end if;
5187          end;
5188
5189          ----------------------
5190          -- All_Calls_Remote --
5191          ----------------------
5192
5193          --  pragma All_Calls_Remote [(library_package_NAME)];
5194
5195          when Pragma_All_Calls_Remote => All_Calls_Remote : declare
5196             Lib_Entity : Entity_Id;
5197
5198          begin
5199             Check_Ada_83_Warning;
5200             Check_Valid_Library_Unit_Pragma;
5201
5202             if Nkind (N) = N_Null_Statement then
5203                return;
5204             end if;
5205
5206             Lib_Entity := Find_Lib_Unit_Name;
5207
5208             --  This pragma should only apply to a RCI unit (RM E.2.3(23))
5209
5210             if Present (Lib_Entity)
5211               and then not Debug_Flag_U
5212             then
5213                if not Is_Remote_Call_Interface (Lib_Entity) then
5214                   Error_Pragma ("pragma% only apply to rci unit");
5215
5216                --  Set flag for entity of the library unit
5217
5218                else
5219                   Set_Has_All_Calls_Remote (Lib_Entity);
5220                end if;
5221
5222             end if;
5223          end All_Calls_Remote;
5224
5225          --------------
5226          -- Annotate --
5227          --------------
5228
5229          --  pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
5230          --  ARG ::= NAME | EXPRESSION
5231
5232          --  The first two arguments are by convention intended to refer to an
5233          --  external tool and a tool-specific function. These arguments are
5234          --  not analyzed.
5235
5236          when Pragma_Annotate => Annotate : begin
5237             GNAT_Pragma;
5238             Check_At_Least_N_Arguments (1);
5239             Check_Arg_Is_Identifier (Arg1);
5240
5241             declare
5242                Arg : Node_Id;
5243                Exp : Node_Id;
5244
5245             begin
5246                --  Second unanalyzed parameter is optional
5247
5248                if No (Arg2) then
5249                   null;
5250                else
5251                   Arg := Next (Arg2);
5252                   while Present (Arg) loop
5253                      Exp := Expression (Arg);
5254                      Analyze (Exp);
5255
5256                      if Is_Entity_Name (Exp) then
5257                         null;
5258
5259                      elsif Nkind (Exp) = N_String_Literal then
5260                         Resolve (Exp, Standard_String);
5261
5262                      elsif Is_Overloaded (Exp) then
5263                            Error_Pragma_Arg
5264                              ("ambiguous argument for pragma%", Exp);
5265
5266                      else
5267                         Resolve (Exp);
5268                      end if;
5269
5270                      Next (Arg);
5271                   end loop;
5272                end if;
5273             end;
5274          end Annotate;
5275
5276          ------------
5277          -- Assert --
5278          ------------
5279
5280          --  pragma Assert ([Check =>] Boolean_EXPRESSION
5281          --                 [, [Message =>] Static_String_EXPRESSION]);
5282
5283          when Pragma_Assert => Assert : declare
5284             Expr : Node_Id;
5285             Newa : List_Id;
5286
5287          begin
5288             Ada_2005_Pragma;
5289             Check_At_Least_N_Arguments (1);
5290             Check_At_Most_N_Arguments (2);
5291             Check_Arg_Order ((Name_Check, Name_Message));
5292             Check_Optional_Identifier (Arg1, Name_Check);
5293
5294             --  We treat pragma Assert as equivalent to:
5295
5296             --    pragma Check (Assertion, condition [, msg]);
5297
5298             --  So rewrite pragma in this manner, and analyze the result
5299
5300             Expr := Get_Pragma_Arg (Arg1);
5301             Newa := New_List (
5302               Make_Pragma_Argument_Association (Loc,
5303                 Expression =>
5304                   Make_Identifier (Loc,
5305                     Chars => Name_Assertion)),
5306
5307               Make_Pragma_Argument_Association (Sloc (Expr),
5308                 Expression => Expr));
5309
5310             if Arg_Count > 1 then
5311                Check_Optional_Identifier (Arg2, Name_Message);
5312                Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String);
5313                Append_To (Newa, Relocate_Node (Arg2));
5314             end if;
5315
5316             Rewrite (N,
5317               Make_Pragma (Loc,
5318                 Chars => Name_Check,
5319                 Pragma_Argument_Associations => Newa));
5320             Analyze (N);
5321          end Assert;
5322
5323          ----------------------
5324          -- Assertion_Policy --
5325          ----------------------
5326
5327          --  pragma Assertion_Policy (Check | Ignore)
5328
5329          when Pragma_Assertion_Policy => Assertion_Policy : declare
5330             Policy : Node_Id;
5331
5332          begin
5333             Ada_2005_Pragma;
5334             Check_Valid_Configuration_Pragma;
5335             Check_Arg_Count (1);
5336             Check_No_Identifiers;
5337             Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
5338
5339             --  We treat pragma Assertion_Policy as equivalent to:
5340
5341             --    pragma Check_Policy (Assertion, policy)
5342
5343             --  So rewrite the pragma in that manner and link on to the chain
5344             --  of Check_Policy pragmas, marking the pragma as analyzed.
5345
5346             Policy := Get_Pragma_Arg (Arg1);
5347
5348             Rewrite (N,
5349               Make_Pragma (Loc,
5350                 Chars => Name_Check_Policy,
5351
5352                 Pragma_Argument_Associations => New_List (
5353                   Make_Pragma_Argument_Association (Loc,
5354                     Expression =>
5355                       Make_Identifier (Loc,
5356                         Chars => Name_Assertion)),
5357
5358                   Make_Pragma_Argument_Association (Loc,
5359                     Expression =>
5360                       Make_Identifier (Sloc (Policy),
5361                         Chars => Chars (Policy))))));
5362
5363             Set_Analyzed (N);
5364             Set_Next_Pragma (N, Opt.Check_Policy_List);
5365             Opt.Check_Policy_List := N;
5366          end Assertion_Policy;
5367
5368          ------------------------------
5369          -- Assume_No_Invalid_Values --
5370          ------------------------------
5371
5372          --  pragma Assume_No_Invalid_Values (On | Off);
5373
5374          when Pragma_Assume_No_Invalid_Values =>
5375             GNAT_Pragma;
5376             Check_Valid_Configuration_Pragma;
5377             Check_Arg_Count (1);
5378             Check_No_Identifiers;
5379             Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
5380
5381             if Chars (Expression (Arg1)) = Name_On then
5382                Assume_No_Invalid_Values := True;
5383             else
5384                Assume_No_Invalid_Values := False;
5385             end if;
5386
5387          ---------------
5388          -- AST_Entry --
5389          ---------------
5390
5391          --  pragma AST_Entry (entry_IDENTIFIER);
5392
5393          when Pragma_AST_Entry => AST_Entry : declare
5394             Ent : Node_Id;
5395
5396          begin
5397             GNAT_Pragma;
5398             Check_VMS (N);
5399             Check_Arg_Count (1);
5400             Check_No_Identifiers;
5401             Check_Arg_Is_Local_Name (Arg1);
5402             Ent := Entity (Expression (Arg1));
5403
5404             --  Note: the implementation of the AST_Entry pragma could handle
5405             --  the entry family case fine, but for now we are consistent with
5406             --  the DEC rules, and do not allow the pragma, which of course
5407             --  has the effect of also forbidding the attribute.
5408
5409             if Ekind (Ent) /= E_Entry then
5410                Error_Pragma_Arg
5411                  ("pragma% argument must be simple entry name", Arg1);
5412
5413             elsif Is_AST_Entry (Ent) then
5414                Error_Pragma_Arg
5415                  ("duplicate % pragma for entry", Arg1);
5416
5417             elsif Has_Homonym (Ent) then
5418                Error_Pragma_Arg
5419                  ("pragma% argument cannot specify overloaded entry", Arg1);
5420
5421             else
5422                declare
5423                   FF : constant Entity_Id := First_Formal (Ent);
5424
5425                begin
5426                   if Present (FF) then
5427                      if Present (Next_Formal (FF)) then
5428                         Error_Pragma_Arg
5429                           ("entry for pragma% can have only one argument",
5430                            Arg1);
5431
5432                      elsif Parameter_Mode (FF) /= E_In_Parameter then
5433                         Error_Pragma_Arg
5434                           ("entry parameter for pragma% must have mode IN",
5435                            Arg1);
5436                      end if;
5437                   end if;
5438                end;
5439
5440                Set_Is_AST_Entry (Ent);
5441             end if;
5442          end AST_Entry;
5443
5444          ------------------
5445          -- Asynchronous --
5446          ------------------
5447
5448          --  pragma Asynchronous (LOCAL_NAME);
5449
5450          when Pragma_Asynchronous => Asynchronous : declare
5451             Nm     : Entity_Id;
5452             C_Ent  : Entity_Id;
5453             L      : List_Id;
5454             S      : Node_Id;
5455             N      : Node_Id;
5456             Formal : Entity_Id;
5457
5458             procedure Process_Async_Pragma;
5459             --  Common processing for procedure and access-to-procedure case
5460
5461             --------------------------
5462             -- Process_Async_Pragma --
5463             --------------------------
5464
5465             procedure Process_Async_Pragma is
5466             begin
5467                if No (L) then
5468                   Set_Is_Asynchronous (Nm);
5469                   return;
5470                end if;
5471
5472                --  The formals should be of mode IN (RM E.4.1(6))
5473
5474                S := First (L);
5475                while Present (S) loop
5476                   Formal := Defining_Identifier (S);
5477
5478                   if Nkind (Formal) = N_Defining_Identifier
5479                     and then Ekind (Formal) /= E_In_Parameter
5480                   then
5481                      Error_Pragma_Arg
5482                        ("pragma% procedure can only have IN parameter",
5483                         Arg1);
5484                   end if;
5485
5486                   Next (S);
5487                end loop;
5488
5489                Set_Is_Asynchronous (Nm);
5490             end Process_Async_Pragma;
5491
5492          --  Start of processing for pragma Asynchronous
5493
5494          begin
5495             Check_Ada_83_Warning;
5496             Check_No_Identifiers;
5497             Check_Arg_Count (1);
5498             Check_Arg_Is_Local_Name (Arg1);
5499
5500             if Debug_Flag_U then
5501                return;
5502             end if;
5503
5504             C_Ent := Cunit_Entity (Current_Sem_Unit);
5505             Analyze (Expression (Arg1));
5506             Nm := Entity (Expression (Arg1));
5507
5508             if not Is_Remote_Call_Interface (C_Ent)
5509               and then not Is_Remote_Types (C_Ent)
5510             then
5511                --  This pragma should only appear in an RCI or Remote Types
5512                --  unit (RM E.4.1(4)).
5513
5514                Error_Pragma
5515                  ("pragma% not in Remote_Call_Interface or " &
5516                   "Remote_Types unit");
5517             end if;
5518
5519             if Ekind (Nm) = E_Procedure
5520               and then Nkind (Parent (Nm)) = N_Procedure_Specification
5521             then
5522                if not Is_Remote_Call_Interface (Nm) then
5523                   Error_Pragma_Arg
5524                     ("pragma% cannot be applied on non-remote procedure",
5525                      Arg1);
5526                end if;
5527
5528                L := Parameter_Specifications (Parent (Nm));
5529                Process_Async_Pragma;
5530                return;
5531
5532             elsif Ekind (Nm) = E_Function then
5533                Error_Pragma_Arg
5534                  ("pragma% cannot be applied to function", Arg1);
5535
5536             elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
5537
5538                   if Is_Record_Type (Nm) then
5539
5540                   --  A record type that is the Equivalent_Type for a remote
5541                   --  access-to-subprogram type.
5542
5543                      N := Declaration_Node (Corresponding_Remote_Type (Nm));
5544
5545                   else
5546                      --  A non-expanded RAS type (distribution is not enabled)
5547
5548                      N := Declaration_Node (Nm);
5549                   end if;
5550
5551                if Nkind (N) = N_Full_Type_Declaration
5552                  and then Nkind (Type_Definition (N)) =
5553                                      N_Access_Procedure_Definition
5554                then
5555                   L := Parameter_Specifications (Type_Definition (N));
5556                   Process_Async_Pragma;
5557
5558                   if Is_Asynchronous (Nm)
5559                     and then Expander_Active
5560                     and then Get_PCS_Name /= Name_No_DSA
5561                   then
5562                      RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
5563                   end if;
5564
5565                else
5566                   Error_Pragma_Arg
5567                     ("pragma% cannot reference access-to-function type",
5568                     Arg1);
5569                end if;
5570
5571             --  Only other possibility is Access-to-class-wide type
5572
5573             elsif Is_Access_Type (Nm)
5574               and then Is_Class_Wide_Type (Designated_Type (Nm))
5575             then
5576                Check_First_Subtype (Arg1);
5577                Set_Is_Asynchronous (Nm);
5578                if Expander_Active then
5579                   RACW_Type_Is_Asynchronous (Nm);
5580                end if;
5581
5582             else
5583                Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
5584             end if;
5585          end Asynchronous;
5586
5587          ------------
5588          -- Atomic --
5589          ------------
5590
5591          --  pragma Atomic (LOCAL_NAME);
5592
5593          when Pragma_Atomic =>
5594             Process_Atomic_Shared_Volatile;
5595
5596          -----------------------
5597          -- Atomic_Components --
5598          -----------------------
5599
5600          --  pragma Atomic_Components (array_LOCAL_NAME);
5601
5602          --  This processing is shared by Volatile_Components
5603
5604          when Pragma_Atomic_Components   |
5605               Pragma_Volatile_Components =>
5606
5607          Atomic_Components : declare
5608             E_Id : Node_Id;
5609             E    : Entity_Id;
5610             D    : Node_Id;
5611             K    : Node_Kind;
5612
5613          begin
5614             Check_Ada_83_Warning;
5615             Check_No_Identifiers;
5616             Check_Arg_Count (1);
5617             Check_Arg_Is_Local_Name (Arg1);
5618             E_Id := Expression (Arg1);
5619
5620             if Etype (E_Id) = Any_Type then
5621                return;
5622             end if;
5623
5624             E := Entity (E_Id);
5625
5626             if Rep_Item_Too_Early (E, N)
5627                  or else
5628                Rep_Item_Too_Late (E, N)
5629             then
5630                return;
5631             end if;
5632
5633             D := Declaration_Node (E);
5634             K := Nkind (D);
5635
5636             if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
5637               or else
5638                 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
5639                    and then Nkind (D) = N_Object_Declaration
5640                    and then Nkind (Object_Definition (D)) =
5641                                        N_Constrained_Array_Definition)
5642             then
5643                --  The flag is set on the object, or on the base type
5644
5645                if Nkind (D) /= N_Object_Declaration then
5646                   E := Base_Type (E);
5647                end if;
5648
5649                Set_Has_Volatile_Components (E);
5650
5651                if Prag_Id = Pragma_Atomic_Components then
5652                   Set_Has_Atomic_Components (E);
5653
5654                   if Is_Packed (E) then
5655                      Set_Is_Packed (E, False);
5656
5657                      Error_Pragma_Arg
5658                        ("?Pack canceled, cannot pack atomic components",
5659                         Arg1);
5660                   end if;
5661                end if;
5662
5663             else
5664                Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
5665             end if;
5666          end Atomic_Components;
5667
5668          --------------------
5669          -- Attach_Handler --
5670          --------------------
5671
5672          --  pragma Attach_Handler (handler_NAME, EXPRESSION);
5673
5674          when Pragma_Attach_Handler =>
5675             Check_Ada_83_Warning;
5676             Check_No_Identifiers;
5677             Check_Arg_Count (2);
5678
5679             if No_Run_Time_Mode then
5680                Error_Msg_CRT ("Attach_Handler pragma", N);
5681             else
5682                Check_Interrupt_Or_Attach_Handler;
5683
5684                --  The expression that designates the attribute may
5685                --  depend on a discriminant, and is therefore a per-
5686                --  object expression, to be expanded in the init proc.
5687                --  If expansion is enabled, perform semantic checks
5688                --  on a copy only.
5689
5690                if Expander_Active then
5691                   declare
5692                      Temp : constant Node_Id :=
5693                               New_Copy_Tree (Expression (Arg2));
5694                   begin
5695                      Set_Parent (Temp, N);
5696                      Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
5697                   end;
5698
5699                else
5700                   Analyze (Expression (Arg2));
5701                   Resolve (Expression (Arg2), RTE (RE_Interrupt_ID));
5702                end if;
5703
5704                Process_Interrupt_Or_Attach_Handler;
5705             end if;
5706
5707          --------------------
5708          -- C_Pass_By_Copy --
5709          --------------------
5710
5711          --  pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
5712
5713          when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
5714             Arg : Node_Id;
5715             Val : Uint;
5716
5717          begin
5718             GNAT_Pragma;
5719             Check_Valid_Configuration_Pragma;
5720             Check_Arg_Count (1);
5721             Check_Optional_Identifier (Arg1, "max_size");
5722
5723             Arg := Expression (Arg1);
5724             Check_Arg_Is_Static_Expression (Arg, Any_Integer);
5725
5726             Val := Expr_Value (Arg);
5727
5728             if Val <= 0 then
5729                Error_Pragma_Arg
5730                  ("maximum size for pragma% must be positive", Arg1);
5731
5732             elsif UI_Is_In_Int_Range (Val) then
5733                Default_C_Record_Mechanism := UI_To_Int (Val);
5734
5735             --  If a giant value is given, Int'Last will do well enough.
5736             --  If sometime someone complains that a record larger than
5737             --  two gigabytes is not copied, we will worry about it then!
5738
5739             else
5740                Default_C_Record_Mechanism := Mechanism_Type'Last;
5741             end if;
5742          end C_Pass_By_Copy;
5743
5744          -----------
5745          -- Check --
5746          -----------
5747
5748          --  pragma Check ([Name    =>] Identifier,
5749          --                [Check   =>] Boolean_Expression
5750          --              [,[Message =>] String_Expression]);
5751
5752          when Pragma_Check => Check : declare
5753             Expr : Node_Id;
5754             Eloc : Source_Ptr;
5755
5756             Check_On : Boolean;
5757             --  Set True if category of assertions referenced by Name enabled
5758
5759          begin
5760             GNAT_Pragma;
5761             Check_At_Least_N_Arguments (2);
5762             Check_At_Most_N_Arguments (3);
5763             Check_Optional_Identifier (Arg1, Name_Name);
5764             Check_Optional_Identifier (Arg2, Name_Check);
5765
5766             if Arg_Count = 3 then
5767                Check_Optional_Identifier (Arg3, Name_Message);
5768                Analyze_And_Resolve (Get_Pragma_Arg (Arg3), Standard_String);
5769             end if;
5770
5771             Check_Arg_Is_Identifier (Arg1);
5772             Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
5773
5774             --  If expansion is active and the check is not enabled then we
5775             --  rewrite the Check as:
5776
5777             --    if False and then condition then
5778             --       null;
5779             --    end if;
5780
5781             --  The reason we do this rewriting during semantic analysis rather
5782             --  than as part of normal expansion is that we cannot analyze and
5783             --  expand the code for the boolean expression directly, or it may
5784             --  cause insertion of actions that would escape the attempt to
5785             --  suppress the check code.
5786
5787             --  Note that the Sloc for the if statement corresponds to the
5788             --  argument condition, not the pragma itself. The reason for this
5789             --  is that we may generate a warning if the condition is False at
5790             --  compile time, and we do not want to delete this warning when we
5791             --  delete the if statement.
5792
5793             Expr := Expression (Arg2);
5794
5795             if Expander_Active and then not Check_On then
5796                Eloc := Sloc (Expr);
5797
5798                Rewrite (N,
5799                  Make_If_Statement (Eloc,
5800                    Condition =>
5801                      Make_And_Then (Eloc,
5802                        Left_Opnd  => New_Occurrence_Of (Standard_False, Eloc),
5803                        Right_Opnd => Expr),
5804                    Then_Statements => New_List (
5805                      Make_Null_Statement (Eloc))));
5806
5807                Analyze (N);
5808
5809             --  Check is active
5810
5811             else
5812                Analyze_And_Resolve (Expr, Any_Boolean);
5813             end if;
5814          end Check;
5815
5816          ----------------
5817          -- Check_Name --
5818          ----------------
5819
5820          --  pragma Check_Name (check_IDENTIFIER);
5821
5822          when Pragma_Check_Name =>
5823             Check_No_Identifiers;
5824             GNAT_Pragma;
5825             Check_Valid_Configuration_Pragma;
5826             Check_Arg_Count (1);
5827             Check_Arg_Is_Identifier (Arg1);
5828
5829             declare
5830                Nam : constant Name_Id := Chars (Expression (Arg1));
5831
5832             begin
5833                for J in Check_Names.First .. Check_Names.Last loop
5834                   if Check_Names.Table (J) = Nam then
5835                      return;
5836                   end if;
5837                end loop;
5838
5839                Check_Names.Append (Nam);
5840             end;
5841
5842          ------------------
5843          -- Check_Policy --
5844          ------------------
5845
5846          --  pragma Check_Policy (
5847          --    [Name   =>] IDENTIFIER,
5848          --    [Policy =>] POLICY_IDENTIFIER);
5849
5850          --  POLICY_IDENTIFIER ::= ON | OFF | CHECK | IGNORE
5851
5852          --  Note: this is a configuration pragma, but it is allowed to appear
5853          --  anywhere else.
5854
5855          when Pragma_Check_Policy =>
5856             GNAT_Pragma;
5857             Check_Arg_Count (2);
5858             Check_Optional_Identifier (Arg1, Name_Name);
5859             Check_Optional_Identifier (Arg2, Name_Policy);
5860             Check_Arg_Is_One_Of
5861               (Arg2, Name_On, Name_Off, Name_Check, Name_Ignore);
5862
5863             --  A Check_Policy pragma can appear either as a configuration
5864             --  pragma, or in a declarative part or a package spec (see RM
5865             --  11.5(5) for rules for Suppress/Unsuppress which are also
5866             --  followed for Check_Policy).
5867
5868             if not Is_Configuration_Pragma then
5869                Check_Is_In_Decl_Part_Or_Package_Spec;
5870             end if;
5871
5872             Set_Next_Pragma (N, Opt.Check_Policy_List);
5873             Opt.Check_Policy_List := N;
5874
5875          ---------------------
5876          -- CIL_Constructor --
5877          ---------------------
5878
5879          --  pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
5880
5881          --  Processing for this pragma is shared with Java_Constructor
5882
5883          -------------
5884          -- Comment --
5885          -------------
5886
5887          --  pragma Comment (static_string_EXPRESSION)
5888
5889          --  Processing for pragma Comment shares the circuitry for pragma
5890          --  Ident. The only differences are that Ident enforces a limit of 31
5891          --  characters on its argument, and also enforces limitations on
5892          --  placement for DEC compatibility. Pragma Comment shares neither of
5893          --  these restrictions.
5894
5895          -------------------
5896          -- Common_Object --
5897          -------------------
5898
5899          --  pragma Common_Object (
5900          --        [Internal =>] LOCAL_NAME
5901          --     [, [External =>] EXTERNAL_SYMBOL]
5902          --     [, [Size     =>] EXTERNAL_SYMBOL]);
5903
5904          --  Processing for this pragma is shared with Psect_Object
5905
5906          ------------------------
5907          -- Compile_Time_Error --
5908          ------------------------
5909
5910          --  pragma Compile_Time_Error
5911          --    (boolean_EXPRESSION, static_string_EXPRESSION);
5912
5913          when Pragma_Compile_Time_Error =>
5914             GNAT_Pragma;
5915             Process_Compile_Time_Warning_Or_Error;
5916
5917          --------------------------
5918          -- Compile_Time_Warning --
5919          --------------------------
5920
5921          --  pragma Compile_Time_Warning
5922          --    (boolean_EXPRESSION, static_string_EXPRESSION);
5923
5924          when Pragma_Compile_Time_Warning =>
5925             GNAT_Pragma;
5926             Process_Compile_Time_Warning_Or_Error;
5927
5928          -------------------
5929          -- Compiler_Unit --
5930          -------------------
5931
5932          when Pragma_Compiler_Unit =>
5933             GNAT_Pragma;
5934             Check_Arg_Count (0);
5935             Set_Is_Compiler_Unit (Get_Source_Unit (N));
5936
5937          -----------------------------
5938          -- Complete_Representation --
5939          -----------------------------
5940
5941          --  pragma Complete_Representation;
5942
5943          when Pragma_Complete_Representation =>
5944             GNAT_Pragma;
5945             Check_Arg_Count (0);
5946
5947             if Nkind (Parent (N)) /= N_Record_Representation_Clause then
5948                Error_Pragma
5949                  ("pragma & must appear within record representation clause");
5950             end if;
5951
5952          ----------------------------
5953          -- Complex_Representation --
5954          ----------------------------
5955
5956          --  pragma Complex_Representation ([Entity =>] LOCAL_NAME);
5957
5958          when Pragma_Complex_Representation => Complex_Representation : declare
5959             E_Id : Entity_Id;
5960             E    : Entity_Id;
5961             Ent  : Entity_Id;
5962
5963          begin
5964             GNAT_Pragma;
5965             Check_Arg_Count (1);
5966             Check_Optional_Identifier (Arg1, Name_Entity);
5967             Check_Arg_Is_Local_Name (Arg1);
5968             E_Id := Expression (Arg1);
5969
5970             if Etype (E_Id) = Any_Type then
5971                return;
5972             end if;
5973
5974             E := Entity (E_Id);
5975
5976             if not Is_Record_Type (E) then
5977                Error_Pragma_Arg
5978                  ("argument for pragma% must be record type", Arg1);
5979             end if;
5980
5981             Ent := First_Entity (E);
5982
5983             if No (Ent)
5984               or else No (Next_Entity (Ent))
5985               or else Present (Next_Entity (Next_Entity (Ent)))
5986               or else not Is_Floating_Point_Type (Etype (Ent))
5987               or else Etype (Ent) /= Etype (Next_Entity (Ent))
5988             then
5989                Error_Pragma_Arg
5990                  ("record for pragma% must have two fields of the same "
5991                   & "floating-point type", Arg1);
5992
5993             else
5994                Set_Has_Complex_Representation (Base_Type (E));
5995
5996                --  We need to treat the type has having a non-standard
5997                --  representation, for back-end purposes, even though in
5998                --  general a complex will have the default representation
5999                --  of a record with two real components.
6000
6001                Set_Has_Non_Standard_Rep (Base_Type (E));
6002             end if;
6003          end Complex_Representation;
6004
6005          -------------------------
6006          -- Component_Alignment --
6007          -------------------------
6008
6009          --  pragma Component_Alignment (
6010          --        [Form =>] ALIGNMENT_CHOICE
6011          --     [, [Name =>] type_LOCAL_NAME]);
6012          --
6013          --   ALIGNMENT_CHOICE ::=
6014          --     Component_Size
6015          --   | Component_Size_4
6016          --   | Storage_Unit
6017          --   | Default
6018
6019          when Pragma_Component_Alignment => Component_AlignmentP : declare
6020             Args  : Args_List (1 .. 2);
6021             Names : constant Name_List (1 .. 2) := (
6022                       Name_Form,
6023                       Name_Name);
6024
6025             Form  : Node_Id renames Args (1);
6026             Name  : Node_Id renames Args (2);
6027
6028             Atype : Component_Alignment_Kind;
6029             Typ   : Entity_Id;
6030
6031          begin
6032             GNAT_Pragma;
6033             Gather_Associations (Names, Args);
6034
6035             if No (Form) then
6036                Error_Pragma ("missing Form argument for pragma%");
6037             end if;
6038
6039             Check_Arg_Is_Identifier (Form);
6040
6041             --  Get proper alignment, note that Default = Component_Size on all
6042             --  machines we have so far, and we want to set this value rather
6043             --  than the default value to indicate that it has been explicitly
6044             --  set (and thus will not get overridden by the default component
6045             --  alignment for the current scope)
6046
6047             if Chars (Form) = Name_Component_Size then
6048                Atype := Calign_Component_Size;
6049
6050             elsif Chars (Form) = Name_Component_Size_4 then
6051                Atype := Calign_Component_Size_4;
6052
6053             elsif Chars (Form) = Name_Default then
6054                Atype := Calign_Component_Size;
6055
6056             elsif Chars (Form) = Name_Storage_Unit then
6057                Atype := Calign_Storage_Unit;
6058
6059             else
6060                Error_Pragma_Arg
6061                  ("invalid Form parameter for pragma%", Form);
6062             end if;
6063
6064             --  Case with no name, supplied, affects scope table entry
6065
6066             if No (Name) then
6067                Scope_Stack.Table
6068                  (Scope_Stack.Last).Component_Alignment_Default := Atype;
6069
6070             --  Case of name supplied
6071
6072             else
6073                Check_Arg_Is_Local_Name (Name);
6074                Find_Type (Name);
6075                Typ := Entity (Name);
6076
6077                if Typ = Any_Type
6078                  or else Rep_Item_Too_Early (Typ, N)
6079                then
6080                   return;
6081                else
6082                   Typ := Underlying_Type (Typ);
6083                end if;
6084
6085                if not Is_Record_Type (Typ)
6086                  and then not Is_Array_Type (Typ)
6087                then
6088                   Error_Pragma_Arg
6089                     ("Name parameter of pragma% must identify record or " &
6090                      "array type", Name);
6091                end if;
6092
6093                --  An explicit Component_Alignment pragma overrides an
6094                --  implicit pragma Pack, but not an explicit one.
6095
6096                if not Has_Pragma_Pack (Base_Type (Typ)) then
6097                   Set_Is_Packed (Base_Type (Typ), False);
6098                   Set_Component_Alignment (Base_Type (Typ), Atype);
6099                end if;
6100             end if;
6101          end Component_AlignmentP;
6102
6103          ----------------
6104          -- Controlled --
6105          ----------------
6106
6107          --  pragma Controlled (first_subtype_LOCAL_NAME);
6108
6109          when Pragma_Controlled => Controlled : declare
6110             Arg : Node_Id;
6111
6112          begin
6113             Check_No_Identifiers;
6114             Check_Arg_Count (1);
6115             Check_Arg_Is_Local_Name (Arg1);
6116             Arg := Expression (Arg1);
6117
6118             if not Is_Entity_Name (Arg)
6119               or else not Is_Access_Type (Entity (Arg))
6120             then
6121                Error_Pragma_Arg ("pragma% requires access type", Arg1);
6122             else
6123                Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
6124             end if;
6125          end Controlled;
6126
6127          ----------------
6128          -- Convention --
6129          ----------------
6130
6131          --  pragma Convention ([Convention =>] convention_IDENTIFIER,
6132          --    [Entity =>] LOCAL_NAME);
6133
6134          when Pragma_Convention => Convention : declare
6135             C : Convention_Id;
6136             E : Entity_Id;
6137             pragma Warnings (Off, C);
6138             pragma Warnings (Off, E);
6139          begin
6140             Check_Arg_Order ((Name_Convention, Name_Entity));
6141             Check_Ada_83_Warning;
6142             Check_Arg_Count (2);
6143             Process_Convention (C, E);
6144          end Convention;
6145
6146          ---------------------------
6147          -- Convention_Identifier --
6148          ---------------------------
6149
6150          --  pragma Convention_Identifier ([Name =>] IDENTIFIER,
6151          --    [Convention =>] convention_IDENTIFIER);
6152
6153          when Pragma_Convention_Identifier => Convention_Identifier : declare
6154             Idnam : Name_Id;
6155             Cname : Name_Id;
6156
6157          begin
6158             GNAT_Pragma;
6159             Check_Arg_Order ((Name_Name, Name_Convention));
6160             Check_Arg_Count (2);
6161             Check_Optional_Identifier (Arg1, Name_Name);
6162             Check_Optional_Identifier (Arg2, Name_Convention);
6163             Check_Arg_Is_Identifier (Arg1);
6164             Check_Arg_Is_Identifier (Arg2);
6165             Idnam := Chars (Expression (Arg1));
6166             Cname := Chars (Expression (Arg2));
6167
6168             if Is_Convention_Name (Cname) then
6169                Record_Convention_Identifier
6170                  (Idnam, Get_Convention_Id (Cname));
6171             else
6172                Error_Pragma_Arg
6173                  ("second arg for % pragma must be convention", Arg2);
6174             end if;
6175          end Convention_Identifier;
6176
6177          ---------------
6178          -- CPP_Class --
6179          ---------------
6180
6181          --  pragma CPP_Class ([Entity =>] local_NAME)
6182
6183          when Pragma_CPP_Class => CPP_Class : declare
6184             Arg : Node_Id;
6185             Typ : Entity_Id;
6186
6187          begin
6188             if Warn_On_Obsolescent_Feature then
6189                Error_Msg_N
6190                  ("'G'N'A'T pragma cpp'_class is now obsolete; replace it" &
6191                   " by pragma import?", N);
6192             end if;
6193
6194             GNAT_Pragma;
6195             Check_Arg_Count (1);
6196             Check_Optional_Identifier (Arg1, Name_Entity);
6197             Check_Arg_Is_Local_Name (Arg1);
6198
6199             Arg := Expression (Arg1);
6200             Analyze (Arg);
6201
6202             if Etype (Arg) = Any_Type then
6203                return;
6204             end if;
6205
6206             if not Is_Entity_Name (Arg)
6207               or else not Is_Type (Entity (Arg))
6208             then
6209                Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
6210             end if;
6211
6212             Typ := Entity (Arg);
6213
6214             if not Is_Tagged_Type (Typ) then
6215                Error_Pragma_Arg ("pragma% applicable to tagged types ", Arg1);
6216             end if;
6217
6218             --  Types treated as CPP classes are treated as limited, but we
6219             --  don't require them to be declared this way. A warning is issued
6220             --  to encourage the user to declare them as limited. This is not
6221             --  an error, for compatibility reasons, because these types have
6222             --  been supported this way for some time.
6223
6224             if not Is_Limited_Type (Typ) then
6225                Error_Msg_N
6226                  ("imported 'C'P'P type should be " &
6227                     "explicitly declared limited?",
6228                   Get_Pragma_Arg (Arg1));
6229                Error_Msg_N
6230                  ("\type will be considered limited",
6231                   Get_Pragma_Arg (Arg1));
6232             end if;
6233
6234             Set_Is_CPP_Class      (Typ);
6235             Set_Is_Limited_Record (Typ);
6236             Set_Convention        (Typ, Convention_CPP);
6237
6238             --  Imported CPP types must not have discriminants (because C++
6239             --  classes do not have discriminants).
6240
6241             if Has_Discriminants (Typ) then
6242                Error_Msg_N
6243                  ("imported 'C'P'P type cannot have discriminants",
6244                   First (Discriminant_Specifications
6245                           (Declaration_Node (Typ))));
6246             end if;
6247
6248             --  Components of imported CPP types must not have default
6249             --  expressions because the constructor (if any) is in the
6250             --  C++ side.
6251
6252             if Is_Incomplete_Or_Private_Type (Typ)
6253               and then No (Underlying_Type (Typ))
6254             then
6255                --  It should be an error to apply pragma CPP to a private
6256                --  type if the underlying type is not visible (as it is
6257                --  for any representation item). For now, for backward
6258                --  compatibility we do nothing but we cannot check components
6259                --  because they are not available at this stage. All this code
6260                --  will be removed when we cleanup this obsolete GNAT pragma???
6261
6262                null;
6263
6264             else
6265                declare
6266                   Tdef  : constant Node_Id :=
6267                             Type_Definition (Declaration_Node (Typ));
6268                   Clist : Node_Id;
6269                   Comp  : Node_Id;
6270
6271                begin
6272                   if Nkind (Tdef) = N_Record_Definition then
6273                      Clist := Component_List (Tdef);
6274                   else
6275                      pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
6276                      Clist := Component_List (Record_Extension_Part (Tdef));
6277                   end if;
6278
6279                   if Present (Clist) then
6280                      Comp := First (Component_Items (Clist));
6281                      while Present (Comp) loop
6282                         if Present (Expression (Comp)) then
6283                            Error_Msg_N
6284                              ("component of imported 'C'P'P type cannot have" &
6285                               " default expression", Expression (Comp));
6286                         end if;
6287
6288                         Next (Comp);
6289                      end loop;
6290                   end if;
6291                end;
6292             end if;
6293          end CPP_Class;
6294
6295          ---------------------
6296          -- CPP_Constructor --
6297          ---------------------
6298
6299          --  pragma CPP_Constructor ([Entity =>] LOCAL_NAME
6300          --    [, [External_Name =>] static_string_EXPRESSION ]
6301          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
6302
6303          when Pragma_CPP_Constructor => CPP_Constructor : declare
6304             Elmt    : Elmt_Id;
6305             Id      : Entity_Id;
6306             Def_Id  : Entity_Id;
6307             Tag_Typ : Entity_Id;
6308
6309          begin
6310             GNAT_Pragma;
6311             Check_At_Least_N_Arguments (1);
6312             Check_At_Most_N_Arguments (3);
6313             Check_Optional_Identifier (Arg1, Name_Entity);
6314             Check_Arg_Is_Local_Name (Arg1);
6315
6316             Id := Expression (Arg1);
6317             Find_Program_Unit_Name (Id);
6318
6319             --  If we did not find the name, we are done
6320
6321             if Etype (Id) = Any_Type then
6322                return;
6323             end if;
6324
6325             Def_Id := Entity (Id);
6326
6327             if Ekind (Def_Id) = E_Function
6328               and then (Is_CPP_Class (Etype (Def_Id))
6329                          or else (Is_Class_Wide_Type (Etype (Def_Id))
6330                                    and then
6331                                   Is_CPP_Class (Root_Type (Etype (Def_Id)))))
6332             then
6333                if Arg_Count >= 2 then
6334                   Set_Imported (Def_Id);
6335                   Set_Is_Public (Def_Id);
6336                   Process_Interface_Name (Def_Id, Arg2, Arg3);
6337                end if;
6338
6339                Set_Has_Completion (Def_Id);
6340                Set_Is_Constructor (Def_Id);
6341
6342                --  Imported C++ constructors are not dispatching primitives
6343                --  because in C++ they don't have a dispatch table slot.
6344                --  However, in Ada the constructor has the profile of a
6345                --  function that returns a tagged type and therefore it has
6346                --  been treated as a primitive operation during semantic
6347                --  analysis. We now remove it from the list of primitive
6348                --  operations of the type.
6349
6350                if Is_Tagged_Type (Etype (Def_Id))
6351                  and then not Is_Class_Wide_Type (Etype (Def_Id))
6352                then
6353                   pragma Assert (Is_Dispatching_Operation (Def_Id));
6354                   Tag_Typ := Etype (Def_Id);
6355
6356                   Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
6357                   while Present (Elmt) and then Node (Elmt) /= Def_Id loop
6358                      Next_Elmt (Elmt);
6359                   end loop;
6360
6361                   Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
6362                   Set_Is_Dispatching_Operation (Def_Id, False);
6363                end if;
6364
6365                --  For backward compatibility, if the constructor returns a
6366                --  class wide type, and we internally change the return type to
6367                --  the corresponding root type.
6368
6369                if Is_Class_Wide_Type (Etype (Def_Id)) then
6370                   Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
6371                end if;
6372             else
6373                Error_Pragma_Arg
6374                  ("pragma% requires function returning a 'C'P'P_Class type",
6375                    Arg1);
6376             end if;
6377          end CPP_Constructor;
6378
6379          -----------------
6380          -- CPP_Virtual --
6381          -----------------
6382
6383          when Pragma_CPP_Virtual => CPP_Virtual : declare
6384          begin
6385             GNAT_Pragma;
6386
6387             if Warn_On_Obsolescent_Feature then
6388                Error_Msg_N
6389                  ("'G'N'A'T pragma cpp'_virtual is now obsolete and has " &
6390                   "no effect?", N);
6391             end if;
6392          end CPP_Virtual;
6393
6394          ----------------
6395          -- CPP_Vtable --
6396          ----------------
6397
6398          when Pragma_CPP_Vtable => CPP_Vtable : declare
6399          begin
6400             GNAT_Pragma;
6401
6402             if Warn_On_Obsolescent_Feature then
6403                Error_Msg_N
6404                  ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
6405                   "no effect?", N);
6406             end if;
6407          end CPP_Vtable;
6408
6409          -----------
6410          -- Debug --
6411          -----------
6412
6413          --  pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
6414
6415          when Pragma_Debug => Debug : declare
6416                Cond : Node_Id;
6417
6418          begin
6419             GNAT_Pragma;
6420
6421             Cond :=
6422               New_Occurrence_Of
6423                 (Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active),
6424                  Loc);
6425
6426             if Arg_Count = 2 then
6427                Cond :=
6428                  Make_And_Then (Loc,
6429                    Left_Opnd   => Relocate_Node (Cond),
6430                    Right_Opnd  => Expression (Arg1));
6431             end if;
6432
6433             --  Rewrite into a conditional with an appropriate condition. We
6434             --  wrap the procedure call in a block so that overhead from e.g.
6435             --  use of the secondary stack does not generate execution overhead
6436             --  for suppressed conditions.
6437
6438             Rewrite (N, Make_Implicit_If_Statement (N,
6439               Condition => Cond,
6440                  Then_Statements => New_List (
6441                    Make_Block_Statement (Loc,
6442                      Handled_Statement_Sequence =>
6443                        Make_Handled_Sequence_Of_Statements (Loc,
6444                          Statements => New_List (
6445                            Relocate_Node (Debug_Statement (N))))))));
6446             Analyze (N);
6447          end Debug;
6448
6449          ------------------
6450          -- Debug_Policy --
6451          ------------------
6452
6453          --  pragma Debug_Policy (Check | Ignore)
6454
6455          when Pragma_Debug_Policy =>
6456             GNAT_Pragma;
6457             Check_Arg_Count (1);
6458             Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
6459             Debug_Pragmas_Enabled := Chars (Expression (Arg1)) = Name_Check;
6460
6461          ---------------------
6462          -- Detect_Blocking --
6463          ---------------------
6464
6465          --  pragma Detect_Blocking;
6466
6467          when Pragma_Detect_Blocking =>
6468             Ada_2005_Pragma;
6469             Check_Arg_Count (0);
6470             Check_Valid_Configuration_Pragma;
6471             Detect_Blocking := True;
6472
6473          -------------------
6474          -- Discard_Names --
6475          -------------------
6476
6477          --  pragma Discard_Names [([On =>] LOCAL_NAME)];
6478
6479          when Pragma_Discard_Names => Discard_Names : declare
6480             E    : Entity_Id;
6481             E_Id : Entity_Id;
6482
6483          begin
6484             Check_Ada_83_Warning;
6485
6486             --  Deal with configuration pragma case
6487
6488             if Arg_Count = 0 and then Is_Configuration_Pragma then
6489                Global_Discard_Names := True;
6490                return;
6491
6492             --  Otherwise, check correct appropriate context
6493
6494             else
6495                Check_Is_In_Decl_Part_Or_Package_Spec;
6496
6497                if Arg_Count = 0 then
6498
6499                   --  If there is no parameter, then from now on this pragma
6500                   --  applies to any enumeration, exception or tagged type
6501                   --  defined in the current declarative part, and recursively
6502                   --  to any nested scope.
6503
6504                   Set_Discard_Names (Current_Scope);
6505                   return;
6506
6507                else
6508                   Check_Arg_Count (1);
6509                   Check_Optional_Identifier (Arg1, Name_On);
6510                   Check_Arg_Is_Local_Name (Arg1);
6511
6512                   E_Id := Expression (Arg1);
6513
6514                   if Etype (E_Id) = Any_Type then
6515                      return;
6516                   else
6517                      E := Entity (E_Id);
6518                   end if;
6519
6520                   if (Is_First_Subtype (E)
6521                       and then
6522                         (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
6523                     or else Ekind (E) = E_Exception
6524                   then
6525                      Set_Discard_Names (E);
6526                   else
6527                      Error_Pragma_Arg
6528                        ("inappropriate entity for pragma%", Arg1);
6529                   end if;
6530
6531                end if;
6532             end if;
6533          end Discard_Names;
6534
6535          ---------------
6536          -- Elaborate --
6537          ---------------
6538
6539          --  pragma Elaborate (library_unit_NAME {, library_unit_NAME});
6540
6541          when Pragma_Elaborate => Elaborate : declare
6542             Arg   : Node_Id;
6543             Citem : Node_Id;
6544
6545          begin
6546             --  Pragma must be in context items list of a compilation unit
6547
6548             if not Is_In_Context_Clause then
6549                Pragma_Misplaced;
6550             end if;
6551
6552             --  Must be at least one argument
6553
6554             if Arg_Count = 0 then
6555                Error_Pragma ("pragma% requires at least one argument");
6556             end if;
6557
6558             --  In Ada 83 mode, there can be no items following it in the
6559             --  context list except other pragmas and implicit with clauses
6560             --  (e.g. those added by use of Rtsfind). In Ada 95 mode, this
6561             --  placement rule does not apply.
6562
6563             if Ada_Version = Ada_83 and then Comes_From_Source (N) then
6564                Citem := Next (N);
6565                while Present (Citem) loop
6566                   if Nkind (Citem) = N_Pragma
6567                     or else (Nkind (Citem) = N_With_Clause
6568                               and then Implicit_With (Citem))
6569                   then
6570                      null;
6571                   else
6572                      Error_Pragma
6573                        ("(Ada 83) pragma% must be at end of context clause");
6574                   end if;
6575
6576                   Next (Citem);
6577                end loop;
6578             end if;
6579
6580             --  Finally, the arguments must all be units mentioned in a with
6581             --  clause in the same context clause. Note we already checked (in
6582             --  Par.Prag) that the arguments are all identifiers or selected
6583             --  components.
6584
6585             Arg := Arg1;
6586             Outer : while Present (Arg) loop
6587                Citem := First (List_Containing (N));
6588                Inner : while Citem /= N loop
6589                   if Nkind (Citem) = N_With_Clause
6590                     and then Same_Name (Name (Citem), Expression (Arg))
6591                   then
6592                      Set_Elaborate_Present (Citem, True);
6593                      Set_Unit_Name (Expression (Arg), Name (Citem));
6594
6595                      --  With the pragma present, elaboration calls on
6596                      --  subprograms from the named unit need no further
6597                      --  checks, as long as the pragma appears in the current
6598                      --  compilation unit. If the pragma appears in some unit
6599                      --  in the context, there might still be a need for an
6600                      --  Elaborate_All_Desirable from the current compilation
6601                      --  to the named unit, so we keep the check enabled.
6602
6603                      if In_Extended_Main_Source_Unit (N) then
6604                         Set_Suppress_Elaboration_Warnings
6605                           (Entity (Name (Citem)));
6606                      end if;
6607
6608                      exit Inner;
6609                   end if;
6610
6611                   Next (Citem);
6612                end loop Inner;
6613
6614                if Citem = N then
6615                   Error_Pragma_Arg
6616                     ("argument of pragma% is not with'ed unit", Arg);
6617                end if;
6618
6619                Next (Arg);
6620             end loop Outer;
6621
6622             --  Give a warning if operating in static mode with -gnatwl
6623             --  (elaboration warnings enabled) switch set.
6624
6625             if Elab_Warnings and not Dynamic_Elaboration_Checks then
6626                Error_Msg_N
6627                  ("?use of pragma Elaborate may not be safe", N);
6628                Error_Msg_N
6629                  ("?use pragma Elaborate_All instead if possible", N);
6630             end if;
6631          end Elaborate;
6632
6633          -------------------
6634          -- Elaborate_All --
6635          -------------------
6636
6637          --  pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
6638
6639          when Pragma_Elaborate_All => Elaborate_All : declare
6640             Arg   : Node_Id;
6641             Citem : Node_Id;
6642
6643          begin
6644             Check_Ada_83_Warning;
6645
6646             --  Pragma must be in context items list of a compilation unit
6647
6648             if not Is_In_Context_Clause then
6649                Pragma_Misplaced;
6650             end if;
6651
6652             --  Must be at least one argument
6653
6654             if Arg_Count = 0 then
6655                Error_Pragma ("pragma% requires at least one argument");
6656             end if;
6657
6658             --  Note: unlike pragma Elaborate, pragma Elaborate_All does not
6659             --  have to appear at the end of the context clause, but may
6660             --  appear mixed in with other items, even in Ada 83 mode.
6661
6662             --  Final check: the arguments must all be units mentioned in
6663             --  a with clause in the same context clause. Note that we
6664             --  already checked (in Par.Prag) that all the arguments are
6665             --  either identifiers or selected components.
6666
6667             Arg := Arg1;
6668             Outr : while Present (Arg) loop
6669                Citem := First (List_Containing (N));
6670                Innr : while Citem /= N loop
6671                   if Nkind (Citem) = N_With_Clause
6672                     and then Same_Name (Name (Citem), Expression (Arg))
6673                   then
6674                      Set_Elaborate_All_Present (Citem, True);
6675                      Set_Unit_Name (Expression (Arg), Name (Citem));
6676
6677                      --  Suppress warnings and elaboration checks on the named
6678                      --  unit if the pragma is in the current compilation, as
6679                      --  for pragma Elaborate.
6680
6681                      if In_Extended_Main_Source_Unit (N) then
6682                         Set_Suppress_Elaboration_Warnings
6683                           (Entity (Name (Citem)));
6684                      end if;
6685                      exit Innr;
6686                   end if;
6687
6688                   Next (Citem);
6689                end loop Innr;
6690
6691                if Citem = N then
6692                   Set_Error_Posted (N);
6693                   Error_Pragma_Arg
6694                     ("argument of pragma% is not with'ed unit", Arg);
6695                end if;
6696
6697                Next (Arg);
6698             end loop Outr;
6699          end Elaborate_All;
6700
6701          --------------------
6702          -- Elaborate_Body --
6703          --------------------
6704
6705          --  pragma Elaborate_Body [( library_unit_NAME )];
6706
6707          when Pragma_Elaborate_Body => Elaborate_Body : declare
6708             Cunit_Node : Node_Id;
6709             Cunit_Ent  : Entity_Id;
6710
6711          begin
6712             Check_Ada_83_Warning;
6713             Check_Valid_Library_Unit_Pragma;
6714
6715             if Nkind (N) = N_Null_Statement then
6716                return;
6717             end if;
6718
6719             Cunit_Node := Cunit (Current_Sem_Unit);
6720             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
6721
6722             if Nkind_In (Unit (Cunit_Node), N_Package_Body,
6723                                             N_Subprogram_Body)
6724             then
6725                Error_Pragma ("pragma% must refer to a spec, not a body");
6726             else
6727                Set_Body_Required (Cunit_Node, True);
6728                Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
6729
6730                --  If we are in dynamic elaboration mode, then we suppress
6731                --  elaboration warnings for the unit, since it is definitely
6732                --  fine NOT to do dynamic checks at the first level (and such
6733                --  checks will be suppressed because no elaboration boolean
6734                --  is created for Elaborate_Body packages).
6735
6736                --  But in the static model of elaboration, Elaborate_Body is
6737                --  definitely NOT good enough to ensure elaboration safety on
6738                --  its own, since the body may WITH other units that are not
6739                --  safe from an elaboration point of view, so a client must
6740                --  still do an Elaborate_All on such units.
6741
6742                --  Debug flag -gnatdD restores the old behavior of 3.13, where
6743                --  Elaborate_Body always suppressed elab warnings.
6744
6745                if Dynamic_Elaboration_Checks or Debug_Flag_DD then
6746                   Set_Suppress_Elaboration_Warnings (Cunit_Ent);
6747                end if;
6748             end if;
6749          end Elaborate_Body;
6750
6751          ------------------------
6752          -- Elaboration_Checks --
6753          ------------------------
6754
6755          --  pragma Elaboration_Checks (Static | Dynamic);
6756
6757          when Pragma_Elaboration_Checks =>
6758             GNAT_Pragma;
6759             Check_Arg_Count (1);
6760             Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
6761             Dynamic_Elaboration_Checks :=
6762               (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
6763
6764          ---------------
6765          -- Eliminate --
6766          ---------------
6767
6768          --  pragma Eliminate (
6769          --      [Unit_Name  =>] IDENTIFIER | SELECTED_COMPONENT,
6770          --    [,[Entity     =>] IDENTIFIER |
6771          --                      SELECTED_COMPONENT |
6772          --                      STRING_LITERAL]
6773          --    [,                OVERLOADING_RESOLUTION]);
6774
6775          --  OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
6776          --                             SOURCE_LOCATION
6777
6778          --  PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
6779          --                                        FUNCTION_PROFILE
6780
6781          --  PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
6782
6783          --  FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
6784          --                       Result_Type => result_SUBTYPE_NAME]
6785
6786          --  PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
6787          --  SUBTYPE_NAME    ::= STRING_LITERAL
6788
6789          --  SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
6790          --  SOURCE_TRACE    ::= STRING_LITERAL
6791
6792          when Pragma_Eliminate => Eliminate : declare
6793             Args  : Args_List (1 .. 5);
6794             Names : constant Name_List (1 .. 5) := (
6795                       Name_Unit_Name,
6796                       Name_Entity,
6797                       Name_Parameter_Types,
6798                       Name_Result_Type,
6799                       Name_Source_Location);
6800
6801             Unit_Name       : Node_Id renames Args (1);
6802             Entity          : Node_Id renames Args (2);
6803             Parameter_Types : Node_Id renames Args (3);
6804             Result_Type     : Node_Id renames Args (4);
6805             Source_Location : Node_Id renames Args (5);
6806
6807          begin
6808             GNAT_Pragma;
6809             Check_Valid_Configuration_Pragma;
6810             Gather_Associations (Names, Args);
6811
6812             if No (Unit_Name) then
6813                Error_Pragma ("missing Unit_Name argument for pragma%");
6814             end if;
6815
6816             if No (Entity)
6817               and then (Present (Parameter_Types)
6818                           or else
6819                         Present (Result_Type)
6820                           or else
6821                         Present (Source_Location))
6822             then
6823                Error_Pragma ("missing Entity argument for pragma%");
6824             end if;
6825
6826             if (Present (Parameter_Types)
6827                        or else
6828                 Present (Result_Type))
6829               and then
6830                 Present (Source_Location)
6831             then
6832                Error_Pragma
6833                  ("parameter profile and source location cannot " &
6834                   "be used together in pragma%");
6835             end if;
6836
6837             Process_Eliminate_Pragma
6838               (N,
6839                Unit_Name,
6840                Entity,
6841                Parameter_Types,
6842                Result_Type,
6843                Source_Location);
6844          end Eliminate;
6845
6846          ------------
6847          -- Export --
6848          ------------
6849
6850          --  pragma Export (
6851          --    [   Convention    =>] convention_IDENTIFIER,
6852          --    [   Entity        =>] local_NAME
6853          --    [, [External_Name =>] static_string_EXPRESSION ]
6854          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
6855
6856          when Pragma_Export => Export : declare
6857             C      : Convention_Id;
6858             Def_Id : Entity_Id;
6859
6860             pragma Warnings (Off, C);
6861
6862          begin
6863             Check_Ada_83_Warning;
6864             Check_Arg_Order
6865               ((Name_Convention,
6866                 Name_Entity,
6867                 Name_External_Name,
6868                 Name_Link_Name));
6869             Check_At_Least_N_Arguments (2);
6870             Check_At_Most_N_Arguments  (4);
6871             Process_Convention (C, Def_Id);
6872
6873             if Ekind (Def_Id) /= E_Constant then
6874                Note_Possible_Modification (Expression (Arg2), Sure => False);
6875             end if;
6876
6877             Process_Interface_Name (Def_Id, Arg3, Arg4);
6878             Set_Exported (Def_Id, Arg2);
6879
6880             --  If the entity is a deferred constant, propagate the information
6881             --  to the full view, because gigi elaborates the full view only.
6882
6883             if Ekind (Def_Id) = E_Constant
6884               and then Present (Full_View (Def_Id))
6885             then
6886                declare
6887                   Id2 : constant Entity_Id := Full_View (Def_Id);
6888                begin
6889                   Set_Is_Exported    (Id2, Is_Exported          (Def_Id));
6890                   Set_First_Rep_Item (Id2, First_Rep_Item       (Def_Id));
6891                   Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
6892                end;
6893             end if;
6894          end Export;
6895
6896          ----------------------
6897          -- Export_Exception --
6898          ----------------------
6899
6900          --  pragma Export_Exception (
6901          --        [Internal         =>] LOCAL_NAME
6902          --     [, [External         =>] EXTERNAL_SYMBOL]
6903          --     [, [Form     =>] Ada | VMS]
6904          --     [, [Code     =>] static_integer_EXPRESSION]);
6905
6906          when Pragma_Export_Exception => Export_Exception : declare
6907             Args  : Args_List (1 .. 4);
6908             Names : constant Name_List (1 .. 4) := (
6909                       Name_Internal,
6910                       Name_External,
6911                       Name_Form,
6912                       Name_Code);
6913
6914             Internal : Node_Id renames Args (1);
6915             External : Node_Id renames Args (2);
6916             Form     : Node_Id renames Args (3);
6917             Code     : Node_Id renames Args (4);
6918
6919          begin
6920             GNAT_Pragma;
6921
6922             if Inside_A_Generic then
6923                Error_Pragma ("pragma% cannot be used for generic entities");
6924             end if;
6925
6926             Gather_Associations (Names, Args);
6927             Process_Extended_Import_Export_Exception_Pragma (
6928               Arg_Internal => Internal,
6929               Arg_External => External,
6930               Arg_Form     => Form,
6931               Arg_Code     => Code);
6932
6933             if not Is_VMS_Exception (Entity (Internal)) then
6934                Set_Exported (Entity (Internal), Internal);
6935             end if;
6936          end Export_Exception;
6937
6938          ---------------------
6939          -- Export_Function --
6940          ---------------------
6941
6942          --  pragma Export_Function (
6943          --        [Internal         =>] LOCAL_NAME
6944          --     [, [External         =>] EXTERNAL_SYMBOL]
6945          --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
6946          --     [, [Result_Type      =>] TYPE_DESIGNATOR]
6947          --     [, [Mechanism        =>] MECHANISM]
6948          --     [, [Result_Mechanism =>] MECHANISM_NAME]);
6949
6950          --  EXTERNAL_SYMBOL ::=
6951          --    IDENTIFIER
6952          --  | static_string_EXPRESSION
6953
6954          --  PARAMETER_TYPES ::=
6955          --    null
6956          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6957
6958          --  TYPE_DESIGNATOR ::=
6959          --    subtype_NAME
6960          --  | subtype_Name ' Access
6961
6962          --  MECHANISM ::=
6963          --    MECHANISM_NAME
6964          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6965
6966          --  MECHANISM_ASSOCIATION ::=
6967          --    [formal_parameter_NAME =>] MECHANISM_NAME
6968
6969          --  MECHANISM_NAME ::=
6970          --    Value
6971          --  | Reference
6972          --  | Descriptor [([Class =>] CLASS_NAME)]
6973
6974          --  CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6975
6976          when Pragma_Export_Function => Export_Function : declare
6977             Args  : Args_List (1 .. 6);
6978             Names : constant Name_List (1 .. 6) := (
6979                       Name_Internal,
6980                       Name_External,
6981                       Name_Parameter_Types,
6982                       Name_Result_Type,
6983                       Name_Mechanism,
6984                       Name_Result_Mechanism);
6985
6986             Internal         : Node_Id renames Args (1);
6987             External         : Node_Id renames Args (2);
6988             Parameter_Types  : Node_Id renames Args (3);
6989             Result_Type      : Node_Id renames Args (4);
6990             Mechanism        : Node_Id renames Args (5);
6991             Result_Mechanism : Node_Id renames Args (6);
6992
6993          begin
6994             GNAT_Pragma;
6995             Gather_Associations (Names, Args);
6996             Process_Extended_Import_Export_Subprogram_Pragma (
6997               Arg_Internal         => Internal,
6998               Arg_External         => External,
6999               Arg_Parameter_Types  => Parameter_Types,
7000               Arg_Result_Type      => Result_Type,
7001               Arg_Mechanism        => Mechanism,
7002               Arg_Result_Mechanism => Result_Mechanism);
7003          end Export_Function;
7004
7005          -------------------
7006          -- Export_Object --
7007          -------------------
7008
7009          --  pragma Export_Object (
7010          --        [Internal =>] LOCAL_NAME
7011          --     [, [External =>] EXTERNAL_SYMBOL]
7012          --     [, [Size     =>] EXTERNAL_SYMBOL]);
7013
7014          --  EXTERNAL_SYMBOL ::=
7015          --    IDENTIFIER
7016          --  | static_string_EXPRESSION
7017
7018          --  PARAMETER_TYPES ::=
7019          --    null
7020          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7021
7022          --  TYPE_DESIGNATOR ::=
7023          --    subtype_NAME
7024          --  | subtype_Name ' Access
7025
7026          --  MECHANISM ::=
7027          --    MECHANISM_NAME
7028          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7029
7030          --  MECHANISM_ASSOCIATION ::=
7031          --    [formal_parameter_NAME =>] MECHANISM_NAME
7032
7033          --  MECHANISM_NAME ::=
7034          --    Value
7035          --  | Reference
7036          --  | Descriptor [([Class =>] CLASS_NAME)]
7037
7038          --  CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7039
7040          when Pragma_Export_Object => Export_Object : declare
7041             Args  : Args_List (1 .. 3);
7042             Names : constant Name_List (1 .. 3) := (
7043                       Name_Internal,
7044                       Name_External,
7045                       Name_Size);
7046
7047             Internal : Node_Id renames Args (1);
7048             External : Node_Id renames Args (2);
7049             Size     : Node_Id renames Args (3);
7050
7051          begin
7052             GNAT_Pragma;
7053             Gather_Associations (Names, Args);
7054             Process_Extended_Import_Export_Object_Pragma (
7055               Arg_Internal => Internal,
7056               Arg_External => External,
7057               Arg_Size     => Size);
7058          end Export_Object;
7059
7060          ----------------------
7061          -- Export_Procedure --
7062          ----------------------
7063
7064          --  pragma Export_Procedure (
7065          --        [Internal         =>] LOCAL_NAME
7066          --     [, [External         =>] EXTERNAL_SYMBOL]
7067          --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
7068          --     [, [Mechanism        =>] MECHANISM]);
7069
7070          --  EXTERNAL_SYMBOL ::=
7071          --    IDENTIFIER
7072          --  | static_string_EXPRESSION
7073
7074          --  PARAMETER_TYPES ::=
7075          --    null
7076          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7077
7078          --  TYPE_DESIGNATOR ::=
7079          --    subtype_NAME
7080          --  | subtype_Name ' Access
7081
7082          --  MECHANISM ::=
7083          --    MECHANISM_NAME
7084          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7085
7086          --  MECHANISM_ASSOCIATION ::=
7087          --    [formal_parameter_NAME =>] MECHANISM_NAME
7088
7089          --  MECHANISM_NAME ::=
7090          --    Value
7091          --  | Reference
7092          --  | Descriptor [([Class =>] CLASS_NAME)]
7093
7094          --  CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7095
7096          when Pragma_Export_Procedure => Export_Procedure : declare
7097             Args  : Args_List (1 .. 4);
7098             Names : constant Name_List (1 .. 4) := (
7099                       Name_Internal,
7100                       Name_External,
7101                       Name_Parameter_Types,
7102                       Name_Mechanism);
7103
7104             Internal        : Node_Id renames Args (1);
7105             External        : Node_Id renames Args (2);
7106             Parameter_Types : Node_Id renames Args (3);
7107             Mechanism       : Node_Id renames Args (4);
7108
7109          begin
7110             GNAT_Pragma;
7111             Gather_Associations (Names, Args);
7112             Process_Extended_Import_Export_Subprogram_Pragma (
7113               Arg_Internal        => Internal,
7114               Arg_External        => External,
7115               Arg_Parameter_Types => Parameter_Types,
7116               Arg_Mechanism       => Mechanism);
7117          end Export_Procedure;
7118
7119          ------------------
7120          -- Export_Value --
7121          ------------------
7122
7123          --  pragma Export_Value (
7124          --     [Value     =>] static_integer_EXPRESSION,
7125          --     [Link_Name =>] static_string_EXPRESSION);
7126
7127          when Pragma_Export_Value =>
7128             GNAT_Pragma;
7129             Check_Arg_Order ((Name_Value, Name_Link_Name));
7130             Check_Arg_Count (2);
7131
7132             Check_Optional_Identifier (Arg1, Name_Value);
7133             Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
7134
7135             Check_Optional_Identifier (Arg2, Name_Link_Name);
7136             Check_Arg_Is_Static_Expression (Arg2, Standard_String);
7137
7138          -----------------------------
7139          -- Export_Valued_Procedure --
7140          -----------------------------
7141
7142          --  pragma Export_Valued_Procedure (
7143          --        [Internal         =>] LOCAL_NAME
7144          --     [, [External         =>] EXTERNAL_SYMBOL,]
7145          --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
7146          --     [, [Mechanism        =>] MECHANISM]);
7147
7148          --  EXTERNAL_SYMBOL ::=
7149          --    IDENTIFIER
7150          --  | static_string_EXPRESSION
7151
7152          --  PARAMETER_TYPES ::=
7153          --    null
7154          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7155
7156          --  TYPE_DESIGNATOR ::=
7157          --    subtype_NAME
7158          --  | subtype_Name ' Access
7159
7160          --  MECHANISM ::=
7161          --    MECHANISM_NAME
7162          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7163
7164          --  MECHANISM_ASSOCIATION ::=
7165          --    [formal_parameter_NAME =>] MECHANISM_NAME
7166
7167          --  MECHANISM_NAME ::=
7168          --    Value
7169          --  | Reference
7170          --  | Descriptor [([Class =>] CLASS_NAME)]
7171
7172          --  CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7173
7174          when Pragma_Export_Valued_Procedure =>
7175          Export_Valued_Procedure : declare
7176             Args  : Args_List (1 .. 4);
7177             Names : constant Name_List (1 .. 4) := (
7178                       Name_Internal,
7179                       Name_External,
7180                       Name_Parameter_Types,
7181                       Name_Mechanism);
7182
7183             Internal        : Node_Id renames Args (1);
7184             External        : Node_Id renames Args (2);
7185             Parameter_Types : Node_Id renames Args (3);
7186             Mechanism       : Node_Id renames Args (4);
7187
7188          begin
7189             GNAT_Pragma;
7190             Gather_Associations (Names, Args);
7191             Process_Extended_Import_Export_Subprogram_Pragma (
7192               Arg_Internal        => Internal,
7193               Arg_External        => External,
7194               Arg_Parameter_Types => Parameter_Types,
7195               Arg_Mechanism       => Mechanism);
7196          end Export_Valued_Procedure;
7197
7198          -------------------
7199          -- Extend_System --
7200          -------------------
7201
7202          --  pragma Extend_System ([Name =>] Identifier);
7203
7204          when Pragma_Extend_System => Extend_System : declare
7205          begin
7206             GNAT_Pragma;
7207             Check_Valid_Configuration_Pragma;
7208             Check_Arg_Count (1);
7209             Check_Optional_Identifier (Arg1, Name_Name);
7210             Check_Arg_Is_Identifier (Arg1);
7211
7212             Get_Name_String (Chars (Expression (Arg1)));
7213
7214             if Name_Len > 4
7215               and then Name_Buffer (1 .. 4) = "aux_"
7216             then
7217                if Present (System_Extend_Pragma_Arg) then
7218                   if Chars (Expression (Arg1)) =
7219                      Chars (Expression (System_Extend_Pragma_Arg))
7220                   then
7221                      null;
7222                   else
7223                      Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
7224                      Error_Pragma ("pragma% conflicts with that #");
7225                   end if;
7226
7227                else
7228                   System_Extend_Pragma_Arg := Arg1;
7229
7230                   if not GNAT_Mode then
7231                      System_Extend_Unit := Arg1;
7232                   end if;
7233                end if;
7234             else
7235                Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
7236             end if;
7237          end Extend_System;
7238
7239          ------------------------
7240          -- Extensions_Allowed --
7241          ------------------------
7242
7243          --  pragma Extensions_Allowed (ON | OFF);
7244
7245          when Pragma_Extensions_Allowed =>
7246             GNAT_Pragma;
7247             Check_Arg_Count (1);
7248             Check_No_Identifiers;
7249             Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
7250
7251             if Chars (Expression (Arg1)) = Name_On then
7252                Extensions_Allowed := True;
7253             else
7254                Extensions_Allowed := False;
7255             end if;
7256
7257          --------------
7258          -- External --
7259          --------------
7260
7261          --  pragma External (
7262          --    [   Convention    =>] convention_IDENTIFIER,
7263          --    [   Entity        =>] local_NAME
7264          --    [, [External_Name =>] static_string_EXPRESSION ]
7265          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
7266
7267          when Pragma_External => External : declare
7268                Def_Id : Entity_Id;
7269
7270                C : Convention_Id;
7271                pragma Warnings (Off, C);
7272
7273          begin
7274             GNAT_Pragma;
7275             Check_Arg_Order
7276               ((Name_Convention,
7277                 Name_Entity,
7278                 Name_External_Name,
7279                 Name_Link_Name));
7280             Check_At_Least_N_Arguments (2);
7281             Check_At_Most_N_Arguments  (4);
7282             Process_Convention (C, Def_Id);
7283             Note_Possible_Modification (Expression (Arg2), Sure => False);
7284             Process_Interface_Name (Def_Id, Arg3, Arg4);
7285             Set_Exported (Def_Id, Arg2);
7286          end External;
7287
7288          --------------------------
7289          -- External_Name_Casing --
7290          --------------------------
7291
7292          --  pragma External_Name_Casing (
7293          --    UPPERCASE | LOWERCASE
7294          --    [, AS_IS | UPPERCASE | LOWERCASE]);
7295
7296          when Pragma_External_Name_Casing => External_Name_Casing : declare
7297          begin
7298             GNAT_Pragma;
7299             Check_No_Identifiers;
7300
7301             if Arg_Count = 2 then
7302                Check_Arg_Is_One_Of
7303                  (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
7304
7305                case Chars (Get_Pragma_Arg (Arg2)) is
7306                   when Name_As_Is     =>
7307                      Opt.External_Name_Exp_Casing := As_Is;
7308
7309                   when Name_Uppercase =>
7310                      Opt.External_Name_Exp_Casing := Uppercase;
7311
7312                   when Name_Lowercase =>
7313                      Opt.External_Name_Exp_Casing := Lowercase;
7314
7315                   when others =>
7316                      null;
7317                end case;
7318
7319             else
7320                Check_Arg_Count (1);
7321             end if;
7322
7323             Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
7324
7325             case Chars (Get_Pragma_Arg (Arg1)) is
7326                when Name_Uppercase =>
7327                   Opt.External_Name_Imp_Casing := Uppercase;
7328
7329                when Name_Lowercase =>
7330                   Opt.External_Name_Imp_Casing := Lowercase;
7331
7332                when others =>
7333                   null;
7334             end case;
7335          end External_Name_Casing;
7336
7337          --------------------------
7338          -- Favor_Top_Level --
7339          --------------------------
7340
7341          --  pragma Favor_Top_Level (type_NAME);
7342
7343          when Pragma_Favor_Top_Level => Favor_Top_Level : declare
7344                Named_Entity : Entity_Id;
7345
7346          begin
7347             GNAT_Pragma;
7348             Check_No_Identifiers;
7349             Check_Arg_Count (1);
7350             Check_Arg_Is_Local_Name (Arg1);
7351             Named_Entity := Entity (Expression (Arg1));
7352
7353             --  If it's an access-to-subprogram type (in particular, not a
7354             --  subtype), set the flag on that type.
7355
7356             if Is_Access_Subprogram_Type (Named_Entity) then
7357                Set_Can_Use_Internal_Rep (Named_Entity, False);
7358
7359             --  Otherwise it's an error (name denotes the wrong sort of entity)
7360
7361             else
7362                Error_Pragma_Arg
7363                  ("access-to-subprogram type expected", Expression (Arg1));
7364             end if;
7365          end Favor_Top_Level;
7366
7367          ---------------
7368          -- Fast_Math --
7369          ---------------
7370
7371          --  pragma Fast_Math;
7372
7373          when Pragma_Fast_Math =>
7374             GNAT_Pragma;
7375             Check_No_Identifiers;
7376             Check_Valid_Configuration_Pragma;
7377             Fast_Math := True;
7378
7379          ---------------------------
7380          -- Finalize_Storage_Only --
7381          ---------------------------
7382
7383          --  pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
7384
7385          when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
7386             Assoc   : constant Node_Id := Arg1;
7387             Type_Id : constant Node_Id := Expression (Assoc);
7388             Typ     : Entity_Id;
7389
7390          begin
7391             GNAT_Pragma;
7392             Check_No_Identifiers;
7393             Check_Arg_Count (1);
7394             Check_Arg_Is_Local_Name (Arg1);
7395
7396             Find_Type (Type_Id);
7397             Typ := Entity (Type_Id);
7398
7399             if Typ = Any_Type
7400               or else Rep_Item_Too_Early (Typ, N)
7401             then
7402                return;
7403             else
7404                Typ := Underlying_Type (Typ);
7405             end if;
7406
7407             if not Is_Controlled (Typ) then
7408                Error_Pragma ("pragma% must specify controlled type");
7409             end if;
7410
7411             Check_First_Subtype (Arg1);
7412
7413             if Finalize_Storage_Only (Typ) then
7414                Error_Pragma ("duplicate pragma%, only one allowed");
7415
7416             elsif not Rep_Item_Too_Late (Typ, N) then
7417                Set_Finalize_Storage_Only (Base_Type (Typ), True);
7418             end if;
7419          end Finalize_Storage;
7420
7421          --------------------------
7422          -- Float_Representation --
7423          --------------------------
7424
7425          --  pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
7426
7427          --  FLOAT_REP ::= VAX_Float | IEEE_Float
7428
7429          when Pragma_Float_Representation => Float_Representation : declare
7430             Argx : Node_Id;
7431             Digs : Nat;
7432             Ent  : Entity_Id;
7433
7434          begin
7435             GNAT_Pragma;
7436
7437             if Arg_Count = 1 then
7438                Check_Valid_Configuration_Pragma;
7439             else
7440                Check_Arg_Count (2);
7441                Check_Optional_Identifier (Arg2, Name_Entity);
7442                Check_Arg_Is_Local_Name (Arg2);
7443             end if;
7444
7445             Check_No_Identifier (Arg1);
7446             Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
7447
7448             if not OpenVMS_On_Target then
7449                if Chars (Expression (Arg1)) = Name_VAX_Float then
7450                   Error_Pragma
7451                     ("?pragma% ignored (applies only to Open'V'M'S)");
7452                end if;
7453
7454                return;
7455             end if;
7456
7457             --  One argument case
7458
7459             if Arg_Count = 1 then
7460                if Chars (Expression (Arg1)) = Name_VAX_Float then
7461                   if Opt.Float_Format = 'I' then
7462                      Error_Pragma ("'I'E'E'E format previously specified");
7463                   end if;
7464
7465                   Opt.Float_Format := 'V';
7466
7467                else
7468                   if Opt.Float_Format = 'V' then
7469                      Error_Pragma ("'V'A'X format previously specified");
7470                   end if;
7471
7472                   Opt.Float_Format := 'I';
7473                end if;
7474
7475                Set_Standard_Fpt_Formats;
7476
7477             --  Two argument case
7478
7479             else
7480                Argx := Get_Pragma_Arg (Arg2);
7481
7482                if not Is_Entity_Name (Argx)
7483                  or else not Is_Floating_Point_Type (Entity (Argx))
7484                then
7485                   Error_Pragma_Arg
7486                     ("second argument of% pragma must be floating-point type",
7487                      Arg2);
7488                end if;
7489
7490                Ent  := Entity (Argx);
7491                Digs := UI_To_Int (Digits_Value (Ent));
7492
7493                --  Two arguments, VAX_Float case
7494
7495                if Chars (Expression (Arg1)) = Name_VAX_Float then
7496                   case Digs is
7497                      when  6 => Set_F_Float (Ent);
7498                      when  9 => Set_D_Float (Ent);
7499                      when 15 => Set_G_Float (Ent);
7500
7501                      when others =>
7502                         Error_Pragma_Arg
7503                           ("wrong digits value, must be 6,9 or 15", Arg2);
7504                   end case;
7505
7506                --  Two arguments, IEEE_Float case
7507
7508                else
7509                   case Digs is
7510                      when  6 => Set_IEEE_Short (Ent);
7511                      when 15 => Set_IEEE_Long  (Ent);
7512
7513                      when others =>
7514                         Error_Pragma_Arg
7515                           ("wrong digits value, must be 6 or 15", Arg2);
7516                   end case;
7517                end if;
7518             end if;
7519          end Float_Representation;
7520
7521          -----------
7522          -- Ident --
7523          -----------
7524
7525          --  pragma Ident (static_string_EXPRESSION)
7526
7527          --  Note: pragma Comment shares this processing. Pragma Comment is
7528          --  identical to Ident, except that the restriction of the argument to
7529          --  31 characters and the placement restrictions are not enforced for
7530          --  pragma Comment.
7531
7532          when Pragma_Ident | Pragma_Comment => Ident : declare
7533             Str : Node_Id;
7534
7535          begin
7536             GNAT_Pragma;
7537             Check_Arg_Count (1);
7538             Check_No_Identifiers;
7539             Check_Arg_Is_Static_Expression (Arg1, Standard_String);
7540
7541             --  For pragma Ident, preserve DEC compatibility by requiring the
7542             --  pragma to appear in a declarative part or package spec.
7543
7544             if Prag_Id = Pragma_Ident then
7545                Check_Is_In_Decl_Part_Or_Package_Spec;
7546             end if;
7547
7548             Str := Expr_Value_S (Expression (Arg1));
7549
7550             declare
7551                CS : Node_Id;
7552                GP : Node_Id;
7553
7554             begin
7555                GP := Parent (Parent (N));
7556
7557                if Nkind_In (GP, N_Package_Declaration,
7558                                 N_Generic_Package_Declaration)
7559                then
7560                   GP := Parent (GP);
7561                end if;
7562
7563                --  If we have a compilation unit, then record the ident value,
7564                --  checking for improper duplication.
7565
7566                if Nkind (GP) = N_Compilation_Unit then
7567                   CS := Ident_String (Current_Sem_Unit);
7568
7569                   if Present (CS) then
7570
7571                      --  For Ident, we do not permit multiple instances
7572
7573                      if Prag_Id = Pragma_Ident then
7574                         Error_Pragma ("duplicate% pragma not permitted");
7575
7576                      --  For Comment, we concatenate the string, unless we want
7577                      --  to preserve the tree structure for ASIS.
7578
7579                      elsif not ASIS_Mode then
7580                         Start_String (Strval (CS));
7581                         Store_String_Char (' ');
7582                         Store_String_Chars (Strval (Str));
7583                         Set_Strval (CS, End_String);
7584                      end if;
7585
7586                   else
7587                      --  In VMS, the effect of IDENT is achieved by passing
7588                      --  IDENTIFICATION=name as a --for-linker switch.
7589
7590                      if OpenVMS_On_Target then
7591                         Start_String;
7592                         Store_String_Chars
7593                           ("--for-linker=IDENTIFICATION=");
7594                         String_To_Name_Buffer (Strval (Str));
7595                         Store_String_Chars (Name_Buffer (1 .. Name_Len));
7596
7597                         --  Only the last processed IDENT is saved. The main
7598                         --  purpose is so an IDENT associated with a main
7599                         --  procedure will be used in preference to an IDENT
7600                         --  associated with a with'd package.
7601
7602                         Replace_Linker_Option_String
7603                           (End_String, "--for-linker=IDENTIFICATION=");
7604                      end if;
7605
7606                      Set_Ident_String (Current_Sem_Unit, Str);
7607                   end if;
7608
7609                --  For subunits, we just ignore the Ident, since in GNAT these
7610                --  are not separate object files, and hence not separate units
7611                --  in the unit table.
7612
7613                elsif Nkind (GP) = N_Subunit then
7614                   null;
7615
7616                --  Otherwise we have a misplaced pragma Ident, but we ignore
7617                --  this if we are in an instantiation, since it comes from
7618                --  a generic, and has no relevance to the instantiation.
7619
7620                elsif Prag_Id = Pragma_Ident then
7621                   if Instantiation_Location (Loc) = No_Location then
7622                      Error_Pragma ("pragma% only allowed at outer level");
7623                   end if;
7624                end if;
7625             end;
7626          end Ident;
7627
7628          --------------------------
7629          -- Implemented_By_Entry --
7630          --------------------------
7631
7632          --  pragma Implemented_By_Entry (DIRECT_NAME);
7633
7634          when Pragma_Implemented_By_Entry => Implemented_By_Entry : declare
7635             Ent : Entity_Id;
7636
7637          begin
7638             Ada_2005_Pragma;
7639             Check_Arg_Count (1);
7640             Check_No_Identifiers;
7641             Check_Arg_Is_Identifier (Arg1);
7642             Check_Arg_Is_Local_Name (Arg1);
7643             Ent := Entity (Expression (Arg1));
7644
7645             --  Pragma Implemented_By_Entry must be applied only to protected
7646             --  synchronized or task interface primitives.
7647
7648             if (Ekind (Ent) /= E_Function
7649                   and then Ekind (Ent) /= E_Procedure)
7650                or else not Present (First_Formal (Ent))
7651                or else not Is_Concurrent_Interface (Etype (First_Formal (Ent)))
7652             then
7653                Error_Pragma_Arg
7654                  ("pragma % must be applied to a concurrent interface " &
7655                   "primitive", Arg1);
7656
7657             else
7658                if Einfo.Implemented_By_Entry (Ent)
7659                  and then Warn_On_Redundant_Constructs
7660                then
7661                   Error_Pragma ("?duplicate pragma%!");
7662                else
7663                   Set_Implemented_By_Entry (Ent);
7664                end if;
7665             end if;
7666          end Implemented_By_Entry;
7667
7668          -----------------------
7669          -- Implicit_Packing --
7670          -----------------------
7671
7672          --  pragma Implicit_Packing;
7673
7674          when Pragma_Implicit_Packing =>
7675             GNAT_Pragma;
7676             Check_Arg_Count (0);
7677             Implicit_Packing := True;
7678
7679          ------------
7680          -- Import --
7681          ------------
7682
7683          --  pragma Import (
7684          --       [Convention    =>] convention_IDENTIFIER,
7685          --       [Entity        =>] local_NAME
7686          --    [, [External_Name =>] static_string_EXPRESSION ]
7687          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
7688
7689          when Pragma_Import =>
7690             Check_Ada_83_Warning;
7691             Check_Arg_Order
7692               ((Name_Convention,
7693                 Name_Entity,
7694                 Name_External_Name,
7695                 Name_Link_Name));
7696             Check_At_Least_N_Arguments (2);
7697             Check_At_Most_N_Arguments  (4);
7698             Process_Import_Or_Interface;
7699
7700          ----------------------
7701          -- Import_Exception --
7702          ----------------------
7703
7704          --  pragma Import_Exception (
7705          --        [Internal         =>] LOCAL_NAME
7706          --     [, [External         =>] EXTERNAL_SYMBOL]
7707          --     [, [Form     =>] Ada | VMS]
7708          --     [, [Code     =>] static_integer_EXPRESSION]);
7709
7710          when Pragma_Import_Exception => Import_Exception : declare
7711             Args  : Args_List (1 .. 4);
7712             Names : constant Name_List (1 .. 4) := (
7713                       Name_Internal,
7714                       Name_External,
7715                       Name_Form,
7716                       Name_Code);
7717
7718             Internal : Node_Id renames Args (1);
7719             External : Node_Id renames Args (2);
7720             Form     : Node_Id renames Args (3);
7721             Code     : Node_Id renames Args (4);
7722
7723          begin
7724             GNAT_Pragma;
7725             Gather_Associations (Names, Args);
7726
7727             if Present (External) and then Present (Code) then
7728                Error_Pragma
7729                  ("cannot give both External and Code options for pragma%");
7730             end if;
7731
7732             Process_Extended_Import_Export_Exception_Pragma (
7733               Arg_Internal => Internal,
7734               Arg_External => External,
7735               Arg_Form     => Form,
7736               Arg_Code     => Code);
7737
7738             if not Is_VMS_Exception (Entity (Internal)) then
7739                Set_Imported (Entity (Internal));
7740             end if;
7741          end Import_Exception;
7742
7743          ---------------------
7744          -- Import_Function --
7745          ---------------------
7746
7747          --  pragma Import_Function (
7748          --        [Internal                 =>] LOCAL_NAME,
7749          --     [, [External                 =>] EXTERNAL_SYMBOL]
7750          --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
7751          --     [, [Result_Type              =>] SUBTYPE_MARK]
7752          --     [, [Mechanism                =>] MECHANISM]
7753          --     [, [Result_Mechanism         =>] MECHANISM_NAME]
7754          --     [, [First_Optional_Parameter =>] IDENTIFIER]);
7755
7756          --  EXTERNAL_SYMBOL ::=
7757          --    IDENTIFIER
7758          --  | static_string_EXPRESSION
7759
7760          --  PARAMETER_TYPES ::=
7761          --    null
7762          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7763
7764          --  TYPE_DESIGNATOR ::=
7765          --    subtype_NAME
7766          --  | subtype_Name ' Access
7767
7768          --  MECHANISM ::=
7769          --    MECHANISM_NAME
7770          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7771
7772          --  MECHANISM_ASSOCIATION ::=
7773          --    [formal_parameter_NAME =>] MECHANISM_NAME
7774
7775          --  MECHANISM_NAME ::=
7776          --    Value
7777          --  | Reference
7778          --  | Descriptor [([Class =>] CLASS_NAME)]
7779
7780          --  CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7781
7782          when Pragma_Import_Function => Import_Function : declare
7783             Args  : Args_List (1 .. 7);
7784             Names : constant Name_List (1 .. 7) := (
7785                       Name_Internal,
7786                       Name_External,
7787                       Name_Parameter_Types,
7788                       Name_Result_Type,
7789                       Name_Mechanism,
7790                       Name_Result_Mechanism,
7791                       Name_First_Optional_Parameter);
7792
7793             Internal                 : Node_Id renames Args (1);
7794             External                 : Node_Id renames Args (2);
7795             Parameter_Types          : Node_Id renames Args (3);
7796             Result_Type              : Node_Id renames Args (4);
7797             Mechanism                : Node_Id renames Args (5);
7798             Result_Mechanism         : Node_Id renames Args (6);
7799             First_Optional_Parameter : Node_Id renames Args (7);
7800
7801          begin
7802             GNAT_Pragma;
7803             Gather_Associations (Names, Args);
7804             Process_Extended_Import_Export_Subprogram_Pragma (
7805               Arg_Internal                 => Internal,
7806               Arg_External                 => External,
7807               Arg_Parameter_Types          => Parameter_Types,
7808               Arg_Result_Type              => Result_Type,
7809               Arg_Mechanism                => Mechanism,
7810               Arg_Result_Mechanism         => Result_Mechanism,
7811               Arg_First_Optional_Parameter => First_Optional_Parameter);
7812          end Import_Function;
7813
7814          -------------------
7815          -- Import_Object --
7816          -------------------
7817
7818          --  pragma Import_Object (
7819          --        [Internal =>] LOCAL_NAME
7820          --     [, [External =>] EXTERNAL_SYMBOL]
7821          --     [, [Size     =>] EXTERNAL_SYMBOL]);
7822
7823          --  EXTERNAL_SYMBOL ::=
7824          --    IDENTIFIER
7825          --  | static_string_EXPRESSION
7826
7827          when Pragma_Import_Object => Import_Object : declare
7828             Args  : Args_List (1 .. 3);
7829             Names : constant Name_List (1 .. 3) := (
7830                       Name_Internal,
7831                       Name_External,
7832                       Name_Size);
7833
7834             Internal : Node_Id renames Args (1);
7835             External : Node_Id renames Args (2);
7836             Size     : Node_Id renames Args (3);
7837
7838          begin
7839             GNAT_Pragma;
7840             Gather_Associations (Names, Args);
7841             Process_Extended_Import_Export_Object_Pragma (
7842               Arg_Internal => Internal,
7843               Arg_External => External,
7844               Arg_Size     => Size);
7845          end Import_Object;
7846
7847          ----------------------
7848          -- Import_Procedure --
7849          ----------------------
7850
7851          --  pragma Import_Procedure (
7852          --        [Internal                 =>] LOCAL_NAME
7853          --     [, [External                 =>] EXTERNAL_SYMBOL]
7854          --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
7855          --     [, [Mechanism                =>] MECHANISM]
7856          --     [, [First_Optional_Parameter =>] IDENTIFIER]);
7857
7858          --  EXTERNAL_SYMBOL ::=
7859          --    IDENTIFIER
7860          --  | static_string_EXPRESSION
7861
7862          --  PARAMETER_TYPES ::=
7863          --    null
7864          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7865
7866          --  TYPE_DESIGNATOR ::=
7867          --    subtype_NAME
7868          --  | subtype_Name ' Access
7869
7870          --  MECHANISM ::=
7871          --    MECHANISM_NAME
7872          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7873
7874          --  MECHANISM_ASSOCIATION ::=
7875          --    [formal_parameter_NAME =>] MECHANISM_NAME
7876
7877          --  MECHANISM_NAME ::=
7878          --    Value
7879          --  | Reference
7880          --  | Descriptor [([Class =>] CLASS_NAME)]
7881
7882          --  CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7883
7884          when Pragma_Import_Procedure => Import_Procedure : declare
7885             Args  : Args_List (1 .. 5);
7886             Names : constant Name_List (1 .. 5) := (
7887                       Name_Internal,
7888                       Name_External,
7889                       Name_Parameter_Types,
7890                       Name_Mechanism,
7891                       Name_First_Optional_Parameter);
7892
7893             Internal                 : Node_Id renames Args (1);
7894             External                 : Node_Id renames Args (2);
7895             Parameter_Types          : Node_Id renames Args (3);
7896             Mechanism                : Node_Id renames Args (4);
7897             First_Optional_Parameter : Node_Id renames Args (5);
7898
7899          begin
7900             GNAT_Pragma;
7901             Gather_Associations (Names, Args);
7902             Process_Extended_Import_Export_Subprogram_Pragma (
7903               Arg_Internal                 => Internal,
7904               Arg_External                 => External,
7905               Arg_Parameter_Types          => Parameter_Types,
7906               Arg_Mechanism                => Mechanism,
7907               Arg_First_Optional_Parameter => First_Optional_Parameter);
7908          end Import_Procedure;
7909
7910          -----------------------------
7911          -- Import_Valued_Procedure --
7912          -----------------------------
7913
7914          --  pragma Import_Valued_Procedure (
7915          --        [Internal                 =>] LOCAL_NAME
7916          --     [, [External                 =>] EXTERNAL_SYMBOL]
7917          --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
7918          --     [, [Mechanism                =>] MECHANISM]
7919          --     [, [First_Optional_Parameter =>] IDENTIFIER]);
7920
7921          --  EXTERNAL_SYMBOL ::=
7922          --    IDENTIFIER
7923          --  | static_string_EXPRESSION
7924
7925          --  PARAMETER_TYPES ::=
7926          --    null
7927          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
7928
7929          --  TYPE_DESIGNATOR ::=
7930          --    subtype_NAME
7931          --  | subtype_Name ' Access
7932
7933          --  MECHANISM ::=
7934          --    MECHANISM_NAME
7935          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
7936
7937          --  MECHANISM_ASSOCIATION ::=
7938          --    [formal_parameter_NAME =>] MECHANISM_NAME
7939
7940          --  MECHANISM_NAME ::=
7941          --    Value
7942          --  | Reference
7943          --  | Descriptor [([Class =>] CLASS_NAME)]
7944
7945          --  CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7946
7947          when Pragma_Import_Valued_Procedure =>
7948          Import_Valued_Procedure : declare
7949             Args  : Args_List (1 .. 5);
7950             Names : constant Name_List (1 .. 5) := (
7951                       Name_Internal,
7952                       Name_External,
7953                       Name_Parameter_Types,
7954                       Name_Mechanism,
7955                       Name_First_Optional_Parameter);
7956
7957             Internal                 : Node_Id renames Args (1);
7958             External                 : Node_Id renames Args (2);
7959             Parameter_Types          : Node_Id renames Args (3);
7960             Mechanism                : Node_Id renames Args (4);
7961             First_Optional_Parameter : Node_Id renames Args (5);
7962
7963          begin
7964             GNAT_Pragma;
7965             Gather_Associations (Names, Args);
7966             Process_Extended_Import_Export_Subprogram_Pragma (
7967               Arg_Internal                 => Internal,
7968               Arg_External                 => External,
7969               Arg_Parameter_Types          => Parameter_Types,
7970               Arg_Mechanism                => Mechanism,
7971               Arg_First_Optional_Parameter => First_Optional_Parameter);
7972          end Import_Valued_Procedure;
7973
7974          ------------------------
7975          -- Initialize_Scalars --
7976          ------------------------
7977
7978          --  pragma Initialize_Scalars;
7979
7980          when Pragma_Initialize_Scalars =>
7981             GNAT_Pragma;
7982             Check_Arg_Count (0);
7983             Check_Valid_Configuration_Pragma;
7984             Check_Restriction (No_Initialize_Scalars, N);
7985
7986             --  Initialize_Scalars creates false positives in CodePeer,
7987             --  so ignore this pragma in this mode.
7988
7989             if not Restriction_Active (No_Initialize_Scalars)
7990               and then not CodePeer_Mode
7991             then
7992                Init_Or_Norm_Scalars := True;
7993                Initialize_Scalars := True;
7994             end if;
7995
7996          ------------
7997          -- Inline --
7998          ------------
7999
8000          --  pragma Inline ( NAME {, NAME} );
8001
8002          when Pragma_Inline =>
8003
8004             --  Pragma is active if inlining option is active
8005
8006             Process_Inline (Inline_Active);
8007
8008          -------------------
8009          -- Inline_Always --
8010          -------------------
8011
8012          --  pragma Inline_Always ( NAME {, NAME} );
8013
8014          when Pragma_Inline_Always =>
8015             GNAT_Pragma;
8016             Process_Inline (True);
8017
8018          --------------------
8019          -- Inline_Generic --
8020          --------------------
8021
8022          --  pragma Inline_Generic (NAME {, NAME});
8023
8024          when Pragma_Inline_Generic =>
8025             GNAT_Pragma;
8026             Process_Generic_List;
8027
8028          ----------------------
8029          -- Inspection_Point --
8030          ----------------------
8031
8032          --  pragma Inspection_Point [(object_NAME {, object_NAME})];
8033
8034          when Pragma_Inspection_Point => Inspection_Point : declare
8035             Arg : Node_Id;
8036             Exp : Node_Id;
8037
8038          begin
8039             if Arg_Count > 0 then
8040                Arg := Arg1;
8041                loop
8042                   Exp := Expression (Arg);
8043                   Analyze (Exp);
8044
8045                   if not Is_Entity_Name (Exp)
8046                     or else not Is_Object (Entity (Exp))
8047                   then
8048                      Error_Pragma_Arg ("object name required", Arg);
8049                   end if;
8050
8051                   Next (Arg);
8052                   exit when No (Arg);
8053                end loop;
8054             end if;
8055          end Inspection_Point;
8056
8057          ---------------
8058          -- Interface --
8059          ---------------
8060
8061          --  pragma Interface (
8062          --    [   Convention    =>] convention_IDENTIFIER,
8063          --    [   Entity        =>] local_NAME
8064          --    [, [External_Name =>] static_string_EXPRESSION ]
8065          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
8066
8067          when Pragma_Interface =>
8068             GNAT_Pragma;
8069             Check_Arg_Order
8070               ((Name_Convention,
8071                 Name_Entity,
8072                 Name_External_Name,
8073                 Name_Link_Name));
8074             Check_At_Least_N_Arguments (2);
8075             Check_At_Most_N_Arguments  (4);
8076             Process_Import_Or_Interface;
8077
8078          --------------------
8079          -- Interface_Name --
8080          --------------------
8081
8082          --  pragma Interface_Name (
8083          --    [  Entity        =>] local_NAME
8084          --    [,[External_Name =>] static_string_EXPRESSION ]
8085          --    [,[Link_Name     =>] static_string_EXPRESSION ]);
8086
8087          when Pragma_Interface_Name => Interface_Name : declare
8088             Id     : Node_Id;
8089             Def_Id : Entity_Id;
8090             Hom_Id : Entity_Id;
8091             Found  : Boolean;
8092
8093          begin
8094             GNAT_Pragma;
8095             Check_Arg_Order
8096               ((Name_Entity, Name_External_Name, Name_Link_Name));
8097             Check_At_Least_N_Arguments (2);
8098             Check_At_Most_N_Arguments  (3);
8099             Id := Expression (Arg1);
8100             Analyze (Id);
8101
8102             if not Is_Entity_Name (Id) then
8103                Error_Pragma_Arg
8104                  ("first argument for pragma% must be entity name", Arg1);
8105             elsif Etype (Id) = Any_Type then
8106                return;
8107             else
8108                Def_Id := Entity (Id);
8109             end if;
8110
8111             --  Special DEC-compatible processing for the object case, forces
8112             --  object to be imported.
8113
8114             if Ekind (Def_Id) = E_Variable then
8115                Kill_Size_Check_Code (Def_Id);
8116                Note_Possible_Modification (Id, Sure => False);
8117
8118                --  Initialization is not allowed for imported variable
8119
8120                if Present (Expression (Parent (Def_Id)))
8121                  and then Comes_From_Source (Expression (Parent (Def_Id)))
8122                then
8123                   Error_Msg_Sloc := Sloc (Def_Id);
8124                   Error_Pragma_Arg
8125                     ("no initialization allowed for declaration of& #",
8126                      Arg2);
8127
8128                else
8129                   --  For compatibility, support VADS usage of providing both
8130                   --  pragmas Interface and Interface_Name to obtain the effect
8131                   --  of a single Import pragma.
8132
8133                   if Is_Imported (Def_Id)
8134                     and then Present (First_Rep_Item (Def_Id))
8135                     and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
8136                     and then
8137                       Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
8138                   then
8139                      null;
8140                   else
8141                      Set_Imported (Def_Id);
8142                   end if;
8143
8144                   Set_Is_Public (Def_Id);
8145                   Process_Interface_Name (Def_Id, Arg2, Arg3);
8146                end if;
8147
8148             --  Otherwise must be subprogram
8149
8150             elsif not Is_Subprogram (Def_Id) then
8151                Error_Pragma_Arg
8152                  ("argument of pragma% is not subprogram", Arg1);
8153
8154             else
8155                Check_At_Most_N_Arguments (3);
8156                Hom_Id := Def_Id;
8157                Found := False;
8158
8159                --  Loop through homonyms
8160
8161                loop
8162                   Def_Id := Get_Base_Subprogram (Hom_Id);
8163
8164                   if Is_Imported (Def_Id) then
8165                      Process_Interface_Name (Def_Id, Arg2, Arg3);
8166                      Found := True;
8167                   end if;
8168
8169                   Hom_Id := Homonym (Hom_Id);
8170
8171                   exit when No (Hom_Id)
8172                     or else Scope (Hom_Id) /= Current_Scope;
8173                end loop;
8174
8175                if not Found then
8176                   Error_Pragma_Arg
8177                     ("argument of pragma% is not imported subprogram",
8178                      Arg1);
8179                end if;
8180             end if;
8181          end Interface_Name;
8182
8183          -----------------------
8184          -- Interrupt_Handler --
8185          -----------------------
8186
8187          --  pragma Interrupt_Handler (handler_NAME);
8188
8189          when Pragma_Interrupt_Handler =>
8190             Check_Ada_83_Warning;
8191             Check_Arg_Count (1);
8192             Check_No_Identifiers;
8193
8194             if No_Run_Time_Mode then
8195                Error_Msg_CRT ("Interrupt_Handler pragma", N);
8196             else
8197                Check_Interrupt_Or_Attach_Handler;
8198                Process_Interrupt_Or_Attach_Handler;
8199             end if;
8200
8201          ------------------------
8202          -- Interrupt_Priority --
8203          ------------------------
8204
8205          --  pragma Interrupt_Priority [(EXPRESSION)];
8206
8207          when Pragma_Interrupt_Priority => Interrupt_Priority : declare
8208             P   : constant Node_Id := Parent (N);
8209             Arg : Node_Id;
8210
8211          begin
8212             Check_Ada_83_Warning;
8213
8214             if Arg_Count /= 0 then
8215                Arg := Expression (Arg1);
8216                Check_Arg_Count (1);
8217                Check_No_Identifiers;
8218
8219                --  The expression must be analyzed in the special manner
8220                --  described in "Handling of Default and Per-Object
8221                --  Expressions" in sem.ads.
8222
8223                Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
8224             end if;
8225
8226             if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
8227                Pragma_Misplaced;
8228                return;
8229
8230             elsif Has_Priority_Pragma (P) then
8231                Error_Pragma ("duplicate pragma% not allowed");
8232
8233             else
8234                Set_Has_Priority_Pragma (P, True);
8235                Record_Rep_Item (Defining_Identifier (Parent (P)), N);
8236             end if;
8237          end Interrupt_Priority;
8238
8239          ---------------------
8240          -- Interrupt_State --
8241          ---------------------
8242
8243          --  pragma Interrupt_State (
8244          --    [Name  =>] INTERRUPT_ID,
8245          --    [State =>] INTERRUPT_STATE);
8246
8247          --  INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
8248          --  INTERRUPT_STATE => System | Runtime | User
8249
8250          --  Note: if the interrupt id is given as an identifier, then it must
8251          --  be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
8252          --  given as a static integer expression which must be in the range of
8253          --  Ada.Interrupts.Interrupt_ID.
8254
8255          when Pragma_Interrupt_State => Interrupt_State : declare
8256
8257             Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
8258             --  This is the entity Ada.Interrupts.Interrupt_ID;
8259
8260             State_Type : Character;
8261             --  Set to 's'/'r'/'u' for System/Runtime/User
8262
8263             IST_Num : Pos;
8264             --  Index to entry in Interrupt_States table
8265
8266             Int_Val : Uint;
8267             --  Value of interrupt
8268
8269             Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
8270             --  The first argument to the pragma
8271
8272             Int_Ent : Entity_Id;
8273             --  Interrupt entity in Ada.Interrupts.Names
8274
8275          begin
8276             GNAT_Pragma;
8277             Check_Arg_Order ((Name_Name, Name_State));
8278             Check_Arg_Count (2);
8279
8280             Check_Optional_Identifier (Arg1, Name_Name);
8281             Check_Optional_Identifier (Arg2, Name_State);
8282             Check_Arg_Is_Identifier (Arg2);
8283
8284             --  First argument is identifier
8285
8286             if Nkind (Arg1X) = N_Identifier then
8287
8288                --  Search list of names in Ada.Interrupts.Names
8289
8290                Int_Ent := First_Entity (RTE (RE_Names));
8291                loop
8292                   if No (Int_Ent) then
8293                      Error_Pragma_Arg ("invalid interrupt name", Arg1);
8294
8295                   elsif Chars (Int_Ent) = Chars (Arg1X) then
8296                      Int_Val := Expr_Value (Constant_Value (Int_Ent));
8297                      exit;
8298                   end if;
8299
8300                   Next_Entity (Int_Ent);
8301                end loop;
8302
8303             --  First argument is not an identifier, so it must be a static
8304             --  expression of type Ada.Interrupts.Interrupt_ID.
8305
8306             else
8307                Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
8308                Int_Val := Expr_Value (Arg1X);
8309
8310                if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
8311                     or else
8312                   Int_Val > Expr_Value (Type_High_Bound (Int_Id))
8313                then
8314                   Error_Pragma_Arg
8315                     ("value not in range of type " &
8316                      """Ada.Interrupts.Interrupt_'I'D""", Arg1);
8317                end if;
8318             end if;
8319
8320             --  Check OK state
8321
8322             case Chars (Get_Pragma_Arg (Arg2)) is
8323                when Name_Runtime => State_Type := 'r';
8324                when Name_System  => State_Type := 's';
8325                when Name_User    => State_Type := 'u';
8326
8327                when others =>
8328                   Error_Pragma_Arg ("invalid interrupt state", Arg2);
8329             end case;
8330
8331             --  Check if entry is already stored
8332
8333             IST_Num := Interrupt_States.First;
8334             loop
8335                --  If entry not found, add it
8336
8337                if IST_Num > Interrupt_States.Last then
8338                   Interrupt_States.Append
8339                     ((Interrupt_Number => UI_To_Int (Int_Val),
8340                       Interrupt_State  => State_Type,
8341                       Pragma_Loc       => Loc));
8342                   exit;
8343
8344                --  Case of entry for the same entry
8345
8346                elsif Int_Val = Interrupt_States.Table (IST_Num).
8347                                                            Interrupt_Number
8348                then
8349                   --  If state matches, done, no need to make redundant entry
8350
8351                   exit when
8352                     State_Type = Interrupt_States.Table (IST_Num).
8353                                                            Interrupt_State;
8354
8355                   --  Otherwise if state does not match, error
8356
8357                   Error_Msg_Sloc :=
8358                     Interrupt_States.Table (IST_Num).Pragma_Loc;
8359                   Error_Pragma_Arg
8360                     ("state conflicts with that given #", Arg2);
8361                   exit;
8362                end if;
8363
8364                IST_Num := IST_Num + 1;
8365             end loop;
8366          end Interrupt_State;
8367
8368          ----------------------
8369          -- Java_Constructor --
8370          ----------------------
8371
8372          --  pragma Java_Constructor ([Entity =>] LOCAL_NAME);
8373
8374          --  Also handles pragma CIL_Constructor
8375
8376          when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
8377          Java_Constructor : declare
8378             Id         : Entity_Id;
8379             Def_Id     : Entity_Id;
8380             Hom_Id     : Entity_Id;
8381             Convention : Convention_Id;
8382
8383          begin
8384             GNAT_Pragma;
8385             Check_Arg_Count (1);
8386             Check_Optional_Identifier (Arg1, Name_Entity);
8387             Check_Arg_Is_Local_Name (Arg1);
8388
8389             Id := Expression (Arg1);
8390             Find_Program_Unit_Name (Id);
8391
8392             --  If we did not find the name, we are done
8393
8394             if Etype (Id) = Any_Type then
8395                return;
8396             end if;
8397
8398             case Prag_Id is
8399                when Pragma_CIL_Constructor  => Convention := Convention_CIL;
8400                when Pragma_Java_Constructor => Convention := Convention_Java;
8401                when others                  => null;
8402             end case;
8403
8404             Hom_Id := Entity (Id);
8405
8406             --  Loop through homonyms
8407
8408             loop
8409                Def_Id := Get_Base_Subprogram (Hom_Id);
8410
8411                --  The constructor is required to be a function returning an
8412                --  access type whose designated type has convention Java/CIL.
8413
8414                if Ekind (Def_Id) = E_Function
8415                  and then
8416                    (Is_Value_Type (Etype (Def_Id))
8417                      or else
8418                        (Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
8419                          and then
8420                           Atree.Convention (Etype (Def_Id)) = Convention)
8421                      or else
8422                        (Ekind (Etype (Def_Id)) in Access_Kind
8423                          and then
8424                           (Atree.Convention
8425                              (Designated_Type (Etype (Def_Id))) = Convention
8426                             or else
8427                               Atree.Convention
8428                                (Root_Type (Designated_Type (Etype (Def_Id)))) =
8429                                                                  Convention)))
8430                then
8431                   Set_Is_Constructor (Def_Id);
8432                   Set_Convention     (Def_Id, Convention);
8433                   Set_Is_Imported    (Def_Id);
8434
8435                else
8436                   if Convention = Convention_Java then
8437                      Error_Pragma_Arg
8438                        ("pragma% requires function returning a " &
8439                         "'Java access type", Arg1);
8440                   else
8441                      pragma Assert (Convention = Convention_CIL);
8442                      Error_Pragma_Arg
8443                        ("pragma% requires function returning a " &
8444                         "'C'I'L access type", Arg1);
8445                   end if;
8446                end if;
8447
8448                Hom_Id := Homonym (Hom_Id);
8449
8450                exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
8451             end loop;
8452          end Java_Constructor;
8453
8454          ----------------------
8455          -- Java_Interface --
8456          ----------------------
8457
8458          --  pragma Java_Interface ([Entity =>] LOCAL_NAME);
8459
8460          when Pragma_Java_Interface => Java_Interface : declare
8461             Arg : Node_Id;
8462             Typ : Entity_Id;
8463
8464          begin
8465             GNAT_Pragma;
8466             Check_Arg_Count (1);
8467             Check_Optional_Identifier (Arg1, Name_Entity);
8468             Check_Arg_Is_Local_Name (Arg1);
8469
8470             Arg := Expression (Arg1);
8471             Analyze (Arg);
8472
8473             if Etype (Arg) = Any_Type then
8474                return;
8475             end if;
8476
8477             if not Is_Entity_Name (Arg)
8478               or else not Is_Type (Entity (Arg))
8479             then
8480                Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
8481             end if;
8482
8483             Typ := Underlying_Type (Entity (Arg));
8484
8485             --  For now simply check some of the semantic constraints on the
8486             --  type. This currently leaves out some restrictions on interface
8487             --  types, namely that the parent type must be java.lang.Object.Typ
8488             --  and that all primitives of the type should be declared
8489             --  abstract. ???
8490
8491             if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
8492                Error_Pragma_Arg ("pragma% requires an abstract "
8493                  & "tagged type", Arg1);
8494
8495             elsif not Has_Discriminants (Typ)
8496               or else Ekind (Etype (First_Discriminant (Typ)))
8497                         /= E_Anonymous_Access_Type
8498               or else
8499                 not Is_Class_Wide_Type
8500                       (Designated_Type (Etype (First_Discriminant (Typ))))
8501             then
8502                Error_Pragma_Arg
8503                  ("type must have a class-wide access discriminant", Arg1);
8504             end if;
8505          end Java_Interface;
8506
8507          ----------------
8508          -- Keep_Names --
8509          ----------------
8510
8511          --  pragma Keep_Names ([On => ] local_NAME);
8512
8513          when Pragma_Keep_Names => Keep_Names : declare
8514             Arg : Node_Id;
8515
8516          begin
8517             GNAT_Pragma;
8518             Check_Arg_Count (1);
8519             Check_Optional_Identifier (Arg1, Name_On);
8520             Check_Arg_Is_Local_Name (Arg1);
8521
8522             Arg := Expression (Arg1);
8523             Analyze (Arg);
8524
8525             if Etype (Arg) = Any_Type then
8526                return;
8527             end if;
8528
8529             if not Is_Entity_Name (Arg)
8530               or else Ekind (Entity (Arg)) /= E_Enumeration_Type
8531             then
8532                Error_Pragma_Arg
8533                  ("pragma% requires a local enumeration type", Arg1);
8534             end if;
8535
8536             Set_Discard_Names (Entity (Arg), False);
8537          end Keep_Names;
8538
8539          -------------
8540          -- License --
8541          -------------
8542
8543          --  pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
8544
8545          when Pragma_License =>
8546             GNAT_Pragma;
8547             Check_Arg_Count (1);
8548             Check_No_Identifiers;
8549             Check_Valid_Configuration_Pragma;
8550             Check_Arg_Is_Identifier (Arg1);
8551
8552             declare
8553                Sind : constant Source_File_Index :=
8554                         Source_Index (Current_Sem_Unit);
8555
8556             begin
8557                case Chars (Get_Pragma_Arg (Arg1)) is
8558                   when Name_GPL =>
8559                      Set_License (Sind, GPL);
8560
8561                   when Name_Modified_GPL =>
8562                      Set_License (Sind, Modified_GPL);
8563
8564                   when Name_Restricted =>
8565                      Set_License (Sind, Restricted);
8566
8567                   when Name_Unrestricted =>
8568                      Set_License (Sind, Unrestricted);
8569
8570                   when others =>
8571                      Error_Pragma_Arg ("invalid license name", Arg1);
8572                end case;
8573             end;
8574
8575          ---------------
8576          -- Link_With --
8577          ---------------
8578
8579          --  pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
8580
8581          when Pragma_Link_With => Link_With : declare
8582             Arg : Node_Id;
8583
8584          begin
8585             GNAT_Pragma;
8586
8587             if Operating_Mode = Generate_Code
8588               and then In_Extended_Main_Source_Unit (N)
8589             then
8590                Check_At_Least_N_Arguments (1);
8591                Check_No_Identifiers;
8592                Check_Is_In_Decl_Part_Or_Package_Spec;
8593                Check_Arg_Is_Static_Expression (Arg1, Standard_String);
8594                Start_String;
8595
8596                Arg := Arg1;
8597                while Present (Arg) loop
8598                   Check_Arg_Is_Static_Expression (Arg, Standard_String);
8599
8600                   --  Store argument, converting sequences of spaces to a
8601                   --  single null character (this is one of the differences
8602                   --  in processing between Link_With and Linker_Options).
8603
8604                   Arg_Store : declare
8605                      C : constant Char_Code := Get_Char_Code (' ');
8606                      S : constant String_Id :=
8607                            Strval (Expr_Value_S (Expression (Arg)));
8608                      L : constant Nat := String_Length (S);
8609                      F : Nat := 1;
8610
8611                      procedure Skip_Spaces;
8612                      --  Advance F past any spaces
8613
8614                      -----------------
8615                      -- Skip_Spaces --
8616                      -----------------
8617
8618                      procedure Skip_Spaces is
8619                      begin
8620                         while F <= L and then Get_String_Char (S, F) = C loop
8621                            F := F + 1;
8622                         end loop;
8623                      end Skip_Spaces;
8624
8625                   --  Start of processing for Arg_Store
8626
8627                   begin
8628                      Skip_Spaces; -- skip leading spaces
8629
8630                      --  Loop through characters, changing any embedded
8631                      --  sequence of spaces to a single null character (this
8632                      --  is how Link_With/Linker_Options differ)
8633
8634                      while F <= L loop
8635                         if Get_String_Char (S, F) = C then
8636                            Skip_Spaces;
8637                            exit when F > L;
8638                            Store_String_Char (ASCII.NUL);
8639
8640                         else
8641                            Store_String_Char (Get_String_Char (S, F));
8642                            F := F + 1;
8643                         end if;
8644                      end loop;
8645                   end Arg_Store;
8646
8647                   Arg := Next (Arg);
8648
8649                   if Present (Arg) then
8650                      Store_String_Char (ASCII.NUL);
8651                   end if;
8652                end loop;
8653
8654                Store_Linker_Option_String (End_String);
8655             end if;
8656          end Link_With;
8657
8658          ------------------
8659          -- Linker_Alias --
8660          ------------------
8661
8662          --  pragma Linker_Alias (
8663          --      [Entity =>]  LOCAL_NAME
8664          --      [Target =>]  static_string_EXPRESSION);
8665
8666          when Pragma_Linker_Alias =>
8667             GNAT_Pragma;
8668             Check_Arg_Order ((Name_Entity, Name_Target));
8669             Check_Arg_Count (2);
8670             Check_Optional_Identifier (Arg1, Name_Entity);
8671             Check_Optional_Identifier (Arg2, Name_Target);
8672             Check_Arg_Is_Library_Level_Local_Name (Arg1);
8673             Check_Arg_Is_Static_Expression (Arg2, Standard_String);
8674
8675             --  The only processing required is to link this item on to the
8676             --  list of rep items for the given entity. This is accomplished
8677             --  by the call to Rep_Item_Too_Late (when no error is detected
8678             --  and False is returned).
8679
8680             if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
8681                return;
8682             else
8683                Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
8684             end if;
8685
8686          ------------------------
8687          -- Linker_Constructor --
8688          ------------------------
8689
8690          --  pragma Linker_Constructor (procedure_LOCAL_NAME);
8691
8692          --  Code is shared with Linker_Destructor
8693
8694          -----------------------
8695          -- Linker_Destructor --
8696          -----------------------
8697
8698          --  pragma Linker_Destructor (procedure_LOCAL_NAME);
8699
8700          when Pragma_Linker_Constructor |
8701               Pragma_Linker_Destructor =>
8702          Linker_Constructor : declare
8703             Arg1_X : Node_Id;
8704             Proc   : Entity_Id;
8705
8706          begin
8707             GNAT_Pragma;
8708             Check_Arg_Count (1);
8709             Check_No_Identifiers;
8710             Check_Arg_Is_Local_Name (Arg1);
8711             Arg1_X := Expression (Arg1);
8712             Analyze (Arg1_X);
8713             Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
8714
8715             if not Is_Library_Level_Entity (Proc) then
8716                Error_Pragma_Arg
8717                 ("argument for pragma% must be library level entity", Arg1);
8718             end if;
8719
8720             --  The only processing required is to link this item on to the
8721             --  list of rep items for the given entity. This is accomplished
8722             --  by the call to Rep_Item_Too_Late (when no error is detected
8723             --  and False is returned).
8724
8725             if Rep_Item_Too_Late (Proc, N) then
8726                return;
8727             else
8728                Set_Has_Gigi_Rep_Item (Proc);
8729             end if;
8730          end Linker_Constructor;
8731
8732          --------------------
8733          -- Linker_Options --
8734          --------------------
8735
8736          --  pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
8737
8738          when Pragma_Linker_Options => Linker_Options : declare
8739             Arg : Node_Id;
8740
8741          begin
8742             Check_Ada_83_Warning;
8743             Check_No_Identifiers;
8744             Check_Arg_Count (1);
8745             Check_Is_In_Decl_Part_Or_Package_Spec;
8746             Check_Arg_Is_Static_Expression (Arg1, Standard_String);
8747             Start_String (Strval (Expr_Value_S (Expression (Arg1))));
8748
8749             Arg := Arg2;
8750             while Present (Arg) loop
8751                Check_Arg_Is_Static_Expression (Arg, Standard_String);
8752                Store_String_Char (ASCII.NUL);
8753                Store_String_Chars (Strval (Expr_Value_S (Expression (Arg))));
8754                Arg := Next (Arg);
8755             end loop;
8756
8757             if Operating_Mode = Generate_Code
8758               and then In_Extended_Main_Source_Unit (N)
8759             then
8760                Store_Linker_Option_String (End_String);
8761             end if;
8762          end Linker_Options;
8763
8764          --------------------
8765          -- Linker_Section --
8766          --------------------
8767
8768          --  pragma Linker_Section (
8769          --      [Entity  =>]  LOCAL_NAME
8770          --      [Section =>]  static_string_EXPRESSION);
8771
8772          when Pragma_Linker_Section =>
8773             GNAT_Pragma;
8774             Check_Arg_Order ((Name_Entity, Name_Section));
8775             Check_Arg_Count (2);
8776             Check_Optional_Identifier (Arg1, Name_Entity);
8777             Check_Optional_Identifier (Arg2, Name_Section);
8778             Check_Arg_Is_Library_Level_Local_Name (Arg1);
8779             Check_Arg_Is_Static_Expression (Arg2, Standard_String);
8780
8781             --  This pragma applies only to objects
8782
8783             if not Is_Object (Entity (Expression (Arg1))) then
8784                Error_Pragma_Arg ("pragma% applies only to objects", Arg1);
8785             end if;
8786
8787             --  The only processing required is to link this item on to the
8788             --  list of rep items for the given entity. This is accomplished
8789             --  by the call to Rep_Item_Too_Late (when no error is detected
8790             --  and False is returned).
8791
8792             if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
8793                return;
8794             else
8795                Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
8796             end if;
8797
8798          ----------
8799          -- List --
8800          ----------
8801
8802          --  pragma List (On | Off)
8803
8804          --  There is nothing to do here, since we did all the processing for
8805          --  this pragma in Par.Prag (so that it works properly even in syntax
8806          --  only mode).
8807
8808          when Pragma_List =>
8809             null;
8810
8811          --------------------
8812          -- Locking_Policy --
8813          --------------------
8814
8815          --  pragma Locking_Policy (policy_IDENTIFIER);
8816
8817          when Pragma_Locking_Policy => declare
8818             LP : Character;
8819
8820          begin
8821             Check_Ada_83_Warning;
8822             Check_Arg_Count (1);
8823             Check_No_Identifiers;
8824             Check_Arg_Is_Locking_Policy (Arg1);
8825             Check_Valid_Configuration_Pragma;
8826             Get_Name_String (Chars (Expression (Arg1)));
8827             LP := Fold_Upper (Name_Buffer (1));
8828
8829             if Locking_Policy /= ' '
8830               and then Locking_Policy /= LP
8831             then
8832                Error_Msg_Sloc := Locking_Policy_Sloc;
8833                Error_Pragma ("locking policy incompatible with policy#");
8834
8835             --  Set new policy, but always preserve System_Location since we
8836             --  like the error message with the run time name.
8837
8838             else
8839                Locking_Policy := LP;
8840
8841                if Locking_Policy_Sloc /= System_Location then
8842                   Locking_Policy_Sloc := Loc;
8843                end if;
8844             end if;
8845          end;
8846
8847          ----------------
8848          -- Long_Float --
8849          ----------------
8850
8851          --  pragma Long_Float (D_Float | G_Float);
8852
8853          when Pragma_Long_Float =>
8854             GNAT_Pragma;
8855             Check_Valid_Configuration_Pragma;
8856             Check_Arg_Count (1);
8857             Check_No_Identifier (Arg1);
8858             Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
8859
8860             if not OpenVMS_On_Target then
8861                Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)");
8862             end if;
8863
8864             --  D_Float case
8865
8866             if Chars (Expression (Arg1)) = Name_D_Float then
8867                if Opt.Float_Format_Long = 'G' then
8868                   Error_Pragma ("G_Float previously specified");
8869                end if;
8870
8871                Opt.Float_Format_Long := 'D';
8872
8873             --  G_Float case (this is the default, does not need overriding)
8874
8875             else
8876                if Opt.Float_Format_Long = 'D' then
8877                   Error_Pragma ("D_Float previously specified");
8878                end if;
8879
8880                Opt.Float_Format_Long := 'G';
8881             end if;
8882
8883             Set_Standard_Fpt_Formats;
8884
8885          -----------------------
8886          -- Machine_Attribute --
8887          -----------------------
8888
8889          --  pragma Machine_Attribute (
8890          --       [Entity         =>] LOCAL_NAME,
8891          --       [Attribute_Name =>] static_string_EXPRESSION
8892          --    [, [Info           =>] static_EXPRESSION] );
8893
8894          when Pragma_Machine_Attribute => Machine_Attribute : declare
8895             Def_Id : Entity_Id;
8896
8897          begin
8898             GNAT_Pragma;
8899             Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
8900
8901             if Arg_Count = 3 then
8902                Check_Optional_Identifier (Arg3, Name_Info);
8903                Check_Arg_Is_Static_Expression (Arg3);
8904             else
8905                Check_Arg_Count (2);
8906             end if;
8907
8908             Check_Optional_Identifier (Arg1, Name_Entity);
8909             Check_Optional_Identifier (Arg2, Name_Attribute_Name);
8910             Check_Arg_Is_Local_Name (Arg1);
8911             Check_Arg_Is_Static_Expression (Arg2, Standard_String);
8912             Def_Id := Entity (Expression (Arg1));
8913
8914             if Is_Access_Type (Def_Id) then
8915                Def_Id := Designated_Type (Def_Id);
8916             end if;
8917
8918             if Rep_Item_Too_Early (Def_Id, N) then
8919                return;
8920             end if;
8921
8922             Def_Id := Underlying_Type (Def_Id);
8923
8924             --  The only processing required is to link this item on to the
8925             --  list of rep items for the given entity. This is accomplished
8926             --  by the call to Rep_Item_Too_Late (when no error is detected
8927             --  and False is returned).
8928
8929             if Rep_Item_Too_Late (Def_Id, N) then
8930                return;
8931             else
8932                Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
8933             end if;
8934          end Machine_Attribute;
8935
8936          ----------
8937          -- Main --
8938          ----------
8939
8940          --  pragma Main
8941          --   (MAIN_OPTION [, MAIN_OPTION]);
8942
8943          --  MAIN_OPTION ::=
8944          --    [STACK_SIZE              =>] static_integer_EXPRESSION
8945          --  | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
8946          --  | [TIME_SLICING_ENABLED    =>] static_boolean_EXPRESSION
8947
8948          when Pragma_Main => Main : declare
8949             Args  : Args_List (1 .. 3);
8950             Names : constant Name_List (1 .. 3) := (
8951                       Name_Stack_Size,
8952                       Name_Task_Stack_Size_Default,
8953                       Name_Time_Slicing_Enabled);
8954
8955             Nod : Node_Id;
8956
8957          begin
8958             GNAT_Pragma;
8959             Gather_Associations (Names, Args);
8960
8961             for J in 1 .. 2 loop
8962                if Present (Args (J)) then
8963                   Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
8964                end if;
8965             end loop;
8966
8967             if Present (Args (3)) then
8968                Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
8969             end if;
8970
8971             Nod := Next (N);
8972             while Present (Nod) loop
8973                if Nkind (Nod) = N_Pragma
8974                  and then Pragma_Name (Nod) = Name_Main
8975                then
8976                   Error_Msg_Name_1 := Pname;
8977                   Error_Msg_N ("duplicate pragma% not permitted", Nod);
8978                end if;
8979
8980                Next (Nod);
8981             end loop;
8982          end Main;
8983
8984          ------------------
8985          -- Main_Storage --
8986          ------------------
8987
8988          --  pragma Main_Storage
8989          --   (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
8990
8991          --  MAIN_STORAGE_OPTION ::=
8992          --    [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
8993          --  | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
8994
8995          when Pragma_Main_Storage => Main_Storage : declare
8996             Args  : Args_List (1 .. 2);
8997             Names : constant Name_List (1 .. 2) := (
8998                       Name_Working_Storage,
8999                       Name_Top_Guard);
9000
9001             Nod : Node_Id;
9002
9003          begin
9004             GNAT_Pragma;
9005             Gather_Associations (Names, Args);
9006
9007             for J in 1 .. 2 loop
9008                if Present (Args (J)) then
9009                   Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
9010                end if;
9011             end loop;
9012
9013             Check_In_Main_Program;
9014
9015             Nod := Next (N);
9016             while Present (Nod) loop
9017                if Nkind (Nod) = N_Pragma
9018                  and then Pragma_Name (Nod) = Name_Main_Storage
9019                then
9020                   Error_Msg_Name_1 := Pname;
9021                   Error_Msg_N ("duplicate pragma% not permitted", Nod);
9022                end if;
9023
9024                Next (Nod);
9025             end loop;
9026          end Main_Storage;
9027
9028          -----------------
9029          -- Memory_Size --
9030          -----------------
9031
9032          --  pragma Memory_Size (NUMERIC_LITERAL)
9033
9034          when Pragma_Memory_Size =>
9035             GNAT_Pragma;
9036
9037             --  Memory size is simply ignored
9038
9039             Check_No_Identifiers;
9040             Check_Arg_Count (1);
9041             Check_Arg_Is_Integer_Literal (Arg1);
9042
9043          -------------
9044          -- No_Body --
9045          -------------
9046
9047          --  pragma No_Body;
9048
9049          --  The only correct use of this pragma is on its own in a file, in
9050          --  which case it is specially processed (see Gnat1drv.Check_Bad_Body
9051          --  and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
9052          --  check for a file containing nothing but a No_Body pragma). If we
9053          --  attempt to process it during normal semantics processing, it means
9054          --  it was misplaced.
9055
9056          when Pragma_No_Body =>
9057             GNAT_Pragma;
9058             Pragma_Misplaced;
9059
9060          ---------------
9061          -- No_Return --
9062          ---------------
9063
9064          --  pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
9065
9066          when Pragma_No_Return => No_Return : declare
9067             Id    : Node_Id;
9068             E     : Entity_Id;
9069             Found : Boolean;
9070             Arg   : Node_Id;
9071
9072          begin
9073             Ada_2005_Pragma;
9074             Check_At_Least_N_Arguments (1);
9075
9076             --  Loop through arguments of pragma
9077
9078             Arg := Arg1;
9079             while Present (Arg) loop
9080                Check_Arg_Is_Local_Name (Arg);
9081                Id := Expression (Arg);
9082                Analyze (Id);
9083
9084                if not Is_Entity_Name (Id) then
9085                   Error_Pragma_Arg ("entity name required", Arg);
9086                end if;
9087
9088                if Etype (Id) = Any_Type then
9089                   raise Pragma_Exit;
9090                end if;
9091
9092                --  Loop to find matching procedures
9093
9094                E := Entity (Id);
9095                Found := False;
9096                while Present (E)
9097                  and then Scope (E) = Current_Scope
9098                loop
9099                   if Ekind (E) = E_Procedure
9100                     or else Ekind (E) = E_Generic_Procedure
9101                   then
9102                      Set_No_Return (E);
9103
9104                      --  Set flag on any alias as well
9105
9106                      if Is_Overloadable (E) and then Present (Alias (E)) then
9107                         Set_No_Return (Alias (E));
9108                      end if;
9109
9110                      Found := True;
9111                   end if;
9112
9113                   E := Homonym (E);
9114                end loop;
9115
9116                if not Found then
9117                   Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
9118                end if;
9119
9120                Next (Arg);
9121             end loop;
9122          end No_Return;
9123
9124          -----------------
9125          -- No_Run_Time --
9126          -----------------
9127
9128          --  pragma No_Run_Time;
9129
9130          --  Note: this pragma is retained for backwards compatibility. See
9131          --  body of Rtsfind for full details on its handling.
9132
9133          when Pragma_No_Run_Time =>
9134             GNAT_Pragma;
9135             Check_Valid_Configuration_Pragma;
9136             Check_Arg_Count (0);
9137
9138             No_Run_Time_Mode           := True;
9139             Configurable_Run_Time_Mode := True;
9140
9141             --  Set Duration to 32 bits if word size is 32
9142
9143             if Ttypes.System_Word_Size = 32 then
9144                Duration_32_Bits_On_Target := True;
9145             end if;
9146
9147             --  Set appropriate restrictions
9148
9149             Set_Restriction (No_Finalization, N);
9150             Set_Restriction (No_Exception_Handlers, N);
9151             Set_Restriction (Max_Tasks, N, 0);
9152             Set_Restriction (No_Tasking, N);
9153
9154          ------------------------
9155          -- No_Strict_Aliasing --
9156          ------------------------
9157
9158          --  pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
9159
9160          when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
9161             E_Id : Entity_Id;
9162
9163          begin
9164             GNAT_Pragma;
9165             Check_At_Most_N_Arguments (1);
9166
9167             if Arg_Count = 0 then
9168                Check_Valid_Configuration_Pragma;
9169                Opt.No_Strict_Aliasing := True;
9170
9171             else
9172                Check_Optional_Identifier (Arg2, Name_Entity);
9173                Check_Arg_Is_Local_Name (Arg1);
9174                E_Id := Entity (Expression (Arg1));
9175
9176                if E_Id = Any_Type then
9177                   return;
9178                elsif No (E_Id) or else not Is_Access_Type (E_Id) then
9179                   Error_Pragma_Arg ("pragma% requires access type", Arg1);
9180                end if;
9181
9182                Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
9183             end if;
9184          end No_Strict_Aliasing;
9185
9186          -----------------------
9187          -- Normalize_Scalars --
9188          -----------------------
9189
9190          --  pragma Normalize_Scalars;
9191
9192          when Pragma_Normalize_Scalars =>
9193             Check_Ada_83_Warning;
9194             Check_Arg_Count (0);
9195             Check_Valid_Configuration_Pragma;
9196
9197             --  Normalize_Scalars creates false positives in CodePeer, so
9198             --  ignore this pragma in this mode.
9199
9200             if not CodePeer_Mode then
9201                Normalize_Scalars := True;
9202                Init_Or_Norm_Scalars := True;
9203             end if;
9204
9205          -----------------
9206          -- Obsolescent --
9207          -----------------
9208
9209          --  pragma Obsolescent;
9210
9211          --  pragma Obsolescent (
9212          --    [Message =>] static_string_EXPRESSION
9213          --  [,[Version =>] Ada_05]]);
9214
9215          --  pragma Obsolescent (
9216          --    [Entity  =>] NAME
9217          --  [,[Message =>] static_string_EXPRESSION
9218          --  [,[Version =>] Ada_05]] );
9219
9220          when Pragma_Obsolescent => Obsolescent : declare
9221             Ename : Node_Id;
9222             Decl  : Node_Id;
9223
9224             procedure Set_Obsolescent (E : Entity_Id);
9225             --  Given an entity Ent, mark it as obsolescent if appropriate
9226
9227             ---------------------
9228             -- Set_Obsolescent --
9229             ---------------------
9230
9231             procedure Set_Obsolescent (E : Entity_Id) is
9232                Active : Boolean;
9233                Ent    : Entity_Id;
9234                S      : String_Id;
9235
9236             begin
9237                Active := True;
9238                Ent    := E;
9239
9240                --  Entity name was given
9241
9242                if Present (Ename) then
9243
9244                   --  If entity name matches, we are fine. Save entity in
9245                   --  pragma argument, for ASIS use.
9246
9247                   if Chars (Ename) = Chars (Ent) then
9248                      Set_Entity (Ename, Ent);
9249                      Generate_Reference (Ent, Ename);
9250
9251                   --  If entity name does not match, only possibility is an
9252                   --  enumeration literal from an enumeration type declaration.
9253
9254                   elsif Ekind (Ent) /= E_Enumeration_Type then
9255                      Error_Pragma
9256                        ("pragma % entity name does not match declaration");
9257
9258                   else
9259                      Ent := First_Literal (E);
9260                      loop
9261                         if No (Ent) then
9262                            Error_Pragma
9263                              ("pragma % entity name does not match any " &
9264                               "enumeration literal");
9265
9266                         elsif Chars (Ent) = Chars (Ename) then
9267                            Set_Entity (Ename, Ent);
9268                            Generate_Reference (Ent, Ename);
9269                            exit;
9270
9271                         else
9272                            Ent := Next_Literal (Ent);
9273                         end if;
9274                      end loop;
9275                   end if;
9276                end if;
9277
9278                --  Ent points to entity to be marked
9279
9280                if Arg_Count >= 1 then
9281
9282                   --  Deal with static string argument
9283
9284                   Check_Arg_Is_Static_Expression (Arg1, Standard_String);
9285                   S := Strval (Expression (Arg1));
9286
9287                   for J in 1 .. String_Length (S) loop
9288                      if not In_Character_Range (Get_String_Char (S, J)) then
9289                         Error_Pragma_Arg
9290                           ("pragma% argument does not allow wide characters",
9291                            Arg1);
9292                      end if;
9293                   end loop;
9294
9295                   Obsolescent_Warnings.Append
9296                     ((Ent => Ent, Msg => Strval (Expression (Arg1))));
9297
9298                   --  Check for Ada_05 parameter
9299
9300                   if Arg_Count /= 1 then
9301                      Check_Arg_Count (2);
9302
9303                      declare
9304                         Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
9305
9306                      begin
9307                         Check_Arg_Is_Identifier (Argx);
9308
9309                         if Chars (Argx) /= Name_Ada_05 then
9310                            Error_Msg_Name_2 := Name_Ada_05;
9311                            Error_Pragma_Arg
9312                              ("only allowed argument for pragma% is %", Argx);
9313                         end if;
9314
9315                         if Ada_Version_Explicit < Ada_05
9316                           or else not Warn_On_Ada_2005_Compatibility
9317                         then
9318                            Active := False;
9319                         end if;
9320                      end;
9321                   end if;
9322                end if;
9323
9324                --  Set flag if pragma active
9325
9326                if Active then
9327                   Set_Is_Obsolescent (Ent);
9328                end if;
9329
9330                return;
9331             end Set_Obsolescent;
9332
9333          --  Start of processing for pragma Obsolescent
9334
9335          begin
9336             GNAT_Pragma;
9337
9338             Check_At_Most_N_Arguments (3);
9339
9340             --  See if first argument specifies an entity name
9341
9342             if Arg_Count >= 1
9343               and then
9344                 (Chars (Arg1) = Name_Entity
9345                    or else
9346                      Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
9347                                                       N_Identifier,
9348                                                       N_Operator_Symbol))
9349             then
9350                Ename := Get_Pragma_Arg (Arg1);
9351
9352                --  Eliminate first argument, so we can share processing
9353
9354                Arg1 := Arg2;
9355                Arg2 := Arg3;
9356                Arg_Count := Arg_Count - 1;
9357
9358             --  No Entity name argument given
9359
9360             else
9361                Ename := Empty;
9362             end if;
9363
9364             if Arg_Count >= 1 then
9365                Check_Optional_Identifier (Arg1, Name_Message);
9366
9367                if Arg_Count = 2 then
9368                   Check_Optional_Identifier (Arg2, Name_Version);
9369                end if;
9370             end if;
9371
9372             --  Get immediately preceding declaration
9373
9374             Decl := Prev (N);
9375             while Present (Decl) and then Nkind (Decl) = N_Pragma loop
9376                Prev (Decl);
9377             end loop;
9378
9379             --  Cases where we do not follow anything other than another pragma
9380
9381             if No (Decl) then
9382
9383                --  First case: library level compilation unit declaration with
9384                --  the pragma immediately following the declaration.
9385
9386                if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
9387                   Set_Obsolescent
9388                     (Defining_Entity (Unit (Parent (Parent (N)))));
9389                   return;
9390
9391                --  Case 2: library unit placement for package
9392
9393                else
9394                   declare
9395                      Ent : constant Entity_Id := Find_Lib_Unit_Name;
9396                   begin
9397                      if Is_Package_Or_Generic_Package (Ent) then
9398                         Set_Obsolescent (Ent);
9399                         return;
9400                      end if;
9401                   end;
9402                end if;
9403
9404             --  Cases where we must follow a declaration
9405
9406             else
9407                if         Nkind (Decl) not in N_Declaration
9408                  and then Nkind (Decl) not in N_Later_Decl_Item
9409                  and then Nkind (Decl) not in N_Generic_Declaration
9410                  and then Nkind (Decl) not in N_Renaming_Declaration
9411                then
9412                   Error_Pragma
9413                     ("pragma% misplaced, "
9414                      & "must immediately follow a declaration");
9415
9416                else
9417                   Set_Obsolescent (Defining_Entity (Decl));
9418                   return;
9419                end if;
9420             end if;
9421          end Obsolescent;
9422
9423          --------------
9424          -- Optimize --
9425          --------------
9426
9427          --  pragma Optimize (Time | Space | Off);
9428
9429          --  The actual check for optimize is done in Gigi. Note that this
9430          --  pragma does not actually change the optimization setting, it
9431          --  simply checks that it is consistent with the pragma.
9432
9433          when Pragma_Optimize =>
9434             Check_No_Identifiers;
9435             Check_Arg_Count (1);
9436             Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
9437
9438          ------------------------
9439          -- Optimize_Alignment --
9440          ------------------------
9441
9442          --  pragma Optimize_Alignment (Time | Space | Off);
9443
9444          when Pragma_Optimize_Alignment =>
9445             GNAT_Pragma;
9446             Check_No_Identifiers;
9447             Check_Arg_Count (1);
9448             Check_Valid_Configuration_Pragma;
9449
9450             declare
9451                Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
9452             begin
9453                case Nam is
9454                   when Name_Time =>
9455                      Opt.Optimize_Alignment := 'T';
9456                   when Name_Space =>
9457                      Opt.Optimize_Alignment := 'S';
9458                   when Name_Off =>
9459                      Opt.Optimize_Alignment := 'O';
9460                   when others =>
9461                      Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
9462                end case;
9463             end;
9464
9465             --  Set indication that mode is set locally. If we are in fact in a
9466             --  configuration pragma file, this setting is harmless since the
9467             --  switch will get reset anyway at the start of each unit.
9468
9469             Optimize_Alignment_Local := True;
9470
9471          ----------
9472          -- Pack --
9473          ----------
9474
9475          --  pragma Pack (first_subtype_LOCAL_NAME);
9476
9477          when Pragma_Pack => Pack : declare
9478             Assoc   : constant Node_Id := Arg1;
9479             Type_Id : Node_Id;
9480             Typ     : Entity_Id;
9481
9482          begin
9483             Check_No_Identifiers;
9484             Check_Arg_Count (1);
9485             Check_Arg_Is_Local_Name (Arg1);
9486
9487             Type_Id := Expression (Assoc);
9488             Find_Type (Type_Id);
9489             Typ := Entity (Type_Id);
9490
9491             if Typ = Any_Type
9492               or else Rep_Item_Too_Early (Typ, N)
9493             then
9494                return;
9495             else
9496                Typ := Underlying_Type (Typ);
9497             end if;
9498
9499             if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
9500                Error_Pragma ("pragma% must specify array or record type");
9501             end if;
9502
9503             Check_First_Subtype (Arg1);
9504
9505             if Has_Pragma_Pack (Typ) then
9506                Error_Pragma ("duplicate pragma%, only one allowed");
9507
9508             --  Array type
9509
9510             elsif Is_Array_Type (Typ) then
9511
9512                --  Pack not allowed for aliased or atomic components
9513
9514                if Has_Aliased_Components (Base_Type (Typ)) then
9515                   Error_Pragma
9516                     ("pragma% ignored, cannot pack aliased components?");
9517
9518                elsif Has_Atomic_Components (Typ)
9519                  or else Is_Atomic (Component_Type (Typ))
9520                then
9521                   Error_Pragma
9522                     ("?pragma% ignored, cannot pack atomic components");
9523                end if;
9524
9525                --  If we had an explicit component size given, then we do not
9526                --  let Pack override this given size. We also give a warning
9527                --  that Pack is being ignored unless we can tell for sure that
9528                --  the Pack would not have had any effect anyway.
9529
9530                if Has_Component_Size_Clause (Typ) then
9531                   if Known_Static_RM_Size (Component_Type (Typ))
9532                     and then
9533                       RM_Size (Component_Type (Typ)) = Component_Size (Typ)
9534                   then
9535                      null;
9536                   else
9537                      Error_Pragma
9538                        ("?pragma% ignored, explicit component size given");
9539                   end if;
9540
9541                --  If no prior array component size given, Pack is effective
9542
9543                else
9544                   if not Rep_Item_Too_Late (Typ, N) then
9545
9546                      --  In the context of static code analysis, we do not need
9547                      --  complex front-end expansions related to pragma Pack,
9548                      --  so disable handling of pragma Pack in this case.
9549
9550                      if CodePeer_Mode then
9551                         null;
9552
9553                      --  For normal non-VM target, do the packing
9554
9555                      elsif VM_Target = No_VM then
9556                         Set_Is_Packed            (Base_Type (Typ));
9557                         Set_Has_Pragma_Pack      (Base_Type (Typ));
9558                            Set_Has_Non_Standard_Rep (Base_Type (Typ));
9559
9560                      --  If we ignore the pack, then warn about this, except
9561                      --  that we suppress the warning in GNAT mode.
9562
9563                      elsif not GNAT_Mode then
9564                         Error_Pragma
9565                           ("?pragma% ignored in this configuration");
9566                      end if;
9567                   end if;
9568                end if;
9569
9570             --  For record types, the pack is always effective
9571
9572             else pragma Assert (Is_Record_Type (Typ));
9573                if not Rep_Item_Too_Late (Typ, N) then
9574                   if VM_Target = No_VM then
9575                      Set_Is_Packed            (Base_Type (Typ));
9576                      Set_Has_Pragma_Pack      (Base_Type (Typ));
9577                      Set_Has_Non_Standard_Rep (Base_Type (Typ));
9578
9579                   elsif not GNAT_Mode then
9580                      Error_Pragma ("?pragma% ignored in this configuration");
9581                   end if;
9582                end if;
9583             end if;
9584          end Pack;
9585
9586          ----------
9587          -- Page --
9588          ----------
9589
9590          --  pragma Page;
9591
9592          --  There is nothing to do here, since we did all the processing for
9593          --  this pragma in Par.Prag (so that it works properly even in syntax
9594          --  only mode).
9595
9596          when Pragma_Page =>
9597             null;
9598
9599          -------------
9600          -- Passive --
9601          -------------
9602
9603          --  pragma Passive [(PASSIVE_FORM)];
9604
9605          --   PASSIVE_FORM ::= Semaphore | No
9606
9607          when Pragma_Passive =>
9608             GNAT_Pragma;
9609
9610             if Nkind (Parent (N)) /= N_Task_Definition then
9611                Error_Pragma ("pragma% must be within task definition");
9612             end if;
9613
9614             if Arg_Count /= 0 then
9615                Check_Arg_Count (1);
9616                Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
9617             end if;
9618
9619          ----------------------------------
9620          -- Preelaborable_Initialization --
9621          ----------------------------------
9622
9623          --  pragma Preelaborable_Initialization (DIRECT_NAME);
9624
9625          when Pragma_Preelaborable_Initialization => Preelab_Init : declare
9626             Ent : Entity_Id;
9627
9628          begin
9629             Ada_2005_Pragma;
9630             Check_Arg_Count (1);
9631             Check_No_Identifiers;
9632             Check_Arg_Is_Identifier (Arg1);
9633             Check_Arg_Is_Local_Name (Arg1);
9634             Check_First_Subtype (Arg1);
9635             Ent := Entity (Expression (Arg1));
9636
9637             if not Is_Private_Type (Ent)
9638               and then not Is_Protected_Type (Ent)
9639             then
9640                Error_Pragma_Arg
9641                  ("pragma % can only be applied to private or protected type",
9642                   Arg1);
9643             end if;
9644
9645             --  Give an error if the pragma is applied to a protected type that
9646             --  does not qualify (due to having entries, or due to components
9647             --  that do not qualify).
9648
9649             if Is_Protected_Type (Ent)
9650               and then not Has_Preelaborable_Initialization (Ent)
9651             then
9652                Error_Msg_N
9653                  ("protected type & does not have preelaborable " &
9654                   "initialization", Ent);
9655
9656             --  Otherwise mark the type as definitely having preelaborable
9657             --  initialization.
9658
9659             else
9660                Set_Known_To_Have_Preelab_Init (Ent);
9661             end if;
9662
9663             if Has_Pragma_Preelab_Init (Ent)
9664               and then Warn_On_Redundant_Constructs
9665             then
9666                Error_Pragma ("?duplicate pragma%!");
9667             else
9668                Set_Has_Pragma_Preelab_Init (Ent);
9669             end if;
9670          end Preelab_Init;
9671
9672          --------------------
9673          -- Persistent_BSS --
9674          --------------------
9675
9676          when Pragma_Persistent_BSS => Persistent_BSS :  declare
9677             Decl : Node_Id;
9678             Ent  : Entity_Id;
9679             Prag : Node_Id;
9680
9681          begin
9682             GNAT_Pragma;
9683             Check_At_Most_N_Arguments (1);
9684
9685             --  Case of application to specific object (one argument)
9686
9687             if Arg_Count = 1 then
9688                Check_Arg_Is_Library_Level_Local_Name (Arg1);
9689
9690                if not Is_Entity_Name (Expression (Arg1))
9691                  or else
9692                   (Ekind (Entity (Expression (Arg1))) /= E_Variable
9693                     and then Ekind (Entity (Expression (Arg1))) /= E_Constant)
9694                then
9695                   Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
9696                end if;
9697
9698                Ent := Entity (Expression (Arg1));
9699                Decl := Parent (Ent);
9700
9701                if Rep_Item_Too_Late (Ent, N) then
9702                   return;
9703                end if;
9704
9705                if Present (Expression (Decl)) then
9706                   Error_Pragma_Arg
9707                     ("object for pragma% cannot have initialization", Arg1);
9708                end if;
9709
9710                if not Is_Potentially_Persistent_Type (Etype (Ent)) then
9711                   Error_Pragma_Arg
9712                     ("object type for pragma% is not potentially persistent",
9713                      Arg1);
9714                end if;
9715
9716                Prag :=
9717                  Make_Linker_Section_Pragma
9718                    (Ent, Sloc (N), ".persistent.bss");
9719                Insert_After (N, Prag);
9720                Analyze (Prag);
9721
9722             --  Case of use as configuration pragma with no arguments
9723
9724             else
9725                Check_Valid_Configuration_Pragma;
9726                Persistent_BSS_Mode := True;
9727             end if;
9728          end Persistent_BSS;
9729
9730          -------------
9731          -- Polling --
9732          -------------
9733
9734          --  pragma Polling (ON | OFF);
9735
9736          when Pragma_Polling =>
9737             GNAT_Pragma;
9738             Check_Arg_Count (1);
9739             Check_No_Identifiers;
9740             Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
9741             Polling_Required := (Chars (Expression (Arg1)) = Name_On);
9742
9743          -------------------
9744          -- Postcondition --
9745          -------------------
9746
9747          --  pragma Postcondition ([Check   =>] Boolean_Expression
9748          --                      [,[Message =>] String_Expression]);
9749
9750          when Pragma_Postcondition => Postcondition : declare
9751             In_Body : Boolean;
9752             pragma Warnings (Off, In_Body);
9753
9754          begin
9755             GNAT_Pragma;
9756             Check_At_Least_N_Arguments (1);
9757             Check_At_Most_N_Arguments (2);
9758             Check_Optional_Identifier (Arg1, Name_Check);
9759
9760             --  All we need to do here is call the common check procedure,
9761             --  the remainder of the processing is found in Sem_Ch6/Sem_Ch7.
9762
9763             Check_Precondition_Postcondition (In_Body);
9764          end Postcondition;
9765
9766          ------------------
9767          -- Precondition --
9768          ------------------
9769
9770          --  pragma Precondition ([Check   =>] Boolean_Expression
9771          --                     [,[Message =>] String_Expression]);
9772
9773          when Pragma_Precondition => Precondition : declare
9774             In_Body : Boolean;
9775
9776          begin
9777             GNAT_Pragma;
9778             Check_At_Least_N_Arguments (1);
9779             Check_At_Most_N_Arguments (2);
9780             Check_Optional_Identifier (Arg1, Name_Check);
9781
9782             Check_Precondition_Postcondition (In_Body);
9783
9784             --  If in spec, nothing more to do. If in body, then we convert the
9785             --  pragma to pragma Check (Precondition, cond [, msg]). Note we do
9786             --  this whether or not precondition checks are enabled. That works
9787             --  fine since pragma Check will do this check, and will also
9788             --  analyze the condition itself in the proper context.
9789
9790             if In_Body then
9791                if Arg_Count = 2 then
9792                   Check_Optional_Identifier (Arg3, Name_Message);
9793                   Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String);
9794                end if;
9795
9796                Rewrite (N,
9797                  Make_Pragma (Loc,
9798                    Chars => Name_Check,
9799                    Pragma_Argument_Associations => New_List (
9800                      Make_Pragma_Argument_Association (Loc,
9801                        Expression =>
9802                          Make_Identifier (Loc,
9803                            Chars => Name_Precondition)),
9804
9805                      Make_Pragma_Argument_Association (Sloc (Arg1),
9806                        Expression => Relocate_Node (Get_Pragma_Arg (Arg1))))));
9807
9808                if Arg_Count = 2 then
9809                   Append_To (Pragma_Argument_Associations (N),
9810                     Make_Pragma_Argument_Association (Sloc (Arg2),
9811                       Expression => Relocate_Node (Get_Pragma_Arg (Arg2))));
9812                end if;
9813
9814                Analyze (N);
9815             end if;
9816          end Precondition;
9817
9818          ------------------
9819          -- Preelaborate --
9820          ------------------
9821
9822          --  pragma Preelaborate [(library_unit_NAME)];
9823
9824          --  Set the flag Is_Preelaborated of program unit name entity
9825
9826          when Pragma_Preelaborate => Preelaborate : declare
9827             Pa  : constant Node_Id   := Parent (N);
9828             Pk  : constant Node_Kind := Nkind (Pa);
9829             Ent : Entity_Id;
9830
9831          begin
9832             Check_Ada_83_Warning;
9833             Check_Valid_Library_Unit_Pragma;
9834
9835             if Nkind (N) = N_Null_Statement then
9836                return;
9837             end if;
9838
9839             Ent := Find_Lib_Unit_Name;
9840
9841             --  This filters out pragmas inside generic parent then
9842             --  show up inside instantiation
9843
9844             if Present (Ent)
9845               and then not (Pk = N_Package_Specification
9846                               and then Present (Generic_Parent (Pa)))
9847             then
9848                if not Debug_Flag_U then
9849                   Set_Is_Preelaborated (Ent);
9850                   Set_Suppress_Elaboration_Warnings (Ent);
9851                end if;
9852             end if;
9853          end Preelaborate;
9854
9855          ---------------------
9856          -- Preelaborate_05 --
9857          ---------------------
9858
9859          --  pragma Preelaborate_05 [(library_unit_NAME)];
9860
9861          --  This pragma is useable only in GNAT_Mode, where it is used like
9862          --  pragma Preelaborate but it is only effective in Ada 2005 mode
9863          --  (otherwise it is ignored). This is used to implement AI-362 which
9864          --  recategorizes some run-time packages in Ada 2005 mode.
9865
9866          when Pragma_Preelaborate_05 => Preelaborate_05 : declare
9867             Ent : Entity_Id;
9868
9869          begin
9870             GNAT_Pragma;
9871             Check_Valid_Library_Unit_Pragma;
9872
9873             if not GNAT_Mode then
9874                Error_Pragma ("pragma% only available in GNAT mode");
9875             end if;
9876
9877             if Nkind (N) = N_Null_Statement then
9878                return;
9879             end if;
9880
9881             --  This is one of the few cases where we need to test the value of
9882             --  Ada_Version_Explicit rather than Ada_Version (which is always
9883             --  set to Ada_05 in a predefined unit), we need to know the
9884             --  explicit version set to know if this pragma is active.
9885
9886             if Ada_Version_Explicit >= Ada_05 then
9887                Ent := Find_Lib_Unit_Name;
9888                Set_Is_Preelaborated (Ent);
9889                Set_Suppress_Elaboration_Warnings (Ent);
9890             end if;
9891          end Preelaborate_05;
9892
9893          --------------
9894          -- Priority --
9895          --------------
9896
9897          --  pragma Priority (EXPRESSION);
9898
9899          when Pragma_Priority => Priority : declare
9900             P   : constant Node_Id := Parent (N);
9901             Arg : Node_Id;
9902
9903          begin
9904             Check_No_Identifiers;
9905             Check_Arg_Count (1);
9906
9907             --  Subprogram case
9908
9909             if Nkind (P) = N_Subprogram_Body then
9910                Check_In_Main_Program;
9911
9912                Arg := Expression (Arg1);
9913                Analyze_And_Resolve (Arg, Standard_Integer);
9914
9915                --  Must be static
9916
9917                if not Is_Static_Expression (Arg) then
9918                   Flag_Non_Static_Expr
9919                     ("main subprogram priority is not static!", Arg);
9920                   raise Pragma_Exit;
9921
9922                --  If constraint error, then we already signalled an error
9923
9924                elsif Raises_Constraint_Error (Arg) then
9925                   null;
9926
9927                --  Otherwise check in range
9928
9929                else
9930                   declare
9931                      Val : constant Uint := Expr_Value (Arg);
9932
9933                   begin
9934                      if Val < 0
9935                        or else Val > Expr_Value (Expression
9936                                        (Parent (RTE (RE_Max_Priority))))
9937                      then
9938                         Error_Pragma_Arg
9939                           ("main subprogram priority is out of range", Arg1);
9940                      end if;
9941                   end;
9942                end if;
9943
9944                Set_Main_Priority
9945                     (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
9946
9947                --  Load an arbitrary entity from System.Tasking to make sure
9948                --  this package is implicitly with'ed, since we need to have
9949                --  the tasking run-time active for the pragma Priority to have
9950                --  any effect.
9951
9952                declare
9953                   Discard : Entity_Id;
9954                   pragma Warnings (Off, Discard);
9955                begin
9956                   Discard := RTE (RE_Task_List);
9957                end;
9958
9959             --  Task or Protected, must be of type Integer
9960
9961             elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
9962                Arg := Expression (Arg1);
9963
9964                --  The expression must be analyzed in the special manner
9965                --  described in "Handling of Default and Per-Object
9966                --  Expressions" in sem.ads.
9967
9968                Preanalyze_Spec_Expression (Arg, Standard_Integer);
9969
9970                if not Is_Static_Expression (Arg) then
9971                   Check_Restriction (Static_Priorities, Arg);
9972                end if;
9973
9974             --  Anything else is incorrect
9975
9976             else
9977                Pragma_Misplaced;
9978             end if;
9979
9980             if Has_Priority_Pragma (P) then
9981                Error_Pragma ("duplicate pragma% not allowed");
9982             else
9983                Set_Has_Priority_Pragma (P, True);
9984
9985                if Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
9986                   Record_Rep_Item (Defining_Identifier (Parent (P)), N);
9987                   --  exp_ch9 should use this ???
9988                end if;
9989             end if;
9990          end Priority;
9991
9992          -----------------------------------
9993          -- Priority_Specific_Dispatching --
9994          -----------------------------------
9995
9996          --  pragma Priority_Specific_Dispatching (
9997          --    policy_IDENTIFIER,
9998          --    first_priority_EXPRESSION,
9999          --    last_priority_EXPRESSION);
10000
10001          when Pragma_Priority_Specific_Dispatching =>
10002          Priority_Specific_Dispatching : declare
10003             Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
10004             --  This is the entity System.Any_Priority;
10005
10006             DP          : Character;
10007             Lower_Bound : Node_Id;
10008             Upper_Bound : Node_Id;
10009             Lower_Val   : Uint;
10010             Upper_Val   : Uint;
10011
10012          begin
10013             Ada_2005_Pragma;
10014             Check_Arg_Count (3);
10015             Check_No_Identifiers;
10016             Check_Arg_Is_Task_Dispatching_Policy (Arg1);
10017             Check_Valid_Configuration_Pragma;
10018             Get_Name_String (Chars (Expression (Arg1)));
10019             DP := Fold_Upper (Name_Buffer (1));
10020
10021             Lower_Bound := Expression (Arg2);
10022             Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
10023             Lower_Val := Expr_Value (Lower_Bound);
10024
10025             Upper_Bound := Expression (Arg3);
10026             Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
10027             Upper_Val := Expr_Value (Upper_Bound);
10028
10029             --  It is not allowed to use Task_Dispatching_Policy and
10030             --  Priority_Specific_Dispatching in the same partition.
10031
10032             if Task_Dispatching_Policy /= ' ' then
10033                Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
10034                Error_Pragma
10035                  ("pragma% incompatible with Task_Dispatching_Policy#");
10036
10037             --  Check lower bound in range
10038
10039             elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
10040                     or else
10041                   Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
10042             then
10043                Error_Pragma_Arg
10044                  ("first_priority is out of range", Arg2);
10045
10046             --  Check upper bound in range
10047
10048             elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
10049                     or else
10050                   Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
10051             then
10052                Error_Pragma_Arg
10053                  ("last_priority is out of range", Arg3);
10054
10055             --  Check that the priority range is valid
10056
10057             elsif Lower_Val > Upper_Val then
10058                Error_Pragma
10059                  ("last_priority_expression must be greater than" &
10060                   " or equal to first_priority_expression");
10061
10062             --  Store the new policy, but always preserve System_Location since
10063             --  we like the error message with the run-time name.
10064
10065             else
10066                --  Check overlapping in the priority ranges specified in other
10067                --  Priority_Specific_Dispatching pragmas within the same
10068                --  partition. We can only check those we know about!
10069
10070                for J in
10071                   Specific_Dispatching.First .. Specific_Dispatching.Last
10072                loop
10073                   if Specific_Dispatching.Table (J).First_Priority in
10074                     UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
10075                   or else Specific_Dispatching.Table (J).Last_Priority in
10076                     UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
10077                   then
10078                      Error_Msg_Sloc :=
10079                        Specific_Dispatching.Table (J).Pragma_Loc;
10080                         Error_Pragma
10081                           ("priority range overlaps with "
10082                            & "Priority_Specific_Dispatching#");
10083                   end if;
10084                end loop;
10085
10086                --  The use of Priority_Specific_Dispatching is incompatible
10087                --  with Task_Dispatching_Policy.
10088
10089                if Task_Dispatching_Policy /= ' ' then
10090                   Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
10091                      Error_Pragma
10092                        ("Priority_Specific_Dispatching incompatible "
10093                         & "with Task_Dispatching_Policy#");
10094                end if;
10095
10096                --  The use of Priority_Specific_Dispatching forces ceiling
10097                --  locking policy.
10098
10099                if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
10100                   Error_Msg_Sloc := Locking_Policy_Sloc;
10101                      Error_Pragma
10102                        ("Priority_Specific_Dispatching incompatible "
10103                         & "with Locking_Policy#");
10104
10105                --  Set the Ceiling_Locking policy, but preserve System_Location
10106                --  since we like the error message with the run time name.
10107
10108                else
10109                   Locking_Policy := 'C';
10110
10111                   if Locking_Policy_Sloc /= System_Location then
10112                      Locking_Policy_Sloc := Loc;
10113                   end if;
10114                end if;
10115
10116                --  Add entry in the table
10117
10118                Specific_Dispatching.Append
10119                     ((Dispatching_Policy => DP,
10120                       First_Priority     => UI_To_Int (Lower_Val),
10121                       Last_Priority      => UI_To_Int (Upper_Val),
10122                       Pragma_Loc         => Loc));
10123             end if;
10124          end Priority_Specific_Dispatching;
10125
10126          -------------
10127          -- Profile --
10128          -------------
10129
10130          --  pragma Profile (profile_IDENTIFIER);
10131
10132          --  profile_IDENTIFIER => Restricted | Ravenscar
10133
10134          when Pragma_Profile =>
10135             Ada_2005_Pragma;
10136             Check_Arg_Count (1);
10137             Check_Valid_Configuration_Pragma;
10138             Check_No_Identifiers;
10139
10140             declare
10141                Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
10142             begin
10143                if Chars (Argx) = Name_Ravenscar then
10144                   Set_Ravenscar_Profile (N);
10145                elsif Chars (Argx) = Name_Restricted then
10146                   Set_Profile_Restrictions
10147                     (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
10148                else
10149                   Error_Pragma_Arg ("& is not a valid profile", Argx);
10150                end if;
10151             end;
10152
10153          ----------------------
10154          -- Profile_Warnings --
10155          ----------------------
10156
10157          --  pragma Profile_Warnings (profile_IDENTIFIER);
10158
10159          --  profile_IDENTIFIER => Restricted | Ravenscar
10160
10161          when Pragma_Profile_Warnings =>
10162             GNAT_Pragma;
10163             Check_Arg_Count (1);
10164             Check_Valid_Configuration_Pragma;
10165             Check_No_Identifiers;
10166
10167             declare
10168                Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
10169             begin
10170                if Chars (Argx) = Name_Ravenscar then
10171                   Set_Profile_Restrictions (Ravenscar, N, Warn => True);
10172                elsif Chars (Argx) = Name_Restricted then
10173                   Set_Profile_Restrictions (Restricted, N, Warn => True);
10174                else
10175                   Error_Pragma_Arg ("& is not a valid profile", Argx);
10176                end if;
10177             end;
10178
10179          --------------------------
10180          -- Propagate_Exceptions --
10181          --------------------------
10182
10183          --  pragma Propagate_Exceptions;
10184
10185          --  Note: this pragma is obsolete and has no effect
10186
10187          when Pragma_Propagate_Exceptions =>
10188             GNAT_Pragma;
10189             Check_Arg_Count (0);
10190
10191             if In_Extended_Main_Source_Unit (N) then
10192                Propagate_Exceptions := True;
10193             end if;
10194
10195          ------------------
10196          -- Psect_Object --
10197          ------------------
10198
10199          --  pragma Psect_Object (
10200          --        [Internal =>] LOCAL_NAME,
10201          --     [, [External =>] EXTERNAL_SYMBOL]
10202          --     [, [Size     =>] EXTERNAL_SYMBOL]);
10203
10204          when Pragma_Psect_Object | Pragma_Common_Object =>
10205          Psect_Object : declare
10206             Args  : Args_List (1 .. 3);
10207             Names : constant Name_List (1 .. 3) := (
10208                       Name_Internal,
10209                       Name_External,
10210                       Name_Size);
10211
10212             Internal : Node_Id renames Args (1);
10213             External : Node_Id renames Args (2);
10214             Size     : Node_Id renames Args (3);
10215
10216             Def_Id : Entity_Id;
10217
10218             procedure Check_Too_Long (Arg : Node_Id);
10219             --  Posts message if the argument is an identifier with more
10220             --  than 31 characters, or a string literal with more than
10221             --  31 characters, and we are operating under VMS
10222
10223             --------------------
10224             -- Check_Too_Long --
10225             --------------------
10226
10227             procedure Check_Too_Long (Arg : Node_Id) is
10228                X : constant Node_Id := Original_Node (Arg);
10229
10230             begin
10231                if not Nkind_In (X, N_String_Literal, N_Identifier) then
10232                   Error_Pragma_Arg
10233                     ("inappropriate argument for pragma %", Arg);
10234                end if;
10235
10236                if OpenVMS_On_Target then
10237                   if (Nkind (X) = N_String_Literal
10238                        and then String_Length (Strval (X)) > 31)
10239                     or else
10240                      (Nkind (X) = N_Identifier
10241                        and then Length_Of_Name (Chars (X)) > 31)
10242                   then
10243                      Error_Pragma_Arg
10244                        ("argument for pragma % is longer than 31 characters",
10245                         Arg);
10246                   end if;
10247                end if;
10248             end Check_Too_Long;
10249
10250          --  Start of processing for Common_Object/Psect_Object
10251
10252          begin
10253             GNAT_Pragma;
10254             Gather_Associations (Names, Args);
10255             Process_Extended_Import_Export_Internal_Arg (Internal);
10256
10257             Def_Id := Entity (Internal);
10258
10259             if Ekind (Def_Id) /= E_Constant
10260               and then Ekind (Def_Id) /= E_Variable
10261             then
10262                Error_Pragma_Arg
10263                  ("pragma% must designate an object", Internal);
10264             end if;
10265
10266             Check_Too_Long (Internal);
10267
10268             if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
10269                Error_Pragma_Arg
10270                  ("cannot use pragma% for imported/exported object",
10271                   Internal);
10272             end if;
10273
10274             if Is_Concurrent_Type (Etype (Internal)) then
10275                Error_Pragma_Arg
10276                  ("cannot specify pragma % for task/protected object",
10277                   Internal);
10278             end if;
10279
10280             if Has_Rep_Pragma (Def_Id, Name_Common_Object)
10281                  or else
10282                Has_Rep_Pragma (Def_Id, Name_Psect_Object)
10283             then
10284                Error_Msg_N ("?duplicate Common/Psect_Object pragma", N);
10285             end if;
10286
10287             if Ekind (Def_Id) = E_Constant then
10288                Error_Pragma_Arg
10289                  ("cannot specify pragma % for a constant", Internal);
10290             end if;
10291
10292             if Is_Record_Type (Etype (Internal)) then
10293                declare
10294                   Ent  : Entity_Id;
10295                   Decl : Entity_Id;
10296
10297                begin
10298                   Ent := First_Entity (Etype (Internal));
10299                   while Present (Ent) loop
10300                      Decl := Declaration_Node (Ent);
10301
10302                      if Ekind (Ent) = E_Component
10303                        and then Nkind (Decl) = N_Component_Declaration
10304                        and then Present (Expression (Decl))
10305                        and then Warn_On_Export_Import
10306                      then
10307                         Error_Msg_N
10308                           ("?object for pragma % has defaults", Internal);
10309                         exit;
10310
10311                      else
10312                         Next_Entity (Ent);
10313                      end if;
10314                   end loop;
10315                end;
10316             end if;
10317
10318             if Present (Size) then
10319                Check_Too_Long (Size);
10320             end if;
10321
10322             if Present (External) then
10323                Check_Arg_Is_External_Name (External);
10324                Check_Too_Long (External);
10325             end if;
10326
10327             --  If all error tests pass, link pragma on to the rep item chain
10328
10329             Record_Rep_Item (Def_Id, N);
10330          end Psect_Object;
10331
10332          ----------
10333          -- Pure --
10334          ----------
10335
10336          --  pragma Pure [(library_unit_NAME)];
10337
10338          when Pragma_Pure => Pure : declare
10339             Ent : Entity_Id;
10340
10341          begin
10342             Check_Ada_83_Warning;
10343             Check_Valid_Library_Unit_Pragma;
10344
10345             if Nkind (N) = N_Null_Statement then
10346                return;
10347             end if;
10348
10349             Ent := Find_Lib_Unit_Name;
10350             Set_Is_Pure (Ent);
10351             Set_Has_Pragma_Pure (Ent);
10352             Set_Suppress_Elaboration_Warnings (Ent);
10353          end Pure;
10354
10355          -------------
10356          -- Pure_05 --
10357          -------------
10358
10359          --  pragma Pure_05 [(library_unit_NAME)];
10360
10361          --  This pragma is useable only in GNAT_Mode, where it is used like
10362          --  pragma Pure but it is only effective in Ada 2005 mode (otherwise
10363          --  it is ignored). It may be used after a pragma Preelaborate, in
10364          --  which case it overrides the effect of the pragma Preelaborate.
10365          --  This is used to implement AI-362 which recategorizes some run-time
10366          --  packages in Ada 2005 mode.
10367
10368          when Pragma_Pure_05 => Pure_05 : declare
10369             Ent : Entity_Id;
10370
10371          begin
10372             GNAT_Pragma;
10373             Check_Valid_Library_Unit_Pragma;
10374
10375             if not GNAT_Mode then
10376                Error_Pragma ("pragma% only available in GNAT mode");
10377             end if;
10378
10379             if Nkind (N) = N_Null_Statement then
10380                return;
10381             end if;
10382
10383             --  This is one of the few cases where we need to test the value of
10384             --  Ada_Version_Explicit rather than Ada_Version (which is always
10385             --  set to Ada_05 in a predefined unit), we need to know the
10386             --  explicit version set to know if this pragma is active.
10387
10388             if Ada_Version_Explicit >= Ada_05 then
10389                Ent := Find_Lib_Unit_Name;
10390                Set_Is_Preelaborated (Ent, False);
10391                Set_Is_Pure (Ent);
10392                Set_Suppress_Elaboration_Warnings (Ent);
10393             end if;
10394          end Pure_05;
10395
10396          -------------------
10397          -- Pure_Function --
10398          -------------------
10399
10400          --  pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
10401
10402          when Pragma_Pure_Function => Pure_Function : declare
10403             E_Id      : Node_Id;
10404             E         : Entity_Id;
10405             Def_Id    : Entity_Id;
10406             Effective : Boolean := False;
10407
10408          begin
10409             GNAT_Pragma;
10410             Check_Arg_Count (1);
10411             Check_Optional_Identifier (Arg1, Name_Entity);
10412             Check_Arg_Is_Local_Name (Arg1);
10413             E_Id := Expression (Arg1);
10414
10415             if Error_Posted (E_Id) then
10416                return;
10417             end if;
10418
10419             --  Loop through homonyms (overloadings) of referenced entity
10420
10421             E := Entity (E_Id);
10422
10423             if Present (E) then
10424                loop
10425                   Def_Id := Get_Base_Subprogram (E);
10426
10427                   if Ekind (Def_Id) /= E_Function
10428                     and then Ekind (Def_Id) /= E_Generic_Function
10429                     and then Ekind (Def_Id) /= E_Operator
10430                   then
10431                      Error_Pragma_Arg
10432                        ("pragma% requires a function name", Arg1);
10433                   end if;
10434
10435                   Set_Is_Pure (Def_Id);
10436
10437                   if not Has_Pragma_Pure_Function (Def_Id) then
10438                      Set_Has_Pragma_Pure_Function (Def_Id);
10439                      Effective := True;
10440                   end if;
10441
10442                   E := Homonym (E);
10443                   exit when No (E) or else Scope (E) /= Current_Scope;
10444                end loop;
10445
10446                if not Effective
10447                  and then Warn_On_Redundant_Constructs
10448                then
10449                   Error_Msg_NE ("pragma Pure_Function on& is redundant?",
10450                     N, Entity (E_Id));
10451                end if;
10452             end if;
10453          end Pure_Function;
10454
10455          --------------------
10456          -- Queuing_Policy --
10457          --------------------
10458
10459          --  pragma Queuing_Policy (policy_IDENTIFIER);
10460
10461          when Pragma_Queuing_Policy => declare
10462             QP : Character;
10463
10464          begin
10465             Check_Ada_83_Warning;
10466             Check_Arg_Count (1);
10467             Check_No_Identifiers;
10468             Check_Arg_Is_Queuing_Policy (Arg1);
10469             Check_Valid_Configuration_Pragma;
10470             Get_Name_String (Chars (Expression (Arg1)));
10471             QP := Fold_Upper (Name_Buffer (1));
10472
10473             if Queuing_Policy /= ' '
10474               and then Queuing_Policy /= QP
10475             then
10476                Error_Msg_Sloc := Queuing_Policy_Sloc;
10477                Error_Pragma ("queuing policy incompatible with policy#");
10478
10479             --  Set new policy, but always preserve System_Location since we
10480             --  like the error message with the run time name.
10481
10482             else
10483                Queuing_Policy := QP;
10484
10485                if Queuing_Policy_Sloc /= System_Location then
10486                   Queuing_Policy_Sloc := Loc;
10487                end if;
10488             end if;
10489          end;
10490
10491          -----------------------
10492          -- Relative_Deadline --
10493          -----------------------
10494
10495          --  pragma Relative_Deadline (time_span_EXPRESSION);
10496
10497          when Pragma_Relative_Deadline => Relative_Deadline : declare
10498             P   : constant Node_Id := Parent (N);
10499             Arg : Node_Id;
10500
10501          begin
10502             Ada_2005_Pragma;
10503             Check_No_Identifiers;
10504             Check_Arg_Count (1);
10505
10506             Arg := Expression (Arg1);
10507
10508             --  The expression must be analyzed in the special manner described
10509             --  in "Handling of Default and Per-Object Expressions" in sem.ads.
10510
10511             Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
10512
10513             --  Subprogram case
10514
10515             if Nkind (P) = N_Subprogram_Body then
10516                Check_In_Main_Program;
10517
10518             --  Tasks
10519
10520             elsif Nkind (P) = N_Task_Definition then
10521                null;
10522
10523             --  Anything else is incorrect
10524
10525             else
10526                Pragma_Misplaced;
10527             end if;
10528
10529             if Has_Relative_Deadline_Pragma (P) then
10530                Error_Pragma ("duplicate pragma% not allowed");
10531             else
10532                Set_Has_Relative_Deadline_Pragma (P, True);
10533
10534                if Nkind (P) = N_Task_Definition then
10535                   Record_Rep_Item (Defining_Identifier (Parent (P)), N);
10536                end if;
10537             end if;
10538          end Relative_Deadline;
10539
10540          ---------------------------
10541          -- Remote_Call_Interface --
10542          ---------------------------
10543
10544          --  pragma Remote_Call_Interface [(library_unit_NAME)];
10545
10546          when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
10547             Cunit_Node : Node_Id;
10548             Cunit_Ent  : Entity_Id;
10549             K          : Node_Kind;
10550
10551          begin
10552             Check_Ada_83_Warning;
10553             Check_Valid_Library_Unit_Pragma;
10554
10555             if Nkind (N) = N_Null_Statement then
10556                return;
10557             end if;
10558
10559             Cunit_Node := Cunit (Current_Sem_Unit);
10560             K          := Nkind (Unit (Cunit_Node));
10561             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
10562
10563             if K = N_Package_Declaration
10564               or else K = N_Generic_Package_Declaration
10565               or else K = N_Subprogram_Declaration
10566               or else K = N_Generic_Subprogram_Declaration
10567               or else (K = N_Subprogram_Body
10568                          and then Acts_As_Spec (Unit (Cunit_Node)))
10569             then
10570                null;
10571             else
10572                Error_Pragma (
10573                  "pragma% must apply to package or subprogram declaration");
10574             end if;
10575
10576             Set_Is_Remote_Call_Interface (Cunit_Ent);
10577          end Remote_Call_Interface;
10578
10579          ------------------
10580          -- Remote_Types --
10581          ------------------
10582
10583          --  pragma Remote_Types [(library_unit_NAME)];
10584
10585          when Pragma_Remote_Types => Remote_Types : declare
10586             Cunit_Node : Node_Id;
10587             Cunit_Ent  : Entity_Id;
10588
10589          begin
10590             Check_Ada_83_Warning;
10591             Check_Valid_Library_Unit_Pragma;
10592
10593             if Nkind (N) = N_Null_Statement then
10594                return;
10595             end if;
10596
10597             Cunit_Node := Cunit (Current_Sem_Unit);
10598             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
10599
10600             if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
10601                                                 N_Generic_Package_Declaration)
10602             then
10603                Error_Pragma
10604                  ("pragma% can only apply to a package declaration");
10605             end if;
10606
10607             Set_Is_Remote_Types (Cunit_Ent);
10608          end Remote_Types;
10609
10610          ---------------
10611          -- Ravenscar --
10612          ---------------
10613
10614          --  pragma Ravenscar;
10615
10616          when Pragma_Ravenscar =>
10617             GNAT_Pragma;
10618             Check_Arg_Count (0);
10619             Check_Valid_Configuration_Pragma;
10620             Set_Ravenscar_Profile (N);
10621
10622             if Warn_On_Obsolescent_Feature then
10623                Error_Msg_N
10624                  ("pragma Ravenscar is an obsolescent feature?", N);
10625                Error_Msg_N
10626                  ("|use pragma Profile (Ravenscar) instead", N);
10627             end if;
10628
10629          -------------------------
10630          -- Restricted_Run_Time --
10631          -------------------------
10632
10633          --  pragma Restricted_Run_Time;
10634
10635          when Pragma_Restricted_Run_Time =>
10636             GNAT_Pragma;
10637             Check_Arg_Count (0);
10638             Check_Valid_Configuration_Pragma;
10639             Set_Profile_Restrictions
10640               (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
10641
10642             if Warn_On_Obsolescent_Feature then
10643                Error_Msg_N
10644                  ("pragma Restricted_Run_Time is an obsolescent feature?", N);
10645                Error_Msg_N
10646                  ("|use pragma Profile (Restricted) instead", N);
10647             end if;
10648
10649          ------------------
10650          -- Restrictions --
10651          ------------------
10652
10653          --  pragma Restrictions (RESTRICTION {, RESTRICTION});
10654
10655          --  RESTRICTION ::=
10656          --    restriction_IDENTIFIER
10657          --  | restriction_parameter_IDENTIFIER => EXPRESSION
10658
10659          when Pragma_Restrictions =>
10660             Process_Restrictions_Or_Restriction_Warnings
10661               (Warn => Treat_Restrictions_As_Warnings);
10662
10663          --------------------------
10664          -- Restriction_Warnings --
10665          --------------------------
10666
10667          --  pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
10668
10669          --  RESTRICTION ::=
10670          --    restriction_IDENTIFIER
10671          --  | restriction_parameter_IDENTIFIER => EXPRESSION
10672
10673          when Pragma_Restriction_Warnings =>
10674             GNAT_Pragma;
10675             Process_Restrictions_Or_Restriction_Warnings (Warn => True);
10676
10677          ----------------
10678          -- Reviewable --
10679          ----------------
10680
10681          --  pragma Reviewable;
10682
10683          when Pragma_Reviewable =>
10684             Check_Ada_83_Warning;
10685             Check_Arg_Count (0);
10686
10687             --  Call dummy debugging function rv. This is done to assist front
10688             --  end debugging. By placing a Reviewable pragma in the source
10689             --  program, a breakpoint on rv catches this place in the source,
10690             --  allowing convenient stepping to the point of interest.
10691
10692             rv;
10693
10694          --------------------------
10695          -- Short_Circuit_And_Or --
10696          --------------------------
10697
10698          when Pragma_Short_Circuit_And_Or =>
10699             GNAT_Pragma;
10700             Check_Arg_Count (0);
10701             Check_Valid_Configuration_Pragma;
10702             Short_Circuit_And_Or := True;
10703
10704          -------------------
10705          -- Share_Generic --
10706          -------------------
10707
10708          --  pragma Share_Generic (NAME {, NAME});
10709
10710          when Pragma_Share_Generic =>
10711             GNAT_Pragma;
10712             Process_Generic_List;
10713
10714          ------------
10715          -- Shared --
10716          ------------
10717
10718          --  pragma Shared (LOCAL_NAME);
10719
10720          when Pragma_Shared =>
10721             GNAT_Pragma;
10722             Process_Atomic_Shared_Volatile;
10723
10724          --------------------
10725          -- Shared_Passive --
10726          --------------------
10727
10728          --  pragma Shared_Passive [(library_unit_NAME)];
10729
10730          --  Set the flag Is_Shared_Passive of program unit name entity
10731
10732          when Pragma_Shared_Passive => Shared_Passive : declare
10733             Cunit_Node : Node_Id;
10734             Cunit_Ent  : Entity_Id;
10735
10736          begin
10737             Check_Ada_83_Warning;
10738             Check_Valid_Library_Unit_Pragma;
10739
10740             if Nkind (N) = N_Null_Statement then
10741                return;
10742             end if;
10743
10744             Cunit_Node := Cunit (Current_Sem_Unit);
10745             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
10746
10747             if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
10748                                                 N_Generic_Package_Declaration)
10749             then
10750                Error_Pragma
10751                  ("pragma% can only apply to a package declaration");
10752             end if;
10753
10754             Set_Is_Shared_Passive (Cunit_Ent);
10755          end Shared_Passive;
10756
10757          ----------------------
10758          -- Source_File_Name --
10759          ----------------------
10760
10761          --  There are five forms for this pragma:
10762
10763          --  pragma Source_File_Name (
10764          --    [UNIT_NAME      =>] unit_NAME,
10765          --     BODY_FILE_NAME =>  STRING_LITERAL
10766          --    [, [INDEX =>] INTEGER_LITERAL]);
10767
10768          --  pragma Source_File_Name (
10769          --    [UNIT_NAME      =>] unit_NAME,
10770          --     SPEC_FILE_NAME =>  STRING_LITERAL
10771          --    [, [INDEX =>] INTEGER_LITERAL]);
10772
10773          --  pragma Source_File_Name (
10774          --     BODY_FILE_NAME  => STRING_LITERAL
10775          --  [, DOT_REPLACEMENT => STRING_LITERAL]
10776          --  [, CASING          => CASING_SPEC]);
10777
10778          --  pragma Source_File_Name (
10779          --     SPEC_FILE_NAME  => STRING_LITERAL
10780          --  [, DOT_REPLACEMENT => STRING_LITERAL]
10781          --  [, CASING          => CASING_SPEC]);
10782
10783          --  pragma Source_File_Name (
10784          --     SUBUNIT_FILE_NAME  => STRING_LITERAL
10785          --  [, DOT_REPLACEMENT    => STRING_LITERAL]
10786          --  [, CASING             => CASING_SPEC]);
10787
10788          --  CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
10789
10790          --  Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
10791          --  Source_File_Name (SFN), however their usage is exclusive: SFN can
10792          --  only be used when no project file is used, while SFNP can only be
10793          --  used when a project file is used.
10794
10795          --  No processing here. Processing was completed during parsing, since
10796          --  we need to have file names set as early as possible. Units are
10797          --  loaded well before semantic processing starts.
10798
10799          --  The only processing we defer to this point is the check for
10800          --  correct placement.
10801
10802          when Pragma_Source_File_Name =>
10803             GNAT_Pragma;
10804             Check_Valid_Configuration_Pragma;
10805
10806          ------------------------------
10807          -- Source_File_Name_Project --
10808          ------------------------------
10809
10810          --  See Source_File_Name for syntax
10811
10812          --  No processing here. Processing was completed during parsing, since
10813          --  we need to have file names set as early as possible. Units are
10814          --  loaded well before semantic processing starts.
10815
10816          --  The only processing we defer to this point is the check for
10817          --  correct placement.
10818
10819          when Pragma_Source_File_Name_Project =>
10820             GNAT_Pragma;
10821             Check_Valid_Configuration_Pragma;
10822
10823             --  Check that a pragma Source_File_Name_Project is used only in a
10824             --  configuration pragmas file.
10825
10826             --  Pragmas Source_File_Name_Project should only be generated by
10827             --  the Project Manager in configuration pragmas files.
10828
10829             --  This is really an ugly test. It seems to depend on some
10830             --  accidental and undocumented property. At the very least it
10831             --  needs to be documented, but it would be better to have a
10832             --  clean way of testing if we are in a configuration file???
10833
10834             if Present (Parent (N)) then
10835                Error_Pragma
10836                  ("pragma% can only appear in a configuration pragmas file");
10837             end if;
10838
10839          ----------------------
10840          -- Source_Reference --
10841          ----------------------
10842
10843          --  pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
10844
10845          --  Nothing to do, all processing completed in Par.Prag, since we need
10846          --  the information for possible parser messages that are output.
10847
10848          when Pragma_Source_Reference =>
10849             GNAT_Pragma;
10850
10851          --------------------------------
10852          -- Static_Elaboration_Desired --
10853          --------------------------------
10854
10855          --  pragma Static_Elaboration_Desired (DIRECT_NAME);
10856
10857          when Pragma_Static_Elaboration_Desired =>
10858             GNAT_Pragma;
10859             Check_At_Most_N_Arguments (1);
10860
10861             if Is_Compilation_Unit (Current_Scope)
10862               and then Ekind (Current_Scope) = E_Package
10863             then
10864                Set_Static_Elaboration_Desired (Current_Scope, True);
10865             else
10866                Error_Pragma ("pragma% must apply to a library-level package");
10867             end if;
10868
10869          ------------------
10870          -- Storage_Size --
10871          ------------------
10872
10873          --  pragma Storage_Size (EXPRESSION);
10874
10875          when Pragma_Storage_Size => Storage_Size : declare
10876             P   : constant Node_Id := Parent (N);
10877             Arg : Node_Id;
10878
10879          begin
10880             Check_No_Identifiers;
10881             Check_Arg_Count (1);
10882
10883             --  The expression must be analyzed in the special manner described
10884             --  in "Handling of Default Expressions" in sem.ads.
10885
10886             Arg := Expression (Arg1);
10887             Preanalyze_Spec_Expression (Arg, Any_Integer);
10888
10889             if not Is_Static_Expression (Arg) then
10890                Check_Restriction (Static_Storage_Size, Arg);
10891             end if;
10892
10893             if Nkind (P) /= N_Task_Definition then
10894                Pragma_Misplaced;
10895                return;
10896
10897             else
10898                if Has_Storage_Size_Pragma (P) then
10899                   Error_Pragma ("duplicate pragma% not allowed");
10900                else
10901                   Set_Has_Storage_Size_Pragma (P, True);
10902                end if;
10903
10904                Record_Rep_Item (Defining_Identifier (Parent (P)), N);
10905                --  ???  exp_ch9 should use this!
10906             end if;
10907          end Storage_Size;
10908
10909          ------------------
10910          -- Storage_Unit --
10911          ------------------
10912
10913          --  pragma Storage_Unit (NUMERIC_LITERAL);
10914
10915          --  Only permitted argument is System'Storage_Unit value
10916
10917          when Pragma_Storage_Unit =>
10918             Check_No_Identifiers;
10919             Check_Arg_Count (1);
10920             Check_Arg_Is_Integer_Literal (Arg1);
10921
10922             if Intval (Expression (Arg1)) /=
10923               UI_From_Int (Ttypes.System_Storage_Unit)
10924             then
10925                Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
10926                Error_Pragma_Arg
10927                  ("the only allowed argument for pragma% is ^", Arg1);
10928             end if;
10929
10930          --------------------
10931          -- Stream_Convert --
10932          --------------------
10933
10934          --  pragma Stream_Convert (
10935          --    [Entity =>] type_LOCAL_NAME,
10936          --    [Read   =>] function_NAME,
10937          --    [Write  =>] function NAME);
10938
10939          when Pragma_Stream_Convert => Stream_Convert : declare
10940
10941             procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
10942             --  Check that the given argument is the name of a local function
10943             --  of one argument that is not overloaded earlier in the current
10944             --  local scope. A check is also made that the argument is a
10945             --  function with one parameter.
10946
10947             --------------------------------------
10948             -- Check_OK_Stream_Convert_Function --
10949             --------------------------------------
10950
10951             procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
10952                Ent : Entity_Id;
10953
10954             begin
10955                Check_Arg_Is_Local_Name (Arg);
10956                Ent := Entity (Expression (Arg));
10957
10958                if Has_Homonym (Ent) then
10959                   Error_Pragma_Arg
10960                     ("argument for pragma% may not be overloaded", Arg);
10961                end if;
10962
10963                if Ekind (Ent) /= E_Function
10964                  or else No (First_Formal (Ent))
10965                  or else Present (Next_Formal (First_Formal (Ent)))
10966                then
10967                   Error_Pragma_Arg
10968                     ("argument for pragma% must be" &
10969                      " function of one argument", Arg);
10970                end if;
10971             end Check_OK_Stream_Convert_Function;
10972
10973          --  Start of processing for Stream_Convert
10974
10975          begin
10976             GNAT_Pragma;
10977             Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
10978             Check_Arg_Count (3);
10979             Check_Optional_Identifier (Arg1, Name_Entity);
10980             Check_Optional_Identifier (Arg2, Name_Read);
10981             Check_Optional_Identifier (Arg3, Name_Write);
10982             Check_Arg_Is_Local_Name (Arg1);
10983             Check_OK_Stream_Convert_Function (Arg2);
10984             Check_OK_Stream_Convert_Function (Arg3);
10985
10986             declare
10987                Typ   : constant Entity_Id :=
10988                          Underlying_Type (Entity (Expression (Arg1)));
10989                Read  : constant Entity_Id := Entity (Expression (Arg2));
10990                Write : constant Entity_Id := Entity (Expression (Arg3));
10991
10992             begin
10993                Check_First_Subtype (Arg1);
10994
10995                --  Check for too early or too late. Note that we don't enforce
10996                --  the rule about primitive operations in this case, since, as
10997                --  is the case for explicit stream attributes themselves, these
10998                --  restrictions are not appropriate. Note that the chaining of
10999                --  the pragma by Rep_Item_Too_Late is actually the critical
11000                --  processing done for this pragma.
11001
11002                if Rep_Item_Too_Early (Typ, N)
11003                     or else
11004                   Rep_Item_Too_Late (Typ, N, FOnly => True)
11005                then
11006                   return;
11007                end if;
11008
11009                --  Return if previous error
11010
11011                if Etype (Typ) = Any_Type
11012                     or else
11013                   Etype (Read) = Any_Type
11014                     or else
11015                   Etype (Write) = Any_Type
11016                then
11017                   return;
11018                end if;
11019
11020                --  Error checks
11021
11022                if Underlying_Type (Etype (Read)) /= Typ then
11023                   Error_Pragma_Arg
11024                     ("incorrect return type for function&", Arg2);
11025                end if;
11026
11027                if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
11028                   Error_Pragma_Arg
11029                     ("incorrect parameter type for function&", Arg3);
11030                end if;
11031
11032                if Underlying_Type (Etype (First_Formal (Read))) /=
11033                   Underlying_Type (Etype (Write))
11034                then
11035                   Error_Pragma_Arg
11036                     ("result type of & does not match Read parameter type",
11037                      Arg3);
11038                end if;
11039             end;
11040          end Stream_Convert;
11041
11042          -------------------------
11043          -- Style_Checks (GNAT) --
11044          -------------------------
11045
11046          --  pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
11047
11048          --  This is processed by the parser since some of the style checks
11049          --  take place during source scanning and parsing. This means that
11050          --  we don't need to issue error messages here.
11051
11052          when Pragma_Style_Checks => Style_Checks : declare
11053             A  : constant Node_Id   := Expression (Arg1);
11054             S  : String_Id;
11055             C  : Char_Code;
11056
11057          begin
11058             GNAT_Pragma;
11059             Check_No_Identifiers;
11060
11061             --  Two argument form
11062
11063             if Arg_Count = 2 then
11064                Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
11065
11066                declare
11067                   E_Id : Node_Id;
11068                   E    : Entity_Id;
11069
11070                begin
11071                   E_Id := Expression (Arg2);
11072                   Analyze (E_Id);
11073
11074                   if not Is_Entity_Name (E_Id) then
11075                      Error_Pragma_Arg
11076                        ("second argument of pragma% must be entity name",
11077                         Arg2);
11078                   end if;
11079
11080                   E := Entity (E_Id);
11081
11082                   if E = Any_Id then
11083                      return;
11084                   else
11085                      loop
11086                         Set_Suppress_Style_Checks (E,
11087                           (Chars (Expression (Arg1)) = Name_Off));
11088                         exit when No (Homonym (E));
11089                         E := Homonym (E);
11090                      end loop;
11091                   end if;
11092                end;
11093
11094             --  One argument form
11095
11096             else
11097                Check_Arg_Count (1);
11098
11099                if Nkind (A) = N_String_Literal then
11100                   S   := Strval (A);
11101
11102                   declare
11103                      Slen    : constant Natural := Natural (String_Length (S));
11104                      Options : String (1 .. Slen);
11105                      J       : Natural;
11106
11107                   begin
11108                      J := 1;
11109                      loop
11110                         C := Get_String_Char (S, Int (J));
11111                         exit when not In_Character_Range (C);
11112                         Options (J) := Get_Character (C);
11113
11114                         --  If at end of string, set options. As per discussion
11115                         --  above, no need to check for errors, since we issued
11116                         --  them in the parser.
11117
11118                         if J = Slen then
11119                            Set_Style_Check_Options (Options);
11120                            exit;
11121                         end if;
11122
11123                         J := J + 1;
11124                      end loop;
11125                   end;
11126
11127                elsif Nkind (A) = N_Identifier then
11128                   if Chars (A) = Name_All_Checks then
11129                      Set_Default_Style_Check_Options;
11130
11131                   elsif Chars (A) = Name_On then
11132                      Style_Check := True;
11133
11134                   elsif Chars (A) = Name_Off then
11135                      Style_Check := False;
11136                   end if;
11137                end if;
11138             end if;
11139          end Style_Checks;
11140
11141          --------------
11142          -- Subtitle --
11143          --------------
11144
11145          --  pragma Subtitle ([Subtitle =>] STRING_LITERAL);
11146
11147          when Pragma_Subtitle =>
11148             GNAT_Pragma;
11149             Check_Arg_Count (1);
11150             Check_Optional_Identifier (Arg1, Name_Subtitle);
11151             Check_Arg_Is_String_Literal (Arg1);
11152
11153          --------------
11154          -- Suppress --
11155          --------------
11156
11157          --  pragma Suppress (IDENTIFIER [, [On =>] NAME]);
11158
11159          when Pragma_Suppress =>
11160             Process_Suppress_Unsuppress (True);
11161
11162          ------------------
11163          -- Suppress_All --
11164          ------------------
11165
11166          --  pragma Suppress_All;
11167
11168          --  The only check made here is that the pragma appears in the proper
11169          --  place, i.e. following a compilation unit. If indeed it appears in
11170          --  this context, then the parser has already inserted an equivalent
11171          --  pragma Suppress (All_Checks) to get the required effect.
11172
11173          when Pragma_Suppress_All =>
11174             GNAT_Pragma;
11175             Check_Arg_Count (0);
11176
11177             if Nkind (Parent (N)) /= N_Compilation_Unit_Aux
11178               or else not Is_List_Member (N)
11179               or else List_Containing (N) /= Pragmas_After (Parent (N))
11180             then
11181                Error_Pragma
11182                  ("misplaced pragma%, must follow compilation unit");
11183             end if;
11184
11185          -------------------------
11186          -- Suppress_Debug_Info --
11187          -------------------------
11188
11189          --  pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
11190
11191          when Pragma_Suppress_Debug_Info =>
11192             GNAT_Pragma;
11193             Check_Arg_Count (1);
11194             Check_Optional_Identifier (Arg1, Name_Entity);
11195             Check_Arg_Is_Local_Name (Arg1);
11196             Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
11197
11198          ----------------------------------
11199          -- Suppress_Exception_Locations --
11200          ----------------------------------
11201
11202          --  pragma Suppress_Exception_Locations;
11203
11204          when Pragma_Suppress_Exception_Locations =>
11205             GNAT_Pragma;
11206             Check_Arg_Count (0);
11207             Check_Valid_Configuration_Pragma;
11208             Exception_Locations_Suppressed := True;
11209
11210          -----------------------------
11211          -- Suppress_Initialization --
11212          -----------------------------
11213
11214          --  pragma Suppress_Initialization ([Entity =>] type_Name);
11215
11216          when Pragma_Suppress_Initialization => Suppress_Init : declare
11217             E_Id : Node_Id;
11218             E    : Entity_Id;
11219
11220          begin
11221             GNAT_Pragma;
11222             Check_Arg_Count (1);
11223             Check_Optional_Identifier (Arg1, Name_Entity);
11224             Check_Arg_Is_Local_Name (Arg1);
11225
11226             E_Id := Expression (Arg1);
11227
11228             if Etype (E_Id) = Any_Type then
11229                return;
11230             end if;
11231
11232             E := Entity (E_Id);
11233
11234             if Is_Type (E) then
11235                if Is_Incomplete_Or_Private_Type (E) then
11236                   if No (Full_View (Base_Type (E))) then
11237                      Error_Pragma_Arg
11238                        ("argument of pragma% cannot be an incomplete type",
11239                          Arg1);
11240                   else
11241                      Set_Suppress_Init_Proc (Full_View (Base_Type (E)));
11242                   end if;
11243                else
11244                   Set_Suppress_Init_Proc (Base_Type (E));
11245                end if;
11246
11247             else
11248                Error_Pragma_Arg
11249                  ("pragma% requires argument that is a type name", Arg1);
11250             end if;
11251          end Suppress_Init;
11252
11253          -----------------
11254          -- System_Name --
11255          -----------------
11256
11257          --  pragma System_Name (DIRECT_NAME);
11258
11259          --  Syntax check: one argument, which must be the identifier GNAT or
11260          --  the identifier GCC, no other identifiers are acceptable.
11261
11262          when Pragma_System_Name =>
11263             GNAT_Pragma;
11264             Check_No_Identifiers;
11265             Check_Arg_Count (1);
11266             Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
11267
11268          -----------------------------
11269          -- Task_Dispatching_Policy --
11270          -----------------------------
11271
11272          --  pragma Task_Dispatching_Policy (policy_IDENTIFIER);
11273
11274          when Pragma_Task_Dispatching_Policy => declare
11275             DP : Character;
11276
11277          begin
11278             Check_Ada_83_Warning;
11279             Check_Arg_Count (1);
11280             Check_No_Identifiers;
11281             Check_Arg_Is_Task_Dispatching_Policy (Arg1);
11282             Check_Valid_Configuration_Pragma;
11283             Get_Name_String (Chars (Expression (Arg1)));
11284             DP := Fold_Upper (Name_Buffer (1));
11285
11286             if Task_Dispatching_Policy /= ' '
11287               and then Task_Dispatching_Policy /= DP
11288             then
11289                Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
11290                Error_Pragma
11291                  ("task dispatching policy incompatible with policy#");
11292
11293             --  Set new policy, but always preserve System_Location since we
11294             --  like the error message with the run time name.
11295
11296             else
11297                Task_Dispatching_Policy := DP;
11298
11299                if Task_Dispatching_Policy_Sloc /= System_Location then
11300                   Task_Dispatching_Policy_Sloc := Loc;
11301                end if;
11302             end if;
11303          end;
11304
11305          --------------
11306          -- Task_Info --
11307          --------------
11308
11309          --  pragma Task_Info (EXPRESSION);
11310
11311          when Pragma_Task_Info => Task_Info : declare
11312             P : constant Node_Id := Parent (N);
11313
11314          begin
11315             GNAT_Pragma;
11316
11317             if Nkind (P) /= N_Task_Definition then
11318                Error_Pragma ("pragma% must appear in task definition");
11319             end if;
11320
11321             Check_No_Identifiers;
11322             Check_Arg_Count (1);
11323
11324             Analyze_And_Resolve (Expression (Arg1), RTE (RE_Task_Info_Type));
11325
11326             if Etype (Expression (Arg1)) = Any_Type then
11327                return;
11328             end if;
11329
11330             if Has_Task_Info_Pragma (P) then
11331                Error_Pragma ("duplicate pragma% not allowed");
11332             else
11333                Set_Has_Task_Info_Pragma (P, True);
11334             end if;
11335          end Task_Info;
11336
11337          ---------------
11338          -- Task_Name --
11339          ---------------
11340
11341          --  pragma Task_Name (string_EXPRESSION);
11342
11343          when Pragma_Task_Name => Task_Name : declare
11344             P   : constant Node_Id := Parent (N);
11345             Arg : Node_Id;
11346
11347          begin
11348             Check_No_Identifiers;
11349             Check_Arg_Count (1);
11350
11351             Arg := Expression (Arg1);
11352
11353             --  The expression is used in the call to Create_Task, and must be
11354             --  expanded there, not in the context of the current spec. It must
11355             --  however be analyzed to capture global references, in case it
11356             --  appears in a generic context.
11357
11358             Preanalyze_And_Resolve (Arg, Standard_String);
11359
11360             if Nkind (P) /= N_Task_Definition then
11361                Pragma_Misplaced;
11362             end if;
11363
11364             if Has_Task_Name_Pragma (P) then
11365                Error_Pragma ("duplicate pragma% not allowed");
11366             else
11367                Set_Has_Task_Name_Pragma (P, True);
11368                Record_Rep_Item (Defining_Identifier (Parent (P)), N);
11369             end if;
11370          end Task_Name;
11371
11372          ------------------
11373          -- Task_Storage --
11374          ------------------
11375
11376          --  pragma Task_Storage (
11377          --     [Task_Type =>] LOCAL_NAME,
11378          --     [Top_Guard =>] static_integer_EXPRESSION);
11379
11380          when Pragma_Task_Storage => Task_Storage : declare
11381             Args  : Args_List (1 .. 2);
11382             Names : constant Name_List (1 .. 2) := (
11383                       Name_Task_Type,
11384                       Name_Top_Guard);
11385
11386             Task_Type : Node_Id renames Args (1);
11387             Top_Guard : Node_Id renames Args (2);
11388
11389             Ent : Entity_Id;
11390
11391          begin
11392             GNAT_Pragma;
11393             Gather_Associations (Names, Args);
11394
11395             if No (Task_Type) then
11396                Error_Pragma
11397                  ("missing task_type argument for pragma%");
11398             end if;
11399
11400             Check_Arg_Is_Local_Name (Task_Type);
11401
11402             Ent := Entity (Task_Type);
11403
11404             if not Is_Task_Type (Ent) then
11405                Error_Pragma_Arg
11406                  ("argument for pragma% must be task type", Task_Type);
11407             end if;
11408
11409             if No (Top_Guard) then
11410                Error_Pragma_Arg
11411                  ("pragma% takes two arguments", Task_Type);
11412             else
11413                Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
11414             end if;
11415
11416             Check_First_Subtype (Task_Type);
11417
11418             if Rep_Item_Too_Late (Ent, N) then
11419                raise Pragma_Exit;
11420             end if;
11421          end Task_Storage;
11422
11423          --------------------------
11424          -- Thread_Local_Storage --
11425          --------------------------
11426
11427          --  pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
11428
11429          when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
11430             Id : Node_Id;
11431             E  : Entity_Id;
11432
11433          begin
11434             GNAT_Pragma;
11435             Check_Arg_Count (1);
11436             Check_Optional_Identifier (Arg1, Name_Entity);
11437             Check_Arg_Is_Library_Level_Local_Name (Arg1);
11438
11439             Id := Expression (Arg1);
11440             Analyze (Id);
11441
11442             if not Is_Entity_Name (Id)
11443               or else Ekind (Entity (Id)) /= E_Variable
11444             then
11445                Error_Pragma_Arg ("local variable name required", Arg1);
11446             end if;
11447
11448             E := Entity (Id);
11449
11450             if Rep_Item_Too_Early (E, N)
11451               or else Rep_Item_Too_Late (E, N)
11452             then
11453                raise Pragma_Exit;
11454             end if;
11455
11456             Set_Has_Pragma_Thread_Local_Storage (E);
11457             Set_Has_Gigi_Rep_Item (E);
11458          end Thread_Local_Storage;
11459
11460          ----------------
11461          -- Time_Slice --
11462          ----------------
11463
11464          --  pragma Time_Slice (static_duration_EXPRESSION);
11465
11466          when Pragma_Time_Slice => Time_Slice : declare
11467             Val : Ureal;
11468             Nod : Node_Id;
11469
11470          begin
11471             GNAT_Pragma;
11472             Check_Arg_Count (1);
11473             Check_No_Identifiers;
11474             Check_In_Main_Program;
11475             Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
11476
11477             if not Error_Posted (Arg1) then
11478                Nod := Next (N);
11479                while Present (Nod) loop
11480                   if Nkind (Nod) = N_Pragma
11481                     and then Pragma_Name (Nod) = Name_Time_Slice
11482                   then
11483                      Error_Msg_Name_1 := Pname;
11484                      Error_Msg_N ("duplicate pragma% not permitted", Nod);
11485                   end if;
11486
11487                   Next (Nod);
11488                end loop;
11489             end if;
11490
11491             --  Process only if in main unit
11492
11493             if Get_Source_Unit (Loc) = Main_Unit then
11494                Opt.Time_Slice_Set := True;
11495                Val := Expr_Value_R (Expression (Arg1));
11496
11497                if Val <= Ureal_0 then
11498                   Opt.Time_Slice_Value := 0;
11499
11500                elsif Val > UR_From_Uint (UI_From_Int (1000)) then
11501                   Opt.Time_Slice_Value := 1_000_000_000;
11502
11503                else
11504                   Opt.Time_Slice_Value :=
11505                     UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
11506                end if;
11507             end if;
11508          end Time_Slice;
11509
11510          -----------
11511          -- Title --
11512          -----------
11513
11514          --  pragma Title (TITLING_OPTION [, TITLING OPTION]);
11515
11516          --   TITLING_OPTION ::=
11517          --     [Title =>] STRING_LITERAL
11518          --   | [Subtitle =>] STRING_LITERAL
11519
11520          when Pragma_Title => Title : declare
11521             Args  : Args_List (1 .. 2);
11522             Names : constant Name_List (1 .. 2) := (
11523                       Name_Title,
11524                       Name_Subtitle);
11525
11526          begin
11527             GNAT_Pragma;
11528             Gather_Associations (Names, Args);
11529
11530             for J in 1 .. 2 loop
11531                if Present (Args (J)) then
11532                   Check_Arg_Is_String_Literal (Args (J));
11533                end if;
11534             end loop;
11535          end Title;
11536
11537          ---------------------
11538          -- Unchecked_Union --
11539          ---------------------
11540
11541          --  pragma Unchecked_Union (first_subtype_LOCAL_NAME)
11542
11543          when Pragma_Unchecked_Union => Unchecked_Union : declare
11544             Assoc   : constant Node_Id := Arg1;
11545             Type_Id : constant Node_Id := Expression (Assoc);
11546             Typ     : Entity_Id;
11547             Discr   : Entity_Id;
11548             Tdef    : Node_Id;
11549             Clist   : Node_Id;
11550             Vpart   : Node_Id;
11551             Comp    : Node_Id;
11552             Variant : Node_Id;
11553
11554          begin
11555             Ada_2005_Pragma;
11556             Check_No_Identifiers;
11557             Check_Arg_Count (1);
11558             Check_Arg_Is_Local_Name (Arg1);
11559
11560             Find_Type (Type_Id);
11561             Typ := Entity (Type_Id);
11562
11563             if Typ = Any_Type
11564               or else Rep_Item_Too_Early (Typ, N)
11565             then
11566                return;
11567             else
11568                Typ := Underlying_Type (Typ);
11569             end if;
11570
11571             if Rep_Item_Too_Late (Typ, N) then
11572                return;
11573             end if;
11574
11575             Check_First_Subtype (Arg1);
11576
11577             --  Note remaining cases are references to a type in the current
11578             --  declarative part. If we find an error, we post the error on
11579             --  the relevant type declaration at an appropriate point.
11580
11581             if not Is_Record_Type (Typ) then
11582                Error_Msg_N ("Unchecked_Union must be record type", Typ);
11583                return;
11584
11585             elsif Is_Tagged_Type (Typ) then
11586                Error_Msg_N ("Unchecked_Union must not be tagged", Typ);
11587                return;
11588
11589             elsif Is_Limited_Type (Typ) then
11590                Error_Msg_N
11591                  ("Unchecked_Union must not be limited record type", Typ);
11592                Explain_Limited_Type (Typ, Typ);
11593                return;
11594
11595             else
11596                if not Has_Discriminants (Typ) then
11597                   Error_Msg_N
11598                     ("Unchecked_Union must have one discriminant", Typ);
11599                   return;
11600                end if;
11601
11602                Discr := First_Discriminant (Typ);
11603                while Present (Discr) loop
11604                   if No (Discriminant_Default_Value (Discr)) then
11605                      Error_Msg_N
11606                        ("Unchecked_Union discriminant must have default value",
11607                         Discr);
11608                   end if;
11609                   Next_Discriminant (Discr);
11610                end loop;
11611
11612                Tdef  := Type_Definition (Declaration_Node (Typ));
11613                Clist := Component_List (Tdef);
11614
11615                Comp := First (Component_Items (Clist));
11616                while Present (Comp) loop
11617                   Check_Component (Comp);
11618                   Next (Comp);
11619                end loop;
11620
11621                if No (Clist) or else No (Variant_Part (Clist)) then
11622                   Error_Msg_N
11623                     ("Unchecked_Union must have variant part",
11624                      Tdef);
11625                   return;
11626                end if;
11627
11628                Vpart := Variant_Part (Clist);
11629
11630                Variant := First (Variants (Vpart));
11631                while Present (Variant) loop
11632                   Check_Variant (Variant);
11633                   Next (Variant);
11634                end loop;
11635             end if;
11636
11637             Set_Is_Unchecked_Union  (Typ, True);
11638             Set_Convention          (Typ, Convention_C);
11639
11640             Set_Has_Unchecked_Union (Base_Type (Typ), True);
11641             Set_Is_Unchecked_Union  (Base_Type (Typ), True);
11642          end Unchecked_Union;
11643
11644          ------------------------
11645          -- Unimplemented_Unit --
11646          ------------------------
11647
11648          --  pragma Unimplemented_Unit;
11649
11650          --  Note: this only gives an error if we are generating code, or if
11651          --  we are in a generic library unit (where the pragma appears in the
11652          --  body, not in the spec).
11653
11654          when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
11655             Cunitent : constant Entity_Id :=
11656                          Cunit_Entity (Get_Source_Unit (Loc));
11657             Ent_Kind : constant Entity_Kind :=
11658                          Ekind (Cunitent);
11659
11660          begin
11661             GNAT_Pragma;
11662             Check_Arg_Count (0);
11663
11664             if Operating_Mode = Generate_Code
11665               or else Ent_Kind = E_Generic_Function
11666               or else Ent_Kind = E_Generic_Procedure
11667               or else Ent_Kind = E_Generic_Package
11668             then
11669                Get_Name_String (Chars (Cunitent));
11670                Set_Casing (Mixed_Case);
11671                Write_Str (Name_Buffer (1 .. Name_Len));
11672                Write_Str (" is not supported in this configuration");
11673                Write_Eol;
11674                raise Unrecoverable_Error;
11675             end if;
11676          end Unimplemented_Unit;
11677
11678          ------------------------
11679          -- Universal_Aliasing --
11680          ------------------------
11681
11682          --  pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
11683
11684          when Pragma_Universal_Aliasing => Universal_Alias : declare
11685             E_Id : Entity_Id;
11686
11687          begin
11688             GNAT_Pragma;
11689             Check_Arg_Count (1);
11690             Check_Optional_Identifier (Arg2, Name_Entity);
11691             Check_Arg_Is_Local_Name (Arg1);
11692             E_Id := Entity (Expression (Arg1));
11693
11694             if E_Id = Any_Type then
11695                return;
11696             elsif No (E_Id) or else not Is_Type (E_Id) then
11697                Error_Pragma_Arg ("pragma% requires type", Arg1);
11698             end if;
11699
11700             Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
11701          end Universal_Alias;
11702
11703          --------------------
11704          -- Universal_Data --
11705          --------------------
11706
11707          --  pragma Universal_Data [(library_unit_NAME)];
11708
11709          when Pragma_Universal_Data =>
11710             GNAT_Pragma;
11711
11712             --  If this is a configuration pragma, then set the universal
11713             --  addressing option, otherwise confirm that the pragma satisfies
11714             --  the requirements of library unit pragma placement and leave it
11715             --  to the GNAAMP back end to detect the pragma (avoids transitive
11716             --  setting of the option due to withed units).
11717
11718             if Is_Configuration_Pragma then
11719                Universal_Addressing_On_AAMP := True;
11720             else
11721                Check_Valid_Library_Unit_Pragma;
11722             end if;
11723
11724             if not AAMP_On_Target then
11725                Error_Pragma ("?pragma% ignored (applies only to AAMP)");
11726             end if;
11727
11728          ----------------
11729          -- Unmodified --
11730          ----------------
11731
11732          --  pragma Unmodified (local_Name {, local_Name});
11733
11734          when Pragma_Unmodified => Unmodified : declare
11735             Arg_Node : Node_Id;
11736             Arg_Expr : Node_Id;
11737             Arg_Ent  : Entity_Id;
11738
11739          begin
11740             GNAT_Pragma;
11741             Check_At_Least_N_Arguments (1);
11742
11743             --  Loop through arguments
11744
11745             Arg_Node := Arg1;
11746             while Present (Arg_Node) loop
11747                Check_No_Identifier (Arg_Node);
11748
11749                --  Note: the analyze call done by Check_Arg_Is_Local_Name will
11750                --  in fact generate reference, so that the entity will have a
11751                --  reference, which will inhibit any warnings about it not
11752                --  being referenced, and also properly show up in the ali file
11753                --  as a reference. But this reference is recorded before the
11754                --  Has_Pragma_Unreferenced flag is set, so that no warning is
11755                --  generated for this reference.
11756
11757                Check_Arg_Is_Local_Name (Arg_Node);
11758                Arg_Expr := Get_Pragma_Arg (Arg_Node);
11759
11760                if Is_Entity_Name (Arg_Expr) then
11761                   Arg_Ent := Entity (Arg_Expr);
11762
11763                   if not Is_Assignable (Arg_Ent) then
11764                      Error_Pragma_Arg
11765                        ("pragma% can only be applied to a variable",
11766                         Arg_Expr);
11767                   else
11768                      Set_Has_Pragma_Unmodified (Arg_Ent);
11769                   end if;
11770                end if;
11771
11772                Next (Arg_Node);
11773             end loop;
11774          end Unmodified;
11775
11776          ------------------
11777          -- Unreferenced --
11778          ------------------
11779
11780          --  pragma Unreferenced (local_Name {, local_Name});
11781
11782          --    or when used in a context clause:
11783
11784          --  pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
11785
11786          when Pragma_Unreferenced => Unreferenced : declare
11787             Arg_Node : Node_Id;
11788             Arg_Expr : Node_Id;
11789             Arg_Ent  : Entity_Id;
11790             Citem    : Node_Id;
11791
11792          begin
11793             GNAT_Pragma;
11794             Check_At_Least_N_Arguments (1);
11795
11796             --  Check case of appearing within context clause
11797
11798             if Is_In_Context_Clause then
11799
11800                --  The arguments must all be units mentioned in a with clause
11801                --  in the same context clause. Note we already checked (in
11802                --  Par.Prag) that the arguments are either identifiers or
11803                --  selected components.
11804
11805                Arg_Node := Arg1;
11806                while Present (Arg_Node) loop
11807                   Citem := First (List_Containing (N));
11808                   while Citem /= N loop
11809                      if Nkind (Citem) = N_With_Clause
11810                        and then Same_Name (Name (Citem), Expression (Arg_Node))
11811                      then
11812                         Set_Has_Pragma_Unreferenced
11813                           (Cunit_Entity
11814                              (Get_Source_Unit
11815                                 (Library_Unit (Citem))));
11816                         Set_Unit_Name (Expression (Arg_Node), Name (Citem));
11817                         exit;
11818                      end if;
11819
11820                      Next (Citem);
11821                   end loop;
11822
11823                   if Citem = N then
11824                      Error_Pragma_Arg
11825                        ("argument of pragma% is not with'ed unit", Arg_Node);
11826                   end if;
11827
11828                   Next (Arg_Node);
11829                end loop;
11830
11831             --  Case of not in list of context items
11832
11833             else
11834                Arg_Node := Arg1;
11835                while Present (Arg_Node) loop
11836                   Check_No_Identifier (Arg_Node);
11837
11838                   --  Note: the analyze call done by Check_Arg_Is_Local_Name
11839                   --  will in fact generate reference, so that the entity will
11840                   --  have a reference, which will inhibit any warnings about
11841                   --  it not being referenced, and also properly show up in the
11842                   --  ali file as a reference. But this reference is recorded
11843                   --  before the Has_Pragma_Unreferenced flag is set, so that
11844                   --  no warning is generated for this reference.
11845
11846                   Check_Arg_Is_Local_Name (Arg_Node);
11847                   Arg_Expr := Get_Pragma_Arg (Arg_Node);
11848
11849                   if Is_Entity_Name (Arg_Expr) then
11850                      Arg_Ent := Entity (Arg_Expr);
11851
11852                      --  If the entity is overloaded, the pragma applies to the
11853                      --  most recent overloading, as documented. In this case,
11854                      --  name resolution does not generate a reference, so it
11855                      --  must be done here explicitly.
11856
11857                      if Is_Overloaded (Arg_Expr) then
11858                         Generate_Reference (Arg_Ent, N);
11859                      end if;
11860
11861                      Set_Has_Pragma_Unreferenced (Arg_Ent);
11862                   end if;
11863
11864                   Next (Arg_Node);
11865                end loop;
11866             end if;
11867          end Unreferenced;
11868
11869          --------------------------
11870          -- Unreferenced_Objects --
11871          --------------------------
11872
11873          --  pragma Unreferenced_Objects (local_Name {, local_Name});
11874
11875          when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
11876             Arg_Node : Node_Id;
11877             Arg_Expr : Node_Id;
11878
11879          begin
11880             GNAT_Pragma;
11881             Check_At_Least_N_Arguments (1);
11882
11883             Arg_Node := Arg1;
11884             while Present (Arg_Node) loop
11885                Check_No_Identifier (Arg_Node);
11886                Check_Arg_Is_Local_Name (Arg_Node);
11887                Arg_Expr := Get_Pragma_Arg (Arg_Node);
11888
11889                if not Is_Entity_Name (Arg_Expr)
11890                  or else not Is_Type (Entity (Arg_Expr))
11891                then
11892                   Error_Pragma_Arg
11893                     ("argument for pragma% must be type or subtype", Arg_Node);
11894                end if;
11895
11896                Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr));
11897                Next (Arg_Node);
11898             end loop;
11899          end Unreferenced_Objects;
11900
11901          ------------------------------
11902          -- Unreserve_All_Interrupts --
11903          ------------------------------
11904
11905          --  pragma Unreserve_All_Interrupts;
11906
11907          when Pragma_Unreserve_All_Interrupts =>
11908             GNAT_Pragma;
11909             Check_Arg_Count (0);
11910
11911             if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
11912                Unreserve_All_Interrupts := True;
11913             end if;
11914
11915          ----------------
11916          -- Unsuppress --
11917          ----------------
11918
11919          --  pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
11920
11921          when Pragma_Unsuppress =>
11922             Ada_2005_Pragma;
11923             Process_Suppress_Unsuppress (False);
11924
11925          -------------------
11926          -- Use_VADS_Size --
11927          -------------------
11928
11929          --  pragma Use_VADS_Size;
11930
11931          when Pragma_Use_VADS_Size =>
11932             GNAT_Pragma;
11933             Check_Arg_Count (0);
11934             Check_Valid_Configuration_Pragma;
11935             Use_VADS_Size := True;
11936
11937          ---------------------
11938          -- Validity_Checks --
11939          ---------------------
11940
11941          --  pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
11942
11943          when Pragma_Validity_Checks => Validity_Checks : declare
11944             A  : constant Node_Id   := Expression (Arg1);
11945             S  : String_Id;
11946             C  : Char_Code;
11947
11948          begin
11949             GNAT_Pragma;
11950             Check_Arg_Count (1);
11951             Check_No_Identifiers;
11952
11953             if Nkind (A) = N_String_Literal then
11954                S   := Strval (A);
11955
11956                declare
11957                   Slen    : constant Natural := Natural (String_Length (S));
11958                   Options : String (1 .. Slen);
11959                   J       : Natural;
11960
11961                begin
11962                   J := 1;
11963                   loop
11964                      C := Get_String_Char (S, Int (J));
11965                      exit when not In_Character_Range (C);
11966                      Options (J) := Get_Character (C);
11967
11968                      if J = Slen then
11969                         Set_Validity_Check_Options (Options);
11970                         exit;
11971                      else
11972                         J := J + 1;
11973                      end if;
11974                   end loop;
11975                end;
11976
11977             elsif Nkind (A) = N_Identifier then
11978
11979                if Chars (A) = Name_All_Checks then
11980                   Set_Validity_Check_Options ("a");
11981
11982                elsif Chars (A) = Name_On then
11983                   Validity_Checks_On := True;
11984
11985                elsif Chars (A) = Name_Off then
11986                   Validity_Checks_On := False;
11987
11988                end if;
11989             end if;
11990          end Validity_Checks;
11991
11992          --------------
11993          -- Volatile --
11994          --------------
11995
11996          --  pragma Volatile (LOCAL_NAME);
11997
11998          when Pragma_Volatile =>
11999             Process_Atomic_Shared_Volatile;
12000
12001          -------------------------
12002          -- Volatile_Components --
12003          -------------------------
12004
12005          --  pragma Volatile_Components (array_LOCAL_NAME);
12006
12007          --  Volatile is handled by the same circuit as Atomic_Components
12008
12009          --------------
12010          -- Warnings --
12011          --------------
12012
12013          --  pragma Warnings (On | Off);
12014          --  pragma Warnings (On | Off, LOCAL_NAME);
12015          --  pragma Warnings (static_string_EXPRESSION);
12016          --  pragma Warnings (On | Off, STRING_LITERAL);
12017
12018          when Pragma_Warnings => Warnings : begin
12019             GNAT_Pragma;
12020             Check_At_Least_N_Arguments (1);
12021             Check_No_Identifiers;
12022
12023             --  If debug flag -gnatd.i is set, pragma is ignored
12024
12025             if Debug_Flag_Dot_I then
12026                return;
12027             end if;
12028
12029             --  Process various forms of the pragma
12030
12031             declare
12032                Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
12033
12034             begin
12035                --  One argument case
12036
12037                if Arg_Count = 1 then
12038
12039                   --  On/Off one argument case was processed by parser
12040
12041                   if Nkind (Argx) = N_Identifier
12042                     and then
12043                       (Chars (Argx) = Name_On
12044                          or else
12045                        Chars (Argx) = Name_Off)
12046                   then
12047                      null;
12048
12049                   --  One argument case must be ON/OFF or static string expr
12050
12051                   elsif not Is_Static_String_Expression (Arg1) then
12052                      Error_Pragma_Arg
12053                        ("argument of pragma% must be On/Off or " &
12054                         "static string expression", Arg2);
12055
12056                   --  One argument string expression case
12057
12058                   else
12059                      declare
12060                         Lit : constant Node_Id   := Expr_Value_S (Argx);
12061                         Str : constant String_Id := Strval (Lit);
12062                         Len : constant Nat       := String_Length (Str);
12063                         C   : Char_Code;
12064                         J   : Nat;
12065                         OK  : Boolean;
12066                         Chr : Character;
12067
12068                      begin
12069                         J := 1;
12070                         while J <= Len loop
12071                            C := Get_String_Char (Str, J);
12072                            OK := In_Character_Range (C);
12073
12074                            if OK then
12075                               Chr := Get_Character (C);
12076
12077                               --  Dot case
12078
12079                               if J < Len and then Chr = '.' then
12080                                  J := J + 1;
12081                                  C := Get_String_Char (Str, J);
12082                                  Chr := Get_Character (C);
12083
12084                                  if not Set_Dot_Warning_Switch (Chr) then
12085                                     Error_Pragma_Arg
12086                                       ("invalid warning switch character " &
12087                                        '.' & Chr, Arg1);
12088                                  end if;
12089
12090                               --  Non-Dot case
12091
12092                               else
12093                                  OK := Set_Warning_Switch (Chr);
12094                               end if;
12095                            end if;
12096
12097                            if not OK then
12098                               Error_Pragma_Arg
12099                                 ("invalid warning switch character " & Chr,
12100                                  Arg1);
12101                            end if;
12102
12103                            J := J + 1;
12104                         end loop;
12105                      end;
12106                   end if;
12107
12108                   --  Two or more arguments (must be two)
12109
12110                else
12111                   Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12112                   Check_At_Most_N_Arguments (2);
12113
12114                   declare
12115                      E_Id : Node_Id;
12116                      E    : Entity_Id;
12117                      Err  : Boolean;
12118
12119                   begin
12120                      E_Id := Expression (Arg2);
12121                      Analyze (E_Id);
12122
12123                      --  In the expansion of an inlined body, a reference to
12124                      --  the formal may be wrapped in a conversion if the
12125                      --  actual is a conversion. Retrieve the real entity name.
12126
12127                      if (In_Instance_Body
12128                          or else In_Inlined_Body)
12129                        and then Nkind (E_Id) = N_Unchecked_Type_Conversion
12130                      then
12131                         E_Id := Expression (E_Id);
12132                      end if;
12133
12134                      --  Entity name case
12135
12136                      if Is_Entity_Name (E_Id) then
12137                         E := Entity (E_Id);
12138
12139                         if E = Any_Id then
12140                            return;
12141                         else
12142                            loop
12143                               Set_Warnings_Off
12144                                 (E, (Chars (Expression (Arg1)) = Name_Off));
12145
12146                               if Chars (Expression (Arg1)) = Name_Off
12147                                 and then Warn_On_Warnings_Off
12148                               then
12149                                  Warnings_Off_Pragmas.Append ((N, E));
12150                               end if;
12151
12152                               if Is_Enumeration_Type (E) then
12153                                  declare
12154                                     Lit : Entity_Id;
12155                                  begin
12156                                     Lit := First_Literal (E);
12157                                     while Present (Lit) loop
12158                                        Set_Warnings_Off (Lit);
12159                                        Next_Literal (Lit);
12160                                     end loop;
12161                                  end;
12162                               end if;
12163
12164                               exit when No (Homonym (E));
12165                               E := Homonym (E);
12166                            end loop;
12167                         end if;
12168
12169                      --  Error if not entity or static string literal case
12170
12171                      elsif not Is_Static_String_Expression (Arg2) then
12172                         Error_Pragma_Arg
12173                           ("second argument of pragma% must be entity " &
12174                            "name or static string expression", Arg2);
12175
12176                      --  String literal case
12177
12178                      else
12179                         String_To_Name_Buffer
12180                           (Strval (Expr_Value_S (Expression (Arg2))));
12181
12182                         --  Note on configuration pragma case: If this is a
12183                         --  configuration pragma, then for an OFF pragma, we
12184                         --  just set Config True in the call, which is all
12185                         --  that needs to be done. For the case of ON, this
12186                         --  is normally an error, unless it is canceling the
12187                         --  effect of a previous OFF pragma in the same file.
12188                         --  In any other case, an error will be signalled (ON
12189                         --  with no matching OFF).
12190
12191                         if Chars (Argx) = Name_Off then
12192                            Set_Specific_Warning_Off
12193                              (Loc, Name_Buffer (1 .. Name_Len),
12194                               Config => Is_Configuration_Pragma);
12195
12196                         elsif Chars (Argx) = Name_On then
12197                            Set_Specific_Warning_On
12198                              (Loc, Name_Buffer (1 .. Name_Len), Err);
12199
12200                            if Err then
12201                               Error_Msg
12202                                 ("?pragma Warnings On with no " &
12203                                  "matching Warnings Off",
12204                                  Loc);
12205                            end if;
12206                         end if;
12207                      end if;
12208                   end;
12209                end if;
12210             end;
12211          end Warnings;
12212
12213          -------------------
12214          -- Weak_External --
12215          -------------------
12216
12217          --  pragma Weak_External ([Entity =>] LOCAL_NAME);
12218
12219          when Pragma_Weak_External => Weak_External : declare
12220             Ent : Entity_Id;
12221
12222          begin
12223             GNAT_Pragma;
12224             Check_Arg_Count (1);
12225             Check_Optional_Identifier (Arg1, Name_Entity);
12226             Check_Arg_Is_Library_Level_Local_Name (Arg1);
12227             Ent := Entity (Expression (Arg1));
12228
12229             if Rep_Item_Too_Early (Ent, N) then
12230                return;
12231             else
12232                Ent := Underlying_Type (Ent);
12233             end if;
12234
12235             --  The only processing required is to link this item on to the
12236             --  list of rep items for the given entity. This is accomplished
12237             --  by the call to Rep_Item_Too_Late (when no error is detected
12238             --  and False is returned).
12239
12240             if Rep_Item_Too_Late (Ent, N) then
12241                return;
12242             else
12243                Set_Has_Gigi_Rep_Item (Ent);
12244             end if;
12245          end Weak_External;
12246
12247          -----------------------------
12248          -- Wide_Character_Encoding --
12249          -----------------------------
12250
12251          --  pragma Wide_Character_Encoding (IDENTIFIER);
12252
12253          when Pragma_Wide_Character_Encoding =>
12254             GNAT_Pragma;
12255
12256             --  Nothing to do, handled in parser. Note that we do not enforce
12257             --  configuration pragma placement, this pragma can appear at any
12258             --  place in the source, allowing mixed encodings within a single
12259             --  source program.
12260
12261             null;
12262
12263          --------------------
12264          -- Unknown_Pragma --
12265          --------------------
12266
12267          --  Should be impossible, since the case of an unknown pragma is
12268          --  separately processed before the case statement is entered.
12269
12270          when Unknown_Pragma =>
12271             raise Program_Error;
12272       end case;
12273
12274    exception
12275       when Pragma_Exit => null;
12276    end Analyze_Pragma;
12277
12278    -------------------
12279    -- Check_Enabled --
12280    -------------------
12281
12282    function Check_Enabled (Nam : Name_Id) return Boolean is
12283       PP : Node_Id;
12284
12285    begin
12286       PP := Opt.Check_Policy_List;
12287       loop
12288          if No (PP) then
12289             return Assertions_Enabled;
12290
12291          elsif
12292            Nam = Chars (Expression (First (Pragma_Argument_Associations (PP))))
12293          then
12294             case
12295               Chars (Expression (Last (Pragma_Argument_Associations (PP))))
12296             is
12297             when Name_On | Name_Check =>
12298                return True;
12299             when Name_Off | Name_Ignore =>
12300                return False;
12301             when others =>
12302                raise Program_Error;
12303             end case;
12304
12305          else
12306             PP := Next_Pragma (PP);
12307          end if;
12308       end loop;
12309    end Check_Enabled;
12310
12311    ---------------------------------
12312    -- Delay_Config_Pragma_Analyze --
12313    ---------------------------------
12314
12315    function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
12316    begin
12317       return Pragma_Name (N) = Name_Interrupt_State
12318                or else
12319              Pragma_Name (N) = Name_Priority_Specific_Dispatching;
12320    end Delay_Config_Pragma_Analyze;
12321
12322    -------------------------
12323    -- Get_Base_Subprogram --
12324    -------------------------
12325
12326    function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
12327       Result : Entity_Id;
12328
12329    begin
12330       --  Follow subprogram renaming chain
12331
12332       Result := Def_Id;
12333       while Is_Subprogram (Result)
12334         and then
12335           (Is_Generic_Instance (Result)
12336             or else Nkind (Parent (Declaration_Node (Result))) =
12337                                          N_Subprogram_Renaming_Declaration)
12338         and then Present (Alias (Result))
12339       loop
12340          Result := Alias (Result);
12341       end loop;
12342
12343       return Result;
12344    end Get_Base_Subprogram;
12345
12346    --------------------
12347    -- Get_Pragma_Arg --
12348    --------------------
12349
12350    function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is
12351    begin
12352       if Nkind (Arg) = N_Pragma_Argument_Association then
12353          return Expression (Arg);
12354       else
12355          return Arg;
12356       end if;
12357    end Get_Pragma_Arg;
12358
12359    ----------------
12360    -- Initialize --
12361    ----------------
12362
12363    procedure Initialize is
12364    begin
12365       Externals.Init;
12366    end Initialize;
12367
12368    -----------------------------
12369    -- Is_Config_Static_String --
12370    -----------------------------
12371
12372    function Is_Config_Static_String (Arg : Node_Id) return Boolean is
12373
12374       function Add_Config_Static_String (Arg : Node_Id) return Boolean;
12375       --  This is an internal recursive function that is just like the outer
12376       --  function except that it adds the string to the name buffer rather
12377       --  than placing the string in the name buffer.
12378
12379       ------------------------------
12380       -- Add_Config_Static_String --
12381       ------------------------------
12382
12383       function Add_Config_Static_String (Arg : Node_Id) return Boolean is
12384          N : Node_Id;
12385          C : Char_Code;
12386
12387       begin
12388          N := Arg;
12389
12390          if Nkind (N) = N_Op_Concat then
12391             if Add_Config_Static_String (Left_Opnd (N)) then
12392                N := Right_Opnd (N);
12393             else
12394                return False;
12395             end if;
12396          end if;
12397
12398          if Nkind (N) /= N_String_Literal then
12399             Error_Msg_N ("string literal expected for pragma argument", N);
12400             return False;
12401
12402          else
12403             for J in 1 .. String_Length (Strval (N)) loop
12404                C := Get_String_Char (Strval (N), J);
12405
12406                if not In_Character_Range (C) then
12407                   Error_Msg
12408                     ("string literal contains invalid wide character",
12409                      Sloc (N) + 1 + Source_Ptr (J));
12410                   return False;
12411                end if;
12412
12413                Add_Char_To_Name_Buffer (Get_Character (C));
12414             end loop;
12415          end if;
12416
12417          return True;
12418       end Add_Config_Static_String;
12419
12420    --  Start of processing for Is_Config_Static_String
12421
12422    begin
12423
12424       Name_Len := 0;
12425       return Add_Config_Static_String (Arg);
12426    end Is_Config_Static_String;
12427
12428    -----------------------------------------
12429    -- Is_Non_Significant_Pragma_Reference --
12430    -----------------------------------------
12431
12432    --  This function makes use of the following static table which indicates
12433    --  whether a given pragma is significant. A value of -1 in this table
12434    --  indicates that the reference is significant. A value of zero indicates
12435    --  than appearance as any argument is insignificant, a positive value
12436    --  indicates that appearance in that parameter position is significant.
12437
12438    --  A value of 99 flags a special case requiring a special check (this is
12439    --  used for cases not covered by this standard encoding, e.g. pragma Check
12440    --  where the first argument is not significant, but the others are).
12441
12442    Sig_Flags : constant array (Pragma_Id) of Int :=
12443      (Pragma_AST_Entry                     => -1,
12444       Pragma_Abort_Defer                   => -1,
12445       Pragma_Ada_83                        => -1,
12446       Pragma_Ada_95                        => -1,
12447       Pragma_Ada_05                        => -1,
12448       Pragma_Ada_2005                      => -1,
12449       Pragma_All_Calls_Remote              => -1,
12450       Pragma_Annotate                      => -1,
12451       Pragma_Assert                        => -1,
12452       Pragma_Assertion_Policy              =>  0,
12453       Pragma_Assume_No_Invalid_Values      =>  0,
12454       Pragma_Asynchronous                  => -1,
12455       Pragma_Atomic                        =>  0,
12456       Pragma_Atomic_Components             =>  0,
12457       Pragma_Attach_Handler                => -1,
12458       Pragma_Check                         => 99,
12459       Pragma_Check_Name                    =>  0,
12460       Pragma_Check_Policy                  =>  0,
12461       Pragma_CIL_Constructor               => -1,
12462       Pragma_CPP_Class                     =>  0,
12463       Pragma_CPP_Constructor               =>  0,
12464       Pragma_CPP_Virtual                   =>  0,
12465       Pragma_CPP_Vtable                    =>  0,
12466       Pragma_C_Pass_By_Copy                =>  0,
12467       Pragma_Comment                       =>  0,
12468       Pragma_Common_Object                 => -1,
12469       Pragma_Compile_Time_Error            => -1,
12470       Pragma_Compile_Time_Warning          => -1,
12471       Pragma_Compiler_Unit                 =>  0,
12472       Pragma_Complete_Representation       =>  0,
12473       Pragma_Complex_Representation        =>  0,
12474       Pragma_Component_Alignment           => -1,
12475       Pragma_Controlled                    =>  0,
12476       Pragma_Convention                    =>  0,
12477       Pragma_Convention_Identifier         =>  0,
12478       Pragma_Debug                         => -1,
12479       Pragma_Debug_Policy                  =>  0,
12480       Pragma_Detect_Blocking               => -1,
12481       Pragma_Discard_Names                 =>  0,
12482       Pragma_Elaborate                     => -1,
12483       Pragma_Elaborate_All                 => -1,
12484       Pragma_Elaborate_Body                => -1,
12485       Pragma_Elaboration_Checks            => -1,
12486       Pragma_Eliminate                     => -1,
12487       Pragma_Export                        => -1,
12488       Pragma_Export_Exception              => -1,
12489       Pragma_Export_Function               => -1,
12490       Pragma_Export_Object                 => -1,
12491       Pragma_Export_Procedure              => -1,
12492       Pragma_Export_Value                  => -1,
12493       Pragma_Export_Valued_Procedure       => -1,
12494       Pragma_Extend_System                 => -1,
12495       Pragma_Extensions_Allowed            => -1,
12496       Pragma_External                      => -1,
12497       Pragma_Favor_Top_Level               => -1,
12498       Pragma_External_Name_Casing          => -1,
12499       Pragma_Fast_Math                     => -1,
12500       Pragma_Finalize_Storage_Only         =>  0,
12501       Pragma_Float_Representation          =>  0,
12502       Pragma_Ident                         => -1,
12503       Pragma_Implemented_By_Entry          => -1,
12504       Pragma_Implicit_Packing              =>  0,
12505       Pragma_Import                        => +2,
12506       Pragma_Import_Exception              =>  0,
12507       Pragma_Import_Function               =>  0,
12508       Pragma_Import_Object                 =>  0,
12509       Pragma_Import_Procedure              =>  0,
12510       Pragma_Import_Valued_Procedure       =>  0,
12511       Pragma_Initialize_Scalars            => -1,
12512       Pragma_Inline                        =>  0,
12513       Pragma_Inline_Always                 =>  0,
12514       Pragma_Inline_Generic                =>  0,
12515       Pragma_Inspection_Point              => -1,
12516       Pragma_Interface                     => +2,
12517       Pragma_Interface_Name                => +2,
12518       Pragma_Interrupt_Handler             => -1,
12519       Pragma_Interrupt_Priority            => -1,
12520       Pragma_Interrupt_State               => -1,
12521       Pragma_Java_Constructor              => -1,
12522       Pragma_Java_Interface                => -1,
12523       Pragma_Keep_Names                    =>  0,
12524       Pragma_License                       => -1,
12525       Pragma_Link_With                     => -1,
12526       Pragma_Linker_Alias                  => -1,
12527       Pragma_Linker_Constructor            => -1,
12528       Pragma_Linker_Destructor             => -1,
12529       Pragma_Linker_Options                => -1,
12530       Pragma_Linker_Section                => -1,
12531       Pragma_List                          => -1,
12532       Pragma_Locking_Policy                => -1,
12533       Pragma_Long_Float                    => -1,
12534       Pragma_Machine_Attribute             => -1,
12535       Pragma_Main                          => -1,
12536       Pragma_Main_Storage                  => -1,
12537       Pragma_Memory_Size                   => -1,
12538       Pragma_No_Return                     =>  0,
12539       Pragma_No_Body                       =>  0,
12540       Pragma_No_Run_Time                   => -1,
12541       Pragma_No_Strict_Aliasing            => -1,
12542       Pragma_Normalize_Scalars             => -1,
12543       Pragma_Obsolescent                   =>  0,
12544       Pragma_Optimize                      => -1,
12545       Pragma_Optimize_Alignment            => -1,
12546       Pragma_Pack                          =>  0,
12547       Pragma_Page                          => -1,
12548       Pragma_Passive                       => -1,
12549       Pragma_Preelaborable_Initialization  => -1,
12550       Pragma_Polling                       => -1,
12551       Pragma_Persistent_BSS                =>  0,
12552       Pragma_Postcondition                 => -1,
12553       Pragma_Precondition                  => -1,
12554       Pragma_Preelaborate                  => -1,
12555       Pragma_Preelaborate_05               => -1,
12556       Pragma_Priority                      => -1,
12557       Pragma_Priority_Specific_Dispatching => -1,
12558       Pragma_Profile                       =>  0,
12559       Pragma_Profile_Warnings              =>  0,
12560       Pragma_Propagate_Exceptions          => -1,
12561       Pragma_Psect_Object                  => -1,
12562       Pragma_Pure                          => -1,
12563       Pragma_Pure_05                       => -1,
12564       Pragma_Pure_Function                 => -1,
12565       Pragma_Queuing_Policy                => -1,
12566       Pragma_Ravenscar                     => -1,
12567       Pragma_Relative_Deadline             => -1,
12568       Pragma_Remote_Call_Interface         => -1,
12569       Pragma_Remote_Types                  => -1,
12570       Pragma_Restricted_Run_Time           => -1,
12571       Pragma_Restriction_Warnings          => -1,
12572       Pragma_Restrictions                  => -1,
12573       Pragma_Reviewable                    => -1,
12574       Pragma_Short_Circuit_And_Or          => -1,
12575       Pragma_Share_Generic                 => -1,
12576       Pragma_Shared                        => -1,
12577       Pragma_Shared_Passive                => -1,
12578       Pragma_Source_File_Name              => -1,
12579       Pragma_Source_File_Name_Project      => -1,
12580       Pragma_Source_Reference              => -1,
12581       Pragma_Storage_Size                  => -1,
12582       Pragma_Storage_Unit                  => -1,
12583       Pragma_Static_Elaboration_Desired    => -1,
12584       Pragma_Stream_Convert                => -1,
12585       Pragma_Style_Checks                  => -1,
12586       Pragma_Subtitle                      => -1,
12587       Pragma_Suppress                      =>  0,
12588       Pragma_Suppress_Exception_Locations  =>  0,
12589       Pragma_Suppress_All                  => -1,
12590       Pragma_Suppress_Debug_Info           =>  0,
12591       Pragma_Suppress_Initialization       =>  0,
12592       Pragma_System_Name                   => -1,
12593       Pragma_Task_Dispatching_Policy       => -1,
12594       Pragma_Task_Info                     => -1,
12595       Pragma_Task_Name                     => -1,
12596       Pragma_Task_Storage                  =>  0,
12597       Pragma_Thread_Local_Storage          =>  0,
12598       Pragma_Time_Slice                    => -1,
12599       Pragma_Title                         => -1,
12600       Pragma_Unchecked_Union               =>  0,
12601       Pragma_Unimplemented_Unit            => -1,
12602       Pragma_Universal_Aliasing            => -1,
12603       Pragma_Universal_Data                => -1,
12604       Pragma_Unmodified                    => -1,
12605       Pragma_Unreferenced                  => -1,
12606       Pragma_Unreferenced_Objects          => -1,
12607       Pragma_Unreserve_All_Interrupts      => -1,
12608       Pragma_Unsuppress                    =>  0,
12609       Pragma_Use_VADS_Size                 => -1,
12610       Pragma_Validity_Checks               => -1,
12611       Pragma_Volatile                      =>  0,
12612       Pragma_Volatile_Components           =>  0,
12613       Pragma_Warnings                      => -1,
12614       Pragma_Weak_External                 => -1,
12615       Pragma_Wide_Character_Encoding       =>  0,
12616       Unknown_Pragma                       =>  0);
12617
12618    function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
12619       Id : Pragma_Id;
12620       P  : Node_Id;
12621       C  : Int;
12622       A  : Node_Id;
12623
12624    begin
12625       P := Parent (N);
12626
12627       if Nkind (P) /= N_Pragma_Argument_Association then
12628          return False;
12629
12630       else
12631          Id := Get_Pragma_Id (Parent (P));
12632          C := Sig_Flags (Id);
12633
12634          case C is
12635             when -1 =>
12636                return False;
12637
12638             when 0 =>
12639                return True;
12640
12641             when 99 =>
12642                case Id is
12643
12644                   --  For pragma Check, the first argument is not significant,
12645                   --  the second and the third (if present) arguments are
12646                   --  significant.
12647
12648                   when Pragma_Check =>
12649                      return
12650                        P = First (Pragma_Argument_Associations (Parent (P)));
12651
12652                   when others =>
12653                      raise Program_Error;
12654                end case;
12655
12656             when others =>
12657                A := First (Pragma_Argument_Associations (Parent (P)));
12658                for J in 1 .. C - 1 loop
12659                   if No (A) then
12660                      return False;
12661                   end if;
12662
12663                   Next (A);
12664                end loop;
12665
12666                return A = P; -- is this wrong way round ???
12667          end case;
12668       end if;
12669    end Is_Non_Significant_Pragma_Reference;
12670
12671    ------------------------------
12672    -- Is_Pragma_String_Literal --
12673    ------------------------------
12674
12675    --  This function returns true if the corresponding pragma argument is a
12676    --  static string expression. These are the only cases in which string
12677    --  literals can appear as pragma arguments. We also allow a string literal
12678    --  as the first argument to pragma Assert (although it will of course
12679    --  always generate a type error).
12680
12681    function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
12682       Pragn : constant Node_Id := Parent (Par);
12683       Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
12684       Pname : constant Name_Id := Pragma_Name (Pragn);
12685       Argn  : Natural;
12686       N     : Node_Id;
12687
12688    begin
12689       Argn := 1;
12690       N := First (Assoc);
12691       loop
12692          exit when N = Par;
12693          Argn := Argn + 1;
12694          Next (N);
12695       end loop;
12696
12697       if Pname = Name_Assert then
12698          return True;
12699
12700       elsif Pname = Name_Export then
12701          return Argn > 2;
12702
12703       elsif Pname = Name_Ident then
12704          return Argn = 1;
12705
12706       elsif Pname = Name_Import then
12707          return Argn > 2;
12708
12709       elsif Pname = Name_Interface_Name then
12710          return Argn > 1;
12711
12712       elsif Pname = Name_Linker_Alias then
12713          return Argn = 2;
12714
12715       elsif Pname = Name_Linker_Section then
12716          return Argn = 2;
12717
12718       elsif Pname = Name_Machine_Attribute then
12719          return Argn = 2;
12720
12721       elsif Pname = Name_Source_File_Name then
12722          return True;
12723
12724       elsif Pname = Name_Source_Reference then
12725          return Argn = 2;
12726
12727       elsif Pname = Name_Title then
12728          return True;
12729
12730       elsif Pname = Name_Subtitle then
12731          return True;
12732
12733       else
12734          return False;
12735       end if;
12736    end Is_Pragma_String_Literal;
12737
12738    --------------------------------------
12739    -- Process_Compilation_Unit_Pragmas --
12740    --------------------------------------
12741
12742    procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
12743    begin
12744       --  A special check for pragma Suppress_All, a very strange DEC pragma,
12745       --  strange because it comes at the end of the unit. If we have a pragma
12746       --  Suppress_All in the Pragmas_After of the current unit, then we insert
12747       --  a pragma Suppress (All_Checks) at the start of the context clause to
12748       --  ensure the correct processing.
12749
12750       declare
12751          PA : constant List_Id := Pragmas_After (Aux_Decls_Node (N));
12752          P  : Node_Id;
12753
12754       begin
12755          if Present (PA) then
12756             P := First (PA);
12757             while Present (P) loop
12758                if Pragma_Name (P) = Name_Suppress_All then
12759                   Prepend_To (Context_Items (N),
12760                     Make_Pragma (Sloc (P),
12761                       Chars => Name_Suppress,
12762                       Pragma_Argument_Associations => New_List (
12763                         Make_Pragma_Argument_Association (Sloc (P),
12764                           Expression =>
12765                             Make_Identifier (Sloc (P),
12766                               Chars => Name_All_Checks)))));
12767                   exit;
12768                end if;
12769
12770                Next (P);
12771             end loop;
12772          end if;
12773       end;
12774    end Process_Compilation_Unit_Pragmas;
12775
12776    --------
12777    -- rv --
12778    --------
12779
12780    procedure rv is
12781    begin
12782       null;
12783    end rv;
12784
12785    --------------------------------
12786    -- Set_Encoded_Interface_Name --
12787    --------------------------------
12788
12789    procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
12790       Str : constant String_Id := Strval (S);
12791       Len : constant Int       := String_Length (Str);
12792       CC  : Char_Code;
12793       C   : Character;
12794       J   : Int;
12795
12796       Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
12797
12798       procedure Encode;
12799       --  Stores encoded value of character code CC. The encoding we use an
12800       --  underscore followed by four lower case hex digits.
12801
12802       ------------
12803       -- Encode --
12804       ------------
12805
12806       procedure Encode is
12807       begin
12808          Store_String_Char (Get_Char_Code ('_'));
12809          Store_String_Char
12810            (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
12811          Store_String_Char
12812            (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
12813          Store_String_Char
12814            (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
12815          Store_String_Char
12816            (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
12817       end Encode;
12818
12819    --  Start of processing for Set_Encoded_Interface_Name
12820
12821    begin
12822       --  If first character is asterisk, this is a link name, and we leave it
12823       --  completely unmodified. We also ignore null strings (the latter case
12824       --  happens only in error cases) and no encoding should occur for Java or
12825       --  AAMP interface names.
12826
12827       if Len = 0
12828         or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
12829         or else VM_Target /= No_VM
12830         or else AAMP_On_Target
12831       then
12832          Set_Interface_Name (E, S);
12833
12834       else
12835          J := 1;
12836          loop
12837             CC := Get_String_Char (Str, J);
12838
12839             exit when not In_Character_Range (CC);
12840
12841             C := Get_Character (CC);
12842
12843             exit when C /= '_' and then C /= '$'
12844               and then C not in '0' .. '9'
12845               and then C not in 'a' .. 'z'
12846               and then C not in 'A' .. 'Z';
12847
12848             if J = Len then
12849                Set_Interface_Name (E, S);
12850                return;
12851
12852             else
12853                J := J + 1;
12854             end if;
12855          end loop;
12856
12857          --  Here we need to encode. The encoding we use as follows:
12858          --     three underscores  + four hex digits (lower case)
12859
12860          Start_String;
12861
12862          for J in 1 .. String_Length (Str) loop
12863             CC := Get_String_Char (Str, J);
12864
12865             if not In_Character_Range (CC) then
12866                Encode;
12867             else
12868                C := Get_Character (CC);
12869
12870                if C = '_' or else C = '$'
12871                  or else C in '0' .. '9'
12872                  or else C in 'a' .. 'z'
12873                  or else C in 'A' .. 'Z'
12874                then
12875                   Store_String_Char (CC);
12876                else
12877                   Encode;
12878                end if;
12879             end if;
12880          end loop;
12881
12882          Set_Interface_Name (E,
12883            Make_String_Literal (Sloc (S),
12884              Strval => End_String));
12885       end if;
12886    end Set_Encoded_Interface_Name;
12887
12888    -------------------
12889    -- Set_Unit_Name --
12890    -------------------
12891
12892    procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
12893       Pref : Node_Id;
12894       Scop : Entity_Id;
12895
12896    begin
12897       if Nkind (N) = N_Identifier
12898         and then Nkind (With_Item) = N_Identifier
12899       then
12900          Set_Entity (N, Entity (With_Item));
12901
12902       elsif Nkind (N) = N_Selected_Component then
12903          Change_Selected_Component_To_Expanded_Name (N);
12904          Set_Entity (N, Entity (With_Item));
12905          Set_Entity (Selector_Name (N), Entity (N));
12906
12907          Pref := Prefix (N);
12908          Scop := Scope (Entity (N));
12909          while Nkind (Pref) = N_Selected_Component loop
12910             Change_Selected_Component_To_Expanded_Name (Pref);
12911             Set_Entity (Selector_Name (Pref), Scop);
12912             Set_Entity (Pref, Scop);
12913             Pref := Prefix (Pref);
12914             Scop := Scope (Scop);
12915          end loop;
12916
12917          Set_Entity (Pref, Scop);
12918       end if;
12919    end Set_Unit_Name;
12920
12921 end Sem_Prag;