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