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                 Debug_Pragmas_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          -- Debug_Policy --
5582          ------------------
5583
5584          --  pragma Debug_Policy (Check | Ignore)
5585
5586          when Pragma_Debug_Policy =>
5587             GNAT_Pragma;
5588             Check_Arg_Count (1);
5589             Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
5590             Debug_Pragmas_Enabled := Chars (Expression (Arg1)) = Name_Check;
5591
5592          ---------------------
5593          -- Detect_Blocking --
5594          ---------------------
5595
5596          --  pragma Detect_Blocking;
5597
5598          when Pragma_Detect_Blocking =>
5599             GNAT_Pragma;
5600             Check_Arg_Count (0);
5601             Check_Valid_Configuration_Pragma;
5602             Detect_Blocking := True;
5603
5604          -------------------
5605          -- Discard_Names --
5606          -------------------
5607
5608          --  pragma Discard_Names [([On =>] LOCAL_NAME)];
5609
5610          when Pragma_Discard_Names => Discard_Names : declare
5611             E_Id : Entity_Id;
5612             E    : Entity_Id;
5613
5614          begin
5615             Check_Ada_83_Warning;
5616
5617             --  Deal with configuration pragma case
5618
5619             if Arg_Count = 0 and then Is_Configuration_Pragma then
5620                Global_Discard_Names := True;
5621                return;
5622
5623             --  Otherwise, check correct appropriate context
5624
5625             else
5626                Check_Is_In_Decl_Part_Or_Package_Spec;
5627
5628                if Arg_Count = 0 then
5629
5630                   --  If there is no parameter, then from now on this pragma
5631                   --  applies to any enumeration, exception or tagged type
5632                   --  defined in the current declarative part.
5633
5634                   Set_Discard_Names (Current_Scope);
5635                   return;
5636
5637                else
5638                   Check_Arg_Count (1);
5639                   Check_Optional_Identifier (Arg1, Name_On);
5640                   Check_Arg_Is_Local_Name (Arg1);
5641                   E_Id := Expression (Arg1);
5642
5643                   if Etype (E_Id) = Any_Type then
5644                      return;
5645                   else
5646                      E := Entity (E_Id);
5647                   end if;
5648
5649                   if (Is_First_Subtype (E)
5650                        and then (Is_Enumeration_Type (E)
5651                                   or else Is_Tagged_Type (E)))
5652                     or else Ekind (E) = E_Exception
5653                   then
5654                      Set_Discard_Names (E);
5655                   else
5656                      Error_Pragma_Arg
5657                        ("inappropriate entity for pragma%", Arg1);
5658                   end if;
5659                end if;
5660             end if;
5661          end Discard_Names;
5662
5663          ---------------
5664          -- Elaborate --
5665          ---------------
5666
5667          --  pragma Elaborate (library_unit_NAME {, library_unit_NAME});
5668
5669          when Pragma_Elaborate => Elaborate : declare
5670             Plist       : List_Id;
5671             Parent_Node : Node_Id;
5672             Arg         : Node_Id;
5673             Citem       : Node_Id;
5674
5675          begin
5676             --  Pragma must be in context items list of a compilation unit
5677
5678             if not Is_List_Member (N) then
5679                Pragma_Misplaced;
5680                return;
5681
5682             else
5683                Plist := List_Containing (N);
5684                Parent_Node := Parent (Plist);
5685
5686                if Parent_Node = Empty
5687                  or else Nkind (Parent_Node) /= N_Compilation_Unit
5688                  or else Context_Items (Parent_Node) /= Plist
5689                then
5690                   Pragma_Misplaced;
5691                   return;
5692                end if;
5693             end if;
5694
5695             --  Must be at least one argument
5696
5697             if Arg_Count = 0 then
5698                Error_Pragma ("pragma% requires at least one argument");
5699             end if;
5700
5701             --  In Ada 83 mode, there can be no items following it in the
5702             --  context list except other pragmas and implicit with clauses
5703             --  (e.g. those added by use of Rtsfind). In Ada 95 mode, this
5704             --  placement rule does not apply.
5705
5706             if Ada_Version = Ada_83 and then Comes_From_Source (N) then
5707                Citem := Next (N);
5708
5709                while Present (Citem) loop
5710                   if Nkind (Citem) = N_Pragma
5711                     or else (Nkind (Citem) = N_With_Clause
5712                               and then Implicit_With (Citem))
5713                   then
5714                      null;
5715                   else
5716                      Error_Pragma
5717                        ("(Ada 83) pragma% must be at end of context clause");
5718                   end if;
5719
5720                   Next (Citem);
5721                end loop;
5722             end if;
5723
5724             --  Finally, the arguments must all be units mentioned in a with
5725             --  clause in the same context clause. Note we already checked
5726             --  (in Par.Prag) that the arguments are either identifiers or
5727
5728             Arg := Arg1;
5729             Outer : while Present (Arg) loop
5730                Citem := First (Plist);
5731
5732                Inner : while Citem /= N loop
5733                   if Nkind (Citem) = N_With_Clause
5734                     and then Same_Name (Name (Citem), Expression (Arg))
5735                   then
5736                      Set_Elaborate_Present (Citem, True);
5737                      Set_Unit_Name (Expression (Arg), Name (Citem));
5738
5739                      --  With the pragma present, elaboration calls on
5740                      --  subprograms from the named unit need no further
5741                      --  checks, as long as the pragma appears in the current
5742                      --  compilation unit. If the pragma appears in some unit
5743                      --  in the context, there might still be a need for an
5744                      --  Elaborate_All_Desirable from the current compilation
5745                      --  to the the named unit, so we keep the check enabled.
5746
5747                      if In_Extended_Main_Source_Unit (N) then
5748                         Set_Suppress_Elaboration_Warnings
5749                           (Entity (Name (Citem)));
5750                      end if;
5751                      exit Inner;
5752                   end if;
5753
5754                   Next (Citem);
5755                end loop Inner;
5756
5757                if Citem = N then
5758                   Error_Pragma_Arg
5759                     ("argument of pragma% is not with'ed unit", Arg);
5760                end if;
5761
5762                Next (Arg);
5763             end loop Outer;
5764
5765             --  Give a warning if operating in static mode with -gnatwl
5766             --  (elaboration warnings eanbled) switch set.
5767
5768             if Elab_Warnings and not Dynamic_Elaboration_Checks then
5769                Error_Msg_N
5770                  ("?use of pragma Elaborate may not be safe", N);
5771                Error_Msg_N
5772                  ("?use pragma Elaborate_All instead if possible", N);
5773             end if;
5774          end Elaborate;
5775
5776          -------------------
5777          -- Elaborate_All --
5778          -------------------
5779
5780          --  pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
5781
5782          when Pragma_Elaborate_All => Elaborate_All : declare
5783             Plist       : List_Id;
5784             Parent_Node : Node_Id;
5785             Arg         : Node_Id;
5786             Citem       : Node_Id;
5787
5788          begin
5789             Check_Ada_83_Warning;
5790
5791             --  Pragma must be in context items list of a compilation unit
5792
5793             if not Is_List_Member (N) then
5794                Pragma_Misplaced;
5795                return;
5796
5797             else
5798                Plist := List_Containing (N);
5799                Parent_Node := Parent (Plist);
5800
5801                if Parent_Node = Empty
5802                  or else Nkind (Parent_Node) /= N_Compilation_Unit
5803                  or else Context_Items (Parent_Node) /= Plist
5804                then
5805                   Pragma_Misplaced;
5806                   return;
5807                end if;
5808             end if;
5809
5810             --  Must be at least one argument
5811
5812             if Arg_Count = 0 then
5813                Error_Pragma ("pragma% requires at least one argument");
5814             end if;
5815
5816             --  Note: unlike pragma Elaborate, pragma Elaborate_All does not
5817             --  have to appear at the end of the context clause, but may
5818             --  appear mixed in with other items, even in Ada 83 mode.
5819
5820             --  Final check: the arguments must all be units mentioned in
5821             --  a with clause in the same context clause. Note that we
5822             --  already checked (in Par.Prag) that all the arguments are
5823             --  either identifiers or selected components.
5824
5825             Arg := Arg1;
5826             Outr : while Present (Arg) loop
5827                Citem := First (Plist);
5828
5829                Innr : while Citem /= N loop
5830                   if Nkind (Citem) = N_With_Clause
5831                     and then Same_Name (Name (Citem), Expression (Arg))
5832                   then
5833                      Set_Elaborate_All_Present (Citem, True);
5834                      Set_Unit_Name (Expression (Arg), Name (Citem));
5835
5836                      --  Suppress warnings and elaboration checks on the named
5837                      --  unit if the pragma is in the current compilation, as
5838                      --  for pragma Elaborate.
5839
5840                      if In_Extended_Main_Source_Unit (N) then
5841                         Set_Suppress_Elaboration_Warnings
5842                           (Entity (Name (Citem)));
5843                      end if;
5844                      exit Innr;
5845                   end if;
5846
5847                   Next (Citem);
5848                end loop Innr;
5849
5850                if Citem = N then
5851                   Set_Error_Posted (N);
5852                   Error_Pragma_Arg
5853                     ("argument of pragma% is not with'ed unit", Arg);
5854                end if;
5855
5856                Next (Arg);
5857             end loop Outr;
5858          end Elaborate_All;
5859
5860          --------------------
5861          -- Elaborate_Body --
5862          --------------------
5863
5864          --  pragma Elaborate_Body [( library_unit_NAME )];
5865
5866          when Pragma_Elaborate_Body => Elaborate_Body : declare
5867             Cunit_Node : Node_Id;
5868             Cunit_Ent  : Entity_Id;
5869
5870          begin
5871             Check_Ada_83_Warning;
5872             Check_Valid_Library_Unit_Pragma;
5873
5874             if Nkind (N) = N_Null_Statement then
5875                return;
5876             end if;
5877
5878             Cunit_Node := Cunit (Current_Sem_Unit);
5879             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
5880
5881             if Nkind (Unit (Cunit_Node)) = N_Package_Body
5882                  or else
5883                Nkind (Unit (Cunit_Node)) = N_Subprogram_Body
5884             then
5885                Error_Pragma ("pragma% must refer to a spec, not a body");
5886             else
5887                Set_Body_Required (Cunit_Node, True);
5888                Set_Has_Pragma_Elaborate_Body     (Cunit_Ent);
5889
5890                --  If we are in dynamic elaboration mode, then we suppress
5891                --  elaboration warnings for the unit, since it is definitely
5892                --  fine NOT to do dynamic checks at the first level (and such
5893                --  checks will be suppressed because no elaboration boolean
5894                --  is created for Elaborate_Body packages).
5895
5896                --  But in the static model of elaboration, Elaborate_Body is
5897                --  definitely NOT good enough to ensure elaboration safety on
5898                --  its own, since the body may WITH other units that are not
5899                --  safe from an elaboration point of view, so a client must
5900                --  still do an Elaborate_All on such units.
5901
5902                --  Debug flag -gnatdD restores the old behavior of 3.13,
5903                --  where Elaborate_Body always suppressed elab warnings.
5904
5905                if Dynamic_Elaboration_Checks or Debug_Flag_DD then
5906                   Set_Suppress_Elaboration_Warnings (Cunit_Ent);
5907                end if;
5908             end if;
5909          end Elaborate_Body;
5910
5911          ------------------------
5912          -- Elaboration_Checks --
5913          ------------------------
5914
5915          --  pragma Elaboration_Checks (Static | Dynamic);
5916
5917          when Pragma_Elaboration_Checks =>
5918             GNAT_Pragma;
5919             Check_Arg_Count (1);
5920             Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
5921             Dynamic_Elaboration_Checks :=
5922               (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
5923
5924          ---------------
5925          -- Eliminate --
5926          ---------------
5927
5928          --  pragma Eliminate (
5929          --      [Unit_Name       =>]  IDENTIFIER |
5930          --                            SELECTED_COMPONENT
5931          --    [,[Entity          =>]  IDENTIFIER |
5932          --                            SELECTED_COMPONENT |
5933          --                            STRING_LITERAL]
5934          --    [,]OVERLOADING_RESOLUTION);
5935
5936          --  OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
5937          --                             SOURCE_LOCATION
5938
5939          --  PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
5940          --                                        FUNCTION_PROFILE
5941
5942          --  PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
5943
5944          --  FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
5945          --                       Result_Type => result_SUBTYPE_NAME]
5946
5947          --  PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
5948          --  SUBTYPE_NAME    ::= STRING_LITERAL
5949
5950          --  SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
5951          --  SOURCE_TRACE    ::= STRING_LITERAL
5952
5953          when Pragma_Eliminate => Eliminate : declare
5954             Args  : Args_List (1 .. 5);
5955             Names : constant Name_List (1 .. 5) := (
5956                       Name_Unit_Name,
5957                       Name_Entity,
5958                       Name_Parameter_Types,
5959                       Name_Result_Type,
5960                       Name_Source_Location);
5961
5962             Unit_Name       : Node_Id renames Args (1);
5963             Entity          : Node_Id renames Args (2);
5964             Parameter_Types : Node_Id renames Args (3);
5965             Result_Type     : Node_Id renames Args (4);
5966             Source_Location : Node_Id renames Args (5);
5967
5968          begin
5969             GNAT_Pragma;
5970             Check_Valid_Configuration_Pragma;
5971             Gather_Associations (Names, Args);
5972
5973             if No (Unit_Name) then
5974                Error_Pragma ("missing Unit_Name argument for pragma%");
5975             end if;
5976
5977             if No (Entity)
5978               and then (Present (Parameter_Types)
5979                           or else
5980                         Present (Result_Type)
5981                           or else
5982                         Present (Source_Location))
5983             then
5984                Error_Pragma ("missing Entity argument for pragma%");
5985             end if;
5986
5987             if (Present (Parameter_Types)
5988                        or else
5989                 Present (Result_Type))
5990               and then
5991                 Present (Source_Location)
5992             then
5993                Error_Pragma
5994                  ("parameter profile and source location can not " &
5995                   "be used together in pragma%");
5996             end if;
5997
5998             Process_Eliminate_Pragma
5999               (N,
6000                Unit_Name,
6001                Entity,
6002                Parameter_Types,
6003                Result_Type,
6004                Source_Location);
6005          end Eliminate;
6006
6007          -------------------------
6008          -- Explicit_Overriding --
6009          -------------------------
6010
6011          when Pragma_Explicit_Overriding =>
6012             Check_Valid_Configuration_Pragma;
6013             Check_Arg_Count (0);
6014             Explicit_Overriding := True;
6015
6016          ------------
6017          -- Export --
6018          ------------
6019
6020          --  pragma Export (
6021          --    [   Convention    =>] convention_IDENTIFIER,
6022          --    [   Entity        =>] local_NAME
6023          --    [, [External_Name =>] static_string_EXPRESSION ]
6024          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
6025
6026          when Pragma_Export => Export : declare
6027             C      : Convention_Id;
6028             Def_Id : Entity_Id;
6029
6030          begin
6031             Check_Ada_83_Warning;
6032             Check_Arg_Order
6033               ((Name_Convention,
6034                 Name_Entity,
6035                 Name_External_Name,
6036                 Name_Link_Name));
6037             Check_At_Least_N_Arguments (2);
6038             Check_At_Most_N_Arguments  (4);
6039             Process_Convention (C, Def_Id);
6040
6041             if Ekind (Def_Id) /= E_Constant then
6042                Note_Possible_Modification (Expression (Arg2));
6043             end if;
6044
6045             Process_Interface_Name (Def_Id, Arg3, Arg4);
6046             Set_Exported (Def_Id, Arg2);
6047          end Export;
6048
6049          ----------------------
6050          -- Export_Exception --
6051          ----------------------
6052
6053          --  pragma Export_Exception (
6054          --        [Internal         =>] LOCAL_NAME,
6055          --     [, [External         =>] EXTERNAL_SYMBOL,]
6056          --     [, [Form     =>] Ada | VMS]
6057          --     [, [Code     =>] static_integer_EXPRESSION]);
6058
6059          when Pragma_Export_Exception => Export_Exception : declare
6060             Args  : Args_List (1 .. 4);
6061             Names : constant Name_List (1 .. 4) := (
6062                       Name_Internal,
6063                       Name_External,
6064                       Name_Form,
6065                       Name_Code);
6066
6067             Internal : Node_Id renames Args (1);
6068             External : Node_Id renames Args (2);
6069             Form     : Node_Id renames Args (3);
6070             Code     : Node_Id renames Args (4);
6071
6072          begin
6073             if Inside_A_Generic then
6074                Error_Pragma ("pragma% cannot be used for generic entities");
6075             end if;
6076
6077             Gather_Associations (Names, Args);
6078             Process_Extended_Import_Export_Exception_Pragma (
6079               Arg_Internal => Internal,
6080               Arg_External => External,
6081               Arg_Form     => Form,
6082               Arg_Code     => Code);
6083
6084             if not Is_VMS_Exception (Entity (Internal)) then
6085                Set_Exported (Entity (Internal), Internal);
6086             end if;
6087          end Export_Exception;
6088
6089          ---------------------
6090          -- Export_Function --
6091          ---------------------
6092
6093          --  pragma Export_Function (
6094          --        [Internal         =>] LOCAL_NAME,
6095          --     [, [External         =>] EXTERNAL_SYMBOL,]
6096          --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
6097          --     [, [Result_Type      =>] TYPE_DESIGNATOR]
6098          --     [, [Mechanism        =>] MECHANISM]
6099          --     [, [Result_Mechanism =>] MECHANISM_NAME]);
6100
6101          --  EXTERNAL_SYMBOL ::=
6102          --    IDENTIFIER
6103          --  | static_string_EXPRESSION
6104
6105          --  PARAMETER_TYPES ::=
6106          --    null
6107          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6108
6109          --  TYPE_DESIGNATOR ::=
6110          --    subtype_NAME
6111          --  | subtype_Name ' Access
6112
6113          --  MECHANISM ::=
6114          --    MECHANISM_NAME
6115          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6116
6117          --  MECHANISM_ASSOCIATION ::=
6118          --    [formal_parameter_NAME =>] MECHANISM_NAME
6119
6120          --  MECHANISM_NAME ::=
6121          --    Value
6122          --  | Reference
6123          --  | Descriptor [([Class =>] CLASS_NAME)]
6124
6125          --  CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6126
6127          when Pragma_Export_Function => Export_Function : declare
6128             Args  : Args_List (1 .. 6);
6129             Names : constant Name_List (1 .. 6) := (
6130                       Name_Internal,
6131                       Name_External,
6132                       Name_Parameter_Types,
6133                       Name_Result_Type,
6134                       Name_Mechanism,
6135                       Name_Result_Mechanism);
6136
6137             Internal         : Node_Id renames Args (1);
6138             External         : Node_Id renames Args (2);
6139             Parameter_Types  : Node_Id renames Args (3);
6140             Result_Type      : Node_Id renames Args (4);
6141             Mechanism        : Node_Id renames Args (5);
6142             Result_Mechanism : Node_Id renames Args (6);
6143
6144          begin
6145             GNAT_Pragma;
6146             Gather_Associations (Names, Args);
6147             Process_Extended_Import_Export_Subprogram_Pragma (
6148               Arg_Internal         => Internal,
6149               Arg_External         => External,
6150               Arg_Parameter_Types  => Parameter_Types,
6151               Arg_Result_Type      => Result_Type,
6152               Arg_Mechanism        => Mechanism,
6153               Arg_Result_Mechanism => Result_Mechanism);
6154          end Export_Function;
6155
6156          -------------------
6157          -- Export_Object --
6158          -------------------
6159
6160          --  pragma Export_Object (
6161          --        [Internal =>] LOCAL_NAME,
6162          --     [, [External =>] EXTERNAL_SYMBOL]
6163          --     [, [Size     =>] EXTERNAL_SYMBOL]);
6164
6165          --  EXTERNAL_SYMBOL ::=
6166          --    IDENTIFIER
6167          --  | static_string_EXPRESSION
6168
6169          --  PARAMETER_TYPES ::=
6170          --    null
6171          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6172
6173          --  TYPE_DESIGNATOR ::=
6174          --    subtype_NAME
6175          --  | subtype_Name ' Access
6176
6177          --  MECHANISM ::=
6178          --    MECHANISM_NAME
6179          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6180
6181          --  MECHANISM_ASSOCIATION ::=
6182          --    [formal_parameter_NAME =>] MECHANISM_NAME
6183
6184          --  MECHANISM_NAME ::=
6185          --    Value
6186          --  | Reference
6187          --  | Descriptor [([Class =>] CLASS_NAME)]
6188
6189          --  CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6190
6191          when Pragma_Export_Object => Export_Object : declare
6192             Args  : Args_List (1 .. 3);
6193             Names : constant Name_List (1 .. 3) := (
6194                       Name_Internal,
6195                       Name_External,
6196                       Name_Size);
6197
6198             Internal : Node_Id renames Args (1);
6199             External : Node_Id renames Args (2);
6200             Size     : Node_Id renames Args (3);
6201
6202          begin
6203             GNAT_Pragma;
6204             Gather_Associations (Names, Args);
6205             Process_Extended_Import_Export_Object_Pragma (
6206               Arg_Internal => Internal,
6207               Arg_External => External,
6208               Arg_Size     => Size);
6209          end Export_Object;
6210
6211          ----------------------
6212          -- Export_Procedure --
6213          ----------------------
6214
6215          --  pragma Export_Procedure (
6216          --        [Internal         =>] LOCAL_NAME,
6217          --     [, [External         =>] EXTERNAL_SYMBOL,]
6218          --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
6219          --     [, [Mechanism        =>] MECHANISM]);
6220
6221          --  EXTERNAL_SYMBOL ::=
6222          --    IDENTIFIER
6223          --  | static_string_EXPRESSION
6224
6225          --  PARAMETER_TYPES ::=
6226          --    null
6227          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6228
6229          --  TYPE_DESIGNATOR ::=
6230          --    subtype_NAME
6231          --  | subtype_Name ' Access
6232
6233          --  MECHANISM ::=
6234          --    MECHANISM_NAME
6235          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6236
6237          --  MECHANISM_ASSOCIATION ::=
6238          --    [formal_parameter_NAME =>] MECHANISM_NAME
6239
6240          --  MECHANISM_NAME ::=
6241          --    Value
6242          --  | Reference
6243          --  | Descriptor [([Class =>] CLASS_NAME)]
6244
6245          --  CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6246
6247          when Pragma_Export_Procedure => Export_Procedure : declare
6248             Args  : Args_List (1 .. 4);
6249             Names : constant Name_List (1 .. 4) := (
6250                       Name_Internal,
6251                       Name_External,
6252                       Name_Parameter_Types,
6253                       Name_Mechanism);
6254
6255             Internal        : Node_Id renames Args (1);
6256             External        : Node_Id renames Args (2);
6257             Parameter_Types : Node_Id renames Args (3);
6258             Mechanism       : Node_Id renames Args (4);
6259
6260          begin
6261             GNAT_Pragma;
6262             Gather_Associations (Names, Args);
6263             Process_Extended_Import_Export_Subprogram_Pragma (
6264               Arg_Internal        => Internal,
6265               Arg_External        => External,
6266               Arg_Parameter_Types => Parameter_Types,
6267               Arg_Mechanism       => Mechanism);
6268          end Export_Procedure;
6269
6270          ------------------
6271          -- Export_Value --
6272          ------------------
6273
6274          --  pragma Export_Value (
6275          --     [Value     =>] static_integer_EXPRESSION,
6276          --     [Link_Name =>] static_string_EXPRESSION);
6277
6278          when Pragma_Export_Value =>
6279             GNAT_Pragma;
6280             Check_Arg_Order ((Name_Value, Name_Link_Name));
6281             Check_Arg_Count (2);
6282
6283             Check_Optional_Identifier (Arg1, Name_Value);
6284             Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
6285
6286             Check_Optional_Identifier (Arg2, Name_Link_Name);
6287             Check_Arg_Is_Static_Expression (Arg2, Standard_String);
6288
6289          -----------------------------
6290          -- Export_Valued_Procedure --
6291          -----------------------------
6292
6293          --  pragma Export_Valued_Procedure (
6294          --        [Internal         =>] LOCAL_NAME,
6295          --     [, [External         =>] EXTERNAL_SYMBOL,]
6296          --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
6297          --     [, [Mechanism        =>] MECHANISM]);
6298
6299          --  EXTERNAL_SYMBOL ::=
6300          --    IDENTIFIER
6301          --  | static_string_EXPRESSION
6302
6303          --  PARAMETER_TYPES ::=
6304          --    null
6305          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6306
6307          --  TYPE_DESIGNATOR ::=
6308          --    subtype_NAME
6309          --  | subtype_Name ' Access
6310
6311          --  MECHANISM ::=
6312          --    MECHANISM_NAME
6313          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6314
6315          --  MECHANISM_ASSOCIATION ::=
6316          --    [formal_parameter_NAME =>] MECHANISM_NAME
6317
6318          --  MECHANISM_NAME ::=
6319          --    Value
6320          --  | Reference
6321          --  | Descriptor [([Class =>] CLASS_NAME)]
6322
6323          --  CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6324
6325          when Pragma_Export_Valued_Procedure =>
6326          Export_Valued_Procedure : declare
6327             Args  : Args_List (1 .. 4);
6328             Names : constant Name_List (1 .. 4) := (
6329                       Name_Internal,
6330                       Name_External,
6331                       Name_Parameter_Types,
6332                       Name_Mechanism);
6333
6334             Internal        : Node_Id renames Args (1);
6335             External        : Node_Id renames Args (2);
6336             Parameter_Types : Node_Id renames Args (3);
6337             Mechanism       : Node_Id renames Args (4);
6338
6339          begin
6340             GNAT_Pragma;
6341             Gather_Associations (Names, Args);
6342             Process_Extended_Import_Export_Subprogram_Pragma (
6343               Arg_Internal        => Internal,
6344               Arg_External        => External,
6345               Arg_Parameter_Types => Parameter_Types,
6346               Arg_Mechanism       => Mechanism);
6347          end Export_Valued_Procedure;
6348
6349          -------------------
6350          -- Extend_System --
6351          -------------------
6352
6353          --  pragma Extend_System ([Name =>] Identifier);
6354
6355          when Pragma_Extend_System => Extend_System : declare
6356          begin
6357             GNAT_Pragma;
6358             Check_Valid_Configuration_Pragma;
6359             Check_Arg_Count (1);
6360             Check_Optional_Identifier (Arg1, Name_Name);
6361             Check_Arg_Is_Identifier (Arg1);
6362
6363             Get_Name_String (Chars (Expression (Arg1)));
6364
6365             if Name_Len > 4
6366               and then Name_Buffer (1 .. 4) = "aux_"
6367             then
6368                if Present (System_Extend_Pragma_Arg) then
6369                   if Chars (Expression (Arg1)) =
6370                      Chars (Expression (System_Extend_Pragma_Arg))
6371                   then
6372                      null;
6373                   else
6374                      Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
6375                      Error_Pragma ("pragma% conflicts with that at#");
6376                   end if;
6377
6378                else
6379                   System_Extend_Pragma_Arg := Arg1;
6380
6381                   if not GNAT_Mode then
6382                      System_Extend_Unit := Arg1;
6383                   end if;
6384                end if;
6385             else
6386                Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
6387             end if;
6388          end Extend_System;
6389
6390          ------------------------
6391          -- Extensions_Allowed --
6392          ------------------------
6393
6394          --  pragma Extensions_Allowed (ON | OFF);
6395
6396          when Pragma_Extensions_Allowed =>
6397             GNAT_Pragma;
6398             Check_Arg_Count (1);
6399             Check_No_Identifiers;
6400             Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
6401
6402             if Chars (Expression (Arg1)) = Name_On then
6403                Extensions_Allowed := True;
6404                Ada_Version := Ada_Version_Type'Last;
6405             else
6406                Extensions_Allowed := False;
6407                Ada_Version := Ada_Version_Type'Min (Ada_Version, Ada_95);
6408             end if;
6409
6410             Ada_Version_Explicit := Ada_Version;
6411
6412          --------------
6413          -- External --
6414          --------------
6415
6416          --  pragma External (
6417          --    [   Convention    =>] convention_IDENTIFIER,
6418          --    [   Entity        =>] local_NAME
6419          --    [, [External_Name =>] static_string_EXPRESSION ]
6420          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
6421
6422          when Pragma_External => External : declare
6423             C      : Convention_Id;
6424             Def_Id : Entity_Id;
6425          begin
6426             GNAT_Pragma;
6427             Check_Arg_Order
6428               ((Name_Convention,
6429                 Name_Entity,
6430                 Name_External_Name,
6431                 Name_Link_Name));
6432             Check_At_Least_N_Arguments (2);
6433             Check_At_Most_N_Arguments  (4);
6434             Process_Convention (C, Def_Id);
6435             Note_Possible_Modification (Expression (Arg2));
6436             Process_Interface_Name (Def_Id, Arg3, Arg4);
6437             Set_Exported (Def_Id, Arg2);
6438          end External;
6439
6440          --------------------------
6441          -- External_Name_Casing --
6442          --------------------------
6443
6444          --  pragma External_Name_Casing (
6445          --    UPPERCASE | LOWERCASE
6446          --    [, AS_IS | UPPERCASE | LOWERCASE]);
6447
6448          when Pragma_External_Name_Casing => External_Name_Casing : declare
6449          begin
6450             GNAT_Pragma;
6451             Check_No_Identifiers;
6452
6453             if Arg_Count = 2 then
6454                Check_Arg_Is_One_Of
6455                  (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
6456
6457                case Chars (Get_Pragma_Arg (Arg2)) is
6458                   when Name_As_Is     =>
6459                      Opt.External_Name_Exp_Casing := As_Is;
6460
6461                   when Name_Uppercase =>
6462                      Opt.External_Name_Exp_Casing := Uppercase;
6463
6464                   when Name_Lowercase =>
6465                      Opt.External_Name_Exp_Casing := Lowercase;
6466
6467                   when others =>
6468                      null;
6469                end case;
6470
6471             else
6472                Check_Arg_Count (1);
6473             end if;
6474
6475             Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
6476
6477             case Chars (Get_Pragma_Arg (Arg1)) is
6478                when Name_Uppercase =>
6479                   Opt.External_Name_Imp_Casing := Uppercase;
6480
6481                when Name_Lowercase =>
6482                   Opt.External_Name_Imp_Casing := Lowercase;
6483
6484                when others =>
6485                   null;
6486             end case;
6487          end External_Name_Casing;
6488
6489          ---------------------------
6490          -- Finalize_Storage_Only --
6491          ---------------------------
6492
6493          --  pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
6494
6495          when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
6496             Assoc   : constant Node_Id := Arg1;
6497             Type_Id : constant Node_Id := Expression (Assoc);
6498             Typ     : Entity_Id;
6499
6500          begin
6501             Check_No_Identifiers;
6502             Check_Arg_Count (1);
6503             Check_Arg_Is_Local_Name (Arg1);
6504
6505             Find_Type (Type_Id);
6506             Typ := Entity (Type_Id);
6507
6508             if Typ = Any_Type
6509               or else Rep_Item_Too_Early (Typ, N)
6510             then
6511                return;
6512             else
6513                Typ := Underlying_Type (Typ);
6514             end if;
6515
6516             if not Is_Controlled (Typ) then
6517                Error_Pragma ("pragma% must specify controlled type");
6518             end if;
6519
6520             Check_First_Subtype (Arg1);
6521
6522             if Finalize_Storage_Only (Typ) then
6523                Error_Pragma ("duplicate pragma%, only one allowed");
6524
6525             elsif not Rep_Item_Too_Late (Typ, N) then
6526                Set_Finalize_Storage_Only (Base_Type (Typ), True);
6527             end if;
6528          end Finalize_Storage;
6529
6530          --------------------------
6531          -- Float_Representation --
6532          --------------------------
6533
6534          --  pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
6535
6536          --  FLOAT_REP ::= VAX_Float | IEEE_Float
6537
6538          when Pragma_Float_Representation => Float_Representation : declare
6539             Argx : Node_Id;
6540             Digs : Nat;
6541             Ent  : Entity_Id;
6542
6543          begin
6544             GNAT_Pragma;
6545
6546             if Arg_Count = 1 then
6547                Check_Valid_Configuration_Pragma;
6548             else
6549                Check_Arg_Count (2);
6550                Check_Optional_Identifier (Arg2, Name_Entity);
6551                Check_Arg_Is_Local_Name (Arg2);
6552             end if;
6553
6554             Check_No_Identifier (Arg1);
6555             Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
6556
6557             if not OpenVMS_On_Target then
6558                if Chars (Expression (Arg1)) = Name_VAX_Float then
6559                   Error_Pragma
6560                     ("?pragma% ignored (applies only to Open'V'M'S)");
6561                end if;
6562
6563                return;
6564             end if;
6565
6566             --  One argument case
6567
6568             if Arg_Count = 1 then
6569                if Chars (Expression (Arg1)) = Name_VAX_Float then
6570                   if Opt.Float_Format = 'I' then
6571                      Error_Pragma ("'I'E'E'E format previously specified");
6572                   end if;
6573
6574                   Opt.Float_Format := 'V';
6575
6576                else
6577                   if Opt.Float_Format = 'V' then
6578                      Error_Pragma ("'V'A'X format previously specified");
6579                   end if;
6580
6581                   Opt.Float_Format := 'I';
6582                end if;
6583
6584                Set_Standard_Fpt_Formats;
6585
6586             --  Two argument case
6587
6588             else
6589                Argx := Get_Pragma_Arg (Arg2);
6590
6591                if not Is_Entity_Name (Argx)
6592                  or else not Is_Floating_Point_Type (Entity (Argx))
6593                then
6594                   Error_Pragma_Arg
6595                     ("second argument of% pragma must be floating-point type",
6596                      Arg2);
6597                end if;
6598
6599                Ent  := Entity (Argx);
6600                Digs := UI_To_Int (Digits_Value (Ent));
6601
6602                --  Two arguments, VAX_Float case
6603
6604                if Chars (Expression (Arg1)) = Name_VAX_Float then
6605                   case Digs is
6606                      when  6 => Set_F_Float (Ent);
6607                      when  9 => Set_D_Float (Ent);
6608                      when 15 => Set_G_Float (Ent);
6609
6610                      when others =>
6611                         Error_Pragma_Arg
6612                           ("wrong digits value, must be 6,9 or 15", Arg2);
6613                   end case;
6614
6615                --  Two arguments, IEEE_Float case
6616
6617                else
6618                   case Digs is
6619                      when  6 => Set_IEEE_Short (Ent);
6620                      when 15 => Set_IEEE_Long  (Ent);
6621
6622                      when others =>
6623                         Error_Pragma_Arg
6624                           ("wrong digits value, must be 6 or 15", Arg2);
6625                   end case;
6626                end if;
6627             end if;
6628          end Float_Representation;
6629
6630          -----------
6631          -- Ident --
6632          -----------
6633
6634          --  pragma Ident (static_string_EXPRESSION)
6635
6636          --  Note: pragma Comment shares this processing. Pragma Comment
6637          --  is identical to Ident, except that the restriction of the
6638          --  argument to 31 characters and the placement restrictions
6639          --  are not enforced for pragma Comment.
6640
6641          when Pragma_Ident | Pragma_Comment => Ident : declare
6642             Str : Node_Id;
6643
6644          begin
6645             GNAT_Pragma;
6646             Check_Arg_Count (1);
6647             Check_No_Identifiers;
6648             Check_Arg_Is_Static_Expression (Arg1, Standard_String);
6649
6650             --  For pragma Ident, preserve DEC compatibility by requiring
6651             --  the pragma to appear in a declarative part or package spec.
6652
6653             if Prag_Id = Pragma_Ident then
6654                Check_Is_In_Decl_Part_Or_Package_Spec;
6655             end if;
6656
6657             Str := Expr_Value_S (Expression (Arg1));
6658
6659             declare
6660                CS : Node_Id;
6661                GP : Node_Id;
6662
6663             begin
6664                GP := Parent (Parent (N));
6665
6666                if Nkind (GP) = N_Package_Declaration
6667                     or else
6668                   Nkind (GP) = N_Generic_Package_Declaration
6669                then
6670                   GP := Parent (GP);
6671                end if;
6672
6673                --  If we have a compilation unit, then record the ident
6674                --  value, checking for improper duplication.
6675
6676                if Nkind (GP) = N_Compilation_Unit then
6677                   CS := Ident_String (Current_Sem_Unit);
6678
6679                   if Present (CS) then
6680
6681                      --  For Ident, we do not permit multiple instances
6682
6683                      if Prag_Id = Pragma_Ident then
6684                         Error_Pragma ("duplicate% pragma not permitted");
6685
6686                      --  For Comment, we concatenate the string, unless we
6687                      --  want to preserve the tree structure for ASIS.
6688
6689                      elsif not ASIS_Mode then
6690                         Start_String (Strval (CS));
6691                         Store_String_Char (' ');
6692                         Store_String_Chars (Strval (Str));
6693                         Set_Strval (CS, End_String);
6694                      end if;
6695
6696                   else
6697                      --  In VMS, the effect of IDENT is achieved by passing
6698                      --  IDENTIFICATION=name as a --for-linker switch.
6699
6700                      if OpenVMS_On_Target then
6701                         Start_String;
6702                         Store_String_Chars
6703                           ("--for-linker=IDENTIFICATION=");
6704                         String_To_Name_Buffer (Strval (Str));
6705                         Store_String_Chars (Name_Buffer (1 .. Name_Len));
6706
6707                         --  Only the last processed IDENT is saved. The main
6708                         --  purpose is so an IDENT associated with a main
6709                         --  procedure will be used in preference to an IDENT
6710                         --  associated with a with'd package.
6711
6712                         Replace_Linker_Option_String
6713                           (End_String, "--for-linker=IDENTIFICATION=");
6714                      end if;
6715
6716                      Set_Ident_String (Current_Sem_Unit, Str);
6717                   end if;
6718
6719                --  For subunits, we just ignore the Ident, since in GNAT
6720                --  these are not separate object files, and hence not
6721                --  separate units in the unit table.
6722
6723                elsif Nkind (GP) = N_Subunit then
6724                   null;
6725
6726                --  Otherwise we have a misplaced pragma Ident, but we ignore
6727                --  this if we are in an instantiation, since it comes from
6728                --  a generic, and has no relevance to the instantiation.
6729
6730                elsif Prag_Id = Pragma_Ident then
6731                   if Instantiation_Location (Loc) = No_Location then
6732                      Error_Pragma ("pragma% only allowed at outer level");
6733                   end if;
6734                end if;
6735             end;
6736          end Ident;
6737
6738          ------------
6739          -- Import --
6740          ------------
6741
6742          --  pragma Import (
6743          --    [   Convention    =>] convention_IDENTIFIER,
6744          --    [   Entity        =>] local_NAME
6745          --    [, [External_Name =>] static_string_EXPRESSION ]
6746          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
6747
6748          when Pragma_Import =>
6749             Check_Ada_83_Warning;
6750             Check_Arg_Order
6751               ((Name_Convention,
6752                 Name_Entity,
6753                 Name_External_Name,
6754                 Name_Link_Name));
6755             Check_At_Least_N_Arguments (2);
6756             Check_At_Most_N_Arguments  (4);
6757             Process_Import_Or_Interface;
6758
6759          ----------------------
6760          -- Import_Exception --
6761          ----------------------
6762
6763          --  pragma Import_Exception (
6764          --        [Internal         =>] LOCAL_NAME,
6765          --     [, [External         =>] EXTERNAL_SYMBOL,]
6766          --     [, [Form     =>] Ada | VMS]
6767          --     [, [Code     =>] static_integer_EXPRESSION]);
6768
6769          when Pragma_Import_Exception => Import_Exception : declare
6770             Args  : Args_List (1 .. 4);
6771             Names : constant Name_List (1 .. 4) := (
6772                       Name_Internal,
6773                       Name_External,
6774                       Name_Form,
6775                       Name_Code);
6776
6777             Internal : Node_Id renames Args (1);
6778             External : Node_Id renames Args (2);
6779             Form     : Node_Id renames Args (3);
6780             Code     : Node_Id renames Args (4);
6781
6782          begin
6783             Gather_Associations (Names, Args);
6784
6785             if Present (External) and then Present (Code) then
6786                Error_Pragma
6787                  ("cannot give both External and Code options for pragma%");
6788             end if;
6789
6790             Process_Extended_Import_Export_Exception_Pragma (
6791               Arg_Internal => Internal,
6792               Arg_External => External,
6793               Arg_Form     => Form,
6794               Arg_Code     => Code);
6795
6796             if not Is_VMS_Exception (Entity (Internal)) then
6797                Set_Imported (Entity (Internal));
6798             end if;
6799          end Import_Exception;
6800
6801          ---------------------
6802          -- Import_Function --
6803          ---------------------
6804
6805          --  pragma Import_Function (
6806          --        [Internal                 =>] LOCAL_NAME,
6807          --     [, [External                 =>] EXTERNAL_SYMBOL]
6808          --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
6809          --     [, [Result_Type              =>] SUBTYPE_MARK]
6810          --     [, [Mechanism                =>] MECHANISM]
6811          --     [, [Result_Mechanism         =>] MECHANISM_NAME]
6812          --     [, [First_Optional_Parameter =>] IDENTIFIER]);
6813
6814          --  EXTERNAL_SYMBOL ::=
6815          --    IDENTIFIER
6816          --  | static_string_EXPRESSION
6817
6818          --  PARAMETER_TYPES ::=
6819          --    null
6820          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6821
6822          --  TYPE_DESIGNATOR ::=
6823          --    subtype_NAME
6824          --  | subtype_Name ' Access
6825
6826          --  MECHANISM ::=
6827          --    MECHANISM_NAME
6828          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6829
6830          --  MECHANISM_ASSOCIATION ::=
6831          --    [formal_parameter_NAME =>] MECHANISM_NAME
6832
6833          --  MECHANISM_NAME ::=
6834          --    Value
6835          --  | Reference
6836          --  | Descriptor [([Class =>] CLASS_NAME)]
6837
6838          --  CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6839
6840          when Pragma_Import_Function => Import_Function : declare
6841             Args  : Args_List (1 .. 7);
6842             Names : constant Name_List (1 .. 7) := (
6843                       Name_Internal,
6844                       Name_External,
6845                       Name_Parameter_Types,
6846                       Name_Result_Type,
6847                       Name_Mechanism,
6848                       Name_Result_Mechanism,
6849                       Name_First_Optional_Parameter);
6850
6851             Internal                 : Node_Id renames Args (1);
6852             External                 : Node_Id renames Args (2);
6853             Parameter_Types          : Node_Id renames Args (3);
6854             Result_Type              : Node_Id renames Args (4);
6855             Mechanism                : Node_Id renames Args (5);
6856             Result_Mechanism         : Node_Id renames Args (6);
6857             First_Optional_Parameter : Node_Id renames Args (7);
6858
6859          begin
6860             GNAT_Pragma;
6861             Gather_Associations (Names, Args);
6862             Process_Extended_Import_Export_Subprogram_Pragma (
6863               Arg_Internal                 => Internal,
6864               Arg_External                 => External,
6865               Arg_Parameter_Types          => Parameter_Types,
6866               Arg_Result_Type              => Result_Type,
6867               Arg_Mechanism                => Mechanism,
6868               Arg_Result_Mechanism         => Result_Mechanism,
6869               Arg_First_Optional_Parameter => First_Optional_Parameter);
6870          end Import_Function;
6871
6872          -------------------
6873          -- Import_Object --
6874          -------------------
6875
6876          --  pragma Import_Object (
6877          --        [Internal =>] LOCAL_NAME,
6878          --     [, [External =>] EXTERNAL_SYMBOL]
6879          --     [, [Size     =>] EXTERNAL_SYMBOL]);
6880
6881          --  EXTERNAL_SYMBOL ::=
6882          --    IDENTIFIER
6883          --  | static_string_EXPRESSION
6884
6885          when Pragma_Import_Object => Import_Object : declare
6886             Args  : Args_List (1 .. 3);
6887             Names : constant Name_List (1 .. 3) := (
6888                       Name_Internal,
6889                       Name_External,
6890                       Name_Size);
6891
6892             Internal : Node_Id renames Args (1);
6893             External : Node_Id renames Args (2);
6894             Size     : Node_Id renames Args (3);
6895
6896          begin
6897             GNAT_Pragma;
6898             Gather_Associations (Names, Args);
6899             Process_Extended_Import_Export_Object_Pragma (
6900               Arg_Internal => Internal,
6901               Arg_External => External,
6902               Arg_Size     => Size);
6903          end Import_Object;
6904
6905          ----------------------
6906          -- Import_Procedure --
6907          ----------------------
6908
6909          --  pragma Import_Procedure (
6910          --        [Internal                 =>] LOCAL_NAME,
6911          --     [, [External                 =>] EXTERNAL_SYMBOL]
6912          --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
6913          --     [, [Mechanism                =>] MECHANISM]
6914          --     [, [First_Optional_Parameter =>] IDENTIFIER]);
6915
6916          --  EXTERNAL_SYMBOL ::=
6917          --    IDENTIFIER
6918          --  | static_string_EXPRESSION
6919
6920          --  PARAMETER_TYPES ::=
6921          --    null
6922          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6923
6924          --  TYPE_DESIGNATOR ::=
6925          --    subtype_NAME
6926          --  | subtype_Name ' Access
6927
6928          --  MECHANISM ::=
6929          --    MECHANISM_NAME
6930          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6931
6932          --  MECHANISM_ASSOCIATION ::=
6933          --    [formal_parameter_NAME =>] MECHANISM_NAME
6934
6935          --  MECHANISM_NAME ::=
6936          --    Value
6937          --  | Reference
6938          --  | Descriptor [([Class =>] CLASS_NAME)]
6939
6940          --  CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
6941
6942          when Pragma_Import_Procedure => Import_Procedure : declare
6943             Args  : Args_List (1 .. 5);
6944             Names : constant Name_List (1 .. 5) := (
6945                       Name_Internal,
6946                       Name_External,
6947                       Name_Parameter_Types,
6948                       Name_Mechanism,
6949                       Name_First_Optional_Parameter);
6950
6951             Internal                 : Node_Id renames Args (1);
6952             External                 : Node_Id renames Args (2);
6953             Parameter_Types          : Node_Id renames Args (3);
6954             Mechanism                : Node_Id renames Args (4);
6955             First_Optional_Parameter : Node_Id renames Args (5);
6956
6957          begin
6958             GNAT_Pragma;
6959             Gather_Associations (Names, Args);
6960             Process_Extended_Import_Export_Subprogram_Pragma (
6961               Arg_Internal                 => Internal,
6962               Arg_External                 => External,
6963               Arg_Parameter_Types          => Parameter_Types,
6964               Arg_Mechanism                => Mechanism,
6965               Arg_First_Optional_Parameter => First_Optional_Parameter);
6966          end Import_Procedure;
6967
6968          -----------------------------
6969          -- Import_Valued_Procedure --
6970          -----------------------------
6971
6972          --  pragma Import_Valued_Procedure (
6973          --        [Internal                 =>] LOCAL_NAME,
6974          --     [, [External                 =>] EXTERNAL_SYMBOL]
6975          --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
6976          --     [, [Mechanism                =>] MECHANISM]
6977          --     [, [First_Optional_Parameter =>] IDENTIFIER]);
6978
6979          --  EXTERNAL_SYMBOL ::=
6980          --    IDENTIFIER
6981          --  | static_string_EXPRESSION
6982
6983          --  PARAMETER_TYPES ::=
6984          --    null
6985          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
6986
6987          --  TYPE_DESIGNATOR ::=
6988          --    subtype_NAME
6989          --  | subtype_Name ' Access
6990
6991          --  MECHANISM ::=
6992          --    MECHANISM_NAME
6993          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
6994
6995          --  MECHANISM_ASSOCIATION ::=
6996          --    [formal_parameter_NAME =>] MECHANISM_NAME
6997
6998          --  MECHANISM_NAME ::=
6999          --    Value
7000          --  | Reference
7001          --  | Descriptor [([Class =>] CLASS_NAME)]
7002
7003          --  CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
7004
7005          when Pragma_Import_Valued_Procedure =>
7006          Import_Valued_Procedure : declare
7007             Args  : Args_List (1 .. 5);
7008             Names : constant Name_List (1 .. 5) := (
7009                       Name_Internal,
7010                       Name_External,
7011                       Name_Parameter_Types,
7012                       Name_Mechanism,
7013                       Name_First_Optional_Parameter);
7014
7015             Internal                 : Node_Id renames Args (1);
7016             External                 : Node_Id renames Args (2);
7017             Parameter_Types          : Node_Id renames Args (3);
7018             Mechanism                : Node_Id renames Args (4);
7019             First_Optional_Parameter : Node_Id renames Args (5);
7020
7021          begin
7022             GNAT_Pragma;
7023             Gather_Associations (Names, Args);
7024             Process_Extended_Import_Export_Subprogram_Pragma (
7025               Arg_Internal                 => Internal,
7026               Arg_External                 => External,
7027               Arg_Parameter_Types          => Parameter_Types,
7028               Arg_Mechanism                => Mechanism,
7029               Arg_First_Optional_Parameter => First_Optional_Parameter);
7030          end Import_Valued_Procedure;
7031
7032          ------------------------
7033          -- Initialize_Scalars --
7034          ------------------------
7035
7036          --  pragma Initialize_Scalars;
7037
7038          when Pragma_Initialize_Scalars =>
7039             GNAT_Pragma;
7040             Check_Arg_Count (0);
7041             Check_Valid_Configuration_Pragma;
7042             Check_Restriction (No_Initialize_Scalars, N);
7043
7044             if not Restriction_Active (No_Initialize_Scalars) then
7045                Init_Or_Norm_Scalars := True;
7046                Initialize_Scalars := True;
7047             end if;
7048
7049          ------------
7050          -- Inline --
7051          ------------
7052
7053          --  pragma Inline ( NAME {, NAME} );
7054
7055          when Pragma_Inline =>
7056
7057             --  Pragma is active if inlining option is active
7058
7059             Process_Inline (Inline_Active);
7060
7061          -------------------
7062          -- Inline_Always --
7063          -------------------
7064
7065          --  pragma Inline_Always ( NAME {, NAME} );
7066
7067          when Pragma_Inline_Always =>
7068             Process_Inline (True);
7069
7070          --------------------
7071          -- Inline_Generic --
7072          --------------------
7073
7074          --  pragma Inline_Generic (NAME {, NAME});
7075
7076          when Pragma_Inline_Generic =>
7077             Process_Generic_List;
7078
7079          ----------------------
7080          -- Inspection_Point --
7081          ----------------------
7082
7083          --  pragma Inspection_Point [(object_NAME {, object_NAME})];
7084
7085          when Pragma_Inspection_Point => Inspection_Point : declare
7086             Arg : Node_Id;
7087             Exp : Node_Id;
7088
7089          begin
7090             if Arg_Count > 0 then
7091                Arg := Arg1;
7092                loop
7093                   Exp := Expression (Arg);
7094                   Analyze (Exp);
7095
7096                   if not Is_Entity_Name (Exp)
7097                     or else not Is_Object (Entity (Exp))
7098                   then
7099                      Error_Pragma_Arg ("object name required", Arg);
7100                   end if;
7101
7102                   Next (Arg);
7103                   exit when No (Arg);
7104                end loop;
7105             end if;
7106          end Inspection_Point;
7107
7108          ---------------
7109          -- Interface --
7110          ---------------
7111
7112          --  pragma Interface (
7113          --    convention_IDENTIFIER,
7114          --    local_NAME );
7115
7116          when Pragma_Interface =>
7117             GNAT_Pragma;
7118             Check_Arg_Count (2);
7119             Check_No_Identifiers;
7120             Process_Import_Or_Interface;
7121
7122          --------------------
7123          -- Interface_Name --
7124          --------------------
7125
7126          --  pragma Interface_Name (
7127          --    [  Entity        =>] local_NAME
7128          --    [,[External_Name =>] static_string_EXPRESSION ]
7129          --    [,[Link_Name     =>] static_string_EXPRESSION ]);
7130
7131          when Pragma_Interface_Name => Interface_Name : declare
7132             Id     : Node_Id;
7133             Def_Id : Entity_Id;
7134             Hom_Id : Entity_Id;
7135             Found  : Boolean;
7136
7137          begin
7138             GNAT_Pragma;
7139             Check_Arg_Order
7140               ((Name_Entity, Name_External_Name, Name_Link_Name));
7141             Check_At_Least_N_Arguments (2);
7142             Check_At_Most_N_Arguments  (3);
7143             Id := Expression (Arg1);
7144             Analyze (Id);
7145
7146             if not Is_Entity_Name (Id) then
7147                Error_Pragma_Arg
7148                  ("first argument for pragma% must be entity name", Arg1);
7149             elsif Etype (Id) = Any_Type then
7150                return;
7151             else
7152                Def_Id := Entity (Id);
7153             end if;
7154
7155             --  Special DEC-compatible processing for the object case,
7156             --  forces object to be imported.
7157
7158             if Ekind (Def_Id) = E_Variable then
7159                Kill_Size_Check_Code (Def_Id);
7160                Note_Possible_Modification (Id);
7161
7162                --  Initialization is not allowed for imported variable
7163
7164                if Present (Expression (Parent (Def_Id)))
7165                  and then Comes_From_Source (Expression (Parent (Def_Id)))
7166                then
7167                   Error_Msg_Sloc := Sloc (Def_Id);
7168                   Error_Pragma_Arg
7169                     ("no initialization allowed for declaration of& #",
7170                      Arg2);
7171
7172                else
7173                   --  For compatibility, support VADS usage of providing both
7174                   --  pragmas Interface and Interface_Name to obtain the effect
7175                   --  of a single Import pragma.
7176
7177                   if Is_Imported (Def_Id)
7178                     and then Present (First_Rep_Item (Def_Id))
7179                     and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
7180                     and then Chars (First_Rep_Item (Def_Id)) = Name_Interface
7181                   then
7182                      null;
7183                   else
7184                      Set_Imported (Def_Id);
7185                   end if;
7186
7187                   Set_Is_Public (Def_Id);
7188                   Process_Interface_Name (Def_Id, Arg2, Arg3);
7189                end if;
7190
7191             --  Otherwise must be subprogram
7192
7193             elsif not Is_Subprogram (Def_Id) then
7194                Error_Pragma_Arg
7195                  ("argument of pragma% is not subprogram", Arg1);
7196
7197             else
7198                Check_At_Most_N_Arguments (3);
7199                Hom_Id := Def_Id;
7200                Found := False;
7201
7202                --  Loop through homonyms
7203
7204                loop
7205                   Def_Id := Get_Base_Subprogram (Hom_Id);
7206
7207                   if Is_Imported (Def_Id) then
7208                      Process_Interface_Name (Def_Id, Arg2, Arg3);
7209                      Found := True;
7210                   end if;
7211
7212                   Hom_Id := Homonym (Hom_Id);
7213
7214                   exit when No (Hom_Id)
7215                     or else Scope (Hom_Id) /= Current_Scope;
7216                end loop;
7217
7218                if not Found then
7219                   Error_Pragma_Arg
7220                     ("argument of pragma% is not imported subprogram",
7221                      Arg1);
7222                end if;
7223             end if;
7224          end Interface_Name;
7225
7226          -----------------------
7227          -- Interrupt_Handler --
7228          -----------------------
7229
7230          --  pragma Interrupt_Handler (handler_NAME);
7231
7232          when Pragma_Interrupt_Handler =>
7233             Check_Ada_83_Warning;
7234             Check_Arg_Count (1);
7235             Check_No_Identifiers;
7236
7237             if No_Run_Time_Mode then
7238                Error_Msg_CRT ("Interrupt_Handler pragma", N);
7239             else
7240                Check_Interrupt_Or_Attach_Handler;
7241                Process_Interrupt_Or_Attach_Handler;
7242             end if;
7243
7244          ------------------------
7245          -- Interrupt_Priority --
7246          ------------------------
7247
7248          --  pragma Interrupt_Priority [(EXPRESSION)];
7249
7250          when Pragma_Interrupt_Priority => Interrupt_Priority : declare
7251             P   : constant Node_Id := Parent (N);
7252             Arg : Node_Id;
7253
7254          begin
7255             Check_Ada_83_Warning;
7256
7257             if Arg_Count /= 0 then
7258                Arg := Expression (Arg1);
7259                Check_Arg_Count (1);
7260                Check_No_Identifiers;
7261
7262                --  The expression must be analyzed in the special manner
7263                --  described in "Handling of Default and Per-Object
7264                --  Expressions" in sem.ads.
7265
7266                Analyze_Per_Use_Expression (Arg, RTE (RE_Interrupt_Priority));
7267             end if;
7268
7269             if Nkind (P) /= N_Task_Definition
7270               and then Nkind (P) /= N_Protected_Definition
7271             then
7272                Pragma_Misplaced;
7273                return;
7274
7275             elsif Has_Priority_Pragma (P) then
7276                Error_Pragma ("duplicate pragma% not allowed");
7277
7278             else
7279                Set_Has_Priority_Pragma (P, True);
7280                Record_Rep_Item (Defining_Identifier (Parent (P)), N);
7281             end if;
7282          end Interrupt_Priority;
7283
7284          ---------------------
7285          -- Interrupt_State --
7286          ---------------------
7287
7288          --  pragma Interrupt_State (
7289          --    [Name  =>] INTERRUPT_ID,
7290          --    [State =>] INTERRUPT_STATE);
7291
7292          --  INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
7293          --  INTERRUPT_STATE => System | Runtime | User
7294
7295          --  Note: if the interrupt id is given as an identifier, then
7296          --  it must be one of the identifiers in Ada.Interrupts.Names.
7297          --  Otherwise it is given as a static integer expression which
7298          --  must be in the range of Ada.Interrupts.Interrupt_ID.
7299
7300          when Pragma_Interrupt_State => Interrupt_State : declare
7301
7302             Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
7303             --  This is the entity Ada.Interrupts.Interrupt_ID;
7304
7305             State_Type : Character;
7306             --  Set to 's'/'r'/'u' for System/Runtime/User
7307
7308             IST_Num : Pos;
7309             --  Index to entry in Interrupt_States table
7310
7311             Int_Val : Uint;
7312             --  Value of interrupt
7313
7314             Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
7315             --  The first argument to the pragma
7316
7317             Int_Ent : Entity_Id;
7318             --  Interrupt entity in Ada.Interrupts.Names
7319
7320          begin
7321             GNAT_Pragma;
7322             Check_Arg_Order ((Name_Name, Name_State));
7323             Check_Arg_Count (2);
7324
7325             Check_Optional_Identifier (Arg1, Name_Name);
7326             Check_Optional_Identifier (Arg2, Name_State);
7327             Check_Arg_Is_Identifier (Arg2);
7328
7329             --  First argument is identifier
7330
7331             if Nkind (Arg1X) = N_Identifier then
7332
7333                --  Search list of names in Ada.Interrupts.Names
7334
7335                Int_Ent := First_Entity (RTE (RE_Names));
7336                loop
7337                   if No (Int_Ent) then
7338                      Error_Pragma_Arg ("invalid interrupt name", Arg1);
7339
7340                   elsif Chars (Int_Ent) = Chars (Arg1X) then
7341                      Int_Val := Expr_Value (Constant_Value (Int_Ent));
7342                      exit;
7343                   end if;
7344
7345                   Next_Entity (Int_Ent);
7346                end loop;
7347
7348             --  First argument is not an identifier, so it must be a
7349             --  static expression of type Ada.Interrupts.Interrupt_ID.
7350
7351             else
7352                Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
7353                Int_Val := Expr_Value (Arg1X);
7354
7355                if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
7356                     or else
7357                   Int_Val > Expr_Value (Type_High_Bound (Int_Id))
7358                then
7359                   Error_Pragma_Arg
7360                     ("value not in range of type " &
7361                      """Ada.Interrupts.Interrupt_'I'D""", Arg1);
7362                end if;
7363             end if;
7364
7365             --  Check OK state
7366
7367             case Chars (Get_Pragma_Arg (Arg2)) is
7368                when Name_Runtime => State_Type := 'r';
7369                when Name_System  => State_Type := 's';
7370                when Name_User    => State_Type := 'u';
7371
7372                when others =>
7373                   Error_Pragma_Arg ("invalid interrupt state", Arg2);
7374             end case;
7375
7376             --  Check if entry is already stored
7377
7378             IST_Num := Interrupt_States.First;
7379             loop
7380                --  If entry not found, add it
7381
7382                if IST_Num > Interrupt_States.Last then
7383                   Interrupt_States.Append
7384                     ((Interrupt_Number => UI_To_Int (Int_Val),
7385                       Interrupt_State  => State_Type,
7386                       Pragma_Loc       => Loc));
7387                   exit;
7388
7389                --  Case of entry for the same entry
7390
7391                elsif Int_Val = Interrupt_States.Table (IST_Num).
7392                                                            Interrupt_Number
7393                then
7394                   --  If state matches, done, no need to make redundant entry
7395
7396                   exit when
7397                     State_Type = Interrupt_States.Table (IST_Num).
7398                                                            Interrupt_State;
7399
7400                   --  Otherwise if state does not match, error
7401
7402                   Error_Msg_Sloc :=
7403                     Interrupt_States.Table (IST_Num).Pragma_Loc;
7404                   Error_Pragma_Arg
7405                     ("state conflicts with that given at #", Arg2);
7406                   exit;
7407                end if;
7408
7409                IST_Num := IST_Num + 1;
7410             end loop;
7411          end Interrupt_State;
7412
7413          ----------------------
7414          -- Java_Constructor --
7415          ----------------------
7416
7417          --  pragma Java_Constructor ([Entity =>] LOCAL_NAME);
7418
7419          when Pragma_Java_Constructor => Java_Constructor : declare
7420             Id     : Entity_Id;
7421             Def_Id : Entity_Id;
7422             Hom_Id : Entity_Id;
7423
7424          begin
7425             GNAT_Pragma;
7426             Check_Arg_Count (1);
7427             Check_Optional_Identifier (Arg1, Name_Entity);
7428             Check_Arg_Is_Local_Name (Arg1);
7429
7430             Id := Expression (Arg1);
7431             Find_Program_Unit_Name (Id);
7432
7433             --  If we did not find the name, we are done
7434
7435             if Etype (Id) = Any_Type then
7436                return;
7437             end if;
7438
7439             Hom_Id := Entity (Id);
7440
7441             --  Loop through homonyms
7442
7443             loop
7444                Def_Id := Get_Base_Subprogram (Hom_Id);
7445
7446                --  The constructor is required to be a function returning
7447                --  an access type whose designated type has convention Java.
7448
7449                if Ekind (Def_Id) = E_Function
7450                  and then Ekind (Etype (Def_Id)) in Access_Kind
7451                  and then
7452                    (Atree.Convention
7453                       (Designated_Type (Etype (Def_Id))) = Convention_Java
7454                    or else
7455                      Atree.Convention
7456                       (Root_Type (Designated_Type (Etype (Def_Id))))
7457                         = Convention_Java)
7458                then
7459                   Set_Is_Constructor (Def_Id);
7460                   Set_Convention     (Def_Id, Convention_Java);
7461
7462                else
7463                   Error_Pragma_Arg
7464                     ("pragma% requires function returning a 'Java access type",
7465                       Arg1);
7466                end if;
7467
7468                Hom_Id := Homonym (Hom_Id);
7469
7470                exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
7471             end loop;
7472          end Java_Constructor;
7473
7474          ----------------------
7475          -- Java_Interface --
7476          ----------------------
7477
7478          --  pragma Java_Interface ([Entity =>] LOCAL_NAME);
7479
7480          when Pragma_Java_Interface => Java_Interface : declare
7481             Arg : Node_Id;
7482             Typ : Entity_Id;
7483
7484          begin
7485             GNAT_Pragma;
7486             Check_Arg_Count (1);
7487             Check_Optional_Identifier (Arg1, Name_Entity);
7488             Check_Arg_Is_Local_Name (Arg1);
7489
7490             Arg := Expression (Arg1);
7491             Analyze (Arg);
7492
7493             if Etype (Arg) = Any_Type then
7494                return;
7495             end if;
7496
7497             if not Is_Entity_Name (Arg)
7498               or else not Is_Type (Entity (Arg))
7499             then
7500                Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
7501             end if;
7502
7503             Typ := Underlying_Type (Entity (Arg));
7504
7505             --  For now we simply check some of the semantic constraints
7506             --  on the type. This currently leaves out some restrictions
7507             --  on interface types, namely that the parent type must be
7508             --  java.lang.Object.Typ and that all primitives of the type
7509             --  should be declared abstract. ???
7510
7511             if not Is_Tagged_Type (Typ) or else not Is_Abstract (Typ) then
7512                Error_Pragma_Arg ("pragma% requires an abstract "
7513                  & "tagged type", Arg1);
7514
7515             elsif not Has_Discriminants (Typ)
7516               or else Ekind (Etype (First_Discriminant (Typ)))
7517                         /= E_Anonymous_Access_Type
7518               or else
7519                 not Is_Class_Wide_Type
7520                       (Designated_Type (Etype (First_Discriminant (Typ))))
7521             then
7522                Error_Pragma_Arg
7523                  ("type must have a class-wide access discriminant", Arg1);
7524             end if;
7525          end Java_Interface;
7526
7527          ----------------
7528          -- Keep_Names --
7529          ----------------
7530
7531          --  pragma Keep_Names ([On => ] local_NAME);
7532
7533          when Pragma_Keep_Names => Keep_Names : declare
7534             Arg : Node_Id;
7535
7536          begin
7537             GNAT_Pragma;
7538             Check_Arg_Count (1);
7539             Check_Optional_Identifier (Arg1, Name_On);
7540             Check_Arg_Is_Local_Name (Arg1);
7541
7542             Arg := Expression (Arg1);
7543             Analyze (Arg);
7544
7545             if Etype (Arg) = Any_Type then
7546                return;
7547             end if;
7548
7549             if not Is_Entity_Name (Arg)
7550               or else Ekind (Entity (Arg)) /= E_Enumeration_Type
7551             then
7552                Error_Pragma_Arg
7553                  ("pragma% requires a local enumeration type", Arg1);
7554             end if;
7555
7556             Set_Discard_Names (Entity (Arg), False);
7557          end Keep_Names;
7558
7559          -------------
7560          -- License --
7561          -------------
7562
7563          --  pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
7564
7565          when Pragma_License =>
7566             GNAT_Pragma;
7567             Check_Arg_Count (1);
7568             Check_No_Identifiers;
7569             Check_Valid_Configuration_Pragma;
7570             Check_Arg_Is_Identifier (Arg1);
7571
7572             declare
7573                Sind : constant Source_File_Index :=
7574                         Source_Index (Current_Sem_Unit);
7575
7576             begin
7577                case Chars (Get_Pragma_Arg (Arg1)) is
7578                   when Name_GPL =>
7579                      Set_License (Sind, GPL);
7580
7581                   when Name_Modified_GPL =>
7582                      Set_License (Sind, Modified_GPL);
7583
7584                   when Name_Restricted =>
7585                      Set_License (Sind, Restricted);
7586
7587                   when Name_Unrestricted =>
7588                      Set_License (Sind, Unrestricted);
7589
7590                   when others =>
7591                      Error_Pragma_Arg ("invalid license name", Arg1);
7592                end case;
7593             end;
7594
7595          ---------------
7596          -- Link_With --
7597          ---------------
7598
7599          --  pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
7600
7601          when Pragma_Link_With => Link_With : declare
7602             Arg : Node_Id;
7603
7604          begin
7605             GNAT_Pragma;
7606
7607             if Operating_Mode = Generate_Code
7608               and then In_Extended_Main_Source_Unit (N)
7609             then
7610                Check_At_Least_N_Arguments (1);
7611                Check_No_Identifiers;
7612                Check_Is_In_Decl_Part_Or_Package_Spec;
7613                Check_Arg_Is_Static_Expression (Arg1, Standard_String);
7614                Start_String;
7615
7616                Arg := Arg1;
7617                while Present (Arg) loop
7618                   Check_Arg_Is_Static_Expression (Arg, Standard_String);
7619
7620                   --  Store argument, converting sequences of spaces
7621                   --  to a single null character (this is one of the
7622                   --  differences in processing between Link_With
7623                   --  and Linker_Options).
7624
7625                   declare
7626                      C : constant Char_Code := Get_Char_Code (' ');
7627                      S : constant String_Id :=
7628                            Strval (Expr_Value_S (Expression (Arg)));
7629                      L : constant Nat := String_Length (S);
7630                      F : Nat := 1;
7631
7632                      procedure Skip_Spaces;
7633                      --  Advance F past any spaces
7634
7635                      procedure Skip_Spaces is
7636                      begin
7637                         while F <= L and then Get_String_Char (S, F) = C loop
7638                            F := F + 1;
7639                         end loop;
7640                      end Skip_Spaces;
7641
7642                   begin
7643                      Skip_Spaces; -- skip leading spaces
7644
7645                      --  Loop through characters, changing any embedded
7646                      --  sequence of spaces to a single null character
7647                      --  (this is how Link_With/Linker_Options differ)
7648
7649                      while F <= L loop
7650                         if Get_String_Char (S, F) = C then
7651                            Skip_Spaces;
7652                            exit when F > L;
7653                            Store_String_Char (ASCII.NUL);
7654
7655                         else
7656                            Store_String_Char (Get_String_Char (S, F));
7657                            F := F + 1;
7658                         end if;
7659                      end loop;
7660                   end;
7661
7662                   Arg := Next (Arg);
7663
7664                   if Present (Arg) then
7665                      Store_String_Char (ASCII.NUL);
7666                   end if;
7667                end loop;
7668
7669                Store_Linker_Option_String (End_String);
7670             end if;
7671          end Link_With;
7672
7673          ------------------
7674          -- Linker_Alias --
7675          ------------------
7676
7677          --  pragma Linker_Alias (
7678          --      [Entity =>]  LOCAL_NAME
7679          --      [Target =>]  static_string_EXPRESSION);
7680
7681          when Pragma_Linker_Alias =>
7682             GNAT_Pragma;
7683             Check_Arg_Order ((Name_Entity, Name_Target));
7684             Check_Arg_Count (2);
7685             Check_Optional_Identifier (Arg1, Name_Entity);
7686             Check_Optional_Identifier (Arg2, Name_Target);
7687             Check_Arg_Is_Library_Level_Local_Name (Arg1);
7688             Check_Arg_Is_Static_Expression (Arg2, Standard_String);
7689
7690             --  The only processing required is to link this item on to the
7691             --  list of rep items for the given entity. This is accomplished
7692             --  by the call to Rep_Item_Too_Late (when no error is detected
7693             --  and False is returned).
7694
7695             if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
7696                return;
7697             else
7698                Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
7699             end if;
7700
7701          ------------------------
7702          -- Linker_Constructor --
7703          ------------------------
7704
7705          --  pragma Linker_Constructor (procedure_LOCAL_NAME);
7706
7707          --  Code is shared with Linker_Destructor
7708
7709          -----------------------
7710          -- Linker_Destructor --
7711          -----------------------
7712
7713          --  pragma Linker_Destructor (procedure_LOCAL_NAME);
7714
7715          when Pragma_Linker_Constructor |
7716               Pragma_Linker_Destructor =>
7717          Linker_Constructor : declare
7718             Arg1_X : Node_Id;
7719             Proc   : Entity_Id;
7720
7721          begin
7722             GNAT_Pragma;
7723             Check_Arg_Count (1);
7724             Check_No_Identifiers;
7725             Check_Arg_Is_Local_Name (Arg1);
7726             Arg1_X := Expression (Arg1);
7727             Analyze (Arg1_X);
7728             Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
7729
7730             if not Is_Library_Level_Entity (Proc) then
7731                Error_Pragma_Arg
7732                 ("argument for pragma% must be library level entity", Arg1);
7733             end if;
7734
7735             --  The only processing required is to link this item on to the
7736             --  list of rep items for the given entity. This is accomplished
7737             --  by the call to Rep_Item_Too_Late (when no error is detected
7738             --  and False is returned).
7739
7740             if Rep_Item_Too_Late (Proc, N) then
7741                return;
7742             else
7743                Set_Has_Gigi_Rep_Item (Proc);
7744             end if;
7745          end Linker_Constructor;
7746
7747          --------------------
7748          -- Linker_Options --
7749          --------------------
7750
7751          --  pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
7752
7753          when Pragma_Linker_Options => Linker_Options : declare
7754             Arg : Node_Id;
7755
7756          begin
7757             Check_Ada_83_Warning;
7758             Check_No_Identifiers;
7759             Check_Arg_Count (1);
7760             Check_Is_In_Decl_Part_Or_Package_Spec;
7761
7762             if Operating_Mode = Generate_Code
7763               and then In_Extended_Main_Source_Unit (N)
7764             then
7765                Check_Arg_Is_Static_Expression (Arg1, Standard_String);
7766                Start_String (Strval (Expr_Value_S (Expression (Arg1))));
7767
7768                Arg := Arg2;
7769                while Present (Arg) loop
7770                   Check_Arg_Is_Static_Expression (Arg, Standard_String);
7771                   Store_String_Char (ASCII.NUL);
7772                   Store_String_Chars
7773                     (Strval (Expr_Value_S (Expression (Arg))));
7774                   Arg := Next (Arg);
7775                end loop;
7776
7777                Store_Linker_Option_String (End_String);
7778             end if;
7779          end Linker_Options;
7780
7781          --------------------
7782          -- Linker_Section --
7783          --------------------
7784
7785          --  pragma Linker_Section (
7786          --      [Entity  =>]  LOCAL_NAME
7787          --      [Section =>]  static_string_EXPRESSION);
7788
7789          when Pragma_Linker_Section =>
7790             GNAT_Pragma;
7791             Check_Arg_Order ((Name_Entity, Name_Section));
7792             Check_Arg_Count (2);
7793             Check_Optional_Identifier (Arg1, Name_Entity);
7794             Check_Optional_Identifier (Arg2, Name_Section);
7795             Check_Arg_Is_Library_Level_Local_Name (Arg1);
7796             Check_Arg_Is_Static_Expression (Arg2, Standard_String);
7797
7798             --  The only processing required is to link this item on to the
7799             --  list of rep items for the given entity. This is accomplished
7800             --  by the call to Rep_Item_Too_Late (when no error is detected
7801             --  and False is returned).
7802
7803             if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
7804                return;
7805             else
7806                Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
7807             end if;
7808
7809          ----------
7810          -- List --
7811          ----------
7812
7813          --  pragma List (On | Off)
7814
7815          --  There is nothing to do here, since we did all the processing
7816          --  for this pragma in Par.Prag (so that it works properly even in
7817          --  syntax only mode)
7818
7819          when Pragma_List =>
7820             null;
7821
7822          --------------------
7823          -- Locking_Policy --
7824          --------------------
7825
7826          --  pragma Locking_Policy (policy_IDENTIFIER);
7827
7828          when Pragma_Locking_Policy => declare
7829             LP : Character;
7830
7831          begin
7832             Check_Ada_83_Warning;
7833             Check_Arg_Count (1);
7834             Check_No_Identifiers;
7835             Check_Arg_Is_Locking_Policy (Arg1);
7836             Check_Valid_Configuration_Pragma;
7837             Get_Name_String (Chars (Expression (Arg1)));
7838             LP := Fold_Upper (Name_Buffer (1));
7839
7840             if Locking_Policy /= ' '
7841               and then Locking_Policy /= LP
7842             then
7843                Error_Msg_Sloc := Locking_Policy_Sloc;
7844                Error_Pragma ("locking policy incompatible with policy#");
7845
7846             --  Set new policy, but always preserve System_Location since
7847             --  we like the error message with the run time name.
7848
7849             else
7850                Locking_Policy := LP;
7851
7852                if Locking_Policy_Sloc /= System_Location then
7853                   Locking_Policy_Sloc := Loc;
7854                end if;
7855             end if;
7856          end;
7857
7858          ----------------
7859          -- Long_Float --
7860          ----------------
7861
7862          --  pragma Long_Float (D_Float | G_Float);
7863
7864          when Pragma_Long_Float =>
7865             GNAT_Pragma;
7866             Check_Valid_Configuration_Pragma;
7867             Check_Arg_Count (1);
7868             Check_No_Identifier (Arg1);
7869             Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
7870
7871             if not OpenVMS_On_Target then
7872                Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)");
7873             end if;
7874
7875             --  D_Float case
7876
7877             if Chars (Expression (Arg1)) = Name_D_Float then
7878                if Opt.Float_Format_Long = 'G' then
7879                   Error_Pragma ("G_Float previously specified");
7880                end if;
7881
7882                Opt.Float_Format_Long := 'D';
7883
7884             --  G_Float case (this is the default, does not need overriding)
7885
7886             else
7887                if Opt.Float_Format_Long = 'D' then
7888                   Error_Pragma ("D_Float previously specified");
7889                end if;
7890
7891                Opt.Float_Format_Long := 'G';
7892             end if;
7893
7894             Set_Standard_Fpt_Formats;
7895
7896          -----------------------
7897          -- Machine_Attribute --
7898          -----------------------
7899
7900          --  pragma Machine_Attribute (
7901          --    [Entity         =>] LOCAL_NAME,
7902          --    [Attribute_Name =>] static_string_EXPRESSION
7903          --  [,[Info           =>] static_string_EXPRESSION] );
7904
7905          when Pragma_Machine_Attribute => Machine_Attribute : declare
7906             Def_Id : Entity_Id;
7907
7908          begin
7909             GNAT_Pragma;
7910             Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
7911
7912             if Arg_Count = 3 then
7913                Check_Optional_Identifier (Arg3, Name_Info);
7914                Check_Arg_Is_Static_Expression (Arg3, Standard_String);
7915             else
7916                Check_Arg_Count (2);
7917             end if;
7918
7919             Check_Optional_Identifier (Arg1, Name_Entity);
7920             Check_Optional_Identifier (Arg2, Name_Attribute_Name);
7921             Check_Arg_Is_Local_Name (Arg1);
7922             Check_Arg_Is_Static_Expression (Arg2, Standard_String);
7923             Def_Id := Entity (Expression (Arg1));
7924
7925             if Is_Access_Type (Def_Id) then
7926                Def_Id := Designated_Type (Def_Id);
7927             end if;
7928
7929             if Rep_Item_Too_Early (Def_Id, N) then
7930                return;
7931             end if;
7932
7933             Def_Id := Underlying_Type (Def_Id);
7934
7935             --  The only processing required is to link this item on to the
7936             --  list of rep items for the given entity. This is accomplished
7937             --  by the call to Rep_Item_Too_Late (when no error is detected
7938             --  and False is returned).
7939
7940             if Rep_Item_Too_Late (Def_Id, N) then
7941                return;
7942             else
7943                Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
7944             end if;
7945          end Machine_Attribute;
7946
7947          ----------
7948          -- Main --
7949          ----------
7950
7951          --  pragma Main_Storage
7952          --   (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
7953
7954          --  MAIN_STORAGE_OPTION ::=
7955          --    [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
7956          --  | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
7957
7958          when Pragma_Main => Main : declare
7959             Args  : Args_List (1 .. 3);
7960             Names : constant Name_List (1 .. 3) := (
7961                       Name_Stack_Size,
7962                       Name_Task_Stack_Size_Default,
7963                       Name_Time_Slicing_Enabled);
7964
7965             Nod : Node_Id;
7966
7967          begin
7968             GNAT_Pragma;
7969             Gather_Associations (Names, Args);
7970
7971             for J in 1 .. 2 loop
7972                if Present (Args (J)) then
7973                   Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
7974                end if;
7975             end loop;
7976
7977             if Present (Args (3)) then
7978                Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
7979             end if;
7980
7981             Nod := Next (N);
7982             while Present (Nod) loop
7983                if Nkind (Nod) = N_Pragma
7984                  and then Chars (Nod) = Name_Main
7985                then
7986                   Error_Msg_Name_1 := Chars (N);
7987                   Error_Msg_N ("duplicate pragma% not permitted", Nod);
7988                end if;
7989
7990                Next (Nod);
7991             end loop;
7992          end Main;
7993
7994          ------------------
7995          -- Main_Storage --
7996          ------------------
7997
7998          --  pragma Main_Storage
7999          --   (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
8000
8001          --  MAIN_STORAGE_OPTION ::=
8002          --    [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
8003          --  | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
8004
8005          when Pragma_Main_Storage => Main_Storage : declare
8006             Args  : Args_List (1 .. 2);
8007             Names : constant Name_List (1 .. 2) := (
8008                       Name_Working_Storage,
8009                       Name_Top_Guard);
8010
8011             Nod : Node_Id;
8012
8013          begin
8014             GNAT_Pragma;
8015             Gather_Associations (Names, Args);
8016
8017             for J in 1 .. 2 loop
8018                if Present (Args (J)) then
8019                   Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
8020                end if;
8021             end loop;
8022
8023             Check_In_Main_Program;
8024
8025             Nod := Next (N);
8026             while Present (Nod) loop
8027                if Nkind (Nod) = N_Pragma
8028                  and then Chars (Nod) = Name_Main_Storage
8029                then
8030                   Error_Msg_Name_1 := Chars (N);
8031                   Error_Msg_N ("duplicate pragma% not permitted", Nod);
8032                end if;
8033
8034                Next (Nod);
8035             end loop;
8036          end Main_Storage;
8037
8038          -----------------
8039          -- Memory_Size --
8040          -----------------
8041
8042          --  pragma Memory_Size (NUMERIC_LITERAL)
8043
8044          when Pragma_Memory_Size =>
8045             GNAT_Pragma;
8046
8047             --  Memory size is simply ignored
8048
8049             Check_No_Identifiers;
8050             Check_Arg_Count (1);
8051             Check_Arg_Is_Integer_Literal (Arg1);
8052
8053          ---------------
8054          -- No_Return --
8055          ---------------
8056
8057          --  pragma No_Return (procedure_LOCAL_NAME);
8058
8059          when Pragma_No_Return => No_Return : declare
8060             Id    : Node_Id;
8061             E     : Entity_Id;
8062             Found : Boolean;
8063
8064          begin
8065             GNAT_Pragma;
8066             Check_Arg_Count (1);
8067             Check_No_Identifiers;
8068             Check_Arg_Is_Local_Name (Arg1);
8069             Id := Expression (Arg1);
8070             Analyze (Id);
8071
8072             if not Is_Entity_Name (Id) then
8073                Error_Pragma_Arg ("entity name required", Arg1);
8074             end if;
8075
8076             if Etype (Id) = Any_Type then
8077                raise Pragma_Exit;
8078             end if;
8079
8080             E := Entity (Id);
8081
8082             Found := False;
8083             while Present (E)
8084               and then Scope (E) = Current_Scope
8085             loop
8086                if Ekind (E) = E_Procedure
8087                  or else Ekind (E) = E_Generic_Procedure
8088                then
8089                   Set_No_Return (E);
8090                   Found := True;
8091                end if;
8092
8093                E := Homonym (E);
8094             end loop;
8095
8096             if not Found then
8097                Error_Pragma ("no procedures found for pragma%");
8098             end if;
8099          end No_Return;
8100
8101          ------------------------
8102          -- No_Strict_Aliasing --
8103          ------------------------
8104
8105          --  pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
8106
8107          when Pragma_No_Strict_Aliasing => No_Strict_Alias : declare
8108             E_Id : Entity_Id;
8109
8110          begin
8111             GNAT_Pragma;
8112             Check_At_Most_N_Arguments (1);
8113
8114             if Arg_Count = 0 then
8115                Check_Valid_Configuration_Pragma;
8116                Opt.No_Strict_Aliasing := True;
8117
8118             else
8119                Check_Optional_Identifier (Arg2, Name_Entity);
8120                Check_Arg_Is_Local_Name (Arg1);
8121                E_Id := Entity (Expression (Arg1));
8122
8123                if E_Id = Any_Type then
8124                   return;
8125                elsif No (E_Id) or else not Is_Access_Type (E_Id) then
8126                   Error_Pragma_Arg ("pragma% requires access type", Arg1);
8127                end if;
8128
8129                Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
8130             end if;
8131          end No_Strict_Alias;
8132
8133          -----------------
8134          -- Obsolescent --
8135          -----------------
8136
8137             --  pragma Obsolescent [(static_string_EXPRESSION [, Ada_05])];
8138
8139          when Pragma_Obsolescent => Obsolescent : declare
8140             Subp   : Node_Or_Entity_Id;
8141             S      : String_Id;
8142             Active : Boolean := True;
8143
8144          begin
8145             GNAT_Pragma;
8146             Check_At_Most_N_Arguments (2);
8147             Check_No_Identifiers;
8148
8149             --  Check OK placement
8150
8151             --  First possibility is within a declarative region, where the
8152             --  pragma immediately follows a subprogram declaration.
8153
8154             if Present (Prev (N)) then
8155                Subp := Prev (N);
8156
8157             --  Second possibility, stand alone subprogram declaration with the
8158             --  pragma immediately following the declaration.
8159
8160             elsif No (Prev (N))
8161               and then Nkind (Parent (N)) = N_Compilation_Unit_Aux
8162             then
8163                Subp := Unit (Parent (Parent (N)));
8164
8165             --  Any other possibility is a misplacement
8166
8167             else
8168                Subp := Empty;
8169             end if;
8170
8171             --  Check correct placement
8172
8173             if Nkind (Subp) /= N_Subprogram_Declaration then
8174                Error_Pragma
8175                  ("pragma% misplaced, must immediately " &
8176                   "follow subprogram spec");
8177             end if;
8178
8179             --  If OK placement, acquire arguments
8180
8181             Subp := Defining_Entity (Subp);
8182
8183             if Arg_Count >= 1 then
8184
8185                --  Deal with static string argument
8186
8187                Check_Arg_Is_Static_Expression (Arg1, Standard_String);
8188                S := Strval (Expression (Arg1));
8189
8190                for J in 1 .. String_Length (S) loop
8191                   if not In_Character_Range (Get_String_Char (S, J)) then
8192                      Error_Pragma_Arg
8193                        ("pragma% argument does not allow wide characters",
8194                         Arg1);
8195                   end if;
8196                end loop;
8197
8198                Set_Obsolescent_Warning (Subp, Expression (Arg1));
8199
8200                --  Check for Ada_05 parameter
8201
8202                if Arg_Count /= 1 then
8203                   Check_Arg_Count (2);
8204
8205                   declare
8206                      Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
8207
8208                   begin
8209                      Check_Arg_Is_Identifier (Argx);
8210
8211                      if Chars (Argx) /= Name_Ada_05 then
8212                         Error_Msg_Name_2 := Name_Ada_05;
8213                         Error_Pragma_Arg
8214                           ("only allowed argument for pragma% is %", Argx);
8215                      end if;
8216
8217                      if Ada_Version_Explicit < Ada_05
8218                        or else not Warn_On_Ada_2005_Compatibility
8219                      then
8220                         Active := False;
8221                      end if;
8222                   end;
8223                end if;
8224             end if;
8225
8226             --  Set flag if pragma active
8227
8228             if Active then
8229                Set_Is_Obsolescent (Subp);
8230             end if;
8231          end Obsolescent;
8232
8233          -----------------
8234          -- No_Run_Time --
8235          -----------------
8236
8237          --  pragma No_Run_Time
8238
8239          --  Note: this pragma is retained for backwards compatibiltiy.
8240          --  See body of Rtsfind for full details on its handling.
8241
8242          when Pragma_No_Run_Time =>
8243             GNAT_Pragma;
8244             Check_Valid_Configuration_Pragma;
8245             Check_Arg_Count (0);
8246
8247             No_Run_Time_Mode           := True;
8248             Configurable_Run_Time_Mode := True;
8249
8250             declare
8251                Word32 : constant Boolean := Ttypes.System_Word_Size = 32;
8252             begin
8253                if Word32 then
8254                   Duration_32_Bits_On_Target := True;
8255                end if;
8256             end;
8257
8258             Set_Restriction (No_Finalization, N);
8259             Set_Restriction (No_Exception_Handlers, N);
8260             Set_Restriction (Max_Tasks, N, 0);
8261             Set_Restriction (No_Tasking, N);
8262
8263          -----------------------
8264          -- Normalize_Scalars --
8265          -----------------------
8266
8267          --  pragma Normalize_Scalars;
8268
8269          when Pragma_Normalize_Scalars =>
8270             Check_Ada_83_Warning;
8271             Check_Arg_Count (0);
8272             Check_Valid_Configuration_Pragma;
8273             Normalize_Scalars := True;
8274             Init_Or_Norm_Scalars := True;
8275
8276          --------------
8277          -- Optimize --
8278          --------------
8279
8280          --  pragma Optimize (Time | Space);
8281
8282          --  The actual check for optimize is done in Gigi. Note that this
8283          --  pragma does not actually change the optimization setting, it
8284          --  simply checks that it is consistent with the pragma.
8285
8286          when Pragma_Optimize =>
8287             Check_No_Identifiers;
8288             Check_Arg_Count (1);
8289             Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
8290
8291          -------------------------
8292          -- Optional_Overriding --
8293          -------------------------
8294
8295          --  These pragmas are treated as part of the previous subprogram
8296          --  declaration, and analyzed immediately after it (see sem_ch6,
8297          --  Check_Overriding_Operation). If the pragma has not been analyzed
8298          --  yet, it appears in the wrong place.
8299
8300          when Pragma_Optional_Overriding =>
8301             Error_Msg_N ("pragma must appear immediately after subprogram", N);
8302
8303          ----------
8304          -- Pack --
8305          ----------
8306
8307          --  pragma Pack (first_subtype_LOCAL_NAME);
8308
8309          when Pragma_Pack => Pack : declare
8310             Assoc   : constant Node_Id := Arg1;
8311             Type_Id : Node_Id;
8312             Typ     : Entity_Id;
8313
8314          begin
8315             Check_No_Identifiers;
8316             Check_Arg_Count (1);
8317             Check_Arg_Is_Local_Name (Arg1);
8318
8319             Type_Id := Expression (Assoc);
8320             Find_Type (Type_Id);
8321             Typ := Entity (Type_Id);
8322
8323             if Typ = Any_Type
8324               or else Rep_Item_Too_Early (Typ, N)
8325             then
8326                return;
8327             else
8328                Typ := Underlying_Type (Typ);
8329             end if;
8330
8331             if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
8332                Error_Pragma ("pragma% must specify array or record type");
8333             end if;
8334
8335             Check_First_Subtype (Arg1);
8336
8337             if Has_Pragma_Pack (Typ) then
8338                Error_Pragma ("duplicate pragma%, only one allowed");
8339
8340             --  Array type
8341
8342             elsif Is_Array_Type (Typ) then
8343
8344                --  Pack not allowed for aliased or atomic components
8345
8346                if Has_Aliased_Components (Base_Type (Typ)) then
8347                   Error_Pragma
8348                     ("pragma% ignored, cannot pack aliased components?");
8349
8350                elsif Has_Atomic_Components (Typ)
8351                  or else Is_Atomic (Component_Type (Typ))
8352                then
8353                   Error_Pragma
8354                        ("?pragma% ignored, cannot pack atomic components");
8355                end if;
8356
8357                --  If we had an explicit component size given, then we do not
8358                --  let Pack override this given size. We also give a warning
8359                --  that Pack is being ignored unless we can tell for sure that
8360                --  the Pack would not have had any effect anyway.
8361
8362                if Has_Component_Size_Clause (Typ) then
8363                   if Known_Static_RM_Size (Component_Type (Typ))
8364                     and then
8365                       RM_Size (Component_Type (Typ)) = Component_Size (Typ)
8366                   then
8367                      null;
8368                   else
8369                      Error_Pragma
8370                        ("?pragma% ignored, explicit component size given");
8371                   end if;
8372
8373                --  If no prior array component size given, Pack is effective
8374
8375                else
8376                   if not Rep_Item_Too_Late (Typ, N) then
8377                      Set_Is_Packed            (Base_Type (Typ));
8378                      Set_Has_Pragma_Pack      (Base_Type (Typ));
8379                      Set_Has_Non_Standard_Rep (Base_Type (Typ));
8380                   end if;
8381                end if;
8382
8383             --  For record types, the pack is always effective
8384
8385             else pragma Assert (Is_Record_Type (Typ));
8386                if not Rep_Item_Too_Late (Typ, N) then
8387                   Set_Has_Pragma_Pack      (Base_Type (Typ));
8388                   Set_Is_Packed            (Base_Type (Typ));
8389                   Set_Has_Non_Standard_Rep (Base_Type (Typ));
8390                end if;
8391             end if;
8392          end Pack;
8393
8394          ----------
8395          -- Page --
8396          ----------
8397
8398          --  pragma Page;
8399
8400          --  There is nothing to do here, since we did all the processing
8401          --  for this pragma in Par.Prag (so that it works properly even in
8402          --  syntax only mode)
8403
8404          when Pragma_Page =>
8405             null;
8406
8407          -------------
8408          -- Passive --
8409          -------------
8410
8411          --  pragma Passive [(PASSIVE_FORM)];
8412
8413          --   PASSIVE_FORM ::= Semaphore | No
8414
8415          when Pragma_Passive =>
8416             GNAT_Pragma;
8417
8418             if Nkind (Parent (N)) /= N_Task_Definition then
8419                Error_Pragma ("pragma% must be within task definition");
8420             end if;
8421
8422             if Arg_Count /= 0 then
8423                Check_Arg_Count (1);
8424                Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
8425             end if;
8426
8427          -------------
8428          -- Polling --
8429          -------------
8430
8431          --  pragma Polling (ON | OFF);
8432
8433          when Pragma_Polling =>
8434             GNAT_Pragma;
8435             Check_Arg_Count (1);
8436             Check_No_Identifiers;
8437             Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
8438             Polling_Required := (Chars (Expression (Arg1)) = Name_On);
8439
8440          --------------------
8441          -- Persistent_BSS --
8442          --------------------
8443
8444          when Pragma_Persistent_BSS => Persistent_BSS :  declare
8445             Decl : Node_Id;
8446             Ent  : Entity_Id;
8447             Prag : Node_Id;
8448
8449          begin
8450             GNAT_Pragma;
8451             Check_At_Most_N_Arguments (1);
8452
8453             --  Case of application to specific object (one argument)
8454
8455             if Arg_Count = 1 then
8456                Check_Arg_Is_Library_Level_Local_Name (Arg1);
8457
8458                if not Is_Entity_Name (Expression (Arg1))
8459                  or else
8460                   (Ekind (Entity (Expression (Arg1))) /= E_Variable
8461                     and then Ekind (Entity (Expression (Arg1))) /= E_Constant)
8462                then
8463                   Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
8464                end if;
8465
8466                Ent := Entity (Expression (Arg1));
8467                Decl := Parent (Ent);
8468
8469                if Rep_Item_Too_Late (Ent, N) then
8470                   return;
8471                end if;
8472
8473                if Present (Expression (Decl)) then
8474                   Error_Pragma_Arg
8475                     ("object for pragma% cannot have initialization", Arg1);
8476                end if;
8477
8478                if not Is_Potentially_Persistent_Type (Etype (Ent)) then
8479                   Error_Pragma_Arg
8480                     ("object type for pragma% is not potentially persistent",
8481                      Arg1);
8482                end if;
8483
8484                Prag :=
8485                  Make_Linker_Section_Pragma
8486                    (Ent, Sloc (N), ".persistent.bss");
8487                Insert_After (N, Prag);
8488                Analyze (Prag);
8489
8490             --  Case of use as configuration pragma with no arguments
8491
8492             else
8493                Check_Valid_Configuration_Pragma;
8494                Persistent_BSS_Mode := True;
8495             end if;
8496          end Persistent_BSS;
8497
8498          ------------------
8499          -- Preelaborate --
8500          ------------------
8501
8502          --  pragma Preelaborate [(library_unit_NAME)];
8503
8504          --  Set the flag Is_Preelaborated of program unit name entity
8505
8506          when Pragma_Preelaborate => Preelaborate : declare
8507             Pa  : constant Node_Id   := Parent (N);
8508             Pk  : constant Node_Kind := Nkind (Pa);
8509             Ent : Entity_Id;
8510
8511          begin
8512             Check_Ada_83_Warning;
8513             Check_Valid_Library_Unit_Pragma;
8514
8515             if Nkind (N) = N_Null_Statement then
8516                return;
8517             end if;
8518
8519             Ent := Find_Lib_Unit_Name;
8520
8521             --  This filters out pragmas inside generic parent then
8522             --  show up inside instantiation
8523
8524             if Present (Ent)
8525               and then not (Pk = N_Package_Specification
8526                               and then Present (Generic_Parent (Pa)))
8527             then
8528                if not Debug_Flag_U then
8529                   Set_Is_Preelaborated (Ent);
8530                   Set_Suppress_Elaboration_Warnings (Ent);
8531                end if;
8532             end if;
8533          end Preelaborate;
8534
8535          ---------------------
8536          -- Preelaborate_05 --
8537          ---------------------
8538
8539          --  pragma Preelaborate_05 [(library_unit_NAME)];
8540
8541          --  This pragma is useable only in GNAT_Mode, where it is used like
8542          --  pragma Preelaborate but it is only effective in Ada 2005 mode
8543          --  (otherwise it is ignored). This is used to implement AI-362 which
8544          --  recategorizes some run-time packages in Ada 2005 mode.
8545
8546          when Pragma_Preelaborate_05 => Preelaborate_05 : declare
8547             Ent : Entity_Id;
8548
8549          begin
8550             GNAT_Pragma;
8551             Check_Valid_Library_Unit_Pragma;
8552
8553             if not GNAT_Mode then
8554                Error_Pragma ("pragma% only available in GNAT mode");
8555             end if;
8556
8557             if Nkind (N) = N_Null_Statement then
8558                return;
8559             end if;
8560
8561             --  This is one of the few cases where we need to test the value of
8562             --  Ada_Version_Explicit rather than Ada_Version (which is always
8563             --  set to Ada_05 in a predefined unit), we need to know the
8564             --  explicit version set to know if this pragma is active.
8565
8566             if Ada_Version_Explicit >= Ada_05 then
8567                Ent := Find_Lib_Unit_Name;
8568                Set_Is_Preelaborated (Ent);
8569                Set_Suppress_Elaboration_Warnings (Ent);
8570             end if;
8571          end Preelaborate_05;
8572
8573          --------------
8574          -- Priority --
8575          --------------
8576
8577          --  pragma Priority (EXPRESSION);
8578
8579          when Pragma_Priority => Priority : declare
8580             P   : constant Node_Id := Parent (N);
8581             Arg : Node_Id;
8582
8583          begin
8584             Check_No_Identifiers;
8585             Check_Arg_Count (1);
8586
8587             --  Subprogram case
8588
8589             if Nkind (P) = N_Subprogram_Body then
8590                Check_In_Main_Program;
8591
8592                Arg := Expression (Arg1);
8593                Analyze_And_Resolve (Arg, Standard_Integer);
8594
8595                --  Must be static
8596
8597                if not Is_Static_Expression (Arg) then
8598                   Flag_Non_Static_Expr
8599                     ("main subprogram priority is not static!", Arg);
8600                   raise Pragma_Exit;
8601
8602                --  If constraint error, then we already signalled an error
8603
8604                elsif Raises_Constraint_Error (Arg) then
8605                   null;
8606
8607                --  Otherwise check in range
8608
8609                else
8610                   declare
8611                      Val : constant Uint := Expr_Value (Arg);
8612
8613                   begin
8614                      if Val < 0
8615                        or else Val > Expr_Value (Expression
8616                                        (Parent (RTE (RE_Max_Priority))))
8617                      then
8618                         Error_Pragma_Arg
8619                           ("main subprogram priority is out of range", Arg1);
8620                      end if;
8621                   end;
8622                end if;
8623
8624                Set_Main_Priority
8625                  (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
8626
8627             --  Task or Protected, must be of type Integer
8628
8629             elsif Nkind (P) = N_Protected_Definition
8630                     or else
8631                   Nkind (P) = N_Task_Definition
8632             then
8633                Arg := Expression (Arg1);
8634
8635                --  The expression must be analyzed in the special manner
8636                --  described in "Handling of Default and Per-Object
8637                --  Expressions" in sem.ads.
8638
8639                Analyze_Per_Use_Expression (Arg, Standard_Integer);
8640
8641                if not Is_Static_Expression (Arg) then
8642                   Check_Restriction (Static_Priorities, Arg);
8643                end if;
8644
8645             --  Anything else is incorrect
8646
8647             else
8648                Pragma_Misplaced;
8649             end if;
8650
8651             if Has_Priority_Pragma (P) then
8652                Error_Pragma ("duplicate pragma% not allowed");
8653             else
8654                Set_Has_Priority_Pragma (P, True);
8655
8656                if Nkind (P) = N_Protected_Definition
8657                     or else
8658                   Nkind (P) = N_Task_Definition
8659                then
8660                   Record_Rep_Item (Defining_Identifier (Parent (P)), N);
8661                   --  exp_ch9 should use this ???
8662                end if;
8663             end if;
8664          end Priority;
8665
8666          -------------
8667          -- Profile --
8668          -------------
8669
8670          --  pragma Profile (profile_IDENTIFIER);
8671
8672          --  profile_IDENTIFIER => Protected | Ravenscar
8673
8674          when Pragma_Profile =>
8675             Check_Arg_Count (1);
8676             Check_Valid_Configuration_Pragma;
8677             Check_No_Identifiers;
8678
8679             declare
8680                Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
8681             begin
8682                if Chars (Argx) = Name_Ravenscar then
8683                   Set_Ravenscar_Profile (N);
8684
8685                elsif Chars (Argx) = Name_Restricted then
8686                   Set_Profile_Restrictions (Restricted, N, Warn => False);
8687                else
8688                   Error_Pragma_Arg ("& is not a valid profile", Argx);
8689                end if;
8690             end;
8691
8692          ----------------------
8693          -- Profile_Warnings --
8694          ----------------------
8695
8696          --  pragma Profile_Warnings (profile_IDENTIFIER);
8697
8698          --  profile_IDENTIFIER => Protected | Ravenscar
8699
8700          when Pragma_Profile_Warnings =>
8701             GNAT_Pragma;
8702             Check_Arg_Count (1);
8703             Check_Valid_Configuration_Pragma;
8704             Check_No_Identifiers;
8705
8706             declare
8707                Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
8708             begin
8709                if Chars (Argx) = Name_Ravenscar then
8710                   Set_Profile_Restrictions (Ravenscar, N, Warn => True);
8711
8712                elsif Chars (Argx) = Name_Restricted then
8713                   Set_Profile_Restrictions (Restricted, N, Warn => True);
8714                else
8715                   Error_Pragma_Arg ("& is not a valid profile", Argx);
8716                end if;
8717             end;
8718
8719          --------------------------
8720          -- Propagate_Exceptions --
8721          --------------------------
8722
8723          --  pragma Propagate_Exceptions;
8724
8725          when Pragma_Propagate_Exceptions =>
8726             GNAT_Pragma;
8727             Check_Arg_Count (0);
8728
8729             if In_Extended_Main_Source_Unit (N) then
8730                Propagate_Exceptions := True;
8731             end if;
8732
8733          ------------------
8734          -- Psect_Object --
8735          ------------------
8736
8737          --  pragma Psect_Object (
8738          --        [Internal =>] LOCAL_NAME,
8739          --     [, [External =>] EXTERNAL_SYMBOL]
8740          --     [, [Size     =>] EXTERNAL_SYMBOL]);
8741
8742          when Pragma_Psect_Object | Pragma_Common_Object =>
8743          Psect_Object : declare
8744             Args  : Args_List (1 .. 3);
8745             Names : constant Name_List (1 .. 3) := (
8746                       Name_Internal,
8747                       Name_External,
8748                       Name_Size);
8749
8750             Internal : Node_Id renames Args (1);
8751             External : Node_Id renames Args (2);
8752             Size     : Node_Id renames Args (3);
8753
8754             Def_Id : Entity_Id;
8755
8756             procedure Check_Too_Long (Arg : Node_Id);
8757             --  Posts message if the argument is an identifier with more
8758             --  than 31 characters, or a string literal with more than
8759             --  31 characters, and we are operating under VMS
8760
8761             --------------------
8762             -- Check_Too_Long --
8763             --------------------
8764
8765             procedure Check_Too_Long (Arg : Node_Id) is
8766                X : constant Node_Id := Original_Node (Arg);
8767
8768             begin
8769                if Nkind (X) /= N_String_Literal
8770                     and then
8771                   Nkind (X) /= N_Identifier
8772                then
8773                   Error_Pragma_Arg
8774                     ("inappropriate argument for pragma %", Arg);
8775                end if;
8776
8777                if OpenVMS_On_Target then
8778                   if (Nkind (X) = N_String_Literal
8779                        and then String_Length (Strval (X)) > 31)
8780                     or else
8781                      (Nkind (X) = N_Identifier
8782                        and then Length_Of_Name (Chars (X)) > 31)
8783                   then
8784                      Error_Pragma_Arg
8785                        ("argument for pragma % is longer than 31 characters",
8786                         Arg);
8787                   end if;
8788                end if;
8789             end Check_Too_Long;
8790
8791          --  Start of processing for Common_Object/Psect_Object
8792
8793          begin
8794             GNAT_Pragma;
8795             Gather_Associations (Names, Args);
8796             Process_Extended_Import_Export_Internal_Arg (Internal);
8797
8798             Def_Id := Entity (Internal);
8799
8800             if Ekind (Def_Id) /= E_Constant
8801               and then Ekind (Def_Id) /= E_Variable
8802             then
8803                Error_Pragma_Arg
8804                  ("pragma% must designate an object", Internal);
8805             end if;
8806
8807             Check_Too_Long (Internal);
8808
8809             if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
8810                Error_Pragma_Arg
8811                  ("cannot use pragma% for imported/exported object",
8812                   Internal);
8813             end if;
8814
8815             if Is_Concurrent_Type (Etype (Internal)) then
8816                Error_Pragma_Arg
8817                  ("cannot specify pragma % for task/protected object",
8818                   Internal);
8819             end if;
8820
8821             if Has_Rep_Pragma (Def_Id, Name_Common_Object)
8822                  or else
8823                Has_Rep_Pragma (Def_Id, Name_Psect_Object)
8824             then
8825                Error_Msg_N ("?duplicate Common/Psect_Object pragma", N);
8826             end if;
8827
8828             if Ekind (Def_Id) = E_Constant then
8829                Error_Pragma_Arg
8830                  ("cannot specify pragma % for a constant", Internal);
8831             end if;
8832
8833             if Is_Record_Type (Etype (Internal)) then
8834                declare
8835                   Ent  : Entity_Id;
8836                   Decl : Entity_Id;
8837
8838                begin
8839                   Ent := First_Entity (Etype (Internal));
8840                   while Present (Ent) loop
8841                      Decl := Declaration_Node (Ent);
8842
8843                      if Ekind (Ent) = E_Component
8844                        and then Nkind (Decl) = N_Component_Declaration
8845                        and then Present (Expression (Decl))
8846                        and then Warn_On_Export_Import
8847                      then
8848                         Error_Msg_N
8849                           ("?object for pragma % has defaults", Internal);
8850                         exit;
8851
8852                      else
8853                         Next_Entity (Ent);
8854                      end if;
8855                   end loop;
8856                end;
8857             end if;
8858
8859             if Present (Size) then
8860                Check_Too_Long (Size);
8861             end if;
8862
8863             if Present (External) then
8864                Check_Arg_Is_External_Name (External);
8865                Check_Too_Long (External);
8866             end if;
8867
8868             --  If all error tests pass, link pragma on to the rep item chain
8869
8870             Record_Rep_Item (Def_Id, N);
8871          end Psect_Object;
8872
8873          ----------
8874          -- Pure --
8875          ----------
8876
8877          --  pragma Pure [(library_unit_NAME)];
8878
8879          when Pragma_Pure => Pure : declare
8880             Ent : Entity_Id;
8881
8882          begin
8883             Check_Ada_83_Warning;
8884             Check_Valid_Library_Unit_Pragma;
8885
8886             if Nkind (N) = N_Null_Statement then
8887                return;
8888             end if;
8889
8890             Ent := Find_Lib_Unit_Name;
8891             Set_Is_Pure (Ent);
8892             Set_Suppress_Elaboration_Warnings (Ent);
8893          end Pure;
8894
8895          -------------
8896          -- Pure_05 --
8897          -------------
8898
8899          --  pragma Pure_05 [(library_unit_NAME)];
8900
8901          --  This pragma is useable only in GNAT_Mode, where it is used like
8902          --  pragma Pure but it is only effective in Ada 2005 mode (otherwise
8903          --  it is ignored). It may be used after a pragma Preelaborate, in
8904          --  which case it overrides the effect of the pragma Preelaborate.
8905          --  This is used to implement AI-362 which recategorizes some run-time
8906          --  packages in Ada 2005 mode.
8907
8908          when Pragma_Pure_05 => Pure_05 : declare
8909             Ent : Entity_Id;
8910
8911          begin
8912             GNAT_Pragma;
8913             Check_Valid_Library_Unit_Pragma;
8914
8915             if not GNAT_Mode then
8916                Error_Pragma ("pragma% only available in GNAT mode");
8917             end if;
8918             if Nkind (N) = N_Null_Statement then
8919                return;
8920             end if;
8921
8922             --  This is one of the few cases where we need to test the value of
8923             --  Ada_Version_Explicit rather than Ada_Version (which is always
8924             --  set to Ada_05 in a predefined unit), we need to know the
8925             --  explicit version set to know if this pragma is active.
8926
8927             if Ada_Version_Explicit >= Ada_05 then
8928                Ent := Find_Lib_Unit_Name;
8929                Set_Is_Preelaborated (Ent, False);
8930                Set_Is_Pure (Ent);
8931                Set_Suppress_Elaboration_Warnings (Ent);
8932             end if;
8933          end Pure_05;
8934
8935          -------------------
8936          -- Pure_Function --
8937          -------------------
8938
8939          --  pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
8940
8941          when Pragma_Pure_Function => Pure_Function : declare
8942             E_Id      : Node_Id;
8943             E         : Entity_Id;
8944             Def_Id    : Entity_Id;
8945             Effective : Boolean := False;
8946
8947          begin
8948             GNAT_Pragma;
8949             Check_Arg_Count (1);
8950             Check_Optional_Identifier (Arg1, Name_Entity);
8951             Check_Arg_Is_Local_Name (Arg1);
8952             E_Id := Expression (Arg1);
8953
8954             if Error_Posted (E_Id) then
8955                return;
8956             end if;
8957
8958             --  Loop through homonyms (overloadings) of referenced entity
8959
8960             E := Entity (E_Id);
8961
8962             if Present (E) then
8963                loop
8964                   Def_Id := Get_Base_Subprogram (E);
8965
8966                   if Ekind (Def_Id) /= E_Function
8967                     and then Ekind (Def_Id) /= E_Generic_Function
8968                     and then Ekind (Def_Id) /= E_Operator
8969                   then
8970                      Error_Pragma_Arg
8971                        ("pragma% requires a function name", Arg1);
8972                   end if;
8973
8974                   Set_Is_Pure (Def_Id);
8975
8976                   if not Has_Pragma_Pure_Function (Def_Id) then
8977                      Set_Has_Pragma_Pure_Function (Def_Id);
8978                      Effective := True;
8979                   end if;
8980
8981                   E := Homonym (E);
8982                   exit when No (E) or else Scope (E) /= Current_Scope;
8983                end loop;
8984
8985                if not Effective
8986                  and then Warn_On_Redundant_Constructs
8987                then
8988                   Error_Msg_NE ("pragma Pure_Function on& is redundant?",
8989                     N, Entity (E_Id));
8990                end if;
8991             end if;
8992          end Pure_Function;
8993
8994          --------------------
8995          -- Queuing_Policy --
8996          --------------------
8997
8998          --  pragma Queuing_Policy (policy_IDENTIFIER);
8999
9000          when Pragma_Queuing_Policy => declare
9001             QP : Character;
9002
9003          begin
9004             Check_Ada_83_Warning;
9005             Check_Arg_Count (1);
9006             Check_No_Identifiers;
9007             Check_Arg_Is_Queuing_Policy (Arg1);
9008             Check_Valid_Configuration_Pragma;
9009             Get_Name_String (Chars (Expression (Arg1)));
9010             QP := Fold_Upper (Name_Buffer (1));
9011
9012             if Queuing_Policy /= ' '
9013               and then Queuing_Policy /= QP
9014             then
9015                Error_Msg_Sloc := Queuing_Policy_Sloc;
9016                Error_Pragma ("queuing policy incompatible with policy#");
9017
9018             --  Set new policy, but always preserve System_Location since
9019             --  we like the error message with the run time name.
9020
9021             else
9022                Queuing_Policy := QP;
9023
9024                if Queuing_Policy_Sloc /= System_Location then
9025                   Queuing_Policy_Sloc := Loc;
9026                end if;
9027             end if;
9028          end;
9029
9030          ---------------------------
9031          -- Remote_Call_Interface --
9032          ---------------------------
9033
9034          --  pragma Remote_Call_Interface [(library_unit_NAME)];
9035
9036          when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
9037             Cunit_Node : Node_Id;
9038             Cunit_Ent  : Entity_Id;
9039             K          : Node_Kind;
9040
9041          begin
9042             Check_Ada_83_Warning;
9043             Check_Valid_Library_Unit_Pragma;
9044
9045             if Nkind (N) = N_Null_Statement then
9046                return;
9047             end if;
9048
9049             Cunit_Node := Cunit (Current_Sem_Unit);
9050             K          := Nkind (Unit (Cunit_Node));
9051             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
9052
9053             if K = N_Package_Declaration
9054               or else K = N_Generic_Package_Declaration
9055               or else K = N_Subprogram_Declaration
9056               or else K = N_Generic_Subprogram_Declaration
9057               or else (K = N_Subprogram_Body
9058                          and then Acts_As_Spec (Unit (Cunit_Node)))
9059             then
9060                null;
9061             else
9062                Error_Pragma (
9063                  "pragma% must apply to package or subprogram declaration");
9064             end if;
9065
9066             Set_Is_Remote_Call_Interface (Cunit_Ent);
9067          end Remote_Call_Interface;
9068
9069          ------------------
9070          -- Remote_Types --
9071          ------------------
9072
9073          --  pragma Remote_Types [(library_unit_NAME)];
9074
9075          when Pragma_Remote_Types => Remote_Types : declare
9076             Cunit_Node : Node_Id;
9077             Cunit_Ent  : Entity_Id;
9078
9079          begin
9080             Check_Ada_83_Warning;
9081             Check_Valid_Library_Unit_Pragma;
9082
9083             if Nkind (N) = N_Null_Statement then
9084                return;
9085             end if;
9086
9087             Cunit_Node := Cunit (Current_Sem_Unit);
9088             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
9089
9090             if Nkind (Unit (Cunit_Node)) /= N_Package_Declaration
9091               and then
9092               Nkind (Unit (Cunit_Node)) /= N_Generic_Package_Declaration
9093             then
9094                Error_Pragma (
9095                  "pragma% can only apply to a package declaration");
9096             end if;
9097
9098             Set_Is_Remote_Types (Cunit_Ent);
9099          end Remote_Types;
9100
9101          ---------------
9102          -- Ravenscar --
9103          ---------------
9104
9105          --  pragma Ravenscar;
9106
9107          when Pragma_Ravenscar =>
9108             GNAT_Pragma;
9109             Check_Arg_Count (0);
9110             Check_Valid_Configuration_Pragma;
9111             Set_Ravenscar_Profile (N);
9112
9113             if Warn_On_Obsolescent_Feature then
9114                Error_Msg_N
9115                  ("pragma Ravenscar is an obsolescent feature?", N);
9116                Error_Msg_N
9117                  ("|use pragma Profile (Ravenscar) instead", N);
9118             end if;
9119
9120          -------------------------
9121          -- Restricted_Run_Time --
9122          -------------------------
9123
9124          --  pragma Restricted_Run_Time;
9125
9126          when Pragma_Restricted_Run_Time =>
9127             GNAT_Pragma;
9128             Check_Arg_Count (0);
9129             Check_Valid_Configuration_Pragma;
9130             Set_Profile_Restrictions (Restricted, N, Warn => False);
9131
9132             if Warn_On_Obsolescent_Feature then
9133                Error_Msg_N
9134                  ("pragma Restricted_Run_Time is an obsolescent feature?", N);
9135                Error_Msg_N
9136                  ("|use pragma Profile (Restricted) instead", N);
9137             end if;
9138
9139          ------------------
9140          -- Restrictions --
9141          ------------------
9142
9143          --  pragma Restrictions (RESTRICTION {, RESTRICTION});
9144
9145          --  RESTRICTION ::=
9146          --    restriction_IDENTIFIER
9147          --  | restriction_parameter_IDENTIFIER => EXPRESSION
9148
9149          when Pragma_Restrictions =>
9150             Process_Restrictions_Or_Restriction_Warnings;
9151
9152          --------------------------
9153          -- Restriction_Warnings --
9154          --------------------------
9155
9156          --  pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
9157
9158          --  RESTRICTION ::=
9159          --    restriction_IDENTIFIER
9160          --  | restriction_parameter_IDENTIFIER => EXPRESSION
9161
9162          when Pragma_Restriction_Warnings =>
9163             Process_Restrictions_Or_Restriction_Warnings;
9164
9165          ----------------
9166          -- Reviewable --
9167          ----------------
9168
9169          --  pragma Reviewable;
9170
9171          when Pragma_Reviewable =>
9172             Check_Ada_83_Warning;
9173             Check_Arg_Count (0);
9174
9175          -------------------
9176          -- Share_Generic --
9177          -------------------
9178
9179          --  pragma Share_Generic (NAME {, NAME});
9180
9181          when Pragma_Share_Generic =>
9182             GNAT_Pragma;
9183             Process_Generic_List;
9184
9185          ------------
9186          -- Shared --
9187          ------------
9188
9189          --  pragma Shared (LOCAL_NAME);
9190
9191          when Pragma_Shared =>
9192             GNAT_Pragma;
9193             Process_Atomic_Shared_Volatile;
9194
9195          --------------------
9196          -- Shared_Passive --
9197          --------------------
9198
9199          --  pragma Shared_Passive [(library_unit_NAME)];
9200
9201          --  Set the flag Is_Shared_Passive of program unit name entity
9202
9203          when Pragma_Shared_Passive => Shared_Passive : declare
9204             Cunit_Node : Node_Id;
9205             Cunit_Ent  : Entity_Id;
9206
9207          begin
9208             Check_Ada_83_Warning;
9209             Check_Valid_Library_Unit_Pragma;
9210
9211             if Nkind (N) = N_Null_Statement then
9212                return;
9213             end if;
9214
9215             Cunit_Node := Cunit (Current_Sem_Unit);
9216             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
9217
9218             if Nkind (Unit (Cunit_Node)) /= N_Package_Declaration
9219               and then
9220               Nkind (Unit (Cunit_Node)) /= N_Generic_Package_Declaration
9221             then
9222                Error_Pragma (
9223                  "pragma% can only apply to a package declaration");
9224             end if;
9225
9226             Set_Is_Shared_Passive (Cunit_Ent);
9227          end Shared_Passive;
9228
9229          ----------------------
9230          -- Source_File_Name --
9231          ----------------------
9232
9233          --  There are five forms for this pragma:
9234
9235          --  pragma Source_File_Name (
9236          --    [UNIT_NAME      =>] unit_NAME,
9237          --     BODY_FILE_NAME =>  STRING_LITERAL
9238          --    [, [INDEX =>] INTEGER_LITERAL]);
9239
9240          --  pragma Source_File_Name (
9241          --    [UNIT_NAME      =>] unit_NAME,
9242          --     SPEC_FILE_NAME =>  STRING_LITERAL
9243          --    [, [INDEX =>] INTEGER_LITERAL]);
9244
9245          --  pragma Source_File_Name (
9246          --     BODY_FILE_NAME  => STRING_LITERAL
9247          --  [, DOT_REPLACEMENT => STRING_LITERAL]
9248          --  [, CASING          => CASING_SPEC]);
9249
9250          --  pragma Source_File_Name (
9251          --     SPEC_FILE_NAME  => STRING_LITERAL
9252          --  [, DOT_REPLACEMENT => STRING_LITERAL]
9253          --  [, CASING          => CASING_SPEC]);
9254
9255          --  pragma Source_File_Name (
9256          --     SUBUNIT_FILE_NAME  => STRING_LITERAL
9257          --  [, DOT_REPLACEMENT    => STRING_LITERAL]
9258          --  [, CASING             => CASING_SPEC]);
9259
9260          --  CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
9261
9262          --  Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
9263          --  Source_File_Name (SFN), however their usage is exclusive:
9264          --  SFN can only be used when no project file is used, while
9265          --  SFNP can only be used when a project file is used.
9266
9267          --  No processing here. Processing was completed during parsing,
9268          --  since we need to have file names set as early as possible.
9269          --  Units are loaded well before semantic processing starts.
9270
9271          --  The only processing we defer to this point is the check
9272          --  for correct placement.
9273
9274          when Pragma_Source_File_Name =>
9275             GNAT_Pragma;
9276             Check_Valid_Configuration_Pragma;
9277
9278          ------------------------------
9279          -- Source_File_Name_Project --
9280          ------------------------------
9281
9282          --  See Source_File_Name for syntax
9283
9284          --  No processing here. Processing was completed during parsing,
9285          --  since we need to have file names set as early as possible.
9286          --  Units are loaded well before semantic processing starts.
9287
9288          --  The only processing we defer to this point is the check
9289          --  for correct placement.
9290
9291          when Pragma_Source_File_Name_Project =>
9292             GNAT_Pragma;
9293             Check_Valid_Configuration_Pragma;
9294
9295             --  Check that a pragma Source_File_Name_Project is used only
9296             --  in a configuration pragmas file.
9297
9298             --  Pragmas Source_File_Name_Project should only be generated
9299             --  by the Project Manager in configuration pragmas files.
9300
9301             --  This is really an ugly test. It seems to depend on some
9302             --  accidental and undocumented property. At the very least
9303             --  it needs to be documented, but it would be better to have
9304             --  a clean way of testing if we are in a configuration file???
9305
9306             if Present (Parent (N)) then
9307                Error_Pragma
9308                  ("pragma% can only appear in a configuration pragmas file");
9309             end if;
9310
9311          ----------------------
9312          -- Source_Reference --
9313          ----------------------
9314
9315          --  pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
9316
9317          --  Nothing to do, all processing completed in Par.Prag, since we
9318          --  need the information for possible parser messages that are output
9319
9320          when Pragma_Source_Reference =>
9321             GNAT_Pragma;
9322
9323          ------------------
9324          -- Storage_Size --
9325          ------------------
9326
9327          --  pragma Storage_Size (EXPRESSION);
9328
9329          when Pragma_Storage_Size => Storage_Size : declare
9330             P   : constant Node_Id := Parent (N);
9331             Arg : Node_Id;
9332
9333          begin
9334             Check_No_Identifiers;
9335             Check_Arg_Count (1);
9336
9337             --  The expression must be analyzed in the special manner
9338             --  described in "Handling of Default Expressions" in sem.ads.
9339
9340             --  Set In_Default_Expression for per-object case ???
9341
9342             Arg := Expression (Arg1);
9343             Analyze_Per_Use_Expression (Arg, Any_Integer);
9344
9345             if not Is_Static_Expression (Arg) then
9346                Check_Restriction (Static_Storage_Size, Arg);
9347             end if;
9348
9349             if Nkind (P) /= N_Task_Definition then
9350                Pragma_Misplaced;
9351                return;
9352
9353             else
9354                if Has_Storage_Size_Pragma (P) then
9355                   Error_Pragma ("duplicate pragma% not allowed");
9356                else
9357                   Set_Has_Storage_Size_Pragma (P, True);
9358                end if;
9359
9360                Record_Rep_Item (Defining_Identifier (Parent (P)), N);
9361                --  ???  exp_ch9 should use this!
9362             end if;
9363          end Storage_Size;
9364
9365          ------------------
9366          -- Storage_Unit --
9367          ------------------
9368
9369          --  pragma Storage_Unit (NUMERIC_LITERAL);
9370
9371          --  Only permitted argument is System'Storage_Unit value
9372
9373          when Pragma_Storage_Unit =>
9374             Check_No_Identifiers;
9375             Check_Arg_Count (1);
9376             Check_Arg_Is_Integer_Literal (Arg1);
9377
9378             if Intval (Expression (Arg1)) /=
9379               UI_From_Int (Ttypes.System_Storage_Unit)
9380             then
9381                Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
9382                Error_Pragma_Arg
9383                  ("the only allowed argument for pragma% is ^", Arg1);
9384             end if;
9385
9386          --------------------
9387          -- Stream_Convert --
9388          --------------------
9389
9390          --  pragma Stream_Convert (
9391          --    [Entity =>] type_LOCAL_NAME,
9392          --    [Read   =>] function_NAME,
9393          --    [Write  =>] function NAME);
9394
9395          when Pragma_Stream_Convert => Stream_Convert : declare
9396
9397             procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
9398             --  Check that the given argument is the name of a local
9399             --  function of one argument that is not overloaded earlier
9400             --  in the current local scope. A check is also made that the
9401             --  argument is a function with one parameter.
9402
9403             --------------------------------------
9404             -- Check_OK_Stream_Convert_Function --
9405             --------------------------------------
9406
9407             procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
9408                Ent : Entity_Id;
9409
9410             begin
9411                Check_Arg_Is_Local_Name (Arg);
9412                Ent := Entity (Expression (Arg));
9413
9414                if Has_Homonym (Ent) then
9415                   Error_Pragma_Arg
9416                     ("argument for pragma% may not be overloaded", Arg);
9417                end if;
9418
9419                if Ekind (Ent) /= E_Function
9420                  or else No (First_Formal (Ent))
9421                  or else Present (Next_Formal (First_Formal (Ent)))
9422                then
9423                   Error_Pragma_Arg
9424                     ("argument for pragma% must be" &
9425                      " function of one argument", Arg);
9426                end if;
9427             end Check_OK_Stream_Convert_Function;
9428
9429          --  Start of procecessing for Stream_Convert
9430
9431          begin
9432             GNAT_Pragma;
9433             Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
9434             Check_Arg_Count (3);
9435             Check_Optional_Identifier (Arg1, Name_Entity);
9436             Check_Optional_Identifier (Arg2, Name_Read);
9437             Check_Optional_Identifier (Arg3, Name_Write);
9438             Check_Arg_Is_Local_Name (Arg1);
9439             Check_OK_Stream_Convert_Function (Arg2);
9440             Check_OK_Stream_Convert_Function (Arg3);
9441
9442             declare
9443                Typ   : constant Entity_Id :=
9444                          Underlying_Type (Entity (Expression (Arg1)));
9445                Read  : constant Entity_Id := Entity (Expression (Arg2));
9446                Write : constant Entity_Id := Entity (Expression (Arg3));
9447
9448             begin
9449                if Etype (Typ) = Any_Type
9450                     or else
9451                   Etype (Read) = Any_Type
9452                     or else
9453                   Etype (Write) = Any_Type
9454                then
9455                   return;
9456                end if;
9457
9458                Check_First_Subtype (Arg1);
9459
9460                if Rep_Item_Too_Early (Typ, N)
9461                     or else
9462                   Rep_Item_Too_Late (Typ, N)
9463                then
9464                   return;
9465                end if;
9466
9467                if Underlying_Type (Etype (Read)) /= Typ then
9468                   Error_Pragma_Arg
9469                     ("incorrect return type for function&", Arg2);
9470                end if;
9471
9472                if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
9473                   Error_Pragma_Arg
9474                     ("incorrect parameter type for function&", Arg3);
9475                end if;
9476
9477                if Underlying_Type (Etype (First_Formal (Read))) /=
9478                   Underlying_Type (Etype (Write))
9479                then
9480                   Error_Pragma_Arg
9481                     ("result type of & does not match Read parameter type",
9482                      Arg3);
9483                end if;
9484             end;
9485          end Stream_Convert;
9486
9487          -------------------------
9488          -- Style_Checks (GNAT) --
9489          -------------------------
9490
9491          --  pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
9492
9493          --  This is processed by the parser since some of the style
9494          --  checks take place during source scanning and parsing. This
9495          --  means that we don't need to issue error messages here.
9496
9497          when Pragma_Style_Checks => Style_Checks : declare
9498             A  : constant Node_Id   := Expression (Arg1);
9499             S  : String_Id;
9500             C  : Char_Code;
9501
9502          begin
9503             GNAT_Pragma;
9504             Check_No_Identifiers;
9505
9506             --  Two argument form
9507
9508             if Arg_Count = 2 then
9509                Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
9510
9511                declare
9512                   E_Id : Node_Id;
9513                   E    : Entity_Id;
9514
9515                begin
9516                   E_Id := Expression (Arg2);
9517                   Analyze (E_Id);
9518
9519                   if not Is_Entity_Name (E_Id) then
9520                      Error_Pragma_Arg
9521                        ("second argument of pragma% must be entity name",
9522                         Arg2);
9523                   end if;
9524
9525                   E := Entity (E_Id);
9526
9527                   if E = Any_Id then
9528                      return;
9529                   else
9530                      loop
9531                         Set_Suppress_Style_Checks (E,
9532                           (Chars (Expression (Arg1)) = Name_Off));
9533                         exit when No (Homonym (E));
9534                         E := Homonym (E);
9535                      end loop;
9536                   end if;
9537                end;
9538
9539             --  One argument form
9540
9541             else
9542                Check_Arg_Count (1);
9543
9544                if Nkind (A) = N_String_Literal then
9545                   S   := Strval (A);
9546
9547                   declare
9548                      Slen    : constant Natural := Natural (String_Length (S));
9549                      Options : String (1 .. Slen);
9550                      J       : Natural;
9551
9552                   begin
9553                      J := 1;
9554                      loop
9555                         C := Get_String_Char (S, Int (J));
9556                         exit when not In_Character_Range (C);
9557                         Options (J) := Get_Character (C);
9558
9559                         if J = Slen then
9560                            Set_Style_Check_Options (Options);
9561                            exit;
9562                         else
9563                            J := J + 1;
9564                         end if;
9565                      end loop;
9566                   end;
9567
9568                elsif Nkind (A) = N_Identifier then
9569
9570                   if Chars (A) = Name_All_Checks then
9571                      Set_Default_Style_Check_Options;
9572
9573                   elsif Chars (A) = Name_On then
9574                      Style_Check := True;
9575
9576                   elsif Chars (A) = Name_Off then
9577                      Style_Check := False;
9578
9579                   end if;
9580                end if;
9581             end if;
9582          end Style_Checks;
9583
9584          --------------
9585          -- Subtitle --
9586          --------------
9587
9588          --  pragma Subtitle ([Subtitle =>] STRING_LITERAL);
9589
9590          when Pragma_Subtitle =>
9591             GNAT_Pragma;
9592             Check_Arg_Count (1);
9593             Check_Optional_Identifier (Arg1, Name_Subtitle);
9594             Check_Arg_Is_String_Literal (Arg1);
9595
9596          --------------
9597          -- Suppress --
9598          --------------
9599
9600          --  pragma Suppress (IDENTIFIER [, [On =>] NAME]);
9601
9602          when Pragma_Suppress =>
9603             Process_Suppress_Unsuppress (True);
9604
9605          ------------------
9606          -- Suppress_All --
9607          ------------------
9608
9609          --  pragma Suppress_All;
9610
9611          --  The only check made here is that the pragma appears in the
9612          --  proper place, i.e. following a compilation unit. If indeed
9613          --  it appears in this context, then the parser has already
9614          --  inserted an equivalent pragma Suppress (All_Checks) to get
9615          --  the required effect.
9616
9617          when Pragma_Suppress_All =>
9618             GNAT_Pragma;
9619             Check_Arg_Count (0);
9620
9621             if Nkind (Parent (N)) /= N_Compilation_Unit_Aux
9622               or else not Is_List_Member (N)
9623               or else List_Containing (N) /= Pragmas_After (Parent (N))
9624             then
9625                Error_Pragma
9626                  ("misplaced pragma%, must follow compilation unit");
9627             end if;
9628
9629          -------------------------
9630          -- Suppress_Debug_Info --
9631          -------------------------
9632
9633          --  pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
9634
9635          when Pragma_Suppress_Debug_Info =>
9636             GNAT_Pragma;
9637             Check_Arg_Count (1);
9638             Check_Optional_Identifier (Arg1, Name_Entity);
9639             Check_Arg_Is_Local_Name (Arg1);
9640             Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
9641
9642          ----------------------------------
9643          -- Suppress_Exception_Locations --
9644          ----------------------------------
9645
9646          --  pragma Suppress_Exception_Locations;
9647
9648          when Pragma_Suppress_Exception_Locations =>
9649             GNAT_Pragma;
9650             Check_Arg_Count (0);
9651             Check_Valid_Configuration_Pragma;
9652             Exception_Locations_Suppressed := True;
9653
9654          -----------------------------
9655          -- Suppress_Initialization --
9656          -----------------------------
9657
9658          --  pragma Suppress_Initialization ([Entity =>] type_Name);
9659
9660          when Pragma_Suppress_Initialization => Suppress_Init : declare
9661             E_Id : Node_Id;
9662             E    : Entity_Id;
9663
9664          begin
9665             GNAT_Pragma;
9666             Check_Arg_Count (1);
9667             Check_Optional_Identifier (Arg1, Name_Entity);
9668             Check_Arg_Is_Local_Name (Arg1);
9669
9670             E_Id := Expression (Arg1);
9671
9672             if Etype (E_Id) = Any_Type then
9673                return;
9674             end if;
9675
9676             E := Entity (E_Id);
9677
9678             if Is_Type (E) then
9679                if Is_Incomplete_Or_Private_Type (E) then
9680                   if No (Full_View (Base_Type (E))) then
9681                      Error_Pragma_Arg
9682                        ("argument of pragma% cannot be an incomplete type",
9683                          Arg1);
9684                   else
9685                      Set_Suppress_Init_Proc (Full_View (Base_Type (E)));
9686                   end if;
9687                else
9688                   Set_Suppress_Init_Proc (Base_Type (E));
9689                end if;
9690
9691             else
9692                Error_Pragma_Arg
9693                  ("pragma% requires argument that is a type name", Arg1);
9694             end if;
9695          end Suppress_Init;
9696
9697          -----------------
9698          -- System_Name --
9699          -----------------
9700
9701          --  pragma System_Name (DIRECT_NAME);
9702
9703          --  Syntax check: one argument, which must be the identifier GNAT
9704          --  or the identifier GCC, no other identifiers are acceptable.
9705
9706          when Pragma_System_Name =>
9707             Check_No_Identifiers;
9708             Check_Arg_Count (1);
9709             Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
9710
9711          -----------------------------
9712          -- Task_Dispatching_Policy --
9713          -----------------------------
9714
9715          --  pragma Task_Dispatching_Policy (policy_IDENTIFIER);
9716
9717          when Pragma_Task_Dispatching_Policy => declare
9718             DP : Character;
9719
9720          begin
9721             Check_Ada_83_Warning;
9722             Check_Arg_Count (1);
9723             Check_No_Identifiers;
9724             Check_Arg_Is_Task_Dispatching_Policy (Arg1);
9725             Check_Valid_Configuration_Pragma;
9726             Get_Name_String (Chars (Expression (Arg1)));
9727             DP := Fold_Upper (Name_Buffer (1));
9728
9729             if Task_Dispatching_Policy /= ' '
9730               and then Task_Dispatching_Policy /= DP
9731             then
9732                Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
9733                Error_Pragma
9734                  ("task dispatching policy incompatible with policy#");
9735
9736             --  Set new policy, but always preserve System_Location since
9737             --  we like the error message with the run time name.
9738
9739             else
9740                Task_Dispatching_Policy := DP;
9741
9742                if Task_Dispatching_Policy_Sloc /= System_Location then
9743                   Task_Dispatching_Policy_Sloc := Loc;
9744                end if;
9745             end if;
9746          end;
9747
9748          --------------
9749          -- Task_Info --
9750          --------------
9751
9752          --  pragma Task_Info (EXPRESSION);
9753
9754          when Pragma_Task_Info => Task_Info : declare
9755             P : constant Node_Id := Parent (N);
9756
9757          begin
9758             GNAT_Pragma;
9759
9760             if Nkind (P) /= N_Task_Definition then
9761                Error_Pragma ("pragma% must appear in task definition");
9762             end if;
9763
9764             Check_No_Identifiers;
9765             Check_Arg_Count (1);
9766
9767             Analyze_And_Resolve (Expression (Arg1), RTE (RE_Task_Info_Type));
9768
9769             if Etype (Expression (Arg1)) = Any_Type then
9770                return;
9771             end if;
9772
9773             if Has_Task_Info_Pragma (P) then
9774                Error_Pragma ("duplicate pragma% not allowed");
9775             else
9776                Set_Has_Task_Info_Pragma (P, True);
9777             end if;
9778          end Task_Info;
9779
9780          ---------------
9781          -- Task_Name --
9782          ---------------
9783
9784          --  pragma Task_Name (string_EXPRESSION);
9785
9786          when Pragma_Task_Name => Task_Name : declare
9787          --  pragma Priority (EXPRESSION);
9788
9789             P   : constant Node_Id := Parent (N);
9790             Arg : Node_Id;
9791
9792          begin
9793             Check_No_Identifiers;
9794             Check_Arg_Count (1);
9795
9796             Arg := Expression (Arg1);
9797             Analyze_And_Resolve (Arg, Standard_String);
9798
9799             if Nkind (P) /= N_Task_Definition then
9800                Pragma_Misplaced;
9801             end if;
9802
9803             if Has_Task_Name_Pragma (P) then
9804                Error_Pragma ("duplicate pragma% not allowed");
9805             else
9806                Set_Has_Task_Name_Pragma (P, True);
9807                Record_Rep_Item (Defining_Identifier (Parent (P)), N);
9808             end if;
9809          end Task_Name;
9810
9811          ------------------
9812          -- Task_Storage --
9813          ------------------
9814
9815          --  pragma Task_Storage (
9816          --     [Task_Type =>] LOCAL_NAME,
9817          --     [Top_Guard =>] static_integer_EXPRESSION);
9818
9819          when Pragma_Task_Storage => Task_Storage : declare
9820             Args  : Args_List (1 .. 2);
9821             Names : constant Name_List (1 .. 2) := (
9822                       Name_Task_Type,
9823                       Name_Top_Guard);
9824
9825             Task_Type : Node_Id renames Args (1);
9826             Top_Guard : Node_Id renames Args (2);
9827
9828             Ent : Entity_Id;
9829
9830          begin
9831             GNAT_Pragma;
9832             Gather_Associations (Names, Args);
9833
9834             if No (Task_Type) then
9835                Error_Pragma
9836                  ("missing task_type argument for pragma%");
9837             end if;
9838
9839             Check_Arg_Is_Local_Name (Task_Type);
9840
9841             Ent := Entity (Task_Type);
9842
9843             if not Is_Task_Type (Ent) then
9844                Error_Pragma_Arg
9845                  ("argument for pragma% must be task type", Task_Type);
9846             end if;
9847
9848             if No (Top_Guard) then
9849                Error_Pragma_Arg
9850                  ("pragma% takes two arguments", Task_Type);
9851             else
9852                Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
9853             end if;
9854
9855             Check_First_Subtype (Task_Type);
9856
9857             if Rep_Item_Too_Late (Ent, N) then
9858                raise Pragma_Exit;
9859             end if;
9860          end Task_Storage;
9861
9862          -----------------
9863          -- Thread_Body --
9864          -----------------
9865
9866          --  pragma Thread_Body
9867          --    (  [Entity =>]               LOCAL_NAME
9868          --     [,[Secondary_Stack_Size =>] static_integer_EXPRESSION]);
9869
9870          when Pragma_Thread_Body => Thread_Body : declare
9871             Id : Node_Id;
9872             SS : Node_Id;
9873             E  : Entity_Id;
9874
9875          begin
9876             GNAT_Pragma;
9877             Check_Arg_Order ((Name_Entity, Name_Secondary_Stack_Size));
9878             Check_At_Least_N_Arguments (1);
9879             Check_At_Most_N_Arguments (2);
9880             Check_Optional_Identifier (Arg1, Name_Entity);
9881             Check_Arg_Is_Local_Name (Arg1);
9882
9883             Id := Expression (Arg1);
9884
9885             if not Is_Entity_Name (Id)
9886               or else not Is_Subprogram (Entity (Id))
9887             then
9888                Error_Pragma_Arg ("subprogram name required", Arg1);
9889             end if;
9890
9891             E := Entity (Id);
9892
9893             --  Go to renamed subprogram if present, since Thread_Body applies
9894             --  to the actual renamed entity, not to the renaming entity.
9895
9896             if Present (Alias (E))
9897               and then Nkind (Parent (Declaration_Node (E))) =
9898                          N_Subprogram_Renaming_Declaration
9899             then
9900                E := Alias (E);
9901             end if;
9902
9903             --  Various error checks
9904
9905             if Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body then
9906                Error_Pragma
9907                  ("pragma% requires separate spec and must come before body");
9908
9909             elsif Rep_Item_Too_Early (E, N)
9910                  or else
9911                Rep_Item_Too_Late (E, N)
9912             then
9913                raise Pragma_Exit;
9914
9915             elsif Is_Thread_Body (E) then
9916                Error_Pragma_Arg
9917                  ("only one thread body pragma allowed", Arg1);
9918
9919             elsif Present (Homonym (E))
9920               and then Scope (Homonym (E)) = Current_Scope
9921             then
9922                Error_Pragma_Arg
9923                  ("thread body subprogram must not be overloaded", Arg1);
9924             end if;
9925
9926             Set_Is_Thread_Body (E);
9927
9928             --  Deal with secondary stack argument
9929
9930             if Arg_Count = 2 then
9931                Check_Optional_Identifier (Arg2, Name_Secondary_Stack_Size);
9932                SS := Expression (Arg2);
9933                Analyze_And_Resolve (SS, Any_Integer);
9934             end if;
9935          end Thread_Body;
9936
9937          ----------------
9938          -- Time_Slice --
9939          ----------------
9940
9941          --  pragma Time_Slice (static_duration_EXPRESSION);
9942
9943          when Pragma_Time_Slice => Time_Slice : declare
9944             Val : Ureal;
9945             Nod : Node_Id;
9946
9947          begin
9948             GNAT_Pragma;
9949             Check_Arg_Count (1);
9950             Check_No_Identifiers;
9951             Check_In_Main_Program;
9952             Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
9953
9954             if not Error_Posted (Arg1) then
9955                Nod := Next (N);
9956                while Present (Nod) loop
9957                   if Nkind (Nod) = N_Pragma
9958                     and then Chars (Nod) = Name_Time_Slice
9959                   then
9960                      Error_Msg_Name_1 := Chars (N);
9961                      Error_Msg_N ("duplicate pragma% not permitted", Nod);
9962                   end if;
9963
9964                   Next (Nod);
9965                end loop;
9966             end if;
9967
9968             --  Process only if in main unit
9969
9970             if Get_Source_Unit (Loc) = Main_Unit then
9971                Opt.Time_Slice_Set := True;
9972                Val := Expr_Value_R (Expression (Arg1));
9973
9974                if Val <= Ureal_0 then
9975                   Opt.Time_Slice_Value := 0;
9976
9977                elsif Val > UR_From_Uint (UI_From_Int (1000)) then
9978                   Opt.Time_Slice_Value := 1_000_000_000;
9979
9980                else
9981                   Opt.Time_Slice_Value :=
9982                     UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
9983                end if;
9984             end if;
9985          end Time_Slice;
9986
9987          -----------
9988          -- Title --
9989          -----------
9990
9991          --  pragma Title (TITLING_OPTION [, TITLING OPTION]);
9992
9993          --   TITLING_OPTION ::=
9994          --     [Title =>] STRING_LITERAL
9995          --   | [Subtitle =>] STRING_LITERAL
9996
9997          when Pragma_Title => Title : declare
9998             Args  : Args_List (1 .. 2);
9999             Names : constant Name_List (1 .. 2) := (
10000                       Name_Title,
10001                       Name_Subtitle);
10002
10003          begin
10004             GNAT_Pragma;
10005             Gather_Associations (Names, Args);
10006
10007             for J in 1 .. 2 loop
10008                if Present (Args (J)) then
10009                   Check_Arg_Is_String_Literal (Args (J));
10010                end if;
10011             end loop;
10012          end Title;
10013
10014          ---------------------
10015          -- Unchecked_Union --
10016          ---------------------
10017
10018          --  pragma Unchecked_Union (first_subtype_LOCAL_NAME)
10019
10020          when Pragma_Unchecked_Union => Unchecked_Union : declare
10021             Assoc   : constant Node_Id := Arg1;
10022             Type_Id : constant Node_Id := Expression (Assoc);
10023             Typ     : Entity_Id;
10024             Discr   : Entity_Id;
10025             Tdef    : Node_Id;
10026             Clist   : Node_Id;
10027             Vpart   : Node_Id;
10028             Comp    : Node_Id;
10029             Variant : Node_Id;
10030
10031          begin
10032             GNAT_Pragma;
10033             Check_No_Identifiers;
10034             Check_Arg_Count (1);
10035             Check_Arg_Is_Local_Name (Arg1);
10036
10037             Find_Type (Type_Id);
10038             Typ := Entity (Type_Id);
10039
10040             if Typ = Any_Type
10041               or else Rep_Item_Too_Early (Typ, N)
10042             then
10043                return;
10044             else
10045                Typ := Underlying_Type (Typ);
10046             end if;
10047
10048             if Rep_Item_Too_Late (Typ, N) then
10049                return;
10050             end if;
10051
10052             Check_First_Subtype (Arg1);
10053
10054             --  Note remaining cases are references to a type in the current
10055             --  declarative part. If we find an error, we post the error on
10056             --  the relevant type declaration at an appropriate point.
10057
10058             if not Is_Record_Type (Typ) then
10059                Error_Msg_N ("Unchecked_Union must be record type", Typ);
10060                return;
10061
10062             elsif Is_Tagged_Type (Typ) then
10063                Error_Msg_N ("Unchecked_Union must not be tagged", Typ);
10064                return;
10065
10066             elsif Is_Limited_Type (Typ) then
10067                Error_Msg_N
10068                  ("Unchecked_Union must not be limited record type", Typ);
10069                Explain_Limited_Type (Typ, Typ);
10070                return;
10071
10072             else
10073                if not Has_Discriminants (Typ) then
10074                   Error_Msg_N
10075                     ("Unchecked_Union must have one discriminant", Typ);
10076                   return;
10077                end if;
10078
10079                Discr := First_Discriminant (Typ);
10080
10081                if Present (Next_Discriminant (Discr)) then
10082                   Error_Msg_N
10083                     ("Unchecked_Union must have exactly one discriminant",
10084                      Next_Discriminant (Discr));
10085                   return;
10086                end if;
10087
10088                if No (Discriminant_Default_Value (Discr)) then
10089                   Error_Msg_N
10090                     ("Unchecked_Union discriminant must have default value",
10091                      Discr);
10092                end if;
10093
10094                Tdef  := Type_Definition (Declaration_Node (Typ));
10095                Clist := Component_List (Tdef);
10096
10097                Comp := First (Component_Items (Clist));
10098                while Present (Comp) loop
10099
10100                   Check_Component (Comp);
10101                   Next (Comp);
10102
10103                end loop;
10104
10105                if No (Clist) or else No (Variant_Part (Clist)) then
10106                   Error_Msg_N
10107                     ("Unchecked_Union must have variant part",
10108                      Tdef);
10109                   return;
10110                end if;
10111
10112                Vpart := Variant_Part (Clist);
10113
10114                Variant := First (Variants (Vpart));
10115                while Present (Variant) loop
10116                   Check_Variant (Variant);
10117                   Next (Variant);
10118                end loop;
10119             end if;
10120
10121             Set_Is_Unchecked_Union  (Typ, True);
10122             Set_Convention          (Typ, Convention_C);
10123
10124             Set_Has_Unchecked_Union (Base_Type (Typ), True);
10125             Set_Is_Unchecked_Union  (Base_Type (Typ), True);
10126          end Unchecked_Union;
10127
10128          ------------------------
10129          -- Unimplemented_Unit --
10130          ------------------------
10131
10132          --  pragma Unimplemented_Unit;
10133
10134          --  Note: this only gives an error if we are generating code,
10135          --  or if we are in a generic library unit (where the pragma
10136          --  appears in the body, not in the spec).
10137
10138          when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
10139             Cunitent : constant Entity_Id :=
10140                          Cunit_Entity (Get_Source_Unit (Loc));
10141             Ent_Kind : constant Entity_Kind :=
10142                          Ekind (Cunitent);
10143
10144          begin
10145             GNAT_Pragma;
10146             Check_Arg_Count (0);
10147
10148             if Operating_Mode = Generate_Code
10149               or else Ent_Kind = E_Generic_Function
10150               or else Ent_Kind = E_Generic_Procedure
10151               or else Ent_Kind = E_Generic_Package
10152             then
10153                Get_Name_String (Chars (Cunitent));
10154                Set_Casing (Mixed_Case);
10155                Write_Str (Name_Buffer (1 .. Name_Len));
10156                Write_Str (" is not implemented");
10157                Write_Eol;
10158                raise Unrecoverable_Error;
10159             end if;
10160          end Unimplemented_Unit;
10161
10162          --------------------
10163          -- Universal_Data --
10164          --------------------
10165
10166          --  pragma Universal_Data [(library_unit_NAME)];
10167
10168          when Pragma_Universal_Data =>
10169             GNAT_Pragma;
10170
10171             --  If this is a configuration pragma, then set the universal
10172             --  addressing option, otherwise confirm that the pragma
10173             --  satisfies the requirements of library unit pragma placement
10174             --  and leave it to the GNAAMP back end to detect the pragma
10175             --  (avoids transitive setting of the option due to withed units).
10176
10177             if Is_Configuration_Pragma then
10178                Universal_Addressing_On_AAMP := True;
10179             else
10180                Check_Valid_Library_Unit_Pragma;
10181             end if;
10182
10183             if not AAMP_On_Target then
10184                Error_Pragma ("?pragma% ignored (applies only to AAMP)");
10185             end if;
10186
10187          ------------------
10188          -- Unreferenced --
10189          ------------------
10190
10191          --  pragma Unreferenced (local_Name {, local_Name});
10192
10193          when Pragma_Unreferenced => Unreferenced : declare
10194             Arg_Node : Node_Id;
10195             Arg_Expr : Node_Id;
10196             Arg_Ent  : Entity_Id;
10197
10198          begin
10199             GNAT_Pragma;
10200             Check_At_Least_N_Arguments (1);
10201
10202             Arg_Node := Arg1;
10203             while Present (Arg_Node) loop
10204                Check_No_Identifier (Arg_Node);
10205
10206                --  Note that the analyze call done by Check_Arg_Is_Local_Name
10207                --  will in fact generate a reference, so that the entity will
10208                --  have a reference, which will inhibit any warnings about it
10209                --  not being referenced, and also properly show up in the ali
10210                --  file as a reference. But this reference is recorded before
10211                --  the Has_Pragma_Unreferenced flag is set, so that no warning
10212                --  is generated for this reference.
10213
10214                Check_Arg_Is_Local_Name (Arg_Node);
10215                Arg_Expr := Get_Pragma_Arg (Arg_Node);
10216
10217                if Is_Entity_Name (Arg_Expr) then
10218                   Arg_Ent := Entity (Arg_Expr);
10219
10220                   --  If the entity is overloaded, the pragma applies to the
10221                   --  most recent overloading, as documented. In this case,
10222                   --  name resolution does not generate a reference, so it
10223                   --  must be done here explicitly.
10224
10225                   if Is_Overloaded (Arg_Expr) then
10226                      Generate_Reference (Arg_Ent, N);
10227                   end if;
10228
10229                   Set_Has_Pragma_Unreferenced (Arg_Ent);
10230                end if;
10231
10232                Next (Arg_Node);
10233             end loop;
10234          end Unreferenced;
10235
10236          ------------------------------
10237          -- Unreserve_All_Interrupts --
10238          ------------------------------
10239
10240          --  pragma Unreserve_All_Interrupts;
10241
10242          when Pragma_Unreserve_All_Interrupts =>
10243             GNAT_Pragma;
10244             Check_Arg_Count (0);
10245
10246             if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
10247                Unreserve_All_Interrupts := True;
10248             end if;
10249
10250          ----------------
10251          -- Unsuppress --
10252          ----------------
10253
10254          --  pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
10255
10256          when Pragma_Unsuppress =>
10257             GNAT_Pragma;
10258             Process_Suppress_Unsuppress (False);
10259
10260          -------------------
10261          -- Use_VADS_Size --
10262          -------------------
10263
10264          --  pragma Use_VADS_Size;
10265
10266          when Pragma_Use_VADS_Size =>
10267             GNAT_Pragma;
10268             Check_Arg_Count (0);
10269             Check_Valid_Configuration_Pragma;
10270             Use_VADS_Size := True;
10271
10272          ---------------------
10273          -- Validity_Checks --
10274          ---------------------
10275
10276          --  pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
10277
10278          when Pragma_Validity_Checks => Validity_Checks : declare
10279             A  : constant Node_Id   := Expression (Arg1);
10280             S  : String_Id;
10281             C  : Char_Code;
10282
10283          begin
10284             GNAT_Pragma;
10285             Check_Arg_Count (1);
10286             Check_No_Identifiers;
10287
10288             if Nkind (A) = N_String_Literal then
10289                S   := Strval (A);
10290
10291                declare
10292                   Slen    : constant Natural := Natural (String_Length (S));
10293                   Options : String (1 .. Slen);
10294                   J       : Natural;
10295
10296                begin
10297                   J := 1;
10298                   loop
10299                      C := Get_String_Char (S, Int (J));
10300                      exit when not In_Character_Range (C);
10301                      Options (J) := Get_Character (C);
10302
10303                      if J = Slen then
10304                         Set_Validity_Check_Options (Options);
10305                         exit;
10306                      else
10307                         J := J + 1;
10308                      end if;
10309                   end loop;
10310                end;
10311
10312             elsif Nkind (A) = N_Identifier then
10313
10314                if Chars (A) = Name_All_Checks then
10315                   Set_Validity_Check_Options ("a");
10316
10317                elsif Chars (A) = Name_On then
10318                   Validity_Checks_On := True;
10319
10320                elsif Chars (A) = Name_Off then
10321                   Validity_Checks_On := False;
10322
10323                end if;
10324             end if;
10325          end Validity_Checks;
10326
10327          --------------
10328          -- Volatile --
10329          --------------
10330
10331          --  pragma Volatile (LOCAL_NAME);
10332
10333          when Pragma_Volatile =>
10334             Process_Atomic_Shared_Volatile;
10335
10336          -------------------------
10337          -- Volatile_Components --
10338          -------------------------
10339
10340          --  pragma Volatile_Components (array_LOCAL_NAME);
10341
10342          --  Volatile is handled by the same circuit as Atomic_Components
10343
10344          --------------
10345          -- Warnings --
10346          --------------
10347
10348          --  pragma Warnings (On | Off, [LOCAL_NAME])
10349
10350          when Pragma_Warnings => Warnings : begin
10351             GNAT_Pragma;
10352             Check_At_Least_N_Arguments (1);
10353             Check_At_Most_N_Arguments (2);
10354             Check_No_Identifiers;
10355
10356             --  One argument case was processed by parser in Par.Prag
10357
10358             if Arg_Count /= 1 then
10359                Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
10360                Check_Arg_Count (2);
10361
10362                declare
10363                   E_Id : Node_Id;
10364                   E    : Entity_Id;
10365
10366                begin
10367                   E_Id := Expression (Arg2);
10368                   Analyze (E_Id);
10369
10370                   --  In the expansion of an inlined body, a reference to
10371                   --  the formal may be wrapped in a conversion if the actual
10372                   --  is a conversion. Retrieve the real entity name.
10373
10374                   if (In_Instance_Body
10375                        or else In_Inlined_Body)
10376                     and then Nkind (E_Id) = N_Unchecked_Type_Conversion
10377                   then
10378                      E_Id := Expression (E_Id);
10379                   end if;
10380
10381                   if not Is_Entity_Name (E_Id) then
10382                      Error_Pragma_Arg
10383                        ("second argument of pragma% must be entity name",
10384                         Arg2);
10385                   end if;
10386
10387                   E := Entity (E_Id);
10388
10389                   if E = Any_Id then
10390                      return;
10391                   else
10392                      loop
10393                         Set_Warnings_Off (E,
10394                           (Chars (Expression (Arg1)) = Name_Off));
10395
10396                         if Is_Enumeration_Type (E) then
10397                            declare
10398                               Lit : Entity_Id;
10399                            begin
10400                               Lit := First_Literal (E);
10401                               while Present (Lit) loop
10402                                  Set_Warnings_Off (Lit);
10403                                  Next_Literal (Lit);
10404                               end loop;
10405                            end;
10406                         end if;
10407
10408                         exit when No (Homonym (E));
10409                         E := Homonym (E);
10410                      end loop;
10411                   end if;
10412                end;
10413             end if;
10414          end Warnings;
10415
10416          -------------------
10417          -- Weak_External --
10418          -------------------
10419
10420          --  pragma Weak_External ([Entity =>] LOCAL_NAME);
10421
10422          when Pragma_Weak_External => Weak_External : declare
10423             Ent : Entity_Id;
10424
10425          begin
10426             GNAT_Pragma;
10427             Check_Arg_Count (1);
10428             Check_Optional_Identifier (Arg1, Name_Entity);
10429             Check_Arg_Is_Library_Level_Local_Name (Arg1);
10430             Ent := Entity (Expression (Arg1));
10431
10432             if Rep_Item_Too_Early (Ent, N) then
10433                return;
10434             else
10435                Ent := Underlying_Type (Ent);
10436             end if;
10437
10438             --  The only processing required is to link this item on to the
10439             --  list of rep items for the given entity. This is accomplished
10440             --  by the call to Rep_Item_Too_Late (when no error is detected
10441             --  and False is returned).
10442
10443             if Rep_Item_Too_Late (Ent, N) then
10444                return;
10445             else
10446                Set_Has_Gigi_Rep_Item (Ent);
10447             end if;
10448          end Weak_External;
10449
10450          --------------------
10451          -- Unknown_Pragma --
10452          --------------------
10453
10454          --  Should be impossible, since the case of an unknown pragma is
10455          --  separately processed before the case statement is entered.
10456
10457          when Unknown_Pragma =>
10458             raise Program_Error;
10459       end case;
10460
10461    exception
10462       when Pragma_Exit => null;
10463    end Analyze_Pragma;
10464
10465    ---------------------------------
10466    -- Delay_Config_Pragma_Analyze --
10467    ---------------------------------
10468
10469    function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
10470    begin
10471       return Chars (N) = Name_Interrupt_State;
10472    end Delay_Config_Pragma_Analyze;
10473
10474    -------------------------
10475    -- Get_Base_Subprogram --
10476    -------------------------
10477
10478    function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
10479       Result : Entity_Id;
10480
10481    begin
10482       --  Follow subprogram renaming chain
10483
10484       Result := Def_Id;
10485       while Is_Subprogram (Result)
10486         and then
10487           (Is_Generic_Instance (Result)
10488             or else Nkind (Parent (Declaration_Node (Result))) =
10489                     N_Subprogram_Renaming_Declaration)
10490         and then Present (Alias (Result))
10491       loop
10492          Result := Alias (Result);
10493       end loop;
10494
10495       return Result;
10496    end Get_Base_Subprogram;
10497
10498    -----------------------------
10499    -- Is_Config_Static_String --
10500    -----------------------------
10501
10502    function Is_Config_Static_String (Arg : Node_Id) return Boolean is
10503
10504       function Add_Config_Static_String (Arg : Node_Id) return Boolean;
10505       --  This is an internal recursive function that is just like the
10506       --  outer function except that it adds the string to the name buffer
10507       --  rather than placing the string in the name buffer.
10508
10509       ------------------------------
10510       -- Add_Config_Static_String --
10511       ------------------------------
10512
10513       function Add_Config_Static_String (Arg : Node_Id) return Boolean is
10514          N : Node_Id;
10515          C : Char_Code;
10516
10517       begin
10518          N := Arg;
10519
10520          if Nkind (N) = N_Op_Concat then
10521             if Add_Config_Static_String (Left_Opnd (N)) then
10522                N := Right_Opnd (N);
10523             else
10524                return False;
10525             end if;
10526          end if;
10527
10528          if Nkind (N) /= N_String_Literal then
10529             Error_Msg_N ("string literal expected for pragma argument", N);
10530             return False;
10531
10532          else
10533             for J in 1 .. String_Length (Strval (N)) loop
10534                C := Get_String_Char (Strval (N), J);
10535
10536                if not In_Character_Range (C) then
10537                   Error_Msg
10538                     ("string literal contains invalid wide character",
10539                      Sloc (N) + 1 + Source_Ptr (J));
10540                   return False;
10541                end if;
10542
10543                Add_Char_To_Name_Buffer (Get_Character (C));
10544             end loop;
10545          end if;
10546
10547          return True;
10548       end Add_Config_Static_String;
10549
10550    --  Start of prorcessing for Is_Config_Static_String
10551
10552    begin
10553
10554       Name_Len := 0;
10555       return Add_Config_Static_String (Arg);
10556    end Is_Config_Static_String;
10557
10558    -----------------------------------------
10559    -- Is_Non_Significant_Pragma_Reference --
10560    -----------------------------------------
10561
10562    --  This function makes use of the following static table which indicates
10563    --  whether a given pragma is significant. A value of -1 in this table
10564    --  indicates that the reference is significant. A value of zero indicates
10565    --  than appearence as any argument is insignificant, a positive value
10566    --  indicates that appearence in that parameter position is significant.
10567
10568    Sig_Flags : constant array (Pragma_Id) of Int :=
10569
10570      (Pragma_AST_Entry                    => -1,
10571       Pragma_Abort_Defer                  => -1,
10572       Pragma_Ada_83                       => -1,
10573       Pragma_Ada_95                       => -1,
10574       Pragma_Ada_05                       => -1,
10575       Pragma_All_Calls_Remote             => -1,
10576       Pragma_Annotate                     => -1,
10577       Pragma_Assert                       => -1,
10578       Pragma_Assertion_Policy             =>  0,
10579       Pragma_Asynchronous                 => -1,
10580       Pragma_Atomic                       =>  0,
10581       Pragma_Atomic_Components            =>  0,
10582       Pragma_Attach_Handler               => -1,
10583       Pragma_CPP_Class                    =>  0,
10584       Pragma_CPP_Constructor              =>  0,
10585       Pragma_CPP_Virtual                  =>  0,
10586       Pragma_CPP_Vtable                   =>  0,
10587       Pragma_C_Pass_By_Copy               =>  0,
10588       Pragma_Comment                      =>  0,
10589       Pragma_Common_Object                => -1,
10590       Pragma_Compile_Time_Warning         => -1,
10591       Pragma_Complex_Representation       =>  0,
10592       Pragma_Component_Alignment          => -1,
10593       Pragma_Controlled                   =>  0,
10594       Pragma_Convention                   =>  0,
10595       Pragma_Convention_Identifier        =>  0,
10596       Pragma_Debug                        => -1,
10597       Pragma_Debug_Policy                 =>  0,
10598       Pragma_Detect_Blocking              => -1,
10599       Pragma_Discard_Names                =>  0,
10600       Pragma_Elaborate                    => -1,
10601       Pragma_Elaborate_All                => -1,
10602       Pragma_Elaborate_Body               => -1,
10603       Pragma_Elaboration_Checks           => -1,
10604       Pragma_Eliminate                    => -1,
10605       Pragma_Explicit_Overriding          => -1,
10606       Pragma_Export                       => -1,
10607       Pragma_Export_Exception             => -1,
10608       Pragma_Export_Function              => -1,
10609       Pragma_Export_Object                => -1,
10610       Pragma_Export_Procedure             => -1,
10611       Pragma_Export_Value                 => -1,
10612       Pragma_Export_Valued_Procedure      => -1,
10613       Pragma_Extend_System                => -1,
10614       Pragma_Extensions_Allowed           => -1,
10615       Pragma_External                     => -1,
10616       Pragma_External_Name_Casing         => -1,
10617       Pragma_Finalize_Storage_Only        =>  0,
10618       Pragma_Float_Representation         =>  0,
10619       Pragma_Ident                        => -1,
10620       Pragma_Import                       => +2,
10621       Pragma_Import_Exception             =>  0,
10622       Pragma_Import_Function              =>  0,
10623       Pragma_Import_Object                =>  0,
10624       Pragma_Import_Procedure             =>  0,
10625       Pragma_Import_Valued_Procedure      =>  0,
10626       Pragma_Initialize_Scalars           => -1,
10627       Pragma_Inline                       =>  0,
10628       Pragma_Inline_Always                =>  0,
10629       Pragma_Inline_Generic               =>  0,
10630       Pragma_Inspection_Point             => -1,
10631       Pragma_Interface                    => +2,
10632       Pragma_Interface_Name               => +2,
10633       Pragma_Interrupt_Handler            => -1,
10634       Pragma_Interrupt_Priority           => -1,
10635       Pragma_Interrupt_State              => -1,
10636       Pragma_Java_Constructor             => -1,
10637       Pragma_Java_Interface               => -1,
10638       Pragma_Keep_Names                   =>  0,
10639       Pragma_License                      => -1,
10640       Pragma_Link_With                    => -1,
10641       Pragma_Linker_Alias                 => -1,
10642       Pragma_Linker_Constructor           => -1,
10643       Pragma_Linker_Destructor            => -1,
10644       Pragma_Linker_Options               => -1,
10645       Pragma_Linker_Section               => -1,
10646       Pragma_List                         => -1,
10647       Pragma_Locking_Policy               => -1,
10648       Pragma_Long_Float                   => -1,
10649       Pragma_Machine_Attribute            => -1,
10650       Pragma_Main                         => -1,
10651       Pragma_Main_Storage                 => -1,
10652       Pragma_Memory_Size                  => -1,
10653       Pragma_No_Return                    =>  0,
10654       Pragma_No_Run_Time                  => -1,
10655       Pragma_No_Strict_Aliasing           => -1,
10656       Pragma_Normalize_Scalars            => -1,
10657       Pragma_Obsolescent                  =>  0,
10658       Pragma_Optimize                     => -1,
10659       Pragma_Optional_Overriding          => -1,
10660       Pragma_Pack                         =>  0,
10661       Pragma_Page                         => -1,
10662       Pragma_Passive                      => -1,
10663       Pragma_Polling                      => -1,
10664       Pragma_Persistent_BSS               =>  0,
10665       Pragma_Preelaborate                 => -1,
10666       Pragma_Preelaborate_05              => -1,
10667       Pragma_Priority                     => -1,
10668       Pragma_Profile                      =>  0,
10669       Pragma_Profile_Warnings             =>  0,
10670       Pragma_Propagate_Exceptions         => -1,
10671       Pragma_Psect_Object                 => -1,
10672       Pragma_Pure                         => -1,
10673       Pragma_Pure_05                      => -1,
10674       Pragma_Pure_Function                => -1,
10675       Pragma_Queuing_Policy               => -1,
10676       Pragma_Ravenscar                    => -1,
10677       Pragma_Remote_Call_Interface        => -1,
10678       Pragma_Remote_Types                 => -1,
10679       Pragma_Restricted_Run_Time          => -1,
10680       Pragma_Restriction_Warnings         => -1,
10681       Pragma_Restrictions                 => -1,
10682       Pragma_Reviewable                   => -1,
10683       Pragma_Share_Generic                => -1,
10684       Pragma_Shared                       => -1,
10685       Pragma_Shared_Passive               => -1,
10686       Pragma_Source_File_Name             => -1,
10687       Pragma_Source_File_Name_Project     => -1,
10688       Pragma_Source_Reference             => -1,
10689       Pragma_Storage_Size                 => -1,
10690       Pragma_Storage_Unit                 => -1,
10691       Pragma_Stream_Convert               => -1,
10692       Pragma_Style_Checks                 => -1,
10693       Pragma_Subtitle                     => -1,
10694       Pragma_Suppress                     =>  0,
10695       Pragma_Suppress_Exception_Locations =>  0,
10696       Pragma_Suppress_All                 => -1,
10697       Pragma_Suppress_Debug_Info          =>  0,
10698       Pragma_Suppress_Initialization      =>  0,
10699       Pragma_System_Name                  => -1,
10700       Pragma_Task_Dispatching_Policy      => -1,
10701       Pragma_Task_Info                    => -1,
10702       Pragma_Task_Name                    => -1,
10703       Pragma_Task_Storage                 =>  0,
10704       Pragma_Thread_Body                  => +2,
10705       Pragma_Time_Slice                   => -1,
10706       Pragma_Title                        => -1,
10707       Pragma_Unchecked_Union              =>  0,
10708       Pragma_Unimplemented_Unit           => -1,
10709       Pragma_Universal_Data               => -1,
10710       Pragma_Unreferenced                 => -1,
10711       Pragma_Unreserve_All_Interrupts     => -1,
10712       Pragma_Unsuppress                   =>  0,
10713       Pragma_Use_VADS_Size                => -1,
10714       Pragma_Validity_Checks              => -1,
10715       Pragma_Volatile                     =>  0,
10716       Pragma_Volatile_Components          =>  0,
10717       Pragma_Warnings                     => -1,
10718       Pragma_Weak_External                =>  0,
10719       Unknown_Pragma                      =>  0);
10720
10721    function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
10722       P : Node_Id;
10723       C : Int;
10724       A : Node_Id;
10725
10726    begin
10727       P := Parent (N);
10728
10729       if Nkind (P) /= N_Pragma_Argument_Association then
10730          return False;
10731
10732       else
10733          C := Sig_Flags (Get_Pragma_Id (Chars (Parent (P))));
10734
10735          case C is
10736             when -1 =>
10737                return False;
10738
10739             when 0 =>
10740                return True;
10741
10742             when others =>
10743                A := First (Pragma_Argument_Associations (Parent (P)));
10744                for J in 1 .. C - 1 loop
10745                   if No (A) then
10746                      return False;
10747                   end if;
10748
10749                   Next (A);
10750                end loop;
10751
10752                return A = P;
10753          end case;
10754       end if;
10755    end Is_Non_Significant_Pragma_Reference;
10756
10757    ------------------------------
10758    -- Is_Pragma_String_Literal --
10759    ------------------------------
10760
10761    --  This function returns true if the corresponding pragma argument is
10762    --  a static string expression. These are the only cases in which string
10763    --  literals can appear as pragma arguments. We also allow a string
10764    --  literal as the first argument to pragma Assert (although it will
10765    --  of course always generate a type error).
10766
10767    function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
10768       Pragn : constant Node_Id := Parent (Par);
10769       Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
10770       Pname : constant Name_Id := Chars (Pragn);
10771       Argn  : Natural;
10772       N     : Node_Id;
10773
10774    begin
10775       Argn := 1;
10776       N := First (Assoc);
10777       loop
10778          exit when N = Par;
10779          Argn := Argn + 1;
10780          Next (N);
10781       end loop;
10782
10783       if Pname = Name_Assert then
10784          return True;
10785
10786       elsif Pname = Name_Export then
10787          return Argn > 2;
10788
10789       elsif Pname = Name_Ident then
10790          return Argn = 1;
10791
10792       elsif Pname = Name_Import then
10793          return Argn > 2;
10794
10795       elsif Pname = Name_Interface_Name then
10796          return Argn > 1;
10797
10798       elsif Pname = Name_Linker_Alias then
10799          return Argn = 2;
10800
10801       elsif Pname = Name_Linker_Section then
10802          return Argn = 2;
10803
10804       elsif Pname = Name_Machine_Attribute then
10805          return Argn = 2;
10806
10807       elsif Pname = Name_Source_File_Name then
10808          return True;
10809
10810       elsif Pname = Name_Source_Reference then
10811          return Argn = 2;
10812
10813       elsif Pname = Name_Title then
10814          return True;
10815
10816       elsif Pname = Name_Subtitle then
10817          return True;
10818
10819       else
10820          return False;
10821       end if;
10822    end Is_Pragma_String_Literal;
10823
10824    --------------------------------------
10825    -- Process_Compilation_Unit_Pragmas --
10826    --------------------------------------
10827
10828    procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
10829    begin
10830       --  A special check for pragma Suppress_All. This is a strange DEC
10831       --  pragma, strange because it comes at the end of the unit. If we
10832       --  have a pragma Suppress_All in the Pragmas_After of the current
10833       --  unit, then we insert a pragma Suppress (All_Checks) at the start
10834       --  of the context clause to ensure the correct processing.
10835
10836       declare
10837          PA : constant List_Id := Pragmas_After (Aux_Decls_Node (N));
10838          P  : Node_Id;
10839
10840       begin
10841          if Present (PA) then
10842             P := First (PA);
10843             while Present (P) loop
10844                if Chars (P) = Name_Suppress_All then
10845                   Prepend_To (Context_Items (N),
10846                     Make_Pragma (Sloc (P),
10847                       Chars => Name_Suppress,
10848                       Pragma_Argument_Associations => New_List (
10849                         Make_Pragma_Argument_Association (Sloc (P),
10850                           Expression =>
10851                             Make_Identifier (Sloc (P),
10852                               Chars => Name_All_Checks)))));
10853                   exit;
10854                end if;
10855
10856                Next (P);
10857             end loop;
10858          end if;
10859       end;
10860    end Process_Compilation_Unit_Pragmas;
10861
10862    --------------------------------
10863    -- Set_Encoded_Interface_Name --
10864    --------------------------------
10865
10866    procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
10867       Str : constant String_Id := Strval (S);
10868       Len : constant Int       := String_Length (Str);
10869       CC  : Char_Code;
10870       C   : Character;
10871       J   : Int;
10872
10873       Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
10874
10875       procedure Encode;
10876       --  Stores encoded value of character code CC. The encoding we
10877       --  use an underscore followed by four lower case hex digits.
10878
10879       ------------
10880       -- Encode --
10881       ------------
10882
10883       procedure Encode is
10884       begin
10885          Store_String_Char (Get_Char_Code ('_'));
10886          Store_String_Char
10887            (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
10888          Store_String_Char
10889            (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
10890          Store_String_Char
10891            (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
10892          Store_String_Char
10893            (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
10894       end Encode;
10895
10896    --  Start of processing for Set_Encoded_Interface_Name
10897
10898    begin
10899       --  If first character is asterisk, this is a link name, and we
10900       --  leave it completely unmodified. We also ignore null strings
10901       --  (the latter case happens only in error cases) and no encoding
10902       --  should occur for Java interface names.
10903
10904       if Len = 0
10905         or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
10906         or else Java_VM
10907       then
10908          Set_Interface_Name (E, S);
10909
10910       else
10911          J := 1;
10912          loop
10913             CC := Get_String_Char (Str, J);
10914
10915             exit when not In_Character_Range (CC);
10916
10917             C := Get_Character (CC);
10918
10919             exit when C /= '_' and then C /= '$'
10920               and then C not in '0' .. '9'
10921               and then C not in 'a' .. 'z'
10922               and then C not in 'A' .. 'Z';
10923
10924             if J = Len then
10925                Set_Interface_Name (E, S);
10926                return;
10927
10928             else
10929                J := J + 1;
10930             end if;
10931          end loop;
10932
10933          --  Here we need to encode. The encoding we use as follows:
10934          --     three underscores  + four hex digits (lower case)
10935
10936          Start_String;
10937
10938          for J in 1 .. String_Length (Str) loop
10939             CC := Get_String_Char (Str, J);
10940
10941             if not In_Character_Range (CC) then
10942                Encode;
10943             else
10944                C := Get_Character (CC);
10945
10946                if C = '_' or else C = '$'
10947                  or else C in '0' .. '9'
10948                  or else C in 'a' .. 'z'
10949                  or else C in 'A' .. 'Z'
10950                then
10951                   Store_String_Char (CC);
10952                else
10953                   Encode;
10954                end if;
10955             end if;
10956          end loop;
10957
10958          Set_Interface_Name (E,
10959            Make_String_Literal (Sloc (S),
10960              Strval => End_String));
10961       end if;
10962    end Set_Encoded_Interface_Name;
10963
10964    -------------------
10965    -- Set_Unit_Name --
10966    -------------------
10967
10968    procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
10969       Pref : Node_Id;
10970       Scop : Entity_Id;
10971
10972    begin
10973       if Nkind (N) = N_Identifier
10974         and then Nkind (With_Item) = N_Identifier
10975       then
10976          Set_Entity (N, Entity (With_Item));
10977
10978       elsif Nkind (N) = N_Selected_Component then
10979          Change_Selected_Component_To_Expanded_Name (N);
10980          Set_Entity (N, Entity (With_Item));
10981          Set_Entity (Selector_Name (N), Entity (N));
10982
10983          Pref := Prefix (N);
10984          Scop := Scope (Entity (N));
10985          while Nkind (Pref) = N_Selected_Component loop
10986             Change_Selected_Component_To_Expanded_Name (Pref);
10987             Set_Entity (Selector_Name (Pref), Scop);
10988             Set_Entity (Pref, Scop);
10989             Pref := Prefix (Pref);
10990             Scop := Scope (Scop);
10991          end loop;
10992
10993          Set_Entity (Pref, Scop);
10994       end if;
10995    end Set_Unit_Name;
10996 end Sem_Prag;