gcc/ada/sem_prag.adb

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