gcc/ada/sem_prag.adb

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