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