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 --                                                                          --
  10 --          Copyright (C) 1992-2002, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 --  This unit contains the semantic processing for all pragmas, both language
  29 --  and implementation defined. For most pragmas, the parser only does the
  30 --  most basic job of checking the syntax, so Sem_Prag also contains the code
  31 --  to complete the syntax checks. Certain pragmas are handled partially or
  32 --  completely by the parser (see Par.Prag for further details).
  33
  34 with Atree;    use Atree;
  35 with Casing;   use Casing;
  36 with Csets;    use Csets;
  37 with Debug;    use Debug;
  38 with Einfo;    use Einfo;
  39 with Elists;   use Elists;
  40 with Errout;   use Errout;
  41 with Expander; use Expander;
  42 with Exp_Dist; use Exp_Dist;
  43 with Fname;    use Fname;
  44 with Hostparm; use Hostparm;
  45 with Lib;      use Lib;
  46 with Namet;    use Namet;
  47 with Nlists;   use Nlists;
  48 with Nmake;    use Nmake;
  49 with Opt;      use Opt;
  50 with Output;   use Output;
  51 with Restrict; use Restrict;
  52 with Rtsfind;  use Rtsfind;
  53 with Sem;      use Sem;
  54 with Sem_Ch8;  use Sem_Ch8;
  55 with Sem_Ch13; use Sem_Ch13;
  56 with Sem_Disp; use Sem_Disp;
  57 with Sem_Elim; use Sem_Elim;
  58 with Sem_Eval; use Sem_Eval;
  59 with Sem_Intr; use Sem_Intr;
  60 with Sem_Mech; use Sem_Mech;
  61 with Sem_Res;  use Sem_Res;
  62 with Sem_Type; use Sem_Type;
  63 with Sem_Util; use Sem_Util;
  64 with Sem_VFpt; use Sem_VFpt;
  65 with Stand;    use Stand;
  66 with Sinfo;    use Sinfo;
  67 with Sinfo.CN; use Sinfo.CN;
  68 with Sinput;   use Sinput;
  69 with Snames;   use Snames;
  70 with Stringt;  use Stringt;
  71 with Stylesw;  use Stylesw;
  72 with Targparm; use Targparm;
  73 with Tbuild;   use Tbuild;
  74 with Ttypes;
  75 with Uintp;    use Uintp;
  76 with Urealp;   use Urealp;
  77 with Validsw;  use Validsw;
  78
  79 with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
  80
  81 package body Sem_Prag is
  82
  83    ----------------------------------------------
  84    -- Common Handling of Import-Export Pragmas --
  85    ----------------------------------------------
  86
  87    --  In the following section, a number of Import_xxx and Export_xxx
  88    --  pragmas are defined by GNAT. These are compatible with the DEC
  89    --  pragmas of the same name, and all have the following common
  90    --  form and processing:
  91
  92    --  pragma Export_xxx
  93    --        [Internal                 =>] LOCAL_NAME,
  94    --     [, [External                 =>] EXTERNAL_SYMBOL]
  95    --     [, other optional parameters   ]);
  96
  97    --  pragma Import_xxx
  98    --        [Internal                 =>] LOCAL_NAME,
  99    --     [, [External                 =>] EXTERNAL_SYMBOL]
 100    --     [, other optional parameters   ]);
 101
 102    --   EXTERNAL_SYMBOL ::=
 103    --     IDENTIFIER
 104    --   | static_string_EXPRESSION
 105
 106    --  The internal LOCAL_NAME designates the entity that is imported or
 107    --  exported, and must refer to an entity in the current declarative
 108    --  part (as required by the rules for LOCAL_NAME).
 109
 110    --  The external linker name is designated by the External parameter
 111    --  if given, or the Internal parameter if not (if there is no External
 112    --  parameter, the External parameter is a copy of the Internal name).
 113
 114    --  If the External parameter is given as a string, then this string
 115    --  is treated as an external name (exactly as though it had been given
 116    --  as an External_Name parameter for a normal Import pragma).
 117
 118    --  If the External parameter is given as an identifier (or there is no
 119    --  External parameter, so that the Internal identifier is used), then
 120    --  the external name is the characters of the identifier, translated
 121    --  to all upper case letters for OpenVMS versions of GNAT, and to all
 122    --  lower case letters for all other versions
 123
 124    --  Note: the external name specified or implied by any of these special
 125    --  Import_xxx or Export_xxx pragmas override an external or link name
 126    --  specified in a previous Import or Export pragma.
 127
 128    --  Note: these and all other DEC-compatible GNAT pragmas allow full
 129    --  use of named notation, following the standard rules for subprogram
 130    --  calls, i.e. parameters can be given in any order if named notation
 131    --  is used, and positional and named notation can be mixed, subject to
 132    --  the rule that all positional parameters must appear first.
 133
 134    --  Note: All these pragmas are implemented exactly following the DEC
 135    --  design and implementation and are intended to be fully compatible
 136    --  with the use of these pragmas in the DEC Ada compiler.
 137
 138    -------------------------------------
 139    -- Local Subprograms and Variables --
 140    -------------------------------------
 141
 142    function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
 143    --  This routine is used for possible casing adjustment of an explicit
 144    --  external name supplied as a string literal (the node N), according
 145    --  to the casing requirement of Opt.External_Name_Casing. If this is
 146    --  set to As_Is, then the string literal is returned unchanged, but if
 147    --  it is set to Uppercase or Lowercase, then a new string literal with
 148    --  appropriate casing is constructed.
 149
 150    function Is_Generic_Subprogram (Id : Entity_Id) return Boolean;
 151    --  Return True if Id is a generic procedure or a function
 152
 153    function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
 154    --  If Def_Id refers to a renamed subprogram, then the base subprogram
 155    --  (the original one, following the renaming chain) is returned.
 156    --  Otherwise the entity is returned unchanged. Should be in Einfo???
 157
 158    procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
 159    --  Place semantic information on the argument of an Elaborate or
 160    --  Elaborate_All pragma. Entity name for unit and its parents is
 161    --  taken from item in previous with_clause that mentions the unit.
 162
 163    Locking_Policy_Sloc          : Source_Ptr := No_Location;
 164    Queuing_Policy_Sloc          : Source_Ptr := No_Location;
 165    Task_Dispatching_Policy_Sloc : Source_Ptr := No_Location;
 166    --  These global variables remember the location of a previous locking,
 167    --  queuing or task dispatching policy pragma, so that appropriate error
 168    --  messages can be generated for inconsistent pragmas. Note that it is
 169    --  fine that these are global locations, because the check for consistency
 170    --  is over the entire program.
 171
 172    -------------------------------
 173    -- Adjust_External_Name_Case --
 174    -------------------------------
 175
 176    function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
 177       CC : Char_Code;
 178
 179    begin
 180       --  Adjust case of literal if required
 181
 182       if Opt.External_Name_Exp_Casing = As_Is then
 183          return N;
 184
 185       else
 186          --  Copy existing string
 187
 188          Start_String;
 189
 190          --  Set proper casing
 191
 192          for J in 1 .. String_Length (Strval (N)) loop
 193             CC := Get_String_Char (Strval (N), J);
 194
 195             if Opt.External_Name_Exp_Casing = Uppercase
 196               and then CC >= Get_Char_Code ('a')
 197               and then CC <= Get_Char_Code ('z')
 198             then
 199                Store_String_Char (CC - 32);
 200
 201             elsif Opt.External_Name_Exp_Casing = Lowercase
 202               and then CC >= Get_Char_Code ('A')
 203               and then CC <= Get_Char_Code ('Z')
 204             then
 205                Store_String_Char (CC + 32);
 206
 207             else
 208                Store_String_Char (CC);
 209             end if;
 210          end loop;
 211
 212          return
 213            Make_String_Literal (Sloc (N),
 214              Strval => End_String);
 215       end if;
 216    end Adjust_External_Name_Case;
 217
 218    --------------------
 219    -- Analyze_Pragma --
 220    --------------------
 221
 222    procedure Analyze_Pragma (N : Node_Id) is
 223       Loc     : constant Source_Ptr := Sloc (N);
 224       Prag_Id : Pragma_Id;
 225
 226       Pragma_Exit : exception;
 227       --  This exception is used to exit pragma processing completely. It
 228       --  is used when an error is detected, and in other situations where
 229       --  it is known that no further processing is required.
 230
 231       Arg_Count : Nat;
 232       --  Number of pragma argument associations
 233
 234       Arg1 : Node_Id;
 235       Arg2 : Node_Id;
 236       Arg3 : Node_Id;
 237       Arg4 : Node_Id;
 238       --  First four pragma arguments (pragma argument association nodes,
 239       --  or Empty if the corresponding argument does not exist).
 240
 241       procedure Check_Ada_83_Warning;
 242       --  Issues a warning message for the current pragma if operating in Ada
 243       --  83 mode (used for language pragmas that are not a standard part of
 244       --  Ada 83). This procedure does not raise Error_Pragma. Also notes use
 245       --  of 95 pragma.
 246
 247       procedure Check_Arg_Count (Required : Nat);
 248       --  Check argument count for pragma is equal to given parameter.
 249       --  If not, then issue an error message and raise Pragma_Exit.
 250
 251       --  Note: all routines whose name is Check_Arg_Is_xxx take an
 252       --  argument Arg which can either be a pragma argument association,
 253       --  in which case the check is applied to the expression of the
 254       --  association or an expression directly.
 255
 256       procedure Check_Arg_Is_Identifier (Arg : Node_Id);
 257       --  Check the specified argument Arg to make sure that it is an
 258       --  identifier. If not give error and raise Pragma_Exit.
 259
 260       procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
 261       --  Check the specified argument Arg to make sure that it is an
 262       --  integer literal. If not give error and raise Pragma_Exit.
 263
 264       procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
 265       --  Check the specified argument Arg to make sure that it has the
 266       --  proper syntactic form for a local name and meets the semantic
 267       --  requirements for a local name. The local name is analyzed as
 268       --  part of the processing for this call. In addition, the local
 269       --  name is required to represent an entity at the library level.
 270
 271       procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
 272       --  Check the specified argument Arg to make sure that it has the
 273       --  proper syntactic form for a local name and meets the semantic
 274       --  requirements for a local name. The local name is analyzed as
 275       --  part of the processing for this call.
 276
 277       procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
 278       --  Check the specified argument Arg to make sure that it is a valid
 279       --  locking policy name. If not give error and raise Pragma_Exit.
 280
 281       procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
 282       procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id);
 283       --  Check the specified argument Arg to make sure that it is an
 284       --  identifier whose name matches either N1 or N2 (or N3 if present).
 285       --  If not then give error and raise Pragma_Exit.
 286
 287       procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
 288       --  Check the specified argument Arg to make sure that it is a valid
 289       --  queuing policy name. If not give error and raise Pragma_Exit.
 290
 291       procedure Check_Arg_Is_Static_Expression
 292         (Arg : Node_Id;
 293          Typ : Entity_Id);
 294       --  Check the specified argument Arg to make sure that it is a static
 295       --  expression of the given type (i.e. it will be analyzed and resolved
 296       --  using this type, which can be any valid argument to Resolve, e.g.
 297       --  Any_Integer is OK). If not, given error and raise Pragma_Exit.
 298
 299       procedure Check_Arg_Is_String_Literal (Arg : Node_Id);
 300       --  Check the specified argument Arg to make sure that it is a
 301       --  string literal. If not give error and raise Pragma_Exit
 302
 303       procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
 304       --  Check the specified argument Arg to make sure that it is a valid
 305       --  valid task dispatching policy name. If not give error and raise
 306       --  Pragma_Exit.
 307
 308       procedure Check_At_Least_N_Arguments (N : Nat);
 309       --  Check there are at least N arguments present
 310
 311       procedure Check_At_Most_N_Arguments (N : Nat);
 312       --  Check there are no more than N arguments present
 313
 314       procedure Check_First_Subtype (Arg : Node_Id);
 315       --  Checks that Arg, whose expression is an entity name referencing
 316       --  a subtype, does not reference a type that is not a first subtype.
 317
 318       procedure Check_In_Main_Program;
 319       --  Common checks for pragmas that appear within a main program
 320       --  (Priority, Main_Storage, Time_Slice).
 321
 322       procedure Check_Interrupt_Or_Attach_Handler;
 323       --  Common processing for first argument of pragma Interrupt_Handler
 324       --  or pragma Attach_Handler.
 325
 326       procedure Check_Is_In_Decl_Part_Or_Package_Spec;
 327       --  Check that pragma appears in a declarative part, or in a package
 328       --  specification, i.e. that it does not occur in a statement sequence
 329       --  in a body.
 330
 331       procedure Check_No_Identifier (Arg : Node_Id);
 332       --  Checks that the given argument does not have an identifier. If
 333       --  an identifier is present, then an error message is issued, and
 334       --  Pragma_Exit is raised.
 335
 336       procedure Check_No_Identifiers;
 337       --  Checks that none of the arguments to the pragma has an identifier.
 338       --  If any argument has an identifier, then an error message is issued,
 339       --  and Pragma_Exit is raised.
 340
 341       procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
 342       --  Checks if the given argument has an identifier, and if so, requires
 343       --  it to match the given identifier name. If there is a non-matching
 344       --  identifier, then an error message is given and Error_Pragmas raised.
 345
 346       procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
 347       --  Checks if the given argument has an identifier, and if so, requires
 348       --  it to match the given identifier name. If there is a non-matching
 349       --  identifier, then an error message is given and Error_Pragmas raised.
 350       --  In this version of the procedure, the identifier name is given as
 351       --  a string with lower case letters.
 352
 353       procedure Check_Static_Constraint (Constr : Node_Id);
 354       --  Constr is a constraint from an N_Subtype_Indication node from a
 355       --  component constraint in an Unchecked_Union type. This routine checks
 356       --  that the constraint is static as required by the restrictions for
 357       --  Unchecked_Union.
 358
 359       procedure Check_Valid_Configuration_Pragma;
 360       --  Legality checks for placement of a configuration pragma
 361
 362       procedure Check_Valid_Library_Unit_Pragma;
 363       --  Legality checks for library unit pragmas. A special case arises for
 364       --  pragmas in generic instances that come from copies of the original
 365       --  library unit pragmas in the generic templates. In the case of other
 366       --  than library level instantiations these can appear in contexts which
 367       --  would normally be invalid (they only apply to the original template
 368       --  and to library level instantiations), and they are simply ignored,
 369       --  which is implemented by rewriting them as null statements.
 370
 371       procedure Error_Pragma (Msg : String);
 372       pragma No_Return (Error_Pragma);
 373       --  Outputs error message for current pragma. The message contains an %
 374       --  that will be replaced with the pragma name, and the flag is placed
 375       --  on the pragma itself. Pragma_Exit is then raised.
 376
 377       procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
 378       pragma No_Return (Error_Pragma_Arg);
 379       --  Outputs error message for current pragma. The message may contain
 380       --  a % that will be replaced with the pragma name. The parameter Arg
 381       --  may either be a pragma argument association, in which case the flag
 382       --  is placed on the expression of this association, or an expression,
 383       --  in which case the flag is placed directly on the expression. The
 384       --  message is placed using Error_Msg_N, so the message may also contain
 385       --  an & insertion character which will reference the given Arg value.
 386       --  After placing the message, Pragma_Exit is raised.
 387
 388       procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
 389       pragma No_Return (Error_Pragma_Arg);
 390       --  Similar to above form of Error_Pragma_Arg except that two messages
 391       --  are provided, the second is a continuation comment starting with \.
 392
 393       procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
 394       pragma No_Return (Error_Pragma_Arg_Ident);
 395       --  Outputs error message for current pragma. The message may contain
 396       --  a % that will be replaced with the pragma name. The parameter Arg
 397       --  must be a pragma argument association with a non-empty identifier
 398       --  (i.e. its Chars field must be set), and the error message is placed
 399       --  on the identifier. The message is placed using Error_Msg_N so
 400       --  the message may also contain an & insertion character which will
 401       --  reference the identifier. After placing the message, Pragma_Exit
 402       --  is raised.
 403
 404       function Find_Lib_Unit_Name return Entity_Id;
 405       --  Used for a library unit pragma to find the entity to which the
 406       --  library unit pragma applies, returns the entity found.
 407
 408       procedure Find_Program_Unit_Name (Id : Node_Id);
 409       --  If the pragma is a compilation unit pragma, the id must denote the
 410       --  compilation unit in the same compilation, and the pragma must appear
 411       --  in the list of preceding or trailing pragmas. If it is a program
 412       --  unit pragma that is not a compilation unit pragma, then the
 413       --  identifier must be visible.
 414
 415       type Name_List is array (Natural range <>) of Name_Id;
 416       type Args_List is array (Natural range <>) of Node_Id;
 417       procedure Gather_Associations
 418         (Names : Name_List;
 419          Args  : out Args_List);
 420       --  This procedure is used to gather the arguments for a pragma that
 421       --  permits arbitrary ordering of parameters using the normal rules
 422       --  for named and positional parameters. The Names argument is a list
 423       --  of Name_Id values that corresponds to the allowed pragma argument
 424       --  association identifiers in order. The result returned in Args is
 425       --  a list of corresponding expressions that are the pragma arguments.
 426       --  Note that this is a list of expressions, not of pragma argument
 427       --  associations (Gather_Associations has completely checked all the
 428       --  optional identifiers when it returns). An entry in Args is Empty
 429       --  on return if the corresponding argument is not present.
 430
 431       function Get_Pragma_Arg (Arg : Node_Id) return Node_Id;
 432       --  All the routines that check pragma arguments take either a pragma
 433       --  argument association (in which case the expression of the argument
 434       --  association is checked), or the expression directly. The function
 435       --  Get_Pragma_Arg is a utility used to deal with these two cases. If
 436       --  Arg is a pragma argument association node, then its expression is
 437       --  returned, otherwise Arg is returned unchanged.
 438
 439       procedure GNAT_Pragma;
 440       --  Called for all GNAT defined pragmas to note the use of the feature,
 441       --  and also check the relevant restriction (No_Implementation_Pragmas).
 442
 443       function Is_Before_First_Decl
 444         (Pragma_Node : Node_Id;
 445          Decls       : List_Id)
 446          return        Boolean;
 447       --  Return True if Pragma_Node is before the first declarative item in
 448       --  Decls where Decls is the list of declarative items.
 449
 450       function Is_Configuration_Pragma return Boolean;
 451       --  Deterermines if the placement of the current pragma is appropriate
 452       --  for a configuration pragma (precedes the current compilation unit)
 453
 454       procedure Pragma_Misplaced;
 455       --  Issue fatal error message for misplaced pragma
 456
 457       procedure Process_Atomic_Shared_Volatile;
 458       --  Common processing for pragmas Atomic, Shared, Volatile. Note that
 459       --  Shared is an obsolete Ada 83 pragma, treated as being identical
 460       --  in effect to pragma Atomic.
 461
 462       procedure Process_Convention (C : out Convention_Id; E : out Entity_Id);
 463       --  Common procesing for Convention, Interface, Import and Export.
 464       --  Checks first two arguments of pragma, and sets the appropriate
 465       --  convention value in the specified entity or entities. On return
 466       --  C is the convention, E is the referenced entity.
 467
 468       procedure Process_Extended_Import_Export_Exception_Pragma
 469         (Arg_Internal : Node_Id;
 470          Arg_External : Node_Id;
 471          Arg_Form     : Node_Id;
 472          Arg_Code     : Node_Id);
 473       --  Common processing for the pragmas Import/Export_Exception.
 474       --  The three arguments correspond to the three named parameters of
 475       --  the pragma. An argument is empty if the corresponding parameter
 476       --  is not present in the pragma.
 477
 478       procedure Process_Extended_Import_Export_Object_Pragma
 479         (Arg_Internal : Node_Id;
 480          Arg_External : Node_Id;
 481          Arg_Size     : Node_Id);
 482       --  Common processing for the pragmass Import/Export_Object.
 483       --  The three arguments correspond to the three named parameters
 484       --  of the pragmas. An argument is empty if the corresponding
 485       --  parameter is not present in the pragma.
 486
 487       procedure Process_Extended_Import_Export_Internal_Arg
 488         (Arg_Internal : Node_Id := Empty);
 489       --  Common processing for all extended Import and Export pragmas. The
 490       --  argument is the pragma parameter for the Internal argument. If
 491       --  Arg_Internal is empty or inappropriate, an error message is posted.
 492       --  Otherwise, on normal return, the Entity_Field of Arg_Internal is
 493       --  set to identify the referenced entity.
 494
 495       procedure Process_Extended_Import_Export_Subprogram_Pragma
 496         (Arg_Internal                 : Node_Id;
 497          Arg_External                 : Node_Id;
 498          Arg_Parameter_Types          : Node_Id;
 499          Arg_Result_Type              : Node_Id := Empty;
 500          Arg_Mechanism                : Node_Id;
 501          Arg_Result_Mechanism         : Node_Id := Empty;
 502          Arg_First_Optional_Parameter : Node_Id := Empty);
 503       --  Common processing for all extended Import and Export pragmas
 504       --  applying to subprograms. The caller omits any arguments that do
 505       --  bnot apply to the pragma in question (for example, Arg_Result_Type
 506       --  can be non-Empty only in the Import_Function and Export_Function
 507       --  cases). The argument names correspond to the allowed pragma
 508       --  association identifiers.
 509
 510       procedure Process_Generic_List;
 511       --  Common processing for Share_Generic and Inline_Generic
 512
 513       procedure Process_Import_Or_Interface;
 514       --  Common processing for Import of Interface
 515
 516       procedure Process_Inline (Active : Boolean);
 517       --  Common processing for Inline and Inline_Always. The parameter
 518       --  indicates if the inline pragma is active, i.e. if it should
 519       --  actually cause inlining to occur.
 520
 521       procedure Process_Interface_Name
 522         (Subprogram_Def : Entity_Id;
 523          Ext_Arg        : Node_Id;
 524          Link_Arg       : Node_Id);
 525       --  Given the last two arguments of pragma Import, pragma Export, or
 526       --  pragma Interface_Name, performs validity checks and sets the
 527       --  Interface_Name field of the given subprogram entity to the
 528       --  appropriate external or link name, depending on the arguments
 529       --  given. Ext_Arg is always present, but Link_Arg may be missing.
 530       --  Note that Ext_Arg may represent the Link_Name if Link_Arg is
 531       --  missing, and appropriate named notation is used for Ext_Arg.
 532       --  If neither Ext_Arg nor Link_Arg is present, the interface name
 533       --  is set to the default from the subprogram name.
 534
 535       procedure Process_Interrupt_Or_Attach_Handler;
 536       --  Attach the pragmas to the rep item chain.
 537
 538       procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
 539       --  Common processing for Suppress and Unsuppress. The boolean parameter
 540       --  Suppress_Case is True for the Suppress case, and False for the
 541       --  Unsuppress case.
 542
 543       procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
 544       --  This procedure sets the Is_Exported flag for the given entity,
 545       --  checking that the entity was not previously imported. Arg is
 546       --  the argument that specified the entity.
 547
 548       procedure Set_Extended_Import_Export_External_Name
 549         (Internal_Ent : Entity_Id;
 550          Arg_External : Node_Id);
 551       --  Common processing for all extended import export pragmas. The first
 552       --  argument, Internal_Ent, is the internal entity, which has already
 553       --  been checked for validity by the caller. Arg_External is from the
 554       --  Import or Export pragma, and may be null if no External parameter
 555       --  was present. If Arg_External is present and is a non-null string
 556       --  (a null string is treated as the default), then the Interface_Name
 557       --  field of Internal_Ent is set appropriately.
 558
 559       procedure Set_Imported (E : Entity_Id);
 560       --  This procedure sets the Is_Imported flag for the given entity,
 561       --  checking that it is not previously exported or imported.
 562
 563       procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
 564       --  Mech is a parameter passing mechanism (see Import_Function syntax
 565       --  for MECHANISM_NAME). This routine checks that the mechanism argument
 566       --  has the right form, and if not issues an error message. If the
 567       --  argument has the right form then the Mechanism field of Ent is
 568       --  set appropriately.
 569
 570       --------------------------
 571       -- Check_Ada_83_Warning --
 572       --------------------------
 573
 574       procedure Check_Ada_83_Warning is
 575       begin
 576          if Ada_83 and then Comes_From_Source (N) then
 577             Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
 578          end if;
 579       end Check_Ada_83_Warning;
 580
 581       ---------------------
 582       -- Check_Arg_Count --
 583       ---------------------
 584
 585       procedure Check_Arg_Count (Required : Nat) is
 586       begin
 587          if Arg_Count /= Required then
 588             Error_Pragma ("wrong number of arguments for pragma%");
 589          end if;
 590       end Check_Arg_Count;
 591
 592       -----------------------------
 593       -- Check_Arg_Is_Identifier --
 594       -----------------------------
 595
 596       procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
 597          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 598
 599       begin
 600          if Nkind (Argx) /= N_Identifier then
 601             Error_Pragma_Arg
 602               ("argument for pragma% must be identifier", Argx);
 603          end if;
 604       end Check_Arg_Is_Identifier;
 605
 606       ----------------------------------
 607       -- Check_Arg_Is_Integer_Literal --
 608       ----------------------------------
 609
 610       procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
 611          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 612
 613       begin
 614          if Nkind (Argx) /= N_Integer_Literal then
 615             Error_Pragma_Arg
 616               ("argument for pragma% must be integer literal", Argx);
 617          end if;
 618       end Check_Arg_Is_Integer_Literal;
 619
 620       -------------------------------------------
 621       -- Check_Arg_Is_Library_Level_Local_Name --
 622       -------------------------------------------
 623
 624       --  LOCAL_NAME ::=
 625       --    DIRECT_NAME
 626       --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
 627       --  | library_unit_NAME
 628
 629       procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
 630       begin
 631          Check_Arg_Is_Local_Name (Arg);
 632
 633          if not Is_Library_Level_Entity (Entity (Expression (Arg)))
 634            and then Comes_From_Source (N)
 635          then
 636             Error_Pragma_Arg
 637               ("argument for pragma% must be library level entity", Arg);
 638          end if;
 639       end Check_Arg_Is_Library_Level_Local_Name;
 640
 641       -----------------------------
 642       -- Check_Arg_Is_Local_Name --
 643       -----------------------------
 644
 645       --  LOCAL_NAME ::=
 646       --    DIRECT_NAME
 647       --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
 648       --  | library_unit_NAME
 649
 650       procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
 651          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 652
 653       begin
 654          Analyze (Argx);
 655
 656          if Nkind (Argx) not in N_Direct_Name
 657            and then (Nkind (Argx) /= N_Attribute_Reference
 658                       or else Present (Expressions (Argx))
 659                       or else Nkind (Prefix (Argx)) /= N_Identifier)
 660            and then (not Is_Entity_Name (Argx)
 661                       or else not Is_Compilation_Unit (Entity (Argx)))
 662          then
 663             Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
 664          end if;
 665
 666          if Is_Entity_Name (Argx)
 667            and then Scope (Entity (Argx)) /= Current_Scope
 668          then
 669             Error_Pragma_Arg
 670               ("pragma% argument must be in same declarative part", Arg);
 671          end if;
 672       end Check_Arg_Is_Local_Name;
 673
 674       ---------------------------------
 675       -- Check_Arg_Is_Locking_Policy --
 676       ---------------------------------
 677
 678       procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
 679          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 680
 681       begin
 682          Check_Arg_Is_Identifier (Argx);
 683
 684          if not Is_Locking_Policy_Name (Chars (Argx)) then
 685             Error_Pragma_Arg
 686               ("& is not a valid locking policy name", Argx);
 687          end if;
 688       end Check_Arg_Is_Locking_Policy;
 689
 690       -------------------------
 691       -- Check_Arg_Is_One_Of --
 692       -------------------------
 693
 694       procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
 695          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 696
 697       begin
 698          Check_Arg_Is_Identifier (Argx);
 699
 700          if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then
 701             Error_Msg_Name_2 := N1;
 702             Error_Msg_Name_3 := N2;
 703             Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
 704          end if;
 705       end Check_Arg_Is_One_Of;
 706
 707       procedure Check_Arg_Is_One_Of
 708         (Arg        : Node_Id;
 709          N1, N2, N3 : Name_Id)
 710       is
 711          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 712
 713       begin
 714          Check_Arg_Is_Identifier (Argx);
 715
 716          if Chars (Argx) /= N1
 717            and then Chars (Argx) /= N2
 718            and then Chars (Argx) /= N3
 719          then
 720             Error_Pragma_Arg ("invalid argument for pragma%", Argx);
 721          end if;
 722       end Check_Arg_Is_One_Of;
 723
 724       ---------------------------------
 725       -- Check_Arg_Is_Queuing_Policy --
 726       ---------------------------------
 727
 728       procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
 729          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 730
 731       begin
 732          Check_Arg_Is_Identifier (Argx);
 733
 734          if not Is_Queuing_Policy_Name (Chars (Argx)) then
 735             Error_Pragma_Arg
 736               ("& is not a valid queuing policy name", Argx);
 737          end if;
 738       end Check_Arg_Is_Queuing_Policy;
 739
 740       ------------------------------------
 741       -- Check_Arg_Is_Static_Expression --
 742       ------------------------------------
 743
 744       procedure Check_Arg_Is_Static_Expression
 745         (Arg : Node_Id;
 746          Typ : Entity_Id)
 747       is
 748          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 749
 750       begin
 751          Analyze_And_Resolve (Argx, Typ);
 752
 753          if Is_OK_Static_Expression (Argx) then
 754             return;
 755
 756          elsif Etype (Argx) = Any_Type then
 757             raise Pragma_Exit;
 758
 759          --  An interesting special case, if we have a string literal and
 760          --  we are in Ada 83 mode, then we allow it even though it will
 761          --  not be flagged as static. This allows the use of Ada 95
 762          --  pragmas like Import in Ada 83 mode. They will of course be
 763          --  flagged with warnings as usual, but will not cause errors.
 764
 765          elsif Ada_83 and then Nkind (Argx) = N_String_Literal then
 766             return;
 767
 768          --  Static expression that raises Constraint_Error. This has
 769          --  already been flagged, so just exit from pragma processing.
 770
 771          elsif Is_Static_Expression (Argx) then
 772             raise Pragma_Exit;
 773
 774          --  Finally, we have a real error
 775
 776          else
 777             Error_Pragma_Arg
 778               ("argument for pragma% must be a static expression", Argx);
 779          end if;
 780
 781       end Check_Arg_Is_Static_Expression;
 782
 783       ---------------------------------
 784       -- Check_Arg_Is_String_Literal --
 785       ---------------------------------
 786
 787       procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
 788          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 789
 790       begin
 791          if Nkind (Argx) /= N_String_Literal then
 792             Error_Pragma_Arg
 793               ("argument for pragma% must be string literal", Argx);
 794          end if;
 795
 796       end Check_Arg_Is_String_Literal;
 797
 798       ------------------------------------------
 799       -- Check_Arg_Is_Task_Dispatching_Policy --
 800       ------------------------------------------
 801
 802       procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
 803          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 804
 805       begin
 806          Check_Arg_Is_Identifier (Argx);
 807
 808          if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
 809             Error_Pragma_Arg
 810               ("& is not a valid task dispatching policy name", Argx);
 811          end if;
 812       end Check_Arg_Is_Task_Dispatching_Policy;
 813
 814       --------------------------------
 815       -- Check_At_Least_N_Arguments --
 816       --------------------------------
 817
 818       procedure Check_At_Least_N_Arguments (N : Nat) is
 819       begin
 820          if Arg_Count < N then
 821             Error_Pragma ("too few arguments for pragma%");
 822          end if;
 823       end Check_At_Least_N_Arguments;
 824
 825       -------------------------------
 826       -- Check_At_Most_N_Arguments --
 827       -------------------------------
 828
 829       procedure Check_At_Most_N_Arguments (N : Nat) is
 830          Arg : Node_Id;
 831
 832       begin
 833          if Arg_Count > N then
 834             Arg := Arg1;
 835
 836             for J in 1 .. N loop
 837                Next (Arg);
 838                Error_Pragma_Arg ("too many arguments for pragma%", Arg);
 839             end loop;
 840          end if;
 841       end Check_At_Most_N_Arguments;
 842
 843       -------------------------
 844       -- Check_First_Subtype --
 845       -------------------------
 846
 847       procedure Check_First_Subtype (Arg : Node_Id) is
 848          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
 849
 850       begin
 851          if not Is_First_Subtype (Entity (Argx)) then
 852             Error_Pragma_Arg
 853               ("pragma% cannot apply to subtype", Argx);
 854          end if;
 855       end Check_First_Subtype;
 856
 857       ---------------------------
 858       -- Check_In_Main_Program --
 859       ---------------------------
 860
 861       procedure Check_In_Main_Program is
 862          P : constant Node_Id := Parent (N);
 863
 864       begin
 865          --  Must be at in subprogram body
 866
 867          if Nkind (P) /= N_Subprogram_Body then
 868             Error_Pragma ("% pragma allowed only in subprogram");
 869
 870          --  Otherwise warn if obviously not main program
 871
 872          elsif Present (Parameter_Specifications (Specification (P)))
 873            or else not Is_Library_Level_Entity (Defining_Entity (P))
 874          then
 875             Error_Msg_Name_1 := Chars (N);
 876             Error_Msg_N
 877               ("?pragma% is only effective in main program", N);
 878          end if;
 879       end Check_In_Main_Program;
 880
 881       ---------------------------------------
 882       -- Check_Interrupt_Or_Attach_Handler --
 883       ---------------------------------------
 884
 885       procedure Check_Interrupt_Or_Attach_Handler is
 886          Arg1_X : constant Node_Id := Expression (Arg1);
 887
 888       begin
 889          Analyze (Arg1_X);
 890
 891          if not Is_Entity_Name (Arg1_X) then
 892             Error_Pragma_Arg
 893               ("argument of pragma% must be entity name", Arg1);
 894
 895          elsif Prag_Id = Pragma_Interrupt_Handler then
 896             Check_Restriction (No_Dynamic_Interrupts, N);
 897          end if;
 898
 899          declare
 900             Prot_Proc : Entity_Id := Empty;
 901             Prot_Type : Entity_Id;
 902             Found     : Boolean := False;
 903
 904          begin
 905             if not Is_Overloaded (Arg1_X) then
 906                Prot_Proc := Entity (Arg1_X);
 907
 908             else
 909                declare
 910                   It    : Interp;
 911                   Index : Interp_Index;
 912
 913                begin
 914                   Get_First_Interp (Arg1_X, Index, It);
 915                   while Present (It.Nam) loop
 916                      Prot_Proc := It.Nam;
 917
 918                      if Ekind (Prot_Proc) = E_Procedure
 919                        and then No (First_Formal (Prot_Proc))
 920                      then
 921                         if not Found then
 922                            Found := True;
 923                            Set_Entity (Arg1_X, Prot_Proc);
 924                            Set_Is_Overloaded (Arg1_X, False);
 925                         else
 926                            Error_Pragma_Arg
 927                              ("ambiguous handler name for pragma% ", Arg1);
 928                         end if;
 929                      end if;
 930
 931                      Get_Next_Interp (Index, It);
 932                   end loop;
 933
 934                   if not Found then
 935                      Error_Pragma_Arg
 936                        ("argument of pragma% must be parameterless procedure",
 937                         Arg1);
 938                   else
 939                      Prot_Proc := Entity (Arg1_X);
 940                   end if;
 941                end;
 942             end if;
 943
 944             Prot_Type := Scope (Prot_Proc);
 945
 946             if Ekind (Prot_Proc) /= E_Procedure
 947               or else Ekind (Prot_Type) /= E_Protected_Type
 948             then
 949                Error_Pragma_Arg
 950                  ("argument of pragma% must be protected procedure",
 951                   Arg1);
 952             end if;
 953
 954             if not Is_Library_Level_Entity (Prot_Type) then
 955                Error_Pragma_Arg
 956                  ("pragma% requires library level entity", Arg1);
 957             end if;
 958
 959             if Present (First_Formal (Prot_Proc)) then
 960                Error_Pragma_Arg
 961                  ("argument of pragma% must be parameterless procedure",
 962                   Arg1);
 963             end if;
 964
 965             if Parent (N) /=
 966                  Protected_Definition (Parent (Prot_Type))
 967             then
 968                Error_Pragma ("pragma% must be in protected definition");
 969             end if;
 970
 971          end;
 972       end Check_Interrupt_Or_Attach_Handler;
 973
 974       -------------------------------------------
 975       -- Check_Is_In_Decl_Part_Or_Package_Spec --
 976       -------------------------------------------
 977
 978       procedure Check_Is_In_Decl_Part_Or_Package_Spec is
 979          P : Node_Id;
 980
 981       begin
 982          P := Parent (N);
 983          loop
 984             if No (P) then
 985                exit;
 986
 987             elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
 988                exit;
 989
 990             elsif Nkind (P) = N_Package_Specification then
 991                return;
 992
 993             elsif Nkind (P) = N_Block_Statement then
 994                return;
 995
 996             --  Note: the following tests seem a little peculiar, because
 997             --  they test for bodies, but if we were in the statement part
 998             --  of the body, we would already have hit the handled statement
 999             --  sequence, so the only way we get here is by being in the
1000             --  declarative part of the body.
1001
1002             elsif Nkind (P) = N_Subprogram_Body
1003               or else Nkind (P) = N_Package_Body
1004               or else Nkind (P) = N_Task_Body
1005               or else Nkind (P) = N_Entry_Body
1006             then
1007                return;
1008             end if;
1009
1010             P := Parent (P);
1011          end loop;
1012
1013          Error_Pragma ("pragma% is not in declarative part or package spec");
1014
1015       end Check_Is_In_Decl_Part_Or_Package_Spec;
1016
1017       -------------------------
1018       -- Check_No_Identifier --
1019       -------------------------
1020
1021       procedure Check_No_Identifier (Arg : Node_Id) is
1022       begin
1023          if Chars (Arg) /= No_Name then
1024             Error_Pragma_Arg_Ident
1025               ("pragma% does not permit identifier& here", Arg);
1026          end if;
1027       end Check_No_Identifier;
1028
1029       --------------------------
1030       -- Check_No_Identifiers --
1031       --------------------------
1032
1033       procedure Check_No_Identifiers is
1034          Arg_Node : Node_Id;
1035
1036       begin
1037          if Arg_Count > 0 then
1038             Arg_Node := Arg1;
1039
1040             while Present (Arg_Node) loop
1041                Check_No_Identifier (Arg_Node);
1042                Next (Arg_Node);
1043             end loop;
1044          end if;
1045       end Check_No_Identifiers;
1046
1047       -------------------------------
1048       -- Check_Optional_Identifier --
1049       -------------------------------
1050
1051       procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
1052       begin
1053          if Present (Arg) and then Chars (Arg) /= No_Name then
1054             if Chars (Arg) /= Id then
1055                Error_Msg_Name_1 := Chars (N);
1056                Error_Msg_Name_2 := Id;
1057                Error_Msg_N ("pragma% argument expects identifier%", Arg);
1058                raise Pragma_Exit;
1059             end if;
1060          end if;
1061       end Check_Optional_Identifier;
1062
1063       procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
1064       begin
1065          Name_Buffer (1 .. Id'Length) := Id;
1066          Name_Len := Id'Length;
1067          Check_Optional_Identifier (Arg, Name_Find);
1068       end Check_Optional_Identifier;
1069
1070       -----------------------------
1071       -- Check_Static_Constraint --
1072       -----------------------------
1073
1074       --  Note: for convenience in writing this procedure, in addition to
1075       --  the officially (i.e. by spec) allowed argument which is always
1076       --  a constraint, it also allows ranges and discriminant associations.
1077
1078       procedure Check_Static_Constraint (Constr : Node_Id) is
1079
1080          --------------------
1081          -- Require_Static --
1082          --------------------
1083
1084          procedure Require_Static (E : Node_Id);
1085          --  Require given expression to be static expression
1086
1087          procedure Require_Static (E : Node_Id) is
1088          begin
1089             if not Is_OK_Static_Expression (E) then
1090                Error_Msg_N
1091                  ("non-static constraint not allowed in Unchecked_Union", E);
1092                raise Pragma_Exit;
1093             end if;
1094          end Require_Static;
1095
1096       --  Start of processing for Check_Static_Constraint
1097
1098       begin
1099          case Nkind (Constr) is
1100             when N_Discriminant_Association =>
1101                Require_Static (Expression (Constr));
1102
1103             when N_Range =>
1104                Require_Static (Low_Bound (Constr));
1105                Require_Static (High_Bound (Constr));
1106
1107             when N_Attribute_Reference =>
1108                Require_Static (Type_Low_Bound  (Etype (Prefix (Constr))));
1109                Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
1110
1111             when N_Range_Constraint =>
1112                Check_Static_Constraint (Range_Expression (Constr));
1113
1114             when N_Index_Or_Discriminant_Constraint =>
1115                declare
1116                   IDC : Entity_Id := First (Constraints (Constr));
1117
1118                begin
1119                   while Present (IDC) loop
1120                      Check_Static_Constraint (IDC);
1121                      Next (IDC);
1122                   end loop;
1123                end;
1124
1125             when others =>
1126                null;
1127          end case;
1128       end Check_Static_Constraint;
1129
1130       --------------------------------------
1131       -- Check_Valid_Configuration_Pragma --
1132       --------------------------------------
1133
1134       --  A configuration pragma must appear in the context clause of
1135       --  a compilation unit, at the start of the list (i.e. only other
1136       --  pragmas may precede it).
1137
1138       procedure Check_Valid_Configuration_Pragma is
1139       begin
1140          if not Is_Configuration_Pragma then
1141             Error_Pragma ("incorrect placement for configuration pragma%");
1142          end if;
1143       end Check_Valid_Configuration_Pragma;
1144
1145       -------------------------------------
1146       -- Check_Valid_Library_Unit_Pragma --
1147       -------------------------------------
1148
1149       procedure Check_Valid_Library_Unit_Pragma is
1150          Plist       : List_Id;
1151          Parent_Node : Node_Id;
1152          Unit_Name   : Entity_Id;
1153          Valid       : Boolean := True;
1154          Unit_Kind   : Node_Kind;
1155          Unit_Node   : Node_Id;
1156          Sindex      : Source_File_Index;
1157
1158       begin
1159          if not Is_List_Member (N) then
1160             Pragma_Misplaced;
1161             Valid := False;
1162
1163          else
1164             Plist := List_Containing (N);
1165             Parent_Node := Parent (Plist);
1166
1167             if Parent_Node = Empty then
1168                Pragma_Misplaced;
1169
1170             --  Case of pragma appearing after a compilation unit. In this
1171             --  case it must have an argument with the corresponding name
1172             --  and must be part of the following pragmas of its parent.
1173
1174             elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
1175                if Plist /= Pragmas_After (Parent_Node) then
1176                   Pragma_Misplaced;
1177
1178                elsif Arg_Count = 0 then
1179                   Error_Pragma
1180                     ("argument required if outside compilation unit");
1181
1182                else
1183                   Check_No_Identifiers;
1184                   Check_Arg_Count (1);
1185                   Unit_Node := Unit (Parent (Parent_Node));
1186                   Unit_Kind := Nkind (Unit_Node);
1187
1188                   Analyze (Expression (Arg1));
1189
1190                   if        Unit_Kind = N_Generic_Subprogram_Declaration
1191                     or else Unit_Kind = N_Subprogram_Declaration
1192                   then
1193                      Unit_Name := Defining_Entity (Unit_Node);
1194
1195                   elsif     Unit_Kind = N_Function_Instantiation
1196                     or else Unit_Kind = N_Package_Instantiation
1197                     or else Unit_Kind = N_Procedure_Instantiation
1198                   then
1199                      Unit_Name := Defining_Entity (Unit_Node);
1200
1201                   else
1202                      Unit_Name := Cunit_Entity (Current_Sem_Unit);
1203                   end if;
1204
1205                   if Chars (Unit_Name) /=
1206                      Chars (Entity (Expression (Arg1)))
1207                   then
1208                      Error_Pragma_Arg
1209                        ("pragma% argument is not current unit name", Arg1);
1210                   end if;
1211
1212                   if Ekind (Unit_Name) = E_Package
1213                     and then Present (Renamed_Entity (Unit_Name))
1214                   then
1215                      Error_Pragma ("pragma% not allowed for renamed package");
1216                   end if;
1217                end if;
1218
1219             --  Pragma appears other than after a compilation unit
1220
1221             else
1222                --  Here we check for the generic instantiation case and also
1223                --  for the case of processing a generic formal package. We
1224                --  detect these cases by noting that the Sloc on the node
1225                --  does not belong to the current compilation unit.
1226
1227                Sindex := Source_Index (Current_Sem_Unit);
1228
1229                if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
1230                   Rewrite (N, Make_Null_Statement (Loc));
1231                   return;
1232
1233                --  If before first declaration, the pragma applies to the
1234                --  enclosing unit, and the name if present must be this name.
1235
1236                elsif Is_Before_First_Decl (N, Plist) then
1237                   Unit_Node := Unit_Declaration_Node (Current_Scope);
1238                   Unit_Kind := Nkind (Unit_Node);
1239
1240                   if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
1241                      Pragma_Misplaced;
1242
1243                   elsif Unit_Kind = N_Subprogram_Body
1244                     and then not Acts_As_Spec (Unit_Node)
1245                   then
1246                      Pragma_Misplaced;
1247
1248                   elsif Nkind (Parent_Node) = N_Package_Body then
1249                      Pragma_Misplaced;
1250
1251                   elsif Nkind (Parent_Node) = N_Package_Specification
1252                     and then Plist = Private_Declarations (Parent_Node)
1253                   then
1254                      Pragma_Misplaced;
1255
1256                   elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
1257                           or else Nkind (Parent_Node)
1258                             = N_Generic_Subprogram_Declaration)
1259                     and then Plist = Generic_Formal_Declarations (Parent_Node)
1260                   then
1261                      Pragma_Misplaced;
1262
1263                   elsif Arg_Count > 0 then
1264                      Analyze (Expression (Arg1));
1265
1266                      if Entity (Expression (Arg1)) /= Current_Scope then
1267                         Error_Pragma_Arg
1268                           ("name in pragma% must be enclosing unit", Arg1);
1269                      end if;
1270
1271                   --  It is legal to have no argument in this context
1272
1273                   else
1274                      return;
1275                   end if;
1276
1277                --  Error if not before first declaration. This is because a
1278                --  library unit pragma argument must be the name of a library
1279                --  unit (RM 10.1.5(7)), but the only names permitted in this
1280                --  context are (RM 10.1.5(6)) names of subprogram declarations,
1281                --  generic subprogram declarations or generic instantiations.
1282
1283                else
1284                   Error_Pragma
1285                     ("pragma% misplaced, must be before first declaration");
1286                end if;
1287             end if;
1288          end if;
1289
1290       end Check_Valid_Library_Unit_Pragma;
1291
1292       ------------------
1293       -- Error_Pragma --
1294       ------------------
1295
1296       procedure Error_Pragma (Msg : String) is
1297       begin
1298          Error_Msg_Name_1 := Chars (N);
1299          Error_Msg_N (Msg, N);
1300          raise Pragma_Exit;
1301       end Error_Pragma;
1302
1303       ----------------------
1304       -- Error_Pragma_Arg --
1305       ----------------------
1306
1307       procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
1308       begin
1309          Error_Msg_Name_1 := Chars (N);
1310          Error_Msg_N (Msg, Get_Pragma_Arg (Arg));
1311          raise Pragma_Exit;
1312       end Error_Pragma_Arg;
1313
1314       procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
1315       begin
1316          Error_Msg_Name_1 := Chars (N);
1317          Error_Msg_N (Msg1, Get_Pragma_Arg (Arg));
1318          Error_Pragma_Arg (Msg2, Arg);
1319       end Error_Pragma_Arg;
1320
1321       ----------------------------
1322       -- Error_Pragma_Arg_Ident --
1323       ----------------------------
1324
1325       procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
1326       begin
1327          Error_Msg_Name_1 := Chars (N);
1328          Error_Msg_N (Msg, Arg);
1329          raise Pragma_Exit;
1330       end Error_Pragma_Arg_Ident;
1331
1332       ------------------------
1333       -- Find_Lib_Unit_Name --
1334       ------------------------
1335
1336       function Find_Lib_Unit_Name return Entity_Id is
1337       begin
1338          --  Return inner compilation unit entity, for case of nested
1339          --  categorization pragmas. This happens in generic unit.
1340
1341          if Nkind (Parent (N)) = N_Package_Specification
1342            and then Defining_Entity (Parent (N)) /= Current_Scope
1343          then
1344             return Defining_Entity (Parent (N));
1345
1346          else
1347             return Current_Scope;
1348          end if;
1349       end Find_Lib_Unit_Name;
1350
1351       ----------------------------
1352       -- Find_Program_Unit_Name --
1353       ----------------------------
1354
1355       procedure Find_Program_Unit_Name (Id : Node_Id) is
1356          Unit_Name : Entity_Id;
1357          Unit_Kind : Node_Kind;
1358          P         : constant Node_Id := Parent (N);
1359
1360       begin
1361          if Nkind (P) = N_Compilation_Unit then
1362             Unit_Kind := Nkind (Unit (P));
1363
1364             if Unit_Kind = N_Subprogram_Declaration
1365               or else Unit_Kind = N_Package_Declaration
1366               or else Unit_Kind in N_Generic_Declaration
1367             then
1368                Unit_Name := Defining_Entity (Unit (P));
1369
1370                if Chars (Id) = Chars (Unit_Name) then
1371                   Set_Entity (Id, Unit_Name);
1372                   Set_Etype (Id, Etype (Unit_Name));
1373                else
1374                   Set_Etype (Id, Any_Type);
1375                   Error_Pragma
1376                     ("cannot find program unit referenced by pragma%");
1377                end if;
1378
1379             else
1380                Set_Etype (Id, Any_Type);
1381                Error_Pragma ("pragma% inapplicable to this unit");
1382             end if;
1383
1384          else
1385             Analyze (Id);
1386          end if;
1387
1388       end Find_Program_Unit_Name;
1389
1390       -------------------------
1391       -- Gather_Associations --
1392       -------------------------
1393
1394       procedure Gather_Associations
1395         (Names : Name_List;
1396          Args  : out Args_List)
1397       is
1398          Arg : Node_Id;
1399
1400       begin
1401          --  Initialize all parameters to Empty
1402
1403          for J in Args'Range loop
1404             Args (J) := Empty;
1405          end loop;
1406
1407          --  That's all we have to do if there are no argument associations
1408
1409          if No (Pragma_Argument_Associations (N)) then
1410             return;
1411          end if;
1412
1413          --  Otherwise first deal with any positional parameters present
1414
1415          Arg := First (Pragma_Argument_Associations (N));
1416
1417          for Index in Args'Range loop
1418             exit when No (Arg) or else Chars (Arg) /= No_Name;
1419             Args (Index) := Expression (Arg);
1420             Next (Arg);
1421          end loop;
1422
1423          --  Positional parameters all processed, if any left, then we
1424          --  have too many positional parameters.
1425
1426          if Present (Arg) and then Chars (Arg) = No_Name then
1427             Error_Pragma_Arg
1428               ("too many positional associations for pragma%", Arg);
1429          end if;
1430
1431          --  Process named parameters if any are present
1432
1433          while Present (Arg) loop
1434             if Chars (Arg) = No_Name then
1435                Error_Pragma_Arg
1436                  ("positional association cannot follow named association",
1437                   Arg);
1438
1439             else
1440                for Index in Names'Range loop
1441                   if Names (Index) = Chars (Arg) then
1442                      if Present (Args (Index)) then
1443                         Error_Pragma_Arg
1444                           ("duplicate argument association for pragma%", Arg);
1445                      else
1446                         Args (Index) := Expression (Arg);
1447                         exit;
1448                      end if;
1449                   end if;
1450
1451                   if Index = Names'Last then
1452                      Error_Msg_Name_1 := Chars (N);
1453                      Error_Msg_N ("pragma% does not allow & argument", Arg);
1454
1455                      --  Check for possible misspelling
1456
1457                      for Index1 in Names'Range loop
1458                         if Is_Bad_Spelling_Of
1459                              (Get_Name_String (Chars (Arg)),
1460                               Get_Name_String (Names (Index1)))
1461                         then
1462                            Error_Msg_Name_1 := Names (Index1);
1463                            Error_Msg_N ("\possible misspelling of%", Arg);
1464                            exit;
1465                         end if;
1466                      end loop;
1467
1468                      raise Pragma_Exit;
1469                   end if;
1470                end loop;
1471             end if;
1472
1473             Next (Arg);
1474          end loop;
1475       end Gather_Associations;
1476
1477       --------------------
1478       -- Get_Pragma_Arg --
1479       --------------------
1480
1481       function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is
1482       begin
1483          if Nkind (Arg) = N_Pragma_Argument_Association then
1484             return Expression (Arg);
1485          else
1486             return Arg;
1487          end if;
1488       end Get_Pragma_Arg;
1489
1490       -----------------
1491       -- GNAT_Pragma --
1492       -----------------
1493
1494       procedure GNAT_Pragma is
1495       begin
1496          Check_Restriction (No_Implementation_Pragmas, N);
1497       end GNAT_Pragma;
1498
1499       --------------------------
1500       -- Is_Before_First_Decl --
1501       --------------------------
1502
1503       function Is_Before_First_Decl
1504         (Pragma_Node : Node_Id;
1505          Decls       : List_Id)
1506          return        Boolean
1507       is
1508          Item : Node_Id := First (Decls);
1509
1510       begin
1511          --  Only other pragmas can come before this pragma
1512
1513          loop
1514             if No (Item) or else Nkind (Item) /= N_Pragma then
1515                return False;
1516
1517             elsif Item = Pragma_Node then
1518                return True;
1519             end if;
1520
1521             Next (Item);
1522          end loop;
1523
1524       end Is_Before_First_Decl;
1525
1526       -----------------------------
1527       -- Is_Configuration_Pragma --
1528       -----------------------------
1529
1530       --  A configuration pragma must appear in the context clause of
1531       --  a compilation unit, at the start of the list (i.e. only other
1532       --  pragmas may precede it).
1533
1534       function Is_Configuration_Pragma return Boolean is
1535          Lis : constant List_Id := List_Containing (N);
1536          Par : constant Node_Id := Parent (N);
1537          Prg : Node_Id;
1538
1539       begin
1540          --  If no parent, then we are in the configuration pragma file,
1541          --  so the placement is definitely appropriate.
1542
1543          if No (Par) then
1544             return True;
1545
1546          --  Otherwise we must be in the context clause of a compilation unit
1547          --  and the only thing allowed before us in the context list is more
1548          --  configuration pragmas.
1549
1550          elsif Nkind (Par) = N_Compilation_Unit
1551            and then Context_Items (Par) = Lis
1552          then
1553             Prg := First (Lis);
1554
1555             loop
1556                if Prg = N then
1557                   return True;
1558                elsif Nkind (Prg) /= N_Pragma then
1559                   return False;
1560                end if;
1561
1562                Next (Prg);
1563             end loop;
1564
1565          else
1566             return False;
1567          end if;
1568
1569       end Is_Configuration_Pragma;
1570
1571       ----------------------
1572       -- Pragma_Misplaced --
1573       ----------------------
1574
1575       procedure Pragma_Misplaced is
1576       begin
1577          Error_Pragma ("incorrect placement of pragma%");
1578       end Pragma_Misplaced;
1579
1580       ------------------------------------
1581       -- Process Atomic_Shared_Volatile --
1582       ------------------------------------
1583
1584       procedure Process_Atomic_Shared_Volatile is
1585          E_Id : Node_Id;
1586          E    : Entity_Id;
1587          D    : Node_Id;
1588          K    : Node_Kind;
1589          Utyp : Entity_Id;
1590
1591       begin
1592          Check_Ada_83_Warning;
1593          Check_No_Identifiers;
1594          Check_Arg_Count (1);
1595          Check_Arg_Is_Local_Name (Arg1);
1596          E_Id := Expression (Arg1);
1597
1598          if Etype (E_Id) = Any_Type then
1599             return;
1600          end if;
1601
1602          E := Entity (E_Id);
1603          D := Declaration_Node (E);
1604          K := Nkind (D);
1605
1606          if Is_Type (E) then
1607             if Rep_Item_Too_Early (E, N)
1608                  or else
1609                Rep_Item_Too_Late (E, N)
1610             then
1611                return;
1612             else
1613                Check_First_Subtype (Arg1);
1614             end if;
1615
1616             if Prag_Id /= Pragma_Volatile then
1617                Set_Is_Atomic (E);
1618                Set_Is_Atomic (Underlying_Type (E));
1619             end if;
1620
1621             Set_Is_Volatile (E);
1622             Set_Is_Volatile (Underlying_Type (E));
1623
1624          elsif K = N_Object_Declaration
1625            or else (K = N_Component_Declaration
1626                      and then Original_Record_Component (E) = E)
1627          then
1628             if Rep_Item_Too_Late (E, N) then
1629                return;
1630             end if;
1631
1632             if Prag_Id /= Pragma_Volatile then
1633                Set_Is_Atomic (E);
1634
1635                --  An interesting improvement here. If an object of type X
1636                --  is declared atomic, and the type X is not atomic, that's
1637                --  a pity, since it may not have appropraite alignment etc.
1638                --  We can rescue this in the special case where the object
1639                --  and type are in the same unit by just setting the type
1640                --  as atomic, so that the back end will process it as atomic.
1641
1642                Utyp := Underlying_Type (Etype (E));
1643
1644                if Present (Utyp)
1645                  and then Sloc (E) > No_Location
1646                  and then Sloc (Utyp) > No_Location
1647                  and then
1648                    Get_Source_File_Index (Sloc (E)) =
1649                    Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
1650                then
1651                   Set_Is_Atomic (Underlying_Type (Etype (E)));
1652                end if;
1653             end if;
1654
1655             Set_Is_Volatile (E);
1656
1657          else
1658             Error_Pragma_Arg
1659               ("inappropriate entity for pragma%", Arg1);
1660          end if;
1661       end Process_Atomic_Shared_Volatile;
1662
1663       ------------------------
1664       -- Process_Convention --
1665       ------------------------
1666
1667       procedure Process_Convention
1668         (C : out Convention_Id;
1669          E : out Entity_Id)
1670       is
1671          Id        : Node_Id;
1672          E1        : Entity_Id;
1673          Comp_Unit : Unit_Number_Type;
1674          Cname     : Name_Id;
1675
1676          procedure Set_Convention_From_Pragma (E : Entity_Id);
1677          --  Set convention in entity E, and also flag that the entity has a
1678          --  convention pragma. If entity is for a private or incomplete type,
1679          --  also set convention and flag on underlying type. This procedure
1680          --  also deals with the special case of C_Pass_By_Copy convention.
1681
1682          --------------------------------
1683          -- Set_Convention_From_Pragma --
1684          --------------------------------
1685
1686          procedure Set_Convention_From_Pragma (E : Entity_Id) is
1687          begin
1688             Set_Convention (E, C);
1689             Set_Has_Convention_Pragma (E);
1690
1691             if Is_Incomplete_Or_Private_Type (E) then
1692                Set_Convention            (Underlying_Type (E), C);
1693                Set_Has_Convention_Pragma (Underlying_Type (E), True);
1694             end if;
1695
1696             --  A class-wide type should inherit the convention of
1697             --  the specific root type (although this isn't specified
1698             --  clearly by the RM).
1699
1700             if Is_Type (E) and then Present (Class_Wide_Type (E)) then
1701                Set_Convention (Class_Wide_Type (E), C);
1702             end if;
1703
1704             --  If the entity is a record type, then check for special case
1705             --  of C_Pass_By_Copy, which is treated the same as C except that
1706             --  the special record flag is set. This convention is also only
1707             --  permitted on record types (see AI95-00131).
1708
1709             if Cname = Name_C_Pass_By_Copy then
1710                if Is_Record_Type (E) then
1711                   Set_C_Pass_By_Copy (Base_Type (E));
1712                elsif Is_Incomplete_Or_Private_Type (E)
1713                  and then Is_Record_Type (Underlying_Type (E))
1714                then
1715                   Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
1716                else
1717                   Error_Pragma_Arg
1718                     ("C_Pass_By_Copy convention allowed only for record type",
1719                      Arg2);
1720                end if;
1721             end if;
1722
1723             --  If the entity is a derived boolean type, check for the
1724             --  special case of convention C, C++, or Fortran, where we
1725             --  consider any nonzero value to represent true.
1726
1727             if Is_Discrete_Type (E)
1728               and then Root_Type (Etype (E)) = Standard_Boolean
1729               and then
1730                 (C = Convention_C
1731                    or else
1732                  C = Convention_CPP
1733                    or else
1734                  C = Convention_Fortran)
1735             then
1736                Set_Nonzero_Is_True (Base_Type (E));
1737             end if;
1738          end Set_Convention_From_Pragma;
1739
1740       --  Start of processing for Process_Convention
1741
1742       begin
1743          Check_At_Least_N_Arguments (2);
1744          Check_Arg_Is_Identifier (Arg1);
1745          Check_Optional_Identifier (Arg1, Name_Convention);
1746          Cname := Chars (Expression (Arg1));
1747
1748          --  C_Pass_By_Copy is treated as a synonym for convention C
1749          --  (this is tested again below to set the critical flag)
1750
1751          if Cname = Name_C_Pass_By_Copy then
1752             C := Convention_C;
1753
1754          --  Otherwise we must have something in the standard convention list
1755
1756          elsif Is_Convention_Name (Cname) then
1757             C := Get_Convention_Id (Chars (Expression (Arg1)));
1758
1759          --  In DEC VMS, it seems that there is an undocumented feature
1760          --  that any unrecognized convention is treated as the default,
1761          --  which for us is convention C. It does not seem so terrible
1762          --  to do this unconditionally, silently in the VMS case, and
1763          --  with a warning in the non-VMS case.
1764
1765          else
1766             if not OpenVMS_On_Target then
1767                Error_Msg_N
1768                  ("?unrecognized convention name, C assumed",
1769                   Expression (Arg1));
1770             end if;
1771
1772             C := Convention_C;
1773          end if;
1774
1775          Check_Arg_Is_Local_Name (Arg2);
1776          Check_Optional_Identifier (Arg2, Name_Entity);
1777
1778          Id := Expression (Arg2);
1779          Analyze (Id);
1780
1781          if not Is_Entity_Name (Id) then
1782             Error_Pragma_Arg ("entity name required", Arg2);
1783          end if;
1784
1785          E := Entity (Id);
1786
1787          --  Go to renamed subprogram if present, since convention applies
1788          --  to the actual renamed entity, not to the renaming entity.
1789
1790          if Is_Subprogram (E)
1791            and then Present (Alias (E))
1792            and then Nkind (Parent (Declaration_Node (E))) =
1793                       N_Subprogram_Renaming_Declaration
1794          then
1795             E := Alias (E);
1796          end if;
1797
1798          --  Check that we not applying this to a specless body
1799
1800          if Is_Subprogram (E)
1801            and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
1802          then
1803             Error_Pragma
1804               ("pragma% requires separate spec and must come before body");
1805          end if;
1806
1807          --  Check that we are not applying this to a named constant
1808
1809          if Ekind (E) = E_Named_Integer
1810               or else
1811             Ekind (E) = E_Named_Real
1812          then
1813             Error_Msg_Name_1 := Chars (N);
1814             Error_Msg_N
1815               ("cannot apply pragma% to named constant!",
1816                Get_Pragma_Arg (Arg2));
1817             Error_Pragma_Arg
1818               ("\supply appropriate type for&!", Arg2);
1819          end if;
1820
1821          if Etype (E) = Any_Type
1822            or else Rep_Item_Too_Early (E, N)
1823          then
1824             raise Pragma_Exit;
1825          else
1826             E := Underlying_Type (E);
1827          end if;
1828
1829          if Rep_Item_Too_Late (E, N) then
1830             raise Pragma_Exit;
1831          end if;
1832
1833          if Has_Convention_Pragma (E) then
1834             Error_Pragma_Arg
1835               ("at most one Convention/Export/Import pragma is allowed", Arg2);
1836
1837          elsif Convention (E) = Convention_Protected
1838            or else Ekind (Scope (E)) = E_Protected_Type
1839          then
1840             Error_Pragma_Arg
1841               ("a protected operation cannot be given a different convention",
1842                 Arg2);
1843          end if;
1844
1845          --  For Intrinsic, a subprogram is required
1846
1847          if C = Convention_Intrinsic
1848            and then not Is_Subprogram (E)
1849            and then not Is_Generic_Subprogram (E)
1850          then
1851             Error_Pragma_Arg
1852               ("second argument of pragma% must be a subprogram", Arg2);
1853          end if;
1854
1855          --  For Stdcall, a subprogram, variable or subprogram type is required
1856
1857          if C = Convention_Stdcall
1858            and then not Is_Subprogram (E)
1859            and then not Is_Generic_Subprogram (E)
1860            and then Ekind (E) /= E_Variable
1861            and then not
1862              (Is_Access_Type (E)
1863               and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
1864          then
1865             Error_Pragma_Arg
1866               ("second argument of pragma% must be subprogram (type)",
1867                Arg2);
1868          end if;
1869
1870          if not Is_Subprogram (E)
1871            and then not Is_Generic_Subprogram (E)
1872          then
1873             Set_Convention_From_Pragma (E);
1874
1875             if Is_Type (E) then
1876
1877                Check_First_Subtype (Arg2);
1878                Set_Convention_From_Pragma (Base_Type (E));
1879
1880                --  For subprograms, we must set the convention on the
1881                --  internally generated directly designated type as well.
1882
1883                if Ekind (E) = E_Access_Subprogram_Type then
1884                   Set_Convention_From_Pragma (Directly_Designated_Type (E));
1885                end if;
1886             end if;
1887
1888          --  For the subprogram case, set proper convention for all homonyms
1889          --  in same compilation unit.
1890          --  Is the test of compilation unit really necessary ???
1891          --  What about subprogram renamings here???
1892
1893          else
1894             Comp_Unit := Get_Source_Unit (E);
1895             Set_Convention_From_Pragma (E);
1896
1897             E1 := E;
1898             loop
1899                E1 := Homonym (E1);
1900                exit when No (E1) or else Scope (E1) /= Current_Scope;
1901
1902                --  Note: below we are missing a check for Rep_Item_Too_Late.
1903                --  That is deliberate, we cannot chain the rep item on more
1904                --  than one Rep_Item chain, to be fixed later ???
1905
1906                if Comp_Unit = Get_Source_Unit (E1) then
1907                   Set_Convention_From_Pragma (E1);
1908                end if;
1909             end loop;
1910          end if;
1911
1912       end Process_Convention;
1913
1914       -----------------------------------------------------
1915       -- Process_Extended_Import_Export_Exception_Pragma --
1916       -----------------------------------------------------
1917
1918       procedure Process_Extended_Import_Export_Exception_Pragma
1919         (Arg_Internal : Node_Id;
1920          Arg_External : Node_Id;
1921          Arg_Form     : Node_Id;
1922          Arg_Code     : Node_Id)
1923       is
1924          Def_Id   : Entity_Id;
1925          Code_Val : Uint;
1926
1927       begin
1928          GNAT_Pragma;
1929          Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
1930          Def_Id := Entity (Arg_Internal);
1931
1932          if Ekind (Def_Id) /= E_Exception then
1933             Error_Pragma_Arg
1934               ("pragma% must refer to declared exception", Arg_Internal);
1935          end if;
1936
1937          Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
1938
1939          if Present (Arg_Form) then
1940             Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
1941          end if;
1942
1943          if Present (Arg_Form)
1944            and then Chars (Arg_Form) = Name_Ada
1945          then
1946             null;
1947          else
1948             Set_Is_VMS_Exception (Def_Id);
1949             Set_Exception_Code (Def_Id, No_Uint);
1950          end if;
1951
1952          if Present (Arg_Code) then
1953             if not Is_VMS_Exception (Def_Id) then
1954                Error_Pragma_Arg
1955                  ("Code option for pragma% not allowed for Ada case",
1956                   Arg_Code);
1957             end if;
1958
1959             Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
1960             Code_Val := Expr_Value (Arg_Code);
1961
1962             if not UI_Is_In_Int_Range (Code_Val) then
1963                Error_Pragma_Arg
1964                  ("Code option for pragma% must be in 32-bit range",
1965                   Arg_Code);
1966
1967             else
1968                Set_Exception_Code (Def_Id, Code_Val);
1969             end if;
1970          end if;
1971
1972       end Process_Extended_Import_Export_Exception_Pragma;
1973
1974       -------------------------------------------------
1975       -- Process_Extended_Import_Export_Internal_Arg --
1976       -------------------------------------------------
1977
1978       procedure Process_Extended_Import_Export_Internal_Arg
1979         (Arg_Internal : Node_Id := Empty)
1980       is
1981       begin
1982          GNAT_Pragma;
1983
1984          if No (Arg_Internal) then
1985             Error_Pragma ("Internal parameter required for pragma%");
1986          end if;
1987
1988          if Nkind (Arg_Internal) = N_Identifier then
1989             null;
1990
1991          elsif Nkind (Arg_Internal) = N_Operator_Symbol
1992            and then (Prag_Id = Pragma_Import_Function
1993                        or else
1994                      Prag_Id = Pragma_Export_Function)
1995          then
1996             null;
1997
1998          else
1999             Error_Pragma_Arg
2000               ("wrong form for Internal parameter for pragma%", Arg_Internal);
2001          end if;
2002
2003          Check_Arg_Is_Local_Name (Arg_Internal);
2004
2005       end Process_Extended_Import_Export_Internal_Arg;
2006
2007       --------------------------------------------------
2008       -- Process_Extended_Import_Export_Object_Pragma --
2009       --------------------------------------------------
2010
2011       procedure Process_Extended_Import_Export_Object_Pragma
2012         (Arg_Internal : Node_Id;
2013          Arg_External : Node_Id;
2014          Arg_Size     : Node_Id)
2015       is
2016          Def_Id   : Entity_Id;
2017
2018       begin
2019          Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
2020          Def_Id := Entity (Arg_Internal);
2021
2022          if Ekind (Def_Id) /= E_Constant
2023            and then Ekind (Def_Id) /= E_Variable
2024          then
2025             Error_Pragma_Arg
2026               ("pragma% must designate an object", Arg_Internal);
2027          end if;
2028
2029          if Is_Psected (Def_Id) then
2030             Error_Pragma_Arg
2031               ("previous Psect_Object applies, pragma % not permitted",
2032                Arg_Internal);
2033          end if;
2034
2035          if Rep_Item_Too_Late (Def_Id, N) then
2036             raise Pragma_Exit;
2037          end if;
2038
2039          Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
2040
2041          if Present (Arg_Size)
2042            and then Nkind (Arg_Size) /= N_Identifier
2043            and then Nkind (Arg_Size) /= N_String_Literal
2044          then
2045             Error_Pragma_Arg
2046               ("pragma% Size argument must be identifier or string literal",
2047                Arg_Size);
2048          end if;
2049
2050          --  Export_Object case
2051
2052          if Prag_Id = Pragma_Export_Object then
2053
2054             if not Is_Library_Level_Entity (Def_Id) then
2055                Error_Pragma_Arg
2056                  ("argument for pragma% must be library level entity",
2057                   Arg_Internal);
2058             end if;
2059
2060             if Ekind (Current_Scope) = E_Generic_Package then
2061                Error_Pragma ("pragma& cannot appear in a generic unit");
2062             end if;
2063
2064             if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
2065                Error_Pragma_Arg
2066                  ("exported object must have compile time known size",
2067                   Arg_Internal);
2068             end if;
2069
2070             if Is_Exported (Def_Id) then
2071                Error_Msg_N
2072                  ("?duplicate Export_Object pragma", N);
2073             else
2074                Set_Exported (Def_Id, Arg_Internal);
2075             end if;
2076
2077          --  Import_Object case
2078
2079          else
2080             if Is_Concurrent_Type (Etype (Def_Id)) then
2081                Error_Pragma_Arg
2082                  ("cannot use pragma% for task/protected object",
2083                   Arg_Internal);
2084             end if;
2085
2086             if Ekind (Def_Id) = E_Constant then
2087                Error_Pragma_Arg
2088                  ("cannot import a constant", Arg_Internal);
2089             end if;
2090
2091             if Has_Discriminants (Etype (Def_Id)) then
2092                Error_Msg_N
2093                  ("imported value must be initialized?", Arg_Internal);
2094             end if;
2095
2096             if Is_Access_Type (Etype (Def_Id)) then
2097                Error_Pragma_Arg
2098                  ("cannot import object of an access type?", Arg_Internal);
2099             end if;
2100
2101             if Is_Imported (Def_Id) then
2102                Error_Msg_N
2103                  ("?duplicate Import_Object pragma", N);
2104             else
2105                Set_Imported (Def_Id);
2106             end if;
2107          end if;
2108
2109       end Process_Extended_Import_Export_Object_Pragma;
2110
2111       ------------------------------------------------------
2112       -- Process_Extended_Import_Export_Subprogram_Pragma --
2113       ------------------------------------------------------
2114
2115       procedure Process_Extended_Import_Export_Subprogram_Pragma
2116         (Arg_Internal                 : Node_Id;
2117          Arg_External                 : Node_Id;
2118          Arg_Parameter_Types          : Node_Id;
2119          Arg_Result_Type              : Node_Id := Empty;
2120          Arg_Mechanism                : Node_Id;
2121          Arg_Result_Mechanism         : Node_Id := Empty;
2122          Arg_First_Optional_Parameter : Node_Id := Empty)
2123       is
2124          Ent       : Entity_Id;
2125          Def_Id    : Entity_Id;
2126          Hom_Id    : Entity_Id;
2127          Formal    : Entity_Id;
2128          Ambiguous : Boolean;
2129          Match     : Boolean;
2130          Dval      : Node_Id;
2131
2132          function Same_Base_Type (Ptype, Formal : Entity_Id) return Boolean;
2133          --  Determines if Ptype references the type of Formal. Note that
2134          --  only the base types need to match according to the spec.
2135
2136          function Same_Base_Type (Ptype, Formal : Entity_Id) return Boolean is
2137          begin
2138             Find_Type (Ptype);
2139
2140             if not Is_Entity_Name (Ptype)
2141               or else Entity (Ptype) = Any_Type
2142             then
2143                raise Pragma_Exit;
2144             end if;
2145
2146             return Base_Type (Entity (Ptype)) = Base_Type (Etype (Formal));
2147          end Same_Base_Type;
2148
2149       --  Start of processing for
2150       --  Process_Extended_Import_Export_Subprogram_Pragma
2151
2152       begin
2153          Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
2154          Hom_Id := Entity (Arg_Internal);
2155          Ent := Empty;
2156          Ambiguous := False;
2157
2158          --  Loop through homonyms (overloadings) of Hom_Id
2159
2160          while Present (Hom_Id) loop
2161             Def_Id := Get_Base_Subprogram (Hom_Id);
2162
2163             --  We need a subprogram in the current scope
2164
2165             if not Is_Subprogram (Def_Id)
2166               or else Scope (Def_Id) /= Current_Scope
2167             then
2168                null;
2169
2170             else
2171                Match := True;
2172
2173                --  Pragma cannot apply to subprogram body
2174
2175                if Is_Subprogram (Def_Id)
2176                  and then
2177                    Nkind (Parent
2178                      (Declaration_Node (Def_Id))) = N_Subprogram_Body
2179                then
2180                   Error_Pragma
2181                     ("pragma% requires separate spec"
2182                       & " and must come before body");
2183                end if;
2184
2185                --  Test result type if given, note that the result type
2186                --  parameter can only be present for the function cases.
2187
2188                if Present (Arg_Result_Type)
2189                  and then not Same_Base_Type (Arg_Result_Type, Def_Id)
2190                then
2191                   Match := False;
2192
2193                --  Test parameter types if given. Note that this parameter
2194                --  has not been analyzed (and must not be, since it is
2195                --  semantic nonsense), so we get it as the parser left it.
2196
2197                elsif Present (Arg_Parameter_Types) then
2198                   Check_Matching_Types : declare
2199                      Formal : Entity_Id;
2200                      Ptype  : Node_Id;
2201
2202                   begin
2203                      Formal := First_Formal (Def_Id);
2204
2205                      if Nkind (Arg_Parameter_Types) = N_Null then
2206                         if Present (Formal) then
2207                            Match := False;
2208                         end if;
2209
2210                      --  A list of one type, e.g. (List) is parsed as
2211                      --  a parenthesized expression.
2212
2213                      elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
2214                        and then Paren_Count (Arg_Parameter_Types) = 1
2215                      then
2216                         if No (Formal)
2217                           or else Present (Next_Formal (Formal))
2218                         then
2219                            Match := False;
2220                         else
2221                            Match :=
2222                              Same_Base_Type (Arg_Parameter_Types, Formal);
2223                         end if;
2224
2225                      --  A list of more than one type is parsed as a aggregate
2226
2227                      elsif Nkind (Arg_Parameter_Types) = N_Aggregate
2228                        and then Paren_Count (Arg_Parameter_Types) = 0
2229                      then
2230                         Ptype := First (Expressions (Arg_Parameter_Types));
2231
2232                         while Present (Ptype) or else Present (Formal) loop
2233                            if No (Ptype)
2234                              or else No (Formal)
2235                              or else not Same_Base_Type (Ptype, Formal)
2236                            then
2237                               Match := False;
2238                               exit;
2239                            else
2240                               Next_Formal (Formal);
2241                               Next (Ptype);
2242                            end if;
2243                         end loop;
2244
2245                      --  Anything else is of the wrong form
2246
2247                      else
2248                         Error_Pragma_Arg
2249                           ("wrong form for Parameter_Types parameter",
2250                            Arg_Parameter_Types);
2251                      end if;
2252                   end Check_Matching_Types;
2253                end if;
2254
2255                --  Match is now False if the entry we found did not match
2256                --  either a supplied Parameter_Types or Result_Types argument
2257
2258                if Match then
2259                   if No (Ent) then
2260                      Ent := Def_Id;
2261
2262                   --  Ambiguous case, the flag Ambiguous shows if we already
2263                   --  detected this and output the initial messages.
2264
2265                   else
2266                      if not Ambiguous then
2267                         Ambiguous := True;
2268                         Error_Msg_Name_1 := Chars (N);
2269                         Error_Msg_N
2270                           ("pragma% does not uniquely identify subprogram!",
2271                            N);
2272                         Error_Msg_Sloc := Sloc (Ent);
2273                         Error_Msg_N ("matching subprogram #!", N);
2274                         Ent := Empty;
2275                      end if;
2276
2277                      Error_Msg_Sloc := Sloc (Def_Id);
2278                      Error_Msg_N ("matching subprogram #!", N);
2279                   end if;
2280                end if;
2281             end if;
2282
2283             Hom_Id := Homonym (Hom_Id);
2284          end loop;
2285
2286          --  See if we found an entry
2287
2288          if No (Ent) then
2289             if not Ambiguous then
2290                if Is_Generic_Subprogram (Entity (Arg_Internal)) then
2291                   Error_Pragma
2292                     ("pragma% cannot be given for generic subprogram");
2293
2294                else
2295                   Error_Pragma
2296                     ("pragma% does not identify local subprogram");
2297                end if;
2298             end if;
2299
2300             return;
2301          end if;
2302
2303          --  Import pragmas must be be for imported entities
2304
2305          if (Prag_Id = Pragma_Import_Function
2306                or else
2307              Prag_Id = Pragma_Import_Procedure
2308                or else
2309              Prag_Id = Pragma_Import_Valued_Procedure)
2310          then
2311             if not Is_Imported (Ent) then
2312                Error_Pragma
2313                  ("pragma Import or Interface must precede pragma%");
2314             end if;
2315
2316          --  For the Export cases, the pragma Export is sufficient to set
2317          --  the entity as exported, if it is not exported already. We
2318          --  leave the default Ada convention in this case.
2319
2320          else
2321             Set_Exported (Ent, Arg_Internal);
2322          end if;
2323
2324          --  Special processing for Valued_Procedure cases
2325
2326          if Prag_Id = Pragma_Import_Valued_Procedure
2327            or else
2328             Prag_Id = Pragma_Export_Valued_Procedure
2329          then
2330             Formal := First_Formal (Ent);
2331
2332             if No (Formal) then
2333                Error_Pragma
2334                  ("at least one parameter required for pragma%");
2335
2336             elsif Ekind (Formal) /= E_Out_Parameter then
2337                Error_Pragma
2338                  ("first parameter must have mode out for pragma%");
2339
2340             else
2341                Set_Is_Valued_Procedure (Ent);
2342             end if;
2343          end if;
2344
2345          Set_Extended_Import_Export_External_Name (Ent, Arg_External);
2346
2347          --  Process Result_Mechanism argument if present. We have already
2348          --  checked that this is only allowed for the function case.
2349
2350          if Present (Arg_Result_Mechanism) then
2351             Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
2352          end if;
2353
2354          --  Process Mechanism parameter if present. Note that this parameter
2355          --  is not analyzed, and must not be analyzed since it is semantic
2356          --  nonsense, so we get it in exactly as the parser left it.
2357
2358          if Present (Arg_Mechanism) then
2359
2360             declare
2361                Formal : Entity_Id;
2362                Massoc : Node_Id;
2363                Mname  : Node_Id;
2364                Choice : Node_Id;
2365
2366             begin
2367                --  A single mechanism association without a formal parameter
2368                --  name is parsed as a parenthesized expression. All other
2369                --  cases are parsed as aggregates, so we rewrite the single
2370                --  parameter case as an aggregate for consistency.
2371
2372                if Nkind (Arg_Mechanism) /= N_Aggregate
2373                  and then Paren_Count (Arg_Mechanism) = 1
2374                then
2375                   Rewrite (Arg_Mechanism,
2376                     Make_Aggregate (Sloc (Arg_Mechanism),
2377                       Expressions => New_List (
2378                         Relocate_Node (Arg_Mechanism))));
2379                end if;
2380
2381                --  Case of only mechanism name given, applies to all formals
2382
2383                if Nkind (Arg_Mechanism) /= N_Aggregate then
2384                   Formal := First_Formal (Ent);
2385                   while Present (Formal) loop
2386                      Set_Mechanism_Value (Formal, Arg_Mechanism);
2387                      Next_Formal (Formal);
2388                   end loop;
2389
2390                --  Case of list of mechanism associations given
2391
2392                else
2393                   if Null_Record_Present (Arg_Mechanism) then
2394                      Error_Pragma_Arg
2395                        ("inappropriate form for Mechanism parameter",
2396                         Arg_Mechanism);
2397                   end if;
2398
2399                   --  Deal with positional ones first
2400
2401                   Formal := First_Formal (Ent);
2402                   if Present (Expressions (Arg_Mechanism)) then
2403                      Mname := First (Expressions (Arg_Mechanism));
2404
2405                      while Present (Mname) loop
2406                         if No (Formal) then
2407                            Error_Pragma_Arg
2408                              ("too many mechanism associations", Mname);
2409                         end if;
2410
2411                         Set_Mechanism_Value (Formal, Mname);
2412                         Next_Formal (Formal);
2413                         Next (Mname);
2414                      end loop;
2415                   end if;
2416
2417                   --  Deal with named entries
2418
2419                   if Present (Component_Associations (Arg_Mechanism)) then
2420                      Massoc := First (Component_Associations (Arg_Mechanism));
2421
2422                      while Present (Massoc) loop
2423                         Choice := First (Choices (Massoc));
2424
2425                         if Nkind (Choice) /= N_Identifier
2426                           or else Present (Next (Choice))
2427                         then
2428                            Error_Pragma_Arg
2429                              ("incorrect form for mechanism association",
2430                               Massoc);
2431                         end if;
2432
2433                         Formal := First_Formal (Ent);
2434                         loop
2435                            if No (Formal) then
2436                               Error_Pragma_Arg
2437                                 ("parameter name & not present", Choice);
2438                            end if;
2439
2440                            if Chars (Choice) = Chars (Formal) then
2441                               Set_Mechanism_Value
2442                                 (Formal, Expression (Massoc));
2443                               exit;
2444                            end if;
2445
2446                            Next_Formal (Formal);
2447                         end loop;
2448
2449                         Next (Massoc);
2450                      end loop;
2451                   end if;
2452                end if;
2453             end;
2454          end if;
2455
2456          --  Process First_Optional_Parameter argument if present. We have
2457          --  already checked that this is only allowed for the Import case.
2458
2459          if Present (Arg_First_Optional_Parameter) then
2460             if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
2461                Error_Pragma_Arg
2462                  ("first optional parameter must be formal parameter name",
2463                   Arg_First_Optional_Parameter);
2464             end if;
2465
2466             Formal := First_Formal (Ent);
2467             loop
2468                if No (Formal) then
2469                   Error_Pragma_Arg
2470                     ("specified formal parameter& not found",
2471                      Arg_First_Optional_Parameter);
2472                end if;
2473
2474                exit when Chars (Formal) =
2475                          Chars (Arg_First_Optional_Parameter);
2476
2477                Next_Formal (Formal);
2478             end loop;
2479
2480             Set_First_Optional_Parameter (Ent, Formal);
2481
2482             --  Check specified and all remaining formals have right form
2483
2484             while Present (Formal) loop
2485                if Ekind (Formal) /= E_In_Parameter then
2486                   Error_Msg_NE
2487                     ("optional formal& is not of mode in!",
2488                      Arg_First_Optional_Parameter, Formal);
2489
2490                else
2491                   Dval := Default_Value (Formal);
2492
2493                   if not Present (Dval) then
2494                      Error_Msg_NE
2495                        ("optional formal& does not have default value!",
2496                         Arg_First_Optional_Parameter, Formal);
2497
2498                   elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
2499                      null;
2500
2501                   else
2502                      Error_Msg_NE
2503                        ("default value for optional formal& is non-static!",
2504                         Arg_First_Optional_Parameter, Formal);
2505                   end if;
2506                end if;
2507
2508                Set_Is_Optional_Parameter (Formal);
2509                Next_Formal (Formal);
2510             end loop;
2511          end if;
2512       end Process_Extended_Import_Export_Subprogram_Pragma;
2513
2514       --------------------------
2515       -- Process_Generic_List --
2516       --------------------------
2517
2518       procedure Process_Generic_List is
2519          Arg : Node_Id;
2520          Exp : Node_Id;
2521
2522       begin
2523          GNAT_Pragma;
2524          Check_No_Identifiers;
2525          Check_At_Least_N_Arguments (1);
2526
2527          Arg := Arg1;
2528          while Present (Arg) loop
2529             Exp := Expression (Arg);
2530             Analyze (Exp);
2531
2532             if not Is_Entity_Name (Exp)
2533               or else
2534                 (not Is_Generic_Instance (Entity (Exp))
2535                   and then
2536                  not Is_Generic_Unit (Entity (Exp)))
2537             then
2538                Error_Pragma_Arg
2539                  ("pragma% argument must be name of generic unit/instance",
2540                   Arg);
2541             end if;
2542
2543             Next (Arg);
2544          end loop;
2545       end Process_Generic_List;
2546
2547       ---------------------------------
2548       -- Process_Import_Or_Interface --
2549       ---------------------------------
2550
2551       procedure Process_Import_Or_Interface is
2552          C      : Convention_Id;
2553          Def_Id : Entity_Id;
2554          Hom_Id : Entity_Id;
2555
2556       begin
2557          Process_Convention (C, Def_Id);
2558          Kill_Size_Check_Code (Def_Id);
2559          Note_Possible_Modification (Expression (Arg2));
2560
2561          if Ekind (Def_Id) = E_Variable
2562               or else
2563             Ekind (Def_Id) = E_Constant
2564          then
2565             --  User initialization is not allowed for imported object, but
2566             --  the object declaration may contain a default initialization,
2567             --  that will be discarded.
2568
2569             if Present (Expression (Parent (Def_Id)))
2570                and then Comes_From_Source (Expression (Parent (Def_Id)))
2571             then
2572                Error_Msg_Sloc := Sloc (Def_Id);
2573                Error_Pragma_Arg
2574                  ("no initialization allowed for declaration of& #",
2575                   "\imported entities cannot be initialized ('R'M' 'B.1(24))",
2576                   Arg2);
2577
2578             else
2579                Set_Imported (Def_Id);
2580                Set_Is_Public (Def_Id);
2581                Process_Interface_Name (Def_Id, Arg3, Arg4);
2582             end if;
2583
2584          elsif Is_Subprogram (Def_Id)
2585            or else Is_Generic_Subprogram (Def_Id)
2586          then
2587             --  If the name is overloaded, pragma applies to all of the
2588             --  denoted entities in the same declarative part.
2589
2590             Hom_Id := Def_Id;
2591
2592             while Present (Hom_Id) loop
2593                Def_Id := Get_Base_Subprogram (Hom_Id);
2594
2595                --  Ignore inherited subprograms because the pragma will
2596                --  apply to the parent operation, which is the one called.
2597
2598                if Is_Overloadable (Def_Id)
2599                  and then Present (Alias (Def_Id))
2600                then
2601                   null;
2602
2603                --  Verify that the homonym is in the same declarative
2604                --  part (not just the same scope).
2605
2606                elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
2607                  and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
2608                then
2609                   exit;
2610
2611                else
2612                   Set_Imported (Def_Id);
2613
2614                   --  If Import intrinsic, set intrinsic flag
2615                   --  and verify that it is known as such.
2616
2617                   if C = Convention_Intrinsic then
2618                      Set_Is_Intrinsic_Subprogram (Def_Id);
2619                      Check_Intrinsic_Subprogram
2620                        (Def_Id, Expression (Arg2));
2621                   end if;
2622
2623                   --  All interfaced procedures need an external
2624                   --  symbol created for them since they are
2625                   --  always referenced from another object file.
2626
2627                   Set_Is_Public (Def_Id);
2628                   Set_Has_Completion (Def_Id);
2629                   Process_Interface_Name (Def_Id, Arg3, Arg4);
2630                end if;
2631
2632                if Is_Compilation_Unit (Hom_Id) then
2633
2634                   --  Its possible homonyms are not affected by the pragma.
2635                   --  Such homonyms might be present in the context of other
2636                   --  units being compiled.
2637
2638                   exit;
2639
2640                else
2641                   Hom_Id := Homonym (Hom_Id);
2642                end if;
2643             end loop;
2644
2645          --  When the convention is Java, we also allow Import to be given
2646          --  for packages, exceptions, and record components.
2647
2648          elsif C = Convention_Java
2649            and then (Ekind (Def_Id) = E_Package
2650                      or else Ekind (Def_Id) = E_Exception
2651                      or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
2652          then
2653             Set_Imported (Def_Id);
2654             Set_Is_Public (Def_Id);
2655             Process_Interface_Name (Def_Id, Arg3, Arg4);
2656
2657          else
2658             Error_Pragma_Arg
2659               ("second argument of pragma% must be object or subprogram",
2660                Arg2);
2661          end if;
2662
2663          --  If this pragma applies to a compilation unit, then the unit,
2664          --  which is a subprogram, does not require (or allow) a body.
2665          --  We also do not need to elaborate imported procedures.
2666
2667          if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
2668             declare
2669                Cunit : constant Node_Id := Parent (Parent (N));
2670
2671             begin
2672                Set_Body_Required    (Cunit, False);
2673             end;
2674          end if;
2675
2676       end Process_Import_Or_Interface;
2677
2678       --------------------
2679       -- Process_Inline --
2680       --------------------
2681
2682       procedure Process_Inline (Active : Boolean) is
2683          Assoc   : Node_Id;
2684          Decl    : Node_Id;
2685          Subp_Id : Node_Id;
2686          Subp    : Entity_Id;
2687          Applies : Boolean;
2688
2689          procedure Make_Inline (Subp : Entity_Id);
2690          --  Subp is the defining unit name of the subprogram
2691          --  declaration. Set the flag, as well as the flag in the
2692          --  corresponding body, if there is one present.
2693
2694          procedure Set_Inline_Flags (Subp : Entity_Id);
2695          --  Sets Is_Inlined and Has_Pragma_Inline flags for Subp
2696
2697          -----------------
2698          -- Make_Inline --
2699          -----------------
2700
2701          procedure Make_Inline (Subp : Entity_Id) is
2702             Kind       : Entity_Kind := Ekind (Subp);
2703             Inner_Subp : Entity_Id   := Subp;
2704
2705          begin
2706             if Etype (Subp) = Any_Type then
2707                return;
2708
2709             --  Here we have a candidate for inlining, but we must exclude
2710             --  derived operations. Otherwise we will end up trying to
2711             --  inline a phantom declaration, and the result would be to
2712             --  drag in a body which has no direct inlining associated with
2713             --  it. That would not only be inefficient but would also result
2714             --  in the backend doing cross-unit inlining in cases where it
2715             --  was definitely inappropriate to do so.
2716
2717             --  However, a simple Comes_From_Source test is insufficient,
2718             --  since we do want to allow inlining of generic instances,
2719             --  which also do not come from source. Predefined operators do
2720             --  not come from source but are not inlineable either.
2721
2722             elsif not Comes_From_Source (Subp)
2723               and then not Is_Generic_Instance (Subp)
2724               and then Scope (Subp) /= Standard_Standard
2725             then
2726                Applies := True;
2727                return;
2728
2729             --  The referenced entity must either be the enclosing entity,
2730             --  or an entity declared within the current open scope.
2731
2732             elsif Present (Scope (Subp))
2733               and then Scope (Subp) /= Current_Scope
2734               and then Subp /= Current_Scope
2735             then
2736                Error_Pragma_Arg
2737                  ("argument of% must be entity in current scope", Assoc);
2738                return;
2739             end if;
2740
2741             --  Processing for procedure, operator or function.
2742             --  If subprogram is aliased (as for an instance) indicate
2743             --  that the renamed entity is inlined.
2744
2745             if Kind = E_Procedure
2746               or else Kind = E_Function
2747               or else Kind = E_Operator
2748             then
2749                while Present (Alias (Inner_Subp)) loop
2750                   Inner_Subp := Alias (Inner_Subp);
2751                end loop;
2752
2753                Set_Inline_Flags (Inner_Subp);
2754
2755                Decl := Parent (Parent (Inner_Subp));
2756
2757                if Nkind (Decl) = N_Subprogram_Declaration
2758                  and then Present (Corresponding_Body (Decl))
2759                then
2760                   Set_Inline_Flags (Corresponding_Body (Decl));
2761                end if;
2762
2763                Applies := True;
2764
2765             --  For a generic subprogram set flag as well, for use at
2766             --  the point of instantiation, to determine whether the
2767             --  body should be generated.
2768
2769             elsif Kind = E_Generic_Procedure
2770               or else Kind = E_Generic_Function
2771             then
2772                Set_Inline_Flags (Subp);
2773                Applies := True;
2774
2775             --  Literals are by definition inlined.
2776
2777             elsif Kind = E_Enumeration_Literal then
2778                null;
2779
2780             --  Anything else is an error
2781
2782             else
2783                Error_Pragma_Arg
2784                  ("expect subprogram name for pragma%", Assoc);
2785             end if;
2786          end Make_Inline;
2787
2788          ----------------------
2789          -- Set_Inline_Flags --
2790          ----------------------
2791
2792          procedure Set_Inline_Flags (Subp : Entity_Id) is
2793          begin
2794             if Active then
2795                Set_Is_Inlined (Subp, True);
2796             end if;
2797
2798             if not Has_Pragma_Inline (Subp) then
2799                Set_Has_Pragma_Inline (Subp);
2800                Set_Next_Rep_Item (N, First_Rep_Item (Subp));
2801                Set_First_Rep_Item (Subp, N);
2802             end if;
2803          end Set_Inline_Flags;
2804
2805       --  Start of processing for Process_Inline
2806
2807       begin
2808          Check_No_Identifiers;
2809          Check_At_Least_N_Arguments (1);
2810
2811          if Active then
2812             Inline_Processing_Required := True;
2813          end if;
2814
2815          Assoc := Arg1;
2816          while Present (Assoc) loop
2817             Subp_Id := Expression (Assoc);
2818             Analyze (Subp_Id);
2819             Applies := False;
2820
2821             if Is_Entity_Name (Subp_Id) then
2822                Subp := Entity (Subp_Id);
2823
2824                if Subp = Any_Id then
2825                   Applies := True;
2826
2827                else
2828                   Make_Inline (Subp);
2829
2830                   while Present (Homonym (Subp))
2831                     and then Scope (Homonym (Subp)) = Current_Scope
2832                   loop
2833                      Make_Inline (Homonym (Subp));
2834                      Subp := Homonym (Subp);
2835                   end loop;
2836                end if;
2837             end if;
2838
2839             if not Applies then
2840                Error_Pragma_Arg
2841                  ("inappropriate argument for pragma%", Assoc);
2842             end if;
2843
2844             Next (Assoc);
2845          end loop;
2846
2847       end Process_Inline;
2848
2849       ----------------------------
2850       -- Process_Interface_Name --
2851       ----------------------------
2852
2853       procedure Process_Interface_Name
2854         (Subprogram_Def : Entity_Id;
2855          Ext_Arg        : Node_Id;
2856          Link_Arg       : Node_Id)
2857       is
2858          Ext_Nam    : Node_Id;
2859          Link_Nam   : Node_Id;
2860          String_Val : String_Id;
2861
2862          procedure Check_Form_Of_Interface_Name (SN : Node_Id);
2863          --  SN is a string literal node for an interface name. This routine
2864          --  performs some minimal checks that the name is reasonable. In
2865          --  particular that no spaces or other obviously incorrect characters
2866          --  appear. This is only a warning, since any characters are allowed.
2867
2868          procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
2869             S  : constant String_Id := Strval (Expr_Value_S (SN));
2870             SL : constant Nat       := String_Length (S);
2871             C  : Char_Code;
2872
2873          begin
2874             if SL = 0 then
2875                Error_Msg_N ("interface name cannot be null string", SN);
2876             end if;
2877
2878             for J in 1 .. SL loop
2879                C := Get_String_Char (S, J);
2880
2881                if not In_Character_Range (C)
2882                  or else Get_Character (C) = ' '
2883                  or else Get_Character (C) = ','
2884                then
2885                   Error_Msg_N
2886                     ("?interface name contains illegal character", SN);
2887                end if;
2888             end loop;
2889          end Check_Form_Of_Interface_Name;
2890
2891       --  Start of processing for Process_Interface_Name
2892
2893       begin
2894          if No (Link_Arg) then
2895             if No (Ext_Arg) then
2896                return;
2897
2898             elsif Chars (Ext_Arg) = Name_Link_Name then
2899                Ext_Nam  := Empty;
2900                Link_Nam := Expression (Ext_Arg);
2901
2902             else
2903                Check_Optional_Identifier (Ext_Arg, Name_External_Name);
2904                Ext_Nam  := Expression (Ext_Arg);
2905                Link_Nam := Empty;
2906             end if;
2907
2908          else
2909             Check_Optional_Identifier (Ext_Arg,  Name_External_Name);
2910             Check_Optional_Identifier (Link_Arg, Name_Link_Name);
2911             Ext_Nam  := Expression (Ext_Arg);
2912             Link_Nam := Expression (Link_Arg);
2913          end if;
2914
2915          --  Check expressions for external name and link name are static
2916
2917          if Present (Ext_Nam) then
2918             Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
2919             Check_Form_Of_Interface_Name (Ext_Nam);
2920
2921             --  Verify that the external name is not the name of a local
2922             --  entity, which would hide the imported one and lead to
2923             --  run-time surprises. The problem can only arise for entities
2924             --  declared in a package body (otherwise the external name is
2925             --  fully qualified and won't conflict).
2926
2927             declare
2928                Nam : Name_Id;
2929                E   : Entity_Id;
2930                Par : Node_Id;
2931
2932             begin
2933                if Prag_Id = Pragma_Import then
2934                   String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
2935                   Nam := Name_Find;
2936                   E   := Entity_Id (Get_Name_Table_Info (Nam));
2937
2938                   if Nam /= Chars (Subprogram_Def)
2939                     and then Present (E)
2940                     and then not Is_Overloadable (E)
2941                     and then Is_Immediately_Visible (E)
2942                     and then not Is_Imported (E)
2943                     and then Ekind (Scope (E)) = E_Package
2944                   then
2945                      Par := Parent (E);
2946
2947                      while Present (Par) loop
2948                         if Nkind (Par) = N_Package_Body then
2949                            Error_Msg_Sloc  := Sloc (E);
2950                            Error_Msg_NE
2951                              ("imported entity is hidden by & declared#",
2952                                  Ext_Arg, E);
2953                            exit;
2954                         end if;
2955
2956                         Par := Parent (Par);
2957                      end loop;
2958                   end if;
2959                end if;
2960             end;
2961          end if;
2962
2963          if Present (Link_Nam) then
2964             Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
2965             Check_Form_Of_Interface_Name (Link_Nam);
2966          end if;
2967
2968          --  If there is no link name, just set the external name
2969
2970          if No (Link_Nam) then
2971             Set_Encoded_Interface_Name
2972               (Get_Base_Subprogram (Subprogram_Def),
2973                Adjust_External_Name_Case (Expr_Value_S (Ext_Nam)));
2974
2975          --  For the Link_Name case, the given literal is preceded by an
2976          --  asterisk, which indicates to GCC that the given name should
2977          --  be taken literally, and in particular that no prepending of
2978          --  underlines should occur, even in systems where this is the
2979          --  normal default.
2980
2981          else
2982             Start_String;
2983             Store_String_Char (Get_Char_Code ('*'));
2984             String_Val := Strval (Expr_Value_S (Link_Nam));
2985
2986             for J in 1 .. String_Length (String_Val) loop
2987                Store_String_Char (Get_String_Char (String_Val, J));
2988             end loop;
2989
2990             Link_Nam :=
2991               Make_String_Literal (Sloc (Link_Nam), End_String);
2992
2993             Set_Encoded_Interface_Name
2994               (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
2995          end if;
2996       end Process_Interface_Name;
2997
2998       -----------------------------------------
2999       -- Process_Interrupt_Or_Attach_Handler --
3000       -----------------------------------------
3001
3002       procedure Process_Interrupt_Or_Attach_Handler is
3003          Arg1_X    : constant Node_Id   := Expression (Arg1);
3004          Prot_Proc : constant Entity_Id := Entity (Arg1_X);
3005          Prot_Type : constant Entity_Id := Scope (Prot_Proc);
3006
3007       begin
3008          Set_Is_Interrupt_Handler (Prot_Proc);
3009
3010          if Prag_Id = Pragma_Interrupt_Handler
3011            or Prag_Id = Pragma_Attach_Handler
3012          then
3013             Record_Rep_Item (Prot_Type, N);
3014          end if;
3015
3016       end Process_Interrupt_Or_Attach_Handler;
3017
3018       ---------------------------------
3019       -- Process_Suppress_Unsuppress --
3020       ---------------------------------
3021
3022       procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
3023          C         : Check_Id;
3024          E_Id      : Node_Id;
3025          E         : Entity_Id;
3026          Effective : Boolean;
3027
3028          procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
3029          --  Used to suppress a single check on the given entity
3030
3031          procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
3032          begin
3033             --  First set appropriate suppress flags in the entity
3034
3035             case C is
3036                when Access_Check =>
3037                   Effective := Suppress_Access_Checks (E);
3038                   Set_Suppress_Access_Checks (E, Suppress_Case);
3039
3040                when Accessibility_Check =>
3041                   Effective := Suppress_Accessibility_Checks (E);
3042                   Set_Suppress_Accessibility_Checks (E, Suppress_Case);
3043
3044                when Discriminant_Check =>
3045                   Effective := Suppress_Discriminant_Checks  (E);
3046                   Set_Suppress_Discriminant_Checks (E, Suppress_Case);
3047
3048                when Division_Check =>
3049                   Effective := Suppress_Division_Checks (E);
3050                   Set_Suppress_Division_Checks (E, Suppress_Case);
3051
3052                when Elaboration_Check =>
3053                   Effective := Suppress_Elaboration_Checks (E);
3054                   Set_Suppress_Elaboration_Checks (E, Suppress_Case);
3055
3056                when Index_Check =>
3057                   Effective := Suppress_Index_Checks (E);
3058                   Set_Suppress_Index_Checks (E, Suppress_Case);
3059
3060                when Length_Check =>
3061                   Effective := Suppress_Length_Checks (E);
3062                   Set_Suppress_Length_Checks (E, Suppress_Case);
3063
3064                when Overflow_Check =>
3065                   Effective := Suppress_Overflow_Checks (E);
3066                   Set_Suppress_Overflow_Checks (E, Suppress_Case);
3067
3068                when Range_Check =>
3069                   Effective := Suppress_Range_Checks (E);
3070                   Set_Suppress_Range_Checks (E, Suppress_Case);
3071
3072                when Storage_Check =>
3073                   Effective := Suppress_Storage_Checks (E);
3074                   Set_Suppress_Storage_Checks (E, Suppress_Case);
3075
3076                when Tag_Check =>
3077                   Effective := Suppress_Tag_Checks (E);
3078                   Set_Suppress_Tag_Checks (E, Suppress_Case);
3079
3080                when All_Checks =>
3081                   Suppress_Unsuppress_Echeck (E, Access_Check);
3082                   Suppress_Unsuppress_Echeck (E, Accessibility_Check);
3083                   Suppress_Unsuppress_Echeck (E, Discriminant_Check);
3084                   Suppress_Unsuppress_Echeck (E, Division_Check);
3085                   Suppress_Unsuppress_Echeck (E, Elaboration_Check);
3086                   Suppress_Unsuppress_Echeck (E, Index_Check);
3087                   Suppress_Unsuppress_Echeck (E, Length_Check);
3088                   Suppress_Unsuppress_Echeck (E, Overflow_Check);
3089                   Suppress_Unsuppress_Echeck (E, Range_Check);
3090                   Suppress_Unsuppress_Echeck (E, Storage_Check);
3091                   Suppress_Unsuppress_Echeck (E, Tag_Check);
3092             end case;
3093
3094             --  If the entity is not declared in the current scope, then we
3095             --  make an entry in the Entity_Suppress table so that the flag
3096             --  will be removed on exit. This entry is only made if the
3097             --  suppress did something (i.e. the flag was not already set).
3098
3099             if Effective and then Scope (E) /= Current_Scope then
3100                Entity_Suppress.Increment_Last;
3101                Entity_Suppress.Table
3102                  (Entity_Suppress.Last).Entity := E;
3103                Entity_Suppress.Table
3104                  (Entity_Suppress.Last).Check  := C;
3105             end if;
3106
3107             --  If this is a first subtype, and the base type is distinct,
3108             --  then also set the suppress flags on the base type.
3109
3110             if Is_First_Subtype (E)
3111               and then Etype (E) /= E
3112             then
3113                Suppress_Unsuppress_Echeck (Etype (E), C);
3114             end if;
3115          end Suppress_Unsuppress_Echeck;
3116
3117       --  Start of processing for Process_Suppress_Unsuppress
3118
3119       begin
3120          --  Suppress/Unsuppress can appear as a configuration pragma,
3121          --  or in a declarative part or a package spec (RM 11.5(5))
3122
3123          if not Is_Configuration_Pragma then
3124             Check_Is_In_Decl_Part_Or_Package_Spec;
3125          end if;
3126
3127          Check_At_Least_N_Arguments (1);
3128          Check_At_Most_N_Arguments (2);
3129          Check_No_Identifier (Arg1);
3130          Check_Arg_Is_Identifier (Arg1);
3131
3132          if not Is_Check_Name (Chars (Expression (Arg1))) then
3133             Error_Pragma_Arg
3134               ("argument of pragma% is not valid check name", Arg1);
3135
3136          else
3137             C := Get_Check_Id (Chars (Expression (Arg1)));
3138          end if;
3139
3140          if Arg_Count = 1 then
3141             case C is
3142                when Access_Check =>
3143                   Scope_Suppress.Access_Checks := Suppress_Case;
3144
3145                when Accessibility_Check =>
3146                   Scope_Suppress.Accessibility_Checks := Suppress_Case;
3147
3148                when Discriminant_Check =>
3149                   Scope_Suppress.Discriminant_Checks := Suppress_Case;
3150
3151                when Division_Check =>
3152                   Scope_Suppress.Division_Checks := Suppress_Case;
3153
3154                when Elaboration_Check =>
3155                   Scope_Suppress.Elaboration_Checks := Suppress_Case;
3156
3157                when Index_Check =>
3158                   Scope_Suppress.Index_Checks := Suppress_Case;
3159
3160                when Length_Check =>
3161                   Scope_Suppress.Length_Checks := Suppress_Case;
3162
3163                when Overflow_Check =>
3164                   Scope_Suppress.Overflow_Checks := Suppress_Case;
3165
3166                when Range_Check =>
3167                   Scope_Suppress.Range_Checks := Suppress_Case;
3168
3169                when Storage_Check =>
3170                   Scope_Suppress.Storage_Checks := Suppress_Case;
3171
3172                when Tag_Check =>
3173                   Scope_Suppress.Tag_Checks := Suppress_Case;
3174
3175                when All_Checks =>
3176                   Scope_Suppress := (others => Suppress_Case);
3177
3178             end case;
3179
3180          --  Case of two arguments present, where the check is
3181          --  suppressed for a specified entity (given as the second
3182          --  argument of the pragma)
3183
3184          else
3185             Check_Optional_Identifier (Arg2, Name_On);
3186             E_Id := Expression (Arg2);
3187             Analyze (E_Id);
3188
3189             if not Is_Entity_Name (E_Id) then
3190                Error_Pragma_Arg
3191                  ("second argument of pragma% must be entity name", Arg2);
3192             end if;
3193
3194             E := Entity (E_Id);
3195
3196             if E = Any_Id then
3197                return;
3198             else
3199                loop
3200                   Suppress_Unsuppress_Echeck (E, C);
3201
3202                   if Is_Generic_Instance (E)
3203                     and then Is_Subprogram (E)
3204                     and then Present (Alias (E))
3205                   then
3206                      Suppress_Unsuppress_Echeck (Alias (E), C);
3207                   end if;
3208
3209                   if C = Elaboration_Check and then Suppress_Case then
3210                      Set_Suppress_Elaboration_Warnings (E);
3211                   end if;
3212
3213                   --  If we are within a package specification, the
3214                   --  pragma only applies to homonyms in the same scope.
3215
3216                   exit when No (Homonym (E))
3217                     or else (Scope (Homonym (E)) /= Current_Scope
3218                               and then Ekind (Current_Scope) = E_Package
3219                               and then not In_Package_Body (Current_Scope));
3220
3221                   E := Homonym (E);
3222                end loop;
3223             end if;
3224          end if;
3225
3226       end Process_Suppress_Unsuppress;
3227
3228       ------------------
3229       -- Set_Exported --
3230       ------------------
3231
3232       procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
3233       begin
3234          if Is_Imported (E) then
3235             Error_Pragma_Arg
3236               ("cannot export entity& that was previously imported", Arg);
3237
3238          elsif Present (Address_Clause (E)) then
3239             Error_Pragma_Arg
3240               ("cannot export entity& that has an address clause", Arg);
3241          end if;
3242
3243          Set_Is_Exported (E);
3244
3245          --  Deal with exporting non-library level entity
3246
3247          if not Is_Library_Level_Entity (E) then
3248
3249             --  Not allowed at all for subprograms
3250
3251             if Is_Subprogram (E) then
3252                Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
3253
3254             --  Otherwise set public and statically allocated
3255
3256             else
3257                Set_Is_Public (E);
3258                Set_Is_Statically_Allocated (E);
3259             end if;
3260          end if;
3261
3262          if Inside_A_Generic then
3263             Error_Msg_NE
3264               ("all instances of& will have the same external name?", Arg, E);
3265          end if;
3266
3267       end Set_Exported;
3268
3269       ----------------------------------------------
3270       -- Set_Extended_Import_Export_External_Name --
3271       ----------------------------------------------
3272
3273       procedure Set_Extended_Import_Export_External_Name
3274         (Internal_Ent : Entity_Id;
3275          Arg_External : Node_Id)
3276       is
3277          Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
3278          New_Name : Node_Id;
3279
3280       begin
3281          if No (Arg_External) then
3282             return;
3283
3284          elsif Nkind (Arg_External) = N_String_Literal then
3285             if String_Length (Strval (Arg_External)) = 0 then
3286                return;
3287             else
3288                New_Name := Adjust_External_Name_Case (Arg_External);
3289             end if;
3290
3291          elsif Nkind (Arg_External) = N_Identifier then
3292             New_Name := Get_Default_External_Name (Arg_External);
3293
3294          else
3295             Error_Pragma_Arg
3296               ("incorrect form for External parameter for pragma%",
3297                Arg_External);
3298          end if;
3299
3300          --  If we already have an external name set (by a prior normal
3301          --  Import or Export pragma), then the external names must match
3302
3303          if Present (Interface_Name (Internal_Ent)) then
3304             declare
3305                S1 : constant String_Id := Strval (Old_Name);
3306                S2 : constant String_Id := Strval (New_Name);
3307
3308                procedure Mismatch;
3309                --  Called if names do not match
3310
3311                procedure Mismatch is
3312                begin
3313                   Error_Msg_Sloc := Sloc (Old_Name);
3314                   Error_Pragma_Arg
3315                     ("external name does not match that given #",
3316                      Arg_External);
3317                end Mismatch;
3318
3319             begin
3320                if String_Length (S1) /= String_Length (S2) then
3321                   Mismatch;
3322
3323                else
3324                   for J in 1 .. String_Length (S1) loop
3325                      if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
3326                         Mismatch;
3327                      end if;
3328                   end loop;
3329                end if;
3330             end;
3331
3332          --  Otherwise set the given name
3333
3334          else
3335             Set_Encoded_Interface_Name (Internal_Ent, New_Name);
3336          end if;
3337
3338       end Set_Extended_Import_Export_External_Name;
3339
3340       ------------------
3341       -- Set_Imported --
3342       ------------------
3343
3344       procedure Set_Imported (E : Entity_Id) is
3345       begin
3346          Error_Msg_Sloc  := Sloc (E);
3347
3348          if Is_Exported (E) or else Is_Imported (E) then
3349             Error_Msg_NE ("import of& declared# not allowed", N, E);
3350
3351             if Is_Exported (E) then
3352                Error_Msg_N ("\entity was previously exported", N);
3353             else
3354                Error_Msg_N ("\entity was previously imported", N);
3355             end if;
3356
3357             Error_Pragma ("\(pragma% applies to all previous entities)");
3358
3359          else
3360             Set_Is_Imported (E);
3361
3362             --  If the entity is an object that is not at the library
3363             --  level, then it is statically allocated. We do not worry
3364             --  about objects with address clauses in this context since
3365             --  they are not really imported in the linker sense.
3366
3367             if Is_Object (E)
3368               and then not Is_Library_Level_Entity (E)
3369               and then No (Address_Clause (E))
3370             then
3371                Set_Is_Statically_Allocated (E);
3372             end if;
3373          end if;
3374       end Set_Imported;
3375
3376       -------------------------
3377       -- Set_Mechanism_Value --
3378       -------------------------
3379
3380       --  Note: the mechanism name has not been analyzed (and cannot indeed
3381       --  be analyzed, since it is semantic nonsense), so we get it in the
3382       --  exact form created by the parser.
3383
3384       procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
3385          Class : Node_Id;
3386          Param : Node_Id;
3387
3388          procedure Bad_Class;
3389          --  Signal bad descriptor class name
3390
3391          procedure Bad_Mechanism;
3392          --  Signal bad mechanism name
3393
3394          procedure Bad_Class is
3395          begin
3396             Error_Pragma_Arg ("unrecognized descriptor class name", Class);
3397          end Bad_Class;
3398
3399          procedure Bad_Mechanism is
3400          begin
3401             Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
3402          end Bad_Mechanism;
3403
3404       --  Start of processing for Set_Mechanism_Value
3405
3406       begin
3407          if Mechanism (Ent) /= Default_Mechanism then
3408             Error_Msg_NE
3409               ("mechanism for & has already been set", Mech_Name, Ent);
3410          end if;
3411
3412          --  MECHANISM_NAME ::= value | reference | descriptor
3413
3414          if Nkind (Mech_Name) = N_Identifier then
3415             if Chars (Mech_Name) = Name_Value then
3416                Set_Mechanism (Ent, By_Copy);
3417                return;
3418
3419             elsif Chars (Mech_Name) = Name_Reference then
3420                Set_Mechanism (Ent, By_Reference);
3421                return;
3422
3423             elsif Chars (Mech_Name) = Name_Descriptor then
3424                Check_VMS (Mech_Name);
3425                Set_Mechanism (Ent, By_Descriptor);
3426                return;
3427
3428             elsif Chars (Mech_Name) = Name_Copy then
3429                Error_Pragma_Arg
3430                  ("bad mechanism name, Value assumed", Mech_Name);
3431
3432             else
3433                Bad_Mechanism;
3434             end if;
3435
3436          --  MECHANISM_NAME ::= descriptor (CLASS_NAME)
3437          --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
3438
3439          --  Note: this form is parsed as an indexed component
3440
3441          elsif Nkind (Mech_Name) = N_Indexed_Component then
3442             Class := First (Expressions (Mech_Name));
3443
3444             if Nkind (Prefix (Mech_Name)) /= N_Identifier
3445               or else Chars (Prefix (Mech_Name)) /= Name_Descriptor
3446               or else Present (Next (Class))
3447             then
3448                Bad_Mechanism;
3449             end if;
3450
3451          --  MECHANISM_NAME ::= descriptor (Class => CLASS_NAME)
3452          --  CLASS_NAME     ::= ubs | ubsb | uba | s | sb | a | nca
3453
3454          --  Note: this form is parsed as a function call
3455
3456          elsif Nkind (Mech_Name) = N_Function_Call then
3457
3458             Param := First (Parameter_Associations (Mech_Name));
3459
3460             if Nkind (Name (Mech_Name)) /= N_Identifier
3461               or else Chars (Name (Mech_Name)) /= Name_Descriptor
3462               or else Present (Next (Param))
3463               or else No (Selector_Name (Param))
3464               or else Chars (Selector_Name (Param)) /= Name_Class
3465             then
3466                Bad_Mechanism;
3467             else
3468                Class := Explicit_Actual_Parameter (Param);
3469             end if;
3470
3471          else
3472             Bad_Mechanism;
3473          end if;
3474
3475          --  Fall through here with Class set to descriptor class name
3476
3477          Check_VMS (Mech_Name);
3478
3479          if Nkind (Class) /= N_Identifier then
3480             Bad_Class;
3481
3482          elsif Chars (Class) = Name_UBS then
3483             Set_Mechanism (Ent, By_Descriptor_UBS);
3484
3485          elsif Chars (Class) = Name_UBSB then
3486             Set_Mechanism (Ent, By_Descriptor_UBSB);
3487
3488          elsif Chars (Class) = Name_UBA then
3489             Set_Mechanism (Ent, By_Descriptor_UBA);
3490
3491          elsif Chars (Class) = Name_S then
3492             Set_Mechanism (Ent, By_Descriptor_S);
3493
3494          elsif Chars (Class) = Name_SB then
3495             Set_Mechanism (Ent, By_Descriptor_SB);
3496
3497          elsif Chars (Class) = Name_A then
3498             Set_Mechanism (Ent, By_Descriptor_A);
3499
3500          elsif Chars (Class) = Name_NCA then
3501             Set_Mechanism (Ent, By_Descriptor_NCA);
3502
3503          else
3504             Bad_Class;
3505          end if;
3506
3507       end Set_Mechanism_Value;
3508
3509    --  Start of processing for Analyze_Pragma
3510
3511    begin
3512       if not Is_Pragma_Name (Chars (N)) then
3513          Error_Pragma ("unrecognized pragma%!?");
3514       else
3515          Prag_Id := Get_Pragma_Id (Chars (N));
3516       end if;
3517
3518       --  Preset arguments
3519
3520       Arg1 := Empty;
3521       Arg2 := Empty;
3522       Arg3 := Empty;
3523       Arg4 := Empty;
3524
3525       if Present (Pragma_Argument_Associations (N)) then
3526          Arg1 := First (Pragma_Argument_Associations (N));
3527
3528          if Present (Arg1) then
3529             Arg2 := Next (Arg1);
3530
3531             if Present (Arg2) then
3532                Arg3 := Next (Arg2);
3533
3534                if Present (Arg3) then
3535                   Arg4 := Next (Arg3);
3536                end if;
3537             end if;
3538          end if;
3539       end if;
3540
3541       --  Count number of arguments
3542
3543       declare
3544          Arg_Node : Node_Id;
3545
3546       begin
3547          Arg_Count := 0;
3548          Arg_Node := Arg1;
3549
3550          while Present (Arg_Node) loop
3551             Arg_Count := Arg_Count + 1;
3552             Next (Arg_Node);
3553          end loop;
3554       end;
3555
3556       --  An enumeration type defines the pragmas that are supported by the
3557       --  implementation. Get_Pragma_Id (in package Prag) transorms a name
3558       --  into the corresponding enumeration value for the following case.
3559
3560       case Prag_Id is
3561
3562          -----------------
3563          -- Abort_Defer --
3564          -----------------
3565
3566          --  pragma Abort_Defer;
3567
3568          when Pragma_Abort_Defer =>
3569             GNAT_Pragma;
3570             Check_Arg_Count (0);
3571
3572             --  The only required semantic processing is to check the
3573             --  placement. This pragma must appear at the start of the
3574             --  statement sequence of a handled sequence of statements.
3575
3576             if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
3577               or else N /= First (Statements (Parent (N)))
3578             then
3579                Pragma_Misplaced;
3580             end if;
3581
3582          ------------
3583          -- Ada_83 --
3584          ------------
3585
3586          --  pragma Ada_83;
3587
3588          --  Note: this pragma also has some specific processing in Par.Prag
3589          --  because we want to set the Ada 83 mode switch during parsing.
3590
3591          when Pragma_Ada_83 =>
3592             GNAT_Pragma;
3593             Ada_83 := True;
3594             Ada_95 := False;
3595             Check_Arg_Count (0);
3596
3597          ------------
3598          -- Ada_95 --
3599          ------------
3600
3601          --  pragma Ada_95;
3602
3603          --  Note: this pragma also has some specific processing in Par.Prag
3604          --  because we want to set the Ada 83 mode switch during parsing.
3605
3606          when Pragma_Ada_95 =>
3607             GNAT_Pragma;
3608             Ada_83 := False;
3609             Ada_95 := True;
3610             Check_Arg_Count (0);
3611
3612          ----------------------
3613          -- All_Calls_Remote --
3614          ----------------------
3615
3616          --  pragma All_Calls_Remote [(library_package_NAME)];
3617
3618          when Pragma_All_Calls_Remote => All_Calls_Remote : declare
3619             Lib_Entity : Entity_Id;
3620
3621          begin
3622             Check_Ada_83_Warning;
3623             Check_Valid_Library_Unit_Pragma;
3624
3625             if Nkind (N) = N_Null_Statement then
3626                return;
3627             end if;
3628
3629             Lib_Entity := Find_Lib_Unit_Name;
3630
3631             --  This pragma should only apply to a RCI unit (RM E.2.3(23)).
3632
3633             if Present (Lib_Entity)
3634               and then not Debug_Flag_U
3635             then
3636                if not Is_Remote_Call_Interface (Lib_Entity) then
3637                   Error_Pragma ("pragma% only apply to rci unit");
3638
3639                --  Set flag for entity of the library unit
3640
3641                else
3642                   Set_Has_All_Calls_Remote (Lib_Entity);
3643                end if;
3644
3645             end if;
3646          end All_Calls_Remote;
3647
3648          --------------
3649          -- Annotate --
3650          --------------
3651
3652          --  pragma Annotate (IDENTIFIER {, ARG});
3653          --  ARG ::= NAME | EXPRESSION
3654
3655          when Pragma_Annotate => Annotate : begin
3656             GNAT_Pragma;
3657             Check_At_Least_N_Arguments (1);
3658             Check_Arg_Is_Identifier (Arg1);
3659
3660             declare
3661                Arg : Node_Id := Arg2;
3662                Exp : Node_Id;
3663
3664             begin
3665                while Present (Arg) loop
3666                   Exp := Expression (Arg);
3667                   Analyze (Exp);
3668
3669                   if Is_Entity_Name (Exp) then
3670                      null;
3671
3672                   elsif Nkind (Exp) = N_String_Literal then
3673                      Resolve (Exp, Standard_String);
3674
3675                   elsif Is_Overloaded (Exp) then
3676                      Error_Pragma_Arg ("ambiguous argument for pragma%", Exp);
3677
3678                   else
3679                      Resolve (Exp, Etype (Exp));
3680                   end if;
3681
3682                   Next (Arg);
3683                end loop;
3684             end;
3685          end Annotate;
3686
3687          ------------
3688          -- Assert --
3689          ------------
3690
3691          --  pragma Assert (Boolean_EXPRESSION [, static_string_EXPRESSION]);
3692
3693          when Pragma_Assert =>
3694             GNAT_Pragma;
3695             Check_No_Identifiers;
3696
3697             if Arg_Count > 1 then
3698                Check_Arg_Count (2);
3699                Check_Arg_Is_Static_Expression (Arg2, Standard_String);
3700             end if;
3701
3702             --  If expansion is active and assertions are inactive, then
3703             --  we rewrite the Assertion as:
3704
3705             --    if False and then condition then
3706             --       null;
3707             --    end if;
3708
3709             --  The reason we do this rewriting during semantic analysis
3710             --  rather than as part of normal expansion is that we cannot
3711             --  analyze and expand the code for the boolean expression
3712             --  directly, or it may cause insertion of actions that would
3713             --  escape the attempt to suppress the assertion code.
3714
3715             if Expander_Active and not Assertions_Enabled then
3716                Rewrite (N,
3717                  Make_If_Statement (Loc,
3718                    Condition =>
3719                      Make_And_Then (Loc,
3720                        Left_Opnd  => New_Occurrence_Of (Standard_False, Loc),
3721                        Right_Opnd => Get_Pragma_Arg (Arg1)),
3722                    Then_Statements => New_List (
3723                      Make_Null_Statement (Loc))));
3724
3725                Analyze (N);
3726
3727             --  Otherwise (if assertions are enabled, or if we are not
3728             --  operating with expansion active), then we just analyze
3729             --  and resolve the expression.
3730
3731             else
3732                Analyze_And_Resolve (Expression (Arg1), Any_Boolean);
3733             end if;
3734
3735          ---------------
3736          -- AST_Entry --
3737          ---------------
3738
3739          --  pragma AST_Entry (entry_IDENTIFIER);
3740
3741          when Pragma_AST_Entry => AST_Entry : declare
3742             Ent : Node_Id;
3743
3744          begin
3745             GNAT_Pragma;
3746             Check_VMS (N);
3747             Check_Arg_Count (1);
3748             Check_No_Identifiers;
3749             Check_Arg_Is_Local_Name (Arg1);
3750             Ent := Entity (Expression (Arg1));
3751
3752             --  Note: the implementation of the AST_Entry pragma could handle
3753             --  the entry family case fine, but for now we are consistent with
3754             --  the DEC rules, and do not allow the pragma, which of course
3755             --  has the effect of also forbidding the attribute.
3756
3757             if Ekind (Ent) /= E_Entry then
3758                Error_Pragma_Arg
3759                  ("pragma% argument must be simple entry name", Arg1);
3760
3761             elsif Is_AST_Entry (Ent) then
3762                Error_Pragma_Arg
3763                  ("duplicate % pragma for entry", Arg1);
3764
3765             elsif Has_Homonym (Ent) then
3766                Error_Pragma_Arg
3767                  ("pragma% argument cannot specify overloaded entry", Arg1);
3768
3769             else
3770                declare
3771                   FF : constant Entity_Id := First_Formal (Ent);
3772
3773                begin
3774                   if Present (FF) then
3775                      if Present (Next_Formal (FF)) then
3776                         Error_Pragma_Arg
3777                           ("entry for pragma% can have only one argument",
3778                            Arg1);
3779
3780                      elsif Parameter_Mode (FF) /= E_In_Parameter then
3781                         Error_Pragma_Arg
3782                           ("entry parameter for pragma% must have mode IN",
3783                            Arg1);
3784                      end if;
3785                   end if;
3786                end;
3787
3788                Set_Is_AST_Entry (Ent);
3789             end if;
3790          end AST_Entry;
3791
3792          ------------------
3793          -- Asynchronous --
3794          ------------------
3795
3796          --  pragma Asynchronous (LOCAL_NAME);
3797
3798          when Pragma_Asynchronous => Asynchronous : declare
3799             Nm     : Entity_Id;
3800             C_Ent  : Entity_Id;
3801             L      : List_Id;
3802             S      : Node_Id;
3803             N      : Node_Id;
3804             Formal : Entity_Id;
3805
3806             procedure Process_Async_Pragma;
3807             --  Common processing for procedure and access-to-procedure case
3808
3809             --------------------------
3810             -- Process_Async_Pragma --
3811             --------------------------
3812
3813             procedure Process_Async_Pragma is
3814             begin
3815                if not Present (L) then
3816                   Set_Is_Asynchronous (Nm);
3817                   return;
3818                end if;
3819
3820                --  The formals should be of mode IN (RM E.4.1(6))
3821
3822                S := First (L);
3823                while Present (S) loop
3824                   Formal := Defining_Identifier (S);
3825
3826                   if Nkind (Formal) = N_Defining_Identifier
3827                     and then Ekind (Formal) /= E_In_Parameter
3828                   then
3829                      Error_Pragma_Arg
3830                        ("pragma% procedure can only have IN parameter",
3831                         Arg1);
3832                   end if;
3833
3834                   Next (S);
3835                end loop;
3836
3837                Set_Is_Asynchronous (Nm);
3838             end Process_Async_Pragma;
3839
3840          --  Start of processing for pragma Asynchronous
3841
3842          begin
3843             Check_Ada_83_Warning;
3844             Check_No_Identifiers;
3845             Check_Arg_Count (1);
3846             Check_Arg_Is_Local_Name (Arg1);
3847
3848             if Debug_Flag_U then
3849                return;
3850             end if;
3851
3852             C_Ent := Cunit_Entity (Current_Sem_Unit);
3853             Analyze (Expression (Arg1));
3854             Nm := Entity (Expression (Arg1));
3855
3856             if not Is_Remote_Call_Interface (C_Ent)
3857               and then not Is_Remote_Types (C_Ent)
3858             then
3859                --  This pragma should only appear in an RCI or Remote Types
3860                --  unit (RM E.4.1(4))
3861
3862                Error_Pragma
3863                  ("pragma% not in Remote_Call_Interface or " &
3864                   "Remote_Types unit");
3865             end if;
3866
3867             if Ekind (Nm) = E_Procedure
3868               and then Nkind (Parent (Nm)) = N_Procedure_Specification
3869             then
3870                if not Is_Remote_Call_Interface (Nm) then
3871                   Error_Pragma_Arg
3872                     ("pragma% cannot be applied on non-remote procedure",
3873                      Arg1);
3874                end if;
3875
3876                L := Parameter_Specifications (Parent (Nm));
3877                Process_Async_Pragma;
3878                return;
3879
3880             elsif Ekind (Nm) = E_Function then
3881                Error_Pragma_Arg
3882                  ("pragma% cannot be applied to function", Arg1);
3883
3884             elsif Ekind (Nm) = E_Record_Type
3885               and then Present (Corresponding_Remote_Type (Nm))
3886             then
3887                N := Declaration_Node (Corresponding_Remote_Type (Nm));
3888
3889                if Nkind (N) = N_Full_Type_Declaration
3890                  and then Nkind (Type_Definition (N)) =
3891                                      N_Access_Procedure_Definition
3892                then
3893                   L := Parameter_Specifications (Type_Definition (N));
3894                   Process_Async_Pragma;
3895
3896                else
3897                   Error_Pragma_Arg
3898                     ("pragma% cannot reference access-to-function type",
3899                     Arg1);
3900                end if;
3901
3902             --  Only other possibility is Access-to-class-wide type
3903
3904             elsif Is_Access_Type (Nm)
3905               and then Is_Class_Wide_Type (Designated_Type (Nm))
3906             then
3907                Check_First_Subtype (Arg1);
3908                Set_Is_Asynchronous (Nm);
3909                if Expander_Active then
3910                   RACW_Type_Is_Asynchronous (Nm);
3911                end if;
3912
3913             else
3914                Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
3915             end if;
3916
3917          end Asynchronous;
3918
3919          ------------
3920          -- Atomic --
3921          ------------
3922
3923          --  pragma Atomic (LOCAL_NAME);
3924
3925          when Pragma_Atomic =>
3926             Process_Atomic_Shared_Volatile;
3927
3928          -----------------------
3929          -- Atomic_Components --
3930          -----------------------
3931
3932          --  pragma Atomic_Components (array_LOCAL_NAME);
3933
3934          --  This processing is shared by Volatile_Components
3935
3936          when Pragma_Atomic_Components   |
3937               Pragma_Volatile_Components =>
3938
3939          Atomic_Components : declare
3940             E_Id : Node_Id;
3941             E    : Entity_Id;
3942             D    : Node_Id;
3943             K    : Node_Kind;
3944
3945          begin
3946             Check_Ada_83_Warning;
3947             Check_No_Identifiers;
3948             Check_Arg_Count (1);
3949             Check_Arg_Is_Local_Name (Arg1);
3950             E_Id := Expression (Arg1);
3951
3952             if Etype (E_Id) = Any_Type then
3953                return;
3954             end if;
3955
3956             E := Entity (E_Id);
3957
3958             if Rep_Item_Too_Early (E, N)
3959                  or else
3960                Rep_Item_Too_Late (E, N)
3961             then
3962                return;
3963             end if;
3964
3965             D := Declaration_Node (E);
3966             K := Nkind (D);
3967
3968             if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
3969               or else
3970                 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
3971                    and then Nkind (D) = N_Object_Declaration
3972                    and then Nkind (Object_Definition (D)) =
3973                                        N_Constrained_Array_Definition)
3974             then
3975                --  The flag is set on the object, or on the base type
3976
3977                if Nkind (D) /= N_Object_Declaration then
3978                   E := Base_Type (E);
3979                end if;
3980
3981                Set_Has_Volatile_Components (E);
3982
3983                if Prag_Id = Pragma_Atomic_Components then
3984                   Set_Has_Atomic_Components (E);
3985
3986                   if Is_Packed (E) then
3987                      Set_Is_Packed (E, False);
3988
3989                      Error_Pragma_Arg
3990                        ("?Pack canceled, cannot pack atomic components",
3991                         Arg1);
3992                   end if;
3993                end if;
3994
3995             else
3996                Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
3997             end if;
3998          end Atomic_Components;
3999
4000          --------------------
4001          -- Attach_Handler --
4002          --------------------
4003
4004          --  pragma Attach_Handler (handler_NAME, EXPRESSION);
4005
4006          when Pragma_Attach_Handler =>
4007             Check_Ada_83_Warning;
4008             Check_No_Identifiers;
4009             Check_Arg_Count (2);
4010             Check_Interrupt_Or_Attach_Handler;
4011             Analyze_And_Resolve (Expression (Arg2), RTE (RE_Interrupt_Id));
4012             Process_Interrupt_Or_Attach_Handler;
4013
4014          --------------------
4015          -- C_Pass_By_Copy --
4016          --------------------
4017
4018          --  pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
4019
4020          when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
4021             Arg : Node_Id;
4022             Val : Uint;
4023
4024          begin
4025             GNAT_Pragma;
4026             Check_Valid_Configuration_Pragma;
4027             Check_Arg_Count (1);
4028             Check_Optional_Identifier (Arg1, "max_size");
4029
4030             Arg := Expression (Arg1);
4031             Check_Arg_Is_Static_Expression (Arg, Any_Integer);
4032
4033             Val := Expr_Value (Arg);
4034
4035             if Val <= 0 then
4036                Error_Pragma_Arg
4037                  ("maximum size for pragma% must be positive", Arg1);
4038
4039             elsif UI_Is_In_Int_Range (Val) then
4040                Default_C_Record_Mechanism := UI_To_Int (Val);
4041
4042             --  If a giant value is given, Int'Last will do well enough.
4043             --  If sometime someone complains that a record larger than
4044             --  two gigabytes is not copied, we will worry about it then!
4045
4046             else
4047                Default_C_Record_Mechanism := Mechanism_Type'Last;
4048             end if;
4049          end C_Pass_By_Copy;
4050
4051          -------------
4052          -- Comment --
4053          -------------
4054
4055          --  pragma Comment (static_string_EXPRESSION)
4056
4057          --  Processing for pragma Comment shares the circuitry for
4058          --  pragma Ident. The only differences are that Ident enforces
4059          --  a limit of 31 characters on its argument, and also enforces
4060          --  limitations on placement for DEC compatibility. Pragma
4061          --  Comment shares neither of these restrictions.
4062
4063          -------------------
4064          -- Common_Object --
4065          -------------------
4066
4067          --  pragma Common_Object (
4068          --        [Internal =>] LOCAL_NAME,
4069          --     [, [External =>] EXTERNAL_SYMBOL]
4070          --     [, [Size     =>] EXTERNAL_SYMBOL]);
4071
4072          --  Processing for this pragma is shared with Psect_Object
4073
4074          ----------------------------
4075          -- Complex_Representation --
4076          ----------------------------
4077
4078          --  pragma Complex_Representation ([Entity =>] LOCAL_NAME);
4079
4080          when Pragma_Complex_Representation => Complex_Representation : declare
4081             E_Id : Entity_Id;
4082             E    : Entity_Id;
4083             Ent  : Entity_Id;
4084
4085          begin
4086             GNAT_Pragma;
4087             Check_Arg_Count (1);
4088             Check_Optional_Identifier (Arg1, Name_Entity);
4089             Check_Arg_Is_Local_Name (Arg1);
4090             E_Id := Expression (Arg1);
4091
4092             if Etype (E_Id) = Any_Type then
4093                return;
4094             end if;
4095
4096             E := Entity (E_Id);
4097
4098             if not Is_Record_Type (E) then
4099                Error_Pragma_Arg
4100                  ("argument for pragma% must be record type", Arg1);
4101             end if;
4102
4103             Ent := First_Entity (E);
4104
4105             if No (Ent)
4106               or else No (Next_Entity (Ent))
4107               or else Present (Next_Entity (Next_Entity (Ent)))
4108               or else not Is_Floating_Point_Type (Etype (Ent))
4109               or else Etype (Ent) /= Etype (Next_Entity (Ent))
4110             then
4111                Error_Pragma_Arg
4112                  ("record for pragma% must have two fields of same fpt type",
4113                   Arg1);
4114
4115             else
4116                Set_Has_Complex_Representation (Base_Type (E));
4117             end if;
4118          end Complex_Representation;
4119
4120          -------------------------
4121          -- Component_Alignment --
4122          -------------------------
4123
4124          --  pragma Component_Alignment (
4125          --        [Form =>] ALIGNMENT_CHOICE
4126          --     [, [Name =>] type_LOCAL_NAME]);
4127          --
4128          --   ALIGNMENT_CHOICE ::=
4129          --     Component_Size
4130          --   | Component_Size_4
4131          --   | Storage_Unit
4132          --   | Default
4133
4134          when Pragma_Component_Alignment => Component_AlignmentP : declare
4135             Args  : Args_List (1 .. 2);
4136             Names : Name_List (1 .. 2) := (
4137                       Name_Form,
4138                       Name_Name);
4139
4140             Form  : Node_Id renames Args (1);
4141             Name  : Node_Id renames Args (2);
4142
4143             Atype : Component_Alignment_Kind;
4144             Typ   : Entity_Id;
4145
4146          begin
4147             GNAT_Pragma;
4148             Gather_Associations (Names, Args);
4149
4150             if No (Form) then
4151                Error_Pragma ("missing Form argument for pragma%");
4152             end if;
4153
4154             Check_Arg_Is_Identifier (Form);
4155
4156             --  Get proper alignment, note that Default = Component_Size
4157             --  on all machines we have so far, and we want to set this
4158             --  value rather than the default value to indicate that it
4159             --  has been explicitly set (and thus will not get overridden
4160             --  by the default component alignment for the current scope)
4161
4162             if Chars (Form) = Name_Component_Size then
4163                Atype := Calign_Component_Size;
4164
4165             elsif Chars (Form) = Name_Component_Size_4 then
4166                Atype := Calign_Component_Size_4;
4167
4168             elsif Chars (Form) = Name_Default then
4169                Atype := Calign_Component_Size;
4170
4171             elsif Chars (Form) = Name_Storage_Unit then
4172                Atype := Calign_Storage_Unit;
4173
4174             else
4175                Error_Pragma_Arg
4176                  ("invalid Form parameter for pragma%", Form);
4177             end if;
4178
4179             --  Case with no name, supplied, affects scope table entry
4180
4181             if No (Name) then
4182                Scope_Stack.Table
4183                  (Scope_Stack.Last).Component_Alignment_Default := Atype;
4184
4185             --  Case of name supplied
4186
4187             else
4188                Check_Arg_Is_Local_Name (Name);
4189                Find_Type (Name);
4190                Typ := Entity (Name);
4191
4192                if Typ = Any_Type
4193                  or else Rep_Item_Too_Early (Typ, N)
4194                then
4195                   return;
4196                else
4197                   Typ := Underlying_Type (Typ);
4198                end if;
4199
4200                if not Is_Record_Type (Typ)
4201                  and then not Is_Array_Type (Typ)
4202                then
4203                   Error_Pragma_Arg
4204                     ("Name parameter of pragma% must identify record or " &
4205                      "array type", Name);
4206                end if;
4207
4208                --  An explicit Component_Alignment pragma overrides an
4209                --  implicit pragma Pack, but not an explicit one.
4210
4211                if not Has_Pragma_Pack (Base_Type (Typ)) then
4212                   Set_Is_Packed (Base_Type (Typ), False);
4213                   Set_Component_Alignment (Base_Type (Typ), Atype);
4214                end if;
4215             end if;
4216          end Component_AlignmentP;
4217
4218          ----------------
4219          -- Controlled --
4220          ----------------
4221
4222          --  pragma Controlled (first_subtype_LOCAL_NAME);
4223
4224          when Pragma_Controlled => Controlled : declare
4225             Arg : Node_Id;
4226
4227          begin
4228             Check_No_Identifiers;
4229             Check_Arg_Count (1);
4230             Check_Arg_Is_Local_Name (Arg1);
4231             Arg := Expression (Arg1);
4232
4233             if not Is_Entity_Name (Arg)
4234               or else not Is_Access_Type (Entity (Arg))
4235             then
4236                Error_Pragma_Arg ("pragma% requires access type", Arg1);
4237             else
4238                Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
4239             end if;
4240          end Controlled;
4241
4242          ----------------
4243          -- Convention --
4244          ----------------
4245
4246          --  pragma Convention ([Convention =>] convention_IDENTIFIER,
4247          --    [Entity =>] LOCAL_NAME);
4248
4249          when Pragma_Convention => Convention : declare
4250             C : Convention_Id;
4251             E : Entity_Id;
4252
4253          begin
4254             Check_Ada_83_Warning;
4255             Check_Arg_Count (2);
4256             Process_Convention (C, E);
4257          end Convention;
4258
4259          ---------------------------
4260          -- Convention_Identifier --
4261          ---------------------------
4262
4263          --  pragma Convention_Identifier ([Name =>] IDENTIFIER,
4264          --    [Convention =>] convention_IDENTIFIER);
4265
4266          when Pragma_Convention_Identifier => Convention_Identifier : declare
4267             Idnam : Name_Id;
4268             Cname : Name_Id;
4269
4270          begin
4271             GNAT_Pragma;
4272             Check_Arg_Count (2);
4273             Check_Optional_Identifier (Arg1, Name_Name);
4274             Check_Optional_Identifier (Arg2, Name_Convention);
4275             Check_Arg_Is_Identifier (Arg1);
4276             Check_Arg_Is_Identifier (Arg1);
4277             Idnam := Chars (Expression (Arg1));
4278             Cname := Chars (Expression (Arg2));
4279
4280             if Is_Convention_Name (Cname) then
4281                Record_Convention_Identifier
4282                  (Idnam, Get_Convention_Id (Cname));
4283             else
4284                Error_Pragma_Arg
4285                  ("second arg for % pragma must be convention", Arg2);
4286             end if;
4287          end Convention_Identifier;
4288
4289          ---------------
4290          -- CPP_Class --
4291          ---------------
4292
4293          --  pragma CPP_Class ([Entity =>] local_NAME)
4294
4295          when Pragma_CPP_Class => CPP_Class : declare
4296             Arg         : Node_Id;
4297             Typ         : Entity_Id;
4298             Default_DTC : Entity_Id := Empty;
4299             VTP_Type    : constant Entity_Id  := RTE (RE_Vtable_Ptr);
4300             C           : Entity_Id;
4301             Tag_C       : Entity_Id;
4302
4303          begin
4304             GNAT_Pragma;
4305             Check_Arg_Count (1);
4306             Check_Optional_Identifier (Arg1, Name_Entity);
4307             Check_Arg_Is_Local_Name (Arg1);
4308
4309             Arg := Expression (Arg1);
4310             Analyze (Arg);
4311
4312             if Etype (Arg) = Any_Type then
4313                return;
4314             end if;
4315
4316             if not Is_Entity_Name (Arg)
4317               or else not Is_Type (Entity (Arg))
4318             then
4319                Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
4320             end if;
4321
4322             Typ := Entity (Arg);
4323
4324             if not Is_Record_Type (Typ) then
4325                Error_Pragma_Arg ("pragma% applicable to a record, "
4326                  & "tagged record or record extension", Arg1);
4327             end if;
4328
4329             Default_DTC := First_Component (Typ);
4330             while Present (Default_DTC)
4331               and then Etype (Default_DTC) /= VTP_Type
4332             loop
4333                Next_Component (Default_DTC);
4334             end loop;
4335
4336             --  Case of non tagged type
4337
4338             if not Is_Tagged_Type (Typ) then
4339                Set_Is_CPP_Class (Typ);
4340
4341                if Present (Default_DTC) then
4342                   Error_Pragma_Arg
4343                     ("only tagged records can contain vtable pointers", Arg1);
4344                end if;
4345
4346             --  Case of tagged type with no vtable ptr
4347
4348             --  What is test for Typ = Root_Typ (Typ) about here ???
4349
4350             elsif Is_Tagged_Type (Typ)
4351               and then Typ = Root_Type (Typ)
4352               and then No (Default_DTC)
4353             then
4354                Error_Pragma_Arg
4355                  ("a cpp_class must contain a vtable pointer", Arg1);
4356
4357             --  Tagged type that has a vtable ptr
4358
4359             elsif Present (Default_DTC) then
4360                Set_Is_CPP_Class (Typ);
4361                Set_Is_Limited_Record (Typ);
4362                Set_Is_Tag (Default_DTC);
4363                Set_DT_Entry_Count (Default_DTC, No_Uint);
4364
4365                --  Since a CPP type has no direct link to its associated tag
4366                --  most tags checks cannot be performed
4367
4368                Set_Suppress_Tag_Checks (Typ);
4369                Set_Suppress_Tag_Checks (Class_Wide_Type (Typ));
4370
4371                --  Get rid of the _tag component when there was one.
4372                --  It is only useful for regular tagged types
4373
4374                if Expander_Active and then Typ = Root_Type (Typ) then
4375
4376                   Tag_C := Tag_Component (Typ);
4377                   C := First_Entity (Typ);
4378
4379                   if C = Tag_C then
4380                      Set_First_Entity (Typ, Next_Entity (Tag_C));
4381
4382                   else
4383                      while Next_Entity (C) /= Tag_C loop
4384                         Next_Entity (C);
4385                      end loop;
4386
4387                      Set_Next_Entity (C, Next_Entity (Tag_C));
4388                   end if;
4389                end if;
4390             end if;
4391          end CPP_Class;
4392
4393          ---------------------
4394          -- CPP_Constructor --
4395          ---------------------
4396
4397          --  pragma CPP_Constructor ([Entity =>] LOCAL_NAME);
4398
4399          when Pragma_CPP_Constructor => CPP_Constructor : declare
4400             Id     : Entity_Id;
4401             Def_Id : Entity_Id;
4402
4403          begin
4404             GNAT_Pragma;
4405             Check_Arg_Count (1);
4406             Check_Optional_Identifier (Arg1, Name_Entity);
4407             Check_Arg_Is_Local_Name (Arg1);
4408
4409             Id := Expression (Arg1);
4410             Find_Program_Unit_Name (Id);
4411
4412             --  If we did not find the name, we are done
4413
4414             if Etype (Id) = Any_Type then
4415                return;
4416             end if;
4417
4418             Def_Id := Entity (Id);
4419
4420             if Ekind (Def_Id) = E_Function
4421               and then Is_Class_Wide_Type (Etype (Def_Id))
4422               and then Is_CPP_Class (Etype (Etype (Def_Id)))
4423             then
4424                --  What the heck is this??? this pragma allows only 1 arg
4425
4426                if Arg_Count >= 2 then
4427                   Check_At_Most_N_Arguments (3);
4428                   Process_Interface_Name (Def_Id, Arg2, Arg3);
4429                end if;
4430
4431                if No (Parameter_Specifications (Parent (Def_Id))) then
4432                   Set_Has_Completion (Def_Id);
4433                   Set_Is_Constructor (Def_Id);
4434                else
4435                   Error_Pragma_Arg
4436                     ("non-default constructors not implemented", Arg1);
4437                end if;
4438
4439             else
4440                Error_Pragma_Arg
4441                  ("pragma% requires function returning a 'C'P'P_Class type",
4442                    Arg1);
4443             end if;
4444          end CPP_Constructor;
4445
4446          -----------------
4447          -- CPP_Virtual --
4448          -----------------
4449
4450          --  pragma CPP_Virtual
4451          --      [Entity =>]       LOCAL_NAME
4452          --    [ [Vtable_Ptr =>]   LOCAL_NAME,
4453          --      [Position =>]     static_integer_EXPRESSION]);
4454
4455          when Pragma_CPP_Virtual => CPP_Virtual : declare
4456             Arg      : Node_Id;
4457             Typ      : Entity_Id;
4458             Subp     : Entity_Id;
4459             VTP_Type : constant Entity_Id  := RTE (RE_Vtable_Ptr);
4460             DTC      : Entity_Id;
4461             V        : Uint;
4462
4463          begin
4464             GNAT_Pragma;
4465
4466             if Arg_Count = 3 then
4467                Check_Optional_Identifier (Arg2, "vtable_ptr");
4468
4469                --  We allow Entry_Count as well as Position for the third
4470                --  parameter for back compatibility with versions of GNAT
4471                --  before version 3.12. The documentation has always said
4472                --  Position, but the code up to 3.12 said Entry_Count.
4473
4474                if Chars (Arg3) /= Name_Position then
4475                   Check_Optional_Identifier (Arg3, "entry_count");
4476                end if;
4477
4478             else
4479                Check_Arg_Count (1);
4480             end if;
4481
4482             Check_Optional_Identifier (Arg1, Name_Entity);
4483             Check_Arg_Is_Local_Name (Arg1);
4484
4485             --  First argument must be a subprogram name
4486
4487             Arg := Expression (Arg1);
4488             Find_Program_Unit_Name (Arg);
4489
4490             if Etype (Arg) = Any_Type then
4491                return;
4492             else
4493                Subp := Entity (Arg);
4494             end if;
4495
4496             if not (Is_Subprogram (Subp)
4497                      and then Is_Dispatching_Operation (Subp))
4498             then
4499                Error_Pragma_Arg
4500                  ("pragma% must reference a primitive operation", Arg1);
4501             end if;
4502
4503             Typ := Find_Dispatching_Type (Subp);
4504
4505             --  If only one Argument defaults are :
4506             --    . DTC_Entity is the default Vtable pointer
4507             --    . DT_Position will be set at the freezing point
4508
4509             if Arg_Count = 1 then
4510                Set_DTC_Entity (Subp, Tag_Component (Typ));
4511                return;
4512             end if;
4513
4514             --  Second argument is a component name of type Vtable_Ptr
4515
4516             Arg := Expression (Arg2);
4517
4518             if Nkind (Arg) /= N_Identifier then
4519                Error_Msg_NE ("must be a& component name", Arg, Typ);
4520                raise Pragma_Exit;
4521             end if;
4522
4523             DTC := First_Component (Typ);
4524             while Present (DTC) and then Chars (DTC) /= Chars (Arg) loop
4525                Next_Component (DTC);
4526             end loop;
4527
4528             if No (DTC) then
4529                Error_Msg_NE ("must be a& component name", Arg, Typ);
4530                raise Pragma_Exit;
4531
4532             elsif Etype (DTC) /= VTP_Type then
4533                Wrong_Type (Arg, VTP_Type);
4534                return;
4535             end if;
4536
4537             --  Third argument is an integer (DT_Position)
4538
4539             Arg := Expression (Arg3);
4540             Analyze_And_Resolve (Arg, Any_Integer);
4541
4542             if not Is_Static_Expression (Arg) then
4543                Error_Pragma_Arg
4544                  ("third argument of pragma% must be a static expression",
4545                   Arg3);
4546
4547             else
4548                V := Expr_Value (Expression (Arg3));
4549
4550                if V <= 0 then
4551                   Error_Pragma_Arg
4552                     ("third argument of pragma% must be positive",
4553                      Arg3);
4554
4555                else
4556                   Set_DTC_Entity (Subp, DTC);
4557                   Set_DT_Position (Subp, V);
4558                end if;
4559             end if;
4560          end CPP_Virtual;
4561
4562          ----------------
4563          -- CPP_Vtable --
4564          ----------------
4565
4566          --  pragma CPP_Vtable (
4567          --    [Entity =>]       LOCAL_NAME
4568          --    [Vtable_Ptr =>]   LOCAL_NAME,
4569          --    [Entry_Count =>]  static_integer_EXPRESSION);
4570
4571          when Pragma_CPP_Vtable => CPP_Vtable : declare
4572             Arg      : Node_Id;
4573             Typ      : Entity_Id;
4574             VTP_Type : constant Entity_Id  := RTE (RE_Vtable_Ptr);
4575             DTC      : Entity_Id;
4576             V        : Uint;
4577             Elmt     : Elmt_Id;
4578
4579          begin
4580             GNAT_Pragma;
4581             Check_Arg_Count (3);
4582             Check_Optional_Identifier (Arg1, Name_Entity);
4583             Check_Optional_Identifier (Arg2, "vtable_ptr");
4584             Check_Optional_Identifier (Arg3, "entry_count");
4585             Check_Arg_Is_Local_Name (Arg1);
4586
4587             --  First argument is a record type name
4588
4589             Arg := Expression (Arg1);
4590             Analyze (Arg);
4591
4592             if Etype (Arg) = Any_Type then
4593                return;
4594             else
4595                Typ := Entity (Arg);
4596             end if;
4597
4598             if not (Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ)) then
4599                Error_Pragma_Arg ("'C'P'P_Class tagged type expected", Arg1);
4600             end if;
4601
4602             --  Second argument is a component name of type Vtable_Ptr
4603
4604             Arg := Expression (Arg2);
4605
4606             if Nkind (Arg) /= N_Identifier then
4607                Error_Msg_NE ("must be a& component name", Arg, Typ);
4608                raise Pragma_Exit;
4609             end if;
4610
4611             DTC := First_Component (Typ);
4612             while Present (DTC) and then Chars (DTC) /= Chars (Arg) loop
4613                Next_Component (DTC);
4614             end loop;
4615
4616             if No (DTC) then
4617                Error_Msg_NE ("must be a& component name", Arg, Typ);
4618                raise Pragma_Exit;
4619
4620             elsif Etype (DTC) /= VTP_Type then
4621                Wrong_Type (DTC, VTP_Type);
4622                return;
4623
4624             --  If it is the first pragma Vtable, This becomes the default tag
4625
4626             elsif (not Is_Tag (DTC))
4627               and then DT_Entry_Count (Tag_Component (Typ)) = No_Uint
4628             then
4629                Set_Is_Tag (Tag_Component (Typ), False);
4630                Set_Is_Tag (DTC, True);
4631                Set_DT_Entry_Count (DTC, No_Uint);
4632             end if;
4633
4634             --  Those pragmas must appear before any primitive operation
4635             --  definition (except inherited ones) otherwise the default
4636             --  may be wrong
4637
4638             Elmt := First_Elmt (Primitive_Operations (Typ));
4639             while Present (Elmt) loop
4640                if No (Alias (Node (Elmt))) then
4641                   Error_Msg_Sloc := Sloc (Node (Elmt));
4642                   Error_Pragma
4643                     ("pragma% must appear before this primitive operation");
4644                end if;
4645
4646                Next_Elmt (Elmt);
4647             end loop;
4648
4649             --  Third argument is an integer (DT_Entry_Count)
4650
4651             Arg := Expression (Arg3);
4652             Analyze_And_Resolve (Arg, Any_Integer);
4653
4654             if not Is_Static_Expression (Arg) then
4655                Error_Pragma_Arg
4656                  ("entry count for pragma% must be a static expression", Arg3);
4657
4658             else
4659                V := Expr_Value (Expression (Arg3));
4660
4661                if V <= 0 then
4662                   Error_Pragma_Arg
4663                     ("entry count for pragma% must be positive", Arg3);
4664                else
4665                   Set_DT_Entry_Count (DTC, V);
4666                end if;
4667             end if;
4668
4669          end CPP_Vtable;
4670
4671          -----------
4672          -- Debug --
4673          -----------
4674
4675          --  pragma Debug (PROCEDURE_CALL_STATEMENT);
4676
4677          when Pragma_Debug => Debug : begin
4678             GNAT_Pragma;
4679
4680             --  If assertions are enabled, and we are expanding code, then
4681             --  we rewrite the pragma with its corresponding procedure call
4682             --  and then analyze the call.
4683
4684             if Assertions_Enabled and Expander_Active then
4685                Rewrite (N, Relocate_Node (Debug_Statement (N)));
4686                Analyze (N);
4687
4688             --  Otherwise we work a bit to get a tree that makes sense
4689             --  for ASIS purposes, namely a pragma with an analyzed
4690             --  argument that looks like a procedure call.
4691
4692             else
4693                Expander_Mode_Save_And_Set (False);
4694                Rewrite (N, Relocate_Node (Debug_Statement (N)));
4695                Analyze (N);
4696                Rewrite (N,
4697                  Make_Pragma (Loc,
4698                    Chars => Name_Debug,
4699                    Pragma_Argument_Associations =>
4700                      New_List (Relocate_Node (N))));
4701                Expander_Mode_Restore;
4702             end if;
4703          end Debug;
4704
4705          -------------------
4706          -- Discard_Names --
4707          -------------------
4708
4709          --  pragma Discard_Names [([On =>] LOCAL_NAME)];
4710
4711          when Pragma_Discard_Names => Discard_Names : declare
4712             E_Id : Entity_Id;
4713             E    : Entity_Id;
4714
4715          begin
4716             Check_Ada_83_Warning;
4717
4718             --  Deal with configuration pragma case
4719
4720             if Arg_Count = 0 and then Is_Configuration_Pragma then
4721                Global_Discard_Names := True;
4722                return;
4723
4724             --  Otherwise, check correct appropriate context
4725
4726             else
4727                Check_Is_In_Decl_Part_Or_Package_Spec;
4728
4729                if Arg_Count = 0 then
4730
4731                   --  If there is no parameter, then from now on this pragma
4732                   --  applies to any enumeration, exception or tagged type
4733                   --  defined in the current declarative part.
4734
4735                   Set_Discard_Names (Current_Scope);
4736                   return;
4737
4738                else
4739                   Check_Arg_Count (1);
4740                   Check_Optional_Identifier (Arg1, Name_On);
4741                   Check_Arg_Is_Local_Name (Arg1);
4742                   E_Id := Expression (Arg1);
4743
4744                   if Etype (E_Id) = Any_Type then
4745                      return;
4746                   else
4747                      E := Entity (E_Id);
4748                   end if;
4749
4750                   if (Is_First_Subtype (E)
4751                        and then (Is_Enumeration_Type (E)
4752                                   or else Is_Tagged_Type (E)))
4753                     or else Ekind (E) = E_Exception
4754                   then
4755                      Set_Discard_Names (E);
4756                   else
4757                      Error_Pragma_Arg
4758                        ("inappropriate entity for pragma%", Arg1);
4759                   end if;
4760                end if;
4761             end if;
4762          end Discard_Names;
4763
4764          ---------------
4765          -- Elaborate --
4766          ---------------
4767
4768          --  pragma Elaborate (library_unit_NAME {, library_unit_NAME});
4769
4770          when Pragma_Elaborate => Elaborate : declare
4771             Plist       : List_Id;
4772             Parent_Node : Node_Id;
4773             Arg         : Node_Id;
4774             Citem       : Node_Id;
4775
4776          begin
4777             --  Pragma must be in context items list of a compilation unit
4778
4779             if not Is_List_Member (N) then
4780                Pragma_Misplaced;
4781                return;
4782
4783             else
4784                Plist := List_Containing (N);
4785                Parent_Node := Parent (Plist);
4786
4787                if Parent_Node = Empty
4788                  or else Nkind (Parent_Node) /= N_Compilation_Unit
4789                  or else Context_Items (Parent_Node) /= Plist
4790                then
4791                   Pragma_Misplaced;
4792                   return;
4793                end if;
4794             end if;
4795
4796             --  Must be at least one argument
4797
4798             if Arg_Count = 0 then
4799                Error_Pragma ("pragma% requires at least one argument");
4800             end if;
4801
4802             --  In Ada 83 mode, there can be no items following it in the
4803             --  context list except other pragmas and implicit with clauses
4804             --  (e.g. those added by use of Rtsfind). In Ada 95 mode, this
4805             --  placement rule does not apply.
4806
4807             if Ada_83 and then Comes_From_Source (N) then
4808                Citem := Next (N);
4809
4810                while Present (Citem) loop
4811                   if Nkind (Citem) = N_Pragma
4812                     or else (Nkind (Citem) = N_With_Clause
4813                               and then Implicit_With (Citem))
4814                   then
4815                      null;
4816                   else
4817                      Error_Pragma
4818                        ("(Ada 83) pragma% must be at end of context clause");
4819                   end if;
4820
4821                   Next (Citem);
4822                end loop;
4823             end if;
4824
4825             --  Finally, the arguments must all be units mentioned in a with
4826             --  clause in the same context clause. Note we already checked
4827             --  (in Par.Prag) that the arguments are either identifiers or
4828
4829             Arg := Arg1;
4830             Outer : while Present (Arg) loop
4831                Citem := First (Plist);
4832
4833                Inner : while Citem /= N loop
4834                   if Nkind (Citem) = N_With_Clause
4835                     and then Same_Name (Name (Citem), Expression (Arg))
4836                   then
4837                      Set_Elaborate_Present (Citem, True);
4838                      Set_Unit_Name (Expression (Arg), Name (Citem));
4839                      Set_Suppress_Elaboration_Warnings (Entity (Name (Citem)));
4840                      exit Inner;
4841                   end if;
4842
4843                   Next (Citem);
4844                end loop Inner;
4845
4846                if Citem = N then
4847                   Error_Pragma_Arg
4848                     ("argument of pragma% is not with'ed unit", Arg);
4849                end if;
4850
4851                Next (Arg);
4852             end loop Outer;
4853          end Elaborate;
4854
4855          -------------------
4856          -- Elaborate_All --
4857          -------------------
4858
4859          --  pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
4860
4861          when Pragma_Elaborate_All => Elaborate_All : declare
4862             Plist       : List_Id;
4863             Parent_Node : Node_Id;
4864             Arg         : Node_Id;
4865             Citem       : Node_Id;
4866
4867          begin
4868             Check_Ada_83_Warning;
4869
4870             --  Pragma must be in context items list of a compilation unit
4871
4872             if not Is_List_Member (N) then
4873                Pragma_Misplaced;
4874                return;
4875
4876             else
4877                Plist := List_Containing (N);
4878                Parent_Node := Parent (Plist);
4879
4880                if Parent_Node = Empty
4881                  or else Nkind (Parent_Node) /= N_Compilation_Unit
4882                  or else Context_Items (Parent_Node) /= Plist
4883                then
4884                   Pragma_Misplaced;
4885                   return;
4886                end if;
4887             end if;
4888
4889             --  Must be at least one argument
4890
4891             if Arg_Count = 0 then
4892                Error_Pragma ("pragma% requires at least one argument");
4893             end if;
4894
4895             --  Note: unlike pragma Elaborate, pragma Elaborate_All does not
4896             --  have to appear at the end of the context clause, but may
4897             --  appear mixed in with other items, even in Ada 83 mode.
4898
4899             --  Final check: the arguments must all be units mentioned in
4900             --  a with clause in the same context clause. Note that we
4901             --  already checked (in Par.Prag) that all the arguments are
4902             --  either identifiers or selected components.
4903
4904             Arg := Arg1;
4905             Outr : while Present (Arg) loop
4906                Citem := First (Plist);
4907
4908                Innr : while Citem /= N loop
4909                   if Nkind (Citem) = N_With_Clause
4910                     and then Same_Name (Name (Citem), Expression (Arg))
4911                   then
4912                      Set_Elaborate_All_Present (Citem, True);
4913                      Set_Unit_Name (Expression (Arg), Name (Citem));
4914                      Set_Suppress_Elaboration_Warnings (Entity (Name (Citem)));
4915                      exit Innr;
4916                   end if;
4917
4918                   Next (Citem);
4919                end loop Innr;
4920
4921                if Citem = N then
4922                   Error_Pragma_Arg
4923                     ("argument of pragma% is not with'ed unit", Arg);
4924                end if;
4925
4926                Next (Arg);
4927             end loop Outr;
4928          end Elaborate_All;
4929
4930          --------------------
4931          -- Elaborate_Body --
4932          --------------------
4933
4934          --  pragma Elaborate_Body [( library_unit_NAME )];
4935
4936          when Pragma_Elaborate_Body => Elaborate_Body : declare
4937             Cunit_Node : Node_Id;
4938             Cunit_Ent  : Entity_Id;
4939
4940          begin
4941             Check_Ada_83_Warning;
4942             Check_Valid_Library_Unit_Pragma;
4943
4944             if Nkind (N) = N_Null_Statement then
4945                return;
4946             end if;
4947
4948             Cunit_Node := Cunit (Current_Sem_Unit);
4949             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
4950
4951             if Nkind (Unit (Cunit_Node)) = N_Package_Body
4952                  or else
4953                Nkind (Unit (Cunit_Node)) = N_Subprogram_Body
4954             then
4955                Error_Pragma ("pragma% must refer to a spec, not a body");
4956             else
4957                Set_Body_Required (Cunit_Node, True);
4958                Set_Has_Pragma_Elaborate_Body     (Cunit_Ent);
4959
4960                --  If we are in dynamic elaboration mode, then we suppress
4961                --  elaboration warnings for the unit, since it is definitely
4962                --  fine NOT to do dynamic checks at the first level (and such
4963                --  checks will be suppressed because no elaboration boolean
4964                --  is created for Elaborate_Body packages).
4965
4966                --  But in the static model of elaboration, Elaborate_Body is
4967                --  definitely NOT good enough to ensure elaboration safety on
4968                --  its own, since the body may WITH other units that are not
4969                --  safe from an elaboration point of view, so a client must
4970                --  still do an Elaborate_All on such units.
4971
4972                --  Debug flag -gnatdD restores the old behavior of 3.13,
4973                --  where Elaborate_Body always suppressed elab warnings.
4974
4975                if Dynamic_Elaboration_Checks or Debug_Flag_DD then
4976                   Set_Suppress_Elaboration_Warnings (Cunit_Ent);
4977                end if;
4978             end if;
4979          end Elaborate_Body;
4980
4981          ------------------------
4982          -- Elaboration_Checks --
4983          ------------------------
4984
4985          --  pragma Elaboration_Checks (Static | Dynamic);
4986
4987          when Pragma_Elaboration_Checks =>
4988             GNAT_Pragma;
4989             Check_Arg_Count (1);
4990             Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
4991             Dynamic_Elaboration_Checks :=
4992               (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
4993
4994          ---------------
4995          -- Eliminate --
4996          ---------------
4997
4998          --  pragma Eliminate (
4999          --      [Unit_Name       =>]  IDENTIFIER |
5000          --                            SELECTED_COMPONENT
5001          --    [,[Entity          =>]  IDENTIFIER |
5002          --                            SELECTED_COMPONENT |
5003          --                            STRING_LITERAL]
5004          --    [,[Parameter_Types =>]  PARAMETER_TYPES]
5005          --    [,[Result_Type     =>]  result_SUBTYPE_NAME]
5006          --    [,[Homonym_Number  =>]  INTEGER_LITERAL]);
5007
5008          --  PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
5009          --  SUBTYPE_NAME    ::= STRING_LITERAL
5010
5011          when Pragma_Eliminate => Eliminate : declare
5012             Args  : Args_List (1 .. 5);
5013             Names : Name_List (1 .. 5) := (
5014                       Name_Unit_Name,
5015                       Name_Entity,
5016                       Name_Parameter_Types,
5017                       Name_Result_Type,
5018                       Name_Homonym_Number);
5019
5020             Unit_Name       : Node_Id renames Args (1);
5021             Entity          : Node_Id renames Args (2);
5022             Parameter_Types : Node_Id renames Args (3);
5023             Result_Type     : Node_Id renames Args (4);
5024             Homonym_Number  : Node_Id renames Args (5);
5025
5026          begin
5027             GNAT_Pragma;
5028             Check_Valid_Configuration_Pragma;
5029             Gather_Associations (Names, Args);
5030
5031             if No (Unit_Name) then
5032                Error_Pragma ("missing Unit_Name argument for pragma%");
5033             end if;
5034
5035             if No (Entity)
5036               and then (Present (Parameter_Types)
5037                           or else
5038                         Present (Result_Type)
5039                           or else
5040                         Present (Homonym_Number))
5041             then
5042                Error_Pragma ("missing Entity argument for pragma%");
5043             end if;
5044
5045             Process_Eliminate_Pragma
5046               (Unit_Name,
5047                Entity,
5048                Parameter_Types,
5049                Result_Type,
5050                Homonym_Number);
5051          end Eliminate;
5052
5053          ------------
5054          -- Export --
5055          ------------
5056
5057          --  pragma Export (
5058          --    [   Convention    =>] convention_IDENTIFIER,
5059          --    [   Entity        =>] local_NAME
5060          --    [, [External_Name =>] static_string_EXPRESSION ]
5061          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
5062
5063          when Pragma_Export => Export : declare
5064             C      : Convention_Id;
5065             Def_Id : Entity_Id;
5066
5067          begin
5068             Check_Ada_83_Warning;
5069             Check_At_Least_N_Arguments (2);
5070             Check_At_Most_N_Arguments  (4);
5071             Process_Convention (C, Def_Id);
5072
5073             if Ekind (Def_Id) /= E_Constant then
5074                Note_Possible_Modification (Expression (Arg2));
5075             end if;
5076
5077             Process_Interface_Name (Def_Id, Arg3, Arg4);
5078             Set_Exported (Def_Id, Arg2);
5079          end Export;
5080
5081          ----------------------
5082          -- Export_Exception --
5083          ----------------------
5084
5085          --  pragma Export_Exception (
5086          --        [Internal         =>] LOCAL_NAME,
5087          --     [, [External         =>] EXTERNAL_SYMBOL,]
5088          --     [, [Form     =>] Ada | VMS]
5089          --     [, [Code     =>] static_integer_EXPRESSION]);
5090
5091          when Pragma_Export_Exception => Export_Exception : declare
5092             Args  : Args_List (1 .. 4);
5093             Names : Name_List (1 .. 4) := (
5094                       Name_Internal,
5095                       Name_External,
5096                       Name_Form,
5097                       Name_Code);
5098
5099             Internal : Node_Id renames Args (1);
5100             External : Node_Id renames Args (2);
5101             Form     : Node_Id renames Args (3);
5102             Code     : Node_Id renames Args (4);
5103
5104          begin
5105             if Inside_A_Generic then
5106                Error_Pragma ("pragma% cannot be used for generic entities");
5107             end if;
5108
5109             Gather_Associations (Names, Args);
5110             Process_Extended_Import_Export_Exception_Pragma (
5111               Arg_Internal => Internal,
5112               Arg_External => External,
5113               Arg_Form     => Form,
5114               Arg_Code     => Code);
5115
5116             if not Is_VMS_Exception (Entity (Internal)) then
5117                Set_Exported (Entity (Internal), Internal);
5118             end if;
5119
5120          end Export_Exception;
5121
5122          ---------------------
5123          -- Export_Function --
5124          ---------------------
5125
5126          --  pragma Export_Function (
5127          --        [Internal         =>] LOCAL_NAME,
5128          --     [, [External         =>] EXTERNAL_SYMBOL,]
5129          --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
5130          --     [, [Result_Type      =>] SUBTYPE_MARK]
5131          --     [, [Mechanism        =>] MECHANISM]
5132          --     [, [Result_Mechanism =>] MECHANISM_NAME]);
5133
5134          when Pragma_Export_Function => Export_Function : declare
5135             Args  : Args_List (1 .. 6);
5136             Names : Name_List (1 .. 6) := (
5137                       Name_Internal,
5138                       Name_External,
5139                       Name_Parameter_Types,
5140                       Name_Result_Type,
5141                       Name_Mechanism,
5142                       Name_Result_Mechanism);
5143
5144             Internal         : Node_Id renames Args (1);
5145             External         : Node_Id renames Args (2);
5146             Parameter_Types  : Node_Id renames Args (3);
5147             Result_Type      : Node_Id renames Args (4);
5148             Mechanism        : Node_Id renames Args (5);
5149             Result_Mechanism : Node_Id renames Args (6);
5150
5151          begin
5152             GNAT_Pragma;
5153             Gather_Associations (Names, Args);
5154             Process_Extended_Import_Export_Subprogram_Pragma (
5155               Arg_Internal         => Internal,
5156               Arg_External         => External,
5157               Arg_Parameter_Types  => Parameter_Types,
5158               Arg_Result_Type      => Result_Type,
5159               Arg_Mechanism        => Mechanism,
5160               Arg_Result_Mechanism => Result_Mechanism);
5161          end Export_Function;
5162
5163          -------------------
5164          -- Export_Object --
5165          -------------------
5166
5167          --  pragma Export_Object (
5168          --        [Internal =>] LOCAL_NAME,
5169          --     [, [External =>] EXTERNAL_SYMBOL]
5170          --     [, [Size     =>] EXTERNAL_SYMBOL]);
5171
5172          when Pragma_Export_Object => Export_Object : declare
5173             Args  : Args_List (1 .. 3);
5174             Names : Name_List (1 .. 3) := (
5175                       Name_Internal,
5176                       Name_External,
5177                       Name_Size);
5178
5179             Internal : Node_Id renames Args (1);
5180             External : Node_Id renames Args (2);
5181             Size     : Node_Id renames Args (3);
5182
5183          begin
5184             GNAT_Pragma;
5185             Gather_Associations (Names, Args);
5186             Process_Extended_Import_Export_Object_Pragma (
5187               Arg_Internal => Internal,
5188               Arg_External => External,
5189               Arg_Size     => Size);
5190          end Export_Object;
5191
5192          ----------------------
5193          -- Export_Procedure --
5194          ----------------------
5195
5196          --  pragma Export_Procedure (
5197          --        [Internal         =>] LOCAL_NAME,
5198          --     [, [External         =>] EXTERNAL_SYMBOL,]
5199          --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
5200          --     [, [Mechanism        =>] MECHANISM]);
5201
5202          when Pragma_Export_Procedure => Export_Procedure : declare
5203             Args  : Args_List (1 .. 4);
5204             Names : Name_List (1 .. 4) := (
5205                       Name_Internal,
5206                       Name_External,
5207                       Name_Parameter_Types,
5208                       Name_Mechanism);
5209
5210             Internal        : Node_Id renames Args (1);
5211             External        : Node_Id renames Args (2);
5212             Parameter_Types : Node_Id renames Args (3);
5213             Mechanism       : Node_Id renames Args (4);
5214
5215          begin
5216             GNAT_Pragma;
5217             Gather_Associations (Names, Args);
5218             Process_Extended_Import_Export_Subprogram_Pragma (
5219               Arg_Internal        => Internal,
5220               Arg_External        => External,
5221               Arg_Parameter_Types => Parameter_Types,
5222               Arg_Mechanism       => Mechanism);
5223          end Export_Procedure;
5224
5225          -----------------------------
5226          -- Export_Valued_Procedure --
5227          -----------------------------
5228
5229          --  pragma Export_Valued_Procedure (
5230          --        [Internal         =>] LOCAL_NAME,
5231          --     [, [External         =>] EXTERNAL_SYMBOL,]
5232          --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
5233          --     [, [Mechanism        =>] MECHANISM]);
5234
5235          when Pragma_Export_Valued_Procedure =>
5236          Export_Valued_Procedure : declare
5237             Args  : Args_List (1 .. 4);
5238             Names : Name_List (1 .. 4) := (
5239                       Name_Internal,
5240                       Name_External,
5241                       Name_Parameter_Types,
5242                       Name_Mechanism);
5243
5244             Internal        : Node_Id renames Args (1);
5245             External        : Node_Id renames Args (2);
5246             Parameter_Types : Node_Id renames Args (3);
5247             Mechanism       : Node_Id renames Args (4);
5248
5249          begin
5250             GNAT_Pragma;
5251             Gather_Associations (Names, Args);
5252             Process_Extended_Import_Export_Subprogram_Pragma (
5253               Arg_Internal        => Internal,
5254               Arg_External        => External,
5255               Arg_Parameter_Types => Parameter_Types,
5256               Arg_Mechanism       => Mechanism);
5257          end Export_Valued_Procedure;
5258
5259          -------------------
5260          -- Extend_System --
5261          -------------------
5262
5263          --  pragma Extend_System ([Name =>] Identifier);
5264
5265          when Pragma_Extend_System => Extend_System : declare
5266          begin
5267             GNAT_Pragma;
5268             Check_Valid_Configuration_Pragma;
5269             Check_Arg_Count (1);
5270             Check_Optional_Identifier (Arg1, Name_Name);
5271             Check_Arg_Is_Identifier (Arg1);
5272
5273             Get_Name_String (Chars (Expression (Arg1)));
5274
5275             if Name_Len > 4
5276               and then Name_Buffer (1 .. 4) = "aux_"
5277             then
5278                if Present (System_Extend_Pragma_Arg) then
5279                   if Chars (Expression (Arg1)) =
5280                      Chars (Expression (System_Extend_Pragma_Arg))
5281                   then
5282                      null;
5283                   else
5284                      Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
5285                      Error_Pragma ("pragma% conflicts with that at#");
5286                   end if;
5287
5288                else
5289                   System_Extend_Pragma_Arg := Arg1;
5290                end if;
5291             else
5292                Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
5293             end if;
5294          end Extend_System;
5295
5296          ------------------------
5297          -- Extensions_Allowed --
5298          ------------------------
5299
5300          --  pragma Extensions_Allowed (ON | OFF);
5301
5302          when Pragma_Extensions_Allowed =>
5303             GNAT_Pragma;
5304             Check_Arg_Count (1);
5305             Check_No_Identifiers;
5306             Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
5307             Extensions_Allowed := (Chars (Expression (Arg1)) = Name_On);
5308
5309          --------------
5310          -- External --
5311          --------------
5312
5313          --  pragma External (
5314          --    [   Convention    =>] convention_IDENTIFIER,
5315          --    [   Entity        =>] local_NAME
5316          --    [, [External_Name =>] static_string_EXPRESSION ]
5317          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
5318
5319          when Pragma_External => External : declare
5320             C      : Convention_Id;
5321             Def_Id : Entity_Id;
5322
5323          begin
5324             GNAT_Pragma;
5325             Check_At_Least_N_Arguments (2);
5326             Check_At_Most_N_Arguments  (4);
5327             Process_Convention (C, Def_Id);
5328             Note_Possible_Modification (Expression (Arg2));
5329             Process_Interface_Name (Def_Id, Arg3, Arg4);
5330             Set_Exported (Def_Id, Arg2);
5331          end External;
5332
5333          --------------------------
5334          -- External_Name_Casing --
5335          --------------------------
5336
5337          --  pragma External_Name_Casing (
5338          --    UPPERCASE | LOWERCASE
5339          --    [, AS_IS | UPPERCASE | LOWERCASE]);
5340
5341          when Pragma_External_Name_Casing =>
5342
5343          External_Name_Casing : declare
5344          begin
5345             GNAT_Pragma;
5346             Check_No_Identifiers;
5347
5348             if Arg_Count = 2 then
5349                Check_Arg_Is_One_Of
5350                  (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
5351
5352                case Chars (Get_Pragma_Arg (Arg2)) is
5353                   when Name_As_Is     =>
5354                      Opt.External_Name_Exp_Casing := As_Is;
5355
5356                   when Name_Uppercase =>
5357                      Opt.External_Name_Exp_Casing := Uppercase;
5358
5359                   when Name_Lowercase =>
5360                      Opt.External_Name_Exp_Casing := Lowercase;
5361
5362                   when others =>
5363                      null;
5364                end case;
5365
5366             else
5367                Check_Arg_Count (1);
5368             end if;
5369
5370             Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
5371
5372             case Chars (Get_Pragma_Arg (Arg1)) is
5373                when Name_Uppercase =>
5374                   Opt.External_Name_Imp_Casing := Uppercase;
5375
5376                when Name_Lowercase =>
5377                   Opt.External_Name_Imp_Casing := Lowercase;
5378
5379                when others =>
5380                   null;
5381             end case;
5382          end External_Name_Casing;
5383
5384          ---------------------------
5385          -- Finalize_Storage_Only --
5386          ---------------------------
5387
5388          --  pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
5389
5390          when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
5391             Assoc   : Node_Id := Arg1;
5392             Type_Id : Node_Id := Expression (Assoc);
5393             Typ     : Entity_Id;
5394
5395          begin
5396             Check_No_Identifiers;
5397             Check_Arg_Count (1);
5398             Check_Arg_Is_Local_Name (Arg1);
5399
5400             Find_Type (Type_Id);
5401             Typ := Entity (Type_Id);
5402
5403             if Typ = Any_Type
5404               or else Rep_Item_Too_Early (Typ, N)
5405             then
5406                return;
5407             else
5408                Typ := Underlying_Type (Typ);
5409             end if;
5410
5411             if not Is_Controlled (Typ) then
5412                Error_Pragma ("pragma% must specify controlled type");
5413             end if;
5414
5415             Check_First_Subtype (Arg1);
5416
5417             if Finalize_Storage_Only (Typ) then
5418                Error_Pragma ("duplicate pragma%, only one allowed");
5419
5420             elsif not Rep_Item_Too_Late (Typ, N) then
5421                Set_Finalize_Storage_Only (Base_Type (Typ), True);
5422             end if;
5423          end Finalize_Storage;
5424
5425          --------------------------
5426          -- Float_Representation --
5427          --------------------------
5428
5429          --  pragma Float_Representation (VAX_Float | IEEE_Float);
5430
5431          when Pragma_Float_Representation => Float_Representation : declare
5432             Argx : Node_Id;
5433             Digs : Nat;
5434             Ent  : Entity_Id;
5435
5436          begin
5437             GNAT_Pragma;
5438
5439             if Arg_Count = 1 then
5440                Check_Valid_Configuration_Pragma;
5441             else
5442                Check_Arg_Count (2);
5443                Check_Optional_Identifier (Arg2, Name_Entity);
5444                Check_Arg_Is_Local_Name (Arg2);
5445             end if;
5446
5447             Check_No_Identifier (Arg1);
5448             Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
5449
5450             if not OpenVMS_On_Target then
5451                if Chars (Expression (Arg1)) = Name_VAX_Float then
5452                   Error_Pragma
5453                     ("?pragma% ignored (applies only to Open'V'M'S)");
5454                end if;
5455
5456                return;
5457             end if;
5458
5459             --  One argument case
5460
5461             if Arg_Count = 1 then
5462
5463                if Chars (Expression (Arg1)) = Name_VAX_Float then
5464
5465                   if Opt.Float_Format = 'I' then
5466                      Error_Pragma ("'I'E'E'E format previously specified");
5467                   end if;
5468
5469                   Opt.Float_Format := 'V';
5470
5471                else
5472                   if Opt.Float_Format = 'V' then
5473                      Error_Pragma ("'V'A'X format previously specified");
5474                   end if;
5475
5476                   Opt.Float_Format := 'I';
5477                end if;
5478
5479                Set_Standard_Fpt_Formats;
5480
5481             --  Two argument case
5482
5483             else
5484                Argx := Get_Pragma_Arg (Arg2);
5485
5486                if not Is_Entity_Name (Argx)
5487                  or else not Is_Floating_Point_Type (Entity (Argx))
5488                then
5489                   Error_Pragma_Arg
5490                     ("second argument of% pragma must be floating-point type",
5491                      Arg2);
5492                end if;
5493
5494                Ent  := Entity (Argx);
5495                Digs := UI_To_Int (Digits_Value (Ent));
5496
5497                --  Two arguments, VAX_Float case
5498
5499                if Chars (Expression (Arg1)) = Name_VAX_Float then
5500
5501                   case Digs is
5502                      when  6 => Set_F_Float (Ent);
5503                      when  9 => Set_D_Float (Ent);
5504                      when 15 => Set_G_Float (Ent);
5505
5506                      when others =>
5507                         Error_Pragma_Arg
5508                           ("wrong digits value, must be 6,9 or 15", Arg2);
5509                   end case;
5510
5511                --  Two arguments, IEEE_Float case
5512
5513                else
5514                   case Digs is
5515                      when  6 => Set_IEEE_Short (Ent);
5516                      when 15 => Set_IEEE_Long  (Ent);
5517
5518                      when others =>
5519                         Error_Pragma_Arg
5520                           ("wrong digits value, must be 6 or 15", Arg2);
5521                   end case;
5522                end if;
5523             end if;
5524          end Float_Representation;
5525
5526          -----------
5527          -- Ident --
5528          -----------
5529
5530          --  pragma Ident (static_string_EXPRESSION)
5531
5532          --  Note: pragma Comment shares this processing. Pragma Comment
5533          --  is identical to Ident, except that the restriction of the
5534          --  argument to 31 characters and the placement restrictions
5535          --  are not enforced for pragma Comment.
5536
5537          when Pragma_Ident | Pragma_Comment => Ident : declare
5538             Str : Node_Id;
5539
5540          begin
5541             GNAT_Pragma;
5542             Check_Arg_Count (1);
5543             Check_No_Identifiers;
5544             Check_Arg_Is_Static_Expression (Arg1, Standard_String);
5545
5546             --  For pragma Ident, preserve DEC compatibility by requiring
5547             --  the pragma to appear in a declarative part or package spec.
5548
5549             if Prag_Id = Pragma_Ident then
5550                Check_Is_In_Decl_Part_Or_Package_Spec;
5551             end if;
5552
5553             Str := Expr_Value_S (Expression (Arg1));
5554
5555             --  For pragma Ident, preserve DEC compatibility by limiting
5556             --  the length to 31 characters.
5557
5558             if Prag_Id = Pragma_Ident
5559               and then String_Length (Strval (Str)) > 31
5560             then
5561                Error_Pragma_Arg
5562                  ("argument for pragma% is too long, maximum is 31", Arg1);
5563             end if;
5564
5565             declare
5566                CS : Node_Id;
5567                GP : Node_Id;
5568
5569             begin
5570                GP := Parent (Parent (N));
5571
5572                if Nkind (GP) = N_Package_Declaration
5573                     or else
5574                   Nkind (GP) = N_Generic_Package_Declaration
5575                then
5576                   GP := Parent (GP);
5577                end if;
5578
5579                --  If we have a compilation unit, then record the ident
5580                --  value, checking for improper duplication.
5581
5582                if Nkind (GP) = N_Compilation_Unit then
5583                   CS := Ident_String (Current_Sem_Unit);
5584
5585                   if Present (CS) then
5586
5587                      --  For Ident, we do not permit multiple instances
5588
5589                      if Prag_Id = Pragma_Ident then
5590                         Error_Pragma ("duplicate% pragma not permitted");
5591
5592                      --  For Comment, we concatenate the string, unless we
5593                      --  want to preserve the tree structure for ASIS.
5594
5595                      elsif not Tree_Output then
5596                         Start_String (Strval (CS));
5597                         Store_String_Char (' ');
5598                         Store_String_Chars (Strval (Str));
5599                         Set_Strval (CS, End_String);
5600                      end if;
5601
5602                   else
5603                      --  In VMS, the effect of IDENT is achieved by passing
5604                      --  IDENTIFICATION=name as a --for-linker switch.
5605
5606                      if OpenVMS_On_Target then
5607                         Start_String;
5608                         Store_String_Chars
5609                           ("--for-linker=IDENTIFICATION=");
5610                         String_To_Name_Buffer (Strval (Str));
5611                         Store_String_Chars (Name_Buffer (1 .. Name_Len));
5612
5613                         --  Only the last processed IDENT is saved. The main
5614                         --  purpose is so an IDENT associated with a main
5615                         --  procedure will be used in preference to an IDENT
5616                         --  associated with a with'd package.
5617
5618                         Replace_Linker_Option_String
5619                           (End_String, "--for-linker=IDENTIFICATION=");
5620                      end if;
5621
5622                      Set_Ident_String (Current_Sem_Unit, Str);
5623                   end if;
5624
5625                --  For subunits, we just ignore the Ident, since in GNAT
5626                --  these are not separate object files, and hence not
5627                --  separate units in the unit table.
5628
5629                elsif Nkind (GP) = N_Subunit then
5630                   null;
5631
5632                --  Otherwise we have a misplaced pragma Ident, but we ignore
5633                --  this if we are in an instantiation, since it comes from
5634                --  a generic, and has no relevance to the instantiation.
5635
5636                elsif Prag_Id = Pragma_Ident then
5637                   if Instantiation_Location (Loc) = No_Location then
5638                      Error_Pragma ("pragma% only allowed at outer level");
5639                   end if;
5640                end if;
5641             end;
5642          end Ident;
5643
5644          ------------
5645          -- Import --
5646          ------------
5647
5648          --  pragma Import (
5649          --    [   Convention    =>] convention_IDENTIFIER,
5650          --    [   Entity        =>] local_NAME
5651          --    [, [External_Name =>] static_string_EXPRESSION ]
5652          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
5653
5654          when Pragma_Import =>
5655             Check_Ada_83_Warning;
5656             Check_At_Least_N_Arguments (2);
5657             Check_At_Most_N_Arguments  (4);
5658             Process_Import_Or_Interface;
5659
5660          ----------------------
5661          -- Import_Exception --
5662          ----------------------
5663
5664          --  pragma Import_Exception (
5665          --        [Internal         =>] LOCAL_NAME,
5666          --     [, [External         =>] EXTERNAL_SYMBOL,]
5667          --     [, [Form     =>] Ada | VMS]
5668          --     [, [Code     =>] static_integer_EXPRESSION]);
5669
5670          when Pragma_Import_Exception => Import_Exception : declare
5671             Args  : Args_List (1 .. 4);
5672             Names : Name_List (1 .. 4) := (
5673                       Name_Internal,
5674                       Name_External,
5675                       Name_Form,
5676                       Name_Code);
5677
5678             Internal : Node_Id renames Args (1);
5679             External : Node_Id renames Args (2);
5680             Form     : Node_Id renames Args (3);
5681             Code     : Node_Id renames Args (4);
5682
5683          begin
5684             Gather_Associations (Names, Args);
5685
5686             if Present (External) and then Present (Code) then
5687                Error_Pragma
5688                  ("cannot give both External and Code options for pragma%");
5689             end if;
5690
5691             Process_Extended_Import_Export_Exception_Pragma (
5692               Arg_Internal => Internal,
5693               Arg_External => External,
5694               Arg_Form     => Form,
5695               Arg_Code     => Code);
5696
5697             if not Is_VMS_Exception (Entity (Internal)) then
5698                Set_Imported (Entity (Internal));
5699             end if;
5700          end Import_Exception;
5701
5702          ---------------------
5703          -- Import_Function --
5704          ---------------------
5705
5706          --  pragma Import_Function (
5707          --        [Internal                 =>] LOCAL_NAME,
5708          --     [, [External                 =>] EXTERNAL_SYMBOL]
5709          --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
5710          --     [, [Result_Type              =>] SUBTYPE_MARK]
5711          --     [, [Mechanism                =>] MECHANISM]
5712          --     [, [Result_Mechanism         =>] MECHANISM_NAME]
5713          --     [, [First_Optional_Parameter =>] IDENTIFIER]);
5714
5715          when Pragma_Import_Function => Import_Function : declare
5716             Args  : Args_List (1 .. 7);
5717             Names : Name_List (1 .. 7) := (
5718                       Name_Internal,
5719                       Name_External,
5720                       Name_Parameter_Types,
5721                       Name_Result_Type,
5722                       Name_Mechanism,
5723                       Name_Result_Mechanism,
5724                       Name_First_Optional_Parameter);
5725
5726             Internal                 : Node_Id renames Args (1);
5727             External                 : Node_Id renames Args (2);
5728             Parameter_Types          : Node_Id renames Args (3);
5729             Result_Type              : Node_Id renames Args (4);
5730             Mechanism                : Node_Id renames Args (5);
5731             Result_Mechanism         : Node_Id renames Args (6);
5732             First_Optional_Parameter : Node_Id renames Args (7);
5733
5734          begin
5735             GNAT_Pragma;
5736             Gather_Associations (Names, Args);
5737             Process_Extended_Import_Export_Subprogram_Pragma (
5738               Arg_Internal                 => Internal,
5739               Arg_External                 => External,
5740               Arg_Parameter_Types          => Parameter_Types,
5741               Arg_Result_Type              => Result_Type,
5742               Arg_Mechanism                => Mechanism,
5743               Arg_Result_Mechanism         => Result_Mechanism,
5744               Arg_First_Optional_Parameter => First_Optional_Parameter);
5745          end Import_Function;
5746
5747          -------------------
5748          -- Import_Object --
5749          -------------------
5750
5751          --  pragma Import_Object (
5752          --        [Internal =>] LOCAL_NAME,
5753          --     [, [External =>] EXTERNAL_SYMBOL]
5754          --     [, [Size     =>] EXTERNAL_SYMBOL]);
5755
5756          when Pragma_Import_Object => Import_Object : declare
5757             Args  : Args_List (1 .. 3);
5758             Names : Name_List (1 .. 3) := (
5759                       Name_Internal,
5760                       Name_External,
5761                       Name_Size);
5762
5763             Internal : Node_Id renames Args (1);
5764             External : Node_Id renames Args (2);
5765             Size     : Node_Id renames Args (3);
5766
5767          begin
5768             GNAT_Pragma;
5769             Gather_Associations (Names, Args);
5770             Process_Extended_Import_Export_Object_Pragma (
5771               Arg_Internal => Internal,
5772               Arg_External => External,
5773               Arg_Size     => Size);
5774          end Import_Object;
5775
5776          ----------------------
5777          -- Import_Procedure --
5778          ----------------------
5779
5780          --  pragma Import_Procedure (
5781          --        [Internal                 =>] LOCAL_NAME,
5782          --     [, [External                 =>] EXTERNAL_SYMBOL]
5783          --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
5784          --     [, [Mechanism                =>] MECHANISM]
5785          --     [, [First_Optional_Parameter =>] IDENTIFIER]);
5786
5787          when Pragma_Import_Procedure => Import_Procedure : declare
5788             Args  : Args_List (1 .. 5);
5789             Names : Name_List (1 .. 5) := (
5790                       Name_Internal,
5791                       Name_External,
5792                       Name_Parameter_Types,
5793                       Name_Mechanism,
5794                       Name_First_Optional_Parameter);
5795
5796             Internal                 : Node_Id renames Args (1);
5797             External                 : Node_Id renames Args (2);
5798             Parameter_Types          : Node_Id renames Args (3);
5799             Mechanism                : Node_Id renames Args (4);
5800             First_Optional_Parameter : Node_Id renames Args (5);
5801
5802          begin
5803             GNAT_Pragma;
5804             Gather_Associations (Names, Args);
5805             Process_Extended_Import_Export_Subprogram_Pragma (
5806               Arg_Internal                 => Internal,
5807               Arg_External                 => External,
5808               Arg_Parameter_Types          => Parameter_Types,
5809               Arg_Mechanism                => Mechanism,
5810               Arg_First_Optional_Parameter => First_Optional_Parameter);
5811          end Import_Procedure;
5812
5813          -----------------------------
5814          -- Import_Valued_Procedure --
5815          -----------------------------
5816
5817          --  pragma Import_Valued_Procedure (
5818          --        [Internal                 =>] LOCAL_NAME,
5819          --     [, [External                 =>] EXTERNAL_SYMBOL]
5820          --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
5821          --     [, [Mechanism                =>] MECHANISM]
5822          --     [, [First_Optional_Parameter =>] IDENTIFIER]);
5823
5824          when Pragma_Import_Valued_Procedure =>
5825          Import_Valued_Procedure : declare
5826             Args  : Args_List (1 .. 5);
5827             Names : Name_List (1 .. 5) := (
5828                       Name_Internal,
5829                       Name_External,
5830                       Name_Parameter_Types,
5831                       Name_Mechanism,
5832                       Name_First_Optional_Parameter);
5833
5834             Internal                 : Node_Id renames Args (1);
5835             External                 : Node_Id renames Args (2);
5836             Parameter_Types          : Node_Id renames Args (3);
5837             Mechanism                : Node_Id renames Args (4);
5838             First_Optional_Parameter : Node_Id renames Args (5);
5839
5840          begin
5841             GNAT_Pragma;
5842             Gather_Associations (Names, Args);
5843             Process_Extended_Import_Export_Subprogram_Pragma (
5844               Arg_Internal                 => Internal,
5845               Arg_External                 => External,
5846               Arg_Parameter_Types          => Parameter_Types,
5847               Arg_Mechanism                => Mechanism,
5848               Arg_First_Optional_Parameter => First_Optional_Parameter);
5849          end Import_Valued_Procedure;
5850
5851          ------------------------
5852          -- Initialize_Scalars --
5853          ------------------------
5854
5855          --  pragma Initialize_Scalars;
5856
5857          when Pragma_Initialize_Scalars =>
5858             GNAT_Pragma;
5859             Check_Arg_Count (0);
5860             Check_Valid_Configuration_Pragma;
5861             Init_Or_Norm_Scalars := True;
5862             Initialize_Scalars := True;
5863
5864          ------------
5865          -- Inline --
5866          ------------
5867
5868          --  pragma Inline ( NAME {, NAME} );
5869
5870          when Pragma_Inline =>
5871
5872             --  Pragma is active if inlining option is active
5873
5874             if Inline_Active then
5875                Process_Inline (True);
5876
5877             --  Pragma is active in a predefined file in no run time mode
5878
5879             elsif No_Run_Time
5880               and then
5881                 Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
5882             then
5883                Process_Inline (True);
5884
5885             else
5886                Process_Inline (False);
5887             end if;
5888
5889          -------------------
5890          -- Inline_Always --
5891          -------------------
5892
5893          --  pragma Inline_Always ( NAME {, NAME} );
5894
5895          when Pragma_Inline_Always =>
5896             Process_Inline (True);
5897
5898          --------------------
5899          -- Inline_Generic --
5900          --------------------
5901
5902          --  pragma Inline_Generic (NAME {, NAME});
5903
5904          when Pragma_Inline_Generic =>
5905             Process_Generic_List;
5906
5907          ----------------------
5908          -- Inspection_Point --
5909          ----------------------
5910
5911          --  pragma Inspection_Point [(object_NAME {, object_NAME})];
5912
5913          when Pragma_Inspection_Point => Inspection_Point : declare
5914             Arg : Node_Id;
5915             Exp : Node_Id;
5916
5917          begin
5918             if Arg_Count > 0 then
5919                Arg := Arg1;
5920                loop
5921                   Exp := Expression (Arg);
5922                   Analyze (Exp);
5923
5924                   if not Is_Entity_Name (Exp)
5925                     or else not Is_Object (Entity (Exp))
5926                   then
5927                      Error_Pragma_Arg ("object name required", Arg);
5928                   end if;
5929
5930                   Next (Arg);
5931                   exit when No (Arg);
5932                end loop;
5933             end if;
5934          end Inspection_Point;
5935
5936          ---------------
5937          -- Interface --
5938          ---------------
5939
5940          --  pragma Interface (
5941          --    convention_IDENTIFIER,
5942          --    local_NAME );
5943
5944          when Pragma_Interface =>
5945             GNAT_Pragma;
5946             Check_Arg_Count (2);
5947             Check_No_Identifiers;
5948             Process_Import_Or_Interface;
5949
5950          --------------------
5951          -- Interface_Name --
5952          --------------------
5953
5954          --  pragma Interface_Name (
5955          --    [  Entity        =>] local_NAME
5956          --    [,[External_Name =>] static_string_EXPRESSION ]
5957          --    [,[Link_Name     =>] static_string_EXPRESSION ]);
5958
5959          when Pragma_Interface_Name => Interface_Name : declare
5960             Id     : Node_Id;
5961             Def_Id : Entity_Id;
5962             Hom_Id : Entity_Id;
5963             Found  : Boolean;
5964
5965          begin
5966             GNAT_Pragma;
5967             Check_At_Least_N_Arguments (2);
5968             Check_At_Most_N_Arguments  (3);
5969             Id := Expression (Arg1);
5970             Analyze (Id);
5971
5972             if not Is_Entity_Name (Id) then
5973                Error_Pragma_Arg
5974                  ("first argument for pragma% must be entity name", Arg1);
5975             elsif Etype (Id) = Any_Type then
5976                return;
5977             else
5978                Def_Id := Entity (Id);
5979             end if;
5980
5981             --  Special DEC-compatible processing for the object case,
5982             --  forces object to be imported.
5983
5984             if Ekind (Def_Id) = E_Variable then
5985                Kill_Size_Check_Code (Def_Id);
5986                Note_Possible_Modification (Id);
5987
5988                --  Initialization is not allowed for imported variable
5989
5990                if Present (Expression (Parent (Def_Id)))
5991                  and then Comes_From_Source (Expression (Parent (Def_Id)))
5992                then
5993                   Error_Msg_Sloc := Sloc (Def_Id);
5994                   Error_Pragma_Arg
5995                     ("no initialization allowed for declaration of& #",
5996                      Arg2);
5997
5998                else
5999                   --  For compatibility, support VADS usage of providing both
6000                   --  pragmas Interface and Interface_Name to obtain the effect
6001                   --  of a single Import pragma.
6002
6003                   if Is_Imported (Def_Id)
6004                     and then Present (First_Rep_Item (Def_Id))
6005                     and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
6006                     and then Chars (First_Rep_Item (Def_Id)) = Name_Interface
6007                   then
6008                      null;
6009                   else
6010                      Set_Imported (Def_Id);
6011                   end if;
6012
6013                   Set_Is_Public (Def_Id);
6014                   Process_Interface_Name (Def_Id, Arg2, Arg3);
6015                end if;
6016
6017             --  Otherwise must be subprogram
6018
6019             elsif not Is_Subprogram (Def_Id) then
6020                Error_Pragma_Arg
6021                  ("argument of pragma% is not subprogram", Arg1);
6022
6023             else
6024                Check_At_Most_N_Arguments (3);
6025                Hom_Id := Def_Id;
6026                Found := False;
6027
6028                --  Loop through homonyms
6029
6030                loop
6031                   Def_Id := Get_Base_Subprogram (Hom_Id);
6032
6033                   if Is_Imported (Def_Id) then
6034                      Process_Interface_Name (Def_Id, Arg2, Arg3);
6035                      Found := True;
6036                   end if;
6037
6038                   Hom_Id := Homonym (Hom_Id);
6039
6040                   exit when No (Hom_Id)
6041                     or else Scope (Hom_Id) /= Current_Scope;
6042                end loop;
6043
6044                if not Found then
6045                   Error_Pragma_Arg
6046                     ("argument of pragma% is not imported subprogram",
6047                      Arg1);
6048                end if;
6049             end if;
6050          end Interface_Name;
6051
6052          -----------------------
6053          -- Interrupt_Handler --
6054          -----------------------
6055
6056          --  pragma Interrupt_Handler (handler_NAME);
6057
6058          when Pragma_Interrupt_Handler =>
6059             Check_Ada_83_Warning;
6060             Check_Arg_Count (1);
6061             Check_No_Identifiers;
6062             Check_Interrupt_Or_Attach_Handler;
6063             Process_Interrupt_Or_Attach_Handler;
6064
6065          ------------------------
6066          -- Interrupt_Priority --
6067          ------------------------
6068
6069          --  pragma Interrupt_Priority [(EXPRESSION)];
6070
6071          when Pragma_Interrupt_Priority => Interrupt_Priority : declare
6072             P   : constant Node_Id := Parent (N);
6073             Arg : Node_Id;
6074
6075          begin
6076             Check_Ada_83_Warning;
6077
6078             if Arg_Count /= 0 then
6079                Arg := Expression (Arg1);
6080                Check_Arg_Count (1);
6081                Check_No_Identifiers;
6082
6083                --  Set In_Default_Expression for per-object case???
6084
6085                Analyze_And_Resolve (Arg, Standard_Integer);
6086                if Expander_Active then
6087                   Rewrite (Arg,
6088                     Convert_To (RTE (RE_Interrupt_Priority), Arg));
6089                end if;
6090             end if;
6091
6092             if Nkind (P) /= N_Task_Definition
6093               and then Nkind (P) /= N_Protected_Definition
6094             then
6095                Pragma_Misplaced;
6096                return;
6097
6098             elsif Has_Priority_Pragma (P) then
6099                Error_Pragma ("duplicate pragma% not allowed");
6100
6101             else
6102                Set_Has_Priority_Pragma (P, True);
6103                Record_Rep_Item (Defining_Identifier (Parent (P)), N);
6104             end if;
6105          end Interrupt_Priority;
6106
6107          ----------------------
6108          -- Java_Constructor --
6109          ----------------------
6110
6111          --  pragma Java_Constructor ([Entity =>] LOCAL_NAME);
6112
6113          when Pragma_Java_Constructor => Java_Constructor : declare
6114             Id     : Entity_Id;
6115             Def_Id : Entity_Id;
6116             Hom_Id : Entity_Id;
6117
6118          begin
6119             GNAT_Pragma;
6120             Check_Arg_Count (1);
6121             Check_Optional_Identifier (Arg1, Name_Entity);
6122             Check_Arg_Is_Local_Name (Arg1);
6123
6124             Id := Expression (Arg1);
6125             Find_Program_Unit_Name (Id);
6126
6127             --  If we did not find the name, we are done
6128
6129             if Etype (Id) = Any_Type then
6130                return;
6131             end if;
6132
6133             Hom_Id := Entity (Id);
6134
6135             --  Loop through homonyms
6136
6137             loop
6138                Def_Id := Get_Base_Subprogram (Hom_Id);
6139
6140                --  The constructor is required to be a function returning
6141                --  an access type whose designated type has convention Java.
6142
6143                if Ekind (Def_Id) = E_Function
6144                  and then Ekind (Etype (Def_Id)) in Access_Kind
6145                  and then
6146                    (Atree.Convention
6147                       (Designated_Type (Etype (Def_Id))) = Convention_Java
6148                    or else
6149                      Atree.Convention
6150                       (Root_Type (Designated_Type (Etype (Def_Id))))
6151                         = Convention_Java)
6152                then
6153                   Set_Is_Constructor (Def_Id);
6154                   Set_Convention     (Def_Id, Convention_Java);
6155
6156                else
6157                   Error_Pragma_Arg
6158                     ("pragma% requires function returning a 'Java access type",
6159                       Arg1);
6160                end if;
6161
6162                Hom_Id := Homonym (Hom_Id);
6163
6164                exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
6165             end loop;
6166          end Java_Constructor;
6167
6168          ----------------------
6169          -- Java_Interface --
6170          ----------------------
6171
6172          --  pragma Java_Interface ([Entity =>] LOCAL_NAME);
6173
6174          when Pragma_Java_Interface => Java_Interface : declare
6175             Arg : Node_Id;
6176             Typ : Entity_Id;
6177
6178          begin
6179             GNAT_Pragma;
6180             Check_Arg_Count (1);
6181             Check_Optional_Identifier (Arg1, Name_Entity);
6182             Check_Arg_Is_Local_Name (Arg1);
6183
6184             Arg := Expression (Arg1);
6185             Analyze (Arg);
6186
6187             if Etype (Arg) = Any_Type then
6188                return;
6189             end if;
6190
6191             if not Is_Entity_Name (Arg)
6192               or else not Is_Type (Entity (Arg))
6193             then
6194                Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
6195             end if;
6196
6197             Typ := Underlying_Type (Entity (Arg));
6198
6199             --  For now we simply check some of the semantic constraints
6200             --  on the type. This currently leaves out some restrictions
6201             --  on interface types, namely that the parent type must be
6202             --  java.lang.Object.Typ and that all primitives of the type
6203             --  should be declared abstract. ???
6204
6205             if not Is_Tagged_Type (Typ) or else not Is_Abstract (Typ) then
6206                Error_Pragma_Arg ("pragma% requires an abstract "
6207                  & "tagged type", Arg1);
6208
6209             elsif not Has_Discriminants (Typ)
6210               or else Ekind (Etype (First_Discriminant (Typ)))
6211                         /= E_Anonymous_Access_Type
6212               or else
6213                 not Is_Class_Wide_Type
6214                       (Designated_Type (Etype (First_Discriminant (Typ))))
6215             then
6216                Error_Pragma_Arg
6217                  ("type must have a class-wide access discriminant", Arg1);
6218             end if;
6219          end Java_Interface;
6220
6221          -------------
6222          -- License --
6223          -------------
6224
6225          --  pragma License (RESTRICTED | UNRESRICTED | GPL | MODIFIED_GPL);
6226
6227          when Pragma_License =>
6228             GNAT_Pragma;
6229             Check_Arg_Count (1);
6230             Check_No_Identifiers;
6231             Check_Valid_Configuration_Pragma;
6232             Check_Arg_Is_Identifier (Arg1);
6233
6234             declare
6235                Sind : constant Source_File_Index :=
6236                         Source_Index (Current_Sem_Unit);
6237
6238             begin
6239                case Chars (Get_Pragma_Arg (Arg1)) is
6240                   when Name_GPL =>
6241                      Set_License (Sind, GPL);
6242
6243                   when Name_Modified_GPL =>
6244                      Set_License (Sind, Modified_GPL);
6245
6246                   when Name_Restricted =>
6247                      Set_License (Sind, Restricted);
6248
6249                   when Name_Unrestricted =>
6250                      Set_License (Sind, Unrestricted);
6251
6252                   when others =>
6253                      Error_Pragma_Arg ("invalid license name", Arg1);
6254                end case;
6255             end;
6256
6257          ---------------
6258          -- Link_With --
6259          ---------------
6260
6261          --  pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
6262
6263          when Pragma_Link_With => Link_With : declare
6264             Arg : Node_Id;
6265
6266          begin
6267             GNAT_Pragma;
6268
6269             if Operating_Mode = Generate_Code
6270               and then In_Extended_Main_Source_Unit (N)
6271             then
6272                Check_At_Least_N_Arguments (1);
6273                Check_No_Identifiers;
6274                Check_Is_In_Decl_Part_Or_Package_Spec;
6275                Check_Arg_Is_Static_Expression (Arg1, Standard_String);
6276                Start_String;
6277
6278                Arg := Arg1;
6279                while Present (Arg) loop
6280                   Check_Arg_Is_Static_Expression (Arg, Standard_String);
6281
6282                   --  Store argument, converting sequences of spaces
6283                   --  to a single null character (this is one of the
6284                   --  differences in processing between Link_With
6285                   --  and Linker_Options).
6286
6287                   declare
6288                      C : constant Char_Code := Get_Char_Code (' ');
6289                      S : constant String_Id :=
6290                            Strval (Expr_Value_S (Expression (Arg)));
6291
6292                      F : Nat := 1;
6293                      L : Nat := String_Length (S);
6294
6295                      procedure Skip_Spaces;
6296                      --  Advance F past any spaces
6297
6298                      procedure Skip_Spaces is
6299                      begin
6300                         while F <= L and then Get_String_Char (S, F) = C loop
6301                            F := F + 1;
6302                         end loop;
6303                      end Skip_Spaces;
6304
6305                   begin
6306                      Skip_Spaces; -- skip leading spaces
6307
6308                      --  Loop through characters, changing any embedded
6309                      --  sequence of spaces to a single null character
6310                      --  (this is how Link_With/Linker_Options differ)
6311
6312                      while F <= L loop
6313                         if Get_String_Char (S, F) = C then
6314                            Skip_Spaces;
6315                            exit when F > L;
6316                            Store_String_Char (ASCII.NUL);
6317
6318                         else
6319                            Store_String_Char (Get_String_Char (S, F));
6320                            F := F + 1;
6321                         end if;
6322                      end loop;
6323                   end;
6324
6325                   Arg := Next (Arg);
6326
6327                   if Present (Arg) then
6328                      Store_String_Char (ASCII.NUL);
6329                   end if;
6330                end loop;
6331
6332                Store_Linker_Option_String (End_String);
6333             end if;
6334          end Link_With;
6335
6336          ------------------
6337          -- Linker_Alias --
6338          ------------------
6339
6340          --  pragma Linker_Alias (
6341          --      [Entity =>]  LOCAL_NAME
6342          --      [Alias  =>]  static_string_EXPRESSION);
6343
6344          when Pragma_Linker_Alias =>
6345             GNAT_Pragma;
6346             Check_Arg_Count (2);
6347             Check_Optional_Identifier (Arg1, Name_Entity);
6348             Check_Optional_Identifier (Arg2, "alias");
6349             Check_Arg_Is_Library_Level_Local_Name (Arg1);
6350             Check_Arg_Is_Static_Expression (Arg2, Standard_String);
6351
6352             --  The only processing required is to link this item on to the
6353             --  list of rep items for the given entity. This is accomplished
6354             --  by the call to Rep_Item_Too_Late (when no error is detected
6355             --  and False is returned).
6356
6357             if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
6358                return;
6359             else
6360                Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
6361             end if;
6362
6363          --------------------
6364          -- Linker_Options --
6365          --------------------
6366
6367          --  pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
6368
6369          when Pragma_Linker_Options => Linker_Options : declare
6370             Arg : Node_Id;
6371
6372          begin
6373             Check_Ada_83_Warning;
6374             Check_No_Identifiers;
6375             Check_Arg_Count (1);
6376             Check_Is_In_Decl_Part_Or_Package_Spec;
6377
6378             if Operating_Mode = Generate_Code
6379               and then In_Extended_Main_Source_Unit (N)
6380             then
6381                Check_Arg_Is_Static_Expression (Arg1, Standard_String);
6382                Start_String (Strval (Expr_Value_S (Expression (Arg1))));
6383
6384                Arg := Arg2;
6385                while Present (Arg) loop
6386                   Check_Arg_Is_Static_Expression (Arg, Standard_String);
6387                   Store_String_Char (ASCII.NUL);
6388                   Store_String_Chars
6389                     (Strval (Expr_Value_S (Expression (Arg))));
6390                   Arg := Next (Arg);
6391                end loop;
6392
6393                Store_Linker_Option_String (End_String);
6394             end if;
6395          end Linker_Options;
6396
6397          --------------------
6398          -- Linker_Section --
6399          --------------------
6400
6401          --  pragma Linker_Section (
6402          --      [Entity  =>]  LOCAL_NAME
6403          --      [Section =>]  static_string_EXPRESSION);
6404
6405          when Pragma_Linker_Section =>
6406             GNAT_Pragma;
6407             Check_Arg_Count (2);
6408             Check_Optional_Identifier (Arg1, Name_Entity);
6409             Check_Optional_Identifier (Arg2, Name_Section);
6410             Check_Arg_Is_Library_Level_Local_Name (Arg1);
6411             Check_Arg_Is_Static_Expression (Arg2, Standard_String);
6412
6413             --  The only processing required is to link this item on to the
6414             --  list of rep items for the given entity. This is accomplished
6415             --  by the call to Rep_Item_Too_Late (when no error is detected
6416             --  and False is returned).
6417
6418             if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
6419                return;
6420             else
6421                Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
6422             end if;
6423
6424          ----------
6425          -- List --
6426          ----------
6427
6428          --  pragma List (On | Off)
6429
6430          --  There is nothing to do here, since we did all the processing
6431          --  for this pragma in Par.Prag (so that it works properly even in
6432          --  syntax only mode)
6433
6434          when Pragma_List =>
6435             null;
6436
6437          --------------------
6438          -- Locking_Policy --
6439          --------------------
6440
6441          --  pragma Locking_Policy (policy_IDENTIFIER);
6442
6443          when Pragma_Locking_Policy => declare
6444             LP : Character;
6445
6446          begin
6447             Check_Ada_83_Warning;
6448             Check_Arg_Count (1);
6449             Check_No_Identifiers;
6450             Check_Arg_Is_Locking_Policy (Arg1);
6451             Check_Valid_Configuration_Pragma;
6452             Get_Name_String (Chars (Expression (Arg1)));
6453             LP := Fold_Upper (Name_Buffer (1));
6454
6455             if Locking_Policy /= ' '
6456               and then Locking_Policy /= LP
6457             then
6458                Error_Msg_Sloc := Locking_Policy_Sloc;
6459                Error_Pragma ("locking policy incompatible with policy#");
6460             else
6461                Locking_Policy := LP;
6462                Locking_Policy_Sloc := Loc;
6463             end if;
6464          end;
6465
6466          ----------------
6467          -- Long_Float --
6468          ----------------
6469
6470          --  pragma Long_Float (D_Float | G_Float);
6471
6472          when Pragma_Long_Float =>
6473             GNAT_Pragma;
6474             Check_Valid_Configuration_Pragma;
6475             Check_Arg_Count (1);
6476             Check_No_Identifier (Arg1);
6477             Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
6478
6479             if not OpenVMS_On_Target then
6480                Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)");
6481             end if;
6482
6483             --  D_Float case
6484
6485             if Chars (Expression (Arg1)) = Name_D_Float then
6486                if Opt.Float_Format_Long = 'G' then
6487                   Error_Pragma ("G_Float previously specified");
6488                end if;
6489
6490                Opt.Float_Format_Long := 'D';
6491
6492             --  G_Float case (this is the default, does not need overriding)
6493
6494             else
6495                if Opt.Float_Format_Long = 'D' then
6496                   Error_Pragma ("D_Float previously specified");
6497                end if;
6498
6499                Opt.Float_Format_Long := 'G';
6500             end if;
6501
6502             Set_Standard_Fpt_Formats;
6503
6504          -----------------------
6505          -- Machine_Attribute --
6506          -----------------------
6507
6508          --  pragma Machine_Attribute (
6509          --    [Entity         =>] LOCAL_NAME,
6510          --    [Attribute_Name =>] static_string_EXPRESSION
6511          --  [,[Info           =>] static_string_EXPRESSION] );
6512
6513          when Pragma_Machine_Attribute => Machine_Attribute : declare
6514             Def_Id : Entity_Id;
6515
6516          begin
6517             GNAT_Pragma;
6518
6519             if Arg_Count = 3 then
6520                Check_Optional_Identifier (Arg3, "info");
6521                Check_Arg_Is_Static_Expression (Arg3, Standard_String);
6522             else
6523                Check_Arg_Count (2);
6524             end if;
6525
6526             Check_Arg_Is_Local_Name (Arg1);
6527             Check_Optional_Identifier (Arg2, "attribute_name");
6528             Check_Optional_Identifier (Arg1, Name_Entity);
6529             Check_Arg_Is_Static_Expression (Arg2, Standard_String);
6530             Def_Id := Entity (Expression (Arg1));
6531
6532             if Is_Access_Type (Def_Id) then
6533                Def_Id := Designated_Type (Def_Id);
6534             end if;
6535
6536             if Rep_Item_Too_Early (Def_Id, N) then
6537                return;
6538             end if;
6539
6540             Def_Id := Underlying_Type (Def_Id);
6541
6542             --  The only processing required is to link this item on to the
6543             --  list of rep items for the given entity. This is accomplished
6544             --  by the call to Rep_Item_Too_Late (when no error is detected
6545             --  and False is returned).
6546
6547             if Rep_Item_Too_Late (Def_Id, N) then
6548                return;
6549             else
6550                Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
6551             end if;
6552          end Machine_Attribute;
6553
6554          ----------
6555          -- Main --
6556          ----------
6557
6558          --  pragma Main_Storage
6559          --   (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
6560
6561          --  MAIN_STORAGE_OPTION ::=
6562          --    [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
6563          --  | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
6564
6565          when Pragma_Main => Main : declare
6566             Args  : Args_List (1 .. 3);
6567             Names : Name_List (1 .. 3) := (
6568                       Name_Stack_Size,
6569                       Name_Task_Stack_Size_Default,
6570                       Name_Time_Slicing_Enabled);
6571
6572             Nod : Node_Id;
6573
6574          begin
6575             GNAT_Pragma;
6576             Gather_Associations (Names, Args);
6577
6578             for J in 1 .. 2 loop
6579                if Present (Args (J)) then
6580                   Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
6581                end if;
6582             end loop;
6583
6584             if Present (Args (3)) then
6585                Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
6586             end if;
6587
6588             Nod := Next (N);
6589             while Present (Nod) loop
6590                if Nkind (Nod) = N_Pragma
6591                  and then Chars (Nod) = Name_Main
6592                then
6593                   Error_Msg_Name_1 := Chars (N);
6594                   Error_Msg_N ("duplicate pragma% not permitted", Nod);
6595                end if;
6596
6597                Next (Nod);
6598             end loop;
6599          end Main;
6600
6601          ------------------
6602          -- Main_Storage --
6603          ------------------
6604
6605          --  pragma Main_Storage
6606          --   (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
6607
6608          --  MAIN_STORAGE_OPTION ::=
6609          --    [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
6610          --  | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
6611
6612          when Pragma_Main_Storage => Main_Storage : declare
6613             Args  : Args_List (1 .. 2);
6614             Names : Name_List (1 .. 2) := (
6615                       Name_Working_Storage,
6616                       Name_Top_Guard);
6617
6618             Nod : Node_Id;
6619
6620          begin
6621             GNAT_Pragma;
6622             Gather_Associations (Names, Args);
6623
6624             for J in 1 .. 2 loop
6625                if Present (Args (J)) then
6626                   Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
6627                end if;
6628             end loop;
6629
6630             Check_In_Main_Program;
6631
6632             Nod := Next (N);
6633             while Present (Nod) loop
6634                if Nkind (Nod) = N_Pragma
6635                  and then Chars (Nod) = Name_Main_Storage
6636                then
6637                   Error_Msg_Name_1 := Chars (N);
6638                   Error_Msg_N ("duplicate pragma% not permitted", Nod);
6639                end if;
6640
6641                Next (Nod);
6642             end loop;
6643          end Main_Storage;
6644
6645          -----------------
6646          -- Memory_Size --
6647          -----------------
6648
6649          --  pragma Memory_Size (NUMERIC_LITERAL)
6650
6651          when Pragma_Memory_Size =>
6652             GNAT_Pragma;
6653
6654             --  Memory size is simply ignored
6655
6656             Check_No_Identifiers;
6657             Check_Arg_Count (1);
6658             Check_Arg_Is_Integer_Literal (Arg1);
6659
6660          ---------------
6661          -- No_Return --
6662          ---------------
6663
6664          --  pragma No_Return (procedure_LOCAL_NAME);
6665
6666          when Pragma_No_Return => declare
6667             Id    : Node_Id;
6668             E     : Entity_Id;
6669             Found : Boolean;
6670
6671          begin
6672             GNAT_Pragma;
6673             Check_Arg_Count (1);
6674             Check_No_Identifiers;
6675             Check_Arg_Is_Local_Name (Arg1);
6676             Id := Expression (Arg1);
6677             Analyze (Id);
6678
6679             if not Is_Entity_Name (Id) then
6680                Error_Pragma_Arg ("entity name required", Arg1);
6681             end if;
6682
6683             if Etype (Id) = Any_Type then
6684                raise Pragma_Exit;
6685             end if;
6686
6687             E := Entity (Id);
6688
6689             Found := False;
6690             while Present (E)
6691               and then Scope (E) = Current_Scope
6692             loop
6693                if Ekind (E) = E_Procedure
6694                  or else Ekind (E) = E_Generic_Procedure
6695                then
6696                   Set_No_Return (E);
6697                   Found := True;
6698                end if;
6699
6700                E := Homonym (E);
6701             end loop;
6702
6703             if not Found then
6704                Error_Pragma ("no procedures found for pragma%");
6705             end if;
6706          end;
6707
6708          -----------------
6709          -- No_Run_Time --
6710          -----------------
6711
6712          --  pragma No_Run_Time
6713
6714          when Pragma_No_Run_Time =>
6715             GNAT_Pragma;
6716             Check_Valid_Configuration_Pragma;
6717             Check_Arg_Count (0);
6718             Set_No_Run_Time_Mode;
6719
6720          -----------------------
6721          -- Normalize_Scalars --
6722          -----------------------
6723
6724          --  pragma Normalize_Scalars;
6725
6726          when Pragma_Normalize_Scalars =>
6727             Check_Ada_83_Warning;
6728             Check_Arg_Count (0);
6729             Check_Valid_Configuration_Pragma;
6730             Normalize_Scalars := True;
6731             Init_Or_Norm_Scalars := True;
6732
6733          --------------
6734          -- Optimize --
6735          --------------
6736
6737          --  pragma Optimize (Time | Space);
6738
6739          --  The actual check for optimize is done in Gigi. Note that this
6740          --  pragma does not actually change the optimization setting, it
6741          --  simply checks that it is consistent with the pragma.
6742
6743          when Pragma_Optimize =>
6744             Check_No_Identifiers;
6745             Check_Arg_Count (1);
6746             Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
6747
6748          ----------
6749          -- Pack --
6750          ----------
6751
6752          --  pragma Pack (first_subtype_LOCAL_NAME);
6753
6754          when Pragma_Pack => Pack : declare
6755             Assoc   : Node_Id := Arg1;
6756             Type_Id : Node_Id;
6757             Typ     : Entity_Id;
6758
6759          begin
6760             Check_No_Identifiers;
6761             Check_Arg_Count (1);
6762             Check_Arg_Is_Local_Name (Arg1);
6763
6764             Type_Id := Expression (Assoc);
6765             Find_Type (Type_Id);
6766             Typ := Entity (Type_Id);
6767
6768             if Typ = Any_Type
6769               or else Rep_Item_Too_Early (Typ, N)
6770             then
6771                return;
6772             else
6773                Typ := Underlying_Type (Typ);
6774             end if;
6775
6776             if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
6777                Error_Pragma ("pragma% must specify array or record type");
6778             end if;
6779
6780             Check_First_Subtype (Arg1);
6781
6782             if Has_Pragma_Pack (Typ) then
6783                Error_Pragma ("duplicate pragma%, only one allowed");
6784
6785             --  Array type. We set the Has_Pragma_Pack flag, and Is_Packed,
6786             --  but not Has_Non_Standard_Rep, because we don't actually know
6787             --  till freeze time if the array can have packed representation.
6788             --  That's because in the general case we do not know enough about
6789             --  the component type until it in turn is frozen, which certainly
6790             --  happens before the array type is frozen, but not necessarily
6791             --  till that point (i.e. right now it may be unfrozen).
6792
6793             elsif Is_Array_Type (Typ) then
6794
6795                if Has_Aliased_Components (Base_Type (Typ)) then
6796                   Error_Pragma
6797                     ("pragma% ignored, cannot pack aliased components?");
6798
6799                elsif Has_Atomic_Components (Typ) then
6800                   Error_Pragma
6801                     ("?pragma% ignored, cannot pack atomic components");
6802
6803                elsif not Rep_Item_Too_Late (Typ, N) then
6804                   Set_Is_Packed            (Base_Type (Typ));
6805                   Set_Has_Pragma_Pack      (Base_Type (Typ));
6806                   Set_Has_Non_Standard_Rep (Base_Type (Typ));
6807                end if;
6808
6809             --  Record type. For record types, the pack is always effective
6810
6811             else -- Is_Record_Type (Typ)
6812                if not Rep_Item_Too_Late (Typ, N) then
6813                   Set_Has_Pragma_Pack      (Base_Type (Typ));
6814                   Set_Is_Packed            (Base_Type (Typ));
6815                   Set_Has_Non_Standard_Rep (Base_Type (Typ));
6816                end if;
6817             end if;
6818          end Pack;
6819
6820          ----------
6821          -- Page --
6822          ----------
6823
6824          --  pragma Page;
6825
6826          --  There is nothing to do here, since we did all the processing
6827          --  for this pragma in Par.Prag (so that it works properly even in
6828          --  syntax only mode)
6829
6830          when Pragma_Page =>
6831             null;
6832
6833          -------------
6834          -- Passive --
6835          -------------
6836
6837          --  pragma Passive [(PASSIVE_FORM)];
6838
6839          --   PASSIVE_FORM ::= Semaphore | No
6840
6841          when Pragma_Passive =>
6842             GNAT_Pragma;
6843
6844             if Nkind (Parent (N)) /= N_Task_Definition then
6845                Error_Pragma ("pragma% must be within task definition");
6846             end if;
6847
6848             if Arg_Count /= 0 then
6849                Check_Arg_Count (1);
6850                Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
6851             end if;
6852
6853          -------------
6854          -- Polling --
6855          -------------
6856
6857          --  pragma Polling (ON | OFF);
6858
6859          when Pragma_Polling =>
6860             GNAT_Pragma;
6861             Check_Arg_Count (1);
6862             Check_No_Identifiers;
6863             Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
6864             Polling_Required := (Chars (Expression (Arg1)) = Name_On);
6865
6866          ------------------
6867          -- Preelaborate --
6868          ------------------
6869
6870          --  pragma Preelaborate [(library_unit_NAME)];
6871
6872          --  Set the flag Is_Preelaborated of program unit name entity
6873
6874          when Pragma_Preelaborate => Preelaborate : declare
6875             Ent : Entity_Id;
6876             Pa  : Node_Id   := Parent (N);
6877             Pk  : Node_Kind := Nkind (Pa);
6878
6879          begin
6880             Check_Ada_83_Warning;
6881             Check_Valid_Library_Unit_Pragma;
6882
6883             if Nkind (N) = N_Null_Statement then
6884                return;
6885             end if;
6886
6887             Ent := Find_Lib_Unit_Name;
6888
6889             --  This filters out pragmas inside generic parent then
6890             --  show up inside instantiation
6891
6892             if Present (Ent)
6893               and then not (Pk = N_Package_Specification
6894                              and then Present (Generic_Parent (Pa)))
6895             then
6896                if not Debug_Flag_U then
6897                   Set_Is_Preelaborated (Ent);
6898                   Set_Suppress_Elaboration_Warnings (Ent);
6899                end if;
6900             end if;
6901          end Preelaborate;
6902
6903          --------------
6904          -- Priority --
6905          --------------
6906
6907          --  pragma Priority (EXPRESSION);
6908
6909          when Pragma_Priority => Priority : declare
6910             P   : constant Node_Id := Parent (N);
6911             Arg : Node_Id;
6912
6913          begin
6914             Check_No_Identifiers;
6915             Check_Arg_Count (1);
6916
6917             Arg := Expression (Arg1);
6918             Analyze_And_Resolve (Arg, Standard_Integer);
6919
6920             if not Is_Static_Expression (Arg) then
6921                Check_Restriction (Static_Priorities, Arg);
6922             end if;
6923
6924             --  Subprogram case
6925
6926             if Nkind (P) = N_Subprogram_Body then
6927                Check_In_Main_Program;
6928
6929                --  Must be static
6930
6931                if not Is_Static_Expression (Arg) then
6932                   Error_Pragma_Arg
6933                     ("main subprogram priority is not static", Arg1);
6934
6935                --  If constraint error, then we already signalled an error
6936
6937                elsif Raises_Constraint_Error (Arg) then
6938                   null;
6939
6940                --  Otherwise check in range
6941
6942                else
6943                   declare
6944                      Val : constant Uint := Expr_Value (Arg);
6945
6946                   begin
6947                      if Val < 0
6948                        or else Val > Expr_Value (Expression
6949                                        (Parent (RTE (RE_Max_Priority))))
6950                      then
6951                         Error_Pragma_Arg
6952                           ("main subprogram priority is out of range", Arg1);
6953                      end if;
6954                   end;
6955                end if;
6956
6957                Set_Main_Priority
6958                  (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
6959
6960             --  Task or Protected, must be of type Integer
6961
6962             elsif Nkind (P) = N_Protected_Definition
6963                     or else
6964                   Nkind (P) = N_Task_Definition
6965             then
6966                if Expander_Active then
6967                   Rewrite (Arg,
6968                     Convert_To (RTE (RE_Any_Priority), Arg));
6969                end if;
6970
6971             --  Anything else is incorrect
6972
6973             else
6974                Pragma_Misplaced;
6975             end if;
6976
6977             if Has_Priority_Pragma (P) then
6978                Error_Pragma ("duplicate pragma% not allowed");
6979             else
6980                Set_Has_Priority_Pragma (P, True);
6981
6982                if Nkind (P) = N_Protected_Definition
6983                     or else
6984                   Nkind (P) = N_Task_Definition
6985                then
6986                   Record_Rep_Item (Defining_Identifier (Parent (P)), N);
6987                   --  exp_ch9 should use this ???
6988                end if;
6989             end if;
6990          end Priority;
6991
6992          --------------------------
6993          -- Propagate_Exceptions --
6994          --------------------------
6995
6996          --  pragma Propagate_Exceptions;
6997
6998          when Pragma_Propagate_Exceptions =>
6999             GNAT_Pragma;
7000             Check_Arg_Count (0);
7001
7002             if In_Extended_Main_Source_Unit (N) then
7003                Propagate_Exceptions := True;
7004             end if;
7005
7006          ------------------
7007          -- Psect_Object --
7008          ------------------
7009
7010          --  pragma Psect_Object (
7011          --        [Internal =>] LOCAL_NAME,
7012          --     [, [External =>] EXTERNAL_SYMBOL]
7013          --     [, [Size     =>] EXTERNAL_SYMBOL]);
7014
7015          when Pragma_Psect_Object | Pragma_Common_Object =>
7016          Psect_Object : declare
7017             Args  : Args_List (1 .. 3);
7018             Names : Name_List (1 .. 3) := (
7019                       Name_Internal,
7020                       Name_External,
7021                       Name_Size);
7022
7023             Internal : Node_Id renames Args (1);
7024             External : Node_Id renames Args (2);
7025             Size     : Node_Id renames Args (3);
7026
7027             R_Internal : Node_Id;
7028             R_External : Node_Id;
7029
7030             MA       : Node_Id;
7031             Str      : String_Id;
7032
7033             Def_Id   : Entity_Id;
7034
7035             procedure Check_Too_Long (Arg : Node_Id);
7036             --  Posts message if the argument is an identifier with more
7037             --  than 31 characters, or a string literal with more than
7038             --  31 characters, and we are operating under VMS
7039
7040             --------------------
7041             -- Check_Too_Long --
7042             --------------------
7043
7044             procedure Check_Too_Long (Arg : Node_Id) is
7045                X : Node_Id := Original_Node (Arg);
7046
7047             begin
7048                if Nkind (X) /= N_String_Literal
7049                     and then
7050                   Nkind (X) /= N_Identifier
7051                then
7052                   Error_Pragma_Arg
7053                     ("inappropriate argument for pragma %", Arg);
7054                end if;
7055
7056                if OpenVMS_On_Target then
7057                   if (Nkind (X) = N_String_Literal
7058                        and then String_Length (Strval (X)) > 31)
7059                     or else
7060                      (Nkind (X) = N_Identifier
7061                        and then Length_Of_Name (Chars (X)) > 31)
7062                   then
7063                      Error_Pragma_Arg
7064                        ("argument for pragma % is longer than 31 characters",
7065                         Arg);
7066                   end if;
7067                end if;
7068             end Check_Too_Long;
7069
7070          --  Start of processing for Common_Object/Psect_Object
7071
7072          begin
7073             GNAT_Pragma;
7074             Gather_Associations (Names, Args);
7075             Process_Extended_Import_Export_Internal_Arg (Internal);
7076
7077             R_Internal := Relocate_Node (Internal);
7078
7079             Def_Id := Entity (R_Internal);
7080
7081             if Ekind (Def_Id) /= E_Constant
7082               and then Ekind (Def_Id) /= E_Variable
7083             then
7084                Error_Pragma_Arg
7085                  ("pragma% must designate an object", Internal);
7086             end if;
7087
7088             Check_Too_Long (R_Internal);
7089
7090             if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
7091                Error_Pragma_Arg
7092                  ("cannot use pragma% for imported/exported object",
7093                   R_Internal);
7094             end if;
7095
7096             if Is_Concurrent_Type (Etype (R_Internal)) then
7097                Error_Pragma_Arg
7098                  ("cannot specify pragma % for task/protected object",
7099                   R_Internal);
7100             end if;
7101
7102             if Is_Psected (Def_Id) then
7103                Error_Msg_N ("?duplicate Psect_Object pragma", N);
7104             else
7105                Set_Is_Psected (Def_Id);
7106             end if;
7107
7108             if Ekind (Def_Id) = E_Constant then
7109                Error_Pragma_Arg
7110                  ("cannot specify pragma % for a constant", R_Internal);
7111             end if;
7112
7113             if Is_Record_Type (Etype (R_Internal)) then
7114                declare
7115                   Ent  : Entity_Id;
7116                   Decl : Entity_Id;
7117
7118                begin
7119                   Ent := First_Entity (Etype (R_Internal));
7120                   while Present (Ent) loop
7121                      Decl := Declaration_Node (Ent);
7122
7123                      if Ekind (Ent) = E_Component
7124                        and then Nkind (Decl) = N_Component_Declaration
7125                        and then Present (Expression (Decl))
7126                      then
7127                         Error_Msg_N
7128                           ("?object for pragma % has defaults", R_Internal);
7129                         exit;
7130
7131                      else
7132                         Next_Entity (Ent);
7133                      end if;
7134                   end loop;
7135                end;
7136             end if;
7137
7138             if Present (Size) then
7139                Check_Too_Long (Size);
7140             end if;
7141
7142             --  Make Psect case-insensitive.
7143
7144             if Present (External) then
7145                Check_Too_Long (External);
7146
7147                if Nkind (External) = N_String_Literal then
7148                   String_To_Name_Buffer (Strval (External));
7149                else
7150                   Get_Name_String (Chars (External));
7151                end if;
7152
7153                Set_All_Upper_Case;
7154                Start_String;
7155                Store_String_Chars (Name_Buffer (1 .. Name_Len));
7156                Str := End_String;
7157                R_External := Make_String_Literal
7158                  (Sloc => Sloc (External), Strval => Str);
7159             else
7160                Get_Name_String (Chars (Internal));
7161                Set_All_Upper_Case;
7162                Start_String;
7163                Store_String_Chars (Name_Buffer (1 .. Name_Len));
7164                Str := End_String;
7165                R_External := Make_String_Literal
7166                  (Sloc => Sloc (Internal), Strval => Str);
7167             end if;
7168
7169             --  Transform into pragma Linker_Section, add attributes to
7170             --  match what DEC Ada does. Ignore size for now?
7171
7172             Rewrite (N,
7173                Make_Pragma
7174                  (Sloc (N),
7175                   Name_Linker_Section,
7176                   New_List
7177                     (Make_Pragma_Argument_Association
7178                        (Sloc => Sloc (R_Internal),
7179                         Expression => R_Internal),
7180                      Make_Pragma_Argument_Association
7181                        (Sloc => Sloc (R_External),
7182                         Expression => R_External))));
7183
7184             Analyze (N);
7185
7186             --  Add Machine_Attribute of "overlaid", so the section overlays
7187             --  other sections of the same name.
7188
7189             Start_String;
7190             Store_String_Chars ("overlaid");
7191             Str := End_String;
7192
7193             MA :=
7194                Make_Pragma
7195                  (Sloc (N),
7196                   Name_Machine_Attribute,
7197                   New_List
7198                     (Make_Pragma_Argument_Association
7199                        (Sloc => Sloc (R_Internal),
7200                         Expression => R_Internal),
7201                      Make_Pragma_Argument_Association
7202                        (Sloc => Sloc (R_External),
7203                         Expression =>
7204                           Make_String_Literal
7205                             (Sloc => Sloc (R_External),
7206                              Strval => Str))));
7207             Analyze (MA);
7208
7209             --  Add Machine_Attribute of "global", so the section is visible
7210             --  everywhere
7211
7212             Start_String;
7213             Store_String_Chars ("global");
7214             Str := End_String;
7215
7216             MA :=
7217                Make_Pragma
7218                  (Sloc (N),
7219                   Name_Machine_Attribute,
7220                   New_List
7221                     (Make_Pragma_Argument_Association
7222                        (Sloc => Sloc (R_Internal),
7223                         Expression => R_Internal),
7224                      Make_Pragma_Argument_Association
7225                        (Sloc => Sloc (R_External),
7226                         Expression =>
7227                           Make_String_Literal
7228                             (Sloc => Sloc (R_External),
7229                              Strval => Str))));
7230             Analyze (MA);
7231
7232             --  Add Machine_Attribute of "initialize", so the section is
7233             --  demand zeroed.
7234
7235             Start_String;
7236             Store_String_Chars ("initialize");
7237             Str := End_String;
7238
7239             MA :=
7240                Make_Pragma
7241                  (Sloc (N),
7242                   Name_Machine_Attribute,
7243                   New_List
7244                     (Make_Pragma_Argument_Association
7245                        (Sloc => Sloc (R_Internal),
7246                         Expression => R_Internal),
7247                      Make_Pragma_Argument_Association
7248                        (Sloc => Sloc (R_External),
7249                         Expression =>
7250                           Make_String_Literal
7251                             (Sloc => Sloc (R_External),
7252                              Strval => Str))));
7253             Analyze (MA);
7254          end Psect_Object;
7255
7256          ----------
7257          -- Pure --
7258          ----------
7259
7260          --  pragma Pure [(library_unit_NAME)];
7261
7262          when Pragma_Pure => Pure : declare
7263             Ent : Entity_Id;
7264          begin
7265             Check_Ada_83_Warning;
7266             Check_Valid_Library_Unit_Pragma;
7267
7268             if Nkind (N) = N_Null_Statement then
7269                return;
7270             end if;
7271
7272             Ent := Find_Lib_Unit_Name;
7273             Set_Is_Pure (Ent);
7274             Set_Suppress_Elaboration_Warnings (Ent);
7275          end Pure;
7276
7277          -------------------
7278          -- Pure_Function --
7279          -------------------
7280
7281          --  pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
7282
7283          when Pragma_Pure_Function => Pure_Function : declare
7284             E_Id   : Node_Id;
7285             E      : Entity_Id;
7286             Def_Id : Entity_Id;
7287
7288          begin
7289             GNAT_Pragma;
7290             Check_Arg_Count (1);
7291             Check_Optional_Identifier (Arg1, Name_Entity);
7292             Check_Arg_Is_Local_Name (Arg1);
7293             E_Id := Expression (Arg1);
7294
7295             if Error_Posted (E_Id) then
7296                return;
7297             end if;
7298
7299             --  Loop through homonyms (overloadings) of referenced entity
7300
7301             E := Entity (E_Id);
7302             while Present (E) loop
7303                Def_Id := Get_Base_Subprogram (E);
7304
7305                if Ekind (Def_Id) /= E_Function
7306                  and then Ekind (Def_Id) /= E_Generic_Function
7307                  and then Ekind (Def_Id) /= E_Operator
7308                then
7309                   Error_Pragma_Arg ("pragma% requires a function name", Arg1);
7310                end if;
7311
7312                Set_Is_Pure (Def_Id);
7313                Set_Has_Pragma_Pure_Function (Def_Id);
7314                E := Homonym (E);
7315             end loop;
7316          end Pure_Function;
7317
7318          --------------------
7319          -- Queuing_Policy --
7320          --------------------
7321
7322          --  pragma Queuing_Policy (policy_IDENTIFIER);
7323
7324          when Pragma_Queuing_Policy => declare
7325             QP : Character;
7326
7327          begin
7328             Check_Ada_83_Warning;
7329             Check_Arg_Count (1);
7330             Check_No_Identifiers;
7331             Check_Arg_Is_Queuing_Policy (Arg1);
7332             Check_Valid_Configuration_Pragma;
7333             Get_Name_String (Chars (Expression (Arg1)));
7334             QP := Fold_Upper (Name_Buffer (1));
7335
7336             if Queuing_Policy /= ' '
7337               and then Queuing_Policy /= QP
7338             then
7339                Error_Msg_Sloc := Queuing_Policy_Sloc;
7340                Error_Pragma ("queuing policy incompatible with policy#");
7341             else
7342                Queuing_Policy := QP;
7343                Queuing_Policy_Sloc := Loc;
7344             end if;
7345          end;
7346
7347          ---------------------------
7348          -- Remote_Call_Interface --
7349          ---------------------------
7350
7351          --  pragma Remote_Call_Interface [(library_unit_NAME)];
7352
7353          when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
7354             Cunit_Node : Node_Id;
7355             Cunit_Ent  : Entity_Id;
7356             K          : Node_Kind;
7357
7358          begin
7359             Check_Ada_83_Warning;
7360             Check_Valid_Library_Unit_Pragma;
7361
7362             if Nkind (N) = N_Null_Statement then
7363                return;
7364             end if;
7365
7366             Cunit_Node := Cunit (Current_Sem_Unit);
7367             K          := Nkind (Unit (Cunit_Node));
7368             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
7369
7370             if K = N_Package_Declaration
7371               or else K = N_Generic_Package_Declaration
7372               or else K = N_Subprogram_Declaration
7373               or else K = N_Generic_Subprogram_Declaration
7374               or else (K = N_Subprogram_Body
7375                          and then Acts_As_Spec (Unit (Cunit_Node)))
7376             then
7377                null;
7378             else
7379                Error_Pragma (
7380                  "pragma% must apply to package or subprogram declaration");
7381             end if;
7382
7383             Set_Is_Remote_Call_Interface (Cunit_Ent);
7384          end Remote_Call_Interface;
7385
7386          ------------------
7387          -- Remote_Types --
7388          ------------------
7389
7390          --  pragma Remote_Types [(library_unit_NAME)];
7391
7392          when Pragma_Remote_Types => Remote_Types : declare
7393             Cunit_Node : Node_Id;
7394             Cunit_Ent  : Entity_Id;
7395
7396          begin
7397             Check_Ada_83_Warning;
7398             Check_Valid_Library_Unit_Pragma;
7399
7400             if Nkind (N) = N_Null_Statement then
7401                return;
7402             end if;
7403
7404             Cunit_Node := Cunit (Current_Sem_Unit);
7405             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
7406
7407             if Nkind (Unit (Cunit_Node)) /= N_Package_Declaration
7408               and then
7409               Nkind (Unit (Cunit_Node)) /= N_Generic_Package_Declaration
7410             then
7411                Error_Pragma (
7412                  "pragma% can only apply to a package declaration");
7413             end if;
7414
7415             Set_Is_Remote_Types (Cunit_Ent);
7416          end Remote_Types;
7417
7418          ---------------
7419          -- Ravenscar --
7420          ---------------
7421
7422          when Pragma_Ravenscar =>
7423             GNAT_Pragma;
7424             Check_Arg_Count (0);
7425             Check_Valid_Configuration_Pragma;
7426             Set_Ravenscar;
7427
7428          -------------------------
7429          -- Restricted_Run_Time --
7430          -------------------------
7431
7432          when Pragma_Restricted_Run_Time =>
7433             GNAT_Pragma;
7434             Check_Arg_Count (0);
7435             Check_Valid_Configuration_Pragma;
7436             Set_Restricted_Profile;
7437
7438          ------------------
7439          -- Restrictions --
7440          ------------------
7441
7442          --  pragma Restrictions (RESTRICTION {, RESTRICTION});
7443
7444          --  RESTRICTION ::=
7445          --    restriction_IDENTIFIER
7446          --  | restriction_parameter_IDENTIFIER => EXPRESSION
7447
7448          when Pragma_Restrictions => Restrictions_Pragma : declare
7449             Arg   : Node_Id;
7450             R_Id  : Restriction_Id;
7451             RP_Id : Restriction_Parameter_Id;
7452             Id    : Name_Id;
7453             Expr  : Node_Id;
7454             Val   : Uint;
7455
7456          begin
7457             Check_Ada_83_Warning;
7458             Check_At_Least_N_Arguments (1);
7459             Check_Valid_Configuration_Pragma;
7460
7461             Arg := Arg1;
7462
7463             while Present (Arg) loop
7464                Id := Chars (Arg);
7465                Expr := Expression (Arg);
7466
7467                --  Case of no restriction identifier
7468
7469                if Id = No_Name then
7470                   if Nkind (Expr) /= N_Identifier then
7471                      Error_Pragma_Arg
7472                        ("invalid form for restriction", Arg);
7473
7474                   else
7475                      R_Id := Get_Restriction_Id (Chars (Expr));
7476
7477                      if R_Id = Not_A_Restriction_Id then
7478                         Error_Pragma_Arg
7479                           ("invalid restriction identifier", Arg);
7480
7481                      --  Restriction is active
7482
7483                      else
7484                         if Implementation_Restriction (R_Id) then
7485                            Check_Restriction
7486                              (No_Implementation_Restrictions, Arg);
7487                         end if;
7488
7489                         Restrictions (R_Id) := True;
7490                         Restrictions_Loc (R_Id) := Sloc (N);
7491
7492                         --  Record the restriction if we are in the main unit,
7493                         --  or in the extended main unit. The reason that we
7494                         --  test separately for Main_Unit is that gnat.adc is
7495                         --  processed with Current_Sem_Unit = Main_Unit, but
7496                         --  nodes in gnat.adc do not appear to be the extended
7497                         --  main source unit (they probably should do ???)
7498
7499                         if Current_Sem_Unit = Main_Unit
7500                           or else In_Extended_Main_Source_Unit (N)
7501                         then
7502                            Main_Restrictions (R_Id) := True;
7503                         end if;
7504
7505                         --  A very special case that must be processed here:
7506                         --  pragma Restrictions (No_Exceptions) turns off all
7507                         --  run-time checking. This is a bit dubious in terms
7508                         --  of the formal language definition, but it is what
7509                         --  is intended by the wording of RM H.4(12).
7510
7511                         if R_Id = No_Exceptions then
7512                            Scope_Suppress := (others => True);
7513                         end if;
7514                      end if;
7515                   end if;
7516
7517                --  Case of restriction identifier present
7518
7519                else
7520                   RP_Id := Get_Restriction_Parameter_Id (Id);
7521                   Analyze_And_Resolve (Expr, Any_Integer);
7522
7523                   if RP_Id = Not_A_Restriction_Parameter_Id then
7524                      Error_Pragma_Arg
7525                        ("invalid restriction parameter identifier", Arg);
7526
7527                   elsif not Is_OK_Static_Expression (Expr)
7528                     or else not Is_Integer_Type (Etype (Expr))
7529                     or else Expr_Value (Expr) < 0
7530                   then
7531                      Error_Pragma_Arg
7532                        ("value must be non-negative static integer", Arg);
7533
7534                   --  Restriction pragma is active
7535
7536                   else
7537                      Val := Expr_Value (Expr);
7538
7539                      --  Record pragma if most restrictive so far
7540
7541                      if Restriction_Parameters (RP_Id) = No_Uint
7542                        or else Val < Restriction_Parameters (RP_Id)
7543                      then
7544                         Restriction_Parameters (RP_Id) := Expr_Value (Expr);
7545                         Restriction_Parameters_Loc (RP_Id) := Sloc (N);
7546                      end if;
7547                   end if;
7548                end if;
7549
7550                Next (Arg);
7551             end loop;
7552          end Restrictions_Pragma;
7553
7554          ----------------
7555          -- Reviewable --
7556          ----------------
7557
7558          --  pragma Reviewable;
7559
7560          when Pragma_Reviewable =>
7561             Check_Ada_83_Warning;
7562             Check_Arg_Count (0);
7563
7564          -------------------
7565          -- Share_Generic --
7566          -------------------
7567
7568          --  pragma Share_Generic (NAME {, NAME});
7569
7570          when Pragma_Share_Generic =>
7571             GNAT_Pragma;
7572             Process_Generic_List;
7573
7574          ------------
7575          -- Shared --
7576          ------------
7577
7578          --  pragma Shared (LOCAL_NAME);
7579
7580          when Pragma_Shared =>
7581             GNAT_Pragma;
7582             Process_Atomic_Shared_Volatile;
7583
7584          --------------------
7585          -- Shared_Passive --
7586          --------------------
7587
7588          --  pragma Shared_Passive [(library_unit_NAME)];
7589
7590          --  Set the flag Is_Shared_Passive of program unit name entity
7591
7592          when Pragma_Shared_Passive => Shared_Passive : declare
7593             Cunit_Node : Node_Id;
7594             Cunit_Ent  : Entity_Id;
7595
7596          begin
7597             Check_Ada_83_Warning;
7598             Check_Valid_Library_Unit_Pragma;
7599
7600             if Nkind (N) = N_Null_Statement then
7601                return;
7602             end if;
7603
7604             Cunit_Node := Cunit (Current_Sem_Unit);
7605             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
7606
7607             if Nkind (Unit (Cunit_Node)) /= N_Package_Declaration
7608               and then
7609               Nkind (Unit (Cunit_Node)) /= N_Generic_Package_Declaration
7610             then
7611                Error_Pragma (
7612                  "pragma% can only apply to a package declaration");
7613             end if;
7614
7615             Set_Is_Shared_Passive (Cunit_Ent);
7616          end Shared_Passive;
7617
7618          ----------------------
7619          -- Source_File_Name --
7620          ----------------------
7621
7622          --  pragma Source_File_Name (
7623          --    [UNIT_NAME =>] unit_NAME,
7624          --    [BODY_FILE_NAME | SPEC_FILE_NAME] => STRING_LITERAL);
7625
7626          --  No processing here. Processing was completed during parsing,
7627          --  since we need to have file names set as early as possible.
7628          --  Units are loaded well before semantic processing starts.
7629
7630          --  The only processing we defer to this point is the check
7631          --  for correct placement.
7632
7633          when Pragma_Source_File_Name =>
7634             GNAT_Pragma;
7635             Check_Valid_Configuration_Pragma;
7636
7637          ----------------------
7638          -- Source_Reference --
7639          ----------------------
7640
7641          --  pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
7642
7643          --  Nothing to do, all processing completed in Par.Prag, since we
7644          --  need the information for possible parser messages that are output
7645
7646          when Pragma_Source_Reference =>
7647             GNAT_Pragma;
7648
7649          ------------------
7650          -- Storage_Size --
7651          ------------------
7652
7653          --  pragma Storage_Size (EXPRESSION);
7654
7655          when Pragma_Storage_Size => Storage_Size : declare
7656             P : constant Node_Id := Parent (N);
7657             X : Node_Id;
7658
7659          begin
7660             Check_No_Identifiers;
7661             Check_Arg_Count (1);
7662
7663             --  Set In_Default_Expression for per-object case???
7664
7665             X := Expression (Arg1);
7666             Analyze_And_Resolve (X, Any_Integer);
7667
7668             if not Is_Static_Expression (X) then
7669                Check_Restriction (Static_Storage_Size, X);
7670             end if;
7671
7672             if Nkind (P) /= N_Task_Definition then
7673                Pragma_Misplaced;
7674                return;
7675
7676             else
7677                if Has_Storage_Size_Pragma (P) then
7678                   Error_Pragma ("duplicate pragma% not allowed");
7679                else
7680                   Set_Has_Storage_Size_Pragma (P, True);
7681                end if;
7682
7683                Record_Rep_Item (Defining_Identifier (Parent (P)), N);
7684                --  ???  exp_ch9 should use this!
7685             end if;
7686          end Storage_Size;
7687
7688          ------------------
7689          -- Storage_Unit --
7690          ------------------
7691
7692          --  pragma Storage_Unit (NUMERIC_LITERAL);
7693
7694          --  Only permitted argument is System'Storage_Unit value
7695
7696          when Pragma_Storage_Unit =>
7697             Check_No_Identifiers;
7698             Check_Arg_Count (1);
7699             Check_Arg_Is_Integer_Literal (Arg1);
7700
7701             if Intval (Expression (Arg1)) /=
7702               UI_From_Int (Ttypes.System_Storage_Unit)
7703             then
7704                Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
7705                Error_Pragma_Arg
7706                  ("the only allowed argument for pragma% is ^", Arg1);
7707             end if;
7708
7709          --------------------
7710          -- Stream_Convert --
7711          --------------------
7712
7713          --  pragma Stream_Convert (
7714          --    [Entity =>] type_LOCAL_NAME,
7715          --    [Read   =>] function_NAME,
7716          --    [Write  =>] function NAME);
7717
7718          when Pragma_Stream_Convert => Stream_Convert : declare
7719
7720             procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
7721             --  Check that the given argument is the name of a local
7722             --  function of one argument that is not overloaded earlier
7723             --  in the current local scope. A check is also made that the
7724             --  argument is a function with one parameter.
7725
7726             --------------------------------------
7727             -- Check_OK_Stream_Convert_Function --
7728             --------------------------------------
7729
7730             procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
7731                Ent : Entity_Id;
7732
7733             begin
7734                Check_Arg_Is_Local_Name (Arg);
7735                Ent := Entity (Expression (Arg));
7736
7737                if Has_Homonym (Ent) then
7738                   Error_Pragma_Arg
7739                     ("argument for pragma% may not be overloaded", Arg);
7740                end if;
7741
7742                if Ekind (Ent) /= E_Function
7743                  or else No (First_Formal (Ent))
7744                  or else Present (Next_Formal (First_Formal (Ent)))
7745                then
7746                   Error_Pragma_Arg
7747                     ("argument for pragma% must be" &
7748                      " function of one argument", Arg);
7749                end if;
7750             end Check_OK_Stream_Convert_Function;
7751
7752          --  Start of procecessing for Stream_Convert
7753
7754          begin
7755             GNAT_Pragma;
7756             Check_Arg_Count (3);
7757             Check_Optional_Identifier (Arg1, Name_Entity);
7758             Check_Optional_Identifier (Arg2, Name_Read);
7759             Check_Optional_Identifier (Arg3, Name_Write);
7760             Check_Arg_Is_Local_Name (Arg1);
7761             Check_OK_Stream_Convert_Function (Arg2);
7762             Check_OK_Stream_Convert_Function (Arg3);
7763
7764             declare
7765                Typ   : constant Entity_Id :=
7766                          Underlying_Type (Entity (Expression (Arg1)));
7767                Read  : constant Entity_Id := Entity (Expression (Arg2));
7768                Write : constant Entity_Id := Entity (Expression (Arg3));
7769
7770             begin
7771                if Etype (Typ) = Any_Type
7772                     or else
7773                   Etype (Read) = Any_Type
7774                     or else
7775                   Etype (Write) = Any_Type
7776                then
7777                   return;
7778                end if;
7779
7780                Check_First_Subtype (Arg1);
7781
7782                if Rep_Item_Too_Early (Typ, N)
7783                     or else
7784                   Rep_Item_Too_Late (Typ, N)
7785                then
7786                   return;
7787                end if;
7788
7789                if Underlying_Type (Etype (Read)) /= Typ then
7790                   Error_Pragma_Arg
7791                     ("incorrect return type for function&", Arg2);
7792                end if;
7793
7794                if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
7795                   Error_Pragma_Arg
7796                     ("incorrect parameter type for function&", Arg3);
7797                end if;
7798
7799                if Underlying_Type (Etype (First_Formal (Read))) /=
7800                   Underlying_Type (Etype (Write))
7801                then
7802                   Error_Pragma_Arg
7803                     ("result type of & does not match Read parameter type",
7804                      Arg3);
7805                end if;
7806             end;
7807          end Stream_Convert;
7808
7809          -------------------------
7810          -- Style_Checks (GNAT) --
7811          -------------------------
7812
7813          --  pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
7814
7815          --  This is processed by the parser since some of the style
7816          --  checks take place during source scanning and parsing. This
7817          --  means that we don't need to issue error messages here.
7818
7819          when Pragma_Style_Checks => Style_Checks : declare
7820             A  : constant Node_Id   := Expression (Arg1);
7821             S  : String_Id;
7822             C  : Char_Code;
7823
7824          begin
7825             GNAT_Pragma;
7826             Check_No_Identifiers;
7827
7828             --  Two argument form
7829
7830             if Arg_Count = 2 then
7831                Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
7832
7833                declare
7834                   E_Id : Node_Id;
7835                   E    : Entity_Id;
7836
7837                begin
7838                   E_Id := Expression (Arg2);
7839                   Analyze (E_Id);
7840
7841                   if not Is_Entity_Name (E_Id) then
7842                      Error_Pragma_Arg
7843                        ("second argument of pragma% must be entity name",
7844                         Arg2);
7845                   end if;
7846
7847                   E := Entity (E_Id);
7848
7849                   if E = Any_Id then
7850                      return;
7851                   else
7852                      loop
7853                         Set_Suppress_Style_Checks (E,
7854                           (Chars (Expression (Arg1)) = Name_Off));
7855                         exit when No (Homonym (E));
7856                         E := Homonym (E);
7857                      end loop;
7858                   end if;
7859                end;
7860
7861             --  One argument form
7862
7863             else
7864                Check_Arg_Count (1);
7865
7866                if Nkind (A) = N_String_Literal then
7867                   S   := Strval (A);
7868
7869                   declare
7870                      Slen    : Natural := Natural (String_Length (S));
7871                      Options : String (1 .. Slen);
7872                      J       : Natural;
7873
7874                   begin
7875                      J := 1;
7876                      loop
7877                         C := Get_String_Char (S, Int (J));
7878                         exit when not In_Character_Range (C);
7879                         Options (J) := Get_Character (C);
7880
7881                         if J = Slen then
7882                            Set_Style_Check_Options (Options);
7883                            exit;
7884                         else
7885                            J := J + 1;
7886                         end if;
7887                      end loop;
7888                   end;
7889
7890                elsif Nkind (A) = N_Identifier then
7891
7892                   if Chars (A) = Name_All_Checks then
7893                      Set_Default_Style_Check_Options;
7894
7895                   elsif Chars (A) = Name_On then
7896                      Style_Check := True;
7897
7898                   elsif Chars (A) = Name_Off then
7899                      Style_Check := False;
7900
7901                   end if;
7902                end if;
7903             end if;
7904          end Style_Checks;
7905
7906          --------------
7907          -- Subtitle --
7908          --------------
7909
7910          --  pragma Subtitle ([Subtitle =>] STRING_LITERAL);
7911
7912          when Pragma_Subtitle =>
7913             GNAT_Pragma;
7914             Check_Arg_Count (1);
7915             Check_Optional_Identifier (Arg1, Name_Subtitle);
7916             Check_Arg_Is_String_Literal (Arg1);
7917
7918          --------------
7919          -- Suppress --
7920          --------------
7921
7922          --  pragma Suppress (IDENTIFIER [, [On =>] NAME]);
7923
7924          when Pragma_Suppress =>
7925             Process_Suppress_Unsuppress (True);
7926
7927          ------------------
7928          -- Suppress_All --
7929          ------------------
7930
7931          --  pragma Suppress_All;
7932
7933          --  The only check made here is that the pragma appears in the
7934          --  proper place, i.e. following a compilation unit. If indeed
7935          --  it appears in this context, then the parser has already
7936          --  inserted an equivalent pragma Suppress (All_Checks) to get
7937          --  the required effect.
7938
7939          when Pragma_Suppress_All =>
7940             GNAT_Pragma;
7941             Check_Arg_Count (0);
7942
7943             if Nkind (Parent (N)) /= N_Compilation_Unit_Aux
7944               or else not Is_List_Member (N)
7945               or else List_Containing (N) /= Pragmas_After (Parent (N))
7946             then
7947                Error_Pragma
7948                  ("misplaced pragma%, must follow compilation unit");
7949             end if;
7950
7951          -------------------------
7952          -- Suppress_Debug_Info --
7953          -------------------------
7954
7955          --  pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
7956
7957          when Pragma_Suppress_Debug_Info =>
7958             GNAT_Pragma;
7959             Check_Arg_Count (1);
7960             Check_Arg_Is_Local_Name (Arg1);
7961             Check_Optional_Identifier (Arg1, Name_Entity);
7962             Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
7963
7964          -----------------------------
7965          -- Suppress_Initialization --
7966          -----------------------------
7967
7968          --  pragma Suppress_Initialization ([Entity =>] type_Name);
7969
7970          when Pragma_Suppress_Initialization => Suppress_Init : declare
7971             E_Id : Node_Id;
7972             E    : Entity_Id;
7973
7974          begin
7975             GNAT_Pragma;
7976             Check_Arg_Count (1);
7977             Check_Optional_Identifier (Arg1, Name_Entity);
7978             Check_Arg_Is_Local_Name (Arg1);
7979
7980             E_Id := Expression (Arg1);
7981
7982             if Etype (E_Id) = Any_Type then
7983                return;
7984             end if;
7985
7986             E := Entity (E_Id);
7987
7988             if Is_Type (E) then
7989                if Is_Incomplete_Or_Private_Type (E) then
7990                   if No (Full_View (Base_Type (E))) then
7991                      Error_Pragma_Arg
7992                        ("argument of pragma% cannot be an incomplete type",
7993                          Arg1);
7994                   else
7995                      Set_Suppress_Init_Proc (Full_View (Base_Type (E)));
7996                   end if;
7997                else
7998                   Set_Suppress_Init_Proc (Base_Type (E));
7999                end if;
8000
8001             else
8002                Error_Pragma_Arg
8003                  ("pragma% requires argument that is a type name", Arg1);
8004             end if;
8005          end Suppress_Init;
8006
8007          -----------------
8008          -- System_Name --
8009          -----------------
8010
8011          --  pragma System_Name (DIRECT_NAME);
8012
8013          --  Syntax check: one argument, which must be the identifier GNAT
8014          --  or the identifier GCC, no other identifiers are acceptable.
8015
8016          when Pragma_System_Name =>
8017             Check_No_Identifiers;
8018             Check_Arg_Count (1);
8019             Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
8020
8021          -----------------------------
8022          -- Task_Dispatching_Policy --
8023          -----------------------------
8024
8025          --  pragma Task_Dispatching_Policy (policy_IDENTIFIER);
8026
8027          when Pragma_Task_Dispatching_Policy => declare
8028             DP : Character;
8029
8030          begin
8031             Check_Ada_83_Warning;
8032             Check_Arg_Count (1);
8033             Check_No_Identifiers;
8034             Check_Arg_Is_Task_Dispatching_Policy (Arg1);
8035             Check_Valid_Configuration_Pragma;
8036             Get_Name_String (Chars (Expression (Arg1)));
8037             DP := Fold_Upper (Name_Buffer (1));
8038
8039             if Task_Dispatching_Policy /= ' '
8040               and then Task_Dispatching_Policy /= DP
8041             then
8042                Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
8043                Error_Pragma
8044                  ("task dispatching policy incompatible with policy#");
8045             else
8046                Task_Dispatching_Policy := DP;
8047                Task_Dispatching_Policy_Sloc := Loc;
8048             end if;
8049          end;
8050
8051          --------------
8052          -- Task_Info --
8053          --------------
8054
8055          --  pragma Task_Info (EXPRESSION);
8056
8057          when Pragma_Task_Info => Task_Info : declare
8058             P : constant Node_Id := Parent (N);
8059
8060          begin
8061             GNAT_Pragma;
8062
8063             if Nkind (P) /= N_Task_Definition then
8064                Error_Pragma ("pragma% must appear in task definition");
8065             end if;
8066
8067             Check_No_Identifiers;
8068             Check_Arg_Count (1);
8069
8070             Analyze_And_Resolve (Expression (Arg1), RTE (RE_Task_Info_Type));
8071
8072             if Etype (Expression (Arg1)) = Any_Type then
8073                return;
8074             end if;
8075
8076             if Has_Task_Info_Pragma (P) then
8077                Error_Pragma ("duplicate pragma% not allowed");
8078             else
8079                Set_Has_Task_Info_Pragma (P, True);
8080             end if;
8081          end Task_Info;
8082
8083          ---------------
8084          -- Task_Name --
8085          ---------------
8086
8087          --  pragma Task_Name (string_EXPRESSION);
8088
8089          when Pragma_Task_Name => Task_Name : declare
8090          --  pragma Priority (EXPRESSION);
8091
8092             P   : constant Node_Id := Parent (N);
8093             Arg : Node_Id;
8094
8095          begin
8096             Check_No_Identifiers;
8097             Check_Arg_Count (1);
8098
8099             Arg := Expression (Arg1);
8100             Analyze_And_Resolve (Arg, Standard_String);
8101
8102             if Nkind (P) /= N_Task_Definition then
8103                Pragma_Misplaced;
8104             end if;
8105
8106             if Has_Task_Name_Pragma (P) then
8107                Error_Pragma ("duplicate pragma% not allowed");
8108             else
8109                Set_Has_Task_Name_Pragma (P, True);
8110                Record_Rep_Item (Defining_Identifier (Parent (P)), N);
8111             end if;
8112          end Task_Name;
8113
8114          ------------------
8115          -- Task_Storage --
8116          ------------------
8117
8118          --  pragma Task_Storage (
8119          --     [Task_Type =>] LOCAL_NAME,
8120          --     [Top_Guard =>] static_integer_EXPRESSION);
8121
8122          when Pragma_Task_Storage => Task_Storage : declare
8123             Args  : Args_List (1 .. 2);
8124             Names : Name_List (1 .. 2) := (
8125                       Name_Task_Type,
8126                       Name_Top_Guard);
8127
8128             Task_Type : Node_Id renames Args (1);
8129             Top_Guard : Node_Id renames Args (2);
8130
8131             Ent : Entity_Id;
8132
8133          begin
8134             GNAT_Pragma;
8135             Gather_Associations (Names, Args);
8136             Check_Arg_Is_Local_Name (Task_Type);
8137
8138             Ent := Entity (Task_Type);
8139
8140             if not Is_Task_Type (Ent) then
8141                Error_Pragma_Arg
8142                  ("argument for pragma% must be task type", Task_Type);
8143             end if;
8144
8145             if No (Top_Guard) then
8146                Error_Pragma_Arg
8147                  ("pragma% takes two arguments", Task_Type);
8148             else
8149                Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
8150             end if;
8151
8152             Check_First_Subtype (Task_Type);
8153
8154             if Rep_Item_Too_Late (Ent, N) then
8155                raise Pragma_Exit;
8156             end if;
8157          end Task_Storage;
8158
8159          ----------------
8160          -- Time_Slice --
8161          ----------------
8162
8163          --  pragma Time_Slice (static_duration_EXPRESSION);
8164
8165          when Pragma_Time_Slice => Time_Slice : declare
8166             Val : Ureal;
8167             Nod : Node_Id;
8168
8169          begin
8170             GNAT_Pragma;
8171             Check_Arg_Count (1);
8172             Check_No_Identifiers;
8173             Check_In_Main_Program;
8174             Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
8175
8176             if not Error_Posted (Arg1) then
8177                Nod := Next (N);
8178                while Present (Nod) loop
8179                   if Nkind (Nod) = N_Pragma
8180                     and then Chars (Nod) = Name_Time_Slice
8181                   then
8182                      Error_Msg_Name_1 := Chars (N);
8183                      Error_Msg_N ("duplicate pragma% not permitted", Nod);
8184                   end if;
8185
8186                   Next (Nod);
8187                end loop;
8188             end if;
8189
8190             --  Process only if in main unit
8191
8192             if Get_Source_Unit (Loc) = Main_Unit then
8193                Opt.Time_Slice_Set := True;
8194                Val := Expr_Value_R (Expression (Arg1));
8195
8196                if Val <= Ureal_0 then
8197                   Opt.Time_Slice_Value := 0;
8198
8199                elsif Val > UR_From_Uint (UI_From_Int (1000)) then
8200                   Opt.Time_Slice_Value := 1_000_000_000;
8201
8202                else
8203                   Opt.Time_Slice_Value :=
8204                     UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
8205                end if;
8206             end if;
8207          end Time_Slice;
8208
8209          -----------
8210          -- Title --
8211          -----------
8212
8213          --  pragma Title (TITLING_OPTION [, TITLING OPTION]);
8214
8215          --   TITLING_OPTION ::=
8216          --     [Title =>] STRING_LITERAL
8217          --   | [Subtitle =>] STRING_LITERAL
8218
8219          when Pragma_Title => Title : declare
8220             Args  : Args_List (1 .. 2);
8221             Names : Name_List (1 .. 2) := (
8222                       Name_Title,
8223                       Name_Subtitle);
8224
8225          begin
8226             GNAT_Pragma;
8227             Gather_Associations (Names, Args);
8228
8229             for J in 1 .. 2 loop
8230                if Present (Args (J)) then
8231                   Check_Arg_Is_String_Literal (Args (J));
8232                end if;
8233             end loop;
8234          end Title;
8235
8236          ---------------------
8237          -- Unchecked_Union --
8238          ---------------------
8239
8240          --  pragma Unchecked_Union (first_subtype_LOCAL_NAME)
8241
8242          when Pragma_Unchecked_Union => Unchecked_Union : declare
8243             Assoc   : Node_Id := Arg1;
8244             Type_Id : Node_Id := Expression (Assoc);
8245             Typ     : Entity_Id;
8246             Discr   : Entity_Id;
8247             Tdef    : Node_Id;
8248             Clist   : Node_Id;
8249             Vpart   : Node_Id;
8250             Comp    : Node_Id;
8251             Variant : Node_Id;
8252
8253          begin
8254             GNAT_Pragma;
8255             Check_No_Identifiers;
8256             Check_Arg_Count (1);
8257             Check_Arg_Is_Local_Name (Arg1);
8258
8259             Find_Type (Type_Id);
8260             Typ := Entity (Type_Id);
8261
8262             if Typ = Any_Type
8263               or else Rep_Item_Too_Early (Typ, N)
8264             then
8265                return;
8266             else
8267                Typ := Underlying_Type (Typ);
8268             end if;
8269
8270             if Rep_Item_Too_Late (Typ, N) then
8271                return;
8272             end if;
8273
8274             Check_First_Subtype (Arg1);
8275
8276             --  Note remaining cases are references to a type in the current
8277             --  declarative part. If we find an error, we post the error on
8278             --  the relevant type declaration at an appropriate point.
8279
8280             if not Is_Record_Type (Typ) then
8281                Error_Msg_N ("Unchecked_Union must be record type", Typ);
8282                return;
8283
8284             elsif Is_Tagged_Type (Typ) then
8285                Error_Msg_N ("Unchecked_Union must not be tagged", Typ);
8286                return;
8287
8288             elsif Is_Limited_Type (Typ) then
8289                Error_Msg_N
8290                  ("Unchecked_Union must not be limited record type", Typ);
8291                return;
8292
8293             else
8294                if not Has_Discriminants (Typ) then
8295                   Error_Msg_N
8296                     ("Unchecked_Union must have one discriminant", Typ);
8297                   return;
8298                end if;
8299
8300                Discr := First_Discriminant (Typ);
8301
8302                if Present (Next_Discriminant (Discr)) then
8303                   Error_Msg_N
8304                     ("Unchecked_Union must have exactly one discriminant",
8305                      Next_Discriminant (Discr));
8306                   return;
8307                end if;
8308
8309                if No (Discriminant_Default_Value (Discr)) then
8310                   Error_Msg_N
8311                     ("Unchecked_Union discriminant must have default value",
8312                      Discr);
8313                end if;
8314
8315                Tdef  := Type_Definition (Declaration_Node (Typ));
8316                Clist := Component_List (Tdef);
8317
8318                if No (Clist) or else No (Variant_Part (Clist)) then
8319                   Error_Msg_N
8320                     ("Unchecked_Union must have variant part",
8321                      Tdef);
8322                   return;
8323                end if;
8324
8325                Vpart := Variant_Part (Clist);
8326
8327                if Is_Non_Empty_List (Component_Items (Clist)) then
8328                   Error_Msg_N
8329                     ("components before variant not allowed " &
8330                      "in Unchecked_Union",
8331                      First (Component_Items (Clist)));
8332                end if;
8333
8334                Variant := First (Variants (Vpart));
8335                while Present (Variant) loop
8336                   Clist := Component_List (Variant);
8337
8338                   if Present (Variant_Part (Clist)) then
8339                      Error_Msg_N
8340                        ("Unchecked_Union may not have nested variants",
8341                         Variant_Part (Clist));
8342                   end if;
8343
8344                   if not Is_Non_Empty_List (Component_Items (Clist)) then
8345                      Error_Msg_N
8346                        ("Unchecked_Union may not have empty component list",
8347                         Variant);
8348                      return;
8349                   end if;
8350
8351                   Comp := First (Component_Items (Clist));
8352
8353                   if Nkind (Comp) = N_Component_Declaration then
8354
8355                      if Present (Expression (Comp)) then
8356                         Error_Msg_N
8357                           ("default initialization not allowed " &
8358                            "in Unchecked_Union",
8359                            Expression (Comp));
8360                      end if;
8361
8362                      declare
8363                         Sindic : constant Node_Id :=
8364                                    Subtype_Indication (Comp);
8365
8366                      begin
8367                         if Nkind (Sindic) = N_Subtype_Indication then
8368                            Check_Static_Constraint (Constraint (Sindic));
8369                         end if;
8370                      end;
8371                   end if;
8372
8373                   if Present (Next (Comp)) then
8374                      Error_Msg_N
8375                        ("Unchecked_Union variant can have only one component",
8376                         Next (Comp));
8377                   end if;
8378
8379                   Next (Variant);
8380                end loop;
8381             end if;
8382
8383             Set_Is_Unchecked_Union           (Typ, True);
8384             Set_Suppress_Discriminant_Checks (Typ, True);
8385             Set_Convention                   (Typ, Convention_C);
8386
8387             Set_Has_Unchecked_Union (Base_Type (Typ), True);
8388             Set_Is_Unchecked_Union  (Base_Type (Typ), True);
8389
8390          end Unchecked_Union;
8391
8392          ------------------------
8393          -- Unimplemented_Unit --
8394          ------------------------
8395
8396          --  pragma Unimplemented_Unit;
8397
8398          --  Note: this only gives an error if we are generating code,
8399          --  or if we are in a generic library unit (where the pragma
8400          --  appears in the body, not in the spec).
8401
8402          when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
8403             Cunitent : Entity_Id := Cunit_Entity (Get_Source_Unit (Loc));
8404             Ent_Kind : Entity_Kind := Ekind (Cunitent);
8405
8406          begin
8407             GNAT_Pragma;
8408             Check_Arg_Count (0);
8409
8410             if Operating_Mode = Generate_Code
8411               or else Ent_Kind = E_Generic_Function
8412               or else Ent_Kind = E_Generic_Procedure
8413               or else Ent_Kind = E_Generic_Package
8414             then
8415                Get_Name_String (Chars (Cunitent));
8416                Set_Casing (Mixed_Case);
8417                Write_Str (Name_Buffer (1 .. Name_Len));
8418                Write_Str (" is not implemented");
8419                Write_Eol;
8420                raise Unrecoverable_Error;
8421             end if;
8422          end Unimplemented_Unit;
8423
8424          --------------------
8425          -- Universal_Data --
8426          --------------------
8427
8428          --  pragma Universal_Data;
8429
8430          when Pragma_Universal_Data =>
8431             GNAT_Pragma;
8432             Check_Arg_Count (0);
8433             Check_Valid_Library_Unit_Pragma;
8434
8435             if not AAMP_On_Target then
8436                Error_Pragma ("?pragma% ignored (applies only to AAMP)");
8437             end if;
8438
8439          ------------------
8440          -- Unreferenced --
8441          ------------------
8442
8443          --  pragma Unreferenced (local_Name {, local_Name});
8444
8445          when Pragma_Unreferenced => Unreferenced : declare
8446             Arg_Node : Node_Id;
8447             Arg_Expr : Node_Id;
8448
8449          begin
8450             GNAT_Pragma;
8451             Check_At_Least_N_Arguments (1);
8452
8453             Arg_Node := Arg1;
8454
8455             while Present (Arg_Node) loop
8456                Check_No_Identifier (Arg_Node);
8457
8458                --  Note that the analyze call done by Check_Arg_Is_Local_Name
8459                --  will in fact generate a reference, so that the entity will
8460                --  have a reference, which will inhibit any warnings about it
8461                --  not being referenced, and also properly show up in the ali
8462                --  file as a reference. But this reference is recorded before
8463                --  the Has_Pragma_Unreferenced flag is set, so that no warning
8464                --  is generated for this reference.
8465
8466                Check_Arg_Is_Local_Name (Arg_Node);
8467                Arg_Expr := Get_Pragma_Arg (Arg_Node);
8468
8469                if Is_Entity_Name (Arg_Expr) then
8470                   Set_Has_Pragma_Unreferenced (Entity (Arg_Expr));
8471                end if;
8472
8473                Next (Arg_Node);
8474             end loop;
8475          end Unreferenced;
8476
8477          ------------------------------
8478          -- Unreserve_All_Interrupts --
8479          ------------------------------
8480
8481          --  pragma Unreserve_All_Interrupts;
8482
8483          when Pragma_Unreserve_All_Interrupts =>
8484             GNAT_Pragma;
8485             Check_Arg_Count (0);
8486
8487             if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
8488                Unreserve_All_Interrupts := True;
8489             end if;
8490
8491          ----------------
8492          -- Unsuppress --
8493          ----------------
8494
8495          --  pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
8496
8497          when Pragma_Unsuppress =>
8498             GNAT_Pragma;
8499             Process_Suppress_Unsuppress (False);
8500
8501          -------------------
8502          -- Use_VADS_Size --
8503          -------------------
8504
8505          --  pragma Use_VADS_Size;
8506
8507          when Pragma_Use_VADS_Size =>
8508             GNAT_Pragma;
8509             Check_Arg_Count (0);
8510             Check_Valid_Configuration_Pragma;
8511             Use_VADS_Size := True;
8512
8513          ---------------------
8514          -- Validity_Checks --
8515          ---------------------
8516
8517          --  pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
8518
8519          when Pragma_Validity_Checks => Validity_Checks : declare
8520             A  : constant Node_Id   := Expression (Arg1);
8521             S  : String_Id;
8522             C  : Char_Code;
8523
8524          begin
8525             GNAT_Pragma;
8526             Check_Arg_Count (1);
8527             Check_No_Identifiers;
8528
8529             if Nkind (A) = N_String_Literal then
8530                S   := Strval (A);
8531
8532                declare
8533                   Slen    : Natural := Natural (String_Length (S));
8534                   Options : String (1 .. Slen);
8535                   J       : Natural;
8536
8537                begin
8538                   J := 1;
8539                   loop
8540                      C := Get_String_Char (S, Int (J));
8541                      exit when not In_Character_Range (C);
8542                      Options (J) := Get_Character (C);
8543
8544                      if J = Slen then
8545                         Set_Validity_Check_Options (Options);
8546                         exit;
8547                      else
8548                         J := J + 1;
8549                      end if;
8550                   end loop;
8551                end;
8552
8553             elsif Nkind (A) = N_Identifier then
8554
8555                if Chars (A) = Name_All_Checks then
8556                   Set_Validity_Check_Options ("a");
8557
8558                elsif Chars (A) = Name_On then
8559                   Validity_Checks_On := True;
8560
8561                elsif Chars (A) = Name_Off then
8562                   Validity_Checks_On := False;
8563
8564                end if;
8565             end if;
8566          end Validity_Checks;
8567
8568          --------------
8569          -- Volatile --
8570          --------------
8571
8572          --  pragma Volatile (LOCAL_NAME);
8573
8574          when Pragma_Volatile =>
8575             Process_Atomic_Shared_Volatile;
8576
8577          -------------------------
8578          -- Volatile_Components --
8579          -------------------------
8580
8581          --  pragma Volatile_Components (array_LOCAL_NAME);
8582
8583          --  Volatile is handled by the same circuit as Atomic_Components
8584
8585          --------------
8586          -- Warnings --
8587          --------------
8588
8589          --  pragma Warnings (On | Off, [LOCAL_NAME])
8590
8591          when Pragma_Warnings =>
8592             GNAT_Pragma;
8593             Check_At_Least_N_Arguments (1);
8594             Check_At_Most_N_Arguments (2);
8595             Check_No_Identifiers;
8596
8597             --  One argument case was processed by parser in Par.Prag
8598
8599             if Arg_Count /= 1 then
8600                Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
8601                Check_Arg_Count (2);
8602
8603                declare
8604                   E_Id : Node_Id;
8605                   E    : Entity_Id;
8606
8607                begin
8608                   E_Id := Expression (Arg2);
8609                   Analyze (E_Id);
8610
8611                   if not Is_Entity_Name (E_Id) then
8612                      Error_Pragma_Arg
8613                        ("second argument of pragma% must be entity name",
8614                         Arg2);
8615                   end if;
8616
8617                   E := Entity (E_Id);
8618
8619                   if E = Any_Id then
8620                      return;
8621                   else
8622                      loop
8623                         Set_Warnings_Off (E,
8624                           (Chars (Expression (Arg1)) = Name_Off));
8625
8626                         if Is_Enumeration_Type (E) then
8627                            declare
8628                               Lit : Entity_Id := First_Literal (E);
8629
8630                            begin
8631                               while Present (Lit) loop
8632                                  Set_Warnings_Off (Lit);
8633                                  Next_Literal (Lit);
8634                               end loop;
8635                            end;
8636                         end if;
8637
8638                         exit when No (Homonym (E));
8639                         E := Homonym (E);
8640                      end loop;
8641                   end if;
8642                end;
8643             end if;
8644
8645          -------------------
8646          -- Weak_External --
8647          -------------------
8648
8649          --  pragma Weak_External ([Entity =>] LOCAL_NAME);
8650
8651          when Pragma_Weak_External => Weak_External : declare
8652             Ent : Entity_Id;
8653
8654          begin
8655             GNAT_Pragma;
8656             Check_Arg_Count (1);
8657             Check_Optional_Identifier (Arg1, Name_Entity);
8658             Check_Arg_Is_Library_Level_Local_Name (Arg1);
8659             Ent := Entity (Expression (Arg1));
8660
8661             if Rep_Item_Too_Early (Ent, N) then
8662                return;
8663             else
8664                Ent := Underlying_Type (Ent);
8665             end if;
8666
8667             --  The only processing required is to link this item on to the
8668             --  list of rep items for the given entity. This is accomplished
8669             --  by the call to Rep_Item_Too_Late (when no error is detected
8670             --  and False is returned).
8671
8672             if Rep_Item_Too_Late (Ent, N) then
8673                return;
8674             else
8675                Set_Has_Gigi_Rep_Item (Ent);
8676             end if;
8677          end Weak_External;
8678
8679       end case;
8680
8681    exception
8682       when Pragma_Exit => null;
8683
8684    end Analyze_Pragma;
8685
8686    -------------------------
8687    -- Get_Base_Subprogram --
8688    -------------------------
8689
8690    function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
8691       Result : Entity_Id;
8692
8693    begin
8694       Result := Def_Id;
8695
8696       --  Follow subprogram renaming chain
8697
8698       while Is_Subprogram (Result)
8699         and then
8700           (Is_Generic_Instance (Result)
8701             or else Nkind (Parent (Declaration_Node (Result))) =
8702               N_Subprogram_Renaming_Declaration)
8703         and then Present (Alias (Result))
8704       loop
8705          Result := Alias (Result);
8706       end loop;
8707
8708       return Result;
8709    end Get_Base_Subprogram;
8710
8711    ---------------------------
8712    -- Is_Generic_Subprogram --
8713    ---------------------------
8714
8715    function Is_Generic_Subprogram (Id : Entity_Id) return Boolean is
8716    begin
8717       return  Ekind (Id) = E_Generic_Procedure
8718         or else Ekind (Id) = E_Generic_Function;
8719    end Is_Generic_Subprogram;
8720
8721    ------------------------------
8722    -- Is_Pragma_String_Literal --
8723    ------------------------------
8724
8725    --  This function returns true if the corresponding pragma argument is
8726    --  a static string expression. These are the only cases in which string
8727    --  literals can appear as pragma arguments. We also allow a string
8728    --  literal as the first argument to pragma Assert (although it will
8729    --  of course always generate a type error).
8730
8731    function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
8732       Pragn : constant Node_Id := Parent (Par);
8733       Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
8734       Pname : constant Name_Id := Chars (Pragn);
8735       Argn  : Natural;
8736       N     : Node_Id;
8737
8738    begin
8739       Argn := 1;
8740       N := First (Assoc);
8741       loop
8742          exit when N = Par;
8743          Argn := Argn + 1;
8744          Next (N);
8745       end loop;
8746
8747       if Pname = Name_Assert then
8748          return True;
8749
8750       elsif Pname = Name_Export then
8751          return Argn > 2;
8752
8753       elsif Pname = Name_Ident then
8754          return Argn = 1;
8755
8756       elsif Pname = Name_Import then
8757          return Argn > 2;
8758
8759       elsif Pname = Name_Interface_Name then
8760          return Argn > 1;
8761
8762       elsif Pname = Name_Linker_Alias then
8763          return Argn = 2;
8764
8765       elsif Pname = Name_Linker_Section then
8766          return Argn = 2;
8767
8768       elsif Pname = Name_Machine_Attribute then
8769          return Argn = 2;
8770
8771       elsif Pname = Name_Source_File_Name then
8772          return True;
8773
8774       elsif Pname = Name_Source_Reference then
8775          return Argn = 2;
8776
8777       elsif Pname = Name_Title then
8778          return True;
8779
8780       elsif Pname = Name_Subtitle then
8781          return True;
8782
8783       else
8784          return False;
8785       end if;
8786    end Is_Pragma_String_Literal;
8787
8788    --------------------------------------
8789    -- Process_Compilation_Unit_Pragmas --
8790    --------------------------------------
8791
8792    procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
8793    begin
8794       --  A special check for pragma Suppress_All. This is a strange DEC
8795       --  pragma, strange because it comes at the end of the unit. If we
8796       --  have a pragma Suppress_All in the Pragmas_After of the current
8797       --  unit, then we insert a pragma Suppress (All_Checks) at the start
8798       --  of the context clause to ensure the correct processing.
8799
8800       declare
8801          PA : constant List_Id := Pragmas_After (Aux_Decls_Node (N));
8802          P  : Node_Id;
8803
8804       begin
8805          if Present (PA) then
8806             P := First (PA);
8807             while Present (P) loop
8808                if Chars (P) = Name_Suppress_All then
8809                   Prepend_To (Context_Items (N),
8810                     Make_Pragma (Sloc (P),
8811                       Chars => Name_Suppress,
8812                       Pragma_Argument_Associations => New_List (
8813                         Make_Pragma_Argument_Association (Sloc (P),
8814                           Expression =>
8815                             Make_Identifier (Sloc (P),
8816                               Chars => Name_All_Checks)))));
8817                   exit;
8818                end if;
8819
8820                Next (P);
8821             end loop;
8822          end if;
8823       end;
8824    end Process_Compilation_Unit_Pragmas;
8825
8826    --------------------------------
8827    -- Set_Encoded_Interface_Name --
8828    --------------------------------
8829
8830    procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
8831       Str : constant String_Id := Strval (S);
8832       Len : constant Int       := String_Length (Str);
8833       CC  : Char_Code;
8834       C   : Character;
8835       J   : Int;
8836
8837       Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
8838
8839       procedure Encode;
8840       --  Stores encoded value of character code CC. The encoding we
8841       --  use an underscore followed by four lower case hex digits.
8842
8843       procedure Encode is
8844       begin
8845          Store_String_Char (Get_Char_Code ('_'));
8846          Store_String_Char
8847            (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
8848          Store_String_Char
8849            (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
8850          Store_String_Char
8851            (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
8852          Store_String_Char
8853            (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
8854       end Encode;
8855
8856    --  Start of processing for Set_Encoded_Interface_Name
8857
8858    begin
8859       --  If first character is asterisk, this is a link name, and we
8860       --  leave it completely unmodified. We also ignore null strings
8861       --  (the latter case happens only in error cases) and no encoding
8862       --  should occur for Java interface names.
8863
8864       if Len = 0
8865         or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
8866         or else Java_VM
8867       then
8868          Set_Interface_Name (E, S);
8869
8870       else
8871          J := 1;
8872          loop
8873             CC := Get_String_Char (Str, J);
8874
8875             exit when not In_Character_Range (CC);
8876
8877             C := Get_Character (CC);
8878
8879             exit when C /= '_' and then C /= '$'
8880               and then C not in '0' .. '9'
8881               and then C not in 'a' .. 'z'
8882               and then C not in 'A' .. 'Z';
8883
8884             if J = Len then
8885                Set_Interface_Name (E, S);
8886                return;
8887
8888             else
8889                J := J + 1;
8890             end if;
8891          end loop;
8892
8893          --  Here we need to encode. The encoding we use as follows:
8894          --     three underscores  + four hex digits (lower case)
8895
8896          Start_String;
8897
8898          for J in 1 .. String_Length (Str) loop
8899             CC := Get_String_Char (Str, J);
8900
8901             if not In_Character_Range (CC) then
8902                Encode;
8903             else
8904                C := Get_Character (CC);
8905
8906                if C = '_' or else C = '$'
8907                  or else C in '0' .. '9'
8908                  or else C in 'a' .. 'z'
8909                  or else C in 'A' .. 'Z'
8910                then
8911                   Store_String_Char (CC);
8912                else
8913                   Encode;
8914                end if;
8915             end if;
8916          end loop;
8917
8918          Set_Interface_Name (E,
8919            Make_String_Literal (Sloc (S),
8920              Strval => End_String));
8921       end if;
8922    end Set_Encoded_Interface_Name;
8923
8924    -------------------
8925    -- Set_Unit_Name --
8926    -------------------
8927
8928    procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
8929       Pref : Node_Id;
8930       Scop : Entity_Id;
8931
8932    begin
8933       if Nkind (N) = N_Identifier
8934         and then Nkind (With_Item) = N_Identifier
8935       then
8936          Set_Entity (N, Entity (With_Item));
8937
8938       elsif Nkind (N) = N_Selected_Component then
8939          Change_Selected_Component_To_Expanded_Name (N);
8940          Set_Entity (N, Entity (With_Item));
8941          Set_Entity (Selector_Name (N), Entity (N));
8942
8943          Pref := Prefix (N);
8944          Scop := Scope (Entity (N));
8945
8946          while Nkind (Pref) = N_Selected_Component loop
8947             Change_Selected_Component_To_Expanded_Name (Pref);
8948             Set_Entity (Selector_Name (Pref), Scop);
8949             Set_Entity (Pref, Scop);
8950             Pref := Prefix (Pref);
8951             Scop := Scope (Scop);
8952          end loop;
8953
8954          Set_Entity (Pref, Scop);
8955       end if;
8956    end Set_Unit_Name;
8957
8958 end Sem_Prag;