gcc/ada/sem_prag.adb

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