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