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