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