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