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