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