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