gcc/ada/sem_prag.adb

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