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