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