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