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