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