gcc/ada/sem_prag.adb

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