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