File : 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-2016, 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 Aspects;   use Aspects;
  33 with Atree;     use Atree;
  34 with Casing;    use Casing;
  35 with Checks;    use Checks;
  36 with Contracts; use Contracts;
  37 with Csets;     use Csets;
  38 with Debug;     use Debug;
  39 with Einfo;     use Einfo;
  40 with Elists;    use Elists;
  41 with Errout;    use Errout;
  42 with Exp_Ch7;   use Exp_Ch7;
  43 with Exp_Dist;  use Exp_Dist;
  44 with Exp_Util;  use Exp_Util;
  45 with Freeze;    use Freeze;
  46 with Ghost;     use Ghost;
  47 with Gnatvsn;   use Gnatvsn;
  48 with Lib;       use Lib;
  49 with Lib.Writ;  use Lib.Writ;
  50 with Lib.Xref;  use Lib.Xref;
  51 with Namet.Sp;  use Namet.Sp;
  52 with Nlists;    use Nlists;
  53 with Nmake;     use Nmake;
  54 with Output;    use Output;
  55 with Par_SCO;   use Par_SCO;
  56 with Restrict;  use Restrict;
  57 with Rident;    use Rident;
  58 with Rtsfind;   use Rtsfind;
  59 with Sem;       use Sem;
  60 with Sem_Aux;   use Sem_Aux;
  61 with Sem_Ch3;   use Sem_Ch3;
  62 with Sem_Ch6;   use Sem_Ch6;
  63 with Sem_Ch8;   use Sem_Ch8;
  64 with Sem_Ch12;  use Sem_Ch12;
  65 with Sem_Ch13;  use Sem_Ch13;
  66 with Sem_Disp;  use Sem_Disp;
  67 with Sem_Dist;  use Sem_Dist;
  68 with Sem_Elim;  use Sem_Elim;
  69 with Sem_Eval;  use Sem_Eval;
  70 with Sem_Intr;  use Sem_Intr;
  71 with Sem_Mech;  use Sem_Mech;
  72 with Sem_Res;   use Sem_Res;
  73 with Sem_Type;  use Sem_Type;
  74 with Sem_Util;  use Sem_Util;
  75 with Sem_Warn;  use Sem_Warn;
  76 with Stand;     use Stand;
  77 with Sinfo;     use Sinfo;
  78 with Sinfo.CN;  use Sinfo.CN;
  79 with Sinput;    use Sinput;
  80 with Stringt;   use Stringt;
  81 with Stylesw;   use Stylesw;
  82 with Table;
  83 with Targparm;  use Targparm;
  84 with Tbuild;    use Tbuild;
  85 with Ttypes;
  86 with Uintp;     use Uintp;
  87 with Uname;     use Uname;
  88 with Urealp;    use Urealp;
  89 with Validsw;   use Validsw;
  90 with Warnsw;    use Warnsw;
  91 
  92 with GNAT.HTable; use GNAT.HTable;
  93 
  94 package body Sem_Prag is
  95 
  96    ----------------------------------------------
  97    -- Common Handling of Import-Export Pragmas --
  98    ----------------------------------------------
  99 
 100    --  In the following section, a number of Import_xxx and Export_xxx pragmas
 101    --  are defined by GNAT. These are compatible with the DEC pragmas of the
 102    --  same name, and all have the following common form and processing:
 103 
 104    --  pragma Export_xxx
 105    --        [Internal                 =>] LOCAL_NAME
 106    --     [, [External                 =>] EXTERNAL_SYMBOL]
 107    --     [, other optional parameters   ]);
 108 
 109    --  pragma Import_xxx
 110    --        [Internal                 =>] LOCAL_NAME
 111    --     [, [External                 =>] EXTERNAL_SYMBOL]
 112    --     [, other optional parameters   ]);
 113 
 114    --   EXTERNAL_SYMBOL ::=
 115    --     IDENTIFIER
 116    --   | static_string_EXPRESSION
 117 
 118    --  The internal LOCAL_NAME designates the entity that is imported or
 119    --  exported, and must refer to an entity in the current declarative
 120    --  part (as required by the rules for LOCAL_NAME).
 121 
 122    --  The external linker name is designated by the External parameter if
 123    --  given, or the Internal parameter if not (if there is no External
 124    --  parameter, the External parameter is a copy of the Internal name).
 125 
 126    --  If the External parameter is given as a string, then this string is
 127    --  treated as an external name (exactly as though it had been given as an
 128    --  External_Name parameter for a normal Import pragma).
 129 
 130    --  If the External parameter is given as an identifier (or there is no
 131    --  External parameter, so that the Internal identifier is used), then
 132    --  the external name is the characters of the identifier, translated
 133    --  to all lower case letters.
 134 
 135    --  Note: the external name specified or implied by any of these special
 136    --  Import_xxx or Export_xxx pragmas override an external or link name
 137    --  specified in a previous Import or Export pragma.
 138 
 139    --  Note: these and all other DEC-compatible GNAT pragmas allow full use of
 140    --  named notation, following the standard rules for subprogram calls, i.e.
 141    --  parameters can be given in any order if named notation is used, and
 142    --  positional and named notation can be mixed, subject to the rule that all
 143    --  positional parameters must appear first.
 144 
 145    --  Note: All these pragmas are implemented exactly following the DEC design
 146    --  and implementation and are intended to be fully compatible with the use
 147    --  of these pragmas in the DEC Ada compiler.
 148 
 149    --------------------------------------------
 150    -- Checking for Duplicated External Names --
 151    --------------------------------------------
 152 
 153    --  It is suspicious if two separate Export pragmas use the same external
 154    --  name. The following table is used to diagnose this situation so that
 155    --  an appropriate warning can be issued.
 156 
 157    --  The Node_Id stored is for the N_String_Literal node created to hold
 158    --  the value of the external name. The Sloc of this node is used to
 159    --  cross-reference the location of the duplication.
 160 
 161    package Externals is new Table.Table (
 162      Table_Component_Type => Node_Id,
 163      Table_Index_Type     => Int,
 164      Table_Low_Bound      => 0,
 165      Table_Initial        => 100,
 166      Table_Increment      => 100,
 167      Table_Name           => "Name_Externals");
 168 
 169    --------------------------------------------------------
 170    -- Handling of inherited classwide pre/postconditions --
 171    --------------------------------------------------------
 172 
 173    --  Following AI12-0113, the expression for a classwide condition is
 174    --  transformed for a subprogram that inherits it, by replacing calls
 175    --  to primitive operations of the original controlling type into the
 176    --  corresponding overriding operations of the derived type. The following
 177    --  hash table manages this mapping, and is expanded on demand whenever
 178    --  such inherited expression needs to be constructed.
 179 
 180    --  The mapping is also used to check whether an inherited operation has
 181    --  a condition that depends on overridden operations. For such an
 182    --  operation we must create a wrapper that is then treated as a normal
 183    --  overriding. In SPARK mode such operations are illegal.
 184 
 185    --  For a given root type there may be several type extensions with their
 186    --  own overriding operations, so at various times a given operation of
 187    --  the root will be mapped into different overridings. The root type is
 188    --  also mapped into the current type extension to indicate that its
 189    --  operations are mapped into the overriding operations of that current
 190    --  type extension.
 191 
 192    subtype Num_Primitives is Integer range 0 .. 510;
 193    function Entity_Hash (E : Entity_Id) return Num_Primitives;
 194 
 195    package Primitives_Mapping is new Gnat.HTable.Simple_Htable
 196      (Header_Num => Num_Primitives,
 197       Key        => Entity_Id,
 198       Element    => Entity_Id,
 199       No_element => Empty,
 200       Hash       => Entity_Hash,
 201       Equal      => "=");
 202 
 203    -------------------------------------
 204    -- Local Subprograms and Variables --
 205    -------------------------------------
 206 
 207    function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
 208    --  This routine is used for possible casing adjustment of an explicit
 209    --  external name supplied as a string literal (the node N), according to
 210    --  the casing requirement of Opt.External_Name_Casing. If this is set to
 211    --  As_Is, then the string literal is returned unchanged, but if it is set
 212    --  to Uppercase or Lowercase, then a new string literal with appropriate
 213    --  casing is constructed.
 214 
 215    procedure Analyze_Part_Of
 216      (Indic    : Node_Id;
 217       Item_Id  : Entity_Id;
 218       Encap    : Node_Id;
 219       Encap_Id : out Entity_Id;
 220       Legal    : out Boolean);
 221    --  Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
 222    --  Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
 223    --  Part_Of indicator. Item_Id is the entity of an abstract state, object or
 224    --  package instantiation. Encap denotes the encapsulating state or single
 225    --  concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
 226    --  the indicator is legal.
 227 
 228    function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean;
 229    --  Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
 230    --  Query whether a particular item appears in a mixed list of nodes and
 231    --  entities. It is assumed that all nodes in the list have entities.
 232 
 233    procedure Check_Postcondition_Use_In_Inlined_Subprogram
 234      (Prag    : Node_Id;
 235       Spec_Id : Entity_Id);
 236    --  Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
 237    --  Precondition, Refined_Post and Test_Case. Emit a warning when pragma
 238    --  Prag is associated with subprogram Spec_Id subject to Inline_Always.
 239 
 240    procedure Check_State_And_Constituent_Use
 241      (States   : Elist_Id;
 242       Constits : Elist_Id;
 243       Context  : Node_Id);
 244    --  Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
 245    --  Global and Initializes. Determine whether a state from list States and a
 246    --  corresponding constituent from list Constits (if any) appear in the same
 247    --  context denoted by Context. If this is the case, emit an error.
 248 
 249    procedure Contract_Freeze_Error
 250      (Contract_Id : Entity_Id;
 251       Freeze_Id   : Entity_Id);
 252    --  Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
 253    --  Pre. Emit a freezing-related error message where Freeze_Id is the entity
 254    --  of a body which caused contract "freezing" and Contract_Id denotes the
 255    --  entity of the affected contstruct.
 256 
 257    procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id);
 258    --  Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
 259    --  Prag that duplicates previous pragma Prev.
 260 
 261    function Find_Related_Context
 262      (Prag      : Node_Id;
 263       Do_Checks : Boolean := False) return Node_Id;
 264    --  Subsidiaty to the analysis of pragmas Async_Readers, Async_Writers,
 265    --  Constant_After_Elaboration, Effective_Reads, Effective_Writers and
 266    --  Part_Of. Find the first source declaration or statement found while
 267    --  traversing the previous node chain starting from pragma Prag. If flag
 268    --  Do_Checks is set, the routine reports duplicate pragmas. The routine
 269    --  returns Empty when reaching the start of the node chain.
 270 
 271    function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
 272    --  If Def_Id refers to a renamed subprogram, then the base subprogram (the
 273    --  original one, following the renaming chain) is returned. Otherwise the
 274    --  entity is returned unchanged. Should be in Einfo???
 275 
 276    function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
 277    --  Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
 278    --  Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
 279    --  value of type SPARK_Mode_Type.
 280 
 281    function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
 282    --  Subsidiary to the analysis of pragmas Depends and Refined_Depends.
 283    --  Determine whether dependency clause Clause is surrounded by extra
 284    --  parentheses. If this is the case, issue an error message.
 285 
 286    function Is_CCT_Instance
 287      (Ref_Id     : Entity_Id;
 288       Context_Id : Entity_Id) return Boolean;
 289    --  Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
 290    --  Global. Determine whether entity Ref_Id denotes the current instance of
 291    --  a concurrent type. Context_Id denotes the associated context where the
 292    --  pragma appears.
 293 
 294    function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
 295    --  Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
 296    --  pragma Depends. Determine whether the type of dependency item Item is
 297    --  tagged, unconstrained array, unconstrained record or a record with at
 298    --  least one unconstrained component.
 299 
 300    procedure Record_Possible_Body_Reference
 301      (State_Id : Entity_Id;
 302       Ref      : Node_Id);
 303    --  Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
 304    --  Global. Given an abstract state denoted by State_Id and a reference Ref
 305    --  to it, determine whether the reference appears in a package body that
 306    --  will eventually refine the state. If this is the case, record the
 307    --  reference for future checks (see Analyze_Refined_State_In_Decls).
 308 
 309    procedure Resolve_State (N : Node_Id);
 310    --  Handle the overloading of state names by functions. When N denotes a
 311    --  function, this routine finds the corresponding state and sets the entity
 312    --  of N to that of the state.
 313 
 314    procedure Rewrite_Assertion_Kind (N : Node_Id);
 315    --  If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
 316    --  then it is rewritten as an identifier with the corresponding special
 317    --  name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
 318    --  and Check_Policy.
 319 
 320    procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
 321    --  Place semantic information on the argument of an Elaborate/Elaborate_All
 322    --  pragma. Entity name for unit and its parents is taken from item in
 323    --  previous with_clause that mentions the unit.
 324 
 325    Dummy : Integer := 0;
 326    pragma Volatile (Dummy);
 327    --  Dummy volatile integer used in bodies of ip/rv to prevent optimization
 328 
 329    procedure ip;
 330    pragma No_Inline (ip);
 331    --  A dummy procedure called when pragma Inspection_Point is analyzed. This
 332    --  is just to help debugging the front end. If a pragma Inspection_Point
 333    --  is added to a source program, then breaking on ip will get you to that
 334    --  point in the program.
 335 
 336    procedure rv;
 337    pragma No_Inline (rv);
 338    --  This is a dummy function called by the processing for pragma Reviewable.
 339    --  It is there for assisting front end debugging. By placing a Reviewable
 340    --  pragma in the source program, a breakpoint on rv catches this place in
 341    --  the source, allowing convenient stepping to the point of interest.
 342 
 343    -------------------------------
 344    -- Adjust_External_Name_Case --
 345    -------------------------------
 346 
 347    function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
 348       CC : Char_Code;
 349 
 350    begin
 351       --  Adjust case of literal if required
 352 
 353       if Opt.External_Name_Exp_Casing = As_Is then
 354          return N;
 355 
 356       else
 357          --  Copy existing string
 358 
 359          Start_String;
 360 
 361          --  Set proper casing
 362 
 363          for J in 1 .. String_Length (Strval (N)) loop
 364             CC := Get_String_Char (Strval (N), J);
 365 
 366             if Opt.External_Name_Exp_Casing = Uppercase
 367               and then CC >= Get_Char_Code ('a')
 368               and then CC <= Get_Char_Code ('z')
 369             then
 370                Store_String_Char (CC - 32);
 371 
 372             elsif Opt.External_Name_Exp_Casing = Lowercase
 373               and then CC >= Get_Char_Code ('A')
 374               and then CC <= Get_Char_Code ('Z')
 375             then
 376                Store_String_Char (CC + 32);
 377 
 378             else
 379                Store_String_Char (CC);
 380             end if;
 381          end loop;
 382 
 383          return
 384            Make_String_Literal (Sloc (N),
 385              Strval => End_String);
 386       end if;
 387    end Adjust_External_Name_Case;
 388 
 389    -----------------------------------------
 390    -- Analyze_Contract_Cases_In_Decl_Part --
 391    -----------------------------------------
 392 
 393    procedure Analyze_Contract_Cases_In_Decl_Part
 394      (N         : Node_Id;
 395       Freeze_Id : Entity_Id := Empty)
 396    is
 397       Subp_Decl : constant Node_Id   := Find_Related_Declaration_Or_Body (N);
 398       Spec_Id   : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
 399 
 400       Others_Seen : Boolean := False;
 401       --  This flag is set when an "others" choice is encountered. It is used
 402       --  to detect multiple illegal occurrences of "others".
 403 
 404       procedure Analyze_Contract_Case (CCase : Node_Id);
 405       --  Verify the legality of a single contract case
 406 
 407       ---------------------------
 408       -- Analyze_Contract_Case --
 409       ---------------------------
 410 
 411       procedure Analyze_Contract_Case (CCase : Node_Id) is
 412          Case_Guard  : Node_Id;
 413          Conseq      : Node_Id;
 414          Errors      : Nat;
 415          Extra_Guard : Node_Id;
 416 
 417       begin
 418          if Nkind (CCase) = N_Component_Association then
 419             Case_Guard := First (Choices (CCase));
 420             Conseq     := Expression (CCase);
 421 
 422             --  Each contract case must have exactly one case guard
 423 
 424             Extra_Guard := Next (Case_Guard);
 425 
 426             if Present (Extra_Guard) then
 427                Error_Msg_N
 428                  ("contract case must have exactly one case guard",
 429                   Extra_Guard);
 430             end if;
 431 
 432             --  Check placement of OTHERS if available (SPARK RM 6.1.3(1))
 433 
 434             if Nkind (Case_Guard) = N_Others_Choice then
 435                if Others_Seen then
 436                   Error_Msg_N
 437                     ("only one others choice allowed in contract cases",
 438                      Case_Guard);
 439                else
 440                   Others_Seen := True;
 441                end if;
 442 
 443             elsif Others_Seen then
 444                Error_Msg_N
 445                  ("others must be the last choice in contract cases", N);
 446             end if;
 447 
 448             --  Preanalyze the case guard and consequence
 449 
 450             if Nkind (Case_Guard) /= N_Others_Choice then
 451                Errors := Serious_Errors_Detected;
 452                Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean);
 453 
 454                --  Emit a clarification message when the case guard contains
 455                --  at least one undefined reference, possibly due to contract
 456                --  "freezing".
 457 
 458                if Errors /= Serious_Errors_Detected
 459                  and then Present (Freeze_Id)
 460                  and then Has_Undefined_Reference (Case_Guard)
 461                then
 462                   Contract_Freeze_Error (Spec_Id, Freeze_Id);
 463                end if;
 464             end if;
 465 
 466             Errors := Serious_Errors_Detected;
 467             Preanalyze_Assert_Expression (Conseq, Standard_Boolean);
 468 
 469             --  Emit a clarification message when the consequence contains
 470             --  at least one undefined reference, possibly due to contract
 471             --  "freezing".
 472 
 473             if Errors /= Serious_Errors_Detected
 474               and then Present (Freeze_Id)
 475               and then Has_Undefined_Reference (Conseq)
 476             then
 477                Contract_Freeze_Error (Spec_Id, Freeze_Id);
 478             end if;
 479 
 480          --  The contract case is malformed
 481 
 482          else
 483             Error_Msg_N ("wrong syntax in contract case", CCase);
 484          end if;
 485       end Analyze_Contract_Case;
 486 
 487       --  Local variables
 488 
 489       CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
 490 
 491       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
 492 
 493       CCase         : Node_Id;
 494       Restore_Scope : Boolean := False;
 495 
 496    --  Start of processing for Analyze_Contract_Cases_In_Decl_Part
 497 
 498    begin
 499       --  Do not analyze the pragma multiple times
 500 
 501       if Is_Analyzed_Pragma (N) then
 502          return;
 503       end if;
 504 
 505       --  Set the Ghost mode in effect from the pragma. Due to the delayed
 506       --  analysis of the pragma, the Ghost mode at point of declaration and
 507       --  point of analysis may not necessarily be the same. Use the mode in
 508       --  effect at the point of declaration.
 509 
 510       Set_Ghost_Mode (N);
 511 
 512       --  Single and multiple contract cases must appear in aggregate form. If
 513       --  this is not the case, then either the parser of the analysis of the
 514       --  pragma failed to produce an aggregate.
 515 
 516       pragma Assert (Nkind (CCases) = N_Aggregate);
 517 
 518       if Present (Component_Associations (CCases)) then
 519 
 520          --  Ensure that the formal parameters are visible when analyzing all
 521          --  clauses. This falls out of the general rule of aspects pertaining
 522          --  to subprogram declarations.
 523 
 524          if not In_Open_Scopes (Spec_Id) then
 525             Restore_Scope := True;
 526             Push_Scope (Spec_Id);
 527 
 528             if Is_Generic_Subprogram (Spec_Id) then
 529                Install_Generic_Formals (Spec_Id);
 530             else
 531                Install_Formals (Spec_Id);
 532             end if;
 533          end if;
 534 
 535          CCase := First (Component_Associations (CCases));
 536          while Present (CCase) loop
 537             Analyze_Contract_Case (CCase);
 538             Next (CCase);
 539          end loop;
 540 
 541          if Restore_Scope then
 542             End_Scope;
 543          end if;
 544 
 545          --  Currently it is not possible to inline pre/postconditions on a
 546          --  subprogram subject to pragma Inline_Always.
 547 
 548          Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
 549 
 550       --  Otherwise the pragma is illegal
 551 
 552       else
 553          Error_Msg_N ("wrong syntax for constract cases", N);
 554       end if;
 555 
 556       Ghost_Mode := Save_Ghost_Mode;
 557       Set_Is_Analyzed_Pragma (N);
 558    end Analyze_Contract_Cases_In_Decl_Part;
 559 
 560    ----------------------------------
 561    -- Analyze_Depends_In_Decl_Part --
 562    ----------------------------------
 563 
 564    procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is
 565       Loc       : constant Source_Ptr := Sloc (N);
 566       Subp_Decl : constant Node_Id    := Find_Related_Declaration_Or_Body (N);
 567       Spec_Id   : constant Entity_Id  := Unique_Defining_Entity (Subp_Decl);
 568 
 569       All_Inputs_Seen : Elist_Id := No_Elist;
 570       --  A list containing the entities of all the inputs processed so far.
 571       --  The list is populated with unique entities because the same input
 572       --  may appear in multiple input lists.
 573 
 574       All_Outputs_Seen : Elist_Id := No_Elist;
 575       --  A list containing the entities of all the outputs processed so far.
 576       --  The list is populated with unique entities because output items are
 577       --  unique in a dependence relation.
 578 
 579       Constits_Seen : Elist_Id := No_Elist;
 580       --  A list containing the entities of all constituents processed so far.
 581       --  It aids in detecting illegal usage of a state and a corresponding
 582       --  constituent in pragma [Refinde_]Depends.
 583 
 584       Global_Seen : Boolean := False;
 585       --  A flag set when pragma Global has been processed
 586 
 587       Null_Output_Seen : Boolean := False;
 588       --  A flag used to track the legality of a null output
 589 
 590       Result_Seen : Boolean := False;
 591       --  A flag set when Spec_Id'Result is processed
 592 
 593       States_Seen : Elist_Id := No_Elist;
 594       --  A list containing the entities of all states processed so far. It
 595       --  helps in detecting illegal usage of a state and a corresponding
 596       --  constituent in pragma [Refined_]Depends.
 597 
 598       Subp_Inputs  : Elist_Id := No_Elist;
 599       Subp_Outputs : Elist_Id := No_Elist;
 600       --  Two lists containing the full set of inputs and output of the related
 601       --  subprograms. Note that these lists contain both nodes and entities.
 602 
 603       Task_Input_Seen  : Boolean := False;
 604       Task_Output_Seen : Boolean := False;
 605       --  Flags used to track the implicit dependence of a task unit on itself
 606 
 607       procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
 608       --  Subsidiary routine to Check_Role and Check_Usage. Add the item kind
 609       --  to the name buffer. The individual kinds are as follows:
 610       --    E_Abstract_State           - "state"
 611       --    E_Constant                 - "constant"
 612       --    E_Discriminant             - "discriminant"
 613       --    E_Generic_In_Out_Parameter - "generic parameter"
 614       --    E_Generic_In_Parameter     - "generic parameter"
 615       --    E_In_Parameter             - "parameter"
 616       --    E_In_Out_Parameter         - "parameter"
 617       --    E_Loop_Parameter           - "loop parameter"
 618       --    E_Out_Parameter            - "parameter"
 619       --    E_Protected_Type           - "current instance of protected type"
 620       --    E_Task_Type                - "current instance of task type"
 621       --    E_Variable                 - "global"
 622 
 623       procedure Analyze_Dependency_Clause
 624         (Clause  : Node_Id;
 625          Is_Last : Boolean);
 626       --  Verify the legality of a single dependency clause. Flag Is_Last
 627       --  denotes whether Clause is the last clause in the relation.
 628 
 629       procedure Check_Function_Return;
 630       --  Verify that Funtion'Result appears as one of the outputs
 631       --  (SPARK RM 6.1.5(10)).
 632 
 633       procedure Check_Role
 634         (Item     : Node_Id;
 635          Item_Id  : Entity_Id;
 636          Is_Input : Boolean;
 637          Self_Ref : Boolean);
 638       --  Ensure that an item fulfills its designated input and/or output role
 639       --  as specified by pragma Global (if any) or the enclosing context. If
 640       --  this is not the case, emit an error. Item and Item_Id denote the
 641       --  attributes of an item. Flag Is_Input should be set when item comes
 642       --  from an input list. Flag Self_Ref should be set when the item is an
 643       --  output and the dependency clause has operator "+".
 644 
 645       procedure Check_Usage
 646         (Subp_Items : Elist_Id;
 647          Used_Items : Elist_Id;
 648          Is_Input   : Boolean);
 649       --  Verify that all items from Subp_Items appear in Used_Items. Emit an
 650       --  error if this is not the case.
 651 
 652       procedure Normalize_Clause (Clause : Node_Id);
 653       --  Remove a self-dependency "+" from the input list of a clause
 654 
 655       -----------------------------
 656       -- Add_Item_To_Name_Buffer --
 657       -----------------------------
 658 
 659       procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is
 660       begin
 661          if Ekind (Item_Id) = E_Abstract_State then
 662             Add_Str_To_Name_Buffer ("state");
 663 
 664          elsif Ekind (Item_Id) = E_Constant then
 665             Add_Str_To_Name_Buffer ("constant");
 666 
 667          elsif Ekind (Item_Id) = E_Discriminant then
 668             Add_Str_To_Name_Buffer ("discriminant");
 669 
 670          elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
 671                                   E_Generic_In_Parameter)
 672          then
 673             Add_Str_To_Name_Buffer ("generic parameter");
 674 
 675          elsif Is_Formal (Item_Id) then
 676             Add_Str_To_Name_Buffer ("parameter");
 677 
 678          elsif Ekind (Item_Id) = E_Loop_Parameter then
 679             Add_Str_To_Name_Buffer ("loop parameter");
 680 
 681          elsif Ekind (Item_Id) = E_Protected_Type
 682            or else Is_Single_Protected_Object (Item_Id)
 683          then
 684             Add_Str_To_Name_Buffer ("current instance of protected type");
 685 
 686          elsif Ekind (Item_Id) = E_Task_Type
 687            or else Is_Single_Task_Object (Item_Id)
 688          then
 689             Add_Str_To_Name_Buffer ("current instance of task type");
 690 
 691          elsif Ekind (Item_Id) = E_Variable then
 692             Add_Str_To_Name_Buffer ("global");
 693 
 694          --  The routine should not be called with non-SPARK items
 695 
 696          else
 697             raise Program_Error;
 698          end if;
 699       end Add_Item_To_Name_Buffer;
 700 
 701       -------------------------------
 702       -- Analyze_Dependency_Clause --
 703       -------------------------------
 704 
 705       procedure Analyze_Dependency_Clause
 706         (Clause  : Node_Id;
 707          Is_Last : Boolean)
 708       is
 709          procedure Analyze_Input_List (Inputs : Node_Id);
 710          --  Verify the legality of a single input list
 711 
 712          procedure Analyze_Input_Output
 713            (Item          : Node_Id;
 714             Is_Input      : Boolean;
 715             Self_Ref      : Boolean;
 716             Top_Level     : Boolean;
 717             Seen          : in out Elist_Id;
 718             Null_Seen     : in out Boolean;
 719             Non_Null_Seen : in out Boolean);
 720          --  Verify the legality of a single input or output item. Flag
 721          --  Is_Input should be set whenever Item is an input, False when it
 722          --  denotes an output. Flag Self_Ref should be set when the item is an
 723          --  output and the dependency clause has a "+". Flag Top_Level should
 724          --  be set whenever Item appears immediately within an input or output
 725          --  list. Seen is a collection of all abstract states, objects and
 726          --  formals processed so far. Flag Null_Seen denotes whether a null
 727          --  input or output has been encountered. Flag Non_Null_Seen denotes
 728          --  whether a non-null input or output has been encountered.
 729 
 730          ------------------------
 731          -- Analyze_Input_List --
 732          ------------------------
 733 
 734          procedure Analyze_Input_List (Inputs : Node_Id) is
 735             Inputs_Seen : Elist_Id := No_Elist;
 736             --  A list containing the entities of all inputs that appear in the
 737             --  current input list.
 738 
 739             Non_Null_Input_Seen : Boolean := False;
 740             Null_Input_Seen     : Boolean := False;
 741             --  Flags used to check the legality of an input list
 742 
 743             Input : Node_Id;
 744 
 745          begin
 746             --  Multiple inputs appear as an aggregate
 747 
 748             if Nkind (Inputs) = N_Aggregate then
 749                if Present (Component_Associations (Inputs)) then
 750                   SPARK_Msg_N
 751                     ("nested dependency relations not allowed", Inputs);
 752 
 753                elsif Present (Expressions (Inputs)) then
 754                   Input := First (Expressions (Inputs));
 755                   while Present (Input) loop
 756                      Analyze_Input_Output
 757                        (Item          => Input,
 758                         Is_Input      => True,
 759                         Self_Ref      => False,
 760                         Top_Level     => False,
 761                         Seen          => Inputs_Seen,
 762                         Null_Seen     => Null_Input_Seen,
 763                         Non_Null_Seen => Non_Null_Input_Seen);
 764 
 765                      Next (Input);
 766                   end loop;
 767 
 768                --  Syntax error, always report
 769 
 770                else
 771                   Error_Msg_N ("malformed input dependency list", Inputs);
 772                end if;
 773 
 774             --  Process a solitary input
 775 
 776             else
 777                Analyze_Input_Output
 778                  (Item          => Inputs,
 779                   Is_Input      => True,
 780                   Self_Ref      => False,
 781                   Top_Level     => False,
 782                   Seen          => Inputs_Seen,
 783                   Null_Seen     => Null_Input_Seen,
 784                   Non_Null_Seen => Non_Null_Input_Seen);
 785             end if;
 786 
 787             --  Detect an illegal dependency clause of the form
 788 
 789             --    (null =>[+] null)
 790 
 791             if Null_Output_Seen and then Null_Input_Seen then
 792                SPARK_Msg_N
 793                  ("null dependency clause cannot have a null input list",
 794                   Inputs);
 795             end if;
 796          end Analyze_Input_List;
 797 
 798          --------------------------
 799          -- Analyze_Input_Output --
 800          --------------------------
 801 
 802          procedure Analyze_Input_Output
 803            (Item          : Node_Id;
 804             Is_Input      : Boolean;
 805             Self_Ref      : Boolean;
 806             Top_Level     : Boolean;
 807             Seen          : in out Elist_Id;
 808             Null_Seen     : in out Boolean;
 809             Non_Null_Seen : in out Boolean)
 810          is
 811             procedure Current_Task_Instance_Seen;
 812             --  Set the appropriate global flag when the current instance of a
 813             --  task unit is encountered.
 814 
 815             --------------------------------
 816             -- Current_Task_Instance_Seen --
 817             --------------------------------
 818 
 819             procedure Current_Task_Instance_Seen is
 820             begin
 821                if Is_Input then
 822                   Task_Input_Seen := True;
 823                else
 824                   Task_Output_Seen := True;
 825                end if;
 826             end Current_Task_Instance_Seen;
 827 
 828             --  Local variables
 829 
 830             Is_Output : constant Boolean := not Is_Input;
 831             Grouped   : Node_Id;
 832             Item_Id   : Entity_Id;
 833 
 834          --  Start of processing for Analyze_Input_Output
 835 
 836          begin
 837             --  Multiple input or output items appear as an aggregate
 838 
 839             if Nkind (Item) = N_Aggregate then
 840                if not Top_Level then
 841                   SPARK_Msg_N ("nested grouping of items not allowed", Item);
 842 
 843                elsif Present (Component_Associations (Item)) then
 844                   SPARK_Msg_N
 845                     ("nested dependency relations not allowed", Item);
 846 
 847                --  Recursively analyze the grouped items
 848 
 849                elsif Present (Expressions (Item)) then
 850                   Grouped := First (Expressions (Item));
 851                   while Present (Grouped) loop
 852                      Analyze_Input_Output
 853                        (Item          => Grouped,
 854                         Is_Input      => Is_Input,
 855                         Self_Ref      => Self_Ref,
 856                         Top_Level     => False,
 857                         Seen          => Seen,
 858                         Null_Seen     => Null_Seen,
 859                         Non_Null_Seen => Non_Null_Seen);
 860 
 861                      Next (Grouped);
 862                   end loop;
 863 
 864                --  Syntax error, always report
 865 
 866                else
 867                   Error_Msg_N ("malformed dependency list", Item);
 868                end if;
 869 
 870             --  Process attribute 'Result in the context of a dependency clause
 871 
 872             elsif Is_Attribute_Result (Item) then
 873                Non_Null_Seen := True;
 874 
 875                Analyze (Item);
 876 
 877                --  Attribute 'Result is allowed to appear on the output side of
 878                --  a dependency clause (SPARK RM 6.1.5(6)).
 879 
 880                if Is_Input then
 881                   SPARK_Msg_N ("function result cannot act as input", Item);
 882 
 883                elsif Null_Seen then
 884                   SPARK_Msg_N
 885                     ("cannot mix null and non-null dependency items", Item);
 886 
 887                else
 888                   Result_Seen := True;
 889                end if;
 890 
 891             --  Detect multiple uses of null in a single dependency list or
 892             --  throughout the whole relation. Verify the placement of a null
 893             --  output list relative to the other clauses (SPARK RM 6.1.5(12)).
 894 
 895             elsif Nkind (Item) = N_Null then
 896                if Null_Seen then
 897                   SPARK_Msg_N
 898                     ("multiple null dependency relations not allowed", Item);
 899 
 900                elsif Non_Null_Seen then
 901                   SPARK_Msg_N
 902                     ("cannot mix null and non-null dependency items", Item);
 903 
 904                else
 905                   Null_Seen := True;
 906 
 907                   if Is_Output then
 908                      if not Is_Last then
 909                         SPARK_Msg_N
 910                           ("null output list must be the last clause in a "
 911                            & "dependency relation", Item);
 912 
 913                      --  Catch a useless dependence of the form:
 914                      --    null =>+ ...
 915 
 916                      elsif Self_Ref then
 917                         SPARK_Msg_N
 918                           ("useless dependence, null depends on itself", Item);
 919                      end if;
 920                   end if;
 921                end if;
 922 
 923             --  Default case
 924 
 925             else
 926                Non_Null_Seen := True;
 927 
 928                if Null_Seen then
 929                   SPARK_Msg_N ("cannot mix null and non-null items", Item);
 930                end if;
 931 
 932                Analyze       (Item);
 933                Resolve_State (Item);
 934 
 935                --  Find the entity of the item. If this is a renaming, climb
 936                --  the renaming chain to reach the root object. Renamings of
 937                --  non-entire objects do not yield an entity (Empty).
 938 
 939                Item_Id := Entity_Of (Item);
 940 
 941                if Present (Item_Id) then
 942 
 943                   --  Constants
 944 
 945                   if Ekind_In (Item_Id, E_Constant,
 946                                         E_Discriminant,
 947                                         E_Loop_Parameter)
 948                       or else
 949 
 950                     --  Current instances of concurrent types
 951 
 952                     Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
 953                       or else
 954 
 955                     --  Formal parameters
 956 
 957                     Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
 958                                        E_Generic_In_Parameter,
 959                                        E_In_Parameter,
 960                                        E_In_Out_Parameter,
 961                                        E_Out_Parameter)
 962                       or else
 963 
 964                     --  States, variables
 965 
 966                     Ekind_In (Item_Id, E_Abstract_State, E_Variable)
 967                   then
 968                      --  The item denotes a concurrent type. Note that single
 969                      --  protected/task types are not considered here because
 970                      --  they behave as objects in the context of pragma
 971                      --  [Refined_]Depends.
 972 
 973                      if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
 974 
 975                         --  This use is legal as long as the concurrent type is
 976                         --  the current instance of an enclosing type.
 977 
 978                         if Is_CCT_Instance (Item_Id, Spec_Id) then
 979 
 980                            --  The dependence of a task unit on itself is
 981                            --  implicit and may or may not be explicitly
 982                            --  specified (SPARK RM 6.1.4).
 983 
 984                            if Ekind (Item_Id) = E_Task_Type then
 985                               Current_Task_Instance_Seen;
 986                            end if;
 987 
 988                         --  Otherwise this is not the current instance
 989 
 990                         else
 991                            SPARK_Msg_N
 992                              ("invalid use of subtype mark in dependency "
 993                               & "relation", Item);
 994                         end if;
 995 
 996                      --  The dependency of a task unit on itself is implicit
 997                      --  and may or may not be explicitly specified
 998                      --  (SPARK RM 6.1.4).
 999 
1000                      elsif Is_Single_Task_Object (Item_Id)
1001                        and then Is_CCT_Instance (Item_Id, Spec_Id)
1002                      then
1003                         Current_Task_Instance_Seen;
1004                      end if;
1005 
1006                      --  Ensure that the item fulfills its role as input and/or
1007                      --  output as specified by pragma Global or the enclosing
1008                      --  context.
1009 
1010                      Check_Role (Item, Item_Id, Is_Input, Self_Ref);
1011 
1012                      --  Detect multiple uses of the same state, variable or
1013                      --  formal parameter. If this is not the case, add the
1014                      --  item to the list of processed relations.
1015 
1016                      if Contains (Seen, Item_Id) then
1017                         SPARK_Msg_NE
1018                           ("duplicate use of item &", Item, Item_Id);
1019                      else
1020                         Append_New_Elmt (Item_Id, Seen);
1021                      end if;
1022 
1023                      --  Detect illegal use of an input related to a null
1024                      --  output. Such input items cannot appear in other
1025                      --  input lists (SPARK RM 6.1.5(13)).
1026 
1027                      if Is_Input
1028                        and then Null_Output_Seen
1029                        and then Contains (All_Inputs_Seen, Item_Id)
1030                      then
1031                         SPARK_Msg_N
1032                           ("input of a null output list cannot appear in "
1033                            & "multiple input lists", Item);
1034                      end if;
1035 
1036                      --  Add an input or a self-referential output to the list
1037                      --  of all processed inputs.
1038 
1039                      if Is_Input or else Self_Ref then
1040                         Append_New_Elmt (Item_Id, All_Inputs_Seen);
1041                      end if;
1042 
1043                      --  State related checks (SPARK RM 6.1.5(3))
1044 
1045                      if Ekind (Item_Id) = E_Abstract_State then
1046 
1047                         --  Package and subprogram bodies are instantiated
1048                         --  individually in a separate compiler pass. Due to
1049                         --  this mode of instantiation, the refinement of a
1050                         --  state may no longer be visible when a subprogram
1051                         --  body contract is instantiated. Since the generic
1052                         --  template is legal, do not perform this check in
1053                         --  the instance to circumvent this oddity.
1054 
1055                         if Is_Generic_Instance (Spec_Id) then
1056                            null;
1057 
1058                         --  An abstract state with visible refinement cannot
1059                         --  appear in pragma [Refined_]Depends as its place
1060                         --  must be taken by some of its constituents
1061                         --  (SPARK RM 6.1.4(7)).
1062 
1063                         elsif Has_Visible_Refinement (Item_Id) then
1064                            SPARK_Msg_NE
1065                              ("cannot mention state & in dependence relation",
1066                               Item, Item_Id);
1067                            SPARK_Msg_N ("\use its constituents instead", Item);
1068                            return;
1069 
1070                         --  If the reference to the abstract state appears in
1071                         --  an enclosing package body that will eventually
1072                         --  refine the state, record the reference for future
1073                         --  checks.
1074 
1075                         else
1076                            Record_Possible_Body_Reference
1077                              (State_Id => Item_Id,
1078                               Ref      => Item);
1079                         end if;
1080                      end if;
1081 
1082                      --  When the item renames an entire object, replace the
1083                      --  item with a reference to the object.
1084 
1085                      if Entity (Item) /= Item_Id then
1086                         Rewrite (Item,
1087                           New_Occurrence_Of (Item_Id, Sloc (Item)));
1088                         Analyze (Item);
1089                      end if;
1090 
1091                      --  Add the entity of the current item to the list of
1092                      --  processed items.
1093 
1094                      if Ekind (Item_Id) = E_Abstract_State then
1095                         Append_New_Elmt (Item_Id, States_Seen);
1096 
1097                      --  The variable may eventually become a constituent of a
1098                      --  single protected/task type. Record the reference now
1099                      --  and verify its legality when analyzing the contract of
1100                      --  the variable (SPARK RM 9.3).
1101 
1102                      elsif Ekind (Item_Id) = E_Variable then
1103                         Record_Possible_Part_Of_Reference
1104                           (Var_Id => Item_Id,
1105                            Ref    => Item);
1106                      end if;
1107 
1108                      if Ekind_In (Item_Id, E_Abstract_State,
1109                                            E_Constant,
1110                                            E_Variable)
1111                        and then Present (Encapsulating_State (Item_Id))
1112                      then
1113                         Append_New_Elmt (Item_Id, Constits_Seen);
1114                      end if;
1115 
1116                   --  All other input/output items are illegal
1117                   --  (SPARK RM 6.1.5(1)).
1118 
1119                   else
1120                      SPARK_Msg_N
1121                        ("item must denote parameter, variable, state or "
1122                         & "current instance of concurren type", Item);
1123                   end if;
1124 
1125                --  All other input/output items are illegal
1126                --  (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1127 
1128                else
1129                   Error_Msg_N
1130                     ("item must denote parameter, variable, state or current "
1131                      & "instance of concurrent type", Item);
1132                end if;
1133             end if;
1134          end Analyze_Input_Output;
1135 
1136          --  Local variables
1137 
1138          Inputs   : Node_Id;
1139          Output   : Node_Id;
1140          Self_Ref : Boolean;
1141 
1142          Non_Null_Output_Seen : Boolean := False;
1143          --  Flag used to check the legality of an output list
1144 
1145       --  Start of processing for Analyze_Dependency_Clause
1146 
1147       begin
1148          Inputs   := Expression (Clause);
1149          Self_Ref := False;
1150 
1151          --  An input list with a self-dependency appears as operator "+" where
1152          --  the actuals inputs are the right operand.
1153 
1154          if Nkind (Inputs) = N_Op_Plus then
1155             Inputs   := Right_Opnd (Inputs);
1156             Self_Ref := True;
1157          end if;
1158 
1159          --  Process the output_list of a dependency_clause
1160 
1161          Output := First (Choices (Clause));
1162          while Present (Output) loop
1163             Analyze_Input_Output
1164               (Item          => Output,
1165                Is_Input      => False,
1166                Self_Ref      => Self_Ref,
1167                Top_Level     => True,
1168                Seen          => All_Outputs_Seen,
1169                Null_Seen     => Null_Output_Seen,
1170                Non_Null_Seen => Non_Null_Output_Seen);
1171 
1172             Next (Output);
1173          end loop;
1174 
1175          --  Process the input_list of a dependency_clause
1176 
1177          Analyze_Input_List (Inputs);
1178       end Analyze_Dependency_Clause;
1179 
1180       ---------------------------
1181       -- Check_Function_Return --
1182       ---------------------------
1183 
1184       procedure Check_Function_Return is
1185       begin
1186          if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
1187            and then not Result_Seen
1188          then
1189             SPARK_Msg_NE
1190               ("result of & must appear in exactly one output list",
1191                N, Spec_Id);
1192          end if;
1193       end Check_Function_Return;
1194 
1195       ----------------
1196       -- Check_Role --
1197       ----------------
1198 
1199       procedure Check_Role
1200         (Item     : Node_Id;
1201          Item_Id  : Entity_Id;
1202          Is_Input : Boolean;
1203          Self_Ref : Boolean)
1204       is
1205          procedure Find_Role
1206            (Item_Is_Input  : out Boolean;
1207             Item_Is_Output : out Boolean);
1208          --  Find the input/output role of Item_Id. Flags Item_Is_Input and
1209          --  Item_Is_Output are set depending on the role.
1210 
1211          procedure Role_Error
1212            (Item_Is_Input  : Boolean;
1213             Item_Is_Output : Boolean);
1214          --  Emit an error message concerning the incorrect use of Item in
1215          --  pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1216          --  denote whether the item is an input and/or an output.
1217 
1218          ---------------
1219          -- Find_Role --
1220          ---------------
1221 
1222          procedure Find_Role
1223            (Item_Is_Input  : out Boolean;
1224             Item_Is_Output : out Boolean)
1225          is
1226          begin
1227             Item_Is_Input  := False;
1228             Item_Is_Output := False;
1229 
1230             --  Abstract states
1231 
1232             if Ekind (Item_Id) = E_Abstract_State then
1233 
1234                --  When pragma Global is present, the mode of the state may be
1235                --  further constrained by setting a more restrictive mode.
1236 
1237                if Global_Seen then
1238                   if Appears_In (Subp_Inputs, Item_Id) then
1239                      Item_Is_Input := True;
1240                   end if;
1241 
1242                   if Appears_In (Subp_Outputs, Item_Id) then
1243                      Item_Is_Output := True;
1244                   end if;
1245 
1246                --  Otherwise the state has a default IN OUT mode
1247 
1248                else
1249                   Item_Is_Input  := True;
1250                   Item_Is_Output := True;
1251                end if;
1252 
1253             --  Constants
1254 
1255             elsif Ekind_In (Item_Id, E_Constant,
1256                                      E_Discriminant,
1257                                      E_Loop_Parameter)
1258             then
1259                Item_Is_Input := True;
1260 
1261             --  Parameters
1262 
1263             elsif Ekind_In (Item_Id, E_Generic_In_Parameter,
1264                                      E_In_Parameter)
1265             then
1266                Item_Is_Input := True;
1267 
1268             elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
1269                                      E_In_Out_Parameter)
1270             then
1271                Item_Is_Input  := True;
1272                Item_Is_Output := True;
1273 
1274             elsif Ekind (Item_Id) = E_Out_Parameter then
1275                if Scope (Item_Id) = Spec_Id then
1276 
1277                   --  An OUT parameter of the related subprogram has mode IN
1278                   --  if its type is unconstrained or tagged because array
1279                   --  bounds, discriminants or tags can be read.
1280 
1281                   if Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1282                      Item_Is_Input := True;
1283                   end if;
1284 
1285                   Item_Is_Output := True;
1286 
1287                --  An OUT parameter of an enclosing subprogram behaves as a
1288                --  read-write variable in which case the mode is IN OUT.
1289 
1290                else
1291                   Item_Is_Input  := True;
1292                   Item_Is_Output := True;
1293                end if;
1294 
1295             --  Protected types
1296 
1297             elsif Ekind (Item_Id) = E_Protected_Type then
1298 
1299                --  A protected type acts as a formal parameter of mode IN when
1300                --  it applies to a protected function.
1301 
1302                if Ekind (Spec_Id) = E_Function then
1303                   Item_Is_Input := True;
1304 
1305                --  Otherwise the protected type acts as a formal of mode IN OUT
1306 
1307                else
1308                   Item_Is_Input  := True;
1309                   Item_Is_Output := True;
1310                end if;
1311 
1312             --  Task types
1313 
1314             elsif Ekind (Item_Id) = E_Task_Type then
1315                Item_Is_Input  := True;
1316                Item_Is_Output := True;
1317 
1318             --  Variable case
1319 
1320             else pragma Assert (Ekind (Item_Id) = E_Variable);
1321 
1322                --  When pragma Global is present, the mode of the variable may
1323                --  be further constrained by setting a more restrictive mode.
1324 
1325                if Global_Seen then
1326 
1327                   --  A variable has mode IN when its type is unconstrained or
1328                   --  tagged because array bounds, discriminants or tags can be
1329                   --  read.
1330 
1331                   if Appears_In (Subp_Inputs, Item_Id)
1332                     or else Is_Unconstrained_Or_Tagged_Item (Item_Id)
1333                   then
1334                      Item_Is_Input := True;
1335                   end if;
1336 
1337                   if Appears_In (Subp_Outputs, Item_Id) then
1338                      Item_Is_Output := True;
1339                   end if;
1340 
1341                --  Otherwise the variable has a default IN OUT mode
1342 
1343                else
1344                   Item_Is_Input  := True;
1345                   Item_Is_Output := True;
1346                end if;
1347             end if;
1348          end Find_Role;
1349 
1350          ----------------
1351          -- Role_Error --
1352          ----------------
1353 
1354          procedure Role_Error
1355            (Item_Is_Input  : Boolean;
1356             Item_Is_Output : Boolean)
1357          is
1358             Error_Msg : Name_Id;
1359 
1360          begin
1361             Name_Len := 0;
1362 
1363             --  When the item is not part of the input and the output set of
1364             --  the related subprogram, then it appears as extra in pragma
1365             --  [Refined_]Depends.
1366 
1367             if not Item_Is_Input and then not Item_Is_Output then
1368                Add_Item_To_Name_Buffer (Item_Id);
1369                Add_Str_To_Name_Buffer
1370                  (" & cannot appear in dependence relation");
1371 
1372                Error_Msg := Name_Find;
1373                SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1374 
1375                Error_Msg_Name_1 := Chars (Spec_Id);
1376                SPARK_Msg_NE
1377                  (Fix_Msg (Spec_Id, "\& is not part of the input or output "
1378                   & "set of subprogram %"), Item, Item_Id);
1379 
1380             --  The mode of the item and its role in pragma [Refined_]Depends
1381             --  are in conflict. Construct a detailed message explaining the
1382             --  illegality (SPARK RM 6.1.5(5-6)).
1383 
1384             else
1385                if Item_Is_Input then
1386                   Add_Str_To_Name_Buffer ("read-only");
1387                else
1388                   Add_Str_To_Name_Buffer ("write-only");
1389                end if;
1390 
1391                Add_Char_To_Name_Buffer (' ');
1392                Add_Item_To_Name_Buffer (Item_Id);
1393                Add_Str_To_Name_Buffer  (" & cannot appear as ");
1394 
1395                if Item_Is_Input then
1396                   Add_Str_To_Name_Buffer ("output");
1397                else
1398                   Add_Str_To_Name_Buffer ("input");
1399                end if;
1400 
1401                Add_Str_To_Name_Buffer (" in dependence relation");
1402                Error_Msg := Name_Find;
1403                SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id);
1404             end if;
1405          end Role_Error;
1406 
1407          --  Local variables
1408 
1409          Item_Is_Input  : Boolean;
1410          Item_Is_Output : Boolean;
1411 
1412       --  Start of processing for Check_Role
1413 
1414       begin
1415          Find_Role (Item_Is_Input, Item_Is_Output);
1416 
1417          --  Input item
1418 
1419          if Is_Input then
1420             if not Item_Is_Input then
1421                Role_Error (Item_Is_Input, Item_Is_Output);
1422             end if;
1423 
1424          --  Self-referential item
1425 
1426          elsif Self_Ref then
1427             if not Item_Is_Input or else not Item_Is_Output then
1428                Role_Error (Item_Is_Input, Item_Is_Output);
1429             end if;
1430 
1431          --  Output item
1432 
1433          elsif not Item_Is_Output then
1434             Role_Error (Item_Is_Input, Item_Is_Output);
1435          end if;
1436       end Check_Role;
1437 
1438       -----------------
1439       -- Check_Usage --
1440       -----------------
1441 
1442       procedure Check_Usage
1443         (Subp_Items : Elist_Id;
1444          Used_Items : Elist_Id;
1445          Is_Input   : Boolean)
1446       is
1447          procedure Usage_Error (Item_Id : Entity_Id);
1448          --  Emit an error concerning the illegal usage of an item
1449 
1450          -----------------
1451          -- Usage_Error --
1452          -----------------
1453 
1454          procedure Usage_Error (Item_Id : Entity_Id) is
1455             Error_Msg : Name_Id;
1456 
1457          begin
1458             --  Input case
1459 
1460             if Is_Input then
1461 
1462                --  Unconstrained and tagged items are not part of the explicit
1463                --  input set of the related subprogram, they do not have to be
1464                --  present in a dependence relation and should not be flagged
1465                --  (SPARK RM 6.1.5(8)).
1466 
1467                if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
1468                   Name_Len := 0;
1469 
1470                   Add_Item_To_Name_Buffer (Item_Id);
1471                   Add_Str_To_Name_Buffer
1472                     (" & is missing from input dependence list");
1473 
1474                   Error_Msg := Name_Find;
1475                   SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1476                end if;
1477 
1478             --  Output case (SPARK RM 6.1.5(10))
1479 
1480             else
1481                Name_Len := 0;
1482 
1483                Add_Item_To_Name_Buffer (Item_Id);
1484                Add_Str_To_Name_Buffer
1485                  (" & is missing from output dependence list");
1486 
1487                Error_Msg := Name_Find;
1488                SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id);
1489             end if;
1490          end Usage_Error;
1491 
1492          --  Local variables
1493 
1494          Elmt    : Elmt_Id;
1495          Item    : Node_Id;
1496          Item_Id : Entity_Id;
1497 
1498       --  Start of processing for Check_Usage
1499 
1500       begin
1501          if No (Subp_Items) then
1502             return;
1503          end if;
1504 
1505          --  Each input or output of the subprogram must appear in a dependency
1506          --  relation.
1507 
1508          Elmt := First_Elmt (Subp_Items);
1509          while Present (Elmt) loop
1510             Item := Node (Elmt);
1511 
1512             if Nkind (Item) = N_Defining_Identifier then
1513                Item_Id := Item;
1514             else
1515                Item_Id := Entity_Of (Item);
1516             end if;
1517 
1518             --  The item does not appear in a dependency
1519 
1520             if Present (Item_Id)
1521               and then not Contains (Used_Items, Item_Id)
1522             then
1523                if Is_Formal (Item_Id) then
1524                   Usage_Error (Item_Id);
1525 
1526                --  The current instance of a protected type behaves as a formal
1527                --  parameter (SPARK RM 6.1.4).
1528 
1529                elsif Ekind (Item_Id) = E_Protected_Type
1530                  or else Is_Single_Protected_Object (Item_Id)
1531                then
1532                   Usage_Error (Item_Id);
1533 
1534                --  The current instance of a task type behaves as a formal
1535                --  parameter (SPARK RM 6.1.4).
1536 
1537                elsif Ekind (Item_Id) = E_Task_Type
1538                  or else Is_Single_Task_Object (Item_Id)
1539                then
1540                   --  The dependence of a task unit on itself is implicit and
1541                   --  may or may not be explicitly specified (SPARK RM 6.1.4).
1542                   --  Emit an error if only one input/output is present.
1543 
1544                   if Task_Input_Seen /= Task_Output_Seen then
1545                      Usage_Error (Item_Id);
1546                   end if;
1547 
1548                --  States and global objects are not used properly only when
1549                --  the subprogram is subject to pragma Global.
1550 
1551                elsif Global_Seen then
1552                   Usage_Error (Item_Id);
1553                end if;
1554             end if;
1555 
1556             Next_Elmt (Elmt);
1557          end loop;
1558       end Check_Usage;
1559 
1560       ----------------------
1561       -- Normalize_Clause --
1562       ----------------------
1563 
1564       procedure Normalize_Clause (Clause : Node_Id) is
1565          procedure Create_Or_Modify_Clause
1566            (Output   : Node_Id;
1567             Outputs  : Node_Id;
1568             Inputs   : Node_Id;
1569             After    : Node_Id;
1570             In_Place : Boolean;
1571             Multiple : Boolean);
1572          --  Create a brand new clause to represent the self-reference or
1573          --  modify the input and/or output lists of an existing clause. Output
1574          --  denotes a self-referencial output. Outputs is the output list of a
1575          --  clause. Inputs is the input list of a clause. After denotes the
1576          --  clause after which the new clause is to be inserted. Flag In_Place
1577          --  should be set when normalizing the last output of an output list.
1578          --  Flag Multiple should be set when Output comes from a list with
1579          --  multiple items.
1580 
1581          -----------------------------
1582          -- Create_Or_Modify_Clause --
1583          -----------------------------
1584 
1585          procedure Create_Or_Modify_Clause
1586            (Output   : Node_Id;
1587             Outputs  : Node_Id;
1588             Inputs   : Node_Id;
1589             After    : Node_Id;
1590             In_Place : Boolean;
1591             Multiple : Boolean)
1592          is
1593             procedure Propagate_Output
1594               (Output : Node_Id;
1595                Inputs : Node_Id);
1596             --  Handle the various cases of output propagation to the input
1597             --  list. Output denotes a self-referencial output item. Inputs
1598             --  is the input list of a clause.
1599 
1600             ----------------------
1601             -- Propagate_Output --
1602             ----------------------
1603 
1604             procedure Propagate_Output
1605               (Output : Node_Id;
1606                Inputs : Node_Id)
1607             is
1608                function In_Input_List
1609                  (Item   : Entity_Id;
1610                   Inputs : List_Id) return Boolean;
1611                --  Determine whether a particulat item appears in the input
1612                --  list of a clause.
1613 
1614                -------------------
1615                -- In_Input_List --
1616                -------------------
1617 
1618                function In_Input_List
1619                  (Item   : Entity_Id;
1620                   Inputs : List_Id) return Boolean
1621                is
1622                   Elmt : Node_Id;
1623 
1624                begin
1625                   Elmt := First (Inputs);
1626                   while Present (Elmt) loop
1627                      if Entity_Of (Elmt) = Item then
1628                         return True;
1629                      end if;
1630 
1631                      Next (Elmt);
1632                   end loop;
1633 
1634                   return False;
1635                end In_Input_List;
1636 
1637                --  Local variables
1638 
1639                Output_Id : constant Entity_Id := Entity_Of (Output);
1640                Grouped   : List_Id;
1641 
1642             --  Start of processing for Propagate_Output
1643 
1644             begin
1645                --  The clause is of the form:
1646 
1647                --    (Output =>+ null)
1648 
1649                --  Remove null input and replace it with a copy of the output:
1650 
1651                --    (Output => Output)
1652 
1653                if Nkind (Inputs) = N_Null then
1654                   Rewrite (Inputs, New_Copy_Tree (Output));
1655 
1656                --  The clause is of the form:
1657 
1658                --    (Output =>+ (Input1, ..., InputN))
1659 
1660                --  Determine whether the output is not already mentioned in the
1661                --  input list and if not, add it to the list of inputs:
1662 
1663                --    (Output => (Output, Input1, ..., InputN))
1664 
1665                elsif Nkind (Inputs) = N_Aggregate then
1666                   Grouped := Expressions (Inputs);
1667 
1668                   if not In_Input_List
1669                            (Item   => Output_Id,
1670                             Inputs => Grouped)
1671                   then
1672                      Prepend_To (Grouped, New_Copy_Tree (Output));
1673                   end if;
1674 
1675                --  The clause is of the form:
1676 
1677                --    (Output =>+ Input)
1678 
1679                --  If the input does not mention the output, group the two
1680                --  together:
1681 
1682                --    (Output => (Output, Input))
1683 
1684                elsif Entity_Of (Inputs) /= Output_Id then
1685                   Rewrite (Inputs,
1686                     Make_Aggregate (Loc,
1687                       Expressions => New_List (
1688                         New_Copy_Tree (Output),
1689                         New_Copy_Tree (Inputs))));
1690                end if;
1691             end Propagate_Output;
1692 
1693             --  Local variables
1694 
1695             Loc        : constant Source_Ptr := Sloc (Clause);
1696             New_Clause : Node_Id;
1697 
1698          --  Start of processing for Create_Or_Modify_Clause
1699 
1700          begin
1701             --  A null output depending on itself does not require any
1702             --  normalization.
1703 
1704             if Nkind (Output) = N_Null then
1705                return;
1706 
1707             --  A function result cannot depend on itself because it cannot
1708             --  appear in the input list of a relation (SPARK RM 6.1.5(10)).
1709 
1710             elsif Is_Attribute_Result (Output) then
1711                SPARK_Msg_N ("function result cannot depend on itself", Output);
1712                return;
1713             end if;
1714 
1715             --  When performing the transformation in place, simply add the
1716             --  output to the list of inputs (if not already there). This
1717             --  case arises when dealing with the last output of an output
1718             --  list. Perform the normalization in place to avoid generating
1719             --  a malformed tree.
1720 
1721             if In_Place then
1722                Propagate_Output (Output, Inputs);
1723 
1724                --  A list with multiple outputs is slowly trimmed until only
1725                --  one element remains. When this happens, replace aggregate
1726                --  with the element itself.
1727 
1728                if Multiple then
1729                   Remove  (Output);
1730                   Rewrite (Outputs, Output);
1731                end if;
1732 
1733             --  Default case
1734 
1735             else
1736                --  Unchain the output from its output list as it will appear in
1737                --  a new clause. Note that we cannot simply rewrite the output
1738                --  as null because this will violate the semantics of pragma
1739                --  Depends.
1740 
1741                Remove (Output);
1742 
1743                --  Generate a new clause of the form:
1744                --    (Output => Inputs)
1745 
1746                New_Clause :=
1747                  Make_Component_Association (Loc,
1748                    Choices    => New_List (Output),
1749                    Expression => New_Copy_Tree (Inputs));
1750 
1751                --  The new clause contains replicated content that has already
1752                --  been analyzed. There is not need to reanalyze or renormalize
1753                --  it again.
1754 
1755                Set_Analyzed (New_Clause);
1756 
1757                Propagate_Output
1758                  (Output => First (Choices (New_Clause)),
1759                   Inputs => Expression (New_Clause));
1760 
1761                Insert_After (After, New_Clause);
1762             end if;
1763          end Create_Or_Modify_Clause;
1764 
1765          --  Local variables
1766 
1767          Outputs     : constant Node_Id := First (Choices (Clause));
1768          Inputs      : Node_Id;
1769          Last_Output : Node_Id;
1770          Next_Output : Node_Id;
1771          Output      : Node_Id;
1772 
1773       --  Start of processing for Normalize_Clause
1774 
1775       begin
1776          --  A self-dependency appears as operator "+". Remove the "+" from the
1777          --  tree by moving the real inputs to their proper place.
1778 
1779          if Nkind (Expression (Clause)) = N_Op_Plus then
1780             Rewrite (Expression (Clause), Right_Opnd (Expression (Clause)));
1781             Inputs := Expression (Clause);
1782 
1783             --  Multiple outputs appear as an aggregate
1784 
1785             if Nkind (Outputs) = N_Aggregate then
1786                Last_Output := Last (Expressions (Outputs));
1787 
1788                Output := First (Expressions (Outputs));
1789                while Present (Output) loop
1790 
1791                   --  Normalization may remove an output from its list,
1792                   --  preserve the subsequent output now.
1793 
1794                   Next_Output := Next (Output);
1795 
1796                   Create_Or_Modify_Clause
1797                     (Output   => Output,
1798                      Outputs  => Outputs,
1799                      Inputs   => Inputs,
1800                      After    => Clause,
1801                      In_Place => Output = Last_Output,
1802                      Multiple => True);
1803 
1804                   Output := Next_Output;
1805                end loop;
1806 
1807             --  Solitary output
1808 
1809             else
1810                Create_Or_Modify_Clause
1811                  (Output   => Outputs,
1812                   Outputs  => Empty,
1813                   Inputs   => Inputs,
1814                   After    => Empty,
1815                   In_Place => True,
1816                   Multiple => False);
1817             end if;
1818          end if;
1819       end Normalize_Clause;
1820 
1821       --  Local variables
1822 
1823       Deps    : constant Node_Id   := Expression (Get_Argument (N, Spec_Id));
1824       Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
1825 
1826       Clause        : Node_Id;
1827       Errors        : Nat;
1828       Last_Clause   : Node_Id;
1829       Restore_Scope : Boolean := False;
1830 
1831    --  Start of processing for Analyze_Depends_In_Decl_Part
1832 
1833    begin
1834       --  Do not analyze the pragma multiple times
1835 
1836       if Is_Analyzed_Pragma (N) then
1837          return;
1838       end if;
1839 
1840       --  Empty dependency list
1841 
1842       if Nkind (Deps) = N_Null then
1843 
1844          --  Gather all states, objects and formal parameters that the
1845          --  subprogram may depend on. These items are obtained from the
1846          --  parameter profile or pragma [Refined_]Global (if available).
1847 
1848          Collect_Subprogram_Inputs_Outputs
1849            (Subp_Id      => Subp_Id,
1850             Subp_Inputs  => Subp_Inputs,
1851             Subp_Outputs => Subp_Outputs,
1852             Global_Seen  => Global_Seen);
1853 
1854          --  Verify that every input or output of the subprogram appear in a
1855          --  dependency.
1856 
1857          Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1858          Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1859          Check_Function_Return;
1860 
1861       --  Dependency clauses appear as component associations of an aggregate
1862 
1863       elsif Nkind (Deps) = N_Aggregate then
1864 
1865          --  Do not attempt to perform analysis of a syntactically illegal
1866          --  clause as this will lead to misleading errors.
1867 
1868          if Has_Extra_Parentheses (Deps) then
1869             return;
1870          end if;
1871 
1872          if Present (Component_Associations (Deps)) then
1873             Last_Clause := Last (Component_Associations (Deps));
1874 
1875             --  Gather all states, objects and formal parameters that the
1876             --  subprogram may depend on. These items are obtained from the
1877             --  parameter profile or pragma [Refined_]Global (if available).
1878 
1879             Collect_Subprogram_Inputs_Outputs
1880               (Subp_Id      => Subp_Id,
1881                Subp_Inputs  => Subp_Inputs,
1882                Subp_Outputs => Subp_Outputs,
1883                Global_Seen  => Global_Seen);
1884 
1885             --  When pragma [Refined_]Depends appears on a single concurrent
1886             --  type, it is relocated to the anonymous object.
1887 
1888             if Is_Single_Concurrent_Object (Spec_Id) then
1889                null;
1890 
1891             --  Ensure that the formal parameters are visible when analyzing
1892             --  all clauses. This falls out of the general rule of aspects
1893             --  pertaining to subprogram declarations.
1894 
1895             elsif not In_Open_Scopes (Spec_Id) then
1896                Restore_Scope := True;
1897                Push_Scope (Spec_Id);
1898 
1899                if Ekind (Spec_Id) = E_Task_Type then
1900                   if Has_Discriminants (Spec_Id) then
1901                      Install_Discriminants (Spec_Id);
1902                   end if;
1903 
1904                elsif Is_Generic_Subprogram (Spec_Id) then
1905                   Install_Generic_Formals (Spec_Id);
1906 
1907                else
1908                   Install_Formals (Spec_Id);
1909                end if;
1910             end if;
1911 
1912             Clause := First (Component_Associations (Deps));
1913             while Present (Clause) loop
1914                Errors := Serious_Errors_Detected;
1915 
1916                --  The normalization mechanism may create extra clauses that
1917                --  contain replicated input and output names. There is no need
1918                --  to reanalyze them.
1919 
1920                if not Analyzed (Clause) then
1921                   Set_Analyzed (Clause);
1922 
1923                   Analyze_Dependency_Clause
1924                     (Clause  => Clause,
1925                      Is_Last => Clause = Last_Clause);
1926                end if;
1927 
1928                --  Do not normalize a clause if errors were detected (count
1929                --  of Serious_Errors has increased) because the inputs and/or
1930                --  outputs may denote illegal items. Normalization is disabled
1931                --  in ASIS mode as it alters the tree by introducing new nodes
1932                --  similar to expansion.
1933 
1934                if Serious_Errors_Detected = Errors and then not ASIS_Mode then
1935                   Normalize_Clause (Clause);
1936                end if;
1937 
1938                Next (Clause);
1939             end loop;
1940 
1941             if Restore_Scope then
1942                End_Scope;
1943             end if;
1944 
1945             --  Verify that every input or output of the subprogram appear in a
1946             --  dependency.
1947 
1948             Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
1949             Check_Usage (Subp_Outputs, All_Outputs_Seen, False);
1950             Check_Function_Return;
1951 
1952          --  The dependency list is malformed. This is a syntax error, always
1953          --  report.
1954 
1955          else
1956             Error_Msg_N ("malformed dependency relation", Deps);
1957             return;
1958          end if;
1959 
1960       --  The top level dependency relation is malformed. This is a syntax
1961       --  error, always report.
1962 
1963       else
1964          Error_Msg_N ("malformed dependency relation", Deps);
1965          goto Leave;
1966       end if;
1967 
1968       --  Ensure that a state and a corresponding constituent do not appear
1969       --  together in pragma [Refined_]Depends.
1970 
1971       Check_State_And_Constituent_Use
1972         (States   => States_Seen,
1973          Constits => Constits_Seen,
1974          Context  => N);
1975 
1976       <<Leave>>
1977       Set_Is_Analyzed_Pragma (N);
1978    end Analyze_Depends_In_Decl_Part;
1979 
1980    --------------------------------------------
1981    -- Analyze_External_Property_In_Decl_Part --
1982    --------------------------------------------
1983 
1984    procedure Analyze_External_Property_In_Decl_Part
1985      (N        : Node_Id;
1986       Expr_Val : out Boolean)
1987    is
1988       Arg1     : constant Node_Id := First (Pragma_Argument_Associations (N));
1989       Obj_Decl : constant Node_Id := Find_Related_Context (N);
1990       Obj_Id   : constant Entity_Id := Defining_Entity (Obj_Decl);
1991       Expr     : Node_Id;
1992 
1993    begin
1994       Expr_Val := False;
1995 
1996       --  Do not analyze the pragma multiple times
1997 
1998       if Is_Analyzed_Pragma (N) then
1999          return;
2000       end if;
2001 
2002       Error_Msg_Name_1 := Pragma_Name (N);
2003 
2004       --  An external property pragma must apply to an effectively volatile
2005       --  object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2006       --  The check is performed at the end of the declarative region due to a
2007       --  possible out-of-order arrangement of pragmas:
2008 
2009       --    Obj : ...;
2010       --    pragma Async_Readers (Obj);
2011       --    pragma Volatile (Obj);
2012 
2013       if not Is_Effectively_Volatile (Obj_Id) then
2014          SPARK_Msg_N
2015            ("external property % must apply to a volatile object", N);
2016       end if;
2017 
2018       --  Ensure that the Boolean expression (if present) is static. A missing
2019       --  argument defaults the value to True (SPARK RM 7.1.2(5)).
2020 
2021       Expr_Val := True;
2022 
2023       if Present (Arg1) then
2024          Expr := Get_Pragma_Arg (Arg1);
2025 
2026          if Is_OK_Static_Expression (Expr) then
2027             Expr_Val := Is_True (Expr_Value (Expr));
2028          end if;
2029       end if;
2030 
2031       Set_Is_Analyzed_Pragma (N);
2032    end Analyze_External_Property_In_Decl_Part;
2033 
2034    ---------------------------------
2035    -- Analyze_Global_In_Decl_Part --
2036    ---------------------------------
2037 
2038    procedure Analyze_Global_In_Decl_Part (N : Node_Id) is
2039       Subp_Decl : constant Node_Id   := Find_Related_Declaration_Or_Body (N);
2040       Spec_Id   : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
2041       Subp_Id   : constant Entity_Id := Defining_Entity (Subp_Decl);
2042 
2043       Constits_Seen : Elist_Id := No_Elist;
2044       --  A list containing the entities of all constituents processed so far.
2045       --  It aids in detecting illegal usage of a state and a corresponding
2046       --  constituent in pragma [Refinde_]Global.
2047 
2048       Seen : Elist_Id := No_Elist;
2049       --  A list containing the entities of all the items processed so far. It
2050       --  plays a role in detecting distinct entities.
2051 
2052       States_Seen : Elist_Id := No_Elist;
2053       --  A list containing the entities of all states processed so far. It
2054       --  helps in detecting illegal usage of a state and a corresponding
2055       --  constituent in pragma [Refined_]Global.
2056 
2057       In_Out_Seen : Boolean := False;
2058       Input_Seen  : Boolean := False;
2059       Output_Seen : Boolean := False;
2060       Proof_Seen  : Boolean := False;
2061       --  Flags used to verify the consistency of modes
2062 
2063       procedure Analyze_Global_List
2064         (List        : Node_Id;
2065          Global_Mode : Name_Id := Name_Input);
2066       --  Verify the legality of a single global list declaration. Global_Mode
2067       --  denotes the current mode in effect.
2068 
2069       -------------------------
2070       -- Analyze_Global_List --
2071       -------------------------
2072 
2073       procedure Analyze_Global_List
2074         (List        : Node_Id;
2075          Global_Mode : Name_Id := Name_Input)
2076       is
2077          procedure Analyze_Global_Item
2078            (Item        : Node_Id;
2079             Global_Mode : Name_Id);
2080          --  Verify the legality of a single global item declaration denoted by
2081          --  Item. Global_Mode denotes the current mode in effect.
2082 
2083          procedure Check_Duplicate_Mode
2084            (Mode   : Node_Id;
2085             Status : in out Boolean);
2086          --  Flag Status denotes whether a particular mode has been seen while
2087          --  processing a global list. This routine verifies that Mode is not a
2088          --  duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2089 
2090          procedure Check_Mode_Restriction_In_Enclosing_Context
2091            (Item    : Node_Id;
2092             Item_Id : Entity_Id);
2093          --  Verify that an item of mode In_Out or Output does not appear as an
2094          --  input in the Global aspect of an enclosing subprogram. If this is
2095          --  the case, emit an error. Item and Item_Id are respectively the
2096          --  item and its entity.
2097 
2098          procedure Check_Mode_Restriction_In_Function (Mode : Node_Id);
2099          --  Mode denotes either In_Out or Output. Depending on the kind of the
2100          --  related subprogram, emit an error if those two modes apply to a
2101          --  function (SPARK RM 6.1.4(10)).
2102 
2103          -------------------------
2104          -- Analyze_Global_Item --
2105          -------------------------
2106 
2107          procedure Analyze_Global_Item
2108            (Item        : Node_Id;
2109             Global_Mode : Name_Id)
2110          is
2111             Item_Id : Entity_Id;
2112 
2113          begin
2114             --  Detect one of the following cases
2115 
2116             --    with Global => (null, Name)
2117             --    with Global => (Name_1, null, Name_2)
2118             --    with Global => (Name, null)
2119 
2120             if Nkind (Item) = N_Null then
2121                SPARK_Msg_N ("cannot mix null and non-null global items", Item);
2122                return;
2123             end if;
2124 
2125             Analyze       (Item);
2126             Resolve_State (Item);
2127 
2128             --  Find the entity of the item. If this is a renaming, climb the
2129             --  renaming chain to reach the root object. Renamings of non-
2130             --  entire objects do not yield an entity (Empty).
2131 
2132             Item_Id := Entity_Of (Item);
2133 
2134             if Present (Item_Id) then
2135 
2136                --  A global item may denote a formal parameter of an enclosing
2137                --  subprogram (SPARK RM 6.1.4(6)). Do this check first to
2138                --  provide a better error diagnostic.
2139 
2140                if Is_Formal (Item_Id) then
2141                   if Scope (Item_Id) = Spec_Id then
2142                      SPARK_Msg_NE
2143                        (Fix_Msg (Spec_Id, "global item cannot reference "
2144                         & "parameter of subprogram &"), Item, Spec_Id);
2145                      return;
2146                   end if;
2147 
2148                --  A global item may denote a concurrent type as long as it is
2149                --  the current instance of an enclosing protected or task type
2150                --  (SPARK RM 6.1.4).
2151 
2152                elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
2153                   if Is_CCT_Instance (Item_Id, Spec_Id) then
2154 
2155                      --  Pragma [Refined_]Global associated with a protected
2156                      --  subprogram cannot mention the current instance of a
2157                      --  protected type because the instance behaves as a
2158                      --  formal parameter.
2159 
2160                      if Ekind (Item_Id) = E_Protected_Type then
2161                         Error_Msg_Name_1 := Chars (Item_Id);
2162                         SPARK_Msg_NE
2163                           (Fix_Msg (Spec_Id, "global item of subprogram & "
2164                            & "cannot reference current instance of protected "
2165                            & "type %"), Item, Spec_Id);
2166                         return;
2167 
2168                      --  Pragma [Refined_]Global associated with a task type
2169                      --  cannot mention the current instance of a task type
2170                      --  because the instance behaves as a formal parameter.
2171 
2172                      else pragma Assert (Ekind (Item_Id) = E_Task_Type);
2173                         Error_Msg_Name_1 := Chars (Item_Id);
2174                         SPARK_Msg_NE
2175                           (Fix_Msg (Spec_Id, "global item of subprogram & "
2176                            & "cannot reference current instance of task type "
2177                            & "%"), Item, Spec_Id);
2178                         return;
2179                      end if;
2180 
2181                   --  Otherwise the global item denotes a subtype mark that is
2182                   --  not a current instance.
2183 
2184                   else
2185                      SPARK_Msg_N
2186                        ("invalid use of subtype mark in global list", Item);
2187                      return;
2188                   end if;
2189 
2190                --  A global item may denote the anonymous object created for a
2191                --  single protected/task type as long as the current instance
2192                --  is the same single type (SPARK RM 6.1.4).
2193 
2194                elsif Is_Single_Concurrent_Object (Item_Id)
2195                  and then Is_CCT_Instance (Item_Id, Spec_Id)
2196                then
2197                   --  Pragma [Refined_]Global associated with a protected
2198                   --  subprogram cannot mention the current instance of a
2199                   --  protected type because the instance behaves as a formal
2200                   --  parameter.
2201 
2202                   if Is_Single_Protected_Object (Item_Id) then
2203                      Error_Msg_Name_1 := Chars (Item_Id);
2204                      SPARK_Msg_NE
2205                        (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2206                         & "reference current instance of protected type %"),
2207                         Item, Spec_Id);
2208                      return;
2209 
2210                   --  Pragma [Refined_]Global associated with a task type
2211                   --  cannot mention the current instance of a task type
2212                   --  because the instance behaves as a formal parameter.
2213 
2214                   else pragma Assert (Is_Single_Task_Object (Item_Id));
2215                      Error_Msg_Name_1 := Chars (Item_Id);
2216                      SPARK_Msg_NE
2217                        (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
2218                         & "reference current instance of task type %"),
2219                         Item, Spec_Id);
2220                      return;
2221                   end if;
2222 
2223                --  A formal object may act as a global item inside a generic
2224 
2225                elsif Is_Formal_Object (Item_Id) then
2226                   null;
2227 
2228                --  The only legal references are those to abstract states,
2229                --  objects and various kinds of constants (SPARK RM 6.1.4(4)).
2230 
2231                elsif not Ekind_In (Item_Id, E_Abstract_State,
2232                                             E_Constant,
2233                                             E_Discriminant,
2234                                             E_Loop_Parameter,
2235                                             E_Variable)
2236                then
2237                   SPARK_Msg_N
2238                     ("global item must denote object, state or current "
2239                      & "instance of concurrent type", Item);
2240                   return;
2241                end if;
2242 
2243                --  State related checks
2244 
2245                if Ekind (Item_Id) = E_Abstract_State then
2246 
2247                   --  Package and subprogram bodies are instantiated
2248                   --  individually in a separate compiler pass. Due to this
2249                   --  mode of instantiation, the refinement of a state may
2250                   --  no longer be visible when a subprogram body contract
2251                   --  is instantiated. Since the generic template is legal,
2252                   --  do not perform this check in the instance to circumvent
2253                   --  this oddity.
2254 
2255                   if Is_Generic_Instance (Spec_Id) then
2256                      null;
2257 
2258                   --  An abstract state with visible refinement cannot appear
2259                   --  in pragma [Refined_]Global as its place must be taken by
2260                   --  some of its constituents (SPARK RM 6.1.4(7)).
2261 
2262                   elsif Has_Visible_Refinement (Item_Id) then
2263                      SPARK_Msg_NE
2264                        ("cannot mention state & in global refinement",
2265                         Item, Item_Id);
2266                      SPARK_Msg_N ("\use its constituents instead", Item);
2267                      return;
2268 
2269                   --  An external state cannot appear as a global item of a
2270                   --  nonvolatile function (SPARK RM 7.1.3(8)).
2271 
2272                   elsif Is_External_State (Item_Id)
2273                     and then Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2274                     and then not Is_Volatile_Function (Spec_Id)
2275                   then
2276                      SPARK_Msg_NE
2277                        ("external state & cannot act as global item of "
2278                         & "nonvolatile function", Item, Item_Id);
2279                      return;
2280 
2281                   --  If the reference to the abstract state appears in an
2282                   --  enclosing package body that will eventually refine the
2283                   --  state, record the reference for future checks.
2284 
2285                   else
2286                      Record_Possible_Body_Reference
2287                        (State_Id => Item_Id,
2288                         Ref      => Item);
2289                   end if;
2290 
2291                --  Constant related checks
2292 
2293                elsif Ekind (Item_Id) = E_Constant then
2294 
2295                   --  A constant is a read-only item, therefore it cannot act
2296                   --  as an output.
2297 
2298                   if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2299                      SPARK_Msg_NE
2300                        ("constant & cannot act as output", Item, Item_Id);
2301                      return;
2302                   end if;
2303 
2304                --  Discriminant related checks
2305 
2306                elsif Ekind (Item_Id) = E_Discriminant then
2307 
2308                   --  A discriminant is a read-only item, therefore it cannot
2309                   --  act as an output.
2310 
2311                   if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2312                      SPARK_Msg_NE
2313                        ("discriminant & cannot act as output", Item, Item_Id);
2314                      return;
2315                   end if;
2316 
2317                --  Loop parameter related checks
2318 
2319                elsif Ekind (Item_Id) = E_Loop_Parameter then
2320 
2321                   --  A loop parameter is a read-only item, therefore it cannot
2322                   --  act as an output.
2323 
2324                   if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2325                      SPARK_Msg_NE
2326                        ("loop parameter & cannot act as output",
2327                         Item, Item_Id);
2328                      return;
2329                   end if;
2330 
2331                --  Variable related checks. These are only relevant when
2332                --  SPARK_Mode is on as they are not standard Ada legality
2333                --  rules.
2334 
2335                elsif SPARK_Mode = On
2336                  and then Ekind (Item_Id) = E_Variable
2337                  and then Is_Effectively_Volatile (Item_Id)
2338                then
2339                   --  An effectively volatile object cannot appear as a global
2340                   --  item of a nonvolatile function (SPARK RM 7.1.3(8)).
2341 
2342                   if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
2343                     and then not Is_Volatile_Function (Spec_Id)
2344                   then
2345                      Error_Msg_NE
2346                        ("volatile object & cannot act as global item of a "
2347                         & "function", Item, Item_Id);
2348                      return;
2349 
2350                   --  An effectively volatile object with external property
2351                   --  Effective_Reads set to True must have mode Output or
2352                   --  In_Out (SPARK RM 7.1.3(10)).
2353 
2354                   elsif Effective_Reads_Enabled (Item_Id)
2355                     and then Global_Mode = Name_Input
2356                   then
2357                      Error_Msg_NE
2358                        ("volatile object & with property Effective_Reads must "
2359                         & "have mode In_Out or Output", Item, Item_Id);
2360                      return;
2361                   end if;
2362                end if;
2363 
2364                --  When the item renames an entire object, replace the item
2365                --  with a reference to the object.
2366 
2367                if Entity (Item) /= Item_Id then
2368                   Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item)));
2369                   Analyze (Item);
2370                end if;
2371 
2372             --  Some form of illegal construct masquerading as a name
2373             --  (SPARK RM 6.1.4(4)).
2374 
2375             else
2376                Error_Msg_N
2377                  ("global item must denote object, state or current instance "
2378                   & "of concurrent type", Item);
2379                return;
2380             end if;
2381 
2382             --  Verify that an output does not appear as an input in an
2383             --  enclosing subprogram.
2384 
2385             if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
2386                Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id);
2387             end if;
2388 
2389             --  The same entity might be referenced through various way.
2390             --  Check the entity of the item rather than the item itself
2391             --  (SPARK RM 6.1.4(10)).
2392 
2393             if Contains (Seen, Item_Id) then
2394                SPARK_Msg_N ("duplicate global item", Item);
2395 
2396             --  Add the entity of the current item to the list of processed
2397             --  items.
2398 
2399             else
2400                Append_New_Elmt (Item_Id, Seen);
2401 
2402                if Ekind (Item_Id) = E_Abstract_State then
2403                   Append_New_Elmt (Item_Id, States_Seen);
2404 
2405                --  The variable may eventually become a constituent of a single
2406                --  protected/task type. Record the reference now and verify its
2407                --  legality when analyzing the contract of the variable
2408                --  (SPARK RM 9.3).
2409 
2410                elsif Ekind (Item_Id) = E_Variable then
2411                   Record_Possible_Part_Of_Reference
2412                     (Var_Id => Item_Id,
2413                      Ref    => Item);
2414                end if;
2415 
2416                if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
2417                  and then Present (Encapsulating_State (Item_Id))
2418                then
2419                   Append_New_Elmt (Item_Id, Constits_Seen);
2420                end if;
2421             end if;
2422          end Analyze_Global_Item;
2423 
2424          --------------------------
2425          -- Check_Duplicate_Mode --
2426          --------------------------
2427 
2428          procedure Check_Duplicate_Mode
2429            (Mode   : Node_Id;
2430             Status : in out Boolean)
2431          is
2432          begin
2433             if Status then
2434                SPARK_Msg_N ("duplicate global mode", Mode);
2435             end if;
2436 
2437             Status := True;
2438          end Check_Duplicate_Mode;
2439 
2440          -------------------------------------------------
2441          -- Check_Mode_Restriction_In_Enclosing_Context --
2442          -------------------------------------------------
2443 
2444          procedure Check_Mode_Restriction_In_Enclosing_Context
2445            (Item    : Node_Id;
2446             Item_Id : Entity_Id)
2447          is
2448             Context : Entity_Id;
2449             Dummy   : Boolean;
2450             Inputs  : Elist_Id := No_Elist;
2451             Outputs : Elist_Id := No_Elist;
2452 
2453          begin
2454             --  Traverse the scope stack looking for enclosing subprograms
2455             --  subject to pragma [Refined_]Global.
2456 
2457             Context := Scope (Subp_Id);
2458             while Present (Context) and then Context /= Standard_Standard loop
2459                if Is_Subprogram (Context)
2460                  and then
2461                    (Present (Get_Pragma (Context, Pragma_Global))
2462                       or else
2463                     Present (Get_Pragma (Context, Pragma_Refined_Global)))
2464                then
2465                   Collect_Subprogram_Inputs_Outputs
2466                     (Subp_Id      => Context,
2467                      Subp_Inputs  => Inputs,
2468                      Subp_Outputs => Outputs,
2469                      Global_Seen  => Dummy);
2470 
2471                   --  The item is classified as In_Out or Output but appears as
2472                   --  an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2473 
2474                   if Appears_In (Inputs, Item_Id)
2475                     and then not Appears_In (Outputs, Item_Id)
2476                   then
2477                      SPARK_Msg_NE
2478                        ("global item & cannot have mode In_Out or Output",
2479                         Item, Item_Id);
2480 
2481                      SPARK_Msg_NE
2482                        (Fix_Msg (Subp_Id, "\item already appears as input of "
2483                         & "subprogram &"), Item, Context);
2484 
2485                      --  Stop the traversal once an error has been detected
2486 
2487                      exit;
2488                   end if;
2489                end if;
2490 
2491                Context := Scope (Context);
2492             end loop;
2493          end Check_Mode_Restriction_In_Enclosing_Context;
2494 
2495          ----------------------------------------
2496          -- Check_Mode_Restriction_In_Function --
2497          ----------------------------------------
2498 
2499          procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
2500          begin
2501             if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
2502                SPARK_Msg_N
2503                  ("global mode & is not applicable to functions", Mode);
2504             end if;
2505          end Check_Mode_Restriction_In_Function;
2506 
2507          --  Local variables
2508 
2509          Assoc : Node_Id;
2510          Item  : Node_Id;
2511          Mode  : Node_Id;
2512 
2513       --  Start of processing for Analyze_Global_List
2514 
2515       begin
2516          if Nkind (List) = N_Null then
2517             Set_Analyzed (List);
2518 
2519          --  Single global item declaration
2520 
2521          elsif Nkind_In (List, N_Expanded_Name,
2522                                N_Identifier,
2523                                N_Selected_Component)
2524          then
2525             Analyze_Global_Item (List, Global_Mode);
2526 
2527          --  Simple global list or moded global list declaration
2528 
2529          elsif Nkind (List) = N_Aggregate then
2530             Set_Analyzed (List);
2531 
2532             --  The declaration of a simple global list appear as a collection
2533             --  of expressions.
2534 
2535             if Present (Expressions (List)) then
2536                if Present (Component_Associations (List)) then
2537                   SPARK_Msg_N
2538                     ("cannot mix moded and non-moded global lists", List);
2539                end if;
2540 
2541                Item := First (Expressions (List));
2542                while Present (Item) loop
2543                   Analyze_Global_Item (Item, Global_Mode);
2544                   Next (Item);
2545                end loop;
2546 
2547             --  The declaration of a moded global list appears as a collection
2548             --  of component associations where individual choices denote
2549             --  modes.
2550 
2551             elsif Present (Component_Associations (List)) then
2552                if Present (Expressions (List)) then
2553                   SPARK_Msg_N
2554                     ("cannot mix moded and non-moded global lists", List);
2555                end if;
2556 
2557                Assoc := First (Component_Associations (List));
2558                while Present (Assoc) loop
2559                   Mode := First (Choices (Assoc));
2560 
2561                   if Nkind (Mode) = N_Identifier then
2562                      if Chars (Mode) = Name_In_Out then
2563                         Check_Duplicate_Mode (Mode, In_Out_Seen);
2564                         Check_Mode_Restriction_In_Function (Mode);
2565 
2566                      elsif Chars (Mode) = Name_Input then
2567                         Check_Duplicate_Mode (Mode, Input_Seen);
2568 
2569                      elsif Chars (Mode) = Name_Output then
2570                         Check_Duplicate_Mode (Mode, Output_Seen);
2571                         Check_Mode_Restriction_In_Function (Mode);
2572 
2573                      elsif Chars (Mode) = Name_Proof_In then
2574                         Check_Duplicate_Mode (Mode, Proof_Seen);
2575 
2576                      else
2577                         SPARK_Msg_N ("invalid mode selector", Mode);
2578                      end if;
2579 
2580                   else
2581                      SPARK_Msg_N ("invalid mode selector", Mode);
2582                   end if;
2583 
2584                   --  Items in a moded list appear as a collection of
2585                   --  expressions. Reuse the existing machinery to analyze
2586                   --  them.
2587 
2588                   Analyze_Global_List
2589                     (List        => Expression (Assoc),
2590                      Global_Mode => Chars (Mode));
2591 
2592                   Next (Assoc);
2593                end loop;
2594 
2595             --  Invalid tree
2596 
2597             else
2598                raise Program_Error;
2599             end if;
2600 
2601          --  Any other attempt to declare a global item is illegal. This is a
2602          --  syntax error, always report.
2603 
2604          else
2605             Error_Msg_N ("malformed global list", List);
2606          end if;
2607       end Analyze_Global_List;
2608 
2609       --  Local variables
2610 
2611       Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
2612 
2613       Restore_Scope : Boolean := False;
2614 
2615    --  Start of processing for Analyze_Global_In_Decl_Part
2616 
2617    begin
2618       --  Do not analyze the pragma multiple times
2619 
2620       if Is_Analyzed_Pragma (N) then
2621          return;
2622       end if;
2623 
2624       --  There is nothing to be done for a null global list
2625 
2626       if Nkind (Items) = N_Null then
2627          Set_Analyzed (Items);
2628 
2629       --  Analyze the various forms of global lists and items. Note that some
2630       --  of these may be malformed in which case the analysis emits error
2631       --  messages.
2632 
2633       else
2634          --  When pragma [Refined_]Global appears on a single concurrent type,
2635          --  it is relocated to the anonymous object.
2636 
2637          if Is_Single_Concurrent_Object (Spec_Id) then
2638             null;
2639 
2640          --  Ensure that the formal parameters are visible when processing an
2641          --  item. This falls out of the general rule of aspects pertaining to
2642          --  subprogram declarations.
2643 
2644          elsif not In_Open_Scopes (Spec_Id) then
2645             Restore_Scope := True;
2646             Push_Scope (Spec_Id);
2647 
2648             if Ekind (Spec_Id) = E_Task_Type then
2649                if Has_Discriminants (Spec_Id) then
2650                   Install_Discriminants (Spec_Id);
2651                end if;
2652 
2653             elsif Is_Generic_Subprogram (Spec_Id) then
2654                Install_Generic_Formals (Spec_Id);
2655 
2656             else
2657                Install_Formals (Spec_Id);
2658             end if;
2659          end if;
2660 
2661          Analyze_Global_List (Items);
2662 
2663          if Restore_Scope then
2664             End_Scope;
2665          end if;
2666       end if;
2667 
2668       --  Ensure that a state and a corresponding constituent do not appear
2669       --  together in pragma [Refined_]Global.
2670 
2671       Check_State_And_Constituent_Use
2672         (States   => States_Seen,
2673          Constits => Constits_Seen,
2674          Context  => N);
2675 
2676       Set_Is_Analyzed_Pragma (N);
2677    end Analyze_Global_In_Decl_Part;
2678 
2679    --------------------------------------------
2680    -- Analyze_Initial_Condition_In_Decl_Part --
2681    --------------------------------------------
2682 
2683    procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
2684       Pack_Decl : constant Node_Id   := Find_Related_Package_Or_Body (N);
2685       Pack_Id   : constant Entity_Id := Defining_Entity (Pack_Decl);
2686       Expr      : constant Node_Id   := Expression (Get_Argument (N, Pack_Id));
2687 
2688       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
2689 
2690    begin
2691       --  Do not analyze the pragma multiple times
2692 
2693       if Is_Analyzed_Pragma (N) then
2694          return;
2695       end if;
2696 
2697       --  Set the Ghost mode in effect from the pragma. Due to the delayed
2698       --  analysis of the pragma, the Ghost mode at point of declaration and
2699       --  point of analysis may not necessarily be the same. Use the mode in
2700       --  effect at the point of declaration.
2701 
2702       Set_Ghost_Mode (N);
2703 
2704       --  The expression is preanalyzed because it has not been moved to its
2705       --  final place yet. A direct analysis may generate side effects and this
2706       --  is not desired at this point.
2707 
2708       Preanalyze_Assert_Expression (Expr, Standard_Boolean);
2709       Ghost_Mode := Save_Ghost_Mode;
2710 
2711       Set_Is_Analyzed_Pragma (N);
2712    end Analyze_Initial_Condition_In_Decl_Part;
2713 
2714    --------------------------------------
2715    -- Analyze_Initializes_In_Decl_Part --
2716    --------------------------------------
2717 
2718    procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is
2719       Pack_Decl : constant Node_Id   := Find_Related_Package_Or_Body (N);
2720       Pack_Id   : constant Entity_Id := Defining_Entity (Pack_Decl);
2721 
2722       Constits_Seen : Elist_Id := No_Elist;
2723       --  A list containing the entities of all constituents processed so far.
2724       --  It aids in detecting illegal usage of a state and a corresponding
2725       --  constituent in pragma Initializes.
2726 
2727       Items_Seen : Elist_Id := No_Elist;
2728       --  A list of all initialization items processed so far. This list is
2729       --  used to detect duplicate items.
2730 
2731       Non_Null_Seen : Boolean := False;
2732       Null_Seen     : Boolean := False;
2733       --  Flags used to check the legality of a null initialization list
2734 
2735       States_And_Objs : Elist_Id := No_Elist;
2736       --  A list of all abstract states and objects declared in the visible
2737       --  declarations of the related package. This list is used to detect the
2738       --  legality of initialization items.
2739 
2740       States_Seen : Elist_Id := No_Elist;
2741       --  A list containing the entities of all states processed so far. It
2742       --  helps in detecting illegal usage of a state and a corresponding
2743       --  constituent in pragma Initializes.
2744 
2745       procedure Analyze_Initialization_Item (Item : Node_Id);
2746       --  Verify the legality of a single initialization item
2747 
2748       procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id);
2749       --  Verify the legality of a single initialization item followed by a
2750       --  list of input items.
2751 
2752       procedure Collect_States_And_Objects;
2753       --  Inspect the visible declarations of the related package and gather
2754       --  the entities of all abstract states and objects in States_And_Objs.
2755 
2756       ---------------------------------
2757       -- Analyze_Initialization_Item --
2758       ---------------------------------
2759 
2760       procedure Analyze_Initialization_Item (Item : Node_Id) is
2761          Item_Id : Entity_Id;
2762 
2763       begin
2764          --  Null initialization list
2765 
2766          if Nkind (Item) = N_Null then
2767             if Null_Seen then
2768                SPARK_Msg_N ("multiple null initializations not allowed", Item);
2769 
2770             elsif Non_Null_Seen then
2771                SPARK_Msg_N
2772                  ("cannot mix null and non-null initialization items", Item);
2773             else
2774                Null_Seen := True;
2775             end if;
2776 
2777          --  Initialization item
2778 
2779          else
2780             Non_Null_Seen := True;
2781 
2782             if Null_Seen then
2783                SPARK_Msg_N
2784                  ("cannot mix null and non-null initialization items", Item);
2785             end if;
2786 
2787             Analyze       (Item);
2788             Resolve_State (Item);
2789 
2790             if Is_Entity_Name (Item) then
2791                Item_Id := Entity_Of (Item);
2792 
2793                if Ekind_In (Item_Id, E_Abstract_State,
2794                                      E_Constant,
2795                                      E_Variable)
2796                then
2797                   --  The state or variable must be declared in the visible
2798                   --  declarations of the package (SPARK RM 7.1.5(7)).
2799 
2800                   if not Contains (States_And_Objs, Item_Id) then
2801                      Error_Msg_Name_1 := Chars (Pack_Id);
2802                      SPARK_Msg_NE
2803                        ("initialization item & must appear in the visible "
2804                         & "declarations of package %", Item, Item_Id);
2805 
2806                   --  Detect a duplicate use of the same initialization item
2807                   --  (SPARK RM 7.1.5(5)).
2808 
2809                   elsif Contains (Items_Seen, Item_Id) then
2810                      SPARK_Msg_N ("duplicate initialization item", Item);
2811 
2812                   --  The item is legal, add it to the list of processed states
2813                   --  and variables.
2814 
2815                   else
2816                      Append_New_Elmt (Item_Id, Items_Seen);
2817 
2818                      if Ekind (Item_Id) = E_Abstract_State then
2819                         Append_New_Elmt (Item_Id, States_Seen);
2820                      end if;
2821 
2822                      if Present (Encapsulating_State (Item_Id)) then
2823                         Append_New_Elmt (Item_Id, Constits_Seen);
2824                      end if;
2825                   end if;
2826 
2827                --  The item references something that is not a state or object
2828                --  (SPARK RM 7.1.5(3)).
2829 
2830                else
2831                   SPARK_Msg_N
2832                     ("initialization item must denote object or state", Item);
2833                end if;
2834 
2835             --  Some form of illegal construct masquerading as a name
2836             --  (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2837 
2838             else
2839                Error_Msg_N
2840                  ("initialization item must denote object or state", Item);
2841             end if;
2842          end if;
2843       end Analyze_Initialization_Item;
2844 
2845       ---------------------------------------------
2846       -- Analyze_Initialization_Item_With_Inputs --
2847       ---------------------------------------------
2848 
2849       procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is
2850          Inputs_Seen : Elist_Id := No_Elist;
2851          --  A list of all inputs processed so far. This list is used to detect
2852          --  duplicate uses of an input.
2853 
2854          Non_Null_Seen : Boolean := False;
2855          Null_Seen     : Boolean := False;
2856          --  Flags used to check the legality of an input list
2857 
2858          procedure Analyze_Input_Item (Input : Node_Id);
2859          --  Verify the legality of a single input item
2860 
2861          ------------------------
2862          -- Analyze_Input_Item --
2863          ------------------------
2864 
2865          procedure Analyze_Input_Item (Input : Node_Id) is
2866             Input_Id : Entity_Id;
2867             Input_OK : Boolean := True;
2868 
2869          begin
2870             --  Null input list
2871 
2872             if Nkind (Input) = N_Null then
2873                if Null_Seen then
2874                   SPARK_Msg_N
2875                     ("multiple null initializations not allowed", Item);
2876 
2877                elsif Non_Null_Seen then
2878                   SPARK_Msg_N
2879                     ("cannot mix null and non-null initialization item", Item);
2880                else
2881                   Null_Seen := True;
2882                end if;
2883 
2884             --  Input item
2885 
2886             else
2887                Non_Null_Seen := True;
2888 
2889                if Null_Seen then
2890                   SPARK_Msg_N
2891                     ("cannot mix null and non-null initialization item", Item);
2892                end if;
2893 
2894                Analyze       (Input);
2895                Resolve_State (Input);
2896 
2897                if Is_Entity_Name (Input) then
2898                   Input_Id := Entity_Of (Input);
2899 
2900                   if Ekind_In (Input_Id, E_Abstract_State,
2901                                          E_Constant,
2902                                          E_Generic_In_Out_Parameter,
2903                                          E_Generic_In_Parameter,
2904                                          E_In_Parameter,
2905                                          E_In_Out_Parameter,
2906                                          E_Out_Parameter,
2907                                          E_Variable)
2908                   then
2909                      --  The input cannot denote states or objects declared
2910                      --  within the related package (SPARK RM 7.1.5(4)).
2911 
2912                      if Within_Scope (Input_Id, Current_Scope) then
2913 
2914                         --  Do not consider generic formal parameters or their
2915                         --  respective mappings to generic formals. Even though
2916                         --  the formals appear within the scope of the package,
2917                         --  it is allowed for an initialization item to depend
2918                         --  on an input item.
2919 
2920                         if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
2921                                                E_Generic_In_Parameter)
2922                         then
2923                            null;
2924 
2925                         elsif Ekind_In (Input_Id, E_Constant, E_Variable)
2926                           and then Present (Corresponding_Generic_Association
2927                                      (Declaration_Node (Input_Id)))
2928                         then
2929                            null;
2930 
2931                         else
2932                            Input_OK := False;
2933                            Error_Msg_Name_1 := Chars (Pack_Id);
2934                            SPARK_Msg_NE
2935                              ("input item & cannot denote a visible object or "
2936                               & "state of package %", Input, Input_Id);
2937                         end if;
2938                      end if;
2939 
2940                      --  Detect a duplicate use of the same input item
2941                      --  (SPARK RM 7.1.5(5)).
2942 
2943                      if Contains (Inputs_Seen, Input_Id) then
2944                         Input_OK := False;
2945                         SPARK_Msg_N ("duplicate input item", Input);
2946                      end if;
2947 
2948                      --  Input is legal, add it to the list of processed inputs
2949 
2950                      if Input_OK then
2951                         Append_New_Elmt (Input_Id, Inputs_Seen);
2952 
2953                         if Ekind (Input_Id) = E_Abstract_State then
2954                            Append_New_Elmt (Input_Id, States_Seen);
2955                         end if;
2956 
2957                         if Ekind_In (Input_Id, E_Abstract_State,
2958                                                E_Constant,
2959                                                E_Variable)
2960                           and then Present (Encapsulating_State (Input_Id))
2961                         then
2962                            Append_New_Elmt (Input_Id, Constits_Seen);
2963                         end if;
2964                      end if;
2965 
2966                   --  The input references something that is not a state or an
2967                   --  object (SPARK RM 7.1.5(3)).
2968 
2969                   else
2970                      SPARK_Msg_N
2971                        ("input item must denote object or state", Input);
2972                   end if;
2973 
2974                --  Some form of illegal construct masquerading as a name
2975                --  (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2976 
2977                else
2978                   Error_Msg_N
2979                     ("input item must denote object or state", Input);
2980                end if;
2981             end if;
2982          end Analyze_Input_Item;
2983 
2984          --  Local variables
2985 
2986          Inputs : constant Node_Id := Expression (Item);
2987          Elmt   : Node_Id;
2988          Input  : Node_Id;
2989 
2990          Name_Seen : Boolean := False;
2991          --  A flag used to detect multiple item names
2992 
2993       --  Start of processing for Analyze_Initialization_Item_With_Inputs
2994 
2995       begin
2996          --  Inspect the name of an item with inputs
2997 
2998          Elmt := First (Choices (Item));
2999          while Present (Elmt) loop
3000             if Name_Seen then
3001                SPARK_Msg_N ("only one item allowed in initialization", Elmt);
3002             else
3003                Name_Seen := True;
3004                Analyze_Initialization_Item (Elmt);
3005             end if;
3006 
3007             Next (Elmt);
3008          end loop;
3009 
3010          --  Multiple input items appear as an aggregate
3011 
3012          if Nkind (Inputs) = N_Aggregate then
3013             if Present (Expressions (Inputs)) then
3014                Input := First (Expressions (Inputs));
3015                while Present (Input) loop
3016                   Analyze_Input_Item (Input);
3017                   Next (Input);
3018                end loop;
3019             end if;
3020 
3021             if Present (Component_Associations (Inputs)) then
3022                SPARK_Msg_N
3023                  ("inputs must appear in named association form", Inputs);
3024             end if;
3025 
3026          --  Single input item
3027 
3028          else
3029             Analyze_Input_Item (Inputs);
3030          end if;
3031       end Analyze_Initialization_Item_With_Inputs;
3032 
3033       --------------------------------
3034       -- Collect_States_And_Objects --
3035       --------------------------------
3036 
3037       procedure Collect_States_And_Objects is
3038          Pack_Spec : constant Node_Id := Specification (Pack_Decl);
3039          Decl      : Node_Id;
3040 
3041       begin
3042          --  Collect the abstract states defined in the package (if any)
3043 
3044          if Present (Abstract_States (Pack_Id)) then
3045             States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id));
3046          end if;
3047 
3048          --  Collect all objects the appear in the visible declarations of the
3049          --  related package.
3050 
3051          if Present (Visible_Declarations (Pack_Spec)) then
3052             Decl := First (Visible_Declarations (Pack_Spec));
3053             while Present (Decl) loop
3054                if Comes_From_Source (Decl)
3055                  and then Nkind (Decl) = N_Object_Declaration
3056                then
3057                   Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
3058                end if;
3059 
3060                Next (Decl);
3061             end loop;
3062          end if;
3063       end Collect_States_And_Objects;
3064 
3065       --  Local variables
3066 
3067       Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
3068       Init  : Node_Id;
3069 
3070    --  Start of processing for Analyze_Initializes_In_Decl_Part
3071 
3072    begin
3073       --  Do not analyze the pragma multiple times
3074 
3075       if Is_Analyzed_Pragma (N) then
3076          return;
3077       end if;
3078 
3079       --  Nothing to do when the initialization list is empty
3080 
3081       if Nkind (Inits) = N_Null then
3082          return;
3083       end if;
3084 
3085       --  Single and multiple initialization clauses appear as an aggregate. If
3086       --  this is not the case, then either the parser or the analysis of the
3087       --  pragma failed to produce an aggregate.
3088 
3089       pragma Assert (Nkind (Inits) = N_Aggregate);
3090 
3091       --  Initialize the various lists used during analysis
3092 
3093       Collect_States_And_Objects;
3094 
3095       if Present (Expressions (Inits)) then
3096          Init := First (Expressions (Inits));
3097          while Present (Init) loop
3098             Analyze_Initialization_Item (Init);
3099             Next (Init);
3100          end loop;
3101       end if;
3102 
3103       if Present (Component_Associations (Inits)) then
3104          Init := First (Component_Associations (Inits));
3105          while Present (Init) loop
3106             Analyze_Initialization_Item_With_Inputs (Init);
3107             Next (Init);
3108          end loop;
3109       end if;
3110 
3111       --  Ensure that a state and a corresponding constituent do not appear
3112       --  together in pragma Initializes.
3113 
3114       Check_State_And_Constituent_Use
3115         (States   => States_Seen,
3116          Constits => Constits_Seen,
3117          Context  => N);
3118 
3119       Set_Is_Analyzed_Pragma (N);
3120    end Analyze_Initializes_In_Decl_Part;
3121 
3122    ---------------------
3123    -- Analyze_Part_Of --
3124    ---------------------
3125 
3126    procedure Analyze_Part_Of
3127      (Indic    : Node_Id;
3128       Item_Id  : Entity_Id;
3129       Encap    : Node_Id;
3130       Encap_Id : out Entity_Id;
3131       Legal    : out Boolean)
3132    is
3133       Encap_Typ   : Entity_Id;
3134       Item_Decl   : Node_Id;
3135       Pack_Id     : Entity_Id;
3136       Placement   : State_Space_Kind;
3137       Parent_Unit : Entity_Id;
3138 
3139    begin
3140       --  Assume that the indicator is illegal
3141 
3142       Encap_Id := Empty;
3143       Legal    := False;
3144 
3145       if Nkind_In (Encap, N_Expanded_Name,
3146                           N_Identifier,
3147                           N_Selected_Component)
3148       then
3149          Analyze       (Encap);
3150          Resolve_State (Encap);
3151 
3152          Encap_Id := Entity (Encap);
3153 
3154          --  The encapsulator is an abstract state
3155 
3156          if Ekind (Encap_Id) = E_Abstract_State then
3157             null;
3158 
3159          --  The encapsulator is a single concurrent type (SPARK RM 9.3)
3160 
3161          elsif Is_Single_Concurrent_Object (Encap_Id) then
3162             null;
3163 
3164          --  Otherwise the encapsulator is not a legal choice
3165 
3166          else
3167             SPARK_Msg_N
3168               ("indicator Part_Of must denote abstract state, single "
3169                & "protected type or single task type", Encap);
3170             return;
3171          end if;
3172 
3173       --  This is a syntax error, always report
3174 
3175       else
3176          Error_Msg_N
3177            ("indicator Part_Of must denote abstract state, single protected "
3178             & "type or single task type", Encap);
3179          return;
3180       end if;
3181 
3182       --  Catch a case where indicator Part_Of denotes the abstract view of a
3183       --  variable which appears as an abstract state (SPARK RM 10.1.2 2).
3184 
3185       if From_Limited_With (Encap_Id)
3186         and then Present (Non_Limited_View (Encap_Id))
3187         and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable
3188       then
3189          SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap);
3190          SPARK_Msg_N ("\& denotes abstract view of object", Encap);
3191          return;
3192       end if;
3193 
3194       --  The encapsulator is an abstract state
3195 
3196       if Ekind (Encap_Id) = E_Abstract_State then
3197 
3198          --  Determine where the object, package instantiation or state lives
3199          --  with respect to the enclosing packages or package bodies.
3200 
3201          Find_Placement_In_State_Space
3202            (Item_Id   => Item_Id,
3203             Placement => Placement,
3204             Pack_Id   => Pack_Id);
3205 
3206          --  The item appears in a non-package construct with a declarative
3207          --  part (subprogram, block, etc). As such, the item is not allowed
3208          --  to be a part of an encapsulating state because the item is not
3209          --  visible.
3210 
3211          if Placement = Not_In_Package then
3212             SPARK_Msg_N
3213               ("indicator Part_Of cannot appear in this context "
3214                & "(SPARK RM 7.2.6(5))", Indic);
3215             Error_Msg_Name_1 := Chars (Scope (Encap_Id));
3216             SPARK_Msg_NE
3217               ("\& is not part of the hidden state of package %",
3218                Indic, Item_Id);
3219 
3220          --  The item appears in the visible state space of some package. In
3221          --  general this scenario does not warrant Part_Of except when the
3222          --  package is a private child unit and the encapsulating state is
3223          --  declared in a parent unit or a public descendant of that parent
3224          --  unit.
3225 
3226          elsif Placement = Visible_State_Space then
3227             if Is_Child_Unit (Pack_Id)
3228               and then Is_Private_Descendant (Pack_Id)
3229             then
3230                --  A variable or state abstraction which is part of the visible
3231                --  state of a private child unit (or one of its public
3232                --  descendants) must have its Part_Of indicator specified. The
3233                --  Part_Of indicator must denote a state abstraction declared
3234                --  by either the parent unit of the private unit or by a public
3235                --  descendant of that parent unit.
3236 
3237                --  Find nearest private ancestor (which can be the current unit
3238                --  itself).
3239 
3240                Parent_Unit := Pack_Id;
3241                while Present (Parent_Unit) loop
3242                   exit when
3243                     Private_Present
3244                       (Parent (Unit_Declaration_Node (Parent_Unit)));
3245                   Parent_Unit := Scope (Parent_Unit);
3246                end loop;
3247 
3248                Parent_Unit := Scope (Parent_Unit);
3249 
3250                if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then
3251                   SPARK_Msg_NE
3252                     ("indicator Part_Of must denote abstract state or public "
3253                      & "descendant of & (SPARK RM 7.2.6(3))",
3254                      Indic, Parent_Unit);
3255 
3256                elsif Scope (Encap_Id) = Parent_Unit
3257                  or else
3258                    (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id))
3259                      and then not Is_Private_Descendant (Scope (Encap_Id)))
3260                then
3261                   null;
3262 
3263                else
3264                   SPARK_Msg_NE
3265                     ("indicator Part_Of must denote abstract state or public "
3266                      & "descendant of & (SPARK RM 7.2.6(3))",
3267                      Indic, Parent_Unit);
3268                end if;
3269 
3270             --  Indicator Part_Of is not needed when the related package is not
3271             --  a private child unit or a public descendant thereof.
3272 
3273             else
3274                SPARK_Msg_N
3275                  ("indicator Part_Of cannot appear in this context "
3276                   & "(SPARK RM 7.2.6(5))", Indic);
3277                Error_Msg_Name_1 := Chars (Pack_Id);
3278                SPARK_Msg_NE
3279                  ("\& is declared in the visible part of package %",
3280                   Indic, Item_Id);
3281             end if;
3282 
3283          --  When the item appears in the private state space of a package, the
3284          --  encapsulating state must be declared in the same package.
3285 
3286          elsif Placement = Private_State_Space then
3287             if Scope (Encap_Id) /= Pack_Id then
3288                SPARK_Msg_NE
3289                  ("indicator Part_Of must designate an abstract state of "
3290                   & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
3291                Error_Msg_Name_1 := Chars (Pack_Id);
3292                SPARK_Msg_NE
3293                  ("\& is declared in the private part of package %",
3294                   Indic, Item_Id);
3295             end if;
3296 
3297          --  Items declared in the body state space of a package do not need
3298          --  Part_Of indicators as the refinement has already been seen.
3299 
3300          else
3301             SPARK_Msg_N
3302               ("indicator Part_Of cannot appear in this context "
3303                & "(SPARK RM 7.2.6(5))", Indic);
3304 
3305             if Scope (Encap_Id) = Pack_Id then
3306                Error_Msg_Name_1 := Chars (Pack_Id);
3307                SPARK_Msg_NE
3308                  ("\& is declared in the body of package %", Indic, Item_Id);
3309             end if;
3310          end if;
3311 
3312       --  The encapsulator is a single concurrent type
3313 
3314       else
3315          Encap_Typ := Etype (Encap_Id);
3316 
3317          --  Only abstract states and variables can act as constituents of an
3318          --  encapsulating single concurrent type.
3319 
3320          if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
3321             null;
3322 
3323          --  The constituent is a constant
3324 
3325          elsif Ekind (Item_Id) = E_Constant then
3326             Error_Msg_Name_1 := Chars (Encap_Id);
3327             SPARK_Msg_NE
3328               (Fix_Msg (Encap_Typ, "consant & cannot act as constituent of "
3329                & "single protected type %"), Indic, Item_Id);
3330 
3331          --  The constituent is a package instantiation
3332 
3333          else
3334             Error_Msg_Name_1 := Chars (Encap_Id);
3335             SPARK_Msg_NE
3336               (Fix_Msg (Encap_Typ, "package instantiation & cannot act as "
3337                & "constituent of single protected type %"), Indic, Item_Id);
3338          end if;
3339 
3340          --  When the item denotes an abstract state of a nested package, use
3341          --  the declaration of the package to detect proper placement.
3342 
3343          --    package Pack is
3344          --       task T;
3345          --       package Nested
3346          --         with Abstract_State => (State with Part_Of => T)
3347 
3348          if Ekind (Item_Id) = E_Abstract_State then
3349             Item_Decl := Unit_Declaration_Node (Scope (Item_Id));
3350          else
3351             Item_Decl := Declaration_Node (Item_Id);
3352          end if;
3353 
3354          --  Both the item and its encapsulating single concurrent type must
3355          --  appear in the same declarative region (SPARK RM 9.3). Note that
3356          --  privacy is ignored.
3357 
3358          if Parent (Item_Decl) /= Parent (Declaration_Node (Encap_Id)) then
3359             Error_Msg_Name_1 := Chars (Encap_Id);
3360             SPARK_Msg_NE
3361               (Fix_Msg (Encap_Typ, "constituent & must be declared "
3362                & "immediately within the same region as single protected "
3363                & "type %"), Indic, Item_Id);
3364          end if;
3365       end if;
3366 
3367       Legal := True;
3368    end Analyze_Part_Of;
3369 
3370    ----------------------------------
3371    -- Analyze_Part_Of_In_Decl_Part --
3372    ----------------------------------
3373 
3374    procedure Analyze_Part_Of_In_Decl_Part
3375      (N         : Node_Id;
3376       Freeze_Id : Entity_Id := Empty)
3377    is
3378       Encap    : constant Node_Id   :=
3379                    Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
3380       Errors   : constant Nat       := Serious_Errors_Detected;
3381       Var_Decl : constant Node_Id   := Find_Related_Context (N);
3382       Var_Id   : constant Entity_Id := Defining_Entity (Var_Decl);
3383       Constits : Elist_Id;
3384       Encap_Id : Entity_Id;
3385       Legal    : Boolean;
3386 
3387    begin
3388       --  Detect any discrepancies between the placement of the variable with
3389       --  respect to general state space and the encapsulating state or single
3390       --  concurrent type.
3391 
3392       Analyze_Part_Of
3393         (Indic    => N,
3394          Item_Id  => Var_Id,
3395          Encap    => Encap,
3396          Encap_Id => Encap_Id,
3397          Legal    => Legal);
3398 
3399       --  The Part_Of indicator turns the variable into a constituent of the
3400       --  encapsulating state or single concurrent type.
3401 
3402       if Legal then
3403          pragma Assert (Present (Encap_Id));
3404          Constits := Part_Of_Constituents (Encap_Id);
3405 
3406          if No (Constits) then
3407             Constits := New_Elmt_List;
3408             Set_Part_Of_Constituents (Encap_Id, Constits);
3409          end if;
3410 
3411          Append_Elmt (Var_Id, Constits);
3412          Set_Encapsulating_State (Var_Id, Encap_Id);
3413       end if;
3414 
3415       --  Emit a clarification message when the encapsulator is undefined,
3416       --  possibly due to contract "freezing".
3417 
3418       if Errors /= Serious_Errors_Detected
3419         and then Present (Freeze_Id)
3420         and then Has_Undefined_Reference (Encap)
3421       then
3422          Contract_Freeze_Error (Var_Id, Freeze_Id);
3423       end if;
3424    end Analyze_Part_Of_In_Decl_Part;
3425 
3426    --------------------
3427    -- Analyze_Pragma --
3428    --------------------
3429 
3430    procedure Analyze_Pragma (N : Node_Id) is
3431       Loc     : constant Source_Ptr := Sloc (N);
3432       Prag_Id : Pragma_Id;
3433 
3434       Pname : Name_Id;
3435       --  Name of the source pragma, or name of the corresponding aspect for
3436       --  pragmas which originate in a source aspect. In the latter case, the
3437       --  name may be different from the pragma name.
3438 
3439       Pragma_Exit : exception;
3440       --  This exception is used to exit pragma processing completely. It
3441       --  is used when an error is detected, and no further processing is
3442       --  required. It is also used if an earlier error has left the tree in
3443       --  a state where the pragma should not be processed.
3444 
3445       Arg_Count : Nat;
3446       --  Number of pragma argument associations
3447 
3448       Arg1 : Node_Id;
3449       Arg2 : Node_Id;
3450       Arg3 : Node_Id;
3451       Arg4 : Node_Id;
3452       --  First four pragma arguments (pragma argument association nodes, or
3453       --  Empty if the corresponding argument does not exist).
3454 
3455       type Name_List is array (Natural range <>) of Name_Id;
3456       type Args_List is array (Natural range <>) of Node_Id;
3457       --  Types used for arguments to Check_Arg_Order and Gather_Associations
3458 
3459       -----------------------
3460       -- Local Subprograms --
3461       -----------------------
3462 
3463       procedure Acquire_Warning_Match_String (Arg : Node_Id);
3464       --  Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3465       --  get the given string argument, and place it in Name_Buffer, adding
3466       --  leading and trailing asterisks if they are not already present. The
3467       --  caller has already checked that Arg is a static string expression.
3468 
3469       procedure Ada_2005_Pragma;
3470       --  Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3471       --  Ada 95 mode, these are implementation defined pragmas, so should be
3472       --  caught by the No_Implementation_Pragmas restriction.
3473 
3474       procedure Ada_2012_Pragma;
3475       --  Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3476       --  In Ada 95 or 05 mode, these are implementation defined pragmas, so
3477       --  should be caught by the No_Implementation_Pragmas restriction.
3478 
3479       procedure Analyze_Depends_Global
3480         (Spec_Id   : out Entity_Id;
3481          Subp_Decl : out Node_Id;
3482          Legal     : out Boolean);
3483       --  Subsidiary to the analysis of pragmas Depends and Global. Verify the
3484       --  legality of the placement and related context of the pragma. Spec_Id
3485       --  is the entity of the related subprogram. Subp_Decl is the declaration
3486       --  of the related subprogram. Sets flag Legal when the pragma is legal.
3487 
3488       procedure Analyze_If_Present (Id : Pragma_Id);
3489       --  Inspect the remainder of the list containing pragma N and look for
3490       --  a pragma that matches Id. If found, analyze the pragma.
3491 
3492       procedure Analyze_Pre_Post_Condition;
3493       --  Subsidiary to the analysis of pragmas Precondition and Postcondition
3494 
3495       procedure Analyze_Refined_Depends_Global_Post
3496         (Spec_Id : out Entity_Id;
3497          Body_Id : out Entity_Id;
3498          Legal   : out Boolean);
3499       --  Subsidiary routine to the analysis of body pragmas Refined_Depends,
3500       --  Refined_Global and Refined_Post. Verify the legality of the placement
3501       --  and related context of the pragma. Spec_Id is the entity of the
3502       --  related subprogram. Body_Id is the entity of the subprogram body.
3503       --  Flag Legal is set when the pragma is legal.
3504 
3505       procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
3506       --  Perform full analysis of pragma Unmodified and the write aspect of
3507       --  pragma Unused. Flag Is_Unused should be set when verifying the
3508       --  semantics of pragma Unused.
3509 
3510       procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
3511       --  Perform full analysis of pragma Unreferenced and the read aspect of
3512       --  pragma Unused. Flag Is_Unused should be set when verifying the
3513       --  semantics of pragma Unused.
3514 
3515       procedure Check_Ada_83_Warning;
3516       --  Issues a warning message for the current pragma if operating in Ada
3517       --  83 mode (used for language pragmas that are not a standard part of
3518       --  Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3519       --  of 95 pragma.
3520 
3521       procedure Check_Arg_Count (Required : Nat);
3522       --  Check argument count for pragma is equal to given parameter. If not,
3523       --  then issue an error message and raise Pragma_Exit.
3524 
3525       --  Note: all routines whose name is Check_Arg_Is_xxx take an argument
3526       --  Arg which can either be a pragma argument association, in which case
3527       --  the check is applied to the expression of the association or an
3528       --  expression directly.
3529 
3530       procedure Check_Arg_Is_External_Name (Arg : Node_Id);
3531       --  Check that an argument has the right form for an EXTERNAL_NAME
3532       --  parameter of an extended import/export pragma. The rule is that the
3533       --  name must be an identifier or string literal (in Ada 83 mode) or a
3534       --  static string expression (in Ada 95 mode).
3535 
3536       procedure Check_Arg_Is_Identifier (Arg : Node_Id);
3537       --  Check the specified argument Arg to make sure that it is an
3538       --  identifier. If not give error and raise Pragma_Exit.
3539 
3540       procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
3541       --  Check the specified argument Arg to make sure that it is an integer
3542       --  literal. If not give error and raise Pragma_Exit.
3543 
3544       procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
3545       --  Check the specified argument Arg to make sure that it has the proper
3546       --  syntactic form for a local name and meets the semantic requirements
3547       --  for a local name. The local name is analyzed as part of the
3548       --  processing for this call. In addition, the local name is required
3549       --  to represent an entity at the library level.
3550 
3551       procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
3552       --  Check the specified argument Arg to make sure that it has the proper
3553       --  syntactic form for a local name and meets the semantic requirements
3554       --  for a local name. The local name is analyzed as part of the
3555       --  processing for this call.
3556 
3557       procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
3558       --  Check the specified argument Arg to make sure that it is a valid
3559       --  locking policy name. If not give error and raise Pragma_Exit.
3560 
3561       procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id);
3562       --  Check the specified argument Arg to make sure that it is a valid
3563       --  elaboration policy name. If not give error and raise Pragma_Exit.
3564 
3565       procedure Check_Arg_Is_One_Of
3566         (Arg                : Node_Id;
3567          N1, N2             : Name_Id);
3568       procedure Check_Arg_Is_One_Of
3569         (Arg                : Node_Id;
3570          N1, N2, N3         : Name_Id);
3571       procedure Check_Arg_Is_One_Of
3572         (Arg                : Node_Id;
3573          N1, N2, N3, N4     : Name_Id);
3574       procedure Check_Arg_Is_One_Of
3575         (Arg                : Node_Id;
3576          N1, N2, N3, N4, N5 : Name_Id);
3577       --  Check the specified argument Arg to make sure that it is an
3578       --  identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3579       --  present). If not then give error and raise Pragma_Exit.
3580 
3581       procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
3582       --  Check the specified argument Arg to make sure that it is a valid
3583       --  queuing policy name. If not give error and raise Pragma_Exit.
3584 
3585       procedure Check_Arg_Is_OK_Static_Expression
3586         (Arg : Node_Id;
3587          Typ : Entity_Id := Empty);
3588       --  Check the specified argument Arg to make sure that it is a static
3589       --  expression of the given type (i.e. it will be analyzed and resolved
3590       --  using this type, which can be any valid argument to Resolve, e.g.
3591       --  Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3592       --  Typ is left Empty, then any static expression is allowed. Includes
3593       --  checking that the argument does not raise Constraint_Error.
3594 
3595       procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
3596       --  Check the specified argument Arg to make sure that it is a valid task
3597       --  dispatching policy name. If not give error and raise Pragma_Exit.
3598 
3599       procedure Check_Arg_Order (Names : Name_List);
3600       --  Checks for an instance of two arguments with identifiers for the
3601       --  current pragma which are not in the sequence indicated by Names,
3602       --  and if so, generates a fatal message about bad order of arguments.
3603 
3604       procedure Check_At_Least_N_Arguments (N : Nat);
3605       --  Check there are at least N arguments present
3606 
3607       procedure Check_At_Most_N_Arguments (N : Nat);
3608       --  Check there are no more than N arguments present
3609 
3610       procedure Check_Component
3611         (Comp            : Node_Id;
3612          UU_Typ          : Entity_Id;
3613          In_Variant_Part : Boolean := False);
3614       --  Examine an Unchecked_Union component for correct use of per-object
3615       --  constrained subtypes, and for restrictions on finalizable components.
3616       --  UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3617       --  should be set when Comp comes from a record variant.
3618 
3619       procedure Check_Duplicate_Pragma (E : Entity_Id);
3620       --  Check if a rep item of the same name as the current pragma is already
3621       --  chained as a rep pragma to the given entity. If so give a message
3622       --  about the duplicate, and then raise Pragma_Exit so does not return.
3623       --  Note that if E is a type, then this routine avoids flagging a pragma
3624       --  which applies to a parent type from which E is derived.
3625 
3626       procedure Check_Duplicated_Export_Name (Nam : Node_Id);
3627       --  Nam is an N_String_Literal node containing the external name set by
3628       --  an Import or Export pragma (or extended Import or Export pragma).
3629       --  This procedure checks for possible duplications if this is the export
3630       --  case, and if found, issues an appropriate error message.
3631 
3632       procedure Check_Expr_Is_OK_Static_Expression
3633         (Expr : Node_Id;
3634          Typ  : Entity_Id := Empty);
3635       --  Check the specified expression Expr to make sure that it is a static
3636       --  expression of the given type (i.e. it will be analyzed and resolved
3637       --  using this type, which can be any valid argument to Resolve, e.g.
3638       --  Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3639       --  Typ is left Empty, then any static expression is allowed. Includes
3640       --  checking that the expression does not raise Constraint_Error.
3641 
3642       procedure Check_First_Subtype (Arg : Node_Id);
3643       --  Checks that Arg, whose expression is an entity name, references a
3644       --  first subtype.
3645 
3646       procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
3647       --  Checks that the given argument has an identifier, and if so, requires
3648       --  it to match the given identifier name. If there is no identifier, or
3649       --  a non-matching identifier, then an error message is given and
3650       --  Pragma_Exit is raised.
3651 
3652       procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
3653       --  Checks that the given argument has an identifier, and if so, requires
3654       --  it to match one of the given identifier names. If there is no
3655       --  identifier, or a non-matching identifier, then an error message is
3656       --  given and Pragma_Exit is raised.
3657 
3658       procedure Check_In_Main_Program;
3659       --  Common checks for pragmas that appear within a main program
3660       --  (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3661 
3662       procedure Check_Interrupt_Or_Attach_Handler;
3663       --  Common processing for first argument of pragma Interrupt_Handler or
3664       --  pragma Attach_Handler.
3665 
3666       procedure Check_Loop_Pragma_Placement;
3667       --  Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3668       --  appear immediately within a construct restricted to loops, and that
3669       --  pragmas Loop_Invariant and Loop_Variant are grouped together.
3670 
3671       procedure Check_Is_In_Decl_Part_Or_Package_Spec;
3672       --  Check that pragma appears in a declarative part, or in a package
3673       --  specification, i.e. that it does not occur in a statement sequence
3674       --  in a body.
3675 
3676       procedure Check_No_Identifier (Arg : Node_Id);
3677       --  Checks that the given argument does not have an identifier. If
3678       --  an identifier is present, then an error message is issued, and
3679       --  Pragma_Exit is raised.
3680 
3681       procedure Check_No_Identifiers;
3682       --  Checks that none of the arguments to the pragma has an identifier.
3683       --  If any argument has an identifier, then an error message is issued,
3684       --  and Pragma_Exit is raised.
3685 
3686       procedure Check_No_Link_Name;
3687       --  Checks that no link name is specified
3688 
3689       procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
3690       --  Checks if the given argument has an identifier, and if so, requires
3691       --  it to match the given identifier name. If there is a non-matching
3692       --  identifier, then an error message is given and Pragma_Exit is raised.
3693 
3694       procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
3695       --  Checks if the given argument has an identifier, and if so, requires
3696       --  it to match the given identifier name. If there is a non-matching
3697       --  identifier, then an error message is given and Pragma_Exit is raised.
3698       --  In this version of the procedure, the identifier name is given as
3699       --  a string with lower case letters.
3700 
3701       procedure Check_Static_Boolean_Expression (Expr : Node_Id);
3702       --  Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3703       --  Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3704       --  Extensions_Visible and Volatile_Function. Ensure that expression Expr
3705       --  is an OK static boolean expression. Emit an error if this is not the
3706       --  case.
3707 
3708       procedure Check_Static_Constraint (Constr : Node_Id);
3709       --  Constr is a constraint from an N_Subtype_Indication node from a
3710       --  component constraint in an Unchecked_Union type. This routine checks
3711       --  that the constraint is static as required by the restrictions for
3712       --  Unchecked_Union.
3713 
3714       procedure Check_Valid_Configuration_Pragma;
3715       --  Legality checks for placement of a configuration pragma
3716 
3717       procedure Check_Valid_Library_Unit_Pragma;
3718       --  Legality checks for library unit pragmas. A special case arises for
3719       --  pragmas in generic instances that come from copies of the original
3720       --  library unit pragmas in the generic templates. In the case of other
3721       --  than library level instantiations these can appear in contexts which
3722       --  would normally be invalid (they only apply to the original template
3723       --  and to library level instantiations), and they are simply ignored,
3724       --  which is implemented by rewriting them as null statements.
3725 
3726       procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
3727       --  Check an Unchecked_Union variant for lack of nested variants and
3728       --  presence of at least one component. UU_Typ is the related Unchecked_
3729       --  Union type.
3730 
3731       procedure Ensure_Aggregate_Form (Arg : Node_Id);
3732       --  Subsidiary routine to the processing of pragmas Abstract_State,
3733       --  Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3734       --  Refined_Global and Refined_State. Transform argument Arg into
3735       --  an aggregate if not one already. N_Null is never transformed.
3736       --  Arg may denote an aspect specification or a pragma argument
3737       --  association.
3738 
3739       procedure Error_Pragma (Msg : String);
3740       pragma No_Return (Error_Pragma);
3741       --  Outputs error message for current pragma. The message contains a %
3742       --  that will be replaced with the pragma name, and the flag is placed
3743       --  on the pragma itself. Pragma_Exit is then raised. Note: this routine
3744       --  calls Fix_Error (see spec of that procedure for details).
3745 
3746       procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
3747       pragma No_Return (Error_Pragma_Arg);
3748       --  Outputs error message for current pragma. The message may contain
3749       --  a % that will be replaced with the pragma name. The parameter Arg
3750       --  may either be a pragma argument association, in which case the flag
3751       --  is placed on the expression of this association, or an expression,
3752       --  in which case the flag is placed directly on the expression. The
3753       --  message is placed using Error_Msg_N, so the message may also contain
3754       --  an & insertion character which will reference the given Arg value.
3755       --  After placing the message, Pragma_Exit is raised. Note: this routine
3756       --  calls Fix_Error (see spec of that procedure for details).
3757 
3758       procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
3759       pragma No_Return (Error_Pragma_Arg);
3760       --  Similar to above form of Error_Pragma_Arg except that two messages
3761       --  are provided, the second is a continuation comment starting with \.
3762 
3763       procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
3764       pragma No_Return (Error_Pragma_Arg_Ident);
3765       --  Outputs error message for current pragma. The message may contain a %
3766       --  that will be replaced with the pragma name. The parameter Arg must be
3767       --  a pragma argument association with a non-empty identifier (i.e. its
3768       --  Chars field must be set), and the error message is placed on the
3769       --  identifier. The message is placed using Error_Msg_N so the message
3770       --  may also contain an & insertion character which will reference
3771       --  the identifier. After placing the message, Pragma_Exit is raised.
3772       --  Note: this routine calls Fix_Error (see spec of that procedure for
3773       --  details).
3774 
3775       procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
3776       pragma No_Return (Error_Pragma_Ref);
3777       --  Outputs error message for current pragma. The message may contain
3778       --  a % that will be replaced with the pragma name. The parameter Ref
3779       --  must be an entity whose name can be referenced by & and sloc by #.
3780       --  After placing the message, Pragma_Exit is raised. Note: this routine
3781       --  calls Fix_Error (see spec of that procedure for details).
3782 
3783       function Find_Lib_Unit_Name return Entity_Id;
3784       --  Used for a library unit pragma to find the entity to which the
3785       --  library unit pragma applies, returns the entity found.
3786 
3787       procedure Find_Program_Unit_Name (Id : Node_Id);
3788       --  If the pragma is a compilation unit pragma, the id must denote the
3789       --  compilation unit in the same compilation, and the pragma must appear
3790       --  in the list of preceding or trailing pragmas. If it is a program
3791       --  unit pragma that is not a compilation unit pragma, then the
3792       --  identifier must be visible.
3793 
3794       function Find_Unique_Parameterless_Procedure
3795         (Name : Entity_Id;
3796          Arg  : Node_Id) return Entity_Id;
3797       --  Used for a procedure pragma to find the unique parameterless
3798       --  procedure identified by Name, returns it if it exists, otherwise
3799       --  errors out and uses Arg as the pragma argument for the message.
3800 
3801       function Fix_Error (Msg : String) return String;
3802       --  This is called prior to issuing an error message. Msg is the normal
3803       --  error message issued in the pragma case. This routine checks for the
3804       --  case of a pragma coming from an aspect in the source, and returns a
3805       --  message suitable for the aspect case as follows:
3806       --
3807       --    Each substring "pragma" is replaced by "aspect"
3808       --
3809       --    If "argument of" is at the start of the error message text, it is
3810       --    replaced by "entity for".
3811       --
3812       --    If "argument" is at the start of the error message text, it is
3813       --    replaced by "entity".
3814       --
3815       --  So for example, "argument of pragma X must be discrete type"
3816       --  returns "entity for aspect X must be a discrete type".
3817 
3818       --  Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3819       --  be different from the pragma name). If the current pragma results
3820       --  from rewriting another pragma, then Error_Msg_Name_1 is set to the
3821       --  original pragma name.
3822 
3823       procedure Gather_Associations
3824         (Names : Name_List;
3825          Args  : out Args_List);
3826       --  This procedure is used to gather the arguments for a pragma that
3827       --  permits arbitrary ordering of parameters using the normal rules
3828       --  for named and positional parameters. The Names argument is a list
3829       --  of Name_Id values that corresponds to the allowed pragma argument
3830       --  association identifiers in order. The result returned in Args is
3831       --  a list of corresponding expressions that are the pragma arguments.
3832       --  Note that this is a list of expressions, not of pragma argument
3833       --  associations (Gather_Associations has completely checked all the
3834       --  optional identifiers when it returns). An entry in Args is Empty
3835       --  on return if the corresponding argument is not present.
3836 
3837       procedure GNAT_Pragma;
3838       --  Called for all GNAT defined pragmas to check the relevant restriction
3839       --  (No_Implementation_Pragmas).
3840 
3841       function Is_Before_First_Decl
3842         (Pragma_Node : Node_Id;
3843          Decls       : List_Id) return Boolean;
3844       --  Return True if Pragma_Node is before the first declarative item in
3845       --  Decls where Decls is the list of declarative items.
3846 
3847       function Is_Configuration_Pragma return Boolean;
3848       --  Determines if the placement of the current pragma is appropriate
3849       --  for a configuration pragma.
3850 
3851       function Is_In_Context_Clause return Boolean;
3852       --  Returns True if pragma appears within the context clause of a unit,
3853       --  and False for any other placement (does not generate any messages).
3854 
3855       function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
3856       --  Analyzes the argument, and determines if it is a static string
3857       --  expression, returns True if so, False if non-static or not String.
3858       --  A special case is that a string literal returns True in Ada 83 mode
3859       --  (which has no such thing as static string expressions). Note that
3860       --  the call analyzes its argument, so this cannot be used for the case
3861       --  where an identifier might not be declared.
3862 
3863       procedure Pragma_Misplaced;
3864       pragma No_Return (Pragma_Misplaced);
3865       --  Issue fatal error message for misplaced pragma
3866 
3867       procedure Process_Atomic_Independent_Shared_Volatile;
3868       --  Common processing for pragmas Atomic, Independent, Shared, Volatile,
3869       --  Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3870       --  and treated as being identical in effect to pragma Atomic.
3871 
3872       procedure Process_Compile_Time_Warning_Or_Error;
3873       --  Common processing for Compile_Time_Error and Compile_Time_Warning
3874 
3875       procedure Process_Convention
3876         (C   : out Convention_Id;
3877          Ent : out Entity_Id);
3878       --  Common processing for Convention, Interface, Import and Export.
3879       --  Checks first two arguments of pragma, and sets the appropriate
3880       --  convention value in the specified entity or entities. On return
3881       --  C is the convention, Ent is the referenced entity.
3882 
3883       procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
3884       --  Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3885       --  Name_Suppress for Disable and Name_Unsuppress for Enable.
3886 
3887       procedure Process_Extended_Import_Export_Object_Pragma
3888         (Arg_Internal : Node_Id;
3889          Arg_External : Node_Id;
3890          Arg_Size     : Node_Id);
3891       --  Common processing for the pragmas Import/Export_Object. The three
3892       --  arguments correspond to the three named parameters of the pragmas. An
3893       --  argument is empty if the corresponding parameter is not present in
3894       --  the pragma.
3895 
3896       procedure Process_Extended_Import_Export_Internal_Arg
3897         (Arg_Internal : Node_Id := Empty);
3898       --  Common processing for all extended Import and Export pragmas. The
3899       --  argument is the pragma parameter for the Internal argument. If
3900       --  Arg_Internal is empty or inappropriate, an error message is posted.
3901       --  Otherwise, on normal return, the Entity_Field of Arg_Internal is
3902       --  set to identify the referenced entity.
3903 
3904       procedure Process_Extended_Import_Export_Subprogram_Pragma
3905         (Arg_Internal                 : Node_Id;
3906          Arg_External                 : Node_Id;
3907          Arg_Parameter_Types          : Node_Id;
3908          Arg_Result_Type              : Node_Id := Empty;
3909          Arg_Mechanism                : Node_Id;
3910          Arg_Result_Mechanism         : Node_Id := Empty);
3911       --  Common processing for all extended Import and Export pragmas applying
3912       --  to subprograms. The caller omits any arguments that do not apply to
3913       --  the pragma in question (for example, Arg_Result_Type can be non-Empty
3914       --  only in the Import_Function and Export_Function cases). The argument
3915       --  names correspond to the allowed pragma association identifiers.
3916 
3917       procedure Process_Generic_List;
3918       --  Common processing for Share_Generic and Inline_Generic
3919 
3920       procedure Process_Import_Or_Interface;
3921       --  Common processing for Import or Interface
3922 
3923       procedure Process_Import_Predefined_Type;
3924       --  Processing for completing a type with pragma Import. This is used
3925       --  to declare types that match predefined C types, especially for cases
3926       --  without corresponding Ada predefined type.
3927 
3928       type Inline_Status is (Suppressed, Disabled, Enabled);
3929       --  Inline status of a subprogram, indicated as follows:
3930       --    Suppressed: inlining is suppressed for the subprogram
3931       --    Disabled:   no inlining is requested for the subprogram
3932       --    Enabled:    inlining is requested/required for the subprogram
3933 
3934       procedure Process_Inline (Status : Inline_Status);
3935       --  Common processing for Inline, Inline_Always and No_Inline. Parameter
3936       --  indicates the inline status specified by the pragma.
3937 
3938       procedure Process_Interface_Name
3939         (Subprogram_Def : Entity_Id;
3940          Ext_Arg        : Node_Id;
3941          Link_Arg       : Node_Id);
3942       --  Given the last two arguments of pragma Import, pragma Export, or
3943       --  pragma Interface_Name, performs validity checks and sets the
3944       --  Interface_Name field of the given subprogram entity to the
3945       --  appropriate external or link name, depending on the arguments given.
3946       --  Ext_Arg is always present, but Link_Arg may be missing. Note that
3947       --  Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3948       --  appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3949       --  nor Link_Arg is present, the interface name is set to the default
3950       --  from the subprogram name.
3951 
3952       procedure Process_Interrupt_Or_Attach_Handler;
3953       --  Common processing for Interrupt and Attach_Handler pragmas
3954 
3955       procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
3956       --  Common processing for Restrictions and Restriction_Warnings pragmas.
3957       --  Warn is True for Restriction_Warnings, or for Restrictions if the
3958       --  flag Treat_Restrictions_As_Warnings is set, and False if this flag
3959       --  is not set in the Restrictions case.
3960 
3961       procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
3962       --  Common processing for Suppress and Unsuppress. The boolean parameter
3963       --  Suppress_Case is True for the Suppress case, and False for the
3964       --  Unsuppress case.
3965 
3966       procedure Record_Independence_Check (N : Node_Id; E : Entity_Id);
3967       --  Subsidiary to the analysis of pragmas Independent[_Components].
3968       --  Record such a pragma N applied to entity E for future checks.
3969 
3970       procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
3971       --  This procedure sets the Is_Exported flag for the given entity,
3972       --  checking that the entity was not previously imported. Arg is
3973       --  the argument that specified the entity. A check is also made
3974       --  for exporting inappropriate entities.
3975 
3976       procedure Set_Extended_Import_Export_External_Name
3977         (Internal_Ent : Entity_Id;
3978          Arg_External : Node_Id);
3979       --  Common processing for all extended import export pragmas. The first
3980       --  argument, Internal_Ent, is the internal entity, which has already
3981       --  been checked for validity by the caller. Arg_External is from the
3982       --  Import or Export pragma, and may be null if no External parameter
3983       --  was present. If Arg_External is present and is a non-null string
3984       --  (a null string is treated as the default), then the Interface_Name
3985       --  field of Internal_Ent is set appropriately.
3986 
3987       procedure Set_Imported (E : Entity_Id);
3988       --  This procedure sets the Is_Imported flag for the given entity,
3989       --  checking that it is not previously exported or imported.
3990 
3991       procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
3992       --  Mech is a parameter passing mechanism (see Import_Function syntax
3993       --  for MECHANISM_NAME). This routine checks that the mechanism argument
3994       --  has the right form, and if not issues an error message. If the
3995       --  argument has the right form then the Mechanism field of Ent is
3996       --  set appropriately.
3997 
3998       procedure Set_Rational_Profile;
3999       --  Activate the set of configuration pragmas and permissions that make
4000       --  up the Rational profile.
4001 
4002       procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id);
4003       --  Activate the set of configuration pragmas and restrictions that make
4004       --  up the Profile. Profile must be either GNAT_Extended_Ravencar or
4005       --  Ravenscar. N is the corresponding pragma node, which is used for
4006       --  error messages on any constructs violating the profile.
4007 
4008       ----------------------------------
4009       -- Acquire_Warning_Match_String --
4010       ----------------------------------
4011 
4012       procedure Acquire_Warning_Match_String (Arg : Node_Id) is
4013       begin
4014          String_To_Name_Buffer
4015            (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
4016 
4017          --  Add asterisk at start if not already there
4018 
4019          if Name_Len > 0 and then Name_Buffer (1) /= '*' then
4020             Name_Buffer (2 .. Name_Len + 1) :=
4021               Name_Buffer (1 .. Name_Len);
4022             Name_Buffer (1) := '*';
4023             Name_Len := Name_Len + 1;
4024          end if;
4025 
4026          --  Add asterisk at end if not already there
4027 
4028          if Name_Buffer (Name_Len) /= '*' then
4029             Name_Len := Name_Len + 1;
4030             Name_Buffer (Name_Len) := '*';
4031          end if;
4032       end Acquire_Warning_Match_String;
4033 
4034       ---------------------
4035       -- Ada_2005_Pragma --
4036       ---------------------
4037 
4038       procedure Ada_2005_Pragma is
4039       begin
4040          if Ada_Version <= Ada_95 then
4041             Check_Restriction (No_Implementation_Pragmas, N);
4042          end if;
4043       end Ada_2005_Pragma;
4044 
4045       ---------------------
4046       -- Ada_2012_Pragma --
4047       ---------------------
4048 
4049       procedure Ada_2012_Pragma is
4050       begin
4051          if Ada_Version <= Ada_2005 then
4052             Check_Restriction (No_Implementation_Pragmas, N);
4053          end if;
4054       end Ada_2012_Pragma;
4055 
4056       ----------------------------
4057       -- Analyze_Depends_Global --
4058       ----------------------------
4059 
4060       procedure Analyze_Depends_Global
4061         (Spec_Id   : out Entity_Id;
4062          Subp_Decl : out Node_Id;
4063          Legal     : out Boolean)
4064       is
4065       begin
4066          --  Assume that the pragma is illegal
4067 
4068          Spec_Id   := Empty;
4069          Subp_Decl := Empty;
4070          Legal     := False;
4071 
4072          GNAT_Pragma;
4073          Check_Arg_Count (1);
4074 
4075          --  Ensure the proper placement of the pragma. Depends/Global must be
4076          --  associated with a subprogram declaration or a body that acts as a
4077          --  spec.
4078 
4079          Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4080 
4081          --  Entry
4082 
4083          if Nkind (Subp_Decl) = N_Entry_Declaration then
4084             null;
4085 
4086          --  Generic subprogram
4087 
4088          elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4089             null;
4090 
4091          --  Object declaration of a single concurrent type
4092 
4093          elsif Nkind (Subp_Decl) = N_Object_Declaration then
4094             null;
4095 
4096          --  Single task type
4097 
4098          elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then
4099             null;
4100 
4101          --  Subprogram body acts as spec
4102 
4103          elsif Nkind (Subp_Decl) = N_Subprogram_Body
4104            and then No (Corresponding_Spec (Subp_Decl))
4105          then
4106             null;
4107 
4108          --  Subprogram body stub acts as spec
4109 
4110          elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4111            and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
4112          then
4113             null;
4114 
4115          --  Subprogram declaration
4116 
4117          elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4118             null;
4119 
4120          --  Task type
4121 
4122          elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then
4123             null;
4124 
4125          else
4126             Pragma_Misplaced;
4127             return;
4128          end if;
4129 
4130          --  If we get here, then the pragma is legal
4131 
4132          Legal   := True;
4133          Spec_Id := Unique_Defining_Entity (Subp_Decl);
4134 
4135          --  When the related context is an entry, the entry must belong to a
4136          --  protected unit (SPARK RM 6.1.4(6)).
4137 
4138          if Is_Entry_Declaration (Spec_Id)
4139            and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
4140          then
4141             Pragma_Misplaced;
4142             return;
4143 
4144          --  When the related context is an anonymous object created for a
4145          --  simple concurrent type, the type must be a task
4146          --  (SPARK RM 6.1.4(6)).
4147 
4148          elsif Is_Single_Concurrent_Object (Spec_Id)
4149            and then Ekind (Etype (Spec_Id)) /= E_Task_Type
4150          then
4151             Pragma_Misplaced;
4152             return;
4153          end if;
4154 
4155          --  A pragma that applies to a Ghost entity becomes Ghost for the
4156          --  purposes of legality checks and removal of ignored Ghost code.
4157 
4158          Mark_Pragma_As_Ghost (N, Spec_Id);
4159          Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4160       end Analyze_Depends_Global;
4161 
4162       ------------------------
4163       -- Analyze_If_Present --
4164       ------------------------
4165 
4166       procedure Analyze_If_Present (Id : Pragma_Id) is
4167          Stmt : Node_Id;
4168 
4169       begin
4170          pragma Assert (Is_List_Member (N));
4171 
4172          --  Inspect the declarations or statements following pragma N looking
4173          --  for another pragma whose Id matches the caller's request. If it is
4174          --  available, analyze it.
4175 
4176          Stmt := Next (N);
4177          while Present (Stmt) loop
4178             if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then
4179                Analyze_Pragma (Stmt);
4180                exit;
4181 
4182             --  The first source declaration or statement immediately following
4183             --  N ends the region where a pragma may appear.
4184 
4185             elsif Comes_From_Source (Stmt) then
4186                exit;
4187             end if;
4188 
4189             Next (Stmt);
4190          end loop;
4191       end Analyze_If_Present;
4192 
4193       --------------------------------
4194       -- Analyze_Pre_Post_Condition --
4195       --------------------------------
4196 
4197       procedure Analyze_Pre_Post_Condition is
4198          Prag_Iden : constant Node_Id := Pragma_Identifier (N);
4199          Subp_Decl : Node_Id;
4200          Subp_Id   : Entity_Id;
4201 
4202          Duplicates_OK : Boolean := False;
4203          --  Flag set when a pre/postcondition allows multiple pragmas of the
4204          --  same kind.
4205 
4206          In_Body_OK : Boolean := False;
4207          --  Flag set when a pre/postcondition is allowed to appear on a body
4208          --  even though the subprogram may have a spec.
4209 
4210          Is_Pre_Post : Boolean := False;
4211          --  Flag set when the pragma is one of Pre, Pre_Class, Post or
4212          --  Post_Class.
4213 
4214       begin
4215          --  Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4216          --  offer uniformity among the various kinds of pre/postconditions by
4217          --  rewriting the pragma identifier. This allows the retrieval of the
4218          --  original pragma name by routine Original_Aspect_Pragma_Name.
4219 
4220          if Comes_From_Source (N) then
4221             if Nam_In (Pname, Name_Pre, Name_Pre_Class) then
4222                Is_Pre_Post := True;
4223                Set_Class_Present (N, Pname = Name_Pre_Class);
4224                Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition));
4225 
4226             elsif Nam_In (Pname, Name_Post, Name_Post_Class) then
4227                Is_Pre_Post := True;
4228                Set_Class_Present (N, Pname = Name_Post_Class);
4229                Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition));
4230             end if;
4231          end if;
4232 
4233          --  Determine the semantics with respect to duplicates and placement
4234          --  in a body. Pragmas Precondition and Postcondition were introduced
4235          --  before aspects and are not subject to the same aspect-like rules.
4236 
4237          if Nam_In (Pname, Name_Precondition, Name_Postcondition) then
4238             Duplicates_OK := True;
4239             In_Body_OK    := True;
4240          end if;
4241 
4242          GNAT_Pragma;
4243 
4244          --  Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4245          --  argument without an identifier.
4246 
4247          if Is_Pre_Post then
4248             Check_Arg_Count (1);
4249             Check_No_Identifiers;
4250 
4251          --  Pragmas Precondition and Postcondition have complex argument
4252          --  profile.
4253 
4254          else
4255             Check_At_Least_N_Arguments (1);
4256             Check_At_Most_N_Arguments  (2);
4257             Check_Optional_Identifier (Arg1, Name_Check);
4258 
4259             if Present (Arg2) then
4260                Check_Optional_Identifier (Arg2, Name_Message);
4261                Preanalyze_Spec_Expression
4262                  (Get_Pragma_Arg (Arg2), Standard_String);
4263             end if;
4264          end if;
4265 
4266          --  For a pragma PPC in the extended main source unit, record enabled
4267          --  status in SCO.
4268          --  ??? nothing checks that the pragma is in the main source unit
4269 
4270          if Is_Checked (N) and then not Split_PPC (N) then
4271             Set_SCO_Pragma_Enabled (Loc);
4272          end if;
4273 
4274          --  Ensure the proper placement of the pragma
4275 
4276          Subp_Decl :=
4277            Find_Related_Declaration_Or_Body
4278              (N, Do_Checks => not Duplicates_OK);
4279 
4280          --  When a pre/postcondition pragma applies to an abstract subprogram,
4281          --  its original form must be an aspect with 'Class.
4282 
4283          if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
4284             if not From_Aspect_Specification (N) then
4285                Error_Pragma
4286                  ("pragma % cannot be applied to abstract subprogram");
4287 
4288             elsif not Class_Present (N) then
4289                Error_Pragma
4290                  ("aspect % requires ''Class for abstract subprogram");
4291             end if;
4292 
4293          --  Entry declaration
4294 
4295          elsif Nkind (Subp_Decl) = N_Entry_Declaration then
4296             null;
4297 
4298          --  Generic subprogram declaration
4299 
4300          elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
4301             null;
4302 
4303          --  Subprogram body
4304 
4305          elsif Nkind (Subp_Decl) = N_Subprogram_Body
4306            and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK)
4307          then
4308             null;
4309 
4310          --  Subprogram body stub
4311 
4312          elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
4313            and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK)
4314          then
4315             null;
4316 
4317          --  Subprogram declaration
4318 
4319          elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
4320 
4321             --  AI05-0230: When a pre/postcondition pragma applies to a null
4322             --  procedure, its original form must be an aspect with 'Class.
4323 
4324             if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification
4325               and then Null_Present (Specification (Subp_Decl))
4326               and then From_Aspect_Specification (N)
4327               and then not Class_Present (N)
4328             then
4329                Error_Pragma ("aspect % requires ''Class for null procedure");
4330             end if;
4331 
4332          --  Otherwise the placement is illegal
4333 
4334          else
4335             Pragma_Misplaced;
4336             return;
4337          end if;
4338 
4339          Subp_Id := Defining_Entity (Subp_Decl);
4340 
4341          --  Chain the pragma on the contract for further processing by
4342          --  Analyze_Pre_Post_Condition_In_Decl_Part.
4343 
4344          Add_Contract_Item (N, Defining_Entity (Subp_Decl));
4345 
4346          --  A pragma that applies to a Ghost entity becomes Ghost for the
4347          --  purposes of legality checks and removal of ignored Ghost code.
4348 
4349          Mark_Pragma_As_Ghost (N, Subp_Id);
4350 
4351          --  Fully analyze the pragma when it appears inside an entry or
4352          --  subprogram body because it cannot benefit from forward references.
4353 
4354          if Nkind_In (Subp_Decl, N_Entry_Body,
4355                                  N_Subprogram_Body,
4356                                  N_Subprogram_Body_Stub)
4357          then
4358             --  The legality checks of pragmas Precondition and Postcondition
4359             --  are affected by the SPARK mode in effect and the volatility of
4360             --  the context. Analyze all pragmas in a specific order.
4361 
4362             Analyze_If_Present (Pragma_SPARK_Mode);
4363             Analyze_If_Present (Pragma_Volatile_Function);
4364             Analyze_Pre_Post_Condition_In_Decl_Part (N);
4365          end if;
4366       end Analyze_Pre_Post_Condition;
4367 
4368       -----------------------------------------
4369       -- Analyze_Refined_Depends_Global_Post --
4370       -----------------------------------------
4371 
4372       procedure Analyze_Refined_Depends_Global_Post
4373         (Spec_Id : out Entity_Id;
4374          Body_Id : out Entity_Id;
4375          Legal   : out Boolean)
4376       is
4377          Body_Decl : Node_Id;
4378          Spec_Decl : Node_Id;
4379 
4380       begin
4381          --  Assume that the pragma is illegal
4382 
4383          Spec_Id := Empty;
4384          Body_Id := Empty;
4385          Legal   := False;
4386 
4387          GNAT_Pragma;
4388          Check_Arg_Count (1);
4389          Check_No_Identifiers;
4390 
4391          --  Verify the placement of the pragma and check for duplicates. The
4392          --  pragma must apply to a subprogram body [stub].
4393 
4394          Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True);
4395 
4396          --  Entry body
4397 
4398          if Nkind (Body_Decl) = N_Entry_Body then
4399             null;
4400 
4401          --  Subprogram body
4402 
4403          elsif Nkind (Body_Decl) = N_Subprogram_Body then
4404             null;
4405 
4406          --  Subprogram body stub
4407 
4408          elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then
4409             null;
4410 
4411          --  Task body
4412 
4413          elsif Nkind (Body_Decl) = N_Task_Body then
4414             null;
4415 
4416          else
4417             Pragma_Misplaced;
4418             return;
4419          end if;
4420 
4421          Body_Id := Defining_Entity (Body_Decl);
4422          Spec_Id := Unique_Defining_Entity (Body_Decl);
4423 
4424          --  The pragma must apply to the second declaration of a subprogram.
4425          --  In other words, the body [stub] cannot acts as a spec.
4426 
4427          if No (Spec_Id) then
4428             Error_Pragma ("pragma % cannot apply to a stand alone body");
4429             return;
4430 
4431          --  Catch the case where the subprogram body is a subunit and acts as
4432          --  the third declaration of the subprogram.
4433 
4434          elsif Nkind (Parent (Body_Decl)) = N_Subunit then
4435             Error_Pragma ("pragma % cannot apply to a subunit");
4436             return;
4437          end if;
4438 
4439          --  A refined pragma can only apply to the body [stub] of a subprogram
4440          --  declared in the visible part of a package. Retrieve the context of
4441          --  the subprogram declaration.
4442 
4443          Spec_Decl := Unit_Declaration_Node (Spec_Id);
4444 
4445          --  When dealing with protected entries or protected subprograms, use
4446          --  the enclosing protected type as the proper context.
4447 
4448          if Ekind_In (Spec_Id, E_Entry,
4449                                E_Entry_Family,
4450                                E_Function,
4451                                E_Procedure)
4452            and then Ekind (Scope (Spec_Id)) = E_Protected_Type
4453          then
4454             Spec_Decl := Declaration_Node (Scope (Spec_Id));
4455          end if;
4456 
4457          if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then
4458             Error_Pragma
4459               (Fix_Msg (Spec_Id, "pragma % must apply to the body of "
4460                & "subprogram declared in a package specification"));
4461             return;
4462          end if;
4463 
4464          --  If we get here, then the pragma is legal
4465 
4466          Legal := True;
4467 
4468          --  A pragma that applies to a Ghost entity becomes Ghost for the
4469          --  purposes of legality checks and removal of ignored Ghost code.
4470 
4471          Mark_Pragma_As_Ghost (N, Spec_Id);
4472 
4473          if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
4474             Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
4475          end if;
4476       end Analyze_Refined_Depends_Global_Post;
4477 
4478       ----------------------------------
4479       -- Analyze_Unmodified_Or_Unused --
4480       ----------------------------------
4481 
4482       procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
4483          Arg      : Node_Id;
4484          Arg_Expr : Node_Id;
4485          Arg_Id   : Entity_Id;
4486 
4487          Ghost_Error_Posted : Boolean := False;
4488          --  Flag set when an error concerning the illegal mix of Ghost and
4489          --  non-Ghost variables is emitted.
4490 
4491          Ghost_Id : Entity_Id := Empty;
4492          --  The entity of the first Ghost variable encountered while
4493          --  processing the arguments of the pragma.
4494 
4495       begin
4496          GNAT_Pragma;
4497          Check_At_Least_N_Arguments (1);
4498 
4499          --  Loop through arguments
4500 
4501          Arg := Arg1;
4502          while Present (Arg) loop
4503             Check_No_Identifier (Arg);
4504 
4505             --  Note: the analyze call done by Check_Arg_Is_Local_Name will
4506             --  in fact generate reference, so that the entity will have a
4507             --  reference, which will inhibit any warnings about it not
4508             --  being referenced, and also properly show up in the ali file
4509             --  as a reference. But this reference is recorded before the
4510             --  Has_Pragma_Unreferenced flag is set, so that no warning is
4511             --  generated for this reference.
4512 
4513             Check_Arg_Is_Local_Name (Arg);
4514             Arg_Expr := Get_Pragma_Arg (Arg);
4515 
4516             if Is_Entity_Name (Arg_Expr) then
4517                Arg_Id := Entity (Arg_Expr);
4518 
4519                --  Skip processing the argument if already flagged
4520 
4521                if Is_Assignable (Arg_Id)
4522                  and then not Has_Pragma_Unmodified (Arg_Id)
4523                  and then not Has_Pragma_Unused (Arg_Id)
4524                then
4525                   Set_Has_Pragma_Unmodified (Arg_Id);
4526 
4527                   if Is_Unused then
4528                      Set_Has_Pragma_Unused (Arg_Id);
4529                   end if;
4530 
4531                   --  A pragma that applies to a Ghost entity becomes Ghost for
4532                   --  the purposes of legality checks and removal of ignored
4533                   --  Ghost code.
4534 
4535                   Mark_Pragma_As_Ghost (N, Arg_Id);
4536 
4537                   --  Capture the entity of the first Ghost variable being
4538                   --  processed for error detection purposes.
4539 
4540                   if Is_Ghost_Entity (Arg_Id) then
4541                      if No (Ghost_Id) then
4542                         Ghost_Id := Arg_Id;
4543                      end if;
4544 
4545                   --  Otherwise the variable is non-Ghost. It is illegal to mix
4546                   --  references to Ghost and non-Ghost entities
4547                   --  (SPARK RM 6.9).
4548 
4549                   elsif Present (Ghost_Id)
4550                     and then not Ghost_Error_Posted
4551                   then
4552                      Ghost_Error_Posted := True;
4553 
4554                      Error_Msg_Name_1 := Pname;
4555                      Error_Msg_N
4556                        ("pragma % cannot mention ghost and non-ghost "
4557                         & "variables", N);
4558 
4559                      Error_Msg_Sloc := Sloc (Ghost_Id);
4560                      Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
4561 
4562                      Error_Msg_Sloc := Sloc (Arg_Id);
4563                      Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
4564                   end if;
4565 
4566                --  Warn if already flagged as Unused or Unmodified
4567 
4568                elsif Has_Pragma_Unmodified (Arg_Id) then
4569                   if Has_Pragma_Unused (Arg_Id) then
4570                      Error_Msg_NE
4571                        ("??pragma Unused already given for &!", Arg_Expr,
4572                          Arg_Id);
4573                   else
4574                      Error_Msg_NE
4575                        ("??pragma Unmodified already given for &!", Arg_Expr,
4576                          Arg_Id);
4577                   end if;
4578 
4579                --  Otherwise the pragma referenced an illegal entity
4580 
4581                else
4582                   Error_Pragma_Arg
4583                     ("pragma% can only be applied to a variable", Arg_Expr);
4584                end if;
4585             end if;
4586 
4587             Next (Arg);
4588          end loop;
4589       end Analyze_Unmodified_Or_Unused;
4590 
4591       -----------------------------------
4592       -- Analyze_Unreference_Or_Unused --
4593       -----------------------------------
4594 
4595       procedure Analyze_Unreferenced_Or_Unused
4596         (Is_Unused : Boolean := False)
4597       is
4598          Arg      : Node_Id;
4599          Arg_Expr : Node_Id;
4600          Arg_Id   : Entity_Id;
4601          Citem    : Node_Id;
4602 
4603          Ghost_Error_Posted : Boolean := False;
4604          --  Flag set when an error concerning the illegal mix of Ghost and
4605          --  non-Ghost names is emitted.
4606 
4607          Ghost_Id : Entity_Id := Empty;
4608          --  The entity of the first Ghost name encountered while processing
4609          --  the arguments of the pragma.
4610 
4611       begin
4612          GNAT_Pragma;
4613          Check_At_Least_N_Arguments (1);
4614 
4615          --  Check case of appearing within context clause
4616 
4617          if not Is_Unused and then Is_In_Context_Clause then
4618 
4619             --  The arguments must all be units mentioned in a with clause in
4620             --  the same context clause. Note that Par.Prag already checked
4621             --  that the arguments are either identifiers or selected
4622             --  components.
4623 
4624             Arg := Arg1;
4625             while Present (Arg) loop
4626                Citem := First (List_Containing (N));
4627                while Citem /= N loop
4628                   Arg_Expr := Get_Pragma_Arg (Arg);
4629 
4630                   if Nkind (Citem) = N_With_Clause
4631                     and then Same_Name (Name (Citem), Arg_Expr)
4632                   then
4633                      Set_Has_Pragma_Unreferenced
4634                        (Cunit_Entity
4635                          (Get_Source_Unit
4636                            (Library_Unit (Citem))));
4637                      Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
4638                      exit;
4639                   end if;
4640 
4641                   Next (Citem);
4642                end loop;
4643 
4644                if Citem = N then
4645                   Error_Pragma_Arg
4646                     ("argument of pragma% is not withed unit", Arg);
4647                end if;
4648 
4649                Next (Arg);
4650             end loop;
4651 
4652          --  Case of not in list of context items
4653 
4654          else
4655             Arg := Arg1;
4656             while Present (Arg) loop
4657                Check_No_Identifier (Arg);
4658 
4659                --  Note: the analyze call done by Check_Arg_Is_Local_Name will
4660                --  in fact generate reference, so that the entity will have a
4661                --  reference, which will inhibit any warnings about it not
4662                --  being referenced, and also properly show up in the ali file
4663                --  as a reference. But this reference is recorded before the
4664                --  Has_Pragma_Unreferenced flag is set, so that no warning is
4665                --  generated for this reference.
4666 
4667                Check_Arg_Is_Local_Name (Arg);
4668                Arg_Expr := Get_Pragma_Arg (Arg);
4669 
4670                if Is_Entity_Name (Arg_Expr) then
4671                   Arg_Id := Entity (Arg_Expr);
4672 
4673                   --  Warn if already flagged as Unused or Unreferenced and
4674                   --  skip processing the argument.
4675 
4676                   if Has_Pragma_Unreferenced (Arg_Id) then
4677                      if Has_Pragma_Unused (Arg_Id) then
4678                         Error_Msg_NE
4679                           ("??pragma Unused already given for &!", Arg_Expr,
4680                             Arg_Id);
4681                      else
4682                         Error_Msg_NE
4683                           ("??pragma Unreferenced already given for &!",
4684                             Arg_Expr, Arg_Id);
4685                      end if;
4686 
4687                   --  Apply Unreferenced to the entity
4688 
4689                   else
4690                      --  If the entity is overloaded, the pragma applies to the
4691                      --  most recent overloading, as documented. In this case,
4692                      --  name resolution does not generate a reference, so it
4693                      --  must be done here explicitly.
4694 
4695                      if Is_Overloaded (Arg_Expr) then
4696                         Generate_Reference (Arg_Id, N);
4697                      end if;
4698 
4699                      Set_Has_Pragma_Unreferenced (Arg_Id);
4700 
4701                      if Is_Unused then
4702                         Set_Has_Pragma_Unused (Arg_Id);
4703                      end if;
4704 
4705                      --  A pragma that applies to a Ghost entity becomes Ghost
4706                      --  for the purposes of legality checks and removal of
4707                      --  ignored Ghost code.
4708 
4709                      Mark_Pragma_As_Ghost (N, Arg_Id);
4710 
4711                      --  Capture the entity of the first Ghost name being
4712                      --  processed for error detection purposes.
4713 
4714                      if Is_Ghost_Entity (Arg_Id) then
4715                         if No (Ghost_Id) then
4716                            Ghost_Id := Arg_Id;
4717                         end if;
4718 
4719                      --  Otherwise the name is non-Ghost. It is illegal to mix
4720                      --  references to Ghost and non-Ghost entities
4721                      --  (SPARK RM 6.9).
4722 
4723                      elsif Present (Ghost_Id)
4724                        and then not Ghost_Error_Posted
4725                      then
4726                         Ghost_Error_Posted := True;
4727 
4728                         Error_Msg_Name_1 := Pname;
4729                         Error_Msg_N
4730                           ("pragma % cannot mention ghost and non-ghost "
4731                            & "names", N);
4732 
4733                         Error_Msg_Sloc := Sloc (Ghost_Id);
4734                         Error_Msg_NE
4735                           ("\& # declared as ghost", N, Ghost_Id);
4736 
4737                         Error_Msg_Sloc := Sloc (Arg_Id);
4738                         Error_Msg_NE
4739                           ("\& # declared as non-ghost", N, Arg_Id);
4740                      end if;
4741                   end if;
4742                end if;
4743 
4744                Next (Arg);
4745             end loop;
4746          end if;
4747       end Analyze_Unreferenced_Or_Unused;
4748 
4749       --------------------------
4750       -- Check_Ada_83_Warning --
4751       --------------------------
4752 
4753       procedure Check_Ada_83_Warning is
4754       begin
4755          if Ada_Version = Ada_83 and then Comes_From_Source (N) then
4756             Error_Msg_N ("(Ada 83) pragma& is non-standard??", N);
4757          end if;
4758       end Check_Ada_83_Warning;
4759 
4760       ---------------------
4761       -- Check_Arg_Count --
4762       ---------------------
4763 
4764       procedure Check_Arg_Count (Required : Nat) is
4765       begin
4766          if Arg_Count /= Required then
4767             Error_Pragma ("wrong number of arguments for pragma%");
4768          end if;
4769       end Check_Arg_Count;
4770 
4771       --------------------------------
4772       -- Check_Arg_Is_External_Name --
4773       --------------------------------
4774 
4775       procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
4776          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4777 
4778       begin
4779          if Nkind (Argx) = N_Identifier then
4780             return;
4781 
4782          else
4783             Analyze_And_Resolve (Argx, Standard_String);
4784 
4785             if Is_OK_Static_Expression (Argx) then
4786                return;
4787 
4788             elsif Etype (Argx) = Any_Type then
4789                raise Pragma_Exit;
4790 
4791             --  An interesting special case, if we have a string literal and
4792             --  we are in Ada 83 mode, then we allow it even though it will
4793             --  not be flagged as static. This allows expected Ada 83 mode
4794             --  use of external names which are string literals, even though
4795             --  technically these are not static in Ada 83.
4796 
4797             elsif Ada_Version = Ada_83
4798               and then Nkind (Argx) = N_String_Literal
4799             then
4800                return;
4801 
4802             --  Static expression that raises Constraint_Error. This has
4803             --  already been flagged, so just exit from pragma processing.
4804 
4805             elsif Is_OK_Static_Expression (Argx) then
4806                raise Pragma_Exit;
4807 
4808             --  Here we have a real error (non-static expression)
4809 
4810             else
4811                Error_Msg_Name_1 := Pname;
4812 
4813                declare
4814                   Msg : constant String :=
4815                           "argument for pragma% must be a identifier or "
4816                           & "static string expression!";
4817                begin
4818                   Flag_Non_Static_Expr (Fix_Error (Msg), Argx);
4819                   raise Pragma_Exit;
4820                end;
4821             end if;
4822          end if;
4823       end Check_Arg_Is_External_Name;
4824 
4825       -----------------------------
4826       -- Check_Arg_Is_Identifier --
4827       -----------------------------
4828 
4829       procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
4830          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4831       begin
4832          if Nkind (Argx) /= N_Identifier then
4833             Error_Pragma_Arg
4834               ("argument for pragma% must be identifier", Argx);
4835          end if;
4836       end Check_Arg_Is_Identifier;
4837 
4838       ----------------------------------
4839       -- Check_Arg_Is_Integer_Literal --
4840       ----------------------------------
4841 
4842       procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
4843          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4844       begin
4845          if Nkind (Argx) /= N_Integer_Literal then
4846             Error_Pragma_Arg
4847               ("argument for pragma% must be integer literal", Argx);
4848          end if;
4849       end Check_Arg_Is_Integer_Literal;
4850 
4851       -------------------------------------------
4852       -- Check_Arg_Is_Library_Level_Local_Name --
4853       -------------------------------------------
4854 
4855       --  LOCAL_NAME ::=
4856       --    DIRECT_NAME
4857       --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4858       --  | library_unit_NAME
4859 
4860       procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
4861       begin
4862          Check_Arg_Is_Local_Name (Arg);
4863 
4864          --  If it came from an aspect, we want to give the error just as if it
4865          --  came from source.
4866 
4867          if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
4868            and then (Comes_From_Source (N)
4869                        or else Present (Corresponding_Aspect (Parent (Arg))))
4870          then
4871             Error_Pragma_Arg
4872               ("argument for pragma% must be library level entity", Arg);
4873          end if;
4874       end Check_Arg_Is_Library_Level_Local_Name;
4875 
4876       -----------------------------
4877       -- Check_Arg_Is_Local_Name --
4878       -----------------------------
4879 
4880       --  LOCAL_NAME ::=
4881       --    DIRECT_NAME
4882       --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4883       --  | library_unit_NAME
4884 
4885       procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
4886          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
4887 
4888       begin
4889          --  If this pragma came from an aspect specification, we don't want to
4890          --  check for this error, because that would cause spurious errors, in
4891          --  case a type is frozen in a scope more nested than the type. The
4892          --  aspect itself of course can't be anywhere but on the declaration
4893          --  itself.
4894 
4895          if Nkind (Arg) = N_Pragma_Argument_Association then
4896             if From_Aspect_Specification (Parent (Arg)) then
4897                return;
4898             end if;
4899 
4900          --  Arg is the Expression of an N_Pragma_Argument_Association
4901 
4902          else
4903             if From_Aspect_Specification (Parent (Parent (Arg))) then
4904                return;
4905             end if;
4906          end if;
4907 
4908          Analyze (Argx);
4909 
4910          if Nkind (Argx) not in N_Direct_Name
4911            and then (Nkind (Argx) /= N_Attribute_Reference
4912                       or else Present (Expressions (Argx))
4913                       or else Nkind (Prefix (Argx)) /= N_Identifier)
4914            and then (not Is_Entity_Name (Argx)
4915                       or else not Is_Compilation_Unit (Entity (Argx)))
4916          then
4917             Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
4918          end if;
4919 
4920          --  No further check required if not an entity name
4921 
4922          if not Is_Entity_Name (Argx) then
4923             null;
4924 
4925          else
4926             declare
4927                OK   : Boolean;
4928                Ent  : constant Entity_Id := Entity (Argx);
4929                Scop : constant Entity_Id := Scope (Ent);
4930 
4931             begin
4932                --  Case of a pragma applied to a compilation unit: pragma must
4933                --  occur immediately after the program unit in the compilation.
4934 
4935                if Is_Compilation_Unit (Ent) then
4936                   declare
4937                      Decl : constant Node_Id := Unit_Declaration_Node (Ent);
4938 
4939                   begin
4940                      --  Case of pragma placed immediately after spec
4941 
4942                      if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
4943                         OK := True;
4944 
4945                      --  Case of pragma placed immediately after body
4946 
4947                      elsif Nkind (Decl) = N_Subprogram_Declaration
4948                              and then Present (Corresponding_Body (Decl))
4949                      then
4950                         OK := Parent (N) =
4951                                 Aux_Decls_Node
4952                                   (Parent (Unit_Declaration_Node
4953                                              (Corresponding_Body (Decl))));
4954 
4955                      --  All other cases are illegal
4956 
4957                      else
4958                         OK := False;
4959                      end if;
4960                   end;
4961 
4962                --  Special restricted placement rule from 10.2.1(11.8/2)
4963 
4964                elsif Is_Generic_Formal (Ent)
4965                        and then Prag_Id = Pragma_Preelaborable_Initialization
4966                then
4967                   OK := List_Containing (N) =
4968                           Generic_Formal_Declarations
4969                             (Unit_Declaration_Node (Scop));
4970 
4971                --  If this is an aspect applied to a subprogram body, the
4972                --  pragma is inserted in its declarative part.
4973 
4974                elsif From_Aspect_Specification (N)
4975                  and then  Ent = Current_Scope
4976                  and then
4977                    Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
4978                then
4979                   OK := True;
4980 
4981                --  If the aspect is a predicate (possibly others ???) and the
4982                --  context is a record type, this is a discriminant expression
4983                --  within a type declaration, that freezes the predicated
4984                --  subtype.
4985 
4986                elsif From_Aspect_Specification (N)
4987                  and then Prag_Id = Pragma_Predicate
4988                  and then Ekind (Current_Scope) = E_Record_Type
4989                  and then Scop = Scope (Current_Scope)
4990                then
4991                   OK := True;
4992 
4993                --  Default case, just check that the pragma occurs in the scope
4994                --  of the entity denoted by the name.
4995 
4996                else
4997                   OK := Current_Scope = Scop;
4998                end if;
4999 
5000                if not OK then
5001                   Error_Pragma_Arg
5002                     ("pragma% argument must be in same declarative part", Arg);
5003                end if;
5004             end;
5005          end if;
5006       end Check_Arg_Is_Local_Name;
5007 
5008       ---------------------------------
5009       -- Check_Arg_Is_Locking_Policy --
5010       ---------------------------------
5011 
5012       procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
5013          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5014 
5015       begin
5016          Check_Arg_Is_Identifier (Argx);
5017 
5018          if not Is_Locking_Policy_Name (Chars (Argx)) then
5019             Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
5020          end if;
5021       end Check_Arg_Is_Locking_Policy;
5022 
5023       -----------------------------------------------
5024       -- Check_Arg_Is_Partition_Elaboration_Policy --
5025       -----------------------------------------------
5026 
5027       procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is
5028          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5029 
5030       begin
5031          Check_Arg_Is_Identifier (Argx);
5032 
5033          if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then
5034             Error_Pragma_Arg
5035               ("& is not a valid partition elaboration policy name", Argx);
5036          end if;
5037       end Check_Arg_Is_Partition_Elaboration_Policy;
5038 
5039       -------------------------
5040       -- Check_Arg_Is_One_Of --
5041       -------------------------
5042 
5043       procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5044          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5045 
5046       begin
5047          Check_Arg_Is_Identifier (Argx);
5048 
5049          if not Nam_In (Chars (Argx), N1, N2) then
5050             Error_Msg_Name_2 := N1;
5051             Error_Msg_Name_3 := N2;
5052             Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
5053          end if;
5054       end Check_Arg_Is_One_Of;
5055 
5056       procedure Check_Arg_Is_One_Of
5057         (Arg        : Node_Id;
5058          N1, N2, N3 : Name_Id)
5059       is
5060          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5061 
5062       begin
5063          Check_Arg_Is_Identifier (Argx);
5064 
5065          if not Nam_In (Chars (Argx), N1, N2, N3) then
5066             Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5067          end if;
5068       end Check_Arg_Is_One_Of;
5069 
5070       procedure Check_Arg_Is_One_Of
5071         (Arg                : Node_Id;
5072          N1, N2, N3, N4     : Name_Id)
5073       is
5074          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5075 
5076       begin
5077          Check_Arg_Is_Identifier (Argx);
5078 
5079          if not Nam_In (Chars (Argx), N1, N2, N3, N4) then
5080             Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5081          end if;
5082       end Check_Arg_Is_One_Of;
5083 
5084       procedure Check_Arg_Is_One_Of
5085         (Arg                : Node_Id;
5086          N1, N2, N3, N4, N5 : Name_Id)
5087       is
5088          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5089 
5090       begin
5091          Check_Arg_Is_Identifier (Argx);
5092 
5093          if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then
5094             Error_Pragma_Arg ("invalid argument for pragma%", Argx);
5095          end if;
5096       end Check_Arg_Is_One_Of;
5097 
5098       ---------------------------------
5099       -- Check_Arg_Is_Queuing_Policy --
5100       ---------------------------------
5101 
5102       procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
5103          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5104 
5105       begin
5106          Check_Arg_Is_Identifier (Argx);
5107 
5108          if not Is_Queuing_Policy_Name (Chars (Argx)) then
5109             Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
5110          end if;
5111       end Check_Arg_Is_Queuing_Policy;
5112 
5113       ---------------------------------------
5114       -- Check_Arg_Is_OK_Static_Expression --
5115       ---------------------------------------
5116 
5117       procedure Check_Arg_Is_OK_Static_Expression
5118         (Arg : Node_Id;
5119          Typ : Entity_Id := Empty)
5120       is
5121       begin
5122          Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
5123       end Check_Arg_Is_OK_Static_Expression;
5124 
5125       ------------------------------------------
5126       -- Check_Arg_Is_Task_Dispatching_Policy --
5127       ------------------------------------------
5128 
5129       procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
5130          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5131 
5132       begin
5133          Check_Arg_Is_Identifier (Argx);
5134 
5135          if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
5136             Error_Pragma_Arg
5137               ("& is not an allowed task dispatching policy name", Argx);
5138          end if;
5139       end Check_Arg_Is_Task_Dispatching_Policy;
5140 
5141       ---------------------
5142       -- Check_Arg_Order --
5143       ---------------------
5144 
5145       procedure Check_Arg_Order (Names : Name_List) is
5146          Arg : Node_Id;
5147 
5148          Highest_So_Far : Natural := 0;
5149          --  Highest index in Names seen do far
5150 
5151       begin
5152          Arg := Arg1;
5153          for J in 1 .. Arg_Count loop
5154             if Chars (Arg) /= No_Name then
5155                for K in Names'Range loop
5156                   if Chars (Arg) = Names (K) then
5157                      if K < Highest_So_Far then
5158                         Error_Msg_Name_1 := Pname;
5159                         Error_Msg_N
5160                           ("parameters out of order for pragma%", Arg);
5161                         Error_Msg_Name_1 := Names (K);
5162                         Error_Msg_Name_2 := Names (Highest_So_Far);
5163                         Error_Msg_N ("\% must appear before %", Arg);
5164                         raise Pragma_Exit;
5165 
5166                      else
5167                         Highest_So_Far := K;
5168                      end if;
5169                   end if;
5170                end loop;
5171             end if;
5172 
5173             Arg := Next (Arg);
5174          end loop;
5175       end Check_Arg_Order;
5176 
5177       --------------------------------
5178       -- Check_At_Least_N_Arguments --
5179       --------------------------------
5180 
5181       procedure Check_At_Least_N_Arguments (N : Nat) is
5182       begin
5183          if Arg_Count < N then
5184             Error_Pragma ("too few arguments for pragma%");
5185          end if;
5186       end Check_At_Least_N_Arguments;
5187 
5188       -------------------------------
5189       -- Check_At_Most_N_Arguments --
5190       -------------------------------
5191 
5192       procedure Check_At_Most_N_Arguments (N : Nat) is
5193          Arg : Node_Id;
5194       begin
5195          if Arg_Count > N then
5196             Arg := Arg1;
5197             for J in 1 .. N loop
5198                Next (Arg);
5199                Error_Pragma_Arg ("too many arguments for pragma%", Arg);
5200             end loop;
5201          end if;
5202       end Check_At_Most_N_Arguments;
5203 
5204       ---------------------
5205       -- Check_Component --
5206       ---------------------
5207 
5208       procedure Check_Component
5209         (Comp            : Node_Id;
5210          UU_Typ          : Entity_Id;
5211          In_Variant_Part : Boolean := False)
5212       is
5213          Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
5214          Sindic  : constant Node_Id :=
5215                      Subtype_Indication (Component_Definition (Comp));
5216          Typ     : constant Entity_Id := Etype (Comp_Id);
5217 
5218       begin
5219          --  Ada 2005 (AI-216): If a component subtype is subject to a per-
5220          --  object constraint, then the component type shall be an Unchecked_
5221          --  Union.
5222 
5223          if Nkind (Sindic) = N_Subtype_Indication
5224            and then Has_Per_Object_Constraint (Comp_Id)
5225            and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
5226          then
5227             Error_Msg_N
5228               ("component subtype subject to per-object constraint "
5229                & "must be an Unchecked_Union", Comp);
5230 
5231          --  Ada 2012 (AI05-0026): For an unchecked union type declared within
5232          --  the body of a generic unit, or within the body of any of its
5233          --  descendant library units, no part of the type of a component
5234          --  declared in a variant_part of the unchecked union type shall be of
5235          --  a formal private type or formal private extension declared within
5236          --  the formal part of the generic unit.
5237 
5238          elsif Ada_Version >= Ada_2012
5239            and then In_Generic_Body (UU_Typ)
5240            and then In_Variant_Part
5241            and then Is_Private_Type (Typ)
5242            and then Is_Generic_Type (Typ)
5243          then
5244             Error_Msg_N
5245               ("component of unchecked union cannot be of generic type", Comp);
5246 
5247          elsif Needs_Finalization (Typ) then
5248             Error_Msg_N
5249               ("component of unchecked union cannot be controlled", Comp);
5250 
5251          elsif Has_Task (Typ) then
5252             Error_Msg_N
5253               ("component of unchecked union cannot have tasks", Comp);
5254          end if;
5255       end Check_Component;
5256 
5257       ----------------------------
5258       -- Check_Duplicate_Pragma --
5259       ----------------------------
5260 
5261       procedure Check_Duplicate_Pragma (E : Entity_Id) is
5262          Id : Entity_Id := E;
5263          P  : Node_Id;
5264 
5265       begin
5266          --  Nothing to do if this pragma comes from an aspect specification,
5267          --  since we could not be duplicating a pragma, and we dealt with the
5268          --  case of duplicated aspects in Analyze_Aspect_Specifications.
5269 
5270          if From_Aspect_Specification (N) then
5271             return;
5272          end if;
5273 
5274          --  Otherwise current pragma may duplicate previous pragma or a
5275          --  previously given aspect specification or attribute definition
5276          --  clause for the same pragma.
5277 
5278          P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
5279 
5280          if Present (P) then
5281 
5282             --  If the entity is a type, then we have to make sure that the
5283             --  ostensible duplicate is not for a parent type from which this
5284             --  type is derived.
5285 
5286             if Is_Type (E) then
5287                if Nkind (P) = N_Pragma then
5288                   declare
5289                      Args : constant List_Id :=
5290                               Pragma_Argument_Associations (P);
5291                   begin
5292                      if Present (Args)
5293                        and then Is_Entity_Name (Expression (First (Args)))
5294                        and then Is_Type (Entity (Expression (First (Args))))
5295                        and then Entity (Expression (First (Args))) /= E
5296                      then
5297                         return;
5298                      end if;
5299                   end;
5300 
5301                elsif Nkind (P) = N_Aspect_Specification
5302                  and then Is_Type (Entity (P))
5303                  and then Entity (P) /= E
5304                then
5305                   return;
5306                end if;
5307             end if;
5308 
5309             --  Here we have a definite duplicate
5310 
5311             Error_Msg_Name_1 := Pragma_Name (N);
5312             Error_Msg_Sloc := Sloc (P);
5313 
5314             --  For a single protected or a single task object, the error is
5315             --  issued on the original entity.
5316 
5317             if Ekind_In (Id, E_Task_Type, E_Protected_Type) then
5318                Id := Defining_Identifier (Original_Node (Parent (Id)));
5319             end if;
5320 
5321             if Nkind (P) = N_Aspect_Specification
5322               or else From_Aspect_Specification (P)
5323             then
5324                Error_Msg_NE ("aspect% for & previously given#", N, Id);
5325             else
5326                Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
5327             end if;
5328 
5329             raise Pragma_Exit;
5330          end if;
5331       end Check_Duplicate_Pragma;
5332 
5333       ----------------------------------
5334       -- Check_Duplicated_Export_Name --
5335       ----------------------------------
5336 
5337       procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
5338          String_Val : constant String_Id := Strval (Nam);
5339 
5340       begin
5341          --  We are only interested in the export case, and in the case of
5342          --  generics, it is the instance, not the template, that is the
5343          --  problem (the template will generate a warning in any case).
5344 
5345          if not Inside_A_Generic
5346            and then (Prag_Id = Pragma_Export
5347                        or else
5348                      Prag_Id = Pragma_Export_Procedure
5349                        or else
5350                      Prag_Id = Pragma_Export_Valued_Procedure
5351                        or else
5352                      Prag_Id = Pragma_Export_Function)
5353          then
5354             for J in Externals.First .. Externals.Last loop
5355                if String_Equal (String_Val, Strval (Externals.Table (J))) then
5356                   Error_Msg_Sloc := Sloc (Externals.Table (J));
5357                   Error_Msg_N ("external name duplicates name given#", Nam);
5358                   exit;
5359                end if;
5360             end loop;
5361 
5362             Externals.Append (Nam);
5363          end if;
5364       end Check_Duplicated_Export_Name;
5365 
5366       ----------------------------------------
5367       -- Check_Expr_Is_OK_Static_Expression --
5368       ----------------------------------------
5369 
5370       procedure Check_Expr_Is_OK_Static_Expression
5371         (Expr : Node_Id;
5372          Typ  : Entity_Id := Empty)
5373       is
5374       begin
5375          if Present (Typ) then
5376             Analyze_And_Resolve (Expr, Typ);
5377          else
5378             Analyze_And_Resolve (Expr);
5379          end if;
5380 
5381          --  An expression cannot be considered static if its resolution failed
5382          --  or if it's erroneous. Stop the analysis of the related pragma.
5383 
5384          if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
5385             raise Pragma_Exit;
5386 
5387          elsif Is_OK_Static_Expression (Expr) then
5388             return;
5389 
5390          --  An interesting special case, if we have a string literal and we
5391          --  are in Ada 83 mode, then we allow it even though it will not be
5392          --  flagged as static. This allows the use of Ada 95 pragmas like
5393          --  Import in Ada 83 mode. They will of course be flagged with
5394          --  warnings as usual, but will not cause errors.
5395 
5396          elsif Ada_Version = Ada_83
5397            and then Nkind (Expr) = N_String_Literal
5398          then
5399             return;
5400 
5401          --  Finally, we have a real error
5402 
5403          else
5404             Error_Msg_Name_1 := Pname;
5405             Flag_Non_Static_Expr
5406               (Fix_Error ("argument for pragma% must be a static expression!"),
5407                Expr);
5408             raise Pragma_Exit;
5409          end if;
5410       end Check_Expr_Is_OK_Static_Expression;
5411 
5412       -------------------------
5413       -- Check_First_Subtype --
5414       -------------------------
5415 
5416       procedure Check_First_Subtype (Arg : Node_Id) is
5417          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
5418          Ent  : constant Entity_Id := Entity (Argx);
5419 
5420       begin
5421          if Is_First_Subtype (Ent) then
5422             null;
5423 
5424          elsif Is_Type (Ent) then
5425             Error_Pragma_Arg
5426               ("pragma% cannot apply to subtype", Argx);
5427 
5428          elsif Is_Object (Ent) then
5429             Error_Pragma_Arg
5430               ("pragma% cannot apply to object, requires a type", Argx);
5431 
5432          else
5433             Error_Pragma_Arg
5434               ("pragma% cannot apply to&, requires a type", Argx);
5435          end if;
5436       end Check_First_Subtype;
5437 
5438       ----------------------
5439       -- Check_Identifier --
5440       ----------------------
5441 
5442       procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
5443       begin
5444          if Present (Arg)
5445            and then Nkind (Arg) = N_Pragma_Argument_Association
5446          then
5447             if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
5448                Error_Msg_Name_1 := Pname;
5449                Error_Msg_Name_2 := Id;
5450                Error_Msg_N ("pragma% argument expects identifier%", Arg);
5451                raise Pragma_Exit;
5452             end if;
5453          end if;
5454       end Check_Identifier;
5455 
5456       --------------------------------
5457       -- Check_Identifier_Is_One_Of --
5458       --------------------------------
5459 
5460       procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
5461       begin
5462          if Present (Arg)
5463            and then Nkind (Arg) = N_Pragma_Argument_Association
5464          then
5465             if Chars (Arg) = No_Name then
5466                Error_Msg_Name_1 := Pname;
5467                Error_Msg_N ("pragma% argument expects an identifier", Arg);
5468                raise Pragma_Exit;
5469 
5470             elsif Chars (Arg) /= N1
5471               and then Chars (Arg) /= N2
5472             then
5473                Error_Msg_Name_1 := Pname;
5474                Error_Msg_N ("invalid identifier for pragma% argument", Arg);
5475                raise Pragma_Exit;
5476             end if;
5477          end if;
5478       end Check_Identifier_Is_One_Of;
5479 
5480       ---------------------------
5481       -- Check_In_Main_Program --
5482       ---------------------------
5483 
5484       procedure Check_In_Main_Program is
5485          P : constant Node_Id := Parent (N);
5486 
5487       begin
5488          --  Must be in subprogram body
5489 
5490          if Nkind (P) /= N_Subprogram_Body then
5491             Error_Pragma ("% pragma allowed only in subprogram");
5492 
5493          --  Otherwise warn if obviously not main program
5494 
5495          elsif Present (Parameter_Specifications (Specification (P)))
5496            or else not Is_Compilation_Unit (Defining_Entity (P))
5497          then
5498             Error_Msg_Name_1 := Pname;
5499             Error_Msg_N
5500               ("??pragma% is only effective in main program", N);
5501          end if;
5502       end Check_In_Main_Program;
5503 
5504       ---------------------------------------
5505       -- Check_Interrupt_Or_Attach_Handler --
5506       ---------------------------------------
5507 
5508       procedure Check_Interrupt_Or_Attach_Handler is
5509          Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
5510          Handler_Proc, Proc_Scope : Entity_Id;
5511 
5512       begin
5513          Analyze (Arg1_X);
5514 
5515          if Prag_Id = Pragma_Interrupt_Handler then
5516             Check_Restriction (No_Dynamic_Attachment, N);
5517          end if;
5518 
5519          Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
5520          Proc_Scope := Scope (Handler_Proc);
5521 
5522          if Ekind (Proc_Scope) /= E_Protected_Type then
5523             Error_Pragma_Arg
5524               ("argument of pragma% must be protected procedure", Arg1);
5525          end if;
5526 
5527          --  For pragma case (as opposed to access case), check placement.
5528          --  We don't need to do that for aspects, because we have the
5529          --  check that they aspect applies an appropriate procedure.
5530 
5531          if not From_Aspect_Specification (N)
5532            and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
5533          then
5534             Error_Pragma ("pragma% must be in protected definition");
5535          end if;
5536 
5537          if not Is_Library_Level_Entity (Proc_Scope) then
5538             Error_Pragma_Arg
5539               ("argument for pragma% must be library level entity", Arg1);
5540          end if;
5541 
5542          --  AI05-0033: A pragma cannot appear within a generic body, because
5543          --  instance can be in a nested scope. The check that protected type
5544          --  is itself a library-level declaration is done elsewhere.
5545 
5546          --  Note: we omit this check in Relaxed_RM_Semantics mode to properly
5547          --  handle code prior to AI-0033. Analysis tools typically are not
5548          --  interested in this pragma in any case, so no need to worry too
5549          --  much about its placement.
5550 
5551          if Inside_A_Generic then
5552             if Ekind (Scope (Current_Scope)) = E_Generic_Package
5553               and then In_Package_Body (Scope (Current_Scope))
5554               and then not Relaxed_RM_Semantics
5555             then
5556                Error_Pragma ("pragma% cannot be used inside a generic");
5557             end if;
5558          end if;
5559       end Check_Interrupt_Or_Attach_Handler;
5560 
5561       ---------------------------------
5562       -- Check_Loop_Pragma_Placement --
5563       ---------------------------------
5564 
5565       procedure Check_Loop_Pragma_Placement is
5566          procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id);
5567          --  Verify whether the current pragma is properly grouped with other
5568          --  pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5569          --  related loop where the pragma appears.
5570 
5571          function Is_Loop_Pragma (Stmt : Node_Id) return Boolean;
5572          --  Determine whether an arbitrary statement Stmt denotes pragma
5573          --  Loop_Invariant or Loop_Variant.
5574 
5575          procedure Placement_Error (Constr : Node_Id);
5576          pragma No_Return (Placement_Error);
5577          --  Node Constr denotes the last loop restricted construct before we
5578          --  encountered an illegal relation between enclosing constructs. Emit
5579          --  an error depending on what Constr was.
5580 
5581          --------------------------------
5582          -- Check_Loop_Pragma_Grouping --
5583          --------------------------------
5584 
5585          procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is
5586             Stop_Search : exception;
5587             --  This exception is used to terminate the recursive descent of
5588             --  routine Check_Grouping.
5589 
5590             procedure Check_Grouping (L : List_Id);
5591             --  Find the first group of pragmas in list L and if successful,
5592             --  ensure that the current pragma is part of that group. The
5593             --  routine raises Stop_Search once such a check is performed to
5594             --  halt the recursive descent.
5595 
5596             procedure Grouping_Error (Prag : Node_Id);
5597             pragma No_Return (Grouping_Error);
5598             --  Emit an error concerning the current pragma indicating that it
5599             --  should be placed after pragma Prag.
5600 
5601             --------------------
5602             -- Check_Grouping --
5603             --------------------
5604 
5605             procedure Check_Grouping (L : List_Id) is
5606                HSS  : Node_Id;
5607                Prag : Node_Id;
5608                Stmt : Node_Id;
5609 
5610             begin
5611                --  Inspect the list of declarations or statements looking for
5612                --  the first grouping of pragmas:
5613 
5614                --    loop
5615                --       pragma Loop_Invariant ...;
5616                --       pragma Loop_Variant ...;
5617                --       . . .                     -- (1)
5618                --       pragma Loop_Variant ...;  --  current pragma
5619 
5620                --  If the current pragma is not in the grouping, then it must
5621                --  either appear in a different declarative or statement list
5622                --  or the construct at (1) is separating the pragma from the
5623                --  grouping.
5624 
5625                Stmt := First (L);
5626                while Present (Stmt) loop
5627 
5628                   --  Pragmas Loop_Invariant and Loop_Variant may only appear
5629                   --  inside a loop or a block housed inside a loop. Inspect
5630                   --  the declarations and statements of the block as they may
5631                   --  contain the first grouping.
5632 
5633                   if Nkind (Stmt) = N_Block_Statement then
5634                      HSS := Handled_Statement_Sequence (Stmt);
5635 
5636                      Check_Grouping (Declarations (Stmt));
5637 
5638                      if Present (HSS) then
5639                         Check_Grouping (Statements (HSS));
5640                      end if;
5641 
5642                   --  First pragma of the first topmost grouping has been found
5643 
5644                   elsif Is_Loop_Pragma (Stmt) then
5645 
5646                      --  The group and the current pragma are not in the same
5647                      --  declarative or statement list.
5648 
5649                      if List_Containing (Stmt) /= List_Containing (N) then
5650                         Grouping_Error (Stmt);
5651 
5652                      --  Try to reach the current pragma from the first pragma
5653                      --  of the grouping while skipping other members:
5654 
5655                      --    pragma Loop_Invariant ...;  --  first pragma
5656                      --    pragma Loop_Variant ...;    --  member
5657                      --    . . .
5658                      --    pragma Loop_Variant ...;    --  current pragma
5659 
5660                      else
5661                         while Present (Stmt) loop
5662 
5663                            --  The current pragma is either the first pragma
5664                            --  of the group or is a member of the group. Stop
5665                            --  the search as the placement is legal.
5666 
5667                            if Stmt = N then
5668                               raise Stop_Search;
5669 
5670                            --  Skip group members, but keep track of the last
5671                            --  pragma in the group.
5672 
5673                            elsif Is_Loop_Pragma (Stmt) then
5674                               Prag := Stmt;
5675 
5676                            --  Skip declarations and statements generated by
5677                            --  the compiler during expansion.
5678 
5679                            elsif not Comes_From_Source (Stmt) then
5680                               null;
5681 
5682                            --  A non-pragma is separating the group from the
5683                            --  current pragma, the placement is illegal.
5684 
5685                            else
5686                               Grouping_Error (Prag);
5687                            end if;
5688 
5689                            Next (Stmt);
5690                         end loop;
5691 
5692                         --  If the traversal did not reach the current pragma,
5693                         --  then the list must be malformed.
5694 
5695                         raise Program_Error;
5696                      end if;
5697                   end if;
5698 
5699                   Next (Stmt);
5700                end loop;
5701             end Check_Grouping;
5702 
5703             --------------------
5704             -- Grouping_Error --
5705             --------------------
5706 
5707             procedure Grouping_Error (Prag : Node_Id) is
5708             begin
5709                Error_Msg_Sloc := Sloc (Prag);
5710                Error_Pragma ("pragma% must appear next to pragma#");
5711             end Grouping_Error;
5712 
5713          --  Start of processing for Check_Loop_Pragma_Grouping
5714 
5715          begin
5716             --  Inspect the statements of the loop or nested blocks housed
5717             --  within to determine whether the current pragma is part of the
5718             --  first topmost grouping of Loop_Invariant and Loop_Variant.
5719 
5720             Check_Grouping (Statements (Loop_Stmt));
5721 
5722          exception
5723             when Stop_Search => null;
5724          end Check_Loop_Pragma_Grouping;
5725 
5726          --------------------
5727          -- Is_Loop_Pragma --
5728          --------------------
5729 
5730          function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is
5731          begin
5732             --  Inspect the original node as Loop_Invariant and Loop_Variant
5733             --  pragmas are rewritten to null when assertions are disabled.
5734 
5735             if Nkind (Original_Node (Stmt)) = N_Pragma then
5736                return
5737                  Nam_In (Pragma_Name (Original_Node (Stmt)),
5738                          Name_Loop_Invariant,
5739                          Name_Loop_Variant);
5740             else
5741                return False;
5742             end if;
5743          end Is_Loop_Pragma;
5744 
5745          ---------------------
5746          -- Placement_Error --
5747          ---------------------
5748 
5749          procedure Placement_Error (Constr : Node_Id) is
5750             LA : constant String := " with Loop_Entry";
5751 
5752          begin
5753             if Prag_Id = Pragma_Assert then
5754                Error_Msg_String (1 .. LA'Length) := LA;
5755                Error_Msg_Strlen := LA'Length;
5756             else
5757                Error_Msg_Strlen := 0;
5758             end if;
5759 
5760             if Nkind (Constr) = N_Pragma then
5761                Error_Pragma
5762                  ("pragma %~ must appear immediately within the statements "
5763                   & "of a loop");
5764             else
5765                Error_Pragma_Arg
5766                  ("block containing pragma %~ must appear immediately within "
5767                   & "the statements of a loop", Constr);
5768             end if;
5769          end Placement_Error;
5770 
5771          --  Local declarations
5772 
5773          Prev : Node_Id;
5774          Stmt : Node_Id;
5775 
5776       --  Start of processing for Check_Loop_Pragma_Placement
5777 
5778       begin
5779          --  Check that pragma appears immediately within a loop statement,
5780          --  ignoring intervening block statements.
5781 
5782          Prev := N;
5783          Stmt := Parent (N);
5784          while Present (Stmt) loop
5785 
5786             --  The pragma or previous block must appear immediately within the
5787             --  current block's declarative or statement part.
5788 
5789             if Nkind (Stmt) = N_Block_Statement then
5790                if (No (Declarations (Stmt))
5791                     or else List_Containing (Prev) /= Declarations (Stmt))
5792                  and then
5793                    List_Containing (Prev) /=
5794                      Statements (Handled_Statement_Sequence (Stmt))
5795                then
5796                   Placement_Error (Prev);
5797                   return;
5798 
5799                --  Keep inspecting the parents because we are now within a
5800                --  chain of nested blocks.
5801 
5802                else
5803                   Prev := Stmt;
5804                   Stmt := Parent (Stmt);
5805                end if;
5806 
5807             --  The pragma or previous block must appear immediately within the
5808             --  statements of the loop.
5809 
5810             elsif Nkind (Stmt) = N_Loop_Statement then
5811                if List_Containing (Prev) /= Statements (Stmt) then
5812                   Placement_Error (Prev);
5813                end if;
5814 
5815                --  Stop the traversal because we reached the innermost loop
5816                --  regardless of whether we encountered an error or not.
5817 
5818                exit;
5819 
5820             --  Ignore a handled statement sequence. Note that this node may
5821             --  be related to a subprogram body in which case we will emit an
5822             --  error on the next iteration of the search.
5823 
5824             elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then
5825                Stmt := Parent (Stmt);
5826 
5827             --  Any other statement breaks the chain from the pragma to the
5828             --  loop.
5829 
5830             else
5831                Placement_Error (Prev);
5832                return;
5833             end if;
5834          end loop;
5835 
5836          --  Check that the current pragma Loop_Invariant or Loop_Variant is
5837          --  grouped together with other such pragmas.
5838 
5839          if Is_Loop_Pragma (N) then
5840 
5841             --  The previous check should have located the related loop
5842 
5843             pragma Assert (Nkind (Stmt) = N_Loop_Statement);
5844             Check_Loop_Pragma_Grouping (Stmt);
5845          end if;
5846       end Check_Loop_Pragma_Placement;
5847 
5848       -------------------------------------------
5849       -- Check_Is_In_Decl_Part_Or_Package_Spec --
5850       -------------------------------------------
5851 
5852       procedure Check_Is_In_Decl_Part_Or_Package_Spec is
5853          P : Node_Id;
5854 
5855       begin
5856          P := Parent (N);
5857          loop
5858             if No (P) then
5859                exit;
5860 
5861             elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
5862                exit;
5863 
5864             elsif Nkind_In (P, N_Package_Specification,
5865                                N_Block_Statement)
5866             then
5867                return;
5868 
5869             --  Note: the following tests seem a little peculiar, because
5870             --  they test for bodies, but if we were in the statement part
5871             --  of the body, we would already have hit the handled statement
5872             --  sequence, so the only way we get here is by being in the
5873             --  declarative part of the body.
5874 
5875             elsif Nkind_In (P, N_Subprogram_Body,
5876                                N_Package_Body,
5877                                N_Task_Body,
5878                                N_Entry_Body)
5879             then
5880                return;
5881             end if;
5882 
5883             P := Parent (P);
5884          end loop;
5885 
5886          Error_Pragma ("pragma% is not in declarative part or package spec");
5887       end Check_Is_In_Decl_Part_Or_Package_Spec;
5888 
5889       -------------------------
5890       -- Check_No_Identifier --
5891       -------------------------
5892 
5893       procedure Check_No_Identifier (Arg : Node_Id) is
5894       begin
5895          if Nkind (Arg) = N_Pragma_Argument_Association
5896            and then Chars (Arg) /= No_Name
5897          then
5898             Error_Pragma_Arg_Ident
5899               ("pragma% does not permit identifier& here", Arg);
5900          end if;
5901       end Check_No_Identifier;
5902 
5903       --------------------------
5904       -- Check_No_Identifiers --
5905       --------------------------
5906 
5907       procedure Check_No_Identifiers is
5908          Arg_Node : Node_Id;
5909       begin
5910          Arg_Node := Arg1;
5911          for J in 1 .. Arg_Count loop
5912             Check_No_Identifier (Arg_Node);
5913             Next (Arg_Node);
5914          end loop;
5915       end Check_No_Identifiers;
5916 
5917       ------------------------
5918       -- Check_No_Link_Name --
5919       ------------------------
5920 
5921       procedure Check_No_Link_Name is
5922       begin
5923          if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then
5924             Arg4 := Arg3;
5925          end if;
5926 
5927          if Present (Arg4) then
5928             Error_Pragma_Arg
5929               ("Link_Name argument not allowed for Import Intrinsic", Arg4);
5930          end if;
5931       end Check_No_Link_Name;
5932 
5933       -------------------------------
5934       -- Check_Optional_Identifier --
5935       -------------------------------
5936 
5937       procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
5938       begin
5939          if Present (Arg)
5940            and then Nkind (Arg) = N_Pragma_Argument_Association
5941            and then Chars (Arg) /= No_Name
5942          then
5943             if Chars (Arg) /= Id then
5944                Error_Msg_Name_1 := Pname;
5945                Error_Msg_Name_2 := Id;
5946                Error_Msg_N ("pragma% argument expects identifier%", Arg);
5947                raise Pragma_Exit;
5948             end if;
5949          end if;
5950       end Check_Optional_Identifier;
5951 
5952       procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
5953       begin
5954          Name_Buffer (1 .. Id'Length) := Id;
5955          Name_Len := Id'Length;
5956          Check_Optional_Identifier (Arg, Name_Find);
5957       end Check_Optional_Identifier;
5958 
5959       -------------------------------------
5960       -- Check_Static_Boolean_Expression --
5961       -------------------------------------
5962 
5963       procedure Check_Static_Boolean_Expression (Expr : Node_Id) is
5964       begin
5965          if Present (Expr) then
5966             Analyze_And_Resolve (Expr, Standard_Boolean);
5967 
5968             if not Is_OK_Static_Expression (Expr) then
5969                Error_Pragma_Arg
5970                  ("expression of pragma % must be static", Expr);
5971             end if;
5972          end if;
5973       end Check_Static_Boolean_Expression;
5974 
5975       -----------------------------
5976       -- Check_Static_Constraint --
5977       -----------------------------
5978 
5979       --  Note: for convenience in writing this procedure, in addition to
5980       --  the officially (i.e. by spec) allowed argument which is always a
5981       --  constraint, it also allows ranges and discriminant associations.
5982       --  Above is not clear ???
5983 
5984       procedure Check_Static_Constraint (Constr : Node_Id) is
5985 
5986          procedure Require_Static (E : Node_Id);
5987          --  Require given expression to be static expression
5988 
5989          --------------------
5990          -- Require_Static --
5991          --------------------
5992 
5993          procedure Require_Static (E : Node_Id) is
5994          begin
5995             if not Is_OK_Static_Expression (E) then
5996                Flag_Non_Static_Expr
5997                  ("non-static constraint not allowed in Unchecked_Union!", E);
5998                raise Pragma_Exit;
5999             end if;
6000          end Require_Static;
6001 
6002       --  Start of processing for Check_Static_Constraint
6003 
6004       begin
6005          case Nkind (Constr) is
6006             when N_Discriminant_Association =>
6007                Require_Static (Expression (Constr));
6008 
6009             when N_Range =>
6010                Require_Static (Low_Bound (Constr));
6011                Require_Static (High_Bound (Constr));
6012 
6013             when N_Attribute_Reference =>
6014                Require_Static (Type_Low_Bound  (Etype (Prefix (Constr))));
6015                Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
6016 
6017             when N_Range_Constraint =>
6018                Check_Static_Constraint (Range_Expression (Constr));
6019 
6020             when N_Index_Or_Discriminant_Constraint =>
6021                declare
6022                   IDC : Entity_Id;
6023                begin
6024                   IDC := First (Constraints (Constr));
6025                   while Present (IDC) loop
6026                      Check_Static_Constraint (IDC);
6027                      Next (IDC);
6028                   end loop;
6029                end;
6030 
6031             when others =>
6032                null;
6033          end case;
6034       end Check_Static_Constraint;
6035 
6036       --------------------------------------
6037       -- Check_Valid_Configuration_Pragma --
6038       --------------------------------------
6039 
6040       --  A configuration pragma must appear in the context clause of a
6041       --  compilation unit, and only other pragmas may precede it. Note that
6042       --  the test also allows use in a configuration pragma file.
6043 
6044       procedure Check_Valid_Configuration_Pragma is
6045       begin
6046          if not Is_Configuration_Pragma then
6047             Error_Pragma ("incorrect placement for configuration pragma%");
6048          end if;
6049       end Check_Valid_Configuration_Pragma;
6050 
6051       -------------------------------------
6052       -- Check_Valid_Library_Unit_Pragma --
6053       -------------------------------------
6054 
6055       procedure Check_Valid_Library_Unit_Pragma is
6056          Plist       : List_Id;
6057          Parent_Node : Node_Id;
6058          Unit_Name   : Entity_Id;
6059          Unit_Kind   : Node_Kind;
6060          Unit_Node   : Node_Id;
6061          Sindex      : Source_File_Index;
6062 
6063       begin
6064          if not Is_List_Member (N) then
6065             Pragma_Misplaced;
6066 
6067          else
6068             Plist := List_Containing (N);
6069             Parent_Node := Parent (Plist);
6070 
6071             if Parent_Node = Empty then
6072                Pragma_Misplaced;
6073 
6074             --  Case of pragma appearing after a compilation unit. In this case
6075             --  it must have an argument with the corresponding name and must
6076             --  be part of the following pragmas of its parent.
6077 
6078             elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
6079                if Plist /= Pragmas_After (Parent_Node) then
6080                   Pragma_Misplaced;
6081 
6082                elsif Arg_Count = 0 then
6083                   Error_Pragma
6084                     ("argument required if outside compilation unit");
6085 
6086                else
6087                   Check_No_Identifiers;
6088                   Check_Arg_Count (1);
6089                   Unit_Node := Unit (Parent (Parent_Node));
6090                   Unit_Kind := Nkind (Unit_Node);
6091 
6092                   Analyze (Get_Pragma_Arg (Arg1));
6093 
6094                   if Unit_Kind = N_Generic_Subprogram_Declaration
6095                     or else Unit_Kind = N_Subprogram_Declaration
6096                   then
6097                      Unit_Name := Defining_Entity (Unit_Node);
6098 
6099                   elsif Unit_Kind in N_Generic_Instantiation then
6100                      Unit_Name := Defining_Entity (Unit_Node);
6101 
6102                   else
6103                      Unit_Name := Cunit_Entity (Current_Sem_Unit);
6104                   end if;
6105 
6106                   if Chars (Unit_Name) /=
6107                      Chars (Entity (Get_Pragma_Arg (Arg1)))
6108                   then
6109                      Error_Pragma_Arg
6110                        ("pragma% argument is not current unit name", Arg1);
6111                   end if;
6112 
6113                   if Ekind (Unit_Name) = E_Package
6114                     and then Present (Renamed_Entity (Unit_Name))
6115                   then
6116                      Error_Pragma ("pragma% not allowed for renamed package");
6117                   end if;
6118                end if;
6119 
6120             --  Pragma appears other than after a compilation unit
6121 
6122             else
6123                --  Here we check for the generic instantiation case and also
6124                --  for the case of processing a generic formal package. We
6125                --  detect these cases by noting that the Sloc on the node
6126                --  does not belong to the current compilation unit.
6127 
6128                Sindex := Source_Index (Current_Sem_Unit);
6129 
6130                if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
6131                   Rewrite (N, Make_Null_Statement (Loc));
6132                   return;
6133 
6134                --  If before first declaration, the pragma applies to the
6135                --  enclosing unit, and the name if present must be this name.
6136 
6137                elsif Is_Before_First_Decl (N, Plist) then
6138                   Unit_Node := Unit_Declaration_Node (Current_Scope);
6139                   Unit_Kind := Nkind (Unit_Node);
6140 
6141                   if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
6142                      Pragma_Misplaced;
6143 
6144                   elsif Unit_Kind = N_Subprogram_Body
6145                     and then not Acts_As_Spec (Unit_Node)
6146                   then
6147                      Pragma_Misplaced;
6148 
6149                   elsif Nkind (Parent_Node) = N_Package_Body then
6150                      Pragma_Misplaced;
6151 
6152                   elsif Nkind (Parent_Node) = N_Package_Specification
6153                     and then Plist = Private_Declarations (Parent_Node)
6154                   then
6155                      Pragma_Misplaced;
6156 
6157                   elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
6158                           or else Nkind (Parent_Node) =
6159                                              N_Generic_Subprogram_Declaration)
6160                     and then Plist = Generic_Formal_Declarations (Parent_Node)
6161                   then
6162                      Pragma_Misplaced;
6163 
6164                   elsif Arg_Count > 0 then
6165                      Analyze (Get_Pragma_Arg (Arg1));
6166 
6167                      if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
6168                         Error_Pragma_Arg
6169                           ("name in pragma% must be enclosing unit", Arg1);
6170                      end if;
6171 
6172                   --  It is legal to have no argument in this context
6173 
6174                   else
6175                      return;
6176                   end if;
6177 
6178                --  Error if not before first declaration. This is because a
6179                --  library unit pragma argument must be the name of a library
6180                --  unit (RM 10.1.5(7)), but the only names permitted in this
6181                --  context are (RM 10.1.5(6)) names of subprogram declarations,
6182                --  generic subprogram declarations or generic instantiations.
6183 
6184                else
6185                   Error_Pragma
6186                     ("pragma% misplaced, must be before first declaration");
6187                end if;
6188             end if;
6189          end if;
6190       end Check_Valid_Library_Unit_Pragma;
6191 
6192       -------------------
6193       -- Check_Variant --
6194       -------------------
6195 
6196       procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
6197          Clist : constant Node_Id := Component_List (Variant);
6198          Comp  : Node_Id;
6199 
6200       begin
6201          Comp := First (Component_Items (Clist));
6202          while Present (Comp) loop
6203             Check_Component (Comp, UU_Typ, In_Variant_Part => True);
6204             Next (Comp);
6205          end loop;
6206       end Check_Variant;
6207 
6208       ---------------------------
6209       -- Ensure_Aggregate_Form --
6210       ---------------------------
6211 
6212       procedure Ensure_Aggregate_Form (Arg : Node_Id) is
6213          CFSD    : constant Boolean    := Get_Comes_From_Source_Default;
6214          Expr    : constant Node_Id    := Expression (Arg);
6215          Loc     : constant Source_Ptr := Sloc (Expr);
6216          Comps   : List_Id := No_List;
6217          Exprs   : List_Id := No_List;
6218          Nam     : Name_Id := No_Name;
6219          Nam_Loc : Source_Ptr;
6220 
6221       begin
6222          --  The pragma argument is in positional form:
6223 
6224          --    pragma Depends (Nam => ...)
6225          --                    ^
6226          --                    Chars field
6227 
6228          --  Note that the Sloc of the Chars field is the Sloc of the pragma
6229          --  argument association.
6230 
6231          if Nkind (Arg) = N_Pragma_Argument_Association then
6232             Nam     := Chars (Arg);
6233             Nam_Loc := Sloc (Arg);
6234 
6235             --  Remove the pragma argument name as this will be captured in the
6236             --  aggregate.
6237 
6238             Set_Chars (Arg, No_Name);
6239          end if;
6240 
6241          --  The argument is already in aggregate form, but the presence of a
6242          --  name causes this to be interpreted as named association which in
6243          --  turn must be converted into an aggregate.
6244 
6245          --    pragma Global (In_Out => (A, B, C))
6246          --                   ^         ^
6247          --                   name      aggregate
6248 
6249          --    pragma Global ((In_Out => (A, B, C)))
6250          --                   ^          ^
6251          --                   aggregate  aggregate
6252 
6253          if Nkind (Expr) = N_Aggregate then
6254             if Nam = No_Name then
6255                return;
6256             end if;
6257 
6258          --  Do not transform a null argument into an aggregate as N_Null has
6259          --  special meaning in formal verification pragmas.
6260 
6261          elsif Nkind (Expr) = N_Null then
6262             return;
6263          end if;
6264 
6265          --  Everything comes from source if the original comes from source
6266 
6267          Set_Comes_From_Source_Default (Comes_From_Source (Arg));
6268 
6269          --  Positional argument is transformed into an aggregate with an
6270          --  Expressions list.
6271 
6272          if Nam = No_Name then
6273             Exprs := New_List (Relocate_Node (Expr));
6274 
6275          --  An associative argument is transformed into an aggregate with
6276          --  Component_Associations.
6277 
6278          else
6279             Comps := New_List (
6280               Make_Component_Association (Loc,
6281                 Choices    => New_List (Make_Identifier (Nam_Loc, Nam)),
6282                 Expression => Relocate_Node (Expr)));
6283          end if;
6284 
6285          Set_Expression (Arg,
6286            Make_Aggregate (Loc,
6287              Component_Associations => Comps,
6288              Expressions            => Exprs));
6289 
6290          --  Restore Comes_From_Source default
6291 
6292          Set_Comes_From_Source_Default (CFSD);
6293       end Ensure_Aggregate_Form;
6294 
6295       ------------------
6296       -- Error_Pragma --
6297       ------------------
6298 
6299       procedure Error_Pragma (Msg : String) is
6300       begin
6301          Error_Msg_Name_1 := Pname;
6302          Error_Msg_N (Fix_Error (Msg), N);
6303          raise Pragma_Exit;
6304       end Error_Pragma;
6305 
6306       ----------------------
6307       -- Error_Pragma_Arg --
6308       ----------------------
6309 
6310       procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
6311       begin
6312          Error_Msg_Name_1 := Pname;
6313          Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg));
6314          raise Pragma_Exit;
6315       end Error_Pragma_Arg;
6316 
6317       procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
6318       begin
6319          Error_Msg_Name_1 := Pname;
6320          Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg));
6321          Error_Pragma_Arg (Msg2, Arg);
6322       end Error_Pragma_Arg;
6323 
6324       ----------------------------
6325       -- Error_Pragma_Arg_Ident --
6326       ----------------------------
6327 
6328       procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
6329       begin
6330          Error_Msg_Name_1 := Pname;
6331          Error_Msg_N (Fix_Error (Msg), Arg);
6332          raise Pragma_Exit;
6333       end Error_Pragma_Arg_Ident;
6334 
6335       ----------------------
6336       -- Error_Pragma_Ref --
6337       ----------------------
6338 
6339       procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
6340       begin
6341          Error_Msg_Name_1 := Pname;
6342          Error_Msg_Sloc := Sloc (Ref);
6343          Error_Msg_NE (Fix_Error (Msg), N, Ref);
6344          raise Pragma_Exit;
6345       end Error_Pragma_Ref;
6346 
6347       ------------------------
6348       -- Find_Lib_Unit_Name --
6349       ------------------------
6350 
6351       function Find_Lib_Unit_Name return Entity_Id is
6352       begin
6353          --  Return inner compilation unit entity, for case of nested
6354          --  categorization pragmas. This happens in generic unit.
6355 
6356          if Nkind (Parent (N)) = N_Package_Specification
6357            and then Defining_Entity (Parent (N)) /= Current_Scope
6358          then
6359             return Defining_Entity (Parent (N));
6360          else
6361             return Current_Scope;
6362          end if;
6363       end Find_Lib_Unit_Name;
6364 
6365       ----------------------------
6366       -- Find_Program_Unit_Name --
6367       ----------------------------
6368 
6369       procedure Find_Program_Unit_Name (Id : Node_Id) is
6370          Unit_Name : Entity_Id;
6371          Unit_Kind : Node_Kind;
6372          P         : constant Node_Id := Parent (N);
6373 
6374       begin
6375          if Nkind (P) = N_Compilation_Unit then
6376             Unit_Kind := Nkind (Unit (P));
6377 
6378             if Nkind_In (Unit_Kind, N_Subprogram_Declaration,
6379                                     N_Package_Declaration)
6380               or else Unit_Kind in N_Generic_Declaration
6381             then
6382                Unit_Name := Defining_Entity (Unit (P));
6383 
6384                if Chars (Id) = Chars (Unit_Name) then
6385                   Set_Entity (Id, Unit_Name);
6386                   Set_Etype (Id, Etype (Unit_Name));
6387                else
6388                   Set_Etype (Id, Any_Type);
6389                   Error_Pragma
6390                     ("cannot find program unit referenced by pragma%");
6391                end if;
6392 
6393             else
6394                Set_Etype (Id, Any_Type);
6395                Error_Pragma ("pragma% inapplicable to this unit");
6396             end if;
6397 
6398          else
6399             Analyze (Id);
6400          end if;
6401       end Find_Program_Unit_Name;
6402 
6403       -----------------------------------------
6404       -- Find_Unique_Parameterless_Procedure --
6405       -----------------------------------------
6406 
6407       function Find_Unique_Parameterless_Procedure
6408         (Name : Entity_Id;
6409          Arg  : Node_Id) return Entity_Id
6410       is
6411          Proc : Entity_Id := Empty;
6412 
6413       begin
6414          --  The body of this procedure needs some comments ???
6415 
6416          if not Is_Entity_Name (Name) then
6417             Error_Pragma_Arg
6418               ("argument of pragma% must be entity name", Arg);
6419 
6420          elsif not Is_Overloaded (Name) then
6421             Proc := Entity (Name);
6422 
6423             if Ekind (Proc) /= E_Procedure
6424               or else Present (First_Formal (Proc))
6425             then
6426                Error_Pragma_Arg
6427                  ("argument of pragma% must be parameterless procedure", Arg);
6428             end if;
6429 
6430          else
6431             declare
6432                Found : Boolean := False;
6433                It    : Interp;
6434                Index : Interp_Index;
6435 
6436             begin
6437                Get_First_Interp (Name, Index, It);
6438                while Present (It.Nam) loop
6439                   Proc := It.Nam;
6440 
6441                   if Ekind (Proc) = E_Procedure
6442                     and then No (First_Formal (Proc))
6443                   then
6444                      if not Found then
6445                         Found := True;
6446                         Set_Entity (Name, Proc);
6447                         Set_Is_Overloaded (Name, False);
6448                      else
6449                         Error_Pragma_Arg
6450                           ("ambiguous handler name for pragma% ", Arg);
6451                      end if;
6452                   end if;
6453 
6454                   Get_Next_Interp (Index, It);
6455                end loop;
6456 
6457                if not Found then
6458                   Error_Pragma_Arg
6459                     ("argument of pragma% must be parameterless procedure",
6460                      Arg);
6461                else
6462                   Proc := Entity (Name);
6463                end if;
6464             end;
6465          end if;
6466 
6467          return Proc;
6468       end Find_Unique_Parameterless_Procedure;
6469 
6470       ---------------
6471       -- Fix_Error --
6472       ---------------
6473 
6474       function Fix_Error (Msg : String) return String is
6475          Res      : String (Msg'Range) := Msg;
6476          Res_Last : Natural            := Msg'Last;
6477          J        : Natural;
6478 
6479       begin
6480          --  If we have a rewriting of another pragma, go to that pragma
6481 
6482          if Is_Rewrite_Substitution (N)
6483            and then Nkind (Original_Node (N)) = N_Pragma
6484          then
6485             Error_Msg_Name_1 := Pragma_Name (Original_Node (N));
6486          end if;
6487 
6488          --  Case where pragma comes from an aspect specification
6489 
6490          if From_Aspect_Specification (N) then
6491 
6492             --  Change appearence of "pragma" in message to "aspect"
6493 
6494             J := Res'First;
6495             while J <= Res_Last - 5 loop
6496                if Res (J .. J + 5) = "pragma" then
6497                   Res (J .. J + 5) := "aspect";
6498                   J := J + 6;
6499 
6500                else
6501                   J := J + 1;
6502                end if;
6503             end loop;
6504 
6505             --  Change "argument of" at start of message to "entity for"
6506 
6507             if Res'Length > 11
6508               and then Res (Res'First .. Res'First + 10) = "argument of"
6509             then
6510                Res (Res'First .. Res'First + 9) := "entity for";
6511                Res (Res'First + 10 .. Res_Last - 1) :=
6512                  Res (Res'First + 11 .. Res_Last);
6513                Res_Last := Res_Last - 1;
6514             end if;
6515 
6516             --  Change "argument" at start of message to "entity"
6517 
6518             if Res'Length > 8
6519               and then Res (Res'First .. Res'First + 7) = "argument"
6520             then
6521                Res (Res'First .. Res'First + 5) := "entity";
6522                Res (Res'First + 6 .. Res_Last - 2) :=
6523                  Res (Res'First + 8 .. Res_Last);
6524                Res_Last := Res_Last - 2;
6525             end if;
6526 
6527             --  Get name from corresponding aspect
6528 
6529             Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
6530          end if;
6531 
6532          --  Return possibly modified message
6533 
6534          return Res (Res'First .. Res_Last);
6535       end Fix_Error;
6536 
6537       -------------------------
6538       -- Gather_Associations --
6539       -------------------------
6540 
6541       procedure Gather_Associations
6542         (Names : Name_List;
6543          Args  : out Args_List)
6544       is
6545          Arg : Node_Id;
6546 
6547       begin
6548          --  Initialize all parameters to Empty
6549 
6550          for J in Args'Range loop
6551             Args (J) := Empty;
6552          end loop;
6553 
6554          --  That's all we have to do if there are no argument associations
6555 
6556          if No (Pragma_Argument_Associations (N)) then
6557             return;
6558          end if;
6559 
6560          --  Otherwise first deal with any positional parameters present
6561 
6562          Arg := First (Pragma_Argument_Associations (N));
6563          for Index in Args'Range loop
6564             exit when No (Arg) or else Chars (Arg) /= No_Name;
6565             Args (Index) := Get_Pragma_Arg (Arg);
6566             Next (Arg);
6567          end loop;
6568 
6569          --  Positional parameters all processed, if any left, then we
6570          --  have too many positional parameters.
6571 
6572          if Present (Arg) and then Chars (Arg) = No_Name then
6573             Error_Pragma_Arg
6574               ("too many positional associations for pragma%", Arg);
6575          end if;
6576 
6577          --  Process named parameters if any are present
6578 
6579          while Present (Arg) loop
6580             if Chars (Arg) = No_Name then
6581                Error_Pragma_Arg
6582                  ("positional association cannot follow named association",
6583                   Arg);
6584 
6585             else
6586                for Index in Names'Range loop
6587                   if Names (Index) = Chars (Arg) then
6588                      if Present (Args (Index)) then
6589                         Error_Pragma_Arg
6590                           ("duplicate argument association for pragma%", Arg);
6591                      else
6592                         Args (Index) := Get_Pragma_Arg (Arg);
6593                         exit;
6594                      end if;
6595                   end if;
6596 
6597                   if Index = Names'Last then
6598                      Error_Msg_Name_1 := Pname;
6599                      Error_Msg_N ("pragma% does not allow & argument", Arg);
6600 
6601                      --  Check for possible misspelling
6602 
6603                      for Index1 in Names'Range loop
6604                         if Is_Bad_Spelling_Of
6605                              (Chars (Arg), Names (Index1))
6606                         then
6607                            Error_Msg_Name_1 := Names (Index1);
6608                            Error_Msg_N -- CODEFIX
6609                              ("\possible misspelling of%", Arg);
6610                            exit;
6611                         end if;
6612                      end loop;
6613 
6614                      raise Pragma_Exit;
6615                   end if;
6616                end loop;
6617             end if;
6618 
6619             Next (Arg);
6620          end loop;
6621       end Gather_Associations;
6622 
6623       -----------------
6624       -- GNAT_Pragma --
6625       -----------------
6626 
6627       procedure GNAT_Pragma is
6628       begin
6629          --  We need to check the No_Implementation_Pragmas restriction for
6630          --  the case of a pragma from source. Note that the case of aspects
6631          --  generating corresponding pragmas marks these pragmas as not being
6632          --  from source, so this test also catches that case.
6633 
6634          if Comes_From_Source (N) then
6635             Check_Restriction (No_Implementation_Pragmas, N);
6636          end if;
6637       end GNAT_Pragma;
6638 
6639       --------------------------
6640       -- Is_Before_First_Decl --
6641       --------------------------
6642 
6643       function Is_Before_First_Decl
6644         (Pragma_Node : Node_Id;
6645          Decls       : List_Id) return Boolean
6646       is
6647          Item : Node_Id := First (Decls);
6648 
6649       begin
6650          --  Only other pragmas can come before this pragma
6651 
6652          loop
6653             if No (Item) or else Nkind (Item) /= N_Pragma then
6654                return False;
6655 
6656             elsif Item = Pragma_Node then
6657                return True;
6658             end if;
6659 
6660             Next (Item);
6661          end loop;
6662       end Is_Before_First_Decl;
6663 
6664       -----------------------------
6665       -- Is_Configuration_Pragma --
6666       -----------------------------
6667 
6668       --  A configuration pragma must appear in the context clause of a
6669       --  compilation unit, and only other pragmas may precede it. Note that
6670       --  the test below also permits use in a configuration pragma file.
6671 
6672       function Is_Configuration_Pragma return Boolean is
6673          Lis : constant List_Id := List_Containing (N);
6674          Par : constant Node_Id := Parent (N);
6675          Prg : Node_Id;
6676 
6677       begin
6678          --  If no parent, then we are in the configuration pragma file,
6679          --  so the placement is definitely appropriate.
6680 
6681          if No (Par) then
6682             return True;
6683 
6684          --  Otherwise we must be in the context clause of a compilation unit
6685          --  and the only thing allowed before us in the context list is more
6686          --  configuration pragmas.
6687 
6688          elsif Nkind (Par) = N_Compilation_Unit
6689            and then Context_Items (Par) = Lis
6690          then
6691             Prg := First (Lis);
6692 
6693             loop
6694                if Prg = N then
6695                   return True;
6696                elsif Nkind (Prg) /= N_Pragma then
6697                   return False;
6698                end if;
6699 
6700                Next (Prg);
6701             end loop;
6702 
6703          else
6704             return False;
6705          end if;
6706       end Is_Configuration_Pragma;
6707 
6708       --------------------------
6709       -- Is_In_Context_Clause --
6710       --------------------------
6711 
6712       function Is_In_Context_Clause return Boolean is
6713          Plist       : List_Id;
6714          Parent_Node : Node_Id;
6715 
6716       begin
6717          if not Is_List_Member (N) then
6718             return False;
6719 
6720          else
6721             Plist := List_Containing (N);
6722             Parent_Node := Parent (Plist);
6723 
6724             if Parent_Node = Empty
6725               or else Nkind (Parent_Node) /= N_Compilation_Unit
6726               or else Context_Items (Parent_Node) /= Plist
6727             then
6728                return False;
6729             end if;
6730          end if;
6731 
6732          return True;
6733       end Is_In_Context_Clause;
6734 
6735       ---------------------------------
6736       -- Is_Static_String_Expression --
6737       ---------------------------------
6738 
6739       function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
6740          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
6741          Lit  : constant Boolean := Nkind (Argx) = N_String_Literal;
6742 
6743       begin
6744          Analyze_And_Resolve (Argx);
6745 
6746          --  Special case Ada 83, where the expression will never be static,
6747          --  but we will return true if we had a string literal to start with.
6748 
6749          if Ada_Version = Ada_83 then
6750             return Lit;
6751 
6752          --  Normal case, true only if we end up with a string literal that
6753          --  is marked as being the result of evaluating a static expression.
6754 
6755          else
6756             return Is_OK_Static_Expression (Argx)
6757               and then Nkind (Argx) = N_String_Literal;
6758          end if;
6759 
6760       end Is_Static_String_Expression;
6761 
6762       ----------------------
6763       -- Pragma_Misplaced --
6764       ----------------------
6765 
6766       procedure Pragma_Misplaced is
6767       begin
6768          Error_Pragma ("incorrect placement of pragma%");
6769       end Pragma_Misplaced;
6770 
6771       ------------------------------------------------
6772       -- Process_Atomic_Independent_Shared_Volatile --
6773       ------------------------------------------------
6774 
6775       procedure Process_Atomic_Independent_Shared_Volatile is
6776          procedure Set_Atomic_VFA (E : Entity_Id);
6777          --  Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6778          --  no explicit alignment was given, set alignment to unknown, since
6779          --  back end knows what the alignment requirements are for atomic and
6780          --  full access arrays. Note: this is necessary for derived types.
6781 
6782          --------------------
6783          -- Set_Atomic_VFA --
6784          --------------------
6785 
6786          procedure Set_Atomic_VFA (E : Entity_Id) is
6787          begin
6788             if Prag_Id = Pragma_Volatile_Full_Access then
6789                Set_Is_Volatile_Full_Access (E);
6790             else
6791                Set_Is_Atomic (E);
6792             end if;
6793 
6794             if not Has_Alignment_Clause (E) then
6795                Set_Alignment (E, Uint_0);
6796             end if;
6797          end Set_Atomic_VFA;
6798 
6799          --  Local variables
6800 
6801          Decl  : Node_Id;
6802          E     : Entity_Id;
6803          E_Arg : Node_Id;
6804 
6805       --  Start of processing for Process_Atomic_Independent_Shared_Volatile
6806 
6807       begin
6808          Check_Ada_83_Warning;
6809          Check_No_Identifiers;
6810          Check_Arg_Count (1);
6811          Check_Arg_Is_Local_Name (Arg1);
6812          E_Arg := Get_Pragma_Arg (Arg1);
6813 
6814          if Etype (E_Arg) = Any_Type then
6815             return;
6816          end if;
6817 
6818          E    := Entity (E_Arg);
6819          Decl := Declaration_Node (E);
6820 
6821          --  A pragma that applies to a Ghost entity becomes Ghost for the
6822          --  purposes of legality checks and removal of ignored Ghost code.
6823 
6824          Mark_Pragma_As_Ghost (N, E);
6825 
6826          --  Check duplicate before we chain ourselves
6827 
6828          Check_Duplicate_Pragma (E);
6829 
6830          --  Check Atomic and VFA used together
6831 
6832          if (Is_Atomic (E) and then Prag_Id = Pragma_Volatile_Full_Access)
6833            or else (Is_Volatile_Full_Access (E)
6834                      and then (Prag_Id = Pragma_Atomic
6835                                  or else
6836                                Prag_Id = Pragma_Shared))
6837          then
6838             Error_Pragma
6839               ("cannot have Volatile_Full_Access and Atomic for same entity");
6840          end if;
6841 
6842          --  Check for applying VFA to an entity which has aliased component
6843 
6844          if Prag_Id = Pragma_Volatile_Full_Access then
6845             declare
6846                Comp         : Entity_Id;
6847                Aliased_Comp : Boolean := False;
6848                --  Set True if aliased component present
6849 
6850             begin
6851                if Is_Array_Type (Etype (E)) then
6852                   Aliased_Comp := Has_Aliased_Components (Etype (E));
6853 
6854                --  Record case, too bad Has_Aliased_Components is not also
6855                --  set for records, should it be ???
6856 
6857                elsif Is_Record_Type (Etype (E)) then
6858                   Comp := First_Component_Or_Discriminant (Etype (E));
6859                   while Present (Comp) loop
6860                      if Is_Aliased (Comp)
6861                        or else Is_Aliased (Etype (Comp))
6862                      then
6863                         Aliased_Comp := True;
6864                         exit;
6865                      end if;
6866 
6867                      Next_Component_Or_Discriminant (Comp);
6868                   end loop;
6869                end if;
6870 
6871                if Aliased_Comp then
6872                   Error_Pragma
6873                     ("cannot apply Volatile_Full_Access (aliased component "
6874                      & "present)");
6875                end if;
6876             end;
6877          end if;
6878 
6879          --  Now check appropriateness of the entity
6880 
6881          if Is_Type (E) then
6882             if Rep_Item_Too_Early (E, N)
6883                  or else
6884                Rep_Item_Too_Late (E, N)
6885             then
6886                return;
6887             else
6888                Check_First_Subtype (Arg1);
6889             end if;
6890 
6891             --  Attribute belongs on the base type. If the view of the type is
6892             --  currently private, it also belongs on the underlying type.
6893 
6894             if Prag_Id = Pragma_Atomic
6895                  or else
6896                Prag_Id = Pragma_Shared
6897                  or else
6898                Prag_Id = Pragma_Volatile_Full_Access
6899             then
6900                Set_Atomic_VFA (E);
6901                Set_Atomic_VFA (Base_Type (E));
6902                Set_Atomic_VFA (Underlying_Type (E));
6903             end if;
6904 
6905             --  Atomic/Shared/Volatile_Full_Access imply Independent
6906 
6907             if Prag_Id /= Pragma_Volatile then
6908                Set_Is_Independent (E);
6909                Set_Is_Independent (Base_Type (E));
6910                Set_Is_Independent (Underlying_Type (E));
6911 
6912                if Prag_Id = Pragma_Independent then
6913                   Record_Independence_Check (N, Base_Type (E));
6914                end if;
6915             end if;
6916 
6917             --  Atomic/Shared/Volatile_Full_Access imply Volatile
6918 
6919             if Prag_Id /= Pragma_Independent then
6920                Set_Is_Volatile (E);
6921                Set_Is_Volatile (Base_Type (E));
6922                Set_Is_Volatile (Underlying_Type (E));
6923 
6924                Set_Treat_As_Volatile (E);
6925                Set_Treat_As_Volatile (Underlying_Type (E));
6926             end if;
6927 
6928          elsif Nkind (Decl) = N_Object_Declaration
6929            or else (Nkind (Decl) = N_Component_Declaration
6930                      and then Original_Record_Component (E) = E)
6931          then
6932             if Rep_Item_Too_Late (E, N) then
6933                return;
6934             end if;
6935 
6936             if Prag_Id = Pragma_Atomic
6937                  or else
6938                Prag_Id = Pragma_Shared
6939                  or else
6940                Prag_Id = Pragma_Volatile_Full_Access
6941             then
6942                if Prag_Id = Pragma_Volatile_Full_Access then
6943                   Set_Is_Volatile_Full_Access (E);
6944                else
6945                   Set_Is_Atomic (E);
6946                end if;
6947 
6948                --  If the object declaration has an explicit initialization, a
6949                --  temporary may have to be created to hold the expression, to
6950                --  ensure that access to the object remain atomic.
6951 
6952                if Nkind (Parent (E)) = N_Object_Declaration
6953                  and then Present (Expression (Parent (E)))
6954                then
6955                   Set_Has_Delayed_Freeze (E);
6956                end if;
6957             end if;
6958 
6959             --  Atomic/Shared/Volatile_Full_Access imply Independent
6960 
6961             if Prag_Id /= Pragma_Volatile then
6962                Set_Is_Independent (E);
6963 
6964                if Prag_Id = Pragma_Independent then
6965                   Record_Independence_Check (N, E);
6966                end if;
6967             end if;
6968 
6969             --  Atomic/Shared/Volatile_Full_Access imply Volatile
6970 
6971             if Prag_Id /= Pragma_Independent then
6972                Set_Is_Volatile (E);
6973                Set_Treat_As_Volatile (E);
6974             end if;
6975 
6976          else
6977             Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
6978          end if;
6979 
6980          --  The following check is only relevant when SPARK_Mode is on as
6981          --  this is not a standard Ada legality rule. Pragma Volatile can
6982          --  only apply to a full type declaration or an object declaration
6983          --  (SPARK RM C.6(1)). Original_Node is necessary to account for
6984          --  untagged derived types that are rewritten as subtypes of their
6985          --  respective root types.
6986 
6987          if SPARK_Mode = On
6988            and then Prag_Id = Pragma_Volatile
6989            and then
6990              not Nkind_In (Original_Node (Decl), N_Full_Type_Declaration,
6991                                                  N_Object_Declaration)
6992          then
6993             Error_Pragma_Arg
6994               ("argument of pragma % must denote a full type or object "
6995                & "declaration", Arg1);
6996          end if;
6997       end Process_Atomic_Independent_Shared_Volatile;
6998 
6999       -------------------------------------------
7000       -- Process_Compile_Time_Warning_Or_Error --
7001       -------------------------------------------
7002 
7003       procedure Process_Compile_Time_Warning_Or_Error is
7004          Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
7005 
7006       begin
7007          Check_Arg_Count (2);
7008          Check_No_Identifiers;
7009          Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
7010          Analyze_And_Resolve (Arg1x, Standard_Boolean);
7011 
7012          if Compile_Time_Known_Value (Arg1x) then
7013             if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
7014                declare
7015                   Str   : constant String_Id :=
7016                             Strval (Get_Pragma_Arg (Arg2));
7017                   Len   : constant Nat := String_Length (Str);
7018                   Cont  : Boolean;
7019                   Ptr   : Nat;
7020                   CC    : Char_Code;
7021                   C     : Character;
7022                   Cent  : constant Entity_Id :=
7023                             Cunit_Entity (Current_Sem_Unit);
7024 
7025                   Force : constant Boolean :=
7026                             Prag_Id = Pragma_Compile_Time_Warning
7027                               and then
7028                                 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
7029                               and then (Ekind (Cent) /= E_Package
7030                                          or else not In_Private_Part (Cent));
7031                   --  Set True if this is the warning case, and we are in the
7032                   --  visible part of a package spec, or in a subprogram spec,
7033                   --  in which case we want to force the client to see the
7034                   --  warning, even though it is not in the main unit.
7035 
7036                begin
7037                   --  Loop through segments of message separated by line feeds.
7038                   --  We output these segments as separate messages with
7039                   --  continuation marks for all but the first.
7040 
7041                   Cont := False;
7042                   Ptr := 1;
7043                   loop
7044                      Error_Msg_Strlen := 0;
7045 
7046                      --  Loop to copy characters from argument to error message
7047                      --  string buffer.
7048 
7049                      loop
7050                         exit when Ptr > Len;
7051                         CC := Get_String_Char (Str, Ptr);
7052                         Ptr := Ptr + 1;
7053 
7054                         --  Ignore wide chars ??? else store character
7055 
7056                         if In_Character_Range (CC) then
7057                            C := Get_Character (CC);
7058                            exit when C = ASCII.LF;
7059                            Error_Msg_Strlen := Error_Msg_Strlen + 1;
7060                            Error_Msg_String (Error_Msg_Strlen) := C;
7061                         end if;
7062                      end loop;
7063 
7064                      --  Here with one line ready to go
7065 
7066                      Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
7067 
7068                      --  If this is a warning in a spec, then we want clients
7069                      --  to see the warning, so mark the message with the
7070                      --  special sequence !! to force the warning. In the case
7071                      --  of a package spec, we do not force this if we are in
7072                      --  the private part of the spec.
7073 
7074                      if Force then
7075                         if Cont = False then
7076                            Error_Msg_N ("<<~!!", Arg1);
7077                            Cont := True;
7078                         else
7079                            Error_Msg_N ("\<<~!!", Arg1);
7080                         end if;
7081 
7082                      --  Error, rather than warning, or in a body, so we do not
7083                      --  need to force visibility for client (error will be
7084                      --  output in any case, and this is the situation in which
7085                      --  we do not want a client to get a warning, since the
7086                      --  warning is in the body or the spec private part).
7087 
7088                      else
7089                         if Cont = False then
7090                            Error_Msg_N ("<<~", Arg1);
7091                            Cont := True;
7092                         else
7093                            Error_Msg_N ("\<<~", Arg1);
7094                         end if;
7095                      end if;
7096 
7097                      exit when Ptr > Len;
7098                   end loop;
7099                end;
7100             end if;
7101          end if;
7102       end Process_Compile_Time_Warning_Or_Error;
7103 
7104       ------------------------
7105       -- Process_Convention --
7106       ------------------------
7107 
7108       procedure Process_Convention
7109         (C   : out Convention_Id;
7110          Ent : out Entity_Id)
7111       is
7112          Cname : Name_Id;
7113 
7114          procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
7115          --  Called if we have more than one Export/Import/Convention pragma.
7116          --  This is generally illegal, but we have a special case of allowing
7117          --  Import and Interface to coexist if they specify the convention in
7118          --  a consistent manner. We are allowed to do this, since Interface is
7119          --  an implementation defined pragma, and we choose to do it since we
7120          --  know Rational allows this combination. S is the entity id of the
7121          --  subprogram in question. This procedure also sets the special flag
7122          --  Import_Interface_Present in both pragmas in the case where we do
7123          --  have matching Import and Interface pragmas.
7124 
7125          procedure Set_Convention_From_Pragma (E : Entity_Id);
7126          --  Set convention in entity E, and also flag that the entity has a
7127          --  convention pragma. If entity is for a private or incomplete type,
7128          --  also set convention and flag on underlying type. This procedure
7129          --  also deals with the special case of C_Pass_By_Copy convention,
7130          --  and error checks for inappropriate convention specification.
7131 
7132          -------------------------------
7133          -- Diagnose_Multiple_Pragmas --
7134          -------------------------------
7135 
7136          procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
7137             Pdec : constant Node_Id := Declaration_Node (S);
7138             Decl : Node_Id;
7139             Err  : Boolean;
7140 
7141             function Same_Convention (Decl : Node_Id) return Boolean;
7142             --  Decl is a pragma node. This function returns True if this
7143             --  pragma has a first argument that is an identifier with a
7144             --  Chars field corresponding to the Convention_Id C.
7145 
7146             function Same_Name (Decl : Node_Id) return Boolean;
7147             --  Decl is a pragma node. This function returns True if this
7148             --  pragma has a second argument that is an identifier with a
7149             --  Chars field that matches the Chars of the current subprogram.
7150 
7151             ---------------------
7152             -- Same_Convention --
7153             ---------------------
7154 
7155             function Same_Convention (Decl : Node_Id) return Boolean is
7156                Arg1 : constant Node_Id :=
7157                         First (Pragma_Argument_Associations (Decl));
7158 
7159             begin
7160                if Present (Arg1) then
7161                   declare
7162                      Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
7163                   begin
7164                      if Nkind (Arg) = N_Identifier
7165                        and then Is_Convention_Name (Chars (Arg))
7166                        and then Get_Convention_Id (Chars (Arg)) = C
7167                      then
7168                         return True;
7169                      end if;
7170                   end;
7171                end if;
7172 
7173                return False;
7174             end Same_Convention;
7175 
7176             ---------------
7177             -- Same_Name --
7178             ---------------
7179 
7180             function Same_Name (Decl : Node_Id) return Boolean is
7181                Arg1 : constant Node_Id :=
7182                         First (Pragma_Argument_Associations (Decl));
7183                Arg2 : Node_Id;
7184 
7185             begin
7186                if No (Arg1) then
7187                   return False;
7188                end if;
7189 
7190                Arg2 := Next (Arg1);
7191 
7192                if No (Arg2) then
7193                   return False;
7194                end if;
7195 
7196                declare
7197                   Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
7198                begin
7199                   if Nkind (Arg) = N_Identifier
7200                     and then Chars (Arg) = Chars (S)
7201                   then
7202                      return True;
7203                   end if;
7204                end;
7205 
7206                return False;
7207             end Same_Name;
7208 
7209          --  Start of processing for Diagnose_Multiple_Pragmas
7210 
7211          begin
7212             Err := True;
7213 
7214             --  Definitely give message if we have Convention/Export here
7215 
7216             if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
7217                null;
7218 
7219                --  If we have an Import or Export, scan back from pragma to
7220                --  find any previous pragma applying to the same procedure.
7221                --  The scan will be terminated by the start of the list, or
7222                --  hitting the subprogram declaration. This won't allow one
7223                --  pragma to appear in the public part and one in the private
7224                --  part, but that seems very unlikely in practice.
7225 
7226             else
7227                Decl := Prev (N);
7228                while Present (Decl) and then Decl /= Pdec loop
7229 
7230                   --  Look for pragma with same name as us
7231 
7232                   if Nkind (Decl) = N_Pragma
7233                     and then Same_Name (Decl)
7234                   then
7235                      --  Give error if same as our pragma or Export/Convention
7236 
7237                      if Nam_In (Pragma_Name (Decl), Name_Export,
7238                                                     Name_Convention,
7239                                                     Pragma_Name (N))
7240                      then
7241                         exit;
7242 
7243                      --  Case of Import/Interface or the other way round
7244 
7245                      elsif Nam_In (Pragma_Name (Decl), Name_Interface,
7246                                                        Name_Import)
7247                      then
7248                         --  Here we know that we have Import and Interface. It
7249                         --  doesn't matter which way round they are. See if
7250                         --  they specify the same convention. If so, all OK,
7251                         --  and set special flags to stop other messages
7252 
7253                         if Same_Convention (Decl) then
7254                            Set_Import_Interface_Present (N);
7255                            Set_Import_Interface_Present (Decl);
7256                            Err := False;
7257 
7258                         --  If different conventions, special message
7259 
7260                         else
7261                            Error_Msg_Sloc := Sloc (Decl);
7262                            Error_Pragma_Arg
7263                              ("convention differs from that given#", Arg1);
7264                            return;
7265                         end if;
7266                      end if;
7267                   end if;
7268 
7269                   Next (Decl);
7270                end loop;
7271             end if;
7272 
7273             --  Give message if needed if we fall through those tests
7274             --  except on Relaxed_RM_Semantics where we let go: either this
7275             --  is a case accepted/ignored by other Ada compilers (e.g.
7276             --  a mix of Convention and Import), or another error will be
7277             --  generated later (e.g. using both Import and Export).
7278 
7279             if Err and not Relaxed_RM_Semantics then
7280                Error_Pragma_Arg
7281                  ("at most one Convention/Export/Import pragma is allowed",
7282                   Arg2);
7283             end if;
7284          end Diagnose_Multiple_Pragmas;
7285 
7286          --------------------------------
7287          -- Set_Convention_From_Pragma --
7288          --------------------------------
7289 
7290          procedure Set_Convention_From_Pragma (E : Entity_Id) is
7291          begin
7292             --  Ada 2005 (AI-430): Check invalid attempt to change convention
7293             --  for an overridden dispatching operation. Technically this is
7294             --  an amendment and should only be done in Ada 2005 mode. However,
7295             --  this is clearly a mistake, since the problem that is addressed
7296             --  by this AI is that there is a clear gap in the RM.
7297 
7298             if Is_Dispatching_Operation (E)
7299               and then Present (Overridden_Operation (E))
7300               and then C /= Convention (Overridden_Operation (E))
7301             then
7302                Error_Pragma_Arg
7303                  ("cannot change convention for overridden dispatching "
7304                   & "operation", Arg1);
7305             end if;
7306 
7307             --  Special checks for Convention_Stdcall
7308 
7309             if C = Convention_Stdcall then
7310 
7311                --  A dispatching call is not allowed. A dispatching subprogram
7312                --  cannot be used to interface to the Win32 API, so in fact
7313                --  this check does not impose any effective restriction.
7314 
7315                if Is_Dispatching_Operation (E) then
7316                   Error_Msg_Sloc := Sloc (E);
7317 
7318                   --  Note: make this unconditional so that if there is more
7319                   --  than one call to which the pragma applies, we get a
7320                   --  message for each call. Also don't use Error_Pragma,
7321                   --  so that we get multiple messages.
7322 
7323                   Error_Msg_N
7324                     ("dispatching subprogram# cannot use Stdcall convention!",
7325                      Arg1);
7326 
7327                --  Subprograms are not allowed
7328 
7329                elsif not Is_Subprogram_Or_Generic_Subprogram (E)
7330 
7331                  --  A variable is OK
7332 
7333                  and then Ekind (E) /= E_Variable
7334 
7335                  --  An access to subprogram is also allowed
7336 
7337                  and then not
7338                    (Is_Access_Type (E)
7339                      and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
7340 
7341                  --  Allow internal call to set convention of subprogram type
7342 
7343                  and then not (Ekind (E) = E_Subprogram_Type)
7344                then
7345                   Error_Pragma_Arg
7346                     ("second argument of pragma% must be subprogram (type)",
7347                      Arg2);
7348                end if;
7349             end if;
7350 
7351             --  Set the convention
7352 
7353             Set_Convention (E, C);
7354             Set_Has_Convention_Pragma (E);
7355 
7356             --  For the case of a record base type, also set the convention of
7357             --  any anonymous access types declared in the record which do not
7358             --  currently have a specified convention.
7359 
7360             if Is_Record_Type (E) and then Is_Base_Type (E) then
7361                declare
7362                   Comp : Node_Id;
7363 
7364                begin
7365                   Comp := First_Component (E);
7366                   while Present (Comp) loop
7367                      if Present (Etype (Comp))
7368                        and then Ekind_In (Etype (Comp),
7369                                           E_Anonymous_Access_Type,
7370                                           E_Anonymous_Access_Subprogram_Type)
7371                        and then not Has_Convention_Pragma (Comp)
7372                      then
7373                         Set_Convention (Comp, C);
7374                      end if;
7375 
7376                      Next_Component (Comp);
7377                   end loop;
7378                end;
7379             end if;
7380 
7381             --  Deal with incomplete/private type case, where underlying type
7382             --  is available, so set convention of that underlying type.
7383 
7384             if Is_Incomplete_Or_Private_Type (E)
7385               and then Present (Underlying_Type (E))
7386             then
7387                Set_Convention            (Underlying_Type (E), C);
7388                Set_Has_Convention_Pragma (Underlying_Type (E), True);
7389             end if;
7390 
7391             --  A class-wide type should inherit the convention of the specific
7392             --  root type (although this isn't specified clearly by the RM).
7393 
7394             if Is_Type (E) and then Present (Class_Wide_Type (E)) then
7395                Set_Convention (Class_Wide_Type (E), C);
7396             end if;
7397 
7398             --  If the entity is a record type, then check for special case of
7399             --  C_Pass_By_Copy, which is treated the same as C except that the
7400             --  special record flag is set. This convention is only permitted
7401             --  on record types (see AI95-00131).
7402 
7403             if Cname = Name_C_Pass_By_Copy then
7404                if Is_Record_Type (E) then
7405                   Set_C_Pass_By_Copy (Base_Type (E));
7406                elsif Is_Incomplete_Or_Private_Type (E)
7407                  and then Is_Record_Type (Underlying_Type (E))
7408                then
7409                   Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
7410                else
7411                   Error_Pragma_Arg
7412                     ("C_Pass_By_Copy convention allowed only for record type",
7413                      Arg2);
7414                end if;
7415             end if;
7416 
7417             --  If the entity is a derived boolean type, check for the special
7418             --  case of convention C, C++, or Fortran, where we consider any
7419             --  nonzero value to represent true.
7420 
7421             if Is_Discrete_Type (E)
7422               and then Root_Type (Etype (E)) = Standard_Boolean
7423               and then
7424                 (C = Convention_C
7425                    or else
7426                  C = Convention_CPP
7427                    or else
7428                  C = Convention_Fortran)
7429             then
7430                Set_Nonzero_Is_True (Base_Type (E));
7431             end if;
7432          end Set_Convention_From_Pragma;
7433 
7434          --  Local variables
7435 
7436          Comp_Unit : Unit_Number_Type;
7437          E         : Entity_Id;
7438          E1        : Entity_Id;
7439          Id        : Node_Id;
7440 
7441       --  Start of processing for Process_Convention
7442 
7443       begin
7444          Check_At_Least_N_Arguments (2);
7445          Check_Optional_Identifier (Arg1, Name_Convention);
7446          Check_Arg_Is_Identifier (Arg1);
7447          Cname := Chars (Get_Pragma_Arg (Arg1));
7448 
7449          --  C_Pass_By_Copy is treated as a synonym for convention C (this is
7450          --  tested again below to set the critical flag).
7451 
7452          if Cname = Name_C_Pass_By_Copy then
7453             C := Convention_C;
7454 
7455          --  Otherwise we must have something in the standard convention list
7456 
7457          elsif Is_Convention_Name (Cname) then
7458             C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
7459 
7460          --  Otherwise warn on unrecognized convention
7461 
7462          else
7463             if Warn_On_Export_Import then
7464                Error_Msg_N
7465                  ("??unrecognized convention name, C assumed",
7466                   Get_Pragma_Arg (Arg1));
7467             end if;
7468 
7469             C := Convention_C;
7470          end if;
7471 
7472          Check_Optional_Identifier (Arg2, Name_Entity);
7473          Check_Arg_Is_Local_Name (Arg2);
7474 
7475          Id := Get_Pragma_Arg (Arg2);
7476          Analyze (Id);
7477 
7478          if not Is_Entity_Name (Id) then
7479             Error_Pragma_Arg ("entity name required", Arg2);
7480          end if;
7481 
7482          E := Entity (Id);
7483 
7484          --  Set entity to return
7485 
7486          Ent := E;
7487 
7488          --  Ada_Pass_By_Copy special checking
7489 
7490          if C = Convention_Ada_Pass_By_Copy then
7491             if not Is_First_Subtype (E) then
7492                Error_Pragma_Arg
7493                  ("convention `Ada_Pass_By_Copy` only allowed for types",
7494                   Arg2);
7495             end if;
7496 
7497             if Is_By_Reference_Type (E) then
7498                Error_Pragma_Arg
7499                  ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7500                   & "type", Arg1);
7501             end if;
7502 
7503          --  Ada_Pass_By_Reference special checking
7504 
7505          elsif C = Convention_Ada_Pass_By_Reference then
7506             if not Is_First_Subtype (E) then
7507                Error_Pragma_Arg
7508                  ("convention `Ada_Pass_By_Reference` only allowed for types",
7509                   Arg2);
7510             end if;
7511 
7512             if Is_By_Copy_Type (E) then
7513                Error_Pragma_Arg
7514                  ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7515                   & "type", Arg1);
7516             end if;
7517          end if;
7518 
7519          --  Go to renamed subprogram if present, since convention applies to
7520          --  the actual renamed entity, not to the renaming entity. If the
7521          --  subprogram is inherited, go to parent subprogram.
7522 
7523          if Is_Subprogram (E)
7524            and then Present (Alias (E))
7525          then
7526             if Nkind (Parent (Declaration_Node (E))) =
7527                                        N_Subprogram_Renaming_Declaration
7528             then
7529                if Scope (E) /= Scope (Alias (E)) then
7530                   Error_Pragma_Ref
7531                     ("cannot apply pragma% to non-local entity&#", E);
7532                end if;
7533 
7534                E := Alias (E);
7535 
7536             elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
7537                                         N_Private_Extension_Declaration)
7538               and then Scope (E) = Scope (Alias (E))
7539             then
7540                E := Alias (E);
7541 
7542                --  Return the parent subprogram the entity was inherited from
7543 
7544                Ent := E;
7545             end if;
7546          end if;
7547 
7548          --  Check that we are not applying this to a specless body. Relax this
7549          --  check if Relaxed_RM_Semantics to accomodate other Ada compilers.
7550 
7551          if Is_Subprogram (E)
7552            and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
7553            and then not Relaxed_RM_Semantics
7554          then
7555             Error_Pragma
7556               ("pragma% requires separate spec and must come before body");
7557          end if;
7558 
7559          --  Check that we are not applying this to a named constant
7560 
7561          if Ekind_In (E, E_Named_Integer, E_Named_Real) then
7562             Error_Msg_Name_1 := Pname;
7563             Error_Msg_N
7564               ("cannot apply pragma% to named constant!",
7565                Get_Pragma_Arg (Arg2));
7566             Error_Pragma_Arg
7567               ("\supply appropriate type for&!", Arg2);
7568          end if;
7569 
7570          if Ekind (E) = E_Enumeration_Literal then
7571             Error_Pragma ("enumeration literal not allowed for pragma%");
7572          end if;
7573 
7574          --  Check for rep item appearing too early or too late
7575 
7576          if Etype (E) = Any_Type
7577            or else Rep_Item_Too_Early (E, N)
7578          then
7579             raise Pragma_Exit;
7580 
7581          elsif Present (Underlying_Type (E)) then
7582             E := Underlying_Type (E);
7583          end if;
7584 
7585          if Rep_Item_Too_Late (E, N) then
7586             raise Pragma_Exit;
7587          end if;
7588 
7589          if Has_Convention_Pragma (E) then
7590             Diagnose_Multiple_Pragmas (E);
7591 
7592          elsif Convention (E) = Convention_Protected
7593            or else Ekind (Scope (E)) = E_Protected_Type
7594          then
7595             Error_Pragma_Arg
7596               ("a protected operation cannot be given a different convention",
7597                 Arg2);
7598          end if;
7599 
7600          --  For Intrinsic, a subprogram is required
7601 
7602          if C = Convention_Intrinsic
7603            and then not Is_Subprogram_Or_Generic_Subprogram (E)
7604          then
7605             --  Accept Intrinsic Export on types if Relaxed_RM_Semantics
7606 
7607             if not (Is_Type (E) and then Relaxed_RM_Semantics) then
7608                Error_Pragma_Arg
7609                  ("second argument of pragma% must be a subprogram", Arg2);
7610             end if;
7611          end if;
7612 
7613          --  Deal with non-subprogram cases
7614 
7615          if not Is_Subprogram_Or_Generic_Subprogram (E) then
7616             Set_Convention_From_Pragma (E);
7617 
7618             if Is_Type (E) then
7619 
7620                --  The pragma must apply to a first subtype, but it can also
7621                --  apply to a generic type in a generic formal part, in which
7622                --  case it will also appear in the corresponding instance.
7623 
7624                if Is_Generic_Type (E) or else In_Instance then
7625                   null;
7626                else
7627                   Check_First_Subtype (Arg2);
7628                end if;
7629 
7630                Set_Convention_From_Pragma (Base_Type (E));
7631 
7632                --  For access subprograms, we must set the convention on the
7633                --  internally generated directly designated type as well.
7634 
7635                if Ekind (E) = E_Access_Subprogram_Type then
7636                   Set_Convention_From_Pragma (Directly_Designated_Type (E));
7637                end if;
7638             end if;
7639 
7640          --  For the subprogram case, set proper convention for all homonyms
7641          --  in same scope and the same declarative part, i.e. the same
7642          --  compilation unit.
7643 
7644          else
7645             Comp_Unit := Get_Source_Unit (E);
7646             Set_Convention_From_Pragma (E);
7647 
7648             --  Treat a pragma Import as an implicit body, and pragma import
7649             --  as implicit reference (for navigation in GPS).
7650 
7651             if Prag_Id = Pragma_Import then
7652                Generate_Reference (E, Id, 'b');
7653 
7654             --  For exported entities we restrict the generation of references
7655             --  to entities exported to foreign languages since entities
7656             --  exported to Ada do not provide further information to GPS and
7657             --  add undesired references to the output of the gnatxref tool.
7658 
7659             elsif Prag_Id = Pragma_Export
7660               and then Convention (E) /= Convention_Ada
7661             then
7662                Generate_Reference (E, Id, 'i');
7663             end if;
7664 
7665             --  If the pragma comes from from an aspect, it only applies to the
7666             --  given entity, not its homonyms.
7667 
7668             if From_Aspect_Specification (N) then
7669                return;
7670             end if;
7671 
7672             --  Otherwise Loop through the homonyms of the pragma argument's
7673             --  entity, an apply convention to those in the current scope.
7674 
7675             E1 := Ent;
7676 
7677             loop
7678                E1 := Homonym (E1);
7679                exit when No (E1) or else Scope (E1) /= Current_Scope;
7680 
7681                --  Ignore entry for which convention is already set
7682 
7683                if Has_Convention_Pragma (E1) then
7684                   goto Continue;
7685                end if;
7686 
7687                --  Do not set the pragma on inherited operations or on formal
7688                --  subprograms.
7689 
7690                if Comes_From_Source (E1)
7691                  and then Comp_Unit = Get_Source_Unit (E1)
7692                  and then not Is_Formal_Subprogram (E1)
7693                  and then Nkind (Original_Node (Parent (E1))) /=
7694                                                     N_Full_Type_Declaration
7695                then
7696                   if Present (Alias (E1))
7697                     and then Scope (E1) /= Scope (Alias (E1))
7698                   then
7699                      Error_Pragma_Ref
7700                        ("cannot apply pragma% to non-local entity& declared#",
7701                         E1);
7702                   end if;
7703 
7704                   Set_Convention_From_Pragma (E1);
7705 
7706                   if Prag_Id = Pragma_Import then
7707                      Generate_Reference (E1, Id, 'b');
7708                   end if;
7709                end if;
7710 
7711             <<Continue>>
7712                null;
7713             end loop;
7714          end if;
7715       end Process_Convention;
7716 
7717       ----------------------------------------
7718       -- Process_Disable_Enable_Atomic_Sync --
7719       ----------------------------------------
7720 
7721       procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
7722       begin
7723          Check_No_Identifiers;
7724          Check_At_Most_N_Arguments (1);
7725 
7726          --  Modeled internally as
7727          --    pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7728 
7729          Rewrite (N,
7730            Make_Pragma (Loc,
7731              Pragma_Identifier            =>
7732                Make_Identifier (Loc, Nam),
7733              Pragma_Argument_Associations => New_List (
7734                Make_Pragma_Argument_Association (Loc,
7735                  Expression =>
7736                    Make_Identifier (Loc, Name_Atomic_Synchronization)))));
7737 
7738          if Present (Arg1) then
7739             Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
7740          end if;
7741 
7742          Analyze (N);
7743       end Process_Disable_Enable_Atomic_Sync;
7744 
7745       -------------------------------------------------
7746       -- Process_Extended_Import_Export_Internal_Arg --
7747       -------------------------------------------------
7748 
7749       procedure Process_Extended_Import_Export_Internal_Arg
7750         (Arg_Internal : Node_Id := Empty)
7751       is
7752       begin
7753          if No (Arg_Internal) then
7754             Error_Pragma ("Internal parameter required for pragma%");
7755          end if;
7756 
7757          if Nkind (Arg_Internal) = N_Identifier then
7758             null;
7759 
7760          elsif Nkind (Arg_Internal) = N_Operator_Symbol
7761            and then (Prag_Id = Pragma_Import_Function
7762                        or else
7763                      Prag_Id = Pragma_Export_Function)
7764          then
7765             null;
7766 
7767          else
7768             Error_Pragma_Arg
7769               ("wrong form for Internal parameter for pragma%", Arg_Internal);
7770          end if;
7771 
7772          Check_Arg_Is_Local_Name (Arg_Internal);
7773       end Process_Extended_Import_Export_Internal_Arg;
7774 
7775       --------------------------------------------------
7776       -- Process_Extended_Import_Export_Object_Pragma --
7777       --------------------------------------------------
7778 
7779       procedure Process_Extended_Import_Export_Object_Pragma
7780         (Arg_Internal : Node_Id;
7781          Arg_External : Node_Id;
7782          Arg_Size     : Node_Id)
7783       is
7784          Def_Id : Entity_Id;
7785 
7786       begin
7787          Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7788          Def_Id := Entity (Arg_Internal);
7789 
7790          if not Ekind_In (Def_Id, E_Constant, E_Variable) then
7791             Error_Pragma_Arg
7792               ("pragma% must designate an object", Arg_Internal);
7793          end if;
7794 
7795          if Has_Rep_Pragma (Def_Id, Name_Common_Object)
7796               or else
7797             Has_Rep_Pragma (Def_Id, Name_Psect_Object)
7798          then
7799             Error_Pragma_Arg
7800               ("previous Common/Psect_Object applies, pragma % not permitted",
7801                Arg_Internal);
7802          end if;
7803 
7804          if Rep_Item_Too_Late (Def_Id, N) then
7805             raise Pragma_Exit;
7806          end if;
7807 
7808          Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
7809 
7810          if Present (Arg_Size) then
7811             Check_Arg_Is_External_Name (Arg_Size);
7812          end if;
7813 
7814          --  Export_Object case
7815 
7816          if Prag_Id = Pragma_Export_Object then
7817             if not Is_Library_Level_Entity (Def_Id) then
7818                Error_Pragma_Arg
7819                  ("argument for pragma% must be library level entity",
7820                   Arg_Internal);
7821             end if;
7822 
7823             if Ekind (Current_Scope) = E_Generic_Package then
7824                Error_Pragma ("pragma& cannot appear in a generic unit");
7825             end if;
7826 
7827             if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
7828                Error_Pragma_Arg
7829                  ("exported object must have compile time known size",
7830                   Arg_Internal);
7831             end if;
7832 
7833             if Warn_On_Export_Import and then Is_Exported (Def_Id) then
7834                Error_Msg_N ("??duplicate Export_Object pragma", N);
7835             else
7836                Set_Exported (Def_Id, Arg_Internal);
7837             end if;
7838 
7839          --  Import_Object case
7840 
7841          else
7842             if Is_Concurrent_Type (Etype (Def_Id)) then
7843                Error_Pragma_Arg
7844                  ("cannot use pragma% for task/protected object",
7845                   Arg_Internal);
7846             end if;
7847 
7848             if Ekind (Def_Id) = E_Constant then
7849                Error_Pragma_Arg
7850                  ("cannot import a constant", Arg_Internal);
7851             end if;
7852 
7853             if Warn_On_Export_Import
7854               and then Has_Discriminants (Etype (Def_Id))
7855             then
7856                Error_Msg_N
7857                  ("imported value must be initialized??", Arg_Internal);
7858             end if;
7859 
7860             if Warn_On_Export_Import
7861               and then Is_Access_Type (Etype (Def_Id))
7862             then
7863                Error_Pragma_Arg
7864                  ("cannot import object of an access type??", Arg_Internal);
7865             end if;
7866 
7867             if Warn_On_Export_Import
7868               and then Is_Imported (Def_Id)
7869             then
7870                Error_Msg_N ("??duplicate Import_Object pragma", N);
7871 
7872             --  Check for explicit initialization present. Note that an
7873             --  initialization generated by the code generator, e.g. for an
7874             --  access type, does not count here.
7875 
7876             elsif Present (Expression (Parent (Def_Id)))
7877                and then
7878                  Comes_From_Source
7879                    (Original_Node (Expression (Parent (Def_Id))))
7880             then
7881                Error_Msg_Sloc := Sloc (Def_Id);
7882                Error_Pragma_Arg
7883                  ("imported entities cannot be initialized (RM B.1(24))",
7884                   "\no initialization allowed for & declared#", Arg1);
7885             else
7886                Set_Imported (Def_Id);
7887                Note_Possible_Modification (Arg_Internal, Sure => False);
7888             end if;
7889          end if;
7890       end Process_Extended_Import_Export_Object_Pragma;
7891 
7892       ------------------------------------------------------
7893       -- Process_Extended_Import_Export_Subprogram_Pragma --
7894       ------------------------------------------------------
7895 
7896       procedure Process_Extended_Import_Export_Subprogram_Pragma
7897         (Arg_Internal                 : Node_Id;
7898          Arg_External                 : Node_Id;
7899          Arg_Parameter_Types          : Node_Id;
7900          Arg_Result_Type              : Node_Id := Empty;
7901          Arg_Mechanism                : Node_Id;
7902          Arg_Result_Mechanism         : Node_Id := Empty)
7903       is
7904          Ent       : Entity_Id;
7905          Def_Id    : Entity_Id;
7906          Hom_Id    : Entity_Id;
7907          Formal    : Entity_Id;
7908          Ambiguous : Boolean;
7909          Match     : Boolean;
7910 
7911          function Same_Base_Type
7912           (Ptype  : Node_Id;
7913            Formal : Entity_Id) return Boolean;
7914          --  Determines if Ptype references the type of Formal. Note that only
7915          --  the base types need to match according to the spec. Ptype here is
7916          --  the argument from the pragma, which is either a type name, or an
7917          --  access attribute.
7918 
7919          --------------------
7920          -- Same_Base_Type --
7921          --------------------
7922 
7923          function Same_Base_Type
7924            (Ptype  : Node_Id;
7925             Formal : Entity_Id) return Boolean
7926          is
7927             Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
7928             Pref : Node_Id;
7929 
7930          begin
7931             --  Case where pragma argument is typ'Access
7932 
7933             if Nkind (Ptype) = N_Attribute_Reference
7934               and then Attribute_Name (Ptype) = Name_Access
7935             then
7936                Pref := Prefix (Ptype);
7937                Find_Type (Pref);
7938 
7939                if not Is_Entity_Name (Pref)
7940                  or else Entity (Pref) = Any_Type
7941                then
7942                   raise Pragma_Exit;
7943                end if;
7944 
7945                --  We have a match if the corresponding argument is of an
7946                --  anonymous access type, and its designated type matches the
7947                --  type of the prefix of the access attribute
7948 
7949                return Ekind (Ftyp) = E_Anonymous_Access_Type
7950                  and then Base_Type (Entity (Pref)) =
7951                             Base_Type (Etype (Designated_Type (Ftyp)));
7952 
7953             --  Case where pragma argument is a type name
7954 
7955             else
7956                Find_Type (Ptype);
7957 
7958                if not Is_Entity_Name (Ptype)
7959                  or else Entity (Ptype) = Any_Type
7960                then
7961                   raise Pragma_Exit;
7962                end if;
7963 
7964                --  We have a match if the corresponding argument is of the type
7965                --  given in the pragma (comparing base types)
7966 
7967                return Base_Type (Entity (Ptype)) = Ftyp;
7968             end if;
7969          end Same_Base_Type;
7970 
7971       --  Start of processing for
7972       --  Process_Extended_Import_Export_Subprogram_Pragma
7973 
7974       begin
7975          Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
7976          Ent := Empty;
7977          Ambiguous := False;
7978 
7979          --  Loop through homonyms (overloadings) of the entity
7980 
7981          Hom_Id := Entity (Arg_Internal);
7982          while Present (Hom_Id) loop
7983             Def_Id := Get_Base_Subprogram (Hom_Id);
7984 
7985             --  We need a subprogram in the current scope
7986 
7987             if not Is_Subprogram (Def_Id)
7988               or else Scope (Def_Id) /= Current_Scope
7989             then
7990                null;
7991 
7992             else
7993                Match := True;
7994 
7995                --  Pragma cannot apply to subprogram body
7996 
7997                if Is_Subprogram (Def_Id)
7998                  and then Nkind (Parent (Declaration_Node (Def_Id))) =
7999                                                              N_Subprogram_Body
8000                then
8001                   Error_Pragma
8002                     ("pragma% requires separate spec"
8003                       & " and must come before body");
8004                end if;
8005 
8006                --  Test result type if given, note that the result type
8007                --  parameter can only be present for the function cases.
8008 
8009                if Present (Arg_Result_Type)
8010                  and then not Same_Base_Type (Arg_Result_Type, Def_Id)
8011                then
8012                   Match := False;
8013 
8014                elsif Etype (Def_Id) /= Standard_Void_Type
8015                  and then
8016                    Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure)
8017                then
8018                   Match := False;
8019 
8020                --  Test parameter types if given. Note that this parameter
8021                --  has not been analyzed (and must not be, since it is
8022                --  semantic nonsense), so we get it as the parser left it.
8023 
8024                elsif Present (Arg_Parameter_Types) then
8025                   Check_Matching_Types : declare
8026                      Formal : Entity_Id;
8027                      Ptype  : Node_Id;
8028 
8029                   begin
8030                      Formal := First_Formal (Def_Id);
8031 
8032                      if Nkind (Arg_Parameter_Types) = N_Null then
8033                         if Present (Formal) then
8034                            Match := False;
8035                         end if;
8036 
8037                      --  A list of one type, e.g. (List) is parsed as
8038                      --  a parenthesized expression.
8039 
8040                      elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
8041                        and then Paren_Count (Arg_Parameter_Types) = 1
8042                      then
8043                         if No (Formal)
8044                           or else Present (Next_Formal (Formal))
8045                         then
8046                            Match := False;
8047                         else
8048                            Match :=
8049                              Same_Base_Type (Arg_Parameter_Types, Formal);
8050                         end if;
8051 
8052                      --  A list of more than one type is parsed as a aggregate
8053 
8054                      elsif Nkind (Arg_Parameter_Types) = N_Aggregate
8055                        and then Paren_Count (Arg_Parameter_Types) = 0
8056                      then
8057                         Ptype := First (Expressions (Arg_Parameter_Types));
8058                         while Present (Ptype) or else Present (Formal) loop
8059                            if No (Ptype)
8060                              or else No (Formal)
8061                              or else not Same_Base_Type (Ptype, Formal)
8062                            then
8063                               Match := False;
8064                               exit;
8065                            else
8066                               Next_Formal (Formal);
8067                               Next (Ptype);
8068                            end if;
8069                         end loop;
8070 
8071                      --  Anything else is of the wrong form
8072 
8073                      else
8074                         Error_Pragma_Arg
8075                           ("wrong form for Parameter_Types parameter",
8076                            Arg_Parameter_Types);
8077                      end if;
8078                   end Check_Matching_Types;
8079                end if;
8080 
8081                --  Match is now False if the entry we found did not match
8082                --  either a supplied Parameter_Types or Result_Types argument
8083 
8084                if Match then
8085                   if No (Ent) then
8086                      Ent := Def_Id;
8087 
8088                   --  Ambiguous case, the flag Ambiguous shows if we already
8089                   --  detected this and output the initial messages.
8090 
8091                   else
8092                      if not Ambiguous then
8093                         Ambiguous := True;
8094                         Error_Msg_Name_1 := Pname;
8095                         Error_Msg_N
8096                           ("pragma% does not uniquely identify subprogram!",
8097                            N);
8098                         Error_Msg_Sloc := Sloc (Ent);
8099                         Error_Msg_N ("matching subprogram #!", N);
8100                         Ent := Empty;
8101                      end if;
8102 
8103                      Error_Msg_Sloc := Sloc (Def_Id);
8104                      Error_Msg_N ("matching subprogram #!", N);
8105                   end if;
8106                end if;
8107             end if;
8108 
8109             Hom_Id := Homonym (Hom_Id);
8110          end loop;
8111 
8112          --  See if we found an entry
8113 
8114          if No (Ent) then
8115             if not Ambiguous then
8116                if Is_Generic_Subprogram (Entity (Arg_Internal)) then
8117                   Error_Pragma
8118                     ("pragma% cannot be given for generic subprogram");
8119                else
8120                   Error_Pragma
8121                     ("pragma% does not identify local subprogram");
8122                end if;
8123             end if;
8124 
8125             return;
8126          end if;
8127 
8128          --  Import pragmas must be for imported entities
8129 
8130          if Prag_Id = Pragma_Import_Function
8131               or else
8132             Prag_Id = Pragma_Import_Procedure
8133               or else
8134             Prag_Id = Pragma_Import_Valued_Procedure
8135          then
8136             if not Is_Imported (Ent) then
8137                Error_Pragma
8138                  ("pragma Import or Interface must precede pragma%");
8139             end if;
8140 
8141          --  Here we have the Export case which can set the entity as exported
8142 
8143          --  But does not do so if the specified external name is null, since
8144          --  that is taken as a signal in DEC Ada 83 (with which we want to be
8145          --  compatible) to request no external name.
8146 
8147          elsif Nkind (Arg_External) = N_String_Literal
8148            and then String_Length (Strval (Arg_External)) = 0
8149          then
8150             null;
8151 
8152          --  In all other cases, set entity as exported
8153 
8154          else
8155             Set_Exported (Ent, Arg_Internal);
8156          end if;
8157 
8158          --  Special processing for Valued_Procedure cases
8159 
8160          if Prag_Id = Pragma_Import_Valued_Procedure
8161            or else
8162             Prag_Id = Pragma_Export_Valued_Procedure
8163          then
8164             Formal := First_Formal (Ent);
8165 
8166             if No (Formal) then
8167                Error_Pragma ("at least one parameter required for pragma%");
8168 
8169             elsif Ekind (Formal) /= E_Out_Parameter then
8170                Error_Pragma ("first parameter must have mode out for pragma%");
8171 
8172             else
8173                Set_Is_Valued_Procedure (Ent);
8174             end if;
8175          end if;
8176 
8177          Set_Extended_Import_Export_External_Name (Ent, Arg_External);
8178 
8179          --  Process Result_Mechanism argument if present. We have already
8180          --  checked that this is only allowed for the function case.
8181 
8182          if Present (Arg_Result_Mechanism) then
8183             Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
8184          end if;
8185 
8186          --  Process Mechanism parameter if present. Note that this parameter
8187          --  is not analyzed, and must not be analyzed since it is semantic
8188          --  nonsense, so we get it in exactly as the parser left it.
8189 
8190          if Present (Arg_Mechanism) then
8191             declare
8192                Formal : Entity_Id;
8193                Massoc : Node_Id;
8194                Mname  : Node_Id;
8195                Choice : Node_Id;
8196 
8197             begin
8198                --  A single mechanism association without a formal parameter
8199                --  name is parsed as a parenthesized expression. All other
8200                --  cases are parsed as aggregates, so we rewrite the single
8201                --  parameter case as an aggregate for consistency.
8202 
8203                if Nkind (Arg_Mechanism) /= N_Aggregate
8204                  and then Paren_Count (Arg_Mechanism) = 1
8205                then
8206                   Rewrite (Arg_Mechanism,
8207                     Make_Aggregate (Sloc (Arg_Mechanism),
8208                       Expressions => New_List (
8209                         Relocate_Node (Arg_Mechanism))));
8210                end if;
8211 
8212                --  Case of only mechanism name given, applies to all formals
8213 
8214                if Nkind (Arg_Mechanism) /= N_Aggregate then
8215                   Formal := First_Formal (Ent);
8216                   while Present (Formal) loop
8217                      Set_Mechanism_Value (Formal, Arg_Mechanism);
8218                      Next_Formal (Formal);
8219                   end loop;
8220 
8221                --  Case of list of mechanism associations given
8222 
8223                else
8224                   if Null_Record_Present (Arg_Mechanism) then
8225                      Error_Pragma_Arg
8226                        ("inappropriate form for Mechanism parameter",
8227                         Arg_Mechanism);
8228                   end if;
8229 
8230                   --  Deal with positional ones first
8231 
8232                   Formal := First_Formal (Ent);
8233 
8234                   if Present (Expressions (Arg_Mechanism)) then
8235                      Mname := First (Expressions (Arg_Mechanism));
8236                      while Present (Mname) loop
8237                         if No (Formal) then
8238                            Error_Pragma_Arg
8239                              ("too many mechanism associations", Mname);
8240                         end if;
8241 
8242                         Set_Mechanism_Value (Formal, Mname);
8243                         Next_Formal (Formal);
8244                         Next (Mname);
8245                      end loop;
8246                   end if;
8247 
8248                   --  Deal with named entries
8249 
8250                   if Present (Component_Associations (Arg_Mechanism)) then
8251                      Massoc := First (Component_Associations (Arg_Mechanism));
8252                      while Present (Massoc) loop
8253                         Choice := First (Choices (Massoc));
8254 
8255                         if Nkind (Choice) /= N_Identifier
8256                           or else Present (Next (Choice))
8257                         then
8258                            Error_Pragma_Arg
8259                              ("incorrect form for mechanism association",
8260                               Massoc);
8261                         end if;
8262 
8263                         Formal := First_Formal (Ent);
8264                         loop
8265                            if No (Formal) then
8266                               Error_Pragma_Arg
8267                                 ("parameter name & not present", Choice);
8268                            end if;
8269 
8270                            if Chars (Choice) = Chars (Formal) then
8271                               Set_Mechanism_Value
8272                                 (Formal, Expression (Massoc));
8273 
8274                               --  Set entity on identifier (needed by ASIS)
8275 
8276                               Set_Entity (Choice, Formal);
8277 
8278                               exit;
8279                            end if;
8280 
8281                            Next_Formal (Formal);
8282                         end loop;
8283 
8284                         Next (Massoc);
8285                      end loop;
8286                   end if;
8287                end if;
8288             end;
8289          end if;
8290       end Process_Extended_Import_Export_Subprogram_Pragma;
8291 
8292       --------------------------
8293       -- Process_Generic_List --
8294       --------------------------
8295 
8296       procedure Process_Generic_List is
8297          Arg : Node_Id;
8298          Exp : Node_Id;
8299 
8300       begin
8301          Check_No_Identifiers;
8302          Check_At_Least_N_Arguments (1);
8303 
8304          --  Check all arguments are names of generic units or instances
8305 
8306          Arg := Arg1;
8307          while Present (Arg) loop
8308             Exp := Get_Pragma_Arg (Arg);
8309             Analyze (Exp);
8310 
8311             if not Is_Entity_Name (Exp)
8312               or else
8313                 (not Is_Generic_Instance (Entity (Exp))
8314                   and then
8315                  not Is_Generic_Unit (Entity (Exp)))
8316             then
8317                Error_Pragma_Arg
8318                  ("pragma% argument must be name of generic unit/instance",
8319                   Arg);
8320             end if;
8321 
8322             Next (Arg);
8323          end loop;
8324       end Process_Generic_List;
8325 
8326       ------------------------------------
8327       -- Process_Import_Predefined_Type --
8328       ------------------------------------
8329 
8330       procedure Process_Import_Predefined_Type is
8331          Loc  : constant Source_Ptr := Sloc (N);
8332          Elmt : Elmt_Id;
8333          Ftyp : Node_Id := Empty;
8334          Decl : Node_Id;
8335          Def  : Node_Id;
8336          Nam  : Name_Id;
8337 
8338       begin
8339          String_To_Name_Buffer (Strval (Expression (Arg3)));
8340          Nam := Name_Find;
8341 
8342          Elmt := First_Elmt (Predefined_Float_Types);
8343          while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
8344             Next_Elmt (Elmt);
8345          end loop;
8346 
8347          Ftyp := Node (Elmt);
8348 
8349          if Present (Ftyp) then
8350 
8351             --  Don't build a derived type declaration, because predefined C
8352             --  types have no declaration anywhere, so cannot really be named.
8353             --  Instead build a full type declaration, starting with an
8354             --  appropriate type definition is built
8355 
8356             if Is_Floating_Point_Type (Ftyp) then
8357                Def := Make_Floating_Point_Definition (Loc,
8358                  Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
8359                  Make_Real_Range_Specification (Loc,
8360                    Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
8361                    Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
8362 
8363             --  Should never have a predefined type we cannot handle
8364 
8365             else
8366                raise Program_Error;
8367             end if;
8368 
8369             --  Build and insert a Full_Type_Declaration, which will be
8370             --  analyzed as soon as this list entry has been analyzed.
8371 
8372             Decl := Make_Full_Type_Declaration (Loc,
8373               Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
8374               Type_Definition => Def);
8375 
8376             Insert_After (N, Decl);
8377             Mark_Rewrite_Insertion (Decl);
8378 
8379          else
8380             Error_Pragma_Arg ("no matching type found for pragma%",
8381             Arg2);
8382          end if;
8383       end Process_Import_Predefined_Type;
8384 
8385       ---------------------------------
8386       -- Process_Import_Or_Interface --
8387       ---------------------------------
8388 
8389       procedure Process_Import_Or_Interface is
8390          C      : Convention_Id;
8391          Def_Id : Entity_Id;
8392          Hom_Id : Entity_Id;
8393 
8394       begin
8395          --  In Relaxed_RM_Semantics, support old Ada 83 style:
8396          --  pragma Import (Entity, "external name");
8397 
8398          if Relaxed_RM_Semantics
8399            and then Arg_Count = 2
8400            and then Prag_Id = Pragma_Import
8401            and then Nkind (Expression (Arg2)) = N_String_Literal
8402          then
8403             C := Convention_C;
8404             Def_Id := Get_Pragma_Arg (Arg1);
8405             Analyze (Def_Id);
8406 
8407             if not Is_Entity_Name (Def_Id) then
8408                Error_Pragma_Arg ("entity name required", Arg1);
8409             end if;
8410 
8411             Def_Id := Entity (Def_Id);
8412             Kill_Size_Check_Code (Def_Id);
8413             Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False);
8414 
8415          else
8416             Process_Convention (C, Def_Id);
8417 
8418             --  A pragma that applies to a Ghost entity becomes Ghost for the
8419             --  purposes of legality checks and removal of ignored Ghost code.
8420 
8421             Mark_Pragma_As_Ghost (N, Def_Id);
8422             Kill_Size_Check_Code (Def_Id);
8423             Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
8424          end if;
8425 
8426          --  Various error checks
8427 
8428          if Ekind_In (Def_Id, E_Variable, E_Constant) then
8429 
8430             --  We do not permit Import to apply to a renaming declaration
8431 
8432             if Present (Renamed_Object (Def_Id)) then
8433                Error_Pragma_Arg
8434                  ("pragma% not allowed for object renaming", Arg2);
8435 
8436             --  User initialization is not allowed for imported object, but
8437             --  the object declaration may contain a default initialization,
8438             --  that will be discarded. Note that an explicit initialization
8439             --  only counts if it comes from source, otherwise it is simply
8440             --  the code generator making an implicit initialization explicit.
8441 
8442             elsif Present (Expression (Parent (Def_Id)))
8443               and then Comes_From_Source
8444                          (Original_Node (Expression (Parent (Def_Id))))
8445             then
8446                --  Set imported flag to prevent cascaded errors
8447 
8448                Set_Is_Imported (Def_Id);
8449 
8450                Error_Msg_Sloc := Sloc (Def_Id);
8451                Error_Pragma_Arg
8452                  ("no initialization allowed for declaration of& #",
8453                   "\imported entities cannot be initialized (RM B.1(24))",
8454                   Arg2);
8455 
8456             else
8457                --  If the pragma comes from an aspect specification the
8458                --  Is_Imported flag has already been set.
8459 
8460                if not From_Aspect_Specification (N) then
8461                   Set_Imported (Def_Id);
8462                end if;
8463 
8464                Process_Interface_Name (Def_Id, Arg3, Arg4);
8465 
8466                --  Note that we do not set Is_Public here. That's because we
8467                --  only want to set it if there is no address clause, and we
8468                --  don't know that yet, so we delay that processing till
8469                --  freeze time.
8470 
8471                --  pragma Import completes deferred constants
8472 
8473                if Ekind (Def_Id) = E_Constant then
8474                   Set_Has_Completion (Def_Id);
8475                end if;
8476 
8477                --  It is not possible to import a constant of an unconstrained
8478                --  array type (e.g. string) because there is no simple way to
8479                --  write a meaningful subtype for it.
8480 
8481                if Is_Array_Type (Etype (Def_Id))
8482                  and then not Is_Constrained (Etype (Def_Id))
8483                then
8484                   Error_Msg_NE
8485                     ("imported constant& must have a constrained subtype",
8486                       N, Def_Id);
8487                end if;
8488             end if;
8489 
8490          elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8491 
8492             --  If the name is overloaded, pragma applies to all of the denoted
8493             --  entities in the same declarative part, unless the pragma comes
8494             --  from an aspect specification or was generated by the compiler
8495             --  (such as for pragma Provide_Shift_Operators).
8496 
8497             Hom_Id := Def_Id;
8498             while Present (Hom_Id) loop
8499 
8500                Def_Id := Get_Base_Subprogram (Hom_Id);
8501 
8502                --  Ignore inherited subprograms because the pragma will apply
8503                --  to the parent operation, which is the one called.
8504 
8505                if Is_Overloadable (Def_Id)
8506                  and then Present (Alias (Def_Id))
8507                then
8508                   null;
8509 
8510                --  If it is not a subprogram, it must be in an outer scope and
8511                --  pragma does not apply.
8512 
8513                elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
8514                   null;
8515 
8516                --  The pragma does not apply to primitives of interfaces
8517 
8518                elsif Is_Dispatching_Operation (Def_Id)
8519                  and then Present (Find_Dispatching_Type (Def_Id))
8520                  and then Is_Interface (Find_Dispatching_Type (Def_Id))
8521                then
8522                   null;
8523 
8524                --  Verify that the homonym is in the same declarative part (not
8525                --  just the same scope). If the pragma comes from an aspect
8526                --  specification we know that it is part of the declaration.
8527 
8528                elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
8529                  and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
8530                  and then not From_Aspect_Specification (N)
8531                then
8532                   exit;
8533 
8534                else
8535                   --  If the pragma comes from an aspect specification the
8536                   --  Is_Imported flag has already been set.
8537 
8538                   if not From_Aspect_Specification (N) then
8539                      Set_Imported (Def_Id);
8540                   end if;
8541 
8542                   --  Reject an Import applied to an abstract subprogram
8543 
8544                   if Is_Subprogram (Def_Id)
8545                     and then Is_Abstract_Subprogram (Def_Id)
8546                   then
8547                      Error_Msg_Sloc := Sloc (Def_Id);
8548                      Error_Msg_NE
8549                        ("cannot import abstract subprogram& declared#",
8550                         Arg2, Def_Id);
8551                   end if;
8552 
8553                   --  Special processing for Convention_Intrinsic
8554 
8555                   if C = Convention_Intrinsic then
8556 
8557                      --  Link_Name argument not allowed for intrinsic
8558 
8559                      Check_No_Link_Name;
8560 
8561                      Set_Is_Intrinsic_Subprogram (Def_Id);
8562 
8563                      --  If no external name is present, then check that this
8564                      --  is a valid intrinsic subprogram. If an external name
8565                      --  is present, then this is handled by the back end.
8566 
8567                      if No (Arg3) then
8568                         Check_Intrinsic_Subprogram
8569                           (Def_Id, Get_Pragma_Arg (Arg2));
8570                      end if;
8571                   end if;
8572 
8573                   --  Verify that the subprogram does not have a completion
8574                   --  through a renaming declaration. For other completions the
8575                   --  pragma appears as a too late representation.
8576 
8577                   declare
8578                      Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
8579 
8580                   begin
8581                      if Present (Decl)
8582                        and then Nkind (Decl) = N_Subprogram_Declaration
8583                        and then Present (Corresponding_Body (Decl))
8584                        and then Nkind (Unit_Declaration_Node
8585                                         (Corresponding_Body (Decl))) =
8586                                              N_Subprogram_Renaming_Declaration
8587                      then
8588                         Error_Msg_Sloc := Sloc (Def_Id);
8589                         Error_Msg_NE
8590                           ("cannot import&, renaming already provided for "
8591                            & "declaration #", N, Def_Id);
8592                      end if;
8593                   end;
8594 
8595                   --  If the pragma comes from an aspect specification, there
8596                   --  must be an Import aspect specified as well. In the rare
8597                   --  case where Import is set to False, the suprogram needs to
8598                   --  have a local completion.
8599 
8600                   declare
8601                      Imp_Aspect : constant Node_Id :=
8602                                     Find_Aspect (Def_Id, Aspect_Import);
8603                      Expr       : Node_Id;
8604 
8605                   begin
8606                      if Present (Imp_Aspect)
8607                        and then Present (Expression (Imp_Aspect))
8608                      then
8609                         Expr := Expression (Imp_Aspect);
8610                         Analyze_And_Resolve (Expr, Standard_Boolean);
8611 
8612                         if Is_Entity_Name (Expr)
8613                           and then Entity (Expr) = Standard_True
8614                         then
8615                            Set_Has_Completion (Def_Id);
8616                         end if;
8617 
8618                      --  If there is no expression, the default is True, as for
8619                      --  all boolean aspects. Same for the older pragma.
8620 
8621                      else
8622                         Set_Has_Completion (Def_Id);
8623                      end if;
8624                   end;
8625 
8626                   Process_Interface_Name (Def_Id, Arg3, Arg4);
8627                end if;
8628 
8629                if Is_Compilation_Unit (Hom_Id) then
8630 
8631                   --  Its possible homonyms are not affected by the pragma.
8632                   --  Such homonyms might be present in the context of other
8633                   --  units being compiled.
8634 
8635                   exit;
8636 
8637                elsif From_Aspect_Specification (N) then
8638                   exit;
8639 
8640                --  If the pragma was created by the compiler, then we don't
8641                --  want it to apply to other homonyms. This kind of case can
8642                --  occur when using pragma Provide_Shift_Operators, which
8643                --  generates implicit shift and rotate operators with Import
8644                --  pragmas that might apply to earlier explicit or implicit
8645                --  declarations marked with Import (for example, coming from
8646                --  an earlier pragma Provide_Shift_Operators for another type),
8647                --  and we don't generally want other homonyms being treated
8648                --  as imported or the pragma flagged as an illegal duplicate.
8649 
8650                elsif not Comes_From_Source (N) then
8651                   exit;
8652 
8653                else
8654                   Hom_Id := Homonym (Hom_Id);
8655                end if;
8656             end loop;
8657 
8658          --  Import a CPP class
8659 
8660          elsif C = Convention_CPP
8661            and then (Is_Record_Type (Def_Id)
8662                       or else Ekind (Def_Id) = E_Incomplete_Type)
8663          then
8664             if Ekind (Def_Id) = E_Incomplete_Type then
8665                if Present (Full_View (Def_Id)) then
8666                   Def_Id := Full_View (Def_Id);
8667 
8668                else
8669                   Error_Msg_N
8670                     ("cannot import 'C'P'P type before full declaration seen",
8671                      Get_Pragma_Arg (Arg2));
8672 
8673                   --  Although we have reported the error we decorate it as
8674                   --  CPP_Class to avoid reporting spurious errors
8675 
8676                   Set_Is_CPP_Class (Def_Id);
8677                   return;
8678                end if;
8679             end if;
8680 
8681             --  Types treated as CPP classes must be declared limited (note:
8682             --  this used to be a warning but there is no real benefit to it
8683             --  since we did effectively intend to treat the type as limited
8684             --  anyway).
8685 
8686             if not Is_Limited_Type (Def_Id) then
8687                Error_Msg_N
8688                  ("imported 'C'P'P type must be limited",
8689                   Get_Pragma_Arg (Arg2));
8690             end if;
8691 
8692             if Etype (Def_Id) /= Def_Id
8693               and then not Is_CPP_Class (Root_Type (Def_Id))
8694             then
8695                Error_Msg_N ("root type must be a 'C'P'P type", Arg1);
8696             end if;
8697 
8698             Set_Is_CPP_Class (Def_Id);
8699 
8700             --  Imported CPP types must not have discriminants (because C++
8701             --  classes do not have discriminants).
8702 
8703             if Has_Discriminants (Def_Id) then
8704                Error_Msg_N
8705                  ("imported 'C'P'P type cannot have discriminants",
8706                   First (Discriminant_Specifications
8707                           (Declaration_Node (Def_Id))));
8708             end if;
8709 
8710             --  Check that components of imported CPP types do not have default
8711             --  expressions. For private types this check is performed when the
8712             --  full view is analyzed (see Process_Full_View).
8713 
8714             if not Is_Private_Type (Def_Id) then
8715                Check_CPP_Type_Has_No_Defaults (Def_Id);
8716             end if;
8717 
8718          --  Import a CPP exception
8719 
8720          elsif C = Convention_CPP
8721            and then Ekind (Def_Id) = E_Exception
8722          then
8723             if No (Arg3) then
8724                Error_Pragma_Arg
8725                  ("'External_'Name arguments is required for 'Cpp exception",
8726                   Arg3);
8727             else
8728                --  As only a string is allowed, Check_Arg_Is_External_Name
8729                --  isn't called.
8730 
8731                Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8732             end if;
8733 
8734             if Present (Arg4) then
8735                Error_Pragma_Arg
8736                  ("Link_Name argument not allowed for imported Cpp exception",
8737                   Arg4);
8738             end if;
8739 
8740             --  Do not call Set_Interface_Name as the name of the exception
8741             --  shouldn't be modified (and in particular it shouldn't be
8742             --  the External_Name). For exceptions, the External_Name is the
8743             --  name of the RTTI structure.
8744 
8745             --  ??? Emit an error if pragma Import/Export_Exception is present
8746 
8747          elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
8748             Check_No_Link_Name;
8749             Check_Arg_Count (3);
8750             Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
8751 
8752             Process_Import_Predefined_Type;
8753 
8754          else
8755             Error_Pragma_Arg
8756               ("second argument of pragma% must be object, subprogram "
8757                & "or incomplete type",
8758                Arg2);
8759          end if;
8760 
8761          --  If this pragma applies to a compilation unit, then the unit, which
8762          --  is a subprogram, does not require (or allow) a body. We also do
8763          --  not need to elaborate imported procedures.
8764 
8765          if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
8766             declare
8767                Cunit : constant Node_Id := Parent (Parent (N));
8768             begin
8769                Set_Body_Required (Cunit, False);
8770             end;
8771          end if;
8772       end Process_Import_Or_Interface;
8773 
8774       --------------------
8775       -- Process_Inline --
8776       --------------------
8777 
8778       procedure Process_Inline (Status : Inline_Status) is
8779          Applies : Boolean;
8780          Assoc   : Node_Id;
8781          Decl    : Node_Id;
8782          Subp    : Entity_Id;
8783          Subp_Id : Node_Id;
8784 
8785          Ghost_Error_Posted : Boolean := False;
8786          --  Flag set when an error concerning the illegal mix of Ghost and
8787          --  non-Ghost subprograms is emitted.
8788 
8789          Ghost_Id : Entity_Id := Empty;
8790          --  The entity of the first Ghost subprogram encountered while
8791          --  processing the arguments of the pragma.
8792 
8793          procedure Make_Inline (Subp : Entity_Id);
8794          --  Subp is the defining unit name of the subprogram declaration. Set
8795          --  the flag, as well as the flag in the corresponding body, if there
8796          --  is one present.
8797 
8798          procedure Set_Inline_Flags (Subp : Entity_Id);
8799          --  Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8800          --  Has_Pragma_Inline_Always for the Inline_Always case.
8801 
8802          function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
8803          --  Returns True if it can be determined at this stage that inlining
8804          --  is not possible, for example if the body is available and contains
8805          --  exception handlers, we prevent inlining, since otherwise we can
8806          --  get undefined symbols at link time. This function also emits a
8807          --  warning if front-end inlining is enabled and the pragma appears
8808          --  too late.
8809          --
8810          --  ??? is business with link symbols still valid, or does it relate
8811          --  to front end ZCX which is being phased out ???
8812 
8813          ---------------------------
8814          -- Inlining_Not_Possible --
8815          ---------------------------
8816 
8817          function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
8818             Decl  : constant Node_Id := Unit_Declaration_Node (Subp);
8819             Stats : Node_Id;
8820 
8821          begin
8822             if Nkind (Decl) = N_Subprogram_Body then
8823                Stats := Handled_Statement_Sequence (Decl);
8824                return Present (Exception_Handlers (Stats))
8825                  or else Present (At_End_Proc (Stats));
8826 
8827             elsif Nkind (Decl) = N_Subprogram_Declaration
8828               and then Present (Corresponding_Body (Decl))
8829             then
8830                if Front_End_Inlining
8831                  and then Analyzed (Corresponding_Body (Decl))
8832                then
8833                   Error_Msg_N ("pragma appears too late, ignored??", N);
8834                   return True;
8835 
8836                --  If the subprogram is a renaming as body, the body is just a
8837                --  call to the renamed subprogram, and inlining is trivially
8838                --  possible.
8839 
8840                elsif
8841                  Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
8842                                              N_Subprogram_Renaming_Declaration
8843                then
8844                   return False;
8845 
8846                else
8847                   Stats :=
8848                     Handled_Statement_Sequence
8849                         (Unit_Declaration_Node (Corresponding_Body (Decl)));
8850 
8851                   return
8852                     Present (Exception_Handlers (Stats))
8853                       or else Present (At_End_Proc (Stats));
8854                end if;
8855 
8856             else
8857                --  If body is not available, assume the best, the check is
8858                --  performed again when compiling enclosing package bodies.
8859 
8860                return False;
8861             end if;
8862          end Inlining_Not_Possible;
8863 
8864          -----------------
8865          -- Make_Inline --
8866          -----------------
8867 
8868          procedure Make_Inline (Subp : Entity_Id) is
8869             Kind       : constant Entity_Kind := Ekind (Subp);
8870             Inner_Subp : Entity_Id   := Subp;
8871 
8872          begin
8873             --  Ignore if bad type, avoid cascaded error
8874 
8875             if Etype (Subp) = Any_Type then
8876                Applies := True;
8877                return;
8878 
8879             --  If inlining is not possible, for now do not treat as an error
8880 
8881             elsif Status /= Suppressed
8882               and then Inlining_Not_Possible (Subp)
8883             then
8884                Applies := True;
8885                return;
8886 
8887             --  Here we have a candidate for inlining, but we must exclude
8888             --  derived operations. Otherwise we would end up trying to inline
8889             --  a phantom declaration, and the result would be to drag in a
8890             --  body which has no direct inlining associated with it. That
8891             --  would not only be inefficient but would also result in the
8892             --  backend doing cross-unit inlining in cases where it was
8893             --  definitely inappropriate to do so.
8894 
8895             --  However, a simple Comes_From_Source test is insufficient, since
8896             --  we do want to allow inlining of generic instances which also do
8897             --  not come from source. We also need to recognize specs generated
8898             --  by the front-end for bodies that carry the pragma. Finally,
8899             --  predefined operators do not come from source but are not
8900             --  inlineable either.
8901 
8902             elsif Is_Generic_Instance (Subp)
8903               or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
8904             then
8905                null;
8906 
8907             elsif not Comes_From_Source (Subp)
8908               and then Scope (Subp) /= Standard_Standard
8909             then
8910                Applies := True;
8911                return;
8912             end if;
8913 
8914             --  The referenced entity must either be the enclosing entity, or
8915             --  an entity declared within the current open scope.
8916 
8917             if Present (Scope (Subp))
8918               and then Scope (Subp) /= Current_Scope
8919               and then Subp /= Current_Scope
8920             then
8921                Error_Pragma_Arg
8922                  ("argument of% must be entity in current scope", Assoc);
8923                return;
8924             end if;
8925 
8926             --  Processing for procedure, operator or function. If subprogram
8927             --  is aliased (as for an instance) indicate that the renamed
8928             --  entity (if declared in the same unit) is inlined.
8929             --  If this is the anonymous subprogram created for a subprogram
8930             --  instance, the inlining applies to it directly. Otherwise we
8931             --  retrieve it as the alias of the visible subprogram instance.
8932 
8933             if Is_Subprogram (Subp) then
8934                if Is_Wrapper_Package (Scope (Subp)) then
8935                   Inner_Subp := Subp;
8936                else
8937                   Inner_Subp := Ultimate_Alias (Inner_Subp);
8938                end if;
8939 
8940                if In_Same_Source_Unit (Subp, Inner_Subp) then
8941                   Set_Inline_Flags (Inner_Subp);
8942 
8943                   Decl := Parent (Parent (Inner_Subp));
8944 
8945                   if Nkind (Decl) = N_Subprogram_Declaration
8946                     and then Present (Corresponding_Body (Decl))
8947                   then
8948                      Set_Inline_Flags (Corresponding_Body (Decl));
8949 
8950                   elsif Is_Generic_Instance (Subp)
8951                     and then Comes_From_Source (Subp)
8952                   then
8953                      --  Indicate that the body needs to be created for
8954                      --  inlining subsequent calls. The instantiation node
8955                      --  follows the declaration of the wrapper package
8956                      --  created for it. The subprogram that requires the
8957                      --  body is the anonymous one in the wrapper package.
8958 
8959                      if Scope (Subp) /= Standard_Standard
8960                        and then
8961                          Need_Subprogram_Instance_Body
8962                            (Next (Unit_Declaration_Node
8963                              (Scope (Alias (Subp)))), Subp)
8964                      then
8965                         null;
8966                      end if;
8967 
8968                   --  Inline is a program unit pragma (RM 10.1.5) and cannot
8969                   --  appear in a formal part to apply to a formal subprogram.
8970                   --  Do not apply check within an instance or a formal package
8971                   --  the test will have been applied to the original generic.
8972 
8973                   elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
8974                     and then List_Containing (Decl) = List_Containing (N)
8975                     and then not In_Instance
8976                   then
8977                      Error_Msg_N
8978                        ("Inline cannot apply to a formal subprogram", N);
8979 
8980                   --  If Subp is a renaming, it is the renamed entity that
8981                   --  will appear in any call, and be inlined. However, for
8982                   --  ASIS uses it is convenient to indicate that the renaming
8983                   --  itself is an inlined subprogram, so that some gnatcheck
8984                   --  rules can be applied in the absence of expansion.
8985 
8986                   elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then
8987                      Set_Inline_Flags (Subp);
8988                   end if;
8989                end if;
8990 
8991                Applies := True;
8992 
8993             --  For a generic subprogram set flag as well, for use at the point
8994             --  of instantiation, to determine whether the body should be
8995             --  generated.
8996 
8997             elsif Is_Generic_Subprogram (Subp) then
8998                Set_Inline_Flags (Subp);
8999                Applies := True;
9000 
9001             --  Literals are by definition inlined
9002 
9003             elsif Kind = E_Enumeration_Literal then
9004                null;
9005 
9006             --  Anything else is an error
9007 
9008             else
9009                Error_Pragma_Arg
9010                  ("expect subprogram name for pragma%", Assoc);
9011             end if;
9012          end Make_Inline;
9013 
9014          ----------------------
9015          -- Set_Inline_Flags --
9016          ----------------------
9017 
9018          procedure Set_Inline_Flags (Subp : Entity_Id) is
9019          begin
9020             --  First set the Has_Pragma_XXX flags and issue the appropriate
9021             --  errors and warnings for suspicious combinations.
9022 
9023             if Prag_Id = Pragma_No_Inline then
9024                if Has_Pragma_Inline_Always (Subp) then
9025                   Error_Msg_N
9026                     ("Inline_Always and No_Inline are mutually exclusive", N);
9027                elsif Has_Pragma_Inline (Subp) then
9028                   Error_Msg_NE
9029                     ("Inline and No_Inline both specified for& ??",
9030                      N, Entity (Subp_Id));
9031                end if;
9032 
9033                Set_Has_Pragma_No_Inline (Subp);
9034             else
9035                if Prag_Id = Pragma_Inline_Always then
9036                   if Has_Pragma_No_Inline (Subp) then
9037                      Error_Msg_N
9038                        ("Inline_Always and No_Inline are mutually exclusive",
9039                         N);
9040                   end if;
9041 
9042                   Set_Has_Pragma_Inline_Always (Subp);
9043                else
9044                   if Has_Pragma_No_Inline (Subp) then
9045                      Error_Msg_NE
9046                        ("Inline and No_Inline both specified for& ??",
9047                         N, Entity (Subp_Id));
9048                   end if;
9049                end if;
9050 
9051                if not Has_Pragma_Inline (Subp) then
9052                   Set_Has_Pragma_Inline (Subp);
9053                end if;
9054             end if;
9055 
9056             --  Then adjust the Is_Inlined flag. It can never be set if the
9057             --  subprogram is subject to pragma No_Inline.
9058 
9059             case Status is
9060                when Suppressed =>
9061                   Set_Is_Inlined (Subp, False);
9062                when Disabled =>
9063                   null;
9064                when Enabled =>
9065                   if not Has_Pragma_No_Inline (Subp) then
9066                      Set_Is_Inlined (Subp, True);
9067                   end if;
9068             end case;
9069 
9070             --  A pragma that applies to a Ghost entity becomes Ghost for the
9071             --  purposes of legality checks and removal of ignored Ghost code.
9072 
9073             Mark_Pragma_As_Ghost (N, Subp);
9074 
9075             --  Capture the entity of the first Ghost subprogram being
9076             --  processed for error detection purposes.
9077 
9078             if Is_Ghost_Entity (Subp) then
9079                if No (Ghost_Id) then
9080                   Ghost_Id := Subp;
9081                end if;
9082 
9083             --  Otherwise the subprogram is non-Ghost. It is illegal to mix
9084             --  references to Ghost and non-Ghost entities (SPARK RM 6.9).
9085 
9086             elsif Present (Ghost_Id) and then not Ghost_Error_Posted then
9087                Ghost_Error_Posted := True;
9088 
9089                Error_Msg_Name_1 := Pname;
9090                Error_Msg_N
9091                  ("pragma % cannot mention ghost and non-ghost subprograms",
9092                   N);
9093 
9094                Error_Msg_Sloc := Sloc (Ghost_Id);
9095                Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
9096 
9097                Error_Msg_Sloc := Sloc (Subp);
9098                Error_Msg_NE ("\& # declared as non-ghost", N, Subp);
9099             end if;
9100          end Set_Inline_Flags;
9101 
9102       --  Start of processing for Process_Inline
9103 
9104       begin
9105          Check_No_Identifiers;
9106          Check_At_Least_N_Arguments (1);
9107 
9108          if Status = Enabled then
9109             Inline_Processing_Required := True;
9110          end if;
9111 
9112          Assoc := Arg1;
9113          while Present (Assoc) loop
9114             Subp_Id := Get_Pragma_Arg (Assoc);
9115             Analyze (Subp_Id);
9116             Applies := False;
9117 
9118             if Is_Entity_Name (Subp_Id) then
9119                Subp := Entity (Subp_Id);
9120 
9121                if Subp = Any_Id then
9122 
9123                   --  If previous error, avoid cascaded errors
9124 
9125                   Check_Error_Detected;
9126                   Applies := True;
9127 
9128                else
9129                   Make_Inline (Subp);
9130 
9131                   --  For the pragma case, climb homonym chain. This is
9132                   --  what implements allowing the pragma in the renaming
9133                   --  case, with the result applying to the ancestors, and
9134                   --  also allows Inline to apply to all previous homonyms.
9135 
9136                   if not From_Aspect_Specification (N) then
9137                      while Present (Homonym (Subp))
9138                        and then Scope (Homonym (Subp)) = Current_Scope
9139                      loop
9140                         Make_Inline (Homonym (Subp));
9141                         Subp := Homonym (Subp);
9142                      end loop;
9143                   end if;
9144                end if;
9145             end if;
9146 
9147             if not Applies then
9148                Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc);
9149             end if;
9150 
9151             Next (Assoc);
9152          end loop;
9153       end Process_Inline;
9154 
9155       ----------------------------
9156       -- Process_Interface_Name --
9157       ----------------------------
9158 
9159       procedure Process_Interface_Name
9160         (Subprogram_Def : Entity_Id;
9161          Ext_Arg        : Node_Id;
9162          Link_Arg       : Node_Id)
9163       is
9164          Ext_Nam    : Node_Id;
9165          Link_Nam   : Node_Id;
9166          String_Val : String_Id;
9167 
9168          procedure Check_Form_Of_Interface_Name (SN : Node_Id);
9169          --  SN is a string literal node for an interface name. This routine
9170          --  performs some minimal checks that the name is reasonable. In
9171          --  particular that no spaces or other obviously incorrect characters
9172          --  appear. This is only a warning, since any characters are allowed.
9173 
9174          ----------------------------------
9175          -- Check_Form_Of_Interface_Name --
9176          ----------------------------------
9177 
9178          procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
9179             S  : constant String_Id := Strval (Expr_Value_S (SN));
9180             SL : constant Nat       := String_Length (S);
9181             C  : Char_Code;
9182 
9183          begin
9184             if SL = 0 then
9185                Error_Msg_N ("interface name cannot be null string", SN);
9186             end if;
9187 
9188             for J in 1 .. SL loop
9189                C := Get_String_Char (S, J);
9190 
9191                --  Look for dubious character and issue unconditional warning.
9192                --  Definitely dubious if not in character range.
9193 
9194                if not In_Character_Range (C)
9195 
9196                  --  Commas, spaces and (back)slashes are dubious
9197 
9198                  or else Get_Character (C) = ','
9199                  or else Get_Character (C) = '\'
9200                  or else Get_Character (C) = ' '
9201                  or else Get_Character (C) = '/'
9202                then
9203                   Error_Msg
9204                     ("??interface name contains illegal character",
9205                      Sloc (SN) + Source_Ptr (J));
9206                end if;
9207             end loop;
9208          end Check_Form_Of_Interface_Name;
9209 
9210       --  Start of processing for Process_Interface_Name
9211 
9212       begin
9213          if No (Link_Arg) then
9214             if No (Ext_Arg) then
9215                return;
9216 
9217             elsif Chars (Ext_Arg) = Name_Link_Name then
9218                Ext_Nam  := Empty;
9219                Link_Nam := Expression (Ext_Arg);
9220 
9221             else
9222                Check_Optional_Identifier (Ext_Arg, Name_External_Name);
9223                Ext_Nam  := Expression (Ext_Arg);
9224                Link_Nam := Empty;
9225             end if;
9226 
9227          else
9228             Check_Optional_Identifier (Ext_Arg,  Name_External_Name);
9229             Check_Optional_Identifier (Link_Arg, Name_Link_Name);
9230             Ext_Nam  := Expression (Ext_Arg);
9231             Link_Nam := Expression (Link_Arg);
9232          end if;
9233 
9234          --  Check expressions for external name and link name are static
9235 
9236          if Present (Ext_Nam) then
9237             Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
9238             Check_Form_Of_Interface_Name (Ext_Nam);
9239 
9240             --  Verify that external name is not the name of a local entity,
9241             --  which would hide the imported one and could lead to run-time
9242             --  surprises. The problem can only arise for entities declared in
9243             --  a package body (otherwise the external name is fully qualified
9244             --  and will not conflict).
9245 
9246             declare
9247                Nam : Name_Id;
9248                E   : Entity_Id;
9249                Par : Node_Id;
9250 
9251             begin
9252                if Prag_Id = Pragma_Import then
9253                   String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
9254                   Nam := Name_Find;
9255                   E   := Entity_Id (Get_Name_Table_Int (Nam));
9256 
9257                   if Nam /= Chars (Subprogram_Def)
9258                     and then Present (E)
9259                     and then not Is_Overloadable (E)
9260                     and then Is_Immediately_Visible (E)
9261                     and then not Is_Imported (E)
9262                     and then Ekind (Scope (E)) = E_Package
9263                   then
9264                      Par := Parent (E);
9265                      while Present (Par) loop
9266                         if Nkind (Par) = N_Package_Body then
9267                            Error_Msg_Sloc := Sloc (E);
9268                            Error_Msg_NE
9269                              ("imported entity is hidden by & declared#",
9270                               Ext_Arg, E);
9271                            exit;
9272                         end if;
9273 
9274                         Par := Parent (Par);
9275                      end loop;
9276                   end if;
9277                end if;
9278             end;
9279          end if;
9280 
9281          if Present (Link_Nam) then
9282             Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
9283             Check_Form_Of_Interface_Name (Link_Nam);
9284          end if;
9285 
9286          --  If there is no link name, just set the external name
9287 
9288          if No (Link_Nam) then
9289             Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
9290 
9291          --  For the Link_Name case, the given literal is preceded by an
9292          --  asterisk, which indicates to GCC that the given name should be
9293          --  taken literally, and in particular that no prepending of
9294          --  underlines should occur, even in systems where this is the
9295          --  normal default.
9296 
9297          else
9298             Start_String;
9299             Store_String_Char (Get_Char_Code ('*'));
9300             String_Val := Strval (Expr_Value_S (Link_Nam));
9301             Store_String_Chars (String_Val);
9302             Link_Nam :=
9303               Make_String_Literal (Sloc (Link_Nam),
9304                 Strval => End_String);
9305          end if;
9306 
9307          --  Set the interface name. If the entity is a generic instance, use
9308          --  its alias, which is the callable entity.
9309 
9310          if Is_Generic_Instance (Subprogram_Def) then
9311             Set_Encoded_Interface_Name
9312               (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
9313          else
9314             Set_Encoded_Interface_Name
9315               (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
9316          end if;
9317 
9318          Check_Duplicated_Export_Name (Link_Nam);
9319       end Process_Interface_Name;
9320 
9321       -----------------------------------------
9322       -- Process_Interrupt_Or_Attach_Handler --
9323       -----------------------------------------
9324 
9325       procedure Process_Interrupt_Or_Attach_Handler is
9326          Handler  : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1));
9327          Prot_Typ : constant Entity_Id := Scope (Handler);
9328 
9329       begin
9330          --  A pragma that applies to a Ghost entity becomes Ghost for the
9331          --  purposes of legality checks and removal of ignored Ghost code.
9332 
9333          Mark_Pragma_As_Ghost (N, Handler);
9334          Set_Is_Interrupt_Handler (Handler);
9335 
9336          pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
9337 
9338          Record_Rep_Item (Prot_Typ, N);
9339 
9340          --  Chain the pragma on the contract for completeness
9341 
9342          Add_Contract_Item (N, Handler);
9343       end Process_Interrupt_Or_Attach_Handler;
9344 
9345       --------------------------------------------------
9346       -- Process_Restrictions_Or_Restriction_Warnings --
9347       --------------------------------------------------
9348 
9349       --  Note: some of the simple identifier cases were handled in par-prag,
9350       --  but it is harmless (and more straightforward) to simply handle all
9351       --  cases here, even if it means we repeat a bit of work in some cases.
9352 
9353       procedure Process_Restrictions_Or_Restriction_Warnings
9354         (Warn : Boolean)
9355       is
9356          Arg   : Node_Id;
9357          R_Id  : Restriction_Id;
9358          Id    : Name_Id;
9359          Expr  : Node_Id;
9360          Val   : Uint;
9361 
9362       begin
9363          --  Ignore all Restrictions pragmas in CodePeer mode
9364 
9365          if CodePeer_Mode then
9366             return;
9367          end if;
9368 
9369          Check_Ada_83_Warning;
9370          Check_At_Least_N_Arguments (1);
9371          Check_Valid_Configuration_Pragma;
9372 
9373          Arg := Arg1;
9374          while Present (Arg) loop
9375             Id := Chars (Arg);
9376             Expr := Get_Pragma_Arg (Arg);
9377 
9378             --  Case of no restriction identifier present
9379 
9380             if Id = No_Name then
9381                if Nkind (Expr) /= N_Identifier then
9382                   Error_Pragma_Arg
9383                     ("invalid form for restriction", Arg);
9384                end if;
9385 
9386                R_Id :=
9387                  Get_Restriction_Id
9388                    (Process_Restriction_Synonyms (Expr));
9389 
9390                if R_Id not in All_Boolean_Restrictions then
9391                   Error_Msg_Name_1 := Pname;
9392                   Error_Msg_N
9393                     ("invalid restriction identifier&", Get_Pragma_Arg (Arg));
9394 
9395                   --  Check for possible misspelling
9396 
9397                   for J in Restriction_Id loop
9398                      declare
9399                         Rnm : constant String := Restriction_Id'Image (J);
9400 
9401                      begin
9402                         Name_Buffer (1 .. Rnm'Length) := Rnm;
9403                         Name_Len := Rnm'Length;
9404                         Set_Casing (All_Lower_Case);
9405 
9406                         if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
9407                            Set_Casing
9408                              (Identifier_Casing (Current_Source_File));
9409                            Error_Msg_String (1 .. Rnm'Length) :=
9410                              Name_Buffer (1 .. Name_Len);
9411                            Error_Msg_Strlen := Rnm'Length;
9412                            Error_Msg_N -- CODEFIX
9413                              ("\possible misspelling of ""~""",
9414                               Get_Pragma_Arg (Arg));
9415                            exit;
9416                         end if;
9417                      end;
9418                   end loop;
9419 
9420                   raise Pragma_Exit;
9421                end if;
9422 
9423                if Implementation_Restriction (R_Id) then
9424                   Check_Restriction (No_Implementation_Restrictions, Arg);
9425                end if;
9426 
9427                --  Special processing for No_Elaboration_Code restriction
9428 
9429                if R_Id = No_Elaboration_Code then
9430 
9431                   --  Restriction is only recognized within a configuration
9432                   --  pragma file, or within a unit of the main extended
9433                   --  program. Note: the test for Main_Unit is needed to
9434                   --  properly include the case of configuration pragma files.
9435 
9436                   if not (Current_Sem_Unit = Main_Unit
9437                            or else In_Extended_Main_Source_Unit (N))
9438                   then
9439                      return;
9440 
9441                   --  Don't allow in a subunit unless already specified in
9442                   --  body or spec.
9443 
9444                   elsif Nkind (Parent (N)) = N_Compilation_Unit
9445                     and then Nkind (Unit (Parent (N))) = N_Subunit
9446                     and then not Restriction_Active (No_Elaboration_Code)
9447                   then
9448                      Error_Msg_N
9449                        ("invalid specification of ""No_Elaboration_Code""",
9450                         N);
9451                      Error_Msg_N
9452                        ("\restriction cannot be specified in a subunit", N);
9453                      Error_Msg_N
9454                        ("\unless also specified in body or spec", N);
9455                      return;
9456 
9457                   --  If we accept a No_Elaboration_Code restriction, then it
9458                   --  needs to be added to the configuration restriction set so
9459                   --  that we get proper application to other units in the main
9460                   --  extended source as required.
9461 
9462                   else
9463                      Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
9464                   end if;
9465                end if;
9466 
9467                --  If this is a warning, then set the warning unless we already
9468                --  have a real restriction active (we never want a warning to
9469                --  override a real restriction).
9470 
9471                if Warn then
9472                   if not Restriction_Active (R_Id) then
9473                      Set_Restriction (R_Id, N);
9474                      Restriction_Warnings (R_Id) := True;
9475                   end if;
9476 
9477                --  If real restriction case, then set it and make sure that the
9478                --  restriction warning flag is off, since a real restriction
9479                --  always overrides a warning.
9480 
9481                else
9482                   Set_Restriction (R_Id, N);
9483                   Restriction_Warnings (R_Id) := False;
9484                end if;
9485 
9486                --  Check for obsolescent restrictions in Ada 2005 mode
9487 
9488                if not Warn
9489                  and then Ada_Version >= Ada_2005
9490                  and then (R_Id = No_Asynchronous_Control
9491                             or else
9492                            R_Id = No_Unchecked_Deallocation
9493                             or else
9494                            R_Id = No_Unchecked_Conversion)
9495                then
9496                   Check_Restriction (No_Obsolescent_Features, N);
9497                end if;
9498 
9499                --  A very special case that must be processed here: pragma
9500                --  Restrictions (No_Exceptions) turns off all run-time
9501                --  checking. This is a bit dubious in terms of the formal
9502                --  language definition, but it is what is intended by RM
9503                --  H.4(12). Restriction_Warnings never affects generated code
9504                --  so this is done only in the real restriction case.
9505 
9506                --  Atomic_Synchronization is not a real check, so it is not
9507                --  affected by this processing).
9508 
9509                --  Ignore the effect of pragma Restrictions (No_Exceptions) on
9510                --  run-time checks in CodePeer and GNATprove modes: we want to
9511                --  generate checks for analysis purposes, as set respectively
9512                --  by -gnatC and -gnatd.F
9513 
9514                if not Warn
9515                  and then not (CodePeer_Mode or GNATprove_Mode)
9516                  and then R_Id = No_Exceptions
9517                then
9518                   for J in Scope_Suppress.Suppress'Range loop
9519                      if J /= Atomic_Synchronization then
9520                         Scope_Suppress.Suppress (J) := True;
9521                      end if;
9522                   end loop;
9523                end if;
9524 
9525             --  Case of No_Dependence => unit-name. Note that the parser
9526             --  already made the necessary entry in the No_Dependence table.
9527 
9528             elsif Id = Name_No_Dependence then
9529                if not OK_No_Dependence_Unit_Name (Expr) then
9530                   raise Pragma_Exit;
9531                end if;
9532 
9533             --  Case of No_Specification_Of_Aspect => aspect-identifier
9534 
9535             elsif Id = Name_No_Specification_Of_Aspect then
9536                declare
9537                   A_Id : Aspect_Id;
9538 
9539                begin
9540                   if Nkind (Expr) /= N_Identifier then
9541                      A_Id := No_Aspect;
9542                   else
9543                      A_Id := Get_Aspect_Id (Chars (Expr));
9544                   end if;
9545 
9546                   if A_Id = No_Aspect then
9547                      Error_Pragma_Arg ("invalid restriction name", Arg);
9548                   else
9549                      Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
9550                   end if;
9551                end;
9552 
9553             --  Case of No_Use_Of_Attribute => attribute-identifier
9554 
9555             elsif Id = Name_No_Use_Of_Attribute then
9556                if Nkind (Expr) /= N_Identifier
9557                  or else not Is_Attribute_Name (Chars (Expr))
9558                then
9559                   Error_Msg_N ("unknown attribute name??", Expr);
9560 
9561                else
9562                   Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
9563                end if;
9564 
9565             --  Case of No_Use_Of_Entity => fully-qualified-name
9566 
9567             elsif Id = Name_No_Use_Of_Entity then
9568 
9569                --  Restriction is only recognized within a configuration
9570                --  pragma file, or within a unit of the main extended
9571                --  program. Note: the test for Main_Unit is needed to
9572                --  properly include the case of configuration pragma files.
9573 
9574                if Current_Sem_Unit = Main_Unit
9575                  or else In_Extended_Main_Source_Unit (N)
9576                then
9577                   if not OK_No_Dependence_Unit_Name (Expr) then
9578                      Error_Msg_N ("wrong form for entity name", Expr);
9579                   else
9580                      Set_Restriction_No_Use_Of_Entity
9581                        (Expr, Warn, No_Profile);
9582                   end if;
9583                end if;
9584 
9585             --  Case of No_Use_Of_Pragma => pragma-identifier
9586 
9587             elsif Id = Name_No_Use_Of_Pragma then
9588                if Nkind (Expr) /= N_Identifier
9589                  or else not Is_Pragma_Name (Chars (Expr))
9590                then
9591                   Error_Msg_N ("unknown pragma name??", Expr);
9592                else
9593                   Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
9594                end if;
9595 
9596             --  All other cases of restriction identifier present
9597 
9598             else
9599                R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
9600                Analyze_And_Resolve (Expr, Any_Integer);
9601 
9602                if R_Id not in All_Parameter_Restrictions then
9603                   Error_Pragma_Arg
9604                     ("invalid restriction parameter identifier", Arg);
9605 
9606                elsif not Is_OK_Static_Expression (Expr) then
9607                   Flag_Non_Static_Expr
9608                     ("value must be static expression!", Expr);
9609                   raise Pragma_Exit;
9610 
9611                elsif not Is_Integer_Type (Etype (Expr))
9612                  or else Expr_Value (Expr) < 0
9613                then
9614                   Error_Pragma_Arg
9615                     ("value must be non-negative integer", Arg);
9616                end if;
9617 
9618                --  Restriction pragma is active
9619 
9620                Val := Expr_Value (Expr);
9621 
9622                if not UI_Is_In_Int_Range (Val) then
9623                   Error_Pragma_Arg
9624                     ("pragma ignored, value too large??", Arg);
9625                end if;
9626 
9627                --  Warning case. If the real restriction is active, then we
9628                --  ignore the request, since warning never overrides a real
9629                --  restriction. Otherwise we set the proper warning. Note that
9630                --  this circuit sets the warning again if it is already set,
9631                --  which is what we want, since the constant may have changed.
9632 
9633                if Warn then
9634                   if not Restriction_Active (R_Id) then
9635                      Set_Restriction
9636                        (R_Id, N, Integer (UI_To_Int (Val)));
9637                      Restriction_Warnings (R_Id) := True;
9638                   end if;
9639 
9640                --  Real restriction case, set restriction and make sure warning
9641                --  flag is off since real restriction always overrides warning.
9642 
9643                else
9644                   Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
9645                   Restriction_Warnings (R_Id) := False;
9646                end if;
9647             end if;
9648 
9649             Next (Arg);
9650          end loop;
9651       end Process_Restrictions_Or_Restriction_Warnings;
9652 
9653       ---------------------------------
9654       -- Process_Suppress_Unsuppress --
9655       ---------------------------------
9656 
9657       --  Note: this procedure makes entries in the check suppress data
9658       --  structures managed by Sem. See spec of package Sem for full
9659       --  details on how we handle recording of check suppression.
9660 
9661       procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
9662          C    : Check_Id;
9663          E    : Entity_Id;
9664          E_Id : Node_Id;
9665 
9666          In_Package_Spec : constant Boolean :=
9667                              Is_Package_Or_Generic_Package (Current_Scope)
9668                                and then not In_Package_Body (Current_Scope);
9669 
9670          procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
9671          --  Used to suppress a single check on the given entity
9672 
9673          --------------------------------
9674          -- Suppress_Unsuppress_Echeck --
9675          --------------------------------
9676 
9677          procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
9678          begin
9679             --  Check for error of trying to set atomic synchronization for
9680             --  a non-atomic variable.
9681 
9682             if C = Atomic_Synchronization
9683               and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
9684             then
9685                Error_Msg_N
9686                  ("pragma & requires atomic type or variable",
9687                   Pragma_Identifier (Original_Node (N)));
9688             end if;
9689 
9690             Set_Checks_May_Be_Suppressed (E);
9691 
9692             if In_Package_Spec then
9693                Push_Global_Suppress_Stack_Entry
9694                  (Entity   => E,
9695                   Check    => C,
9696                   Suppress => Suppress_Case);
9697             else
9698                Push_Local_Suppress_Stack_Entry
9699                  (Entity   => E,
9700                   Check    => C,
9701                   Suppress => Suppress_Case);
9702             end if;
9703 
9704             --  If this is a first subtype, and the base type is distinct,
9705             --  then also set the suppress flags on the base type.
9706 
9707             if Is_First_Subtype (E) and then Etype (E) /= E then
9708                Suppress_Unsuppress_Echeck (Etype (E), C);
9709             end if;
9710          end Suppress_Unsuppress_Echeck;
9711 
9712       --  Start of processing for Process_Suppress_Unsuppress
9713 
9714       begin
9715          --  Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9716          --  on user code: we want to generate checks for analysis purposes, as
9717          --  set respectively by -gnatC and -gnatd.F
9718 
9719          if Comes_From_Source (N)
9720            and then (CodePeer_Mode or GNATprove_Mode)
9721          then
9722             return;
9723          end if;
9724 
9725          --  Suppress/Unsuppress can appear as a configuration pragma, or in a
9726          --  declarative part or a package spec (RM 11.5(5)).
9727 
9728          if not Is_Configuration_Pragma then
9729             Check_Is_In_Decl_Part_Or_Package_Spec;
9730          end if;
9731 
9732          Check_At_Least_N_Arguments (1);
9733          Check_At_Most_N_Arguments (2);
9734          Check_No_Identifier (Arg1);
9735          Check_Arg_Is_Identifier (Arg1);
9736 
9737          C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
9738 
9739          if C = No_Check_Id then
9740             Error_Pragma_Arg
9741               ("argument of pragma% is not valid check name", Arg1);
9742          end if;
9743 
9744          --  Warn that suppress of Elaboration_Check has no effect in SPARK
9745 
9746          if C = Elaboration_Check and then SPARK_Mode = On then
9747             Error_Pragma_Arg
9748               ("Suppress of Elaboration_Check ignored in SPARK??",
9749                "\elaboration checking rules are statically enforced "
9750                & "(SPARK RM 7.7)", Arg1);
9751          end if;
9752 
9753          --  One-argument case
9754 
9755          if Arg_Count = 1 then
9756 
9757             --  Make an entry in the local scope suppress table. This is the
9758             --  table that directly shows the current value of the scope
9759             --  suppress check for any check id value.
9760 
9761             if C = All_Checks then
9762 
9763                --  For All_Checks, we set all specific predefined checks with
9764                --  the exception of Elaboration_Check, which is handled
9765                --  specially because of not wanting All_Checks to have the
9766                --  effect of deactivating static elaboration order processing.
9767                --  Atomic_Synchronization is also not affected, since this is
9768                --  not a real check.
9769 
9770                for J in Scope_Suppress.Suppress'Range loop
9771                   if J /= Elaboration_Check
9772                        and then
9773                      J /= Atomic_Synchronization
9774                   then
9775                      Scope_Suppress.Suppress (J) := Suppress_Case;
9776                   end if;
9777                end loop;
9778 
9779             --  If not All_Checks, and predefined check, then set appropriate
9780             --  scope entry. Note that we will set Elaboration_Check if this
9781             --  is explicitly specified. Atomic_Synchronization is allowed
9782             --  only if internally generated and entity is atomic.
9783 
9784             elsif C in Predefined_Check_Id
9785               and then (not Comes_From_Source (N)
9786                          or else C /= Atomic_Synchronization)
9787             then
9788                Scope_Suppress.Suppress (C) := Suppress_Case;
9789             end if;
9790 
9791             --  Also make an entry in the Local_Entity_Suppress table
9792 
9793             Push_Local_Suppress_Stack_Entry
9794               (Entity   => Empty,
9795                Check    => C,
9796                Suppress => Suppress_Case);
9797 
9798          --  Case of two arguments present, where the check is suppressed for
9799          --  a specified entity (given as the second argument of the pragma)
9800 
9801          else
9802             --  This is obsolescent in Ada 2005 mode
9803 
9804             if Ada_Version >= Ada_2005 then
9805                Check_Restriction (No_Obsolescent_Features, Arg2);
9806             end if;
9807 
9808             Check_Optional_Identifier (Arg2, Name_On);
9809             E_Id := Get_Pragma_Arg (Arg2);
9810             Analyze (E_Id);
9811 
9812             if not Is_Entity_Name (E_Id) then
9813                Error_Pragma_Arg
9814                  ("second argument of pragma% must be entity name", Arg2);
9815             end if;
9816 
9817             E := Entity (E_Id);
9818 
9819             if E = Any_Id then
9820                return;
9821             end if;
9822 
9823             --  A pragma that applies to a Ghost entity becomes Ghost for the
9824             --  purposes of legality checks and removal of ignored Ghost code.
9825 
9826             Mark_Pragma_As_Ghost (N, E);
9827 
9828             --  Enforce RM 11.5(7) which requires that for a pragma that
9829             --  appears within a package spec, the named entity must be
9830             --  within the package spec. We allow the package name itself
9831             --  to be mentioned since that makes sense, although it is not
9832             --  strictly allowed by 11.5(7).
9833 
9834             if In_Package_Spec
9835               and then E /= Current_Scope
9836               and then Scope (E) /= Current_Scope
9837             then
9838                Error_Pragma_Arg
9839                  ("entity in pragma% is not in package spec (RM 11.5(7))",
9840                   Arg2);
9841             end if;
9842 
9843             --  Loop through homonyms. As noted below, in the case of a package
9844             --  spec, only homonyms within the package spec are considered.
9845 
9846             loop
9847                Suppress_Unsuppress_Echeck (E, C);
9848 
9849                if Is_Generic_Instance (E)
9850                  and then Is_Subprogram (E)
9851                  and then Present (Alias (E))
9852                then
9853                   Suppress_Unsuppress_Echeck (Alias (E), C);
9854                end if;
9855 
9856                --  Move to next homonym if not aspect spec case
9857 
9858                exit when From_Aspect_Specification (N);
9859                E := Homonym (E);
9860                exit when No (E);
9861 
9862                --  If we are within a package specification, the pragma only
9863                --  applies to homonyms in the same scope.
9864 
9865                exit when In_Package_Spec
9866                  and then Scope (E) /= Current_Scope;
9867             end loop;
9868          end if;
9869       end Process_Suppress_Unsuppress;
9870 
9871       -------------------------------
9872       -- Record_Independence_Check --
9873       -------------------------------
9874 
9875       procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is
9876       begin
9877          --  For GCC back ends the validation is done a priori
9878 
9879          if not AAMP_On_Target then
9880             return;
9881          end if;
9882 
9883          Independence_Checks.Append ((N, E));
9884       end Record_Independence_Check;
9885 
9886       ------------------
9887       -- Set_Exported --
9888       ------------------
9889 
9890       procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
9891       begin
9892          if Is_Imported (E) then
9893             Error_Pragma_Arg
9894               ("cannot export entity& that was previously imported", Arg);
9895 
9896          elsif Present (Address_Clause (E))
9897            and then not Relaxed_RM_Semantics
9898          then
9899             Error_Pragma_Arg
9900               ("cannot export entity& that has an address clause", Arg);
9901          end if;
9902 
9903          Set_Is_Exported (E);
9904 
9905          --  Generate a reference for entity explicitly, because the
9906          --  identifier may be overloaded and name resolution will not
9907          --  generate one.
9908 
9909          Generate_Reference (E, Arg);
9910 
9911          --  Deal with exporting non-library level entity
9912 
9913          if not Is_Library_Level_Entity (E) then
9914 
9915             --  Not allowed at all for subprograms
9916 
9917             if Is_Subprogram (E) then
9918                Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
9919 
9920             --  Otherwise set public and statically allocated
9921 
9922             else
9923                Set_Is_Public (E);
9924                Set_Is_Statically_Allocated (E);
9925 
9926                --  Warn if the corresponding W flag is set
9927 
9928                if Warn_On_Export_Import
9929 
9930                  --  Only do this for something that was in the source. Not
9931                  --  clear if this can be False now (there used for sure to be
9932                  --  cases on some systems where it was False), but anyway the
9933                  --  test is harmless if not needed, so it is retained.
9934 
9935                  and then Comes_From_Source (Arg)
9936                then
9937                   Error_Msg_NE
9938                     ("?x?& has been made static as a result of Export",
9939                      Arg, E);
9940                   Error_Msg_N
9941                     ("\?x?this usage is non-standard and non-portable",
9942                      Arg);
9943                end if;
9944             end if;
9945          end if;
9946 
9947          if Warn_On_Export_Import and then Is_Type (E) then
9948             Error_Msg_NE ("exporting a type has no effect?x?", Arg, E);
9949          end if;
9950 
9951          if Warn_On_Export_Import and Inside_A_Generic then
9952             Error_Msg_NE
9953               ("all instances of& will have the same external name?x?",
9954                Arg, E);
9955          end if;
9956       end Set_Exported;
9957 
9958       ----------------------------------------------
9959       -- Set_Extended_Import_Export_External_Name --
9960       ----------------------------------------------
9961 
9962       procedure Set_Extended_Import_Export_External_Name
9963         (Internal_Ent : Entity_Id;
9964          Arg_External : Node_Id)
9965       is
9966          Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
9967          New_Name : Node_Id;
9968 
9969       begin
9970          if No (Arg_External) then
9971             return;
9972          end if;
9973 
9974          Check_Arg_Is_External_Name (Arg_External);
9975 
9976          if Nkind (Arg_External) = N_String_Literal then
9977             if String_Length (Strval (Arg_External)) = 0 then
9978                return;
9979             else
9980                New_Name := Adjust_External_Name_Case (Arg_External);
9981             end if;
9982 
9983          elsif Nkind (Arg_External) = N_Identifier then
9984             New_Name := Get_Default_External_Name (Arg_External);
9985 
9986          --  Check_Arg_Is_External_Name should let through only identifiers and
9987          --  string literals or static string expressions (which are folded to
9988          --  string literals).
9989 
9990          else
9991             raise Program_Error;
9992          end if;
9993 
9994          --  If we already have an external name set (by a prior normal Import
9995          --  or Export pragma), then the external names must match
9996 
9997          if Present (Interface_Name (Internal_Ent)) then
9998 
9999             --  Ignore mismatching names in CodePeer mode, to support some
10000             --  old compilers which would export the same procedure under
10001             --  different names, e.g:
10002             --     procedure P;
10003             --     pragma Export_Procedure (P, "a");
10004             --     pragma Export_Procedure (P, "b");
10005 
10006             if CodePeer_Mode then
10007                return;
10008             end if;
10009 
10010             Check_Matching_Internal_Names : declare
10011                S1 : constant String_Id := Strval (Old_Name);
10012                S2 : constant String_Id := Strval (New_Name);
10013 
10014                procedure Mismatch;
10015                pragma No_Return (Mismatch);
10016                --  Called if names do not match
10017 
10018                --------------
10019                -- Mismatch --
10020                --------------
10021 
10022                procedure Mismatch is
10023                begin
10024                   Error_Msg_Sloc := Sloc (Old_Name);
10025                   Error_Pragma_Arg
10026                     ("external name does not match that given #",
10027                      Arg_External);
10028                end Mismatch;
10029 
10030             --  Start of processing for Check_Matching_Internal_Names
10031 
10032             begin
10033                if String_Length (S1) /= String_Length (S2) then
10034                   Mismatch;
10035 
10036                else
10037                   for J in 1 .. String_Length (S1) loop
10038                      if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
10039                         Mismatch;
10040                      end if;
10041                   end loop;
10042                end if;
10043             end Check_Matching_Internal_Names;
10044 
10045          --  Otherwise set the given name
10046 
10047          else
10048             Set_Encoded_Interface_Name (Internal_Ent, New_Name);
10049             Check_Duplicated_Export_Name (New_Name);
10050          end if;
10051       end Set_Extended_Import_Export_External_Name;
10052 
10053       ------------------
10054       -- Set_Imported --
10055       ------------------
10056 
10057       procedure Set_Imported (E : Entity_Id) is
10058       begin
10059          --  Error message if already imported or exported
10060 
10061          if Is_Exported (E) or else Is_Imported (E) then
10062 
10063             --  Error if being set Exported twice
10064 
10065             if Is_Exported (E) then
10066                Error_Msg_NE ("entity& was previously exported", N, E);
10067 
10068             --  Ignore error in CodePeer mode where we treat all imported
10069             --  subprograms as unknown.
10070 
10071             elsif CodePeer_Mode then
10072                goto OK;
10073 
10074             --  OK if Import/Interface case
10075 
10076             elsif Import_Interface_Present (N) then
10077                goto OK;
10078 
10079             --  Error if being set Imported twice
10080 
10081             else
10082                Error_Msg_NE ("entity& was previously imported", N, E);
10083             end if;
10084 
10085             Error_Msg_Name_1 := Pname;
10086             Error_Msg_N
10087               ("\(pragma% applies to all previous entities)", N);
10088 
10089             Error_Msg_Sloc  := Sloc (E);
10090             Error_Msg_NE ("\import not allowed for& declared#", N, E);
10091 
10092          --  Here if not previously imported or exported, OK to import
10093 
10094          else
10095             Set_Is_Imported (E);
10096 
10097             --  For subprogram, set Import_Pragma field
10098 
10099             if Is_Subprogram (E) then
10100                Set_Import_Pragma (E, N);
10101             end if;
10102 
10103             --  If the entity is an object that is not at the library level,
10104             --  then it is statically allocated. We do not worry about objects
10105             --  with address clauses in this context since they are not really
10106             --  imported in the linker sense.
10107 
10108             if Is_Object (E)
10109               and then not Is_Library_Level_Entity (E)
10110               and then No (Address_Clause (E))
10111             then
10112                Set_Is_Statically_Allocated (E);
10113             end if;
10114          end if;
10115 
10116          <<OK>> null;
10117       end Set_Imported;
10118 
10119       -------------------------
10120       -- Set_Mechanism_Value --
10121       -------------------------
10122 
10123       --  Note: the mechanism name has not been analyzed (and cannot indeed be
10124       --  analyzed, since it is semantic nonsense), so we get it in the exact
10125       --  form created by the parser.
10126 
10127       procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
10128          procedure Bad_Mechanism;
10129          pragma No_Return (Bad_Mechanism);
10130          --  Signal bad mechanism name
10131 
10132          -------------------------
10133          -- Bad_Mechanism_Value --
10134          -------------------------
10135 
10136          procedure Bad_Mechanism is
10137          begin
10138             Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
10139          end Bad_Mechanism;
10140 
10141       --  Start of processing for Set_Mechanism_Value
10142 
10143       begin
10144          if Mechanism (Ent) /= Default_Mechanism then
10145             Error_Msg_NE
10146               ("mechanism for & has already been set", Mech_Name, Ent);
10147          end if;
10148 
10149          --  MECHANISM_NAME ::= value | reference
10150 
10151          if Nkind (Mech_Name) = N_Identifier then
10152             if Chars (Mech_Name) = Name_Value then
10153                Set_Mechanism (Ent, By_Copy);
10154                return;
10155 
10156             elsif Chars (Mech_Name) = Name_Reference then
10157                Set_Mechanism (Ent, By_Reference);
10158                return;
10159 
10160             elsif Chars (Mech_Name) = Name_Copy then
10161                Error_Pragma_Arg
10162                  ("bad mechanism name, Value assumed", Mech_Name);
10163 
10164             else
10165                Bad_Mechanism;
10166             end if;
10167 
10168          else
10169             Bad_Mechanism;
10170          end if;
10171       end Set_Mechanism_Value;
10172 
10173       --------------------------
10174       -- Set_Rational_Profile --
10175       --------------------------
10176 
10177       --  The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10178       --  extension to the semantics of renaming declarations.
10179 
10180       procedure Set_Rational_Profile is
10181       begin
10182          Implicit_Packing     := True;
10183          Overriding_Renamings := True;
10184          Use_VADS_Size        := True;
10185       end Set_Rational_Profile;
10186 
10187       ---------------------------
10188       -- Set_Ravenscar_Profile --
10189       ---------------------------
10190 
10191       --  The tasks to be done here are
10192 
10193       --    Set required policies
10194 
10195       --      pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10196       --      pragma Locking_Policy (Ceiling_Locking)
10197 
10198       --    Set Detect_Blocking mode
10199 
10200       --    Set required restrictions (see System.Rident for detailed list)
10201 
10202       --    Set the No_Dependence rules
10203       --      No_Dependence => Ada.Asynchronous_Task_Control
10204       --      No_Dependence => Ada.Calendar
10205       --      No_Dependence => Ada.Execution_Time.Group_Budget
10206       --      No_Dependence => Ada.Execution_Time.Timers
10207       --      No_Dependence => Ada.Task_Attributes
10208       --      No_Dependence => System.Multiprocessors.Dispatching_Domains
10209 
10210       procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is
10211          procedure Set_Error_Msg_To_Profile_Name;
10212          --  Set Error_Msg_String and Error_Msg_Strlen to the name of the
10213          --  profile.
10214 
10215          -----------------------------------
10216          -- Set_Error_Msg_To_Profile_Name --
10217          -----------------------------------
10218 
10219          procedure Set_Error_Msg_To_Profile_Name is
10220             Prof_Nam : constant Node_Id :=
10221                          Get_Pragma_Arg
10222                            (First (Pragma_Argument_Associations (N)));
10223 
10224          begin
10225             Get_Name_String (Chars (Prof_Nam));
10226             Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
10227             Error_Msg_Strlen := Name_Len;
10228             Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
10229          end Set_Error_Msg_To_Profile_Name;
10230 
10231          --  Local variables
10232 
10233          Nod     : Node_Id;
10234          Pref    : Node_Id;
10235          Pref_Id : Node_Id;
10236          Sel_Id  : Node_Id;
10237 
10238       --  Start of processing for Set_Ravenscar_Profile
10239 
10240       begin
10241          --  pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10242 
10243          if Task_Dispatching_Policy /= ' '
10244            and then Task_Dispatching_Policy /= 'F'
10245          then
10246             Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
10247             Set_Error_Msg_To_Profile_Name;
10248             Error_Pragma ("Profile (~) incompatible with policy#");
10249 
10250          --  Set the FIFO_Within_Priorities policy, but always preserve
10251          --  System_Location since we like the error message with the run time
10252          --  name.
10253 
10254          else
10255             Task_Dispatching_Policy := 'F';
10256 
10257             if Task_Dispatching_Policy_Sloc /= System_Location then
10258                Task_Dispatching_Policy_Sloc := Loc;
10259             end if;
10260          end if;
10261 
10262          --  pragma Locking_Policy (Ceiling_Locking)
10263 
10264          if Locking_Policy /= ' '
10265            and then Locking_Policy /= 'C'
10266          then
10267             Error_Msg_Sloc := Locking_Policy_Sloc;
10268             Set_Error_Msg_To_Profile_Name;
10269             Error_Pragma ("Profile (~) incompatible with policy#");
10270 
10271          --  Set the Ceiling_Locking policy, but preserve System_Location since
10272          --  we like the error message with the run time name.
10273 
10274          else
10275             Locking_Policy := 'C';
10276 
10277             if Locking_Policy_Sloc /= System_Location then
10278                Locking_Policy_Sloc := Loc;
10279             end if;
10280          end if;
10281 
10282          --  pragma Detect_Blocking
10283 
10284          Detect_Blocking := True;
10285 
10286          --  Set the corresponding restrictions
10287 
10288          Set_Profile_Restrictions
10289            (Profile, N, Warn => Treat_Restrictions_As_Warnings);
10290 
10291          --  Set the No_Dependence restrictions
10292 
10293          --  The following No_Dependence restrictions:
10294          --    No_Dependence => Ada.Asynchronous_Task_Control
10295          --    No_Dependence => Ada.Calendar
10296          --    No_Dependence => Ada.Task_Attributes
10297          --  are already set by previous call to Set_Profile_Restrictions.
10298 
10299          --  Set the following restrictions which were added to Ada 2005:
10300          --    No_Dependence => Ada.Execution_Time.Group_Budget
10301          --    No_Dependence => Ada.Execution_Time.Timers
10302 
10303          --  ??? The use of Name_Buffer here is suspicious. The names should
10304          --  be registered in snames.ads-tmpl and used to build the qualified
10305          --  names of units.
10306 
10307          if Ada_Version >= Ada_2005 then
10308             Name_Buffer (1 .. 3) := "ada";
10309             Name_Len := 3;
10310 
10311             Pref_Id := Make_Identifier (Loc, Name_Find);
10312 
10313             Name_Buffer (1 .. 14) := "execution_time";
10314             Name_Len := 14;
10315 
10316             Sel_Id := Make_Identifier (Loc, Name_Find);
10317 
10318             Pref :=
10319               Make_Selected_Component
10320                 (Sloc          => Loc,
10321                  Prefix        => Pref_Id,
10322                  Selector_Name => Sel_Id);
10323 
10324             Name_Buffer (1 .. 13) := "group_budgets";
10325             Name_Len := 13;
10326 
10327             Sel_Id := Make_Identifier (Loc, Name_Find);
10328 
10329             Nod :=
10330               Make_Selected_Component
10331                 (Sloc          => Loc,
10332                  Prefix        => Pref,
10333                  Selector_Name => Sel_Id);
10334 
10335             Set_Restriction_No_Dependence
10336               (Unit    => Nod,
10337                Warn    => Treat_Restrictions_As_Warnings,
10338                Profile => Ravenscar);
10339 
10340             Name_Buffer (1 .. 6) := "timers";
10341             Name_Len := 6;
10342 
10343             Sel_Id := Make_Identifier (Loc, Name_Find);
10344 
10345             Nod :=
10346               Make_Selected_Component
10347                 (Sloc          => Loc,
10348                  Prefix        => Pref,
10349                  Selector_Name => Sel_Id);
10350 
10351             Set_Restriction_No_Dependence
10352               (Unit    => Nod,
10353                Warn    => Treat_Restrictions_As_Warnings,
10354                Profile => Ravenscar);
10355          end if;
10356 
10357          --  Set the following restriction which was added to Ada 2012 (see
10358          --  AI-0171):
10359          --    No_Dependence => System.Multiprocessors.Dispatching_Domains
10360 
10361          if Ada_Version >= Ada_2012 then
10362             Name_Buffer (1 .. 6) := "system";
10363             Name_Len := 6;
10364 
10365             Pref_Id := Make_Identifier (Loc, Name_Find);
10366 
10367             Name_Buffer (1 .. 15) := "multiprocessors";
10368             Name_Len := 15;
10369 
10370             Sel_Id := Make_Identifier (Loc, Name_Find);
10371 
10372             Pref :=
10373               Make_Selected_Component
10374                 (Sloc          => Loc,
10375                  Prefix        => Pref_Id,
10376                  Selector_Name => Sel_Id);
10377 
10378             Name_Buffer (1 .. 19) := "dispatching_domains";
10379             Name_Len := 19;
10380 
10381             Sel_Id := Make_Identifier (Loc, Name_Find);
10382 
10383             Nod :=
10384               Make_Selected_Component
10385                 (Sloc          => Loc,
10386                  Prefix        => Pref,
10387                  Selector_Name => Sel_Id);
10388 
10389             Set_Restriction_No_Dependence
10390               (Unit    => Nod,
10391                Warn    => Treat_Restrictions_As_Warnings,
10392                Profile => Ravenscar);
10393          end if;
10394       end Set_Ravenscar_Profile;
10395 
10396    --  Start of processing for Analyze_Pragma
10397 
10398    begin
10399       --  The following code is a defense against recursion. Not clear that
10400       --  this can happen legitimately, but perhaps some error situations can
10401       --  cause it, and we did see this recursion during testing.
10402 
10403       if Analyzed (N) then
10404          return;
10405       else
10406          Set_Analyzed (N);
10407       end if;
10408 
10409       Check_Restriction_No_Use_Of_Pragma (N);
10410 
10411       --  Deal with unrecognized pragma
10412 
10413       Pname := Pragma_Name (N);
10414 
10415       if not Is_Pragma_Name (Pname) then
10416          if Warn_On_Unrecognized_Pragma then
10417             Error_Msg_Name_1 := Pname;
10418             Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N));
10419 
10420             for PN in First_Pragma_Name .. Last_Pragma_Name loop
10421                if Is_Bad_Spelling_Of (Pname, PN) then
10422                   Error_Msg_Name_1 := PN;
10423                   Error_Msg_N -- CODEFIX
10424                     ("\?g?possible misspelling of %!", Pragma_Identifier (N));
10425                   exit;
10426                end if;
10427             end loop;
10428          end if;
10429 
10430          return;
10431       end if;
10432 
10433       --  Ignore pragma if Ignore_Pragma applies
10434 
10435       if Get_Name_Table_Boolean3 (Pname) then
10436          return;
10437       end if;
10438 
10439       --  Here to start processing for recognized pragma
10440 
10441       Prag_Id := Get_Pragma_Id (Pname);
10442       Pname   := Original_Aspect_Pragma_Name (N);
10443 
10444       --  Capture setting of Opt.Uneval_Old
10445 
10446       case Opt.Uneval_Old is
10447          when 'A' =>
10448             Set_Uneval_Old_Accept (N);
10449          when 'E' =>
10450             null;
10451          when 'W' =>
10452             Set_Uneval_Old_Warn (N);
10453          when others =>
10454             raise Program_Error;
10455       end case;
10456 
10457       --  Check applicable policy. We skip this if Is_Checked or Is_Ignored
10458       --  is already set, indicating that we have already checked the policy
10459       --  at the right point. This happens for example in the case of a pragma
10460       --  that is derived from an Aspect.
10461 
10462       if Is_Ignored (N) or else Is_Checked (N) then
10463          null;
10464 
10465       --  For a pragma that is a rewriting of another pragma, copy the
10466       --  Is_Checked/Is_Ignored status from the rewritten pragma.
10467 
10468       elsif Is_Rewrite_Substitution (N)
10469         and then Nkind (Original_Node (N)) = N_Pragma
10470         and then Original_Node (N) /= N
10471       then
10472          Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
10473          Set_Is_Checked (N, Is_Checked (Original_Node (N)));
10474 
10475       --  Otherwise query the applicable policy at this point
10476 
10477       else
10478          Check_Applicable_Policy (N);
10479 
10480          --  If pragma is disabled, rewrite as NULL and skip analysis
10481 
10482          if Is_Disabled (N) then
10483             Rewrite (N, Make_Null_Statement (Loc));
10484             Analyze (N);
10485             raise Pragma_Exit;
10486          end if;
10487       end if;
10488 
10489       --  Preset arguments
10490 
10491       Arg_Count := 0;
10492       Arg1      := Empty;
10493       Arg2      := Empty;
10494       Arg3      := Empty;
10495       Arg4      := Empty;
10496 
10497       if Present (Pragma_Argument_Associations (N)) then
10498          Arg_Count := List_Length (Pragma_Argument_Associations (N));
10499          Arg1 := First (Pragma_Argument_Associations (N));
10500 
10501          if Present (Arg1) then
10502             Arg2 := Next (Arg1);
10503 
10504             if Present (Arg2) then
10505                Arg3 := Next (Arg2);
10506 
10507                if Present (Arg3) then
10508                   Arg4 := Next (Arg3);
10509                end if;
10510             end if;
10511          end if;
10512       end if;
10513 
10514       --  An enumeration type defines the pragmas that are supported by the
10515       --  implementation. Get_Pragma_Id (in package Prag) transforms a name
10516       --  into the corresponding enumeration value for the following case.
10517 
10518       case Prag_Id is
10519 
10520          -----------------
10521          -- Abort_Defer --
10522          -----------------
10523 
10524          --  pragma Abort_Defer;
10525 
10526          when Pragma_Abort_Defer =>
10527             GNAT_Pragma;
10528             Check_Arg_Count (0);
10529 
10530             --  The only required semantic processing is to check the
10531             --  placement. This pragma must appear at the start of the
10532             --  statement sequence of a handled sequence of statements.
10533 
10534             if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
10535               or else N /= First (Statements (Parent (N)))
10536             then
10537                Pragma_Misplaced;
10538             end if;
10539 
10540          --------------------
10541          -- Abstract_State --
10542          --------------------
10543 
10544          --  pragma Abstract_State (ABSTRACT_STATE_LIST);
10545 
10546          --  ABSTRACT_STATE_LIST ::=
10547          --     null
10548          --  |  STATE_NAME_WITH_OPTIONS
10549          --  | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10550 
10551          --  STATE_NAME_WITH_OPTIONS ::=
10552          --     STATE_NAME
10553          --  | (STATE_NAME with OPTION_LIST)
10554 
10555          --  OPTION_LIST ::= OPTION {, OPTION}
10556 
10557          --  OPTION ::=
10558          --    SIMPLE_OPTION
10559          --  | NAME_VALUE_OPTION
10560 
10561          --  SIMPLE_OPTION ::= Ghost | Synchronous
10562 
10563          --  NAME_VALUE_OPTION ::=
10564          --    Part_Of => ABSTRACT_STATE
10565          --  | External [=> EXTERNAL_PROPERTY_LIST]
10566 
10567          --  EXTERNAL_PROPERTY_LIST ::=
10568          --     EXTERNAL_PROPERTY
10569          --  | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10570 
10571          --  EXTERNAL_PROPERTY ::=
10572          --    Async_Readers    [=> boolean_EXPRESSION]
10573          --  | Async_Writers    [=> boolean_EXPRESSION]
10574          --  | Effective_Reads  [=> boolean_EXPRESSION]
10575          --  | Effective_Writes [=> boolean_EXPRESSION]
10576          --    others            => boolean_EXPRESSION
10577 
10578          --  STATE_NAME ::= defining_identifier
10579 
10580          --  ABSTRACT_STATE ::= name
10581 
10582          --  Characteristics:
10583 
10584          --    * Analysis - The annotation is fully analyzed immediately upon
10585          --    elaboration as it cannot forward reference entities.
10586 
10587          --    * Expansion - None.
10588 
10589          --    * Template - The annotation utilizes the generic template of the
10590          --    related package declaration.
10591 
10592          --    * Globals - The annotation cannot reference global entities.
10593 
10594          --    * Instance - The annotation is instantiated automatically when
10595          --    the related generic package is instantiated.
10596 
10597          when Pragma_Abstract_State => Abstract_State : declare
10598             Missing_Parentheses : Boolean := False;
10599             --  Flag set when a state declaration with options is not properly
10600             --  parenthesized.
10601 
10602             --  Flags used to verify the consistency of states
10603 
10604             Non_Null_Seen : Boolean := False;
10605             Null_Seen     : Boolean := False;
10606 
10607             procedure Analyze_Abstract_State
10608               (State   : Node_Id;
10609                Pack_Id : Entity_Id);
10610             --  Verify the legality of a single state declaration. Create and
10611             --  decorate a state abstraction entity and introduce it into the
10612             --  visibility chain. Pack_Id denotes the entity or the related
10613             --  package where pragma Abstract_State appears.
10614 
10615             procedure Malformed_State_Error (State : Node_Id);
10616             --  Emit an error concerning the illegal declaration of abstract
10617             --  state State. This routine diagnoses syntax errors that lead to
10618             --  a different parse tree. The error is issued regardless of the
10619             --  SPARK mode in effect.
10620 
10621             ----------------------------
10622             -- Analyze_Abstract_State --
10623             ----------------------------
10624 
10625             procedure Analyze_Abstract_State
10626               (State   : Node_Id;
10627                Pack_Id : Entity_Id)
10628             is
10629                --  Flags used to verify the consistency of options
10630 
10631                AR_Seen          : Boolean := False;
10632                AW_Seen          : Boolean := False;
10633                ER_Seen          : Boolean := False;
10634                EW_Seen          : Boolean := False;
10635                External_Seen    : Boolean := False;
10636                Ghost_Seen       : Boolean := False;
10637                Others_Seen      : Boolean := False;
10638                Part_Of_Seen     : Boolean := False;
10639                Synchronous_Seen : Boolean := False;
10640 
10641                --  Flags used to store the static value of all external states'
10642                --  expressions.
10643 
10644                AR_Val : Boolean := False;
10645                AW_Val : Boolean := False;
10646                ER_Val : Boolean := False;
10647                EW_Val : Boolean := False;
10648 
10649                State_Id : Entity_Id := Empty;
10650                --  The entity to be generated for the current state declaration
10651 
10652                procedure Analyze_External_Option (Opt : Node_Id);
10653                --  Verify the legality of option External
10654 
10655                procedure Analyze_External_Property
10656                  (Prop : Node_Id;
10657                   Expr : Node_Id := Empty);
10658                --  Verify the legailty of a single external property. Prop
10659                --  denotes the external property. Expr is the expression used
10660                --  to set the property.
10661 
10662                procedure Analyze_Part_Of_Option (Opt : Node_Id);
10663                --  Verify the legality of option Part_Of
10664 
10665                procedure Check_Duplicate_Option
10666                  (Opt    : Node_Id;
10667                   Status : in out Boolean);
10668                --  Flag Status denotes whether a particular option has been
10669                --  seen while processing a state. This routine verifies that
10670                --  Opt is not a duplicate option and sets the flag Status
10671                --  (SPARK RM 7.1.4(1)).
10672 
10673                procedure Check_Duplicate_Property
10674                  (Prop   : Node_Id;
10675                   Status : in out Boolean);
10676                --  Flag Status denotes whether a particular property has been
10677                --  seen while processing option External. This routine verifies
10678                --  that Prop is not a duplicate property and sets flag Status.
10679                --  Opt is not a duplicate property and sets the flag Status.
10680                --  (SPARK RM 7.1.4(2))
10681 
10682                procedure Check_Ghost_Synchronous;
10683                --  Ensure that the abstract state is not subject to both Ghost
10684                --  and Synchronous simple options. Emit an error if this is the
10685                --  case.
10686 
10687                procedure Create_Abstract_State
10688                  (Nam     : Name_Id;
10689                   Decl    : Node_Id;
10690                   Loc     : Source_Ptr;
10691                   Is_Null : Boolean);
10692                --  Generate an abstract state entity with name Nam and enter it
10693                --  into visibility. Decl is the "declaration" of the state as
10694                --  it appears in pragma Abstract_State. Loc is the location of
10695                --  the related state "declaration". Flag Is_Null should be set
10696                --  when the associated Abstract_State pragma defines a null
10697                --  state.
10698 
10699                -----------------------------
10700                -- Analyze_External_Option --
10701                -----------------------------
10702 
10703                procedure Analyze_External_Option (Opt : Node_Id) is
10704                   Errors : constant Nat := Serious_Errors_Detected;
10705                   Prop   : Node_Id;
10706                   Props  : Node_Id := Empty;
10707 
10708                begin
10709                   if Nkind (Opt) = N_Component_Association then
10710                      Props := Expression (Opt);
10711                   end if;
10712 
10713                   --  External state with properties
10714 
10715                   if Present (Props) then
10716 
10717                      --  Multiple properties appear as an aggregate
10718 
10719                      if Nkind (Props) = N_Aggregate then
10720 
10721                         --  Simple property form
10722 
10723                         Prop := First (Expressions (Props));
10724                         while Present (Prop) loop
10725                            Analyze_External_Property (Prop);
10726                            Next (Prop);
10727                         end loop;
10728 
10729                         --  Property with expression form
10730 
10731                         Prop := First (Component_Associations (Props));
10732                         while Present (Prop) loop
10733                            Analyze_External_Property
10734                              (Prop => First (Choices (Prop)),
10735                               Expr => Expression (Prop));
10736 
10737                            Next (Prop);
10738                         end loop;
10739 
10740                      --  Single property
10741 
10742                      else
10743                         Analyze_External_Property (Props);
10744                      end if;
10745 
10746                   --  An external state defined without any properties defaults
10747                   --  all properties to True.
10748 
10749                   else
10750                      AR_Val := True;
10751                      AW_Val := True;
10752                      ER_Val := True;
10753                      EW_Val := True;
10754                   end if;
10755 
10756                   --  Once all external properties have been processed, verify
10757                   --  their mutual interaction. Do not perform the check when
10758                   --  at least one of the properties is illegal as this will
10759                   --  produce a bogus error.
10760 
10761                   if Errors = Serious_Errors_Detected then
10762                      Check_External_Properties
10763                        (State, AR_Val, AW_Val, ER_Val, EW_Val);
10764                   end if;
10765                end Analyze_External_Option;
10766 
10767                -------------------------------
10768                -- Analyze_External_Property --
10769                -------------------------------
10770 
10771                procedure Analyze_External_Property
10772                  (Prop : Node_Id;
10773                   Expr : Node_Id := Empty)
10774                is
10775                   Expr_Val : Boolean;
10776 
10777                begin
10778                   --  Check the placement of "others" (if available)
10779 
10780                   if Nkind (Prop) = N_Others_Choice then
10781                      if Others_Seen then
10782                         SPARK_Msg_N
10783                           ("only one others choice allowed in option External",
10784                            Prop);
10785                      else
10786                         Others_Seen := True;
10787                      end if;
10788 
10789                   elsif Others_Seen then
10790                      SPARK_Msg_N
10791                        ("others must be the last property in option External",
10792                         Prop);
10793 
10794                   --  The only remaining legal options are the four predefined
10795                   --  external properties.
10796 
10797                   elsif Nkind (Prop) = N_Identifier
10798                     and then Nam_In (Chars (Prop), Name_Async_Readers,
10799                                                    Name_Async_Writers,
10800                                                    Name_Effective_Reads,
10801                                                    Name_Effective_Writes)
10802                   then
10803                      null;
10804 
10805                   --  Otherwise the construct is not a valid property
10806 
10807                   else
10808                      SPARK_Msg_N ("invalid external state property", Prop);
10809                      return;
10810                   end if;
10811 
10812                   --  Ensure that the expression of the external state property
10813                   --  is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10814 
10815                   if Present (Expr) then
10816                      Analyze_And_Resolve (Expr, Standard_Boolean);
10817 
10818                      if Is_OK_Static_Expression (Expr) then
10819                         Expr_Val := Is_True (Expr_Value (Expr));
10820                      else
10821                         SPARK_Msg_N
10822                           ("expression of external state property must be "
10823                            & "static", Expr);
10824                      end if;
10825 
10826                   --  The lack of expression defaults the property to True
10827 
10828                   else
10829                      Expr_Val := True;
10830                   end if;
10831 
10832                   --  Named properties
10833 
10834                   if Nkind (Prop) = N_Identifier then
10835                      if Chars (Prop) = Name_Async_Readers then
10836                         Check_Duplicate_Property (Prop, AR_Seen);
10837                         AR_Val := Expr_Val;
10838 
10839                      elsif Chars (Prop) = Name_Async_Writers then
10840                         Check_Duplicate_Property (Prop, AW_Seen);
10841                         AW_Val := Expr_Val;
10842 
10843                      elsif Chars (Prop) = Name_Effective_Reads then
10844                         Check_Duplicate_Property (Prop, ER_Seen);
10845                         ER_Val := Expr_Val;
10846 
10847                      else
10848                         Check_Duplicate_Property (Prop, EW_Seen);
10849                         EW_Val := Expr_Val;
10850                      end if;
10851 
10852                   --  The handling of property "others" must take into account
10853                   --  all other named properties that have been encountered so
10854                   --  far. Only those that have not been seen are affected by
10855                   --  "others".
10856 
10857                   else
10858                      if not AR_Seen then
10859                         AR_Val := Expr_Val;
10860                      end if;
10861 
10862                      if not AW_Seen then
10863                         AW_Val := Expr_Val;
10864                      end if;
10865 
10866                      if not ER_Seen then
10867                         ER_Val := Expr_Val;
10868                      end if;
10869 
10870                      if not EW_Seen then
10871                         EW_Val := Expr_Val;
10872                      end if;
10873                   end if;
10874                end Analyze_External_Property;
10875 
10876                ----------------------------
10877                -- Analyze_Part_Of_Option --
10878                ----------------------------
10879 
10880                procedure Analyze_Part_Of_Option (Opt : Node_Id) is
10881                   Encap    : constant Node_Id := Expression (Opt);
10882                   Constits : Elist_Id;
10883                   Encap_Id : Entity_Id;
10884                   Legal    : Boolean;
10885 
10886                begin
10887                   Check_Duplicate_Option (Opt, Part_Of_Seen);
10888 
10889                   Analyze_Part_Of
10890                     (Indic    => First (Choices (Opt)),
10891                      Item_Id  => State_Id,
10892                      Encap    => Encap,
10893                      Encap_Id => Encap_Id,
10894                      Legal    => Legal);
10895 
10896                   --  The Part_Of indicator transforms the abstract state into
10897                   --  a constituent of the encapsulating state or single
10898                   --  concurrent type.
10899 
10900                   if Legal then
10901                      pragma Assert (Present (Encap_Id));
10902                      Constits := Part_Of_Constituents (Encap_Id);
10903 
10904                      if No (Constits) then
10905                         Constits := New_Elmt_List;
10906                         Set_Part_Of_Constituents (Encap_Id, Constits);
10907                      end if;
10908 
10909                      Append_Elmt (State_Id, Constits);
10910                      Set_Encapsulating_State (State_Id, Encap_Id);
10911                   end if;
10912                end Analyze_Part_Of_Option;
10913 
10914                ----------------------------
10915                -- Check_Duplicate_Option --
10916                ----------------------------
10917 
10918                procedure Check_Duplicate_Option
10919                  (Opt    : Node_Id;
10920                   Status : in out Boolean)
10921                is
10922                begin
10923                   if Status then
10924                      SPARK_Msg_N ("duplicate state option", Opt);
10925                   end if;
10926 
10927                   Status := True;
10928                end Check_Duplicate_Option;
10929 
10930                ------------------------------
10931                -- Check_Duplicate_Property --
10932                ------------------------------
10933 
10934                procedure Check_Duplicate_Property
10935                  (Prop   : Node_Id;
10936                   Status : in out Boolean)
10937                is
10938                begin
10939                   if Status then
10940                      SPARK_Msg_N ("duplicate external property", Prop);
10941                   end if;
10942 
10943                   Status := True;
10944                end Check_Duplicate_Property;
10945 
10946                -----------------------------
10947                -- Check_Ghost_Synchronous --
10948                -----------------------------
10949 
10950                procedure Check_Ghost_Synchronous is
10951                begin
10952                   --  A synchronized abstract state cannot be Ghost and vice
10953                   --  versa (SPARK RM 6.9(19)).
10954 
10955                   if Ghost_Seen and Synchronous_Seen then
10956                      SPARK_Msg_N ("synchronized state cannot be ghost", State);
10957                   end if;
10958                end Check_Ghost_Synchronous;
10959 
10960                ---------------------------
10961                -- Create_Abstract_State --
10962                ---------------------------
10963 
10964                procedure Create_Abstract_State
10965                  (Nam     : Name_Id;
10966                   Decl    : Node_Id;
10967                   Loc     : Source_Ptr;
10968                   Is_Null : Boolean)
10969                is
10970                begin
10971                   --  The abstract state may be semi-declared when the related
10972                   --  package was withed through a limited with clause. In that
10973                   --  case reuse the entity to fully declare the state.
10974 
10975                   if Present (Decl) and then Present (Entity (Decl)) then
10976                      State_Id := Entity (Decl);
10977 
10978                   --  Otherwise the elaboration of pragma Abstract_State
10979                   --  declares the state.
10980 
10981                   else
10982                      State_Id := Make_Defining_Identifier (Loc, Nam);
10983 
10984                      if Present (Decl) then
10985                         Set_Entity (Decl, State_Id);
10986                      end if;
10987                   end if;
10988 
10989                   --  Null states never come from source
10990 
10991                   Set_Comes_From_Source   (State_Id, not Is_Null);
10992                   Set_Parent              (State_Id, State);
10993                   Set_Ekind               (State_Id, E_Abstract_State);
10994                   Set_Etype               (State_Id, Standard_Void_Type);
10995                   Set_Encapsulating_State (State_Id, Empty);
10996 
10997                   --  An abstract state declared within a Ghost region becomes
10998                   --  Ghost (SPARK RM 6.9(2)).
10999 
11000                   if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then
11001                      Set_Is_Ghost_Entity (State_Id);
11002                   end if;
11003 
11004                   --  Establish a link between the state declaration and the
11005                   --  abstract state entity. Note that a null state remains as
11006                   --  N_Null and does not carry any linkages.
11007 
11008                   if not Is_Null then
11009                      if Present (Decl) then
11010                         Set_Entity (Decl, State_Id);
11011                         Set_Etype  (Decl, Standard_Void_Type);
11012                      end if;
11013 
11014                      --  Every non-null state must be defined, nameable and
11015                      --  resolvable.
11016 
11017                      Push_Scope (Pack_Id);
11018                      Generate_Definition (State_Id);
11019                      Enter_Name (State_Id);
11020                      Pop_Scope;
11021                   end if;
11022                end Create_Abstract_State;
11023 
11024                --  Local variables
11025 
11026                Opt     : Node_Id;
11027                Opt_Nam : Node_Id;
11028 
11029             --  Start of processing for Analyze_Abstract_State
11030 
11031             begin
11032                --  A package with a null abstract state is not allowed to
11033                --  declare additional states.
11034 
11035                if Null_Seen then
11036                   SPARK_Msg_NE
11037                     ("package & has null abstract state", State, Pack_Id);
11038 
11039                --  Null states appear as internally generated entities
11040 
11041                elsif Nkind (State) = N_Null then
11042                   Create_Abstract_State
11043                     (Nam     => New_Internal_Name ('S'),
11044                      Decl    => Empty,
11045                      Loc     => Sloc (State),
11046                      Is_Null => True);
11047                   Null_Seen := True;
11048 
11049                   --  Catch a case where a null state appears in a list of
11050                   --  non-null states.
11051 
11052                   if Non_Null_Seen then
11053                      SPARK_Msg_NE
11054                        ("package & has non-null abstract state",
11055                         State, Pack_Id);
11056                   end if;
11057 
11058                --  Simple state declaration
11059 
11060                elsif Nkind (State) = N_Identifier then
11061                   Create_Abstract_State
11062                     (Nam     => Chars (State),
11063                      Decl    => State,
11064                      Loc     => Sloc (State),
11065                      Is_Null => False);
11066                   Non_Null_Seen := True;
11067 
11068                --  State declaration with various options. This construct
11069                --  appears as an extension aggregate in the tree.
11070 
11071                elsif Nkind (State) = N_Extension_Aggregate then
11072                   if Nkind (Ancestor_Part (State)) = N_Identifier then
11073                      Create_Abstract_State
11074                        (Nam     => Chars (Ancestor_Part (State)),
11075                         Decl    => Ancestor_Part (State),
11076                         Loc     => Sloc (Ancestor_Part (State)),
11077                         Is_Null => False);
11078                      Non_Null_Seen := True;
11079                   else
11080                      SPARK_Msg_N
11081                        ("state name must be an identifier",
11082                         Ancestor_Part (State));
11083                   end if;
11084 
11085                   --  Options External, Ghost and Synchronous appear as
11086                   --  expressions.
11087 
11088                   Opt := First (Expressions (State));
11089                   while Present (Opt) loop
11090                      if Nkind (Opt) = N_Identifier then
11091 
11092                         --  External
11093 
11094                         if Chars (Opt) = Name_External then
11095                            Check_Duplicate_Option (Opt, External_Seen);
11096                            Analyze_External_Option (Opt);
11097 
11098                         --  Ghost
11099 
11100                         elsif Chars (Opt) = Name_Ghost then
11101                            Check_Duplicate_Option (Opt, Ghost_Seen);
11102                            Check_Ghost_Synchronous;
11103 
11104                            if Present (State_Id) then
11105                               Set_Is_Ghost_Entity (State_Id);
11106                            end if;
11107 
11108                         --  Synchronous
11109 
11110                         elsif Chars (Opt) = Name_Synchronous then
11111                            Check_Duplicate_Option (Opt, Synchronous_Seen);
11112                            Check_Ghost_Synchronous;
11113 
11114                         --  Option Part_Of without an encapsulating state is
11115                         --  illegal (SPARK RM 7.1.4(9)).
11116 
11117                         elsif Chars (Opt) = Name_Part_Of then
11118                            SPARK_Msg_N
11119                              ("indicator Part_Of must denote abstract state, "
11120                               & "single protected type or single task type",
11121                               Opt);
11122 
11123                         --  Do not emit an error message when a previous state
11124                         --  declaration with options was not parenthesized as
11125                         --  the option is actually another state declaration.
11126                         --
11127                         --    with Abstract_State
11128                         --      (State_1 with ...,   --  missing parentheses
11129                         --      (State_2 with ...),
11130                         --       State_3)            --  ok state declaration
11131 
11132                         elsif Missing_Parentheses then
11133                            null;
11134 
11135                         --  Otherwise the option is not allowed. Note that it
11136                         --  is not possible to distinguish between an option
11137                         --  and a state declaration when a previous state with
11138                         --  options not properly parentheses.
11139                         --
11140                         --    with Abstract_State
11141                         --      (State_1 with ...,  --  missing parentheses
11142                         --       State_2);          --  could be an option
11143 
11144                         else
11145                            SPARK_Msg_N
11146                              ("simple option not allowed in state declaration",
11147                               Opt);
11148                         end if;
11149 
11150                      --  Catch a case where missing parentheses around a state
11151                      --  declaration with options cause a subsequent state
11152                      --  declaration with options to be treated as an option.
11153                      --
11154                      --    with Abstract_State
11155                      --      (State_1 with ...,   --  missing parentheses
11156                      --      (State_2 with ...))
11157 
11158                      elsif Nkind (Opt) = N_Extension_Aggregate then
11159                         Missing_Parentheses := True;
11160                         SPARK_Msg_N
11161                           ("state declaration must be parenthesized",
11162                            Ancestor_Part (State));
11163 
11164                      --  Otherwise the option is malformed
11165 
11166                      else
11167                         SPARK_Msg_N ("malformed option", Opt);
11168                      end if;
11169 
11170                      Next (Opt);
11171                   end loop;
11172 
11173                   --  Options External and Part_Of appear as component
11174                   --  associations.
11175 
11176                   Opt := First (Component_Associations (State));
11177                   while Present (Opt) loop
11178                      Opt_Nam := First (Choices (Opt));
11179 
11180                      if Nkind (Opt_Nam) = N_Identifier then
11181                         if Chars (Opt_Nam) = Name_External then
11182                            Analyze_External_Option (Opt);
11183 
11184                         elsif Chars (Opt_Nam) = Name_Part_Of then
11185                            Analyze_Part_Of_Option (Opt);
11186 
11187                         else
11188                            SPARK_Msg_N ("invalid state option", Opt);
11189                         end if;
11190                      else
11191                         SPARK_Msg_N ("invalid state option", Opt);
11192                      end if;
11193 
11194                      Next (Opt);
11195                   end loop;
11196 
11197                --  Any other attempt to declare a state is illegal
11198 
11199                else
11200                   Malformed_State_Error (State);
11201                   return;
11202                end if;
11203 
11204                --  Guard against a junk state. In such cases no entity is
11205                --  generated and the subsequent checks cannot be applied.
11206 
11207                if Present (State_Id) then
11208 
11209                   --  Verify whether the state does not introduce an illegal
11210                   --  hidden state within a package subject to a null abstract
11211                   --  state.
11212 
11213                   Check_No_Hidden_State (State_Id);
11214 
11215                   --  Check whether the lack of option Part_Of agrees with the
11216                   --  placement of the abstract state with respect to the state
11217                   --  space.
11218 
11219                   if not Part_Of_Seen then
11220                      Check_Missing_Part_Of (State_Id);
11221                   end if;
11222 
11223                   --  Associate the state with its related package
11224 
11225                   if No (Abstract_States (Pack_Id)) then
11226                      Set_Abstract_States (Pack_Id, New_Elmt_List);
11227                   end if;
11228 
11229                   Append_Elmt (State_Id, Abstract_States (Pack_Id));
11230                end if;
11231             end Analyze_Abstract_State;
11232 
11233             ---------------------------
11234             -- Malformed_State_Error --
11235             ---------------------------
11236 
11237             procedure Malformed_State_Error (State : Node_Id) is
11238             begin
11239                Error_Msg_N ("malformed abstract state declaration", State);
11240 
11241                --  An abstract state with a simple option is being declared
11242                --  with "=>" rather than the legal "with". The state appears
11243                --  as a component association.
11244 
11245                if Nkind (State) = N_Component_Association then
11246                   Error_Msg_N ("\use WITH to specify simple option", State);
11247                end if;
11248             end Malformed_State_Error;
11249 
11250             --  Local variables
11251 
11252             Pack_Decl : Node_Id;
11253             Pack_Id   : Entity_Id;
11254             State     : Node_Id;
11255             States    : Node_Id;
11256 
11257          --  Start of processing for Abstract_State
11258 
11259          begin
11260             GNAT_Pragma;
11261             Check_No_Identifiers;
11262             Check_Arg_Count (1);
11263 
11264             Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
11265 
11266             --  Ensure the proper placement of the pragma. Abstract states must
11267             --  be associated with a package declaration.
11268 
11269             if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
11270                                     N_Package_Declaration)
11271             then
11272                null;
11273 
11274             --  Otherwise the pragma is associated with an illegal construct
11275 
11276             else
11277                Pragma_Misplaced;
11278                return;
11279             end if;
11280 
11281             Pack_Id := Defining_Entity (Pack_Decl);
11282 
11283             --  Chain the pragma on the contract for completeness
11284 
11285             Add_Contract_Item (N, Pack_Id);
11286 
11287             --  The legality checks of pragmas Abstract_State, Initializes, and
11288             --  Initial_Condition are affected by the SPARK mode in effect. In
11289             --  addition, these three pragmas are subject to an inherent order:
11290 
11291             --    1) Abstract_State
11292             --    2) Initializes
11293             --    3) Initial_Condition
11294 
11295             --  Analyze all these pragmas in the order outlined above
11296 
11297             Analyze_If_Present (Pragma_SPARK_Mode);
11298 
11299             --  A pragma that applies to a Ghost entity becomes Ghost for the
11300             --  purposes of legality checks and removal of ignored Ghost code.
11301 
11302             Mark_Pragma_As_Ghost (N, Pack_Id);
11303             Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
11304 
11305             States := Expression (Get_Argument (N, Pack_Id));
11306 
11307             --  Multiple non-null abstract states appear as an aggregate
11308 
11309             if Nkind (States) = N_Aggregate then
11310                State := First (Expressions (States));
11311                while Present (State) loop
11312                   Analyze_Abstract_State (State, Pack_Id);
11313                   Next (State);
11314                end loop;
11315 
11316                --  An abstract state with a simple option is being illegaly
11317                --  declared with "=>" rather than "with". In this case the
11318                --  state declaration appears as a component association.
11319 
11320                if Present (Component_Associations (States)) then
11321                   State := First (Component_Associations (States));
11322                   while Present (State) loop
11323                      Malformed_State_Error (State);
11324                      Next (State);
11325                   end loop;
11326                end if;
11327 
11328             --  Various forms of a single abstract state. Note that these may
11329             --  include malformed state declarations.
11330 
11331             else
11332                Analyze_Abstract_State (States, Pack_Id);
11333             end if;
11334 
11335             Analyze_If_Present (Pragma_Initializes);
11336             Analyze_If_Present (Pragma_Initial_Condition);
11337          end Abstract_State;
11338 
11339          ------------
11340          -- Ada_83 --
11341          ------------
11342 
11343          --  pragma Ada_83;
11344 
11345          --  Note: this pragma also has some specific processing in Par.Prag
11346          --  because we want to set the Ada version mode during parsing.
11347 
11348          when Pragma_Ada_83 =>
11349             GNAT_Pragma;
11350             Check_Arg_Count (0);
11351 
11352             --  We really should check unconditionally for proper configuration
11353             --  pragma placement, since we really don't want mixed Ada modes
11354             --  within a single unit, and the GNAT reference manual has always
11355             --  said this was a configuration pragma, but we did not check and
11356             --  are hesitant to add the check now.
11357 
11358             --  However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11359             --  with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11360             --  or Ada 2012 mode.
11361 
11362             if Ada_Version >= Ada_2005 then
11363                Check_Valid_Configuration_Pragma;
11364             end if;
11365 
11366             --  Now set Ada 83 mode
11367 
11368             if not Latest_Ada_Only then
11369                Ada_Version          := Ada_83;
11370                Ada_Version_Explicit := Ada_83;
11371                Ada_Version_Pragma   := N;
11372             end if;
11373 
11374          ------------
11375          -- Ada_95 --
11376          ------------
11377 
11378          --  pragma Ada_95;
11379 
11380          --  Note: this pragma also has some specific processing in Par.Prag
11381          --  because we want to set the Ada 83 version mode during parsing.
11382 
11383          when Pragma_Ada_95 =>
11384             GNAT_Pragma;
11385             Check_Arg_Count (0);
11386 
11387             --  We really should check unconditionally for proper configuration
11388             --  pragma placement, since we really don't want mixed Ada modes
11389             --  within a single unit, and the GNAT reference manual has always
11390             --  said this was a configuration pragma, but we did not check and
11391             --  are hesitant to add the check now.
11392 
11393             --  However, we really cannot tolerate mixing Ada 2005 with Ada 83
11394             --  or Ada 95, so we must check if we are in Ada 2005 mode.
11395 
11396             if Ada_Version >= Ada_2005 then
11397                Check_Valid_Configuration_Pragma;
11398             end if;
11399 
11400             --  Now set Ada 95 mode
11401 
11402             if not Latest_Ada_Only then
11403                Ada_Version          := Ada_95;
11404                Ada_Version_Explicit := Ada_95;
11405                Ada_Version_Pragma   := N;
11406             end if;
11407 
11408          ---------------------
11409          -- Ada_05/Ada_2005 --
11410          ---------------------
11411 
11412          --  pragma Ada_05;
11413          --  pragma Ada_05 (LOCAL_NAME);
11414 
11415          --  pragma Ada_2005;
11416          --  pragma Ada_2005 (LOCAL_NAME):
11417 
11418          --  Note: these pragmas also have some specific processing in Par.Prag
11419          --  because we want to set the Ada 2005 version mode during parsing.
11420 
11421          --  The one argument form is used for managing the transition from
11422          --  Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11423          --  as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11424          --  mode will generate a warning. In addition, in Ada_83 or Ada_95
11425          --  mode, a preference rule is established which does not choose
11426          --  such an entity unless it is unambiguously specified. This avoids
11427          --  extra subprograms marked this way from generating ambiguities in
11428          --  otherwise legal pre-Ada_2005 programs. The one argument form is
11429          --  intended for exclusive use in the GNAT run-time library.
11430 
11431          when Pragma_Ada_05 | Pragma_Ada_2005 => declare
11432             E_Id : Node_Id;
11433 
11434          begin
11435             GNAT_Pragma;
11436 
11437             if Arg_Count = 1 then
11438                Check_Arg_Is_Local_Name (Arg1);
11439                E_Id := Get_Pragma_Arg (Arg1);
11440 
11441                if Etype (E_Id) = Any_Type then
11442                   return;
11443                end if;
11444 
11445                Set_Is_Ada_2005_Only (Entity (E_Id));
11446                Record_Rep_Item (Entity (E_Id), N);
11447 
11448             else
11449                Check_Arg_Count (0);
11450 
11451                --  For Ada_2005 we unconditionally enforce the documented
11452                --  configuration pragma placement, since we do not want to
11453                --  tolerate mixed modes in a unit involving Ada 2005. That
11454                --  would cause real difficulties for those cases where there
11455                --  are incompatibilities between Ada 95 and Ada 2005.
11456 
11457                Check_Valid_Configuration_Pragma;
11458 
11459                --  Now set appropriate Ada mode
11460 
11461                if not Latest_Ada_Only then
11462                   Ada_Version          := Ada_2005;
11463                   Ada_Version_Explicit := Ada_2005;
11464                   Ada_Version_Pragma   := N;
11465                end if;
11466             end if;
11467          end;
11468 
11469          ---------------------
11470          -- Ada_12/Ada_2012 --
11471          ---------------------
11472 
11473          --  pragma Ada_12;
11474          --  pragma Ada_12 (LOCAL_NAME);
11475 
11476          --  pragma Ada_2012;
11477          --  pragma Ada_2012 (LOCAL_NAME):
11478 
11479          --  Note: these pragmas also have some specific processing in Par.Prag
11480          --  because we want to set the Ada 2012 version mode during parsing.
11481 
11482          --  The one argument form is used for managing the transition from Ada
11483          --  2005 to Ada 2012 in the run-time library. If an entity is marked
11484          --  as Ada_201 only, then referencing the entity in any pre-Ada_2012
11485          --  mode will generate a warning. In addition, in any pre-Ada_2012
11486          --  mode, a preference rule is established which does not choose
11487          --  such an entity unless it is unambiguously specified. This avoids
11488          --  extra subprograms marked this way from generating ambiguities in
11489          --  otherwise legal pre-Ada_2012 programs. The one argument form is
11490          --  intended for exclusive use in the GNAT run-time library.
11491 
11492          when Pragma_Ada_12 | Pragma_Ada_2012 => declare
11493             E_Id : Node_Id;
11494 
11495          begin
11496             GNAT_Pragma;
11497 
11498             if Arg_Count = 1 then
11499                Check_Arg_Is_Local_Name (Arg1);
11500                E_Id := Get_Pragma_Arg (Arg1);
11501 
11502                if Etype (E_Id) = Any_Type then
11503                   return;
11504                end if;
11505 
11506                Set_Is_Ada_2012_Only (Entity (E_Id));
11507                Record_Rep_Item (Entity (E_Id), N);
11508 
11509             else
11510                Check_Arg_Count (0);
11511 
11512                --  For Ada_2012 we unconditionally enforce the documented
11513                --  configuration pragma placement, since we do not want to
11514                --  tolerate mixed modes in a unit involving Ada 2012. That
11515                --  would cause real difficulties for those cases where there
11516                --  are incompatibilities between Ada 95 and Ada 2012. We could
11517                --  allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11518 
11519                Check_Valid_Configuration_Pragma;
11520 
11521                --  Now set appropriate Ada mode
11522 
11523                Ada_Version          := Ada_2012;
11524                Ada_Version_Explicit := Ada_2012;
11525                Ada_Version_Pragma   := N;
11526             end if;
11527          end;
11528 
11529          ----------------------
11530          -- All_Calls_Remote --
11531          ----------------------
11532 
11533          --  pragma All_Calls_Remote [(library_package_NAME)];
11534 
11535          when Pragma_All_Calls_Remote => All_Calls_Remote : declare
11536             Lib_Entity : Entity_Id;
11537 
11538          begin
11539             Check_Ada_83_Warning;
11540             Check_Valid_Library_Unit_Pragma;
11541 
11542             if Nkind (N) = N_Null_Statement then
11543                return;
11544             end if;
11545 
11546             Lib_Entity := Find_Lib_Unit_Name;
11547 
11548             --  A pragma that applies to a Ghost entity becomes Ghost for the
11549             --  purposes of legality checks and removal of ignored Ghost code.
11550 
11551             Mark_Pragma_As_Ghost (N, Lib_Entity);
11552 
11553             --  This pragma should only apply to a RCI unit (RM E.2.3(23))
11554 
11555             if Present (Lib_Entity) and then not Debug_Flag_U then
11556                if not Is_Remote_Call_Interface (Lib_Entity) then
11557                   Error_Pragma ("pragma% only apply to rci unit");
11558 
11559                --  Set flag for entity of the library unit
11560 
11561                else
11562                   Set_Has_All_Calls_Remote (Lib_Entity);
11563                end if;
11564             end if;
11565          end All_Calls_Remote;
11566 
11567          ---------------------------
11568          -- Allow_Integer_Address --
11569          ---------------------------
11570 
11571          --  pragma Allow_Integer_Address;
11572 
11573          when Pragma_Allow_Integer_Address =>
11574             GNAT_Pragma;
11575             Check_Valid_Configuration_Pragma;
11576             Check_Arg_Count (0);
11577 
11578             --  If Address is a private type, then set the flag to allow
11579             --  integer address values. If Address is not private, then this
11580             --  pragma has no purpose, so it is simply ignored. Not clear if
11581             --  there are any such targets now.
11582 
11583             if Opt.Address_Is_Private then
11584                Opt.Allow_Integer_Address := True;
11585             end if;
11586 
11587          --------------
11588          -- Annotate --
11589          --------------
11590 
11591          --  pragma Annotate
11592          --    (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11593          --  ARG ::= NAME | EXPRESSION
11594 
11595          --  The first two arguments are by convention intended to refer to an
11596          --  external tool and a tool-specific function. These arguments are
11597          --  not analyzed.
11598 
11599          when Pragma_Annotate => Annotate : declare
11600             Arg     : Node_Id;
11601             Expr    : Node_Id;
11602             Nam_Arg : Node_Id;
11603 
11604          begin
11605             GNAT_Pragma;
11606             Check_At_Least_N_Arguments (1);
11607 
11608             Nam_Arg := Last (Pragma_Argument_Associations (N));
11609 
11610             --  Determine whether the last argument is "Entity => local_NAME"
11611             --  and if it is, perform the required semantic checks. Remove the
11612             --  argument from further processing.
11613 
11614             if Nkind (Nam_Arg) = N_Pragma_Argument_Association
11615               and then Chars (Nam_Arg) = Name_Entity
11616             then
11617                Check_Arg_Is_Local_Name (Nam_Arg);
11618                Arg_Count := Arg_Count - 1;
11619 
11620                --  A pragma that applies to a Ghost entity becomes Ghost for
11621                --  the purposes of legality checks and removal of ignored Ghost
11622                --  code.
11623 
11624                if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
11625                  and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
11626                then
11627                   Mark_Pragma_As_Ghost (N, Entity (Get_Pragma_Arg (Nam_Arg)));
11628                end if;
11629 
11630                --  Not allowed in compiler units (bootstrap issues)
11631 
11632                Check_Compiler_Unit ("Entity for pragma Annotate", N);
11633             end if;
11634 
11635             --  Continue the processing with last argument removed for now
11636 
11637             Check_Arg_Is_Identifier (Arg1);
11638             Check_No_Identifiers;
11639             Store_Note (N);
11640 
11641             --  The second parameter is optional, it is never analyzed
11642 
11643             if No (Arg2) then
11644                null;
11645 
11646             --  Otherwise there is a second parameter
11647 
11648             else
11649                --  The second parameter must be an identifier
11650 
11651                Check_Arg_Is_Identifier (Arg2);
11652 
11653                --  Process the remaining parameters (if any)
11654 
11655                Arg := Next (Arg2);
11656                while Present (Arg) loop
11657                   Expr := Get_Pragma_Arg (Arg);
11658                   Analyze (Expr);
11659 
11660                   if Is_Entity_Name (Expr) then
11661                      null;
11662 
11663                   --  For string literals, we assume Standard_String as the
11664                   --  type, unless the string contains wide or wide_wide
11665                   --  characters.
11666 
11667                   elsif Nkind (Expr) = N_String_Literal then
11668                      if Has_Wide_Wide_Character (Expr) then
11669                         Resolve (Expr, Standard_Wide_Wide_String);
11670                      elsif Has_Wide_Character (Expr) then
11671                         Resolve (Expr, Standard_Wide_String);
11672                      else
11673                         Resolve (Expr, Standard_String);
11674                      end if;
11675 
11676                   elsif Is_Overloaded (Expr) then
11677                      Error_Pragma_Arg ("ambiguous argument for pragma%", Expr);
11678 
11679                   else
11680                      Resolve (Expr);
11681                   end if;
11682 
11683                   Next (Arg);
11684                end loop;
11685             end if;
11686          end Annotate;
11687 
11688          -------------------------------------------------
11689          -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11690          -------------------------------------------------
11691 
11692          --  pragma Assert
11693          --    (   [Check => ]  Boolean_EXPRESSION
11694          --     [, [Message =>] Static_String_EXPRESSION]);
11695 
11696          --  pragma Assert_And_Cut
11697          --    (   [Check => ]  Boolean_EXPRESSION
11698          --     [, [Message =>] Static_String_EXPRESSION]);
11699 
11700          --  pragma Assume
11701          --    (   [Check => ]  Boolean_EXPRESSION
11702          --     [, [Message =>] Static_String_EXPRESSION]);
11703 
11704          --  pragma Loop_Invariant
11705          --    (   [Check => ]  Boolean_EXPRESSION
11706          --     [, [Message =>] Static_String_EXPRESSION]);
11707 
11708          when Pragma_Assert         |
11709               Pragma_Assert_And_Cut |
11710               Pragma_Assume         |
11711               Pragma_Loop_Invariant =>
11712          Assert : declare
11713             function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
11714             --  Determine whether expression Expr contains a Loop_Entry
11715             --  attribute reference.
11716 
11717             -------------------------
11718             -- Contains_Loop_Entry --
11719             -------------------------
11720 
11721             function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
11722                Has_Loop_Entry : Boolean := False;
11723 
11724                function Process (N : Node_Id) return Traverse_Result;
11725                --  Process function for traversal to look for Loop_Entry
11726 
11727                -------------
11728                -- Process --
11729                -------------
11730 
11731                function Process (N : Node_Id) return Traverse_Result is
11732                begin
11733                   if Nkind (N) = N_Attribute_Reference
11734                     and then Attribute_Name (N) = Name_Loop_Entry
11735                   then
11736                      Has_Loop_Entry := True;
11737                      return Abandon;
11738                   else
11739                      return OK;
11740                   end if;
11741                end Process;
11742 
11743                procedure Traverse is new Traverse_Proc (Process);
11744 
11745             --  Start of processing for Contains_Loop_Entry
11746 
11747             begin
11748                Traverse (Expr);
11749                return Has_Loop_Entry;
11750             end Contains_Loop_Entry;
11751 
11752             --  Local variables
11753 
11754             Expr     : Node_Id;
11755             New_Args : List_Id;
11756 
11757          --  Start of processing for Assert
11758 
11759          begin
11760             --  Assert is an Ada 2005 RM-defined pragma
11761 
11762             if Prag_Id = Pragma_Assert then
11763                Ada_2005_Pragma;
11764 
11765             --  The remaining ones are GNAT pragmas
11766 
11767             else
11768                GNAT_Pragma;
11769             end if;
11770 
11771             Check_At_Least_N_Arguments (1);
11772             Check_At_Most_N_Arguments (2);
11773             Check_Arg_Order ((Name_Check, Name_Message));
11774             Check_Optional_Identifier (Arg1, Name_Check);
11775             Expr := Get_Pragma_Arg (Arg1);
11776 
11777             --  Special processing for Loop_Invariant, Loop_Variant or for
11778             --  other cases where a Loop_Entry attribute is present. If the
11779             --  assertion pragma contains attribute Loop_Entry, ensure that
11780             --  the related pragma is within a loop.
11781 
11782             if        Prag_Id = Pragma_Loop_Invariant
11783               or else Prag_Id = Pragma_Loop_Variant
11784               or else Contains_Loop_Entry (Expr)
11785             then
11786                Check_Loop_Pragma_Placement;
11787 
11788                --  Perform preanalysis to deal with embedded Loop_Entry
11789                --  attributes.
11790 
11791                Preanalyze_Assert_Expression (Expr, Any_Boolean);
11792             end if;
11793 
11794             --  Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11795             --  a corresponding Check pragma:
11796 
11797             --    pragma Check (name, condition [, msg]);
11798 
11799             --  Where name is the identifier matching the pragma name. So
11800             --  rewrite pragma in this manner, transfer the message argument
11801             --  if present, and analyze the result
11802 
11803             --  Note: When dealing with a semantically analyzed tree, the
11804             --  information that a Check node N corresponds to a source Assert,
11805             --  Assume, or Assert_And_Cut pragma can be retrieved from the
11806             --  pragma kind of Original_Node(N).
11807 
11808             New_Args := New_List (
11809               Make_Pragma_Argument_Association (Loc,
11810                 Expression => Make_Identifier (Loc, Pname)),
11811               Make_Pragma_Argument_Association (Sloc (Expr),
11812                 Expression => Expr));
11813 
11814             if Arg_Count > 1 then
11815                Check_Optional_Identifier (Arg2, Name_Message);
11816 
11817                --  Provide semantic annnotations for optional argument, for
11818                --  ASIS use, before rewriting.
11819 
11820                Preanalyze_And_Resolve (Expression (Arg2), Standard_String);
11821                Append_To (New_Args, New_Copy_Tree (Arg2));
11822             end if;
11823 
11824             --  Rewrite as Check pragma
11825 
11826             Rewrite (N,
11827               Make_Pragma (Loc,
11828                 Chars                        => Name_Check,
11829                 Pragma_Argument_Associations => New_Args));
11830 
11831             Analyze (N);
11832          end Assert;
11833 
11834          ----------------------
11835          -- Assertion_Policy --
11836          ----------------------
11837 
11838          --  pragma Assertion_Policy (POLICY_IDENTIFIER);
11839 
11840          --  The following form is Ada 2012 only, but we allow it in all modes
11841 
11842          --  Pragma Assertion_Policy (
11843          --      ASSERTION_KIND => POLICY_IDENTIFIER
11844          --   {, ASSERTION_KIND => POLICY_IDENTIFIER});
11845 
11846          --  ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11847 
11848          --  RM_ASSERTION_KIND ::= Assert               |
11849          --                        Static_Predicate     |
11850          --                        Dynamic_Predicate    |
11851          --                        Pre                  |
11852          --                        Pre'Class            |
11853          --                        Post                 |
11854          --                        Post'Class           |
11855          --                        Type_Invariant       |
11856          --                        Type_Invariant'Class
11857 
11858          --  ID_ASSERTION_KIND ::= Assert_And_Cut            |
11859          --                        Assume                    |
11860          --                        Contract_Cases            |
11861          --                        Debug                     |
11862          --                        Default_Initial_Condition |
11863          --                        Ghost                     |
11864          --                        Initial_Condition         |
11865          --                        Loop_Invariant            |
11866          --                        Loop_Variant              |
11867          --                        Postcondition             |
11868          --                        Precondition              |
11869          --                        Predicate                 |
11870          --                        Refined_Post              |
11871          --                        Statement_Assertions
11872 
11873          --  Note: The RM_ASSERTION_KIND list is language-defined, and the
11874          --  ID_ASSERTION_KIND list contains implementation-defined additions
11875          --  recognized by GNAT. The effect is to control the behavior of
11876          --  identically named aspects and pragmas, depending on the specified
11877          --  policy identifier:
11878 
11879          --  POLICY_IDENTIFIER ::= Check | Disable | Ignore
11880 
11881          --  Note: Check and Ignore are language-defined. Disable is a GNAT
11882          --  implementation-defined addition that results in totally ignoring
11883          --  the corresponding assertion. If Disable is specified, then the
11884          --  argument of the assertion is not even analyzed. This is useful
11885          --  when the aspect/pragma argument references entities in a with'ed
11886          --  package that is replaced by a dummy package in the final build.
11887 
11888          --  Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11889          --  and Type_Invariant'Class were recognized by the parser and
11890          --  transformed into references to the special internal identifiers
11891          --  _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11892          --  processing is required here.
11893 
11894          when Pragma_Assertion_Policy => Assertion_Policy : declare
11895             Arg    : Node_Id;
11896             Kind   : Name_Id;
11897             LocP   : Source_Ptr;
11898             Policy : Node_Id;
11899 
11900          begin
11901             Ada_2005_Pragma;
11902 
11903             --  This can always appear as a configuration pragma
11904 
11905             if Is_Configuration_Pragma then
11906                null;
11907 
11908             --  It can also appear in a declarative part or package spec in Ada
11909             --  2012 mode. We allow this in other modes, but in that case we
11910             --  consider that we have an Ada 2012 pragma on our hands.
11911 
11912             else
11913                Check_Is_In_Decl_Part_Or_Package_Spec;
11914                Ada_2012_Pragma;
11915             end if;
11916 
11917             --  One argument case with no identifier (first form above)
11918 
11919             if Arg_Count = 1
11920               and then (Nkind (Arg1) /= N_Pragma_Argument_Association
11921                          or else Chars (Arg1) = No_Name)
11922             then
11923                Check_Arg_Is_One_Of
11924                  (Arg1, Name_Check, Name_Disable, Name_Ignore);
11925 
11926                --  Treat one argument Assertion_Policy as equivalent to:
11927 
11928                --    pragma Check_Policy (Assertion, policy)
11929 
11930                --  So rewrite pragma in that manner and link on to the chain
11931                --  of Check_Policy pragmas, marking the pragma as analyzed.
11932 
11933                Policy := Get_Pragma_Arg (Arg1);
11934 
11935                Rewrite (N,
11936                  Make_Pragma (Loc,
11937                    Chars                        => Name_Check_Policy,
11938                    Pragma_Argument_Associations => New_List (
11939                      Make_Pragma_Argument_Association (Loc,
11940                        Expression => Make_Identifier (Loc, Name_Assertion)),
11941 
11942                      Make_Pragma_Argument_Association (Loc,
11943                        Expression =>
11944                          Make_Identifier (Sloc (Policy), Chars (Policy))))));
11945                Analyze (N);
11946 
11947             --  Here if we have two or more arguments
11948 
11949             else
11950                Check_At_Least_N_Arguments (1);
11951                Ada_2012_Pragma;
11952 
11953                --  Loop through arguments
11954 
11955                Arg := Arg1;
11956                while Present (Arg) loop
11957                   LocP := Sloc (Arg);
11958 
11959                   --  Kind must be specified
11960 
11961                   if Nkind (Arg) /= N_Pragma_Argument_Association
11962                     or else Chars (Arg) = No_Name
11963                   then
11964                      Error_Pragma_Arg
11965                        ("missing assertion kind for pragma%", Arg);
11966                   end if;
11967 
11968                   --  Check Kind and Policy have allowed forms
11969 
11970                   Kind   := Chars (Arg);
11971                   Policy := Get_Pragma_Arg (Arg);
11972 
11973                   if not Is_Valid_Assertion_Kind (Kind) then
11974                      Error_Pragma_Arg
11975                        ("invalid assertion kind for pragma%", Arg);
11976                   end if;
11977 
11978                   Check_Arg_Is_One_Of
11979                     (Arg, Name_Check, Name_Disable, Name_Ignore);
11980 
11981                   if Kind = Name_Ghost then
11982 
11983                      --  The Ghost policy must be either Check or Ignore
11984                      --  (SPARK RM 6.9(6)).
11985 
11986                      if not Nam_In (Chars (Policy), Name_Check,
11987                                                     Name_Ignore)
11988                      then
11989                         Error_Pragma_Arg
11990                           ("argument of pragma % Ghost must be Check or "
11991                            & "Ignore", Policy);
11992                      end if;
11993 
11994                      --  Pragma Assertion_Policy specifying a Ghost policy
11995                      --  cannot occur within a Ghost subprogram or package
11996                      --  (SPARK RM 6.9(14)).
11997 
11998                      if Ghost_Mode > None then
11999                         Error_Pragma
12000                           ("pragma % cannot appear within ghost subprogram or "
12001                            & "package");
12002                      end if;
12003                   end if;
12004 
12005                   --  Rewrite the Assertion_Policy pragma as a series of
12006                   --  Check_Policy pragmas of the form:
12007 
12008                   --    Check_Policy (Kind, Policy);
12009 
12010                   --  Note: the insertion of the pragmas cannot be done with
12011                   --  Insert_Action because in the configuration case, there
12012                   --  are no scopes on the scope stack and the mechanism will
12013                   --  fail.
12014 
12015                   Insert_Before_And_Analyze (N,
12016                     Make_Pragma (LocP,
12017                       Chars                        => Name_Check_Policy,
12018                       Pragma_Argument_Associations => New_List (
12019                          Make_Pragma_Argument_Association (LocP,
12020                            Expression => Make_Identifier (LocP, Kind)),
12021                          Make_Pragma_Argument_Association (LocP,
12022                            Expression => Policy))));
12023 
12024                   Arg := Next (Arg);
12025                end loop;
12026 
12027                --  Rewrite the Assertion_Policy pragma as null since we have
12028                --  now inserted all the equivalent Check pragmas.
12029 
12030                Rewrite (N, Make_Null_Statement (Loc));
12031                Analyze (N);
12032             end if;
12033          end Assertion_Policy;
12034 
12035          ------------------------------
12036          -- Assume_No_Invalid_Values --
12037          ------------------------------
12038 
12039          --  pragma Assume_No_Invalid_Values (On | Off);
12040 
12041          when Pragma_Assume_No_Invalid_Values =>
12042             GNAT_Pragma;
12043             Check_Valid_Configuration_Pragma;
12044             Check_Arg_Count (1);
12045             Check_No_Identifiers;
12046             Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
12047 
12048             if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
12049                Assume_No_Invalid_Values := True;
12050             else
12051                Assume_No_Invalid_Values := False;
12052             end if;
12053 
12054          --------------------------
12055          -- Attribute_Definition --
12056          --------------------------
12057 
12058          --  pragma Attribute_Definition
12059          --    ([Attribute  =>] ATTRIBUTE_DESIGNATOR,
12060          --     [Entity     =>] LOCAL_NAME,
12061          --     [Expression =>] EXPRESSION | NAME);
12062 
12063          when Pragma_Attribute_Definition => Attribute_Definition : declare
12064             Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1);
12065             Aname                : Name_Id;
12066 
12067          begin
12068             GNAT_Pragma;
12069             Check_Arg_Count (3);
12070             Check_Optional_Identifier (Arg1, "attribute");
12071             Check_Optional_Identifier (Arg2, "entity");
12072             Check_Optional_Identifier (Arg3, "expression");
12073 
12074             if Nkind (Attribute_Designator) /= N_Identifier then
12075                Error_Msg_N ("attribute name expected", Attribute_Designator);
12076                return;
12077             end if;
12078 
12079             Check_Arg_Is_Local_Name (Arg2);
12080 
12081             --  If the attribute is not recognized, then issue a warning (not
12082             --  an error), and ignore the pragma.
12083 
12084             Aname := Chars (Attribute_Designator);
12085 
12086             if not Is_Attribute_Name (Aname) then
12087                Bad_Attribute (Attribute_Designator, Aname, Warn => True);
12088                return;
12089             end if;
12090 
12091             --  Otherwise, rewrite the pragma as an attribute definition clause
12092 
12093             Rewrite (N,
12094               Make_Attribute_Definition_Clause (Loc,
12095                 Name       => Get_Pragma_Arg (Arg2),
12096                 Chars      => Aname,
12097                 Expression => Get_Pragma_Arg (Arg3)));
12098             Analyze (N);
12099          end Attribute_Definition;
12100 
12101          ------------------------------------------------------------------
12102          -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
12103          ------------------------------------------------------------------
12104 
12105          --  pragma Asynch_Readers   [ (boolean_EXPRESSION) ];
12106          --  pragma Asynch_Writers   [ (boolean_EXPRESSION) ];
12107          --  pragma Effective_Reads  [ (boolean_EXPRESSION) ];
12108          --  pragma Effective_Writes [ (boolean_EXPRESSION) ];
12109 
12110          when Pragma_Async_Readers    |
12111               Pragma_Async_Writers    |
12112               Pragma_Effective_Reads  |
12113               Pragma_Effective_Writes =>
12114          Async_Effective : declare
12115             Obj_Decl : Node_Id;
12116             Obj_Id   : Entity_Id;
12117 
12118          begin
12119             GNAT_Pragma;
12120             Check_No_Identifiers;
12121             Check_At_Most_N_Arguments  (1);
12122 
12123             Obj_Decl := Find_Related_Context (N, Do_Checks => True);
12124 
12125             --  Object declaration
12126 
12127             if Nkind (Obj_Decl) = N_Object_Declaration then
12128                null;
12129 
12130             --  Otherwise the pragma is associated with an illegal construact
12131 
12132             else
12133                Pragma_Misplaced;
12134                return;
12135             end if;
12136 
12137             Obj_Id := Defining_Entity (Obj_Decl);
12138 
12139             --  Perform minimal verification to ensure that the argument is at
12140             --  least a variable. Subsequent finer grained checks will be done
12141             --  at the end of the declarative region the contains the pragma.
12142 
12143             if Ekind (Obj_Id) = E_Variable then
12144 
12145                --  Chain the pragma on the contract for further processing by
12146                --  Analyze_External_Property_In_Decl_Part.
12147 
12148                Add_Contract_Item (N, Obj_Id);
12149 
12150                --  A pragma that applies to a Ghost entity becomes Ghost for
12151                --  the purposes of legality checks and removal of ignored Ghost
12152                --  code.
12153 
12154                Mark_Pragma_As_Ghost (N, Obj_Id);
12155 
12156                --  Analyze the Boolean expression (if any)
12157 
12158                if Present (Arg1) then
12159                   Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
12160                end if;
12161 
12162             --  Otherwise the external property applies to a constant
12163 
12164             else
12165                Error_Pragma ("pragma % must apply to a volatile object");
12166             end if;
12167          end Async_Effective;
12168 
12169          ------------------
12170          -- Asynchronous --
12171          ------------------
12172 
12173          --  pragma Asynchronous (LOCAL_NAME);
12174 
12175          when Pragma_Asynchronous => Asynchronous : declare
12176             C_Ent  : Entity_Id;
12177             Decl   : Node_Id;
12178             Formal : Entity_Id;
12179             L      : List_Id;
12180             Nm     : Entity_Id;
12181             S      : Node_Id;
12182 
12183             procedure Process_Async_Pragma;
12184             --  Common processing for procedure and access-to-procedure case
12185 
12186             --------------------------
12187             -- Process_Async_Pragma --
12188             --------------------------
12189 
12190             procedure Process_Async_Pragma is
12191             begin
12192                if No (L) then
12193                   Set_Is_Asynchronous (Nm);
12194                   return;
12195                end if;
12196 
12197                --  The formals should be of mode IN (RM E.4.1(6))
12198 
12199                S := First (L);
12200                while Present (S) loop
12201                   Formal := Defining_Identifier (S);
12202 
12203                   if Nkind (Formal) = N_Defining_Identifier
12204                     and then Ekind (Formal) /= E_In_Parameter
12205                   then
12206                      Error_Pragma_Arg
12207                        ("pragma% procedure can only have IN parameter",
12208                         Arg1);
12209                   end if;
12210 
12211                   Next (S);
12212                end loop;
12213 
12214                Set_Is_Asynchronous (Nm);
12215             end Process_Async_Pragma;
12216 
12217          --  Start of processing for pragma Asynchronous
12218 
12219          begin
12220             Check_Ada_83_Warning;
12221             Check_No_Identifiers;
12222             Check_Arg_Count (1);
12223             Check_Arg_Is_Local_Name (Arg1);
12224 
12225             if Debug_Flag_U then
12226                return;
12227             end if;
12228 
12229             C_Ent := Cunit_Entity (Current_Sem_Unit);
12230             Analyze (Get_Pragma_Arg (Arg1));
12231             Nm := Entity (Get_Pragma_Arg (Arg1));
12232 
12233             --  A pragma that applies to a Ghost entity becomes Ghost for the
12234             --  purposes of legality checks and removal of ignored Ghost code.
12235 
12236             Mark_Pragma_As_Ghost (N, Nm);
12237 
12238             if not Is_Remote_Call_Interface (C_Ent)
12239               and then not Is_Remote_Types (C_Ent)
12240             then
12241                --  This pragma should only appear in an RCI or Remote Types
12242                --  unit (RM E.4.1(4)).
12243 
12244                Error_Pragma
12245                  ("pragma% not in Remote_Call_Interface or Remote_Types unit");
12246             end if;
12247 
12248             if Ekind (Nm) = E_Procedure
12249               and then Nkind (Parent (Nm)) = N_Procedure_Specification
12250             then
12251                if not Is_Remote_Call_Interface (Nm) then
12252                   Error_Pragma_Arg
12253                     ("pragma% cannot be applied on non-remote procedure",
12254                      Arg1);
12255                end if;
12256 
12257                L := Parameter_Specifications (Parent (Nm));
12258                Process_Async_Pragma;
12259                return;
12260 
12261             elsif Ekind (Nm) = E_Function then
12262                Error_Pragma_Arg
12263                  ("pragma% cannot be applied to function", Arg1);
12264 
12265             elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
12266                if Is_Record_Type (Nm) then
12267 
12268                   --  A record type that is the Equivalent_Type for a remote
12269                   --  access-to-subprogram type.
12270 
12271                   Decl := Declaration_Node (Corresponding_Remote_Type (Nm));
12272 
12273                else
12274                   --  A non-expanded RAS type (distribution is not enabled)
12275 
12276                   Decl := Declaration_Node (Nm);
12277                end if;
12278 
12279                if Nkind (Decl) = N_Full_Type_Declaration
12280                  and then Nkind (Type_Definition (Decl)) =
12281                                      N_Access_Procedure_Definition
12282                then
12283                   L := Parameter_Specifications (Type_Definition (Decl));
12284                   Process_Async_Pragma;
12285 
12286                   if Is_Asynchronous (Nm)
12287                     and then Expander_Active
12288                     and then Get_PCS_Name /= Name_No_DSA
12289                   then
12290                      RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
12291                   end if;
12292 
12293                else
12294                   Error_Pragma_Arg
12295                     ("pragma% cannot reference access-to-function type",
12296                     Arg1);
12297                end if;
12298 
12299             --  Only other possibility is Access-to-class-wide type
12300 
12301             elsif Is_Access_Type (Nm)
12302               and then Is_Class_Wide_Type (Designated_Type (Nm))
12303             then
12304                Check_First_Subtype (Arg1);
12305                Set_Is_Asynchronous (Nm);
12306                if Expander_Active then
12307                   RACW_Type_Is_Asynchronous (Nm);
12308                end if;
12309 
12310             else
12311                Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
12312             end if;
12313          end Asynchronous;
12314 
12315          ------------
12316          -- Atomic --
12317          ------------
12318 
12319          --  pragma Atomic (LOCAL_NAME);
12320 
12321          when Pragma_Atomic =>
12322             Process_Atomic_Independent_Shared_Volatile;
12323 
12324          -----------------------
12325          -- Atomic_Components --
12326          -----------------------
12327 
12328          --  pragma Atomic_Components (array_LOCAL_NAME);
12329 
12330          --  This processing is shared by Volatile_Components
12331 
12332          when Pragma_Atomic_Components   |
12333               Pragma_Volatile_Components =>
12334          Atomic_Components : declare
12335             D    : Node_Id;
12336             E    : Entity_Id;
12337             E_Id : Node_Id;
12338             K    : Node_Kind;
12339 
12340          begin
12341             Check_Ada_83_Warning;
12342             Check_No_Identifiers;
12343             Check_Arg_Count (1);
12344             Check_Arg_Is_Local_Name (Arg1);
12345             E_Id := Get_Pragma_Arg (Arg1);
12346 
12347             if Etype (E_Id) = Any_Type then
12348                return;
12349             end if;
12350 
12351             E := Entity (E_Id);
12352 
12353             --  A pragma that applies to a Ghost entity becomes Ghost for the
12354             --  purposes of legality checks and removal of ignored Ghost code.
12355 
12356             Mark_Pragma_As_Ghost (N, E);
12357             Check_Duplicate_Pragma (E);
12358 
12359             if Rep_Item_Too_Early (E, N)
12360                  or else
12361                Rep_Item_Too_Late (E, N)
12362             then
12363                return;
12364             end if;
12365 
12366             D := Declaration_Node (E);
12367             K := Nkind (D);
12368 
12369             if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
12370               or else
12371                 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
12372                    and then Nkind (D) = N_Object_Declaration
12373                    and then Nkind (Object_Definition (D)) =
12374                                        N_Constrained_Array_Definition)
12375             then
12376                --  The flag is set on the object, or on the base type
12377 
12378                if Nkind (D) /= N_Object_Declaration then
12379                   E := Base_Type (E);
12380                end if;
12381 
12382                --  Atomic implies both Independent and Volatile
12383 
12384                if Prag_Id = Pragma_Atomic_Components then
12385                   Set_Has_Atomic_Components (E);
12386                   Set_Has_Independent_Components (E);
12387                end if;
12388 
12389                Set_Has_Volatile_Components (E);
12390 
12391             else
12392                Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
12393             end if;
12394          end Atomic_Components;
12395 
12396          --------------------
12397          -- Attach_Handler --
12398          --------------------
12399 
12400          --  pragma Attach_Handler (handler_NAME, EXPRESSION);
12401 
12402          when Pragma_Attach_Handler =>
12403             Check_Ada_83_Warning;
12404             Check_No_Identifiers;
12405             Check_Arg_Count (2);
12406 
12407             if No_Run_Time_Mode then
12408                Error_Msg_CRT ("Attach_Handler pragma", N);
12409             else
12410                Check_Interrupt_Or_Attach_Handler;
12411 
12412                --  The expression that designates the attribute may depend on a
12413                --  discriminant, and is therefore a per-object expression, to
12414                --  be expanded in the init proc. If expansion is enabled, then
12415                --  perform semantic checks on a copy only.
12416 
12417                declare
12418                   Temp  : Node_Id;
12419                   Typ   : Node_Id;
12420                   Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2);
12421 
12422                begin
12423                   --  In Relaxed_RM_Semantics mode, we allow any static
12424                   --  integer value, for compatibility with other compilers.
12425 
12426                   if Relaxed_RM_Semantics
12427                     and then Nkind (Parg2) = N_Integer_Literal
12428                   then
12429                      Typ := Standard_Integer;
12430                   else
12431                      Typ := RTE (RE_Interrupt_ID);
12432                   end if;
12433 
12434                   if Expander_Active then
12435                      Temp := New_Copy_Tree (Parg2);
12436                      Set_Parent (Temp, N);
12437                      Preanalyze_And_Resolve (Temp, Typ);
12438                   else
12439                      Analyze (Parg2);
12440                      Resolve (Parg2, Typ);
12441                   end if;
12442                end;
12443 
12444                Process_Interrupt_Or_Attach_Handler;
12445             end if;
12446 
12447          --------------------
12448          -- C_Pass_By_Copy --
12449          --------------------
12450 
12451          --  pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
12452 
12453          when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
12454             Arg : Node_Id;
12455             Val : Uint;
12456 
12457          begin
12458             GNAT_Pragma;
12459             Check_Valid_Configuration_Pragma;
12460             Check_Arg_Count (1);
12461             Check_Optional_Identifier (Arg1, "max_size");
12462 
12463             Arg := Get_Pragma_Arg (Arg1);
12464             Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
12465 
12466             Val := Expr_Value (Arg);
12467 
12468             if Val <= 0 then
12469                Error_Pragma_Arg
12470                  ("maximum size for pragma% must be positive", Arg1);
12471 
12472             elsif UI_Is_In_Int_Range (Val) then
12473                Default_C_Record_Mechanism := UI_To_Int (Val);
12474 
12475             --  If a giant value is given, Int'Last will do well enough.
12476             --  If sometime someone complains that a record larger than
12477             --  two gigabytes is not copied, we will worry about it then.
12478 
12479             else
12480                Default_C_Record_Mechanism := Mechanism_Type'Last;
12481             end if;
12482          end C_Pass_By_Copy;
12483 
12484          -----------
12485          -- Check --
12486          -----------
12487 
12488          --  pragma Check ([Name    =>] CHECK_KIND,
12489          --                [Check   =>] Boolean_EXPRESSION
12490          --              [,[Message =>] String_EXPRESSION]);
12491 
12492          --  CHECK_KIND ::= IDENTIFIER           |
12493          --                 Pre'Class            |
12494          --                 Post'Class           |
12495          --                 Invariant'Class      |
12496          --                 Type_Invariant'Class
12497 
12498          --  The identifiers Assertions and Statement_Assertions are not
12499          --  allowed, since they have special meaning for Check_Policy.
12500 
12501          when Pragma_Check => Check : declare
12502             Cname : Name_Id;
12503             Eloc  : Source_Ptr;
12504             Expr  : Node_Id;
12505             Str   : Node_Id;
12506 
12507             Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
12508 
12509          begin
12510             --  Pragma Check is Ghost when it applies to a Ghost entity. Set
12511             --  the mode now to ensure that any nodes generated during analysis
12512             --  and expansion are marked as Ghost.
12513 
12514             Set_Ghost_Mode (N);
12515 
12516             GNAT_Pragma;
12517             Check_At_Least_N_Arguments (2);
12518             Check_At_Most_N_Arguments (3);
12519             Check_Optional_Identifier (Arg1, Name_Name);
12520             Check_Optional_Identifier (Arg2, Name_Check);
12521 
12522             if Arg_Count = 3 then
12523                Check_Optional_Identifier (Arg3, Name_Message);
12524                Str := Get_Pragma_Arg (Arg3);
12525             end if;
12526 
12527             Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1));
12528             Check_Arg_Is_Identifier (Arg1);
12529             Cname := Chars (Get_Pragma_Arg (Arg1));
12530 
12531             --  Check forbidden name Assertions or Statement_Assertions
12532 
12533             case Cname is
12534                when Name_Assertions =>
12535                   Error_Pragma_Arg
12536                     ("""Assertions"" is not allowed as a check kind for "
12537                      & "pragma%", Arg1);
12538 
12539                when Name_Statement_Assertions =>
12540                   Error_Pragma_Arg
12541                     ("""Statement_Assertions"" is not allowed as a check kind "
12542                      & "for pragma%", Arg1);
12543 
12544                when others =>
12545                   null;
12546             end case;
12547 
12548             --  Check applicable policy. We skip this if Checked/Ignored status
12549             --  is already set (e.g. in the case of a pragma from an aspect).
12550 
12551             if Is_Checked (N) or else Is_Ignored (N) then
12552                null;
12553 
12554             --  For a non-source pragma that is a rewriting of another pragma,
12555             --  copy the Is_Checked/Ignored status from the rewritten pragma.
12556 
12557             elsif Is_Rewrite_Substitution (N)
12558               and then Nkind (Original_Node (N)) = N_Pragma
12559               and then Original_Node (N) /= N
12560             then
12561                Set_Is_Ignored (N, Is_Ignored (Original_Node (N)));
12562                Set_Is_Checked (N, Is_Checked (Original_Node (N)));
12563 
12564             --  Otherwise query the applicable policy at this point
12565 
12566             else
12567                case Check_Kind (Cname) is
12568                   when Name_Ignore =>
12569                      Set_Is_Ignored (N, True);
12570                      Set_Is_Checked (N, False);
12571 
12572                   when Name_Check =>
12573                      Set_Is_Ignored (N, False);
12574                      Set_Is_Checked (N, True);
12575 
12576                   --  For disable, rewrite pragma as null statement and skip
12577                   --  rest of the analysis of the pragma.
12578 
12579                   when Name_Disable =>
12580                      Rewrite (N, Make_Null_Statement (Loc));
12581                      Analyze (N);
12582                      raise Pragma_Exit;
12583 
12584                      --  No other possibilities
12585 
12586                   when others =>
12587                      raise Program_Error;
12588                end case;
12589             end if;
12590 
12591             --  If check kind was not Disable, then continue pragma analysis
12592 
12593             Expr := Get_Pragma_Arg (Arg2);
12594 
12595             --  Deal with SCO generation
12596 
12597             case Cname is
12598 
12599                --  Nothing to do for predicates as the checks occur in the
12600                --  client units. The SCO for the aspect in the declaration
12601                --  unit is conservatively always enabled.
12602 
12603                when Name_Predicate =>
12604                   null;
12605 
12606                --  Otherwise mark aspect/pragma SCO as enabled
12607 
12608                when others =>
12609                   if Is_Checked (N) and then not Split_PPC (N) then
12610                      Set_SCO_Pragma_Enabled (Loc);
12611                   end if;
12612             end case;
12613 
12614             --  Deal with analyzing the string argument
12615 
12616             if Arg_Count = 3 then
12617 
12618                --  If checks are not on we don't want any expansion (since
12619                --  such expansion would not get properly deleted) but
12620                --  we do want to analyze (to get proper references).
12621                --  The Preanalyze_And_Resolve routine does just what we want
12622 
12623                if Is_Ignored (N) then
12624                   Preanalyze_And_Resolve (Str, Standard_String);
12625 
12626                   --  Otherwise we need a proper analysis and expansion
12627 
12628                else
12629                   Analyze_And_Resolve (Str, Standard_String);
12630                end if;
12631             end if;
12632 
12633             --  Now you might think we could just do the same with the Boolean
12634             --  expression if checks are off (and expansion is on) and then
12635             --  rewrite the check as a null statement. This would work but we
12636             --  would lose the useful warnings about an assertion being bound
12637             --  to fail even if assertions are turned off.
12638 
12639             --  So instead we wrap the boolean expression in an if statement
12640             --  that looks like:
12641 
12642             --    if False and then condition then
12643             --       null;
12644             --    end if;
12645 
12646             --  The reason we do this rewriting during semantic analysis rather
12647             --  than as part of normal expansion is that we cannot analyze and
12648             --  expand the code for the boolean expression directly, or it may
12649             --  cause insertion of actions that would escape the attempt to
12650             --  suppress the check code.
12651 
12652             --  Note that the Sloc for the if statement corresponds to the
12653             --  argument condition, not the pragma itself. The reason for
12654             --  this is that we may generate a warning if the condition is
12655             --  False at compile time, and we do not want to delete this
12656             --  warning when we delete the if statement.
12657 
12658             if Expander_Active and Is_Ignored (N) then
12659                Eloc := Sloc (Expr);
12660 
12661                Rewrite (N,
12662                  Make_If_Statement (Eloc,
12663                    Condition =>
12664                      Make_And_Then (Eloc,
12665                        Left_Opnd  => Make_Identifier (Eloc, Name_False),
12666                        Right_Opnd => Expr),
12667                    Then_Statements => New_List (
12668                      Make_Null_Statement (Eloc))));
12669 
12670                --  Now go ahead and analyze the if statement
12671 
12672                In_Assertion_Expr := In_Assertion_Expr + 1;
12673 
12674                --  One rather special treatment. If we are now in Eliminated
12675                --  overflow mode, then suppress overflow checking since we do
12676                --  not want to drag in the bignum stuff if we are in Ignore
12677                --  mode anyway. This is particularly important if we are using
12678                --  a configurable run time that does not support bignum ops.
12679 
12680                if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then
12681                   declare
12682                      Svo : constant Boolean :=
12683                              Scope_Suppress.Suppress (Overflow_Check);
12684                   begin
12685                      Scope_Suppress.Overflow_Mode_Assertions  := Strict;
12686                      Scope_Suppress.Suppress (Overflow_Check) := True;
12687                      Analyze (N);
12688                      Scope_Suppress.Suppress (Overflow_Check) := Svo;
12689                      Scope_Suppress.Overflow_Mode_Assertions  := Eliminated;
12690                   end;
12691 
12692                --  Not that special case
12693 
12694                else
12695                   Analyze (N);
12696                end if;
12697 
12698                --  All done with this check
12699 
12700                In_Assertion_Expr := In_Assertion_Expr - 1;
12701 
12702             --  Check is active or expansion not active. In these cases we can
12703             --  just go ahead and analyze the boolean with no worries.
12704 
12705             else
12706                In_Assertion_Expr := In_Assertion_Expr + 1;
12707                Analyze_And_Resolve (Expr, Any_Boolean);
12708                In_Assertion_Expr := In_Assertion_Expr - 1;
12709             end if;
12710 
12711             Ghost_Mode := Save_Ghost_Mode;
12712          end Check;
12713 
12714          --------------------------
12715          -- Check_Float_Overflow --
12716          --------------------------
12717 
12718          --  pragma Check_Float_Overflow;
12719 
12720          when Pragma_Check_Float_Overflow =>
12721             GNAT_Pragma;
12722             Check_Valid_Configuration_Pragma;
12723             Check_Arg_Count (0);
12724             Check_Float_Overflow := not Machine_Overflows_On_Target;
12725 
12726          ----------------
12727          -- Check_Name --
12728          ----------------
12729 
12730          --  pragma Check_Name (check_IDENTIFIER);
12731 
12732          when Pragma_Check_Name =>
12733             GNAT_Pragma;
12734             Check_No_Identifiers;
12735             Check_Valid_Configuration_Pragma;
12736             Check_Arg_Count (1);
12737             Check_Arg_Is_Identifier (Arg1);
12738 
12739             declare
12740                Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
12741 
12742             begin
12743                for J in Check_Names.First .. Check_Names.Last loop
12744                   if Check_Names.Table (J) = Nam then
12745                      return;
12746                   end if;
12747                end loop;
12748 
12749                Check_Names.Append (Nam);
12750             end;
12751 
12752          ------------------
12753          -- Check_Policy --
12754          ------------------
12755 
12756          --  This is the old style syntax, which is still allowed in all modes:
12757 
12758          --  pragma Check_Policy ([Name   =>] CHECK_KIND
12759          --                       [Policy =>] POLICY_IDENTIFIER);
12760 
12761          --  POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12762 
12763          --  CHECK_KIND ::= IDENTIFIER           |
12764          --                 Pre'Class            |
12765          --                 Post'Class           |
12766          --                 Type_Invariant'Class |
12767          --                 Invariant'Class
12768 
12769          --  This is the new style syntax, compatible with Assertion_Policy
12770          --  and also allowed in all modes.
12771 
12772          --  Pragma Check_Policy (
12773          --      CHECK_KIND => POLICY_IDENTIFIER
12774          --   {, CHECK_KIND => POLICY_IDENTIFIER});
12775 
12776          --  Note: the identifiers Name and Policy are not allowed as
12777          --  Check_Kind values. This avoids ambiguities between the old and
12778          --  new form syntax.
12779 
12780          when Pragma_Check_Policy => Check_Policy : declare
12781             Kind : Node_Id;
12782 
12783          begin
12784             GNAT_Pragma;
12785             Check_At_Least_N_Arguments (1);
12786 
12787             --  A Check_Policy pragma can appear either as a configuration
12788             --  pragma, or in a declarative part or a package spec (see RM
12789             --  11.5(5) for rules for Suppress/Unsuppress which are also
12790             --  followed for Check_Policy).
12791 
12792             if not Is_Configuration_Pragma then
12793                Check_Is_In_Decl_Part_Or_Package_Spec;
12794             end if;
12795 
12796             --  Figure out if we have the old or new syntax. We have the
12797             --  old syntax if the first argument has no identifier, or the
12798             --  identifier is Name.
12799 
12800             if Nkind (Arg1) /= N_Pragma_Argument_Association
12801               or else Nam_In (Chars (Arg1), No_Name, Name_Name)
12802             then
12803                --  Old syntax
12804 
12805                Check_Arg_Count (2);
12806                Check_Optional_Identifier (Arg1, Name_Name);
12807                Kind := Get_Pragma_Arg (Arg1);
12808                Rewrite_Assertion_Kind (Kind);
12809                Check_Arg_Is_Identifier (Arg1);
12810 
12811                --  Check forbidden check kind
12812 
12813                if Nam_In (Chars (Kind), Name_Name, Name_Policy) then
12814                   Error_Msg_Name_2 := Chars (Kind);
12815                   Error_Pragma_Arg
12816                     ("pragma% does not allow% as check name", Arg1);
12817                end if;
12818 
12819                --  Check policy
12820 
12821                Check_Optional_Identifier (Arg2, Name_Policy);
12822                Check_Arg_Is_One_Of
12823                  (Arg2,
12824                   Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
12825 
12826                --  And chain pragma on the Check_Policy_List for search
12827 
12828                Set_Next_Pragma (N, Opt.Check_Policy_List);
12829                Opt.Check_Policy_List := N;
12830 
12831             --  For the new syntax, what we do is to convert each argument to
12832             --  an old syntax equivalent. We do that because we want to chain
12833             --  old style Check_Policy pragmas for the search (we don't want
12834             --  to have to deal with multiple arguments in the search).
12835 
12836             else
12837                declare
12838                   Arg   : Node_Id;
12839                   Argx  : Node_Id;
12840                   LocP  : Source_Ptr;
12841                   New_P : Node_Id;
12842 
12843                begin
12844                   Arg := Arg1;
12845                   while Present (Arg) loop
12846                      LocP := Sloc (Arg);
12847                      Argx := Get_Pragma_Arg (Arg);
12848 
12849                      --  Kind must be specified
12850 
12851                      if Nkind (Arg) /= N_Pragma_Argument_Association
12852                        or else Chars (Arg) = No_Name
12853                      then
12854                         Error_Pragma_Arg
12855                           ("missing assertion kind for pragma%", Arg);
12856                      end if;
12857 
12858                      --  Construct equivalent old form syntax Check_Policy
12859                      --  pragma and insert it to get remaining checks.
12860 
12861                      New_P :=
12862                        Make_Pragma (LocP,
12863                          Chars                        => Name_Check_Policy,
12864                          Pragma_Argument_Associations => New_List (
12865                            Make_Pragma_Argument_Association (LocP,
12866                              Expression =>
12867                                Make_Identifier (LocP, Chars (Arg))),
12868                            Make_Pragma_Argument_Association (Sloc (Argx),
12869                              Expression => Argx)));
12870 
12871                      Arg := Next (Arg);
12872 
12873                      --  For a configuration pragma, insert old form in
12874                      --  the corresponding file.
12875 
12876                      if Is_Configuration_Pragma then
12877                         Insert_After (N, New_P);
12878                         Analyze (New_P);
12879 
12880                      else
12881                         Insert_Action (N, New_P);
12882                      end if;
12883                   end loop;
12884 
12885                   --  Rewrite original Check_Policy pragma to null, since we
12886                   --  have converted it into a series of old syntax pragmas.
12887 
12888                   Rewrite (N, Make_Null_Statement (Loc));
12889                   Analyze (N);
12890                end;
12891             end if;
12892          end Check_Policy;
12893 
12894          -------------
12895          -- Comment --
12896          -------------
12897 
12898          --  pragma Comment (static_string_EXPRESSION)
12899 
12900          --  Processing for pragma Comment shares the circuitry for pragma
12901          --  Ident. The only differences are that Ident enforces a limit of 31
12902          --  characters on its argument, and also enforces limitations on
12903          --  placement for DEC compatibility. Pragma Comment shares neither of
12904          --  these restrictions.
12905 
12906          -------------------
12907          -- Common_Object --
12908          -------------------
12909 
12910          --  pragma Common_Object (
12911          --        [Internal =>] LOCAL_NAME
12912          --     [, [External =>] EXTERNAL_SYMBOL]
12913          --     [, [Size     =>] EXTERNAL_SYMBOL]);
12914 
12915          --  Processing for this pragma is shared with Psect_Object
12916 
12917          ------------------------
12918          -- Compile_Time_Error --
12919          ------------------------
12920 
12921          --  pragma Compile_Time_Error
12922          --    (boolean_EXPRESSION, static_string_EXPRESSION);
12923 
12924          when Pragma_Compile_Time_Error =>
12925             GNAT_Pragma;
12926             Process_Compile_Time_Warning_Or_Error;
12927 
12928          --------------------------
12929          -- Compile_Time_Warning --
12930          --------------------------
12931 
12932          --  pragma Compile_Time_Warning
12933          --    (boolean_EXPRESSION, static_string_EXPRESSION);
12934 
12935          when Pragma_Compile_Time_Warning =>
12936             GNAT_Pragma;
12937             Process_Compile_Time_Warning_Or_Error;
12938 
12939          ---------------------------
12940          -- Compiler_Unit_Warning --
12941          ---------------------------
12942 
12943          --  pragma Compiler_Unit_Warning;
12944 
12945          --  Historical note
12946 
12947          --  Originally, we had only pragma Compiler_Unit, and it resulted in
12948          --  errors not warnings. This means that we had introduced a big extra
12949          --  inertia to compiler changes, since even if we implemented a new
12950          --  feature, and even if all versions to be used for bootstrapping
12951          --  implemented this new feature, we could not use it, since old
12952          --  compilers would give errors for using this feature in units
12953          --  having Compiler_Unit pragmas.
12954 
12955          --  By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12956          --  problem. We no longer have any units mentioning Compiler_Unit,
12957          --  so old compilers see Compiler_Unit_Warning which is unrecognized,
12958          --  and thus generates a warning which can be ignored. So that deals
12959          --  with the problem of old compilers not implementing the newer form
12960          --  of the pragma.
12961 
12962          --  Newer compilers recognize the new pragma, but generate warning
12963          --  messages instead of errors, which again can be ignored in the
12964          --  case of an old compiler which implements a wanted new feature
12965          --  but at the time felt like warning about it for older compilers.
12966 
12967          --  We retain Compiler_Unit so that new compilers can be used to build
12968          --  older run-times that use this pragma. That's an unusual case, but
12969          --  it's easy enough to handle, so why not?
12970 
12971          when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning =>
12972             GNAT_Pragma;
12973             Check_Arg_Count (0);
12974 
12975             --  Only recognized in main unit
12976 
12977             if Current_Sem_Unit = Main_Unit then
12978                Compiler_Unit := True;
12979             end if;
12980 
12981          -----------------------------
12982          -- Complete_Representation --
12983          -----------------------------
12984 
12985          --  pragma Complete_Representation;
12986 
12987          when Pragma_Complete_Representation =>
12988             GNAT_Pragma;
12989             Check_Arg_Count (0);
12990 
12991             if Nkind (Parent (N)) /= N_Record_Representation_Clause then
12992                Error_Pragma
12993                  ("pragma & must appear within record representation clause");
12994             end if;
12995 
12996          ----------------------------
12997          -- Complex_Representation --
12998          ----------------------------
12999 
13000          --  pragma Complex_Representation ([Entity =>] LOCAL_NAME);
13001 
13002          when Pragma_Complex_Representation => Complex_Representation : declare
13003             E_Id : Entity_Id;
13004             E    : Entity_Id;
13005             Ent  : Entity_Id;
13006 
13007          begin
13008             GNAT_Pragma;
13009             Check_Arg_Count (1);
13010             Check_Optional_Identifier (Arg1, Name_Entity);
13011             Check_Arg_Is_Local_Name (Arg1);
13012             E_Id := Get_Pragma_Arg (Arg1);
13013 
13014             if Etype (E_Id) = Any_Type then
13015                return;
13016             end if;
13017 
13018             E := Entity (E_Id);
13019 
13020             if not Is_Record_Type (E) then
13021                Error_Pragma_Arg
13022                  ("argument for pragma% must be record type", Arg1);
13023             end if;
13024 
13025             Ent := First_Entity (E);
13026 
13027             if No (Ent)
13028               or else No (Next_Entity (Ent))
13029               or else Present (Next_Entity (Next_Entity (Ent)))
13030               or else not Is_Floating_Point_Type (Etype (Ent))
13031               or else Etype (Ent) /= Etype (Next_Entity (Ent))
13032             then
13033                Error_Pragma_Arg
13034                  ("record for pragma% must have two fields of the same "
13035                   & "floating-point type", Arg1);
13036 
13037             else
13038                Set_Has_Complex_Representation (Base_Type (E));
13039 
13040                --  We need to treat the type has having a non-standard
13041                --  representation, for back-end purposes, even though in
13042                --  general a complex will have the default representation
13043                --  of a record with two real components.
13044 
13045                Set_Has_Non_Standard_Rep (Base_Type (E));
13046             end if;
13047          end Complex_Representation;
13048 
13049          -------------------------
13050          -- Component_Alignment --
13051          -------------------------
13052 
13053          --  pragma Component_Alignment (
13054          --        [Form =>] ALIGNMENT_CHOICE
13055          --     [, [Name =>] type_LOCAL_NAME]);
13056          --
13057          --   ALIGNMENT_CHOICE ::=
13058          --     Component_Size
13059          --   | Component_Size_4
13060          --   | Storage_Unit
13061          --   | Default
13062 
13063          when Pragma_Component_Alignment => Component_AlignmentP : declare
13064             Args  : Args_List (1 .. 2);
13065             Names : constant Name_List (1 .. 2) := (
13066                       Name_Form,
13067                       Name_Name);
13068 
13069             Form  : Node_Id renames Args (1);
13070             Name  : Node_Id renames Args (2);
13071 
13072             Atype : Component_Alignment_Kind;
13073             Typ   : Entity_Id;
13074 
13075          begin
13076             GNAT_Pragma;
13077             Gather_Associations (Names, Args);
13078 
13079             if No (Form) then
13080                Error_Pragma ("missing Form argument for pragma%");
13081             end if;
13082 
13083             Check_Arg_Is_Identifier (Form);
13084 
13085             --  Get proper alignment, note that Default = Component_Size on all
13086             --  machines we have so far, and we want to set this value rather
13087             --  than the default value to indicate that it has been explicitly
13088             --  set (and thus will not get overridden by the default component
13089             --  alignment for the current scope)
13090 
13091             if Chars (Form) = Name_Component_Size then
13092                Atype := Calign_Component_Size;
13093 
13094             elsif Chars (Form) = Name_Component_Size_4 then
13095                Atype := Calign_Component_Size_4;
13096 
13097             elsif Chars (Form) = Name_Default then
13098                Atype := Calign_Component_Size;
13099 
13100             elsif Chars (Form) = Name_Storage_Unit then
13101                Atype := Calign_Storage_Unit;
13102 
13103             else
13104                Error_Pragma_Arg
13105                  ("invalid Form parameter for pragma%", Form);
13106             end if;
13107 
13108             --  The pragma appears in a configuration file
13109 
13110             if No (Parent (N)) then
13111                Check_Valid_Configuration_Pragma;
13112 
13113                --  Capture the component alignment in a global variable when
13114                --  the pragma appears in a configuration file. Note that the
13115                --  scope stack is empty at this point and cannot be used to
13116                --  store the alignment value.
13117 
13118                Configuration_Component_Alignment := Atype;
13119 
13120             --  Case with no name, supplied, affects scope table entry
13121 
13122             elsif No (Name) then
13123                Scope_Stack.Table
13124                  (Scope_Stack.Last).Component_Alignment_Default := Atype;
13125 
13126             --  Case of name supplied
13127 
13128             else
13129                Check_Arg_Is_Local_Name (Name);
13130                Find_Type (Name);
13131                Typ := Entity (Name);
13132 
13133                if Typ = Any_Type
13134                  or else Rep_Item_Too_Early (Typ, N)
13135                then
13136                   return;
13137                else
13138                   Typ := Underlying_Type (Typ);
13139                end if;
13140 
13141                if not Is_Record_Type (Typ)
13142                  and then not Is_Array_Type (Typ)
13143                then
13144                   Error_Pragma_Arg
13145                     ("Name parameter of pragma% must identify record or "
13146                      & "array type", Name);
13147                end if;
13148 
13149                --  An explicit Component_Alignment pragma overrides an
13150                --  implicit pragma Pack, but not an explicit one.
13151 
13152                if not Has_Pragma_Pack (Base_Type (Typ)) then
13153                   Set_Is_Packed (Base_Type (Typ), False);
13154                   Set_Component_Alignment (Base_Type (Typ), Atype);
13155                end if;
13156             end if;
13157          end Component_AlignmentP;
13158 
13159          --------------------------------
13160          -- Constant_After_Elaboration --
13161          --------------------------------
13162 
13163          --  pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
13164 
13165          when Pragma_Constant_After_Elaboration => Constant_After_Elaboration :
13166          declare
13167             Obj_Decl : Node_Id;
13168             Obj_Id   : Entity_Id;
13169 
13170          begin
13171             GNAT_Pragma;
13172             Check_No_Identifiers;
13173             Check_At_Most_N_Arguments (1);
13174 
13175             Obj_Decl := Find_Related_Context (N, Do_Checks => True);
13176 
13177             --  Object declaration
13178 
13179             if Nkind (Obj_Decl) = N_Object_Declaration then
13180                null;
13181 
13182             --  Otherwise the pragma is associated with an illegal construct
13183 
13184             else
13185                Pragma_Misplaced;
13186                return;
13187             end if;
13188 
13189             Obj_Id := Defining_Entity (Obj_Decl);
13190 
13191             --  The object declaration must be a library-level variable which
13192             --  is either explicitly initialized or obtains a value during the
13193             --  elaboration of a package body (SPARK RM 3.3.1).
13194 
13195             if Ekind (Obj_Id) = E_Variable then
13196                if not Is_Library_Level_Entity (Obj_Id) then
13197                   Error_Pragma
13198                     ("pragma % must apply to a library level variable");
13199                   return;
13200                end if;
13201 
13202             --  Otherwise the pragma applies to a constant, which is illegal
13203 
13204             else
13205                Error_Pragma ("pragma % must apply to a variable declaration");
13206                return;
13207             end if;
13208 
13209             --  Chain the pragma on the contract for completeness
13210 
13211             Add_Contract_Item (N, Obj_Id);
13212 
13213             --  A pragma that applies to a Ghost entity becomes Ghost for the
13214             --  purposes of legality checks and removal of ignored Ghost code.
13215 
13216             Mark_Pragma_As_Ghost (N, Obj_Id);
13217 
13218             --  Analyze the Boolean expression (if any)
13219 
13220             if Present (Arg1) then
13221                Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
13222             end if;
13223          end Constant_After_Elaboration;
13224 
13225          --------------------
13226          -- Contract_Cases --
13227          --------------------
13228 
13229          --  pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
13230 
13231          --  CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
13232 
13233          --  CASE_GUARD ::= boolean_EXPRESSION | others
13234 
13235          --  CONSEQUENCE ::= boolean_EXPRESSION
13236 
13237          --  Characteristics:
13238 
13239          --    * Analysis - The annotation undergoes initial checks to verify
13240          --    the legal placement and context. Secondary checks preanalyze the
13241          --    expressions in:
13242 
13243          --       Analyze_Contract_Cases_In_Decl_Part
13244 
13245          --    * Expansion - The annotation is expanded during the expansion of
13246          --    the related subprogram [body] contract as performed in:
13247 
13248          --       Expand_Subprogram_Contract
13249 
13250          --    * Template - The annotation utilizes the generic template of the
13251          --    related subprogram [body] when it is:
13252 
13253          --       aspect on subprogram declaration
13254          --       aspect on stand alone subprogram body
13255          --       pragma on stand alone subprogram body
13256 
13257          --    The annotation must prepare its own template when it is:
13258 
13259          --       pragma on subprogram declaration
13260 
13261          --    * Globals - Capture of global references must occur after full
13262          --    analysis.
13263 
13264          --    * Instance - The annotation is instantiated automatically when
13265          --    the related generic subprogram [body] is instantiated except for
13266          --    the "pragma on subprogram declaration" case. In that scenario
13267          --    the annotation must instantiate itself.
13268 
13269          when Pragma_Contract_Cases => Contract_Cases : declare
13270             Spec_Id   : Entity_Id;
13271             Subp_Decl : Node_Id;
13272 
13273          begin
13274             GNAT_Pragma;
13275             Check_No_Identifiers;
13276             Check_Arg_Count (1);
13277 
13278             --  Ensure the proper placement of the pragma. Contract_Cases must
13279             --  be associated with a subprogram declaration or a body that acts
13280             --  as a spec.
13281 
13282             Subp_Decl :=
13283               Find_Related_Declaration_Or_Body (N, Do_Checks => True);
13284 
13285             --  Entry
13286 
13287             if Nkind (Subp_Decl) = N_Entry_Declaration then
13288                null;
13289 
13290             --  Generic subprogram
13291 
13292             elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
13293                null;
13294 
13295             --  Body acts as spec
13296 
13297             elsif Nkind (Subp_Decl) = N_Subprogram_Body
13298               and then No (Corresponding_Spec (Subp_Decl))
13299             then
13300                null;
13301 
13302             --  Body stub acts as spec
13303 
13304             elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
13305               and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
13306             then
13307                null;
13308 
13309             --  Subprogram
13310 
13311             elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
13312                null;
13313 
13314             else
13315                Pragma_Misplaced;
13316                return;
13317             end if;
13318 
13319             Spec_Id := Unique_Defining_Entity (Subp_Decl);
13320 
13321             --  Chain the pragma on the contract for further processing by
13322             --  Analyze_Contract_Cases_In_Decl_Part.
13323 
13324             Add_Contract_Item (N, Defining_Entity (Subp_Decl));
13325 
13326             --  A pragma that applies to a Ghost entity becomes Ghost for the
13327             --  purposes of legality checks and removal of ignored Ghost code.
13328 
13329             Mark_Pragma_As_Ghost (N, Spec_Id);
13330             Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
13331 
13332             --  Fully analyze the pragma when it appears inside an entry
13333             --  or subprogram body because it cannot benefit from forward
13334             --  references.
13335 
13336             if Nkind_In (Subp_Decl, N_Entry_Body,
13337                                     N_Subprogram_Body,
13338                                     N_Subprogram_Body_Stub)
13339             then
13340                --  The legality checks of pragma Contract_Cases are affected by
13341                --  the SPARK mode in effect and the volatility of the context.
13342                --  Analyze all pragmas in a specific order.
13343 
13344                Analyze_If_Present (Pragma_SPARK_Mode);
13345                Analyze_If_Present (Pragma_Volatile_Function);
13346                Analyze_Contract_Cases_In_Decl_Part (N);
13347             end if;
13348          end Contract_Cases;
13349 
13350          ----------------
13351          -- Controlled --
13352          ----------------
13353 
13354          --  pragma Controlled (first_subtype_LOCAL_NAME);
13355 
13356          when Pragma_Controlled => Controlled : declare
13357             Arg : Node_Id;
13358 
13359          begin
13360             Check_No_Identifiers;
13361             Check_Arg_Count (1);
13362             Check_Arg_Is_Local_Name (Arg1);
13363             Arg := Get_Pragma_Arg (Arg1);
13364 
13365             if not Is_Entity_Name (Arg)
13366               or else not Is_Access_Type (Entity (Arg))
13367             then
13368                Error_Pragma_Arg ("pragma% requires access type", Arg1);
13369             else
13370                Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
13371             end if;
13372          end Controlled;
13373 
13374          ----------------
13375          -- Convention --
13376          ----------------
13377 
13378          --  pragma Convention ([Convention =>] convention_IDENTIFIER,
13379          --    [Entity =>] LOCAL_NAME);
13380 
13381          when Pragma_Convention => Convention : declare
13382             C : Convention_Id;
13383             E : Entity_Id;
13384             pragma Warnings (Off, C);
13385             pragma Warnings (Off, E);
13386          begin
13387             Check_Arg_Order ((Name_Convention, Name_Entity));
13388             Check_Ada_83_Warning;
13389             Check_Arg_Count (2);
13390             Process_Convention (C, E);
13391 
13392             --  A pragma that applies to a Ghost entity becomes Ghost for the
13393             --  purposes of legality checks and removal of ignored Ghost code.
13394 
13395             Mark_Pragma_As_Ghost (N, E);
13396          end Convention;
13397 
13398          ---------------------------
13399          -- Convention_Identifier --
13400          ---------------------------
13401 
13402          --  pragma Convention_Identifier ([Name =>] IDENTIFIER,
13403          --    [Convention =>] convention_IDENTIFIER);
13404 
13405          when Pragma_Convention_Identifier => Convention_Identifier : declare
13406             Idnam : Name_Id;
13407             Cname : Name_Id;
13408 
13409          begin
13410             GNAT_Pragma;
13411             Check_Arg_Order ((Name_Name, Name_Convention));
13412             Check_Arg_Count (2);
13413             Check_Optional_Identifier (Arg1, Name_Name);
13414             Check_Optional_Identifier (Arg2, Name_Convention);
13415             Check_Arg_Is_Identifier (Arg1);
13416             Check_Arg_Is_Identifier (Arg2);
13417             Idnam := Chars (Get_Pragma_Arg (Arg1));
13418             Cname := Chars (Get_Pragma_Arg (Arg2));
13419 
13420             if Is_Convention_Name (Cname) then
13421                Record_Convention_Identifier
13422                  (Idnam, Get_Convention_Id (Cname));
13423             else
13424                Error_Pragma_Arg
13425                  ("second arg for % pragma must be convention", Arg2);
13426             end if;
13427          end Convention_Identifier;
13428 
13429          ---------------
13430          -- CPP_Class --
13431          ---------------
13432 
13433          --  pragma CPP_Class ([Entity =>] LOCAL_NAME)
13434 
13435          when Pragma_CPP_Class => CPP_Class : declare
13436          begin
13437             GNAT_Pragma;
13438 
13439             if Warn_On_Obsolescent_Feature then
13440                Error_Msg_N
13441                  ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
13442                   & "effect; replace it by pragma import?j?", N);
13443             end if;
13444 
13445             Check_Arg_Count (1);
13446 
13447             Rewrite (N,
13448               Make_Pragma (Loc,
13449                 Chars                        => Name_Import,
13450                 Pragma_Argument_Associations => New_List (
13451                   Make_Pragma_Argument_Association (Loc,
13452                     Expression => Make_Identifier (Loc, Name_CPP)),
13453                   New_Copy (First (Pragma_Argument_Associations (N))))));
13454             Analyze (N);
13455          end CPP_Class;
13456 
13457          ---------------------
13458          -- CPP_Constructor --
13459          ---------------------
13460 
13461          --  pragma CPP_Constructor ([Entity =>] LOCAL_NAME
13462          --    [, [External_Name =>] static_string_EXPRESSION ]
13463          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
13464 
13465          when Pragma_CPP_Constructor => CPP_Constructor : declare
13466             Elmt    : Elmt_Id;
13467             Id      : Entity_Id;
13468             Def_Id  : Entity_Id;
13469             Tag_Typ : Entity_Id;
13470 
13471          begin
13472             GNAT_Pragma;
13473             Check_At_Least_N_Arguments (1);
13474             Check_At_Most_N_Arguments (3);
13475             Check_Optional_Identifier (Arg1, Name_Entity);
13476             Check_Arg_Is_Local_Name (Arg1);
13477 
13478             Id := Get_Pragma_Arg (Arg1);
13479             Find_Program_Unit_Name (Id);
13480 
13481             --  If we did not find the name, we are done
13482 
13483             if Etype (Id) = Any_Type then
13484                return;
13485             end if;
13486 
13487             Def_Id := Entity (Id);
13488 
13489             --  Check if already defined as constructor
13490 
13491             if Is_Constructor (Def_Id) then
13492                Error_Msg_N
13493                  ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1);
13494                return;
13495             end if;
13496 
13497             if Ekind (Def_Id) = E_Function
13498               and then (Is_CPP_Class (Etype (Def_Id))
13499                          or else (Is_Class_Wide_Type (Etype (Def_Id))
13500                                    and then
13501                                   Is_CPP_Class (Root_Type (Etype (Def_Id)))))
13502             then
13503                if Scope (Def_Id) /= Scope (Etype (Def_Id)) then
13504                   Error_Msg_N
13505                     ("'C'P'P constructor must be defined in the scope of "
13506                      & "its returned type", Arg1);
13507                end if;
13508 
13509                if Arg_Count >= 2 then
13510                   Set_Imported (Def_Id);
13511                   Set_Is_Public (Def_Id);
13512                   Process_Interface_Name (Def_Id, Arg2, Arg3);
13513                end if;
13514 
13515                Set_Has_Completion (Def_Id);
13516                Set_Is_Constructor (Def_Id);
13517                Set_Convention (Def_Id, Convention_CPP);
13518 
13519                --  Imported C++ constructors are not dispatching primitives
13520                --  because in C++ they don't have a dispatch table slot.
13521                --  However, in Ada the constructor has the profile of a
13522                --  function that returns a tagged type and therefore it has
13523                --  been treated as a primitive operation during semantic
13524                --  analysis. We now remove it from the list of primitive
13525                --  operations of the type.
13526 
13527                if Is_Tagged_Type (Etype (Def_Id))
13528                  and then not Is_Class_Wide_Type (Etype (Def_Id))
13529                  and then Is_Dispatching_Operation (Def_Id)
13530                then
13531                   Tag_Typ := Etype (Def_Id);
13532 
13533                   Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
13534                   while Present (Elmt) and then Node (Elmt) /= Def_Id loop
13535                      Next_Elmt (Elmt);
13536                   end loop;
13537 
13538                   Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
13539                   Set_Is_Dispatching_Operation (Def_Id, False);
13540                end if;
13541 
13542                --  For backward compatibility, if the constructor returns a
13543                --  class wide type, and we internally change the return type to
13544                --  the corresponding root type.
13545 
13546                if Is_Class_Wide_Type (Etype (Def_Id)) then
13547                   Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
13548                end if;
13549             else
13550                Error_Pragma_Arg
13551                  ("pragma% requires function returning a 'C'P'P_Class type",
13552                    Arg1);
13553             end if;
13554          end CPP_Constructor;
13555 
13556          -----------------
13557          -- CPP_Virtual --
13558          -----------------
13559 
13560          when Pragma_CPP_Virtual => CPP_Virtual : declare
13561          begin
13562             GNAT_Pragma;
13563 
13564             if Warn_On_Obsolescent_Feature then
13565                Error_Msg_N
13566                  ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13567                   & "effect?j?", N);
13568             end if;
13569          end CPP_Virtual;
13570 
13571          ----------------
13572          -- CPP_Vtable --
13573          ----------------
13574 
13575          when Pragma_CPP_Vtable => CPP_Vtable : declare
13576          begin
13577             GNAT_Pragma;
13578 
13579             if Warn_On_Obsolescent_Feature then
13580                Error_Msg_N
13581                  ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
13582                   & "effect?j?", N);
13583             end if;
13584          end CPP_Vtable;
13585 
13586          ---------
13587          -- CPU --
13588          ---------
13589 
13590          --  pragma CPU (EXPRESSION);
13591 
13592          when Pragma_CPU => CPU : declare
13593             P   : constant Node_Id := Parent (N);
13594             Arg : Node_Id;
13595             Ent : Entity_Id;
13596 
13597          begin
13598             Ada_2012_Pragma;
13599             Check_No_Identifiers;
13600             Check_Arg_Count (1);
13601 
13602             --  Subprogram case
13603 
13604             if Nkind (P) = N_Subprogram_Body then
13605                Check_In_Main_Program;
13606 
13607                Arg := Get_Pragma_Arg (Arg1);
13608                Analyze_And_Resolve (Arg, Any_Integer);
13609 
13610                Ent := Defining_Unit_Name (Specification (P));
13611 
13612                if Nkind (Ent) = N_Defining_Program_Unit_Name then
13613                   Ent := Defining_Identifier (Ent);
13614                end if;
13615 
13616                --  Must be static
13617 
13618                if not Is_OK_Static_Expression (Arg) then
13619                   Flag_Non_Static_Expr
13620                     ("main subprogram affinity is not static!", Arg);
13621                   raise Pragma_Exit;
13622 
13623                --  If constraint error, then we already signalled an error
13624 
13625                elsif Raises_Constraint_Error (Arg) then
13626                   null;
13627 
13628                --  Otherwise check in range
13629 
13630                else
13631                   declare
13632                      CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
13633                      --  This is the entity System.Multiprocessors.CPU_Range;
13634 
13635                      Val : constant Uint := Expr_Value (Arg);
13636 
13637                   begin
13638                      if Val < Expr_Value (Type_Low_Bound (CPU_Id))
13639                           or else
13640                         Val > Expr_Value (Type_High_Bound (CPU_Id))
13641                      then
13642                         Error_Pragma_Arg
13643                           ("main subprogram CPU is out of range", Arg1);
13644                      end if;
13645                   end;
13646                end if;
13647 
13648                Set_Main_CPU
13649                     (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
13650 
13651             --  Task case
13652 
13653             elsif Nkind (P) = N_Task_Definition then
13654                Arg := Get_Pragma_Arg (Arg1);
13655                Ent := Defining_Identifier (Parent (P));
13656 
13657                --  The expression must be analyzed in the special manner
13658                --  described in "Handling of Default and Per-Object
13659                --  Expressions" in sem.ads.
13660 
13661                Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
13662 
13663             --  Anything else is incorrect
13664 
13665             else
13666                Pragma_Misplaced;
13667             end if;
13668 
13669             --  Check duplicate pragma before we chain the pragma in the Rep
13670             --  Item chain of Ent.
13671 
13672             Check_Duplicate_Pragma (Ent);
13673             Record_Rep_Item (Ent, N);
13674          end CPU;
13675 
13676          -----------
13677          -- Debug --
13678          -----------
13679 
13680          --  pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13681 
13682          when Pragma_Debug => Debug : declare
13683             Cond : Node_Id;
13684             Call : Node_Id;
13685 
13686          begin
13687             GNAT_Pragma;
13688 
13689             --  The condition for executing the call is that the expander
13690             --  is active and that we are not ignoring this debug pragma.
13691 
13692             Cond :=
13693               New_Occurrence_Of
13694                 (Boolean_Literals
13695                   (Expander_Active and then not Is_Ignored (N)),
13696                  Loc);
13697 
13698             if not Is_Ignored (N) then
13699                Set_SCO_Pragma_Enabled (Loc);
13700             end if;
13701 
13702             if Arg_Count = 2 then
13703                Cond :=
13704                  Make_And_Then (Loc,
13705                    Left_Opnd  => Relocate_Node (Cond),
13706                    Right_Opnd => Get_Pragma_Arg (Arg1));
13707                Call := Get_Pragma_Arg (Arg2);
13708             else
13709                Call := Get_Pragma_Arg (Arg1);
13710             end if;
13711 
13712             if Nkind_In (Call,
13713                  N_Indexed_Component,
13714                  N_Function_Call,
13715                  N_Identifier,
13716                  N_Expanded_Name,
13717                  N_Selected_Component)
13718             then
13719                --  If this pragma Debug comes from source, its argument was
13720                --  parsed as a name form (which is syntactically identical).
13721                --  In a generic context a parameterless call will be left as
13722                --  an expanded name (if global) or selected_component if local.
13723                --  Change it to a procedure call statement now.
13724 
13725                Change_Name_To_Procedure_Call_Statement (Call);
13726 
13727             elsif Nkind (Call) = N_Procedure_Call_Statement then
13728 
13729                --  Already in the form of a procedure call statement: nothing
13730                --  to do (could happen in case of an internally generated
13731                --  pragma Debug).
13732 
13733                null;
13734 
13735             else
13736                --  All other cases: diagnose error
13737 
13738                Error_Msg
13739                  ("argument of pragma ""Debug"" is not procedure call",
13740                   Sloc (Call));
13741                return;
13742             end if;
13743 
13744             --  Rewrite into a conditional with an appropriate condition. We
13745             --  wrap the procedure call in a block so that overhead from e.g.
13746             --  use of the secondary stack does not generate execution overhead
13747             --  for suppressed conditions.
13748 
13749             --  Normally the analysis that follows will freeze the subprogram
13750             --  being called. However, if the call is to a null procedure,
13751             --  we want to freeze it before creating the block, because the
13752             --  analysis that follows may be done with expansion disabled, in
13753             --  which case the body will not be generated, leading to spurious
13754             --  errors.
13755 
13756             if Nkind (Call) = N_Procedure_Call_Statement
13757               and then Is_Entity_Name (Name (Call))
13758             then
13759                Analyze (Name (Call));
13760                Freeze_Before (N, Entity (Name (Call)));
13761             end if;
13762 
13763             Rewrite (N,
13764               Make_Implicit_If_Statement (N,
13765                 Condition       => Cond,
13766                 Then_Statements => New_List (
13767                   Make_Block_Statement (Loc,
13768                     Handled_Statement_Sequence =>
13769                       Make_Handled_Sequence_Of_Statements (Loc,
13770                         Statements => New_List (Relocate_Node (Call)))))));
13771             Analyze (N);
13772 
13773             --  Ignore pragma Debug in GNATprove mode. Do this rewriting
13774             --  after analysis of the normally rewritten node, to capture all
13775             --  references to entities, which avoids issuing wrong warnings
13776             --  about unused entities.
13777 
13778             if GNATprove_Mode then
13779                Rewrite (N, Make_Null_Statement (Loc));
13780             end if;
13781          end Debug;
13782 
13783          ------------------
13784          -- Debug_Policy --
13785          ------------------
13786 
13787          --  pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13788 
13789          when Pragma_Debug_Policy =>
13790             GNAT_Pragma;
13791             Check_Arg_Count (1);
13792             Check_No_Identifiers;
13793             Check_Arg_Is_Identifier (Arg1);
13794 
13795             --  Exactly equivalent to pragma Check_Policy (Debug, arg), so
13796             --  rewrite it that way, and let the rest of the checking come
13797             --  from analyzing the rewritten pragma.
13798 
13799             Rewrite (N,
13800               Make_Pragma (Loc,
13801                 Chars                        => Name_Check_Policy,
13802                 Pragma_Argument_Associations => New_List (
13803                   Make_Pragma_Argument_Association (Loc,
13804                     Expression => Make_Identifier (Loc, Name_Debug)),
13805 
13806                   Make_Pragma_Argument_Association (Loc,
13807                     Expression => Get_Pragma_Arg (Arg1)))));
13808             Analyze (N);
13809 
13810          -------------------------------
13811          -- Default_Initial_Condition --
13812          -------------------------------
13813 
13814          --  pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
13815 
13816          when Pragma_Default_Initial_Condition => Default_Init_Cond : declare
13817             Discard : Boolean;
13818             Stmt    : Node_Id;
13819             Typ     : Entity_Id;
13820 
13821          begin
13822             GNAT_Pragma;
13823             Check_No_Identifiers;
13824             Check_At_Most_N_Arguments (1);
13825 
13826             Stmt := Prev (N);
13827             while Present (Stmt) loop
13828 
13829                --  Skip prior pragmas, but check for duplicates
13830 
13831                if Nkind (Stmt) = N_Pragma then
13832                   if Pragma_Name (Stmt) = Pname then
13833                      Error_Msg_Name_1 := Pname;
13834                      Error_Msg_Sloc   := Sloc (Stmt);
13835                      Error_Msg_N ("pragma % duplicates pragma declared#", N);
13836                   end if;
13837 
13838                --  Skip internally generated code
13839 
13840                elsif not Comes_From_Source (Stmt) then
13841                   null;
13842 
13843                --  The associated private type [extension] has been found, stop
13844                --  the search.
13845 
13846                elsif Nkind_In (Stmt, N_Private_Extension_Declaration,
13847                                      N_Private_Type_Declaration)
13848                then
13849                   Typ := Defining_Entity (Stmt);
13850                   exit;
13851 
13852                --  The pragma does not apply to a legal construct, issue an
13853                --  error and stop the analysis.
13854 
13855                else
13856                   Pragma_Misplaced;
13857                   return;
13858                end if;
13859 
13860                Stmt := Prev (Stmt);
13861             end loop;
13862 
13863             --  A pragma that applies to a Ghost entity becomes Ghost for the
13864             --  purposes of legality checks and removal of ignored Ghost code.
13865 
13866             Mark_Pragma_As_Ghost (N, Typ);
13867             Set_Has_Default_Init_Cond (Typ);
13868             Set_Has_Inherited_Default_Init_Cond (Typ, False);
13869 
13870             --  Chain the pragma on the rep item chain for further processing
13871 
13872             Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
13873          end Default_Init_Cond;
13874 
13875          ----------------------------------
13876          -- Default_Scalar_Storage_Order --
13877          ----------------------------------
13878 
13879          --  pragma Default_Scalar_Storage_Order
13880          --           (High_Order_First | Low_Order_First);
13881 
13882          when Pragma_Default_Scalar_Storage_Order => DSSO : declare
13883             Default : Character;
13884 
13885          begin
13886             GNAT_Pragma;
13887             Check_Arg_Count (1);
13888 
13889             --  Default_Scalar_Storage_Order can appear as a configuration
13890             --  pragma, or in a declarative part of a package spec.
13891 
13892             if not Is_Configuration_Pragma then
13893                Check_Is_In_Decl_Part_Or_Package_Spec;
13894             end if;
13895 
13896             Check_No_Identifiers;
13897             Check_Arg_Is_One_Of
13898               (Arg1, Name_High_Order_First, Name_Low_Order_First);
13899             Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
13900             Default := Fold_Upper (Name_Buffer (1));
13901 
13902             if not Support_Nondefault_SSO_On_Target
13903               and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
13904             then
13905                if Warn_On_Unrecognized_Pragma then
13906                   Error_Msg_N
13907                     ("non-default Scalar_Storage_Order not supported "
13908                      & "on target?g?", N);
13909                   Error_Msg_N
13910                     ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
13911                end if;
13912 
13913             --  Here set the specified default
13914 
13915             else
13916                Opt.Default_SSO := Default;
13917             end if;
13918          end DSSO;
13919 
13920          --------------------------
13921          -- Default_Storage_Pool --
13922          --------------------------
13923 
13924          --  pragma Default_Storage_Pool (storage_pool_NAME | null);
13925 
13926          when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare
13927             Pool : Node_Id;
13928 
13929          begin
13930             Ada_2012_Pragma;
13931             Check_Arg_Count (1);
13932 
13933             --  Default_Storage_Pool can appear as a configuration pragma, or
13934             --  in a declarative part of a package spec.
13935 
13936             if not Is_Configuration_Pragma then
13937                Check_Is_In_Decl_Part_Or_Package_Spec;
13938             end if;
13939 
13940             if From_Aspect_Specification (N) then
13941                declare
13942                   E : constant Entity_Id := Entity (Corresponding_Aspect (N));
13943                begin
13944                   if not In_Open_Scopes (E) then
13945                      Error_Msg_N
13946                        ("aspect must apply to package or subprogram", N);
13947                   end if;
13948                end;
13949             end if;
13950 
13951             if Present (Arg1) then
13952                Pool := Get_Pragma_Arg (Arg1);
13953 
13954                --  Case of Default_Storage_Pool (null);
13955 
13956                if Nkind (Pool) = N_Null then
13957                   Analyze (Pool);
13958 
13959                   --  This is an odd case, this is not really an expression,
13960                   --  so we don't have a type for it. So just set the type to
13961                   --  Empty.
13962 
13963                   Set_Etype (Pool, Empty);
13964 
13965                --  Case of Default_Storage_Pool (storage_pool_NAME);
13966 
13967                else
13968                   --  If it's a configuration pragma, then the only allowed
13969                   --  argument is "null".
13970 
13971                   if Is_Configuration_Pragma then
13972                      Error_Pragma_Arg ("NULL expected", Arg1);
13973                   end if;
13974 
13975                   --  The expected type for a non-"null" argument is
13976                   --  Root_Storage_Pool'Class, and the pool must be a variable.
13977 
13978                   Analyze_And_Resolve
13979                     (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
13980 
13981                   if Is_Variable (Pool) then
13982 
13983                      --  A pragma that applies to a Ghost entity becomes Ghost
13984                      --  for the purposes of legality checks and removal of
13985                      --  ignored Ghost code.
13986 
13987                      Mark_Pragma_As_Ghost (N, Entity (Pool));
13988 
13989                   else
13990                      Error_Pragma_Arg
13991                        ("default storage pool must be a variable", Arg1);
13992                   end if;
13993                end if;
13994 
13995                --  Record the pool name (or null). Freeze.Freeze_Entity for an
13996                --  access type will use this information to set the appropriate
13997                --  attributes of the access type.
13998 
13999                Default_Pool := Pool;
14000             end if;
14001          end Default_Storage_Pool;
14002 
14003          -------------
14004          -- Depends --
14005          -------------
14006 
14007          --  pragma Depends (DEPENDENCY_RELATION);
14008 
14009          --  DEPENDENCY_RELATION ::=
14010          --     null
14011          --  | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
14012 
14013          --  DEPENDENCY_CLAUSE ::=
14014          --    OUTPUT_LIST =>[+] INPUT_LIST
14015          --  | NULL_DEPENDENCY_CLAUSE
14016 
14017          --  NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
14018 
14019          --  OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
14020 
14021          --  INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
14022 
14023          --  OUTPUT ::= NAME | FUNCTION_RESULT
14024          --  INPUT  ::= NAME
14025 
14026          --  where FUNCTION_RESULT is a function Result attribute_reference
14027 
14028          --  Characteristics:
14029 
14030          --    * Analysis - The annotation undergoes initial checks to verify
14031          --    the legal placement and context. Secondary checks fully analyze
14032          --    the dependency clauses in:
14033 
14034          --       Analyze_Depends_In_Decl_Part
14035 
14036          --    * Expansion - None.
14037 
14038          --    * Template - The annotation utilizes the generic template of the
14039          --    related subprogram [body] when it is:
14040 
14041          --       aspect on subprogram declaration
14042          --       aspect on stand alone subprogram body
14043          --       pragma on stand alone subprogram body
14044 
14045          --    The annotation must prepare its own template when it is:
14046 
14047          --       pragma on subprogram declaration
14048 
14049          --    * Globals - Capture of global references must occur after full
14050          --    analysis.
14051 
14052          --    * Instance - The annotation is instantiated automatically when
14053          --    the related generic subprogram [body] is instantiated except for
14054          --    the "pragma on subprogram declaration" case. In that scenario
14055          --    the annotation must instantiate itself.
14056 
14057          when Pragma_Depends => Depends : declare
14058             Legal     : Boolean;
14059             Spec_Id   : Entity_Id;
14060             Subp_Decl : Node_Id;
14061 
14062          begin
14063             Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
14064 
14065             if Legal then
14066 
14067                --  Chain the pragma on the contract for further processing by
14068                --  Analyze_Depends_In_Decl_Part.
14069 
14070                Add_Contract_Item (N, Spec_Id);
14071 
14072                --  Fully analyze the pragma when it appears inside an entry
14073                --  or subprogram body because it cannot benefit from forward
14074                --  references.
14075 
14076                if Nkind_In (Subp_Decl, N_Entry_Body,
14077                                        N_Subprogram_Body,
14078                                        N_Subprogram_Body_Stub)
14079                then
14080                   --  The legality checks of pragmas Depends and Global are
14081                   --  affected by the SPARK mode in effect and the volatility
14082                   --  of the context. In addition these two pragmas are subject
14083                   --  to an inherent order:
14084 
14085                   --    1) Global
14086                   --    2) Depends
14087 
14088                   --  Analyze all these pragmas in the order outlined above
14089 
14090                   Analyze_If_Present (Pragma_SPARK_Mode);
14091                   Analyze_If_Present (Pragma_Volatile_Function);
14092                   Analyze_If_Present (Pragma_Global);
14093                   Analyze_Depends_In_Decl_Part (N);
14094                end if;
14095             end if;
14096          end Depends;
14097 
14098          ---------------------
14099          -- Detect_Blocking --
14100          ---------------------
14101 
14102          --  pragma Detect_Blocking;
14103 
14104          when Pragma_Detect_Blocking =>
14105             Ada_2005_Pragma;
14106             Check_Arg_Count (0);
14107             Check_Valid_Configuration_Pragma;
14108             Detect_Blocking := True;
14109 
14110          ------------------------------------
14111          -- Disable_Atomic_Synchronization --
14112          ------------------------------------
14113 
14114          --  pragma Disable_Atomic_Synchronization [(Entity)];
14115 
14116          when Pragma_Disable_Atomic_Synchronization =>
14117             GNAT_Pragma;
14118             Process_Disable_Enable_Atomic_Sync (Name_Suppress);
14119 
14120          -------------------
14121          -- Discard_Names --
14122          -------------------
14123 
14124          --  pragma Discard_Names [([On =>] LOCAL_NAME)];
14125 
14126          when Pragma_Discard_Names => Discard_Names : declare
14127             E    : Entity_Id;
14128             E_Id : Node_Id;
14129 
14130          begin
14131             Check_Ada_83_Warning;
14132 
14133             --  Deal with configuration pragma case
14134 
14135             if Arg_Count = 0 and then Is_Configuration_Pragma then
14136                Global_Discard_Names := True;
14137                return;
14138 
14139             --  Otherwise, check correct appropriate context
14140 
14141             else
14142                Check_Is_In_Decl_Part_Or_Package_Spec;
14143 
14144                if Arg_Count = 0 then
14145 
14146                   --  If there is no parameter, then from now on this pragma
14147                   --  applies to any enumeration, exception or tagged type
14148                   --  defined in the current declarative part, and recursively
14149                   --  to any nested scope.
14150 
14151                   Set_Discard_Names (Current_Scope);
14152                   return;
14153 
14154                else
14155                   Check_Arg_Count (1);
14156                   Check_Optional_Identifier (Arg1, Name_On);
14157                   Check_Arg_Is_Local_Name (Arg1);
14158 
14159                   E_Id := Get_Pragma_Arg (Arg1);
14160 
14161                   if Etype (E_Id) = Any_Type then
14162                      return;
14163                   else
14164                      E := Entity (E_Id);
14165                   end if;
14166 
14167                   --  A pragma that applies to a Ghost entity becomes Ghost for
14168                   --  the purposes of legality checks and removal of ignored
14169                   --  Ghost code.
14170 
14171                   Mark_Pragma_As_Ghost (N, E);
14172 
14173                   if (Is_First_Subtype (E)
14174                       and then
14175                         (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
14176                     or else Ekind (E) = E_Exception
14177                   then
14178                      Set_Discard_Names (E);
14179                      Record_Rep_Item (E, N);
14180 
14181                   else
14182                      Error_Pragma_Arg
14183                        ("inappropriate entity for pragma%", Arg1);
14184                   end if;
14185                end if;
14186             end if;
14187          end Discard_Names;
14188 
14189          ------------------------
14190          -- Dispatching_Domain --
14191          ------------------------
14192 
14193          --  pragma Dispatching_Domain (EXPRESSION);
14194 
14195          when Pragma_Dispatching_Domain => Dispatching_Domain : declare
14196             P   : constant Node_Id := Parent (N);
14197             Arg : Node_Id;
14198             Ent : Entity_Id;
14199 
14200          begin
14201             Ada_2012_Pragma;
14202             Check_No_Identifiers;
14203             Check_Arg_Count (1);
14204 
14205             --  This pragma is born obsolete, but not the aspect
14206 
14207             if not From_Aspect_Specification (N) then
14208                Check_Restriction
14209                  (No_Obsolescent_Features, Pragma_Identifier (N));
14210             end if;
14211 
14212             if Nkind (P) = N_Task_Definition then
14213                Arg := Get_Pragma_Arg (Arg1);
14214                Ent := Defining_Identifier (Parent (P));
14215 
14216                --  A pragma that applies to a Ghost entity becomes Ghost for
14217                --  the purposes of legality checks and removal of ignored Ghost
14218                --  code.
14219 
14220                Mark_Pragma_As_Ghost (N, Ent);
14221 
14222                --  The expression must be analyzed in the special manner
14223                --  described in "Handling of Default and Per-Object
14224                --  Expressions" in sem.ads.
14225 
14226                Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
14227 
14228                --  Check duplicate pragma before we chain the pragma in the Rep
14229                --  Item chain of Ent.
14230 
14231                Check_Duplicate_Pragma (Ent);
14232                Record_Rep_Item (Ent, N);
14233 
14234             --  Anything else is incorrect
14235 
14236             else
14237                Pragma_Misplaced;
14238             end if;
14239          end Dispatching_Domain;
14240 
14241          ---------------
14242          -- Elaborate --
14243          ---------------
14244 
14245          --  pragma Elaborate (library_unit_NAME {, library_unit_NAME});
14246 
14247          when Pragma_Elaborate => Elaborate : declare
14248             Arg   : Node_Id;
14249             Citem : Node_Id;
14250 
14251          begin
14252             --  Pragma must be in context items list of a compilation unit
14253 
14254             if not Is_In_Context_Clause then
14255                Pragma_Misplaced;
14256             end if;
14257 
14258             --  Must be at least one argument
14259 
14260             if Arg_Count = 0 then
14261                Error_Pragma ("pragma% requires at least one argument");
14262             end if;
14263 
14264             --  In Ada 83 mode, there can be no items following it in the
14265             --  context list except other pragmas and implicit with clauses
14266             --  (e.g. those added by use of Rtsfind). In Ada 95 mode, this
14267             --  placement rule does not apply.
14268 
14269             if Ada_Version = Ada_83 and then Comes_From_Source (N) then
14270                Citem := Next (N);
14271                while Present (Citem) loop
14272                   if Nkind (Citem) = N_Pragma
14273                     or else (Nkind (Citem) = N_With_Clause
14274                               and then Implicit_With (Citem))
14275                   then
14276                      null;
14277                   else
14278                      Error_Pragma
14279                        ("(Ada 83) pragma% must be at end of context clause");
14280                   end if;
14281 
14282                   Next (Citem);
14283                end loop;
14284             end if;
14285 
14286             --  Finally, the arguments must all be units mentioned in a with
14287             --  clause in the same context clause. Note we already checked (in
14288             --  Par.Prag) that the arguments are all identifiers or selected
14289             --  components.
14290 
14291             Arg := Arg1;
14292             Outer : while Present (Arg) loop
14293                Citem := First (List_Containing (N));
14294                Inner : while Citem /= N loop
14295                   if Nkind (Citem) = N_With_Clause
14296                     and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14297                   then
14298                      Set_Elaborate_Present (Citem, True);
14299                      Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14300 
14301                      --  With the pragma present, elaboration calls on
14302                      --  subprograms from the named unit need no further
14303                      --  checks, as long as the pragma appears in the current
14304                      --  compilation unit. If the pragma appears in some unit
14305                      --  in the context, there might still be a need for an
14306                      --  Elaborate_All_Desirable from the current compilation
14307                      --  to the named unit, so we keep the check enabled.
14308 
14309                      if In_Extended_Main_Source_Unit (N) then
14310 
14311                         --  This does not apply in SPARK mode, where we allow
14312                         --  pragma Elaborate, but we don't trust it to be right
14313                         --  so we will still insist on the Elaborate_All.
14314 
14315                         if SPARK_Mode /= On then
14316                            Set_Suppress_Elaboration_Warnings
14317                              (Entity (Name (Citem)));
14318                         end if;
14319                      end if;
14320 
14321                      exit Inner;
14322                   end if;
14323 
14324                   Next (Citem);
14325                end loop Inner;
14326 
14327                if Citem = N then
14328                   Error_Pragma_Arg
14329                     ("argument of pragma% is not withed unit", Arg);
14330                end if;
14331 
14332                Next (Arg);
14333             end loop Outer;
14334 
14335             --  Give a warning if operating in static mode with one of the
14336             --  gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14337 
14338             if Elab_Warnings
14339               and not Dynamic_Elaboration_Checks
14340 
14341               --  pragma Elaborate not allowed in SPARK mode anyway. We
14342               --  already complained about it, no point in generating any
14343               --  further complaint.
14344 
14345               and SPARK_Mode /= On
14346             then
14347                Error_Msg_N
14348                  ("?l?use of pragma Elaborate may not be safe", N);
14349                Error_Msg_N
14350                  ("?l?use pragma Elaborate_All instead if possible", N);
14351             end if;
14352          end Elaborate;
14353 
14354          -------------------
14355          -- Elaborate_All --
14356          -------------------
14357 
14358          --  pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14359 
14360          when Pragma_Elaborate_All => Elaborate_All : declare
14361             Arg   : Node_Id;
14362             Citem : Node_Id;
14363 
14364          begin
14365             Check_Ada_83_Warning;
14366 
14367             --  Pragma must be in context items list of a compilation unit
14368 
14369             if not Is_In_Context_Clause then
14370                Pragma_Misplaced;
14371             end if;
14372 
14373             --  Must be at least one argument
14374 
14375             if Arg_Count = 0 then
14376                Error_Pragma ("pragma% requires at least one argument");
14377             end if;
14378 
14379             --  Note: unlike pragma Elaborate, pragma Elaborate_All does not
14380             --  have to appear at the end of the context clause, but may
14381             --  appear mixed in with other items, even in Ada 83 mode.
14382 
14383             --  Final check: the arguments must all be units mentioned in
14384             --  a with clause in the same context clause. Note that we
14385             --  already checked (in Par.Prag) that all the arguments are
14386             --  either identifiers or selected components.
14387 
14388             Arg := Arg1;
14389             Outr : while Present (Arg) loop
14390                Citem := First (List_Containing (N));
14391                Innr : while Citem /= N loop
14392                   if Nkind (Citem) = N_With_Clause
14393                     and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
14394                   then
14395                      Set_Elaborate_All_Present (Citem, True);
14396                      Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
14397 
14398                      --  Suppress warnings and elaboration checks on the named
14399                      --  unit if the pragma is in the current compilation, as
14400                      --  for pragma Elaborate.
14401 
14402                      if In_Extended_Main_Source_Unit (N) then
14403                         Set_Suppress_Elaboration_Warnings
14404                           (Entity (Name (Citem)));
14405                      end if;
14406                      exit Innr;
14407                   end if;
14408 
14409                   Next (Citem);
14410                end loop Innr;
14411 
14412                if Citem = N then
14413                   Set_Error_Posted (N);
14414                   Error_Pragma_Arg
14415                     ("argument of pragma% is not withed unit", Arg);
14416                end if;
14417 
14418                Next (Arg);
14419             end loop Outr;
14420          end Elaborate_All;
14421 
14422          --------------------
14423          -- Elaborate_Body --
14424          --------------------
14425 
14426          --  pragma Elaborate_Body [( library_unit_NAME )];
14427 
14428          when Pragma_Elaborate_Body => Elaborate_Body : declare
14429             Cunit_Node : Node_Id;
14430             Cunit_Ent  : Entity_Id;
14431 
14432          begin
14433             Check_Ada_83_Warning;
14434             Check_Valid_Library_Unit_Pragma;
14435 
14436             if Nkind (N) = N_Null_Statement then
14437                return;
14438             end if;
14439 
14440             Cunit_Node := Cunit (Current_Sem_Unit);
14441             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
14442 
14443             --  A pragma that applies to a Ghost entity becomes Ghost for the
14444             --  purposes of legality checks and removal of ignored Ghost code.
14445 
14446             Mark_Pragma_As_Ghost (N, Cunit_Ent);
14447 
14448             if Nkind_In (Unit (Cunit_Node), N_Package_Body,
14449                                             N_Subprogram_Body)
14450             then
14451                Error_Pragma ("pragma% must refer to a spec, not a body");
14452             else
14453                Set_Body_Required (Cunit_Node, True);
14454                Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
14455 
14456                --  If we are in dynamic elaboration mode, then we suppress
14457                --  elaboration warnings for the unit, since it is definitely
14458                --  fine NOT to do dynamic checks at the first level (and such
14459                --  checks will be suppressed because no elaboration boolean
14460                --  is created for Elaborate_Body packages).
14461 
14462                --  But in the static model of elaboration, Elaborate_Body is
14463                --  definitely NOT good enough to ensure elaboration safety on
14464                --  its own, since the body may WITH other units that are not
14465                --  safe from an elaboration point of view, so a client must
14466                --  still do an Elaborate_All on such units.
14467 
14468                --  Debug flag -gnatdD restores the old behavior of 3.13, where
14469                --  Elaborate_Body always suppressed elab warnings.
14470 
14471                if Dynamic_Elaboration_Checks or Debug_Flag_DD then
14472                   Set_Suppress_Elaboration_Warnings (Cunit_Ent);
14473                end if;
14474             end if;
14475          end Elaborate_Body;
14476 
14477          ------------------------
14478          -- Elaboration_Checks --
14479          ------------------------
14480 
14481          --  pragma Elaboration_Checks (Static | Dynamic);
14482 
14483          when Pragma_Elaboration_Checks =>
14484             GNAT_Pragma;
14485             Check_Arg_Count (1);
14486             Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
14487 
14488             --  Set flag accordingly (ignore attempt at dynamic elaboration
14489             --  checks in SPARK mode).
14490 
14491             Dynamic_Elaboration_Checks :=
14492               Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
14493 
14494          ---------------
14495          -- Eliminate --
14496          ---------------
14497 
14498          --  pragma Eliminate (
14499          --      [Unit_Name  =>] IDENTIFIER | SELECTED_COMPONENT,
14500          --    [,[Entity     =>] IDENTIFIER |
14501          --                      SELECTED_COMPONENT |
14502          --                      STRING_LITERAL]
14503          --    [,                OVERLOADING_RESOLUTION]);
14504 
14505          --  OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
14506          --                             SOURCE_LOCATION
14507 
14508          --  PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
14509          --                                        FUNCTION_PROFILE
14510 
14511          --  PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
14512 
14513          --  FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
14514          --                       Result_Type => result_SUBTYPE_NAME]
14515 
14516          --  PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
14517          --  SUBTYPE_NAME    ::= STRING_LITERAL
14518 
14519          --  SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14520          --  SOURCE_TRACE    ::= STRING_LITERAL
14521 
14522          when Pragma_Eliminate => Eliminate : declare
14523             Args  : Args_List (1 .. 5);
14524             Names : constant Name_List (1 .. 5) := (
14525                       Name_Unit_Name,
14526                       Name_Entity,
14527                       Name_Parameter_Types,
14528                       Name_Result_Type,
14529                       Name_Source_Location);
14530 
14531             Unit_Name       : Node_Id renames Args (1);
14532             Entity          : Node_Id renames Args (2);
14533             Parameter_Types : Node_Id renames Args (3);
14534             Result_Type     : Node_Id renames Args (4);
14535             Source_Location : Node_Id renames Args (5);
14536 
14537          begin
14538             GNAT_Pragma;
14539             Check_Valid_Configuration_Pragma;
14540             Gather_Associations (Names, Args);
14541 
14542             if No (Unit_Name) then
14543                Error_Pragma ("missing Unit_Name argument for pragma%");
14544             end if;
14545 
14546             if No (Entity)
14547               and then (Present (Parameter_Types)
14548                           or else
14549                         Present (Result_Type)
14550                           or else
14551                         Present (Source_Location))
14552             then
14553                Error_Pragma ("missing Entity argument for pragma%");
14554             end if;
14555 
14556             if (Present (Parameter_Types)
14557                   or else
14558                 Present (Result_Type))
14559               and then
14560                 Present (Source_Location)
14561             then
14562                Error_Pragma
14563                  ("parameter profile and source location cannot be used "
14564                   & "together in pragma%");
14565             end if;
14566 
14567             Process_Eliminate_Pragma
14568               (N,
14569                Unit_Name,
14570                Entity,
14571                Parameter_Types,
14572                Result_Type,
14573                Source_Location);
14574          end Eliminate;
14575 
14576          -----------------------------------
14577          -- Enable_Atomic_Synchronization --
14578          -----------------------------------
14579 
14580          --  pragma Enable_Atomic_Synchronization [(Entity)];
14581 
14582          when Pragma_Enable_Atomic_Synchronization =>
14583             GNAT_Pragma;
14584             Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
14585 
14586          ------------
14587          -- Export --
14588          ------------
14589 
14590          --  pragma Export (
14591          --    [   Convention    =>] convention_IDENTIFIER,
14592          --    [   Entity        =>] LOCAL_NAME
14593          --    [, [External_Name =>] static_string_EXPRESSION ]
14594          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
14595 
14596          when Pragma_Export => Export : declare
14597             C      : Convention_Id;
14598             Def_Id : Entity_Id;
14599 
14600             pragma Warnings (Off, C);
14601 
14602          begin
14603             Check_Ada_83_Warning;
14604             Check_Arg_Order
14605               ((Name_Convention,
14606                 Name_Entity,
14607                 Name_External_Name,
14608                 Name_Link_Name));
14609 
14610             Check_At_Least_N_Arguments (2);
14611             Check_At_Most_N_Arguments  (4);
14612 
14613             --  In Relaxed_RM_Semantics, support old Ada 83 style:
14614             --  pragma Export (Entity, "external name");
14615 
14616             if Relaxed_RM_Semantics
14617               and then Arg_Count = 2
14618               and then Nkind (Expression (Arg2)) = N_String_Literal
14619             then
14620                C := Convention_C;
14621                Def_Id := Get_Pragma_Arg (Arg1);
14622                Analyze (Def_Id);
14623 
14624                if not Is_Entity_Name (Def_Id) then
14625                   Error_Pragma_Arg ("entity name required", Arg1);
14626                end if;
14627 
14628                Def_Id := Entity (Def_Id);
14629                Set_Exported (Def_Id, Arg1);
14630 
14631             else
14632                Process_Convention (C, Def_Id);
14633 
14634                --  A pragma that applies to a Ghost entity becomes Ghost for
14635                --  the purposes of legality checks and removal of ignored Ghost
14636                --  code.
14637 
14638                Mark_Pragma_As_Ghost (N, Def_Id);
14639 
14640                if Ekind (Def_Id) /= E_Constant then
14641                   Note_Possible_Modification
14642                     (Get_Pragma_Arg (Arg2), Sure => False);
14643                end if;
14644 
14645                Process_Interface_Name (Def_Id, Arg3, Arg4);
14646                Set_Exported (Def_Id, Arg2);
14647             end if;
14648 
14649             --  If the entity is a deferred constant, propagate the information
14650             --  to the full view, because gigi elaborates the full view only.
14651 
14652             if Ekind (Def_Id) = E_Constant
14653               and then Present (Full_View (Def_Id))
14654             then
14655                declare
14656                   Id2 : constant Entity_Id := Full_View (Def_Id);
14657                begin
14658                   Set_Is_Exported    (Id2, Is_Exported          (Def_Id));
14659                   Set_First_Rep_Item (Id2, First_Rep_Item       (Def_Id));
14660                   Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
14661                end;
14662             end if;
14663          end Export;
14664 
14665          ---------------------
14666          -- Export_Function --
14667          ---------------------
14668 
14669          --  pragma Export_Function (
14670          --        [Internal         =>] LOCAL_NAME
14671          --     [, [External         =>] EXTERNAL_SYMBOL]
14672          --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
14673          --     [, [Result_Type      =>] TYPE_DESIGNATOR]
14674          --     [, [Mechanism        =>] MECHANISM]
14675          --     [, [Result_Mechanism =>] MECHANISM_NAME]);
14676 
14677          --  EXTERNAL_SYMBOL ::=
14678          --    IDENTIFIER
14679          --  | static_string_EXPRESSION
14680 
14681          --  PARAMETER_TYPES ::=
14682          --    null
14683          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14684 
14685          --  TYPE_DESIGNATOR ::=
14686          --    subtype_NAME
14687          --  | subtype_Name ' Access
14688 
14689          --  MECHANISM ::=
14690          --    MECHANISM_NAME
14691          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14692 
14693          --  MECHANISM_ASSOCIATION ::=
14694          --    [formal_parameter_NAME =>] MECHANISM_NAME
14695 
14696          --  MECHANISM_NAME ::=
14697          --    Value
14698          --  | Reference
14699 
14700          when Pragma_Export_Function => Export_Function : declare
14701             Args  : Args_List (1 .. 6);
14702             Names : constant Name_List (1 .. 6) := (
14703                       Name_Internal,
14704                       Name_External,
14705                       Name_Parameter_Types,
14706                       Name_Result_Type,
14707                       Name_Mechanism,
14708                       Name_Result_Mechanism);
14709 
14710             Internal         : Node_Id renames Args (1);
14711             External         : Node_Id renames Args (2);
14712             Parameter_Types  : Node_Id renames Args (3);
14713             Result_Type      : Node_Id renames Args (4);
14714             Mechanism        : Node_Id renames Args (5);
14715             Result_Mechanism : Node_Id renames Args (6);
14716 
14717          begin
14718             GNAT_Pragma;
14719             Gather_Associations (Names, Args);
14720             Process_Extended_Import_Export_Subprogram_Pragma (
14721               Arg_Internal         => Internal,
14722               Arg_External         => External,
14723               Arg_Parameter_Types  => Parameter_Types,
14724               Arg_Result_Type      => Result_Type,
14725               Arg_Mechanism        => Mechanism,
14726               Arg_Result_Mechanism => Result_Mechanism);
14727          end Export_Function;
14728 
14729          -------------------
14730          -- Export_Object --
14731          -------------------
14732 
14733          --  pragma Export_Object (
14734          --        [Internal =>] LOCAL_NAME
14735          --     [, [External =>] EXTERNAL_SYMBOL]
14736          --     [, [Size     =>] EXTERNAL_SYMBOL]);
14737 
14738          --  EXTERNAL_SYMBOL ::=
14739          --    IDENTIFIER
14740          --  | static_string_EXPRESSION
14741 
14742          --  PARAMETER_TYPES ::=
14743          --    null
14744          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14745 
14746          --  TYPE_DESIGNATOR ::=
14747          --    subtype_NAME
14748          --  | subtype_Name ' Access
14749 
14750          --  MECHANISM ::=
14751          --    MECHANISM_NAME
14752          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14753 
14754          --  MECHANISM_ASSOCIATION ::=
14755          --    [formal_parameter_NAME =>] MECHANISM_NAME
14756 
14757          --  MECHANISM_NAME ::=
14758          --    Value
14759          --  | Reference
14760 
14761          when Pragma_Export_Object => Export_Object : declare
14762             Args  : Args_List (1 .. 3);
14763             Names : constant Name_List (1 .. 3) := (
14764                       Name_Internal,
14765                       Name_External,
14766                       Name_Size);
14767 
14768             Internal : Node_Id renames Args (1);
14769             External : Node_Id renames Args (2);
14770             Size     : Node_Id renames Args (3);
14771 
14772          begin
14773             GNAT_Pragma;
14774             Gather_Associations (Names, Args);
14775             Process_Extended_Import_Export_Object_Pragma (
14776               Arg_Internal => Internal,
14777               Arg_External => External,
14778               Arg_Size     => Size);
14779          end Export_Object;
14780 
14781          ----------------------
14782          -- Export_Procedure --
14783          ----------------------
14784 
14785          --  pragma Export_Procedure (
14786          --        [Internal         =>] LOCAL_NAME
14787          --     [, [External         =>] EXTERNAL_SYMBOL]
14788          --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
14789          --     [, [Mechanism        =>] MECHANISM]);
14790 
14791          --  EXTERNAL_SYMBOL ::=
14792          --    IDENTIFIER
14793          --  | static_string_EXPRESSION
14794 
14795          --  PARAMETER_TYPES ::=
14796          --    null
14797          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14798 
14799          --  TYPE_DESIGNATOR ::=
14800          --    subtype_NAME
14801          --  | subtype_Name ' Access
14802 
14803          --  MECHANISM ::=
14804          --    MECHANISM_NAME
14805          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14806 
14807          --  MECHANISM_ASSOCIATION ::=
14808          --    [formal_parameter_NAME =>] MECHANISM_NAME
14809 
14810          --  MECHANISM_NAME ::=
14811          --    Value
14812          --  | Reference
14813 
14814          when Pragma_Export_Procedure => Export_Procedure : declare
14815             Args  : Args_List (1 .. 4);
14816             Names : constant Name_List (1 .. 4) := (
14817                       Name_Internal,
14818                       Name_External,
14819                       Name_Parameter_Types,
14820                       Name_Mechanism);
14821 
14822             Internal        : Node_Id renames Args (1);
14823             External        : Node_Id renames Args (2);
14824             Parameter_Types : Node_Id renames Args (3);
14825             Mechanism       : Node_Id renames Args (4);
14826 
14827          begin
14828             GNAT_Pragma;
14829             Gather_Associations (Names, Args);
14830             Process_Extended_Import_Export_Subprogram_Pragma (
14831               Arg_Internal        => Internal,
14832               Arg_External        => External,
14833               Arg_Parameter_Types => Parameter_Types,
14834               Arg_Mechanism       => Mechanism);
14835          end Export_Procedure;
14836 
14837          ------------------
14838          -- Export_Value --
14839          ------------------
14840 
14841          --  pragma Export_Value (
14842          --     [Value     =>] static_integer_EXPRESSION,
14843          --     [Link_Name =>] static_string_EXPRESSION);
14844 
14845          when Pragma_Export_Value =>
14846             GNAT_Pragma;
14847             Check_Arg_Order ((Name_Value, Name_Link_Name));
14848             Check_Arg_Count (2);
14849 
14850             Check_Optional_Identifier (Arg1, Name_Value);
14851             Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
14852 
14853             Check_Optional_Identifier (Arg2, Name_Link_Name);
14854             Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
14855 
14856          -----------------------------
14857          -- Export_Valued_Procedure --
14858          -----------------------------
14859 
14860          --  pragma Export_Valued_Procedure (
14861          --        [Internal         =>] LOCAL_NAME
14862          --     [, [External         =>] EXTERNAL_SYMBOL,]
14863          --     [, [Parameter_Types  =>] (PARAMETER_TYPES)]
14864          --     [, [Mechanism        =>] MECHANISM]);
14865 
14866          --  EXTERNAL_SYMBOL ::=
14867          --    IDENTIFIER
14868          --  | static_string_EXPRESSION
14869 
14870          --  PARAMETER_TYPES ::=
14871          --    null
14872          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14873 
14874          --  TYPE_DESIGNATOR ::=
14875          --    subtype_NAME
14876          --  | subtype_Name ' Access
14877 
14878          --  MECHANISM ::=
14879          --    MECHANISM_NAME
14880          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14881 
14882          --  MECHANISM_ASSOCIATION ::=
14883          --    [formal_parameter_NAME =>] MECHANISM_NAME
14884 
14885          --  MECHANISM_NAME ::=
14886          --    Value
14887          --  | Reference
14888 
14889          when Pragma_Export_Valued_Procedure =>
14890          Export_Valued_Procedure : declare
14891             Args  : Args_List (1 .. 4);
14892             Names : constant Name_List (1 .. 4) := (
14893                       Name_Internal,
14894                       Name_External,
14895                       Name_Parameter_Types,
14896                       Name_Mechanism);
14897 
14898             Internal        : Node_Id renames Args (1);
14899             External        : Node_Id renames Args (2);
14900             Parameter_Types : Node_Id renames Args (3);
14901             Mechanism       : Node_Id renames Args (4);
14902 
14903          begin
14904             GNAT_Pragma;
14905             Gather_Associations (Names, Args);
14906             Process_Extended_Import_Export_Subprogram_Pragma (
14907               Arg_Internal        => Internal,
14908               Arg_External        => External,
14909               Arg_Parameter_Types => Parameter_Types,
14910               Arg_Mechanism       => Mechanism);
14911          end Export_Valued_Procedure;
14912 
14913          -------------------
14914          -- Extend_System --
14915          -------------------
14916 
14917          --  pragma Extend_System ([Name =>] Identifier);
14918 
14919          when Pragma_Extend_System => Extend_System : declare
14920          begin
14921             GNAT_Pragma;
14922             Check_Valid_Configuration_Pragma;
14923             Check_Arg_Count (1);
14924             Check_Optional_Identifier (Arg1, Name_Name);
14925             Check_Arg_Is_Identifier (Arg1);
14926 
14927             Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
14928 
14929             if Name_Len > 4
14930               and then Name_Buffer (1 .. 4) = "aux_"
14931             then
14932                if Present (System_Extend_Pragma_Arg) then
14933                   if Chars (Get_Pragma_Arg (Arg1)) =
14934                      Chars (Expression (System_Extend_Pragma_Arg))
14935                   then
14936                      null;
14937                   else
14938                      Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
14939                      Error_Pragma ("pragma% conflicts with that #");
14940                   end if;
14941 
14942                else
14943                   System_Extend_Pragma_Arg := Arg1;
14944 
14945                   if not GNAT_Mode then
14946                      System_Extend_Unit := Arg1;
14947                   end if;
14948                end if;
14949             else
14950                Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
14951             end if;
14952          end Extend_System;
14953 
14954          ------------------------
14955          -- Extensions_Allowed --
14956          ------------------------
14957 
14958          --  pragma Extensions_Allowed (ON | OFF);
14959 
14960          when Pragma_Extensions_Allowed =>
14961             GNAT_Pragma;
14962             Check_Arg_Count (1);
14963             Check_No_Identifiers;
14964             Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
14965 
14966             if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
14967                Extensions_Allowed := True;
14968                Ada_Version := Ada_Version_Type'Last;
14969 
14970             else
14971                Extensions_Allowed := False;
14972                Ada_Version := Ada_Version_Explicit;
14973                Ada_Version_Pragma := Empty;
14974             end if;
14975 
14976          ------------------------
14977          -- Extensions_Visible --
14978          ------------------------
14979 
14980          --  pragma Extensions_Visible [ (boolean_EXPRESSION) ];
14981 
14982          --  Characteristics:
14983 
14984          --    * Analysis - The annotation is fully analyzed immediately upon
14985          --    elaboration as its expression must be static.
14986 
14987          --    * Expansion - None.
14988 
14989          --    * Template - The annotation utilizes the generic template of the
14990          --    related subprogram [body] when it is:
14991 
14992          --       aspect on subprogram declaration
14993          --       aspect on stand alone subprogram body
14994          --       pragma on stand alone subprogram body
14995 
14996          --    The annotation must prepare its own template when it is:
14997 
14998          --       pragma on subprogram declaration
14999 
15000          --    * Globals - Capture of global references must occur after full
15001          --    analysis.
15002 
15003          --    * Instance - The annotation is instantiated automatically when
15004          --    the related generic subprogram [body] is instantiated except for
15005          --    the "pragma on subprogram declaration" case. In that scenario
15006          --    the annotation must instantiate itself.
15007 
15008          when Pragma_Extensions_Visible => Extensions_Visible : declare
15009             Formal        : Entity_Id;
15010             Has_OK_Formal : Boolean := False;
15011             Spec_Id       : Entity_Id;
15012             Subp_Decl     : Node_Id;
15013 
15014          begin
15015             GNAT_Pragma;
15016             Check_No_Identifiers;
15017             Check_At_Most_N_Arguments (1);
15018 
15019             Subp_Decl :=
15020               Find_Related_Declaration_Or_Body (N, Do_Checks => True);
15021 
15022             --  Abstract subprogram declaration
15023 
15024             if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
15025                null;
15026 
15027             --  Generic subprogram declaration
15028 
15029             elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
15030                null;
15031 
15032             --  Body acts as spec
15033 
15034             elsif Nkind (Subp_Decl) = N_Subprogram_Body
15035               and then No (Corresponding_Spec (Subp_Decl))
15036             then
15037                null;
15038 
15039             --  Body stub acts as spec
15040 
15041             elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
15042               and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
15043             then
15044                null;
15045 
15046             --  Subprogram declaration
15047 
15048             elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
15049                null;
15050 
15051             --  Otherwise the pragma is associated with an illegal construct
15052 
15053             else
15054                Error_Pragma ("pragma % must apply to a subprogram");
15055                return;
15056             end if;
15057 
15058             --  Chain the pragma on the contract for completeness
15059 
15060             Add_Contract_Item (N, Defining_Entity (Subp_Decl));
15061 
15062             --  The legality checks of pragma Extension_Visible are affected
15063             --  by the SPARK mode in effect. Analyze all pragmas in specific
15064             --  order.
15065 
15066             Analyze_If_Present (Pragma_SPARK_Mode);
15067 
15068             --  Mark the pragma as Ghost if the related subprogram is also
15069             --  Ghost. This also ensures that any expansion performed further
15070             --  below will produce Ghost nodes.
15071 
15072             Spec_Id := Unique_Defining_Entity (Subp_Decl);
15073             Mark_Pragma_As_Ghost (N, Spec_Id);
15074 
15075             --  Examine the formals of the related subprogram
15076 
15077             Formal := First_Formal (Spec_Id);
15078             while Present (Formal) loop
15079 
15080                --  At least one of the formals is of a specific tagged type,
15081                --  the pragma is legal.
15082 
15083                if Is_Specific_Tagged_Type (Etype (Formal)) then
15084                   Has_OK_Formal := True;
15085                   exit;
15086 
15087                --  A generic subprogram with at least one formal of a private
15088                --  type ensures the legality of the pragma because the actual
15089                --  may be specifically tagged. Note that this is verified by
15090                --  the check above at instantiation time.
15091 
15092                elsif Is_Private_Type (Etype (Formal))
15093                  and then Is_Generic_Type (Etype (Formal))
15094                then
15095                   Has_OK_Formal := True;
15096                   exit;
15097                end if;
15098 
15099                Next_Formal (Formal);
15100             end loop;
15101 
15102             if not Has_OK_Formal then
15103                Error_Msg_Name_1 := Pname;
15104                Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N);
15105                Error_Msg_NE
15106                  ("\subprogram & lacks parameter of specific tagged or "
15107                   & "generic private type", N, Spec_Id);
15108 
15109                return;
15110             end if;
15111 
15112             --  Analyze the Boolean expression (if any)
15113 
15114             if Present (Arg1) then
15115                Check_Static_Boolean_Expression
15116                  (Expression (Get_Argument (N, Spec_Id)));
15117             end if;
15118          end Extensions_Visible;
15119 
15120          --------------
15121          -- External --
15122          --------------
15123 
15124          --  pragma External (
15125          --    [   Convention    =>] convention_IDENTIFIER,
15126          --    [   Entity        =>] LOCAL_NAME
15127          --    [, [External_Name =>] static_string_EXPRESSION ]
15128          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
15129 
15130          when Pragma_External => External : declare
15131             C : Convention_Id;
15132             E : Entity_Id;
15133             pragma Warnings (Off, C);
15134 
15135          begin
15136             GNAT_Pragma;
15137             Check_Arg_Order
15138               ((Name_Convention,
15139                 Name_Entity,
15140                 Name_External_Name,
15141                 Name_Link_Name));
15142             Check_At_Least_N_Arguments (2);
15143             Check_At_Most_N_Arguments  (4);
15144             Process_Convention (C, E);
15145 
15146             --  A pragma that applies to a Ghost entity becomes Ghost for the
15147             --  purposes of legality checks and removal of ignored Ghost code.
15148 
15149             Mark_Pragma_As_Ghost (N, E);
15150 
15151             Note_Possible_Modification
15152               (Get_Pragma_Arg (Arg2), Sure => False);
15153             Process_Interface_Name (E, Arg3, Arg4);
15154             Set_Exported (E, Arg2);
15155          end External;
15156 
15157          --------------------------
15158          -- External_Name_Casing --
15159          --------------------------
15160 
15161          --  pragma External_Name_Casing (
15162          --    UPPERCASE | LOWERCASE
15163          --    [, AS_IS | UPPERCASE | LOWERCASE]);
15164 
15165          when Pragma_External_Name_Casing => External_Name_Casing : declare
15166          begin
15167             GNAT_Pragma;
15168             Check_No_Identifiers;
15169 
15170             if Arg_Count = 2 then
15171                Check_Arg_Is_One_Of
15172                  (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
15173 
15174                case Chars (Get_Pragma_Arg (Arg2)) is
15175                   when Name_As_Is     =>
15176                      Opt.External_Name_Exp_Casing := As_Is;
15177 
15178                   when Name_Uppercase =>
15179                      Opt.External_Name_Exp_Casing := Uppercase;
15180 
15181                   when Name_Lowercase =>
15182                      Opt.External_Name_Exp_Casing := Lowercase;
15183 
15184                   when others =>
15185                      null;
15186                end case;
15187 
15188             else
15189                Check_Arg_Count (1);
15190             end if;
15191 
15192             Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
15193 
15194             case Chars (Get_Pragma_Arg (Arg1)) is
15195                when Name_Uppercase =>
15196                   Opt.External_Name_Imp_Casing := Uppercase;
15197 
15198                when Name_Lowercase =>
15199                   Opt.External_Name_Imp_Casing := Lowercase;
15200 
15201                when others =>
15202                   null;
15203             end case;
15204          end External_Name_Casing;
15205 
15206          ---------------
15207          -- Fast_Math --
15208          ---------------
15209 
15210          --  pragma Fast_Math;
15211 
15212          when Pragma_Fast_Math =>
15213             GNAT_Pragma;
15214             Check_No_Identifiers;
15215             Check_Valid_Configuration_Pragma;
15216             Fast_Math := True;
15217 
15218          --------------------------
15219          -- Favor_Top_Level --
15220          --------------------------
15221 
15222          --  pragma Favor_Top_Level (type_NAME);
15223 
15224          when Pragma_Favor_Top_Level => Favor_Top_Level : declare
15225             Typ : Entity_Id;
15226 
15227          begin
15228             GNAT_Pragma;
15229             Check_No_Identifiers;
15230             Check_Arg_Count (1);
15231             Check_Arg_Is_Local_Name (Arg1);
15232             Typ := Entity (Get_Pragma_Arg (Arg1));
15233 
15234             --  A pragma that applies to a Ghost entity becomes Ghost for the
15235             --  purposes of legality checks and removal of ignored Ghost code.
15236 
15237             Mark_Pragma_As_Ghost (N, Typ);
15238 
15239             --  If it's an access-to-subprogram type (in particular, not a
15240             --  subtype), set the flag on that type.
15241 
15242             if Is_Access_Subprogram_Type (Typ) then
15243                Set_Can_Use_Internal_Rep (Typ, False);
15244 
15245             --  Otherwise it's an error (name denotes the wrong sort of entity)
15246 
15247             else
15248                Error_Pragma_Arg
15249                  ("access-to-subprogram type expected",
15250                   Get_Pragma_Arg (Arg1));
15251             end if;
15252          end Favor_Top_Level;
15253 
15254          ---------------------------
15255          -- Finalize_Storage_Only --
15256          ---------------------------
15257 
15258          --  pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
15259 
15260          when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
15261             Assoc   : constant Node_Id := Arg1;
15262             Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
15263             Typ     : Entity_Id;
15264 
15265          begin
15266             GNAT_Pragma;
15267             Check_No_Identifiers;
15268             Check_Arg_Count (1);
15269             Check_Arg_Is_Local_Name (Arg1);
15270 
15271             Find_Type (Type_Id);
15272             Typ := Entity (Type_Id);
15273 
15274             if Typ = Any_Type
15275               or else Rep_Item_Too_Early (Typ, N)
15276             then
15277                return;
15278             else
15279                Typ := Underlying_Type (Typ);
15280             end if;
15281 
15282             if not Is_Controlled (Typ) then
15283                Error_Pragma ("pragma% must specify controlled type");
15284             end if;
15285 
15286             Check_First_Subtype (Arg1);
15287 
15288             if Finalize_Storage_Only (Typ) then
15289                Error_Pragma ("duplicate pragma%, only one allowed");
15290 
15291             elsif not Rep_Item_Too_Late (Typ, N) then
15292                Set_Finalize_Storage_Only (Base_Type (Typ), True);
15293             end if;
15294          end Finalize_Storage;
15295 
15296          -----------
15297          -- Ghost --
15298          -----------
15299 
15300          --  pragma Ghost [ (boolean_EXPRESSION) ];
15301 
15302          when Pragma_Ghost => Ghost : declare
15303             Context   : Node_Id;
15304             Expr      : Node_Id;
15305             Id        : Entity_Id;
15306             Orig_Stmt : Node_Id;
15307             Prev_Id   : Entity_Id;
15308             Stmt      : Node_Id;
15309 
15310          begin
15311             GNAT_Pragma;
15312             Check_No_Identifiers;
15313             Check_At_Most_N_Arguments (1);
15314 
15315             Id   := Empty;
15316             Stmt := Prev (N);
15317             while Present (Stmt) loop
15318 
15319                --  Skip prior pragmas, but check for duplicates
15320 
15321                if Nkind (Stmt) = N_Pragma then
15322                   if Pragma_Name (Stmt) = Pname then
15323                      Error_Msg_Name_1 := Pname;
15324                      Error_Msg_Sloc   := Sloc (Stmt);
15325                      Error_Msg_N ("pragma % duplicates pragma declared#", N);
15326                   end if;
15327 
15328                --  Task unit declared without a definition cannot be subject to
15329                --  pragma Ghost (SPARK RM 6.9(19)).
15330 
15331                elsif Nkind_In (Stmt, N_Single_Task_Declaration,
15332                                      N_Task_Type_Declaration)
15333                then
15334                   Error_Pragma ("pragma % cannot apply to a task type");
15335                   return;
15336 
15337                --  Skip internally generated code
15338 
15339                elsif not Comes_From_Source (Stmt) then
15340                   Orig_Stmt := Original_Node (Stmt);
15341 
15342                   --  When pragma Ghost applies to an untagged derivation, the
15343                   --  derivation is transformed into a [sub]type declaration.
15344 
15345                   if Nkind_In (Stmt, N_Full_Type_Declaration,
15346                                      N_Subtype_Declaration)
15347                     and then Comes_From_Source (Orig_Stmt)
15348                     and then Nkind (Orig_Stmt) = N_Full_Type_Declaration
15349                     and then Nkind (Type_Definition (Orig_Stmt)) =
15350                                N_Derived_Type_Definition
15351                   then
15352                      Id := Defining_Entity (Stmt);
15353                      exit;
15354 
15355                   --  When pragma Ghost applies to an object declaration which
15356                   --  is initialized by means of a function call that returns
15357                   --  on the secondary stack, the object declaration becomes a
15358                   --  renaming.
15359 
15360                   elsif Nkind (Stmt) = N_Object_Renaming_Declaration
15361                     and then Comes_From_Source (Orig_Stmt)
15362                     and then Nkind (Orig_Stmt) = N_Object_Declaration
15363                   then
15364                      Id := Defining_Entity (Stmt);
15365                      exit;
15366 
15367                   --  When pragma Ghost applies to an expression function, the
15368                   --  expression function is transformed into a subprogram.
15369 
15370                   elsif Nkind (Stmt) = N_Subprogram_Declaration
15371                     and then Comes_From_Source (Orig_Stmt)
15372                     and then Nkind (Orig_Stmt) = N_Expression_Function
15373                   then
15374                      Id := Defining_Entity (Stmt);
15375                      exit;
15376                   end if;
15377 
15378                --  The pragma applies to a legal construct, stop the traversal
15379 
15380                elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration,
15381                                      N_Full_Type_Declaration,
15382                                      N_Generic_Subprogram_Declaration,
15383                                      N_Object_Declaration,
15384                                      N_Private_Extension_Declaration,
15385                                      N_Private_Type_Declaration,
15386                                      N_Subprogram_Declaration,
15387                                      N_Subtype_Declaration)
15388                then
15389                   Id := Defining_Entity (Stmt);
15390                   exit;
15391 
15392                --  The pragma does not apply to a legal construct, issue an
15393                --  error and stop the analysis.
15394 
15395                else
15396                   Error_Pragma
15397                     ("pragma % must apply to an object, package, subprogram "
15398                      & "or type");
15399                   return;
15400                end if;
15401 
15402                Stmt := Prev (Stmt);
15403             end loop;
15404 
15405             Context := Parent (N);
15406 
15407             --  Handle compilation units
15408 
15409             if Nkind (Context) = N_Compilation_Unit_Aux then
15410                Context := Unit (Parent (Context));
15411             end if;
15412 
15413             --  Protected and task types cannot be subject to pragma Ghost
15414             --  (SPARK RM 6.9(19)).
15415 
15416             if Nkind_In (Context, N_Protected_Body, N_Protected_Definition)
15417             then
15418                Error_Pragma ("pragma % cannot apply to a protected type");
15419                return;
15420 
15421             elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then
15422                Error_Pragma ("pragma % cannot apply to a task type");
15423                return;
15424             end if;
15425 
15426             if No (Id) then
15427 
15428                --  When pragma Ghost is associated with a [generic] package, it
15429                --  appears in the visible declarations.
15430 
15431                if Nkind (Context) = N_Package_Specification
15432                  and then Present (Visible_Declarations (Context))
15433                  and then List_Containing (N) = Visible_Declarations (Context)
15434                then
15435                   Id := Defining_Entity (Context);
15436 
15437                --  Pragma Ghost applies to a stand alone subprogram body
15438 
15439                elsif Nkind (Context) = N_Subprogram_Body
15440                  and then No (Corresponding_Spec (Context))
15441                then
15442                   Id := Defining_Entity (Context);
15443 
15444                --  Pragma Ghost applies to a subprogram declaration that acts
15445                --  as a compilation unit.
15446 
15447                elsif Nkind (Context) = N_Subprogram_Declaration then
15448                   Id := Defining_Entity (Context);
15449                end if;
15450             end if;
15451 
15452             if No (Id) then
15453                Error_Pragma
15454                  ("pragma % must apply to an object, package, subprogram or "
15455                   & "type");
15456                return;
15457             end if;
15458 
15459             --  Handle completions of types and constants that are subject to
15460             --  pragma Ghost.
15461 
15462             if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then
15463                Prev_Id := Incomplete_Or_Partial_View (Id);
15464 
15465                if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then
15466                   Error_Msg_Name_1 := Pname;
15467 
15468                   --  The full declaration of a deferred constant cannot be
15469                   --  subject to pragma Ghost unless the deferred declaration
15470                   --  is also Ghost (SPARK RM 6.9(9)).
15471 
15472                   if Ekind (Prev_Id) = E_Constant then
15473                      Error_Msg_Name_1 := Pname;
15474                      Error_Msg_NE (Fix_Error
15475                        ("pragma % must apply to declaration of deferred "
15476                         & "constant &"), N, Id);
15477                      return;
15478 
15479                   --  Pragma Ghost may appear on the full view of an incomplete
15480                   --  type because the incomplete declaration lacks aspects and
15481                   --  cannot be subject to pragma Ghost.
15482 
15483                   elsif Ekind (Prev_Id) = E_Incomplete_Type then
15484                      null;
15485 
15486                   --  The full declaration of a type cannot be subject to
15487                   --  pragma Ghost unless the partial view is also Ghost
15488                   --  (SPARK RM 6.9(9)).
15489 
15490                   else
15491                      Error_Msg_NE (Fix_Error
15492                        ("pragma % must apply to partial view of type &"),
15493                         N, Id);
15494                      return;
15495                   end if;
15496                end if;
15497 
15498             --  A synchronized object cannot be subject to pragma Ghost
15499             --  (SPARK RM 6.9(19)).
15500 
15501             elsif Ekind (Id) = E_Variable then
15502                if Is_Protected_Type (Etype (Id)) then
15503                   Error_Pragma ("pragma % cannot apply to a protected object");
15504                   return;
15505 
15506                elsif Is_Task_Type (Etype (Id)) then
15507                   Error_Pragma ("pragma % cannot apply to a task object");
15508                   return;
15509                end if;
15510             end if;
15511 
15512             --  Analyze the Boolean expression (if any)
15513 
15514             if Present (Arg1) then
15515                Expr := Get_Pragma_Arg (Arg1);
15516 
15517                Analyze_And_Resolve (Expr, Standard_Boolean);
15518 
15519                if Is_OK_Static_Expression (Expr) then
15520 
15521                   --  "Ghostness" cannot be turned off once enabled within a
15522                   --  region (SPARK RM 6.9(6)).
15523 
15524                   if Is_False (Expr_Value (Expr))
15525                     and then Ghost_Mode > None
15526                   then
15527                      Error_Pragma
15528                        ("pragma % with value False cannot appear in enabled "
15529                         & "ghost region");
15530                      return;
15531                   end if;
15532 
15533                --  Otherwie the expression is not static
15534 
15535                else
15536                   Error_Pragma_Arg
15537                     ("expression of pragma % must be static", Expr);
15538                   return;
15539                end if;
15540             end if;
15541 
15542             Set_Is_Ghost_Entity (Id);
15543          end Ghost;
15544 
15545          ------------
15546          -- Global --
15547          ------------
15548 
15549          --  pragma Global (GLOBAL_SPECIFICATION);
15550 
15551          --  GLOBAL_SPECIFICATION ::=
15552          --     null
15553          --  | (GLOBAL_LIST)
15554          --  | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15555 
15556          --  MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15557 
15558          --  MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15559          --  GLOBAL_LIST   ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15560          --  GLOBAL_ITEM   ::= NAME
15561 
15562          --  Characteristics:
15563 
15564          --    * Analysis - The annotation undergoes initial checks to verify
15565          --    the legal placement and context. Secondary checks fully analyze
15566          --    the dependency clauses in:
15567 
15568          --       Analyze_Global_In_Decl_Part
15569 
15570          --    * Expansion - None.
15571 
15572          --    * Template - The annotation utilizes the generic template of the
15573          --    related subprogram [body] when it is:
15574 
15575          --       aspect on subprogram declaration
15576          --       aspect on stand alone subprogram body
15577          --       pragma on stand alone subprogram body
15578 
15579          --    The annotation must prepare its own template when it is:
15580 
15581          --       pragma on subprogram declaration
15582 
15583          --    * Globals - Capture of global references must occur after full
15584          --    analysis.
15585 
15586          --    * Instance - The annotation is instantiated automatically when
15587          --    the related generic subprogram [body] is instantiated except for
15588          --    the "pragma on subprogram declaration" case. In that scenario
15589          --    the annotation must instantiate itself.
15590 
15591          when Pragma_Global => Global : declare
15592             Legal     : Boolean;
15593             Spec_Id   : Entity_Id;
15594             Subp_Decl : Node_Id;
15595 
15596          begin
15597             Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal);
15598 
15599             if Legal then
15600 
15601                --  Chain the pragma on the contract for further processing by
15602                --  Analyze_Global_In_Decl_Part.
15603 
15604                Add_Contract_Item (N, Spec_Id);
15605 
15606                --  Fully analyze the pragma when it appears inside an entry
15607                --  or subprogram body because it cannot benefit from forward
15608                --  references.
15609 
15610                if Nkind_In (Subp_Decl, N_Entry_Body,
15611                                        N_Subprogram_Body,
15612                                        N_Subprogram_Body_Stub)
15613                then
15614                   --  The legality checks of pragmas Depends and Global are
15615                   --  affected by the SPARK mode in effect and the volatility
15616                   --  of the context. In addition these two pragmas are subject
15617                   --  to an inherent order:
15618 
15619                   --    1) Global
15620                   --    2) Depends
15621 
15622                   --  Analyze all these pragmas in the order outlined above
15623 
15624                   Analyze_If_Present (Pragma_SPARK_Mode);
15625                   Analyze_If_Present (Pragma_Volatile_Function);
15626                   Analyze_Global_In_Decl_Part (N);
15627                   Analyze_If_Present (Pragma_Depends);
15628                end if;
15629             end if;
15630          end Global;
15631 
15632          -----------
15633          -- Ident --
15634          -----------
15635 
15636          --  pragma Ident (static_string_EXPRESSION)
15637 
15638          --  Note: pragma Comment shares this processing. Pragma Ident is
15639          --  identical in effect to pragma Commment.
15640 
15641          when Pragma_Ident | Pragma_Comment => Ident : declare
15642             Str : Node_Id;
15643 
15644          begin
15645             GNAT_Pragma;
15646             Check_Arg_Count (1);
15647             Check_No_Identifiers;
15648             Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
15649             Store_Note (N);
15650 
15651             Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
15652 
15653             declare
15654                CS : Node_Id;
15655                GP : Node_Id;
15656 
15657             begin
15658                GP := Parent (Parent (N));
15659 
15660                if Nkind_In (GP, N_Package_Declaration,
15661                                 N_Generic_Package_Declaration)
15662                then
15663                   GP := Parent (GP);
15664                end if;
15665 
15666                --  If we have a compilation unit, then record the ident value,
15667                --  checking for improper duplication.
15668 
15669                if Nkind (GP) = N_Compilation_Unit then
15670                   CS := Ident_String (Current_Sem_Unit);
15671 
15672                   if Present (CS) then
15673 
15674                      --  If we have multiple instances, concatenate them, but
15675                      --  not in ASIS, where we want the original tree.
15676 
15677                      if not ASIS_Mode then
15678                         Start_String (Strval (CS));
15679                         Store_String_Char (' ');
15680                         Store_String_Chars (Strval (Str));
15681                         Set_Strval (CS, End_String);
15682                      end if;
15683 
15684                   else
15685                      Set_Ident_String (Current_Sem_Unit, Str);
15686                   end if;
15687 
15688                --  For subunits, we just ignore the Ident, since in GNAT these
15689                --  are not separate object files, and hence not separate units
15690                --  in the unit table.
15691 
15692                elsif Nkind (GP) = N_Subunit then
15693                   null;
15694                end if;
15695             end;
15696          end Ident;
15697 
15698          -------------------
15699          -- Ignore_Pragma --
15700          -------------------
15701 
15702          --  pragma Ignore_Pragma (pragma_IDENTIFIER);
15703 
15704          --  Entirely handled in the parser, nothing to do here
15705 
15706          when Pragma_Ignore_Pragma =>
15707             null;
15708 
15709          ----------------------------
15710          -- Implementation_Defined --
15711          ----------------------------
15712 
15713          --  pragma Implementation_Defined (LOCAL_NAME);
15714 
15715          --  Marks previously declared entity as implementation defined. For
15716          --  an overloaded entity, applies to the most recent homonym.
15717 
15718          --  pragma Implementation_Defined;
15719 
15720          --  The form with no arguments appears anywhere within a scope, most
15721          --  typically a package spec, and indicates that all entities that are
15722          --  defined within the package spec are Implementation_Defined.
15723 
15724          when Pragma_Implementation_Defined => Implementation_Defined : declare
15725             Ent : Entity_Id;
15726 
15727          begin
15728             GNAT_Pragma;
15729             Check_No_Identifiers;
15730 
15731             --  Form with no arguments
15732 
15733             if Arg_Count = 0 then
15734                Set_Is_Implementation_Defined (Current_Scope);
15735 
15736             --  Form with one argument
15737 
15738             else
15739                Check_Arg_Count (1);
15740                Check_Arg_Is_Local_Name (Arg1);
15741                Ent := Entity (Get_Pragma_Arg (Arg1));
15742                Set_Is_Implementation_Defined (Ent);
15743             end if;
15744          end Implementation_Defined;
15745 
15746          -----------------
15747          -- Implemented --
15748          -----------------
15749 
15750          --  pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15751 
15752          --  IMPLEMENTATION_KIND ::=
15753          --    By_Entry | By_Protected_Procedure | By_Any | Optional
15754 
15755          --  "By_Any" and "Optional" are treated as synonyms in order to
15756          --  support Ada 2012 aspect Synchronization.
15757 
15758          when Pragma_Implemented => Implemented : declare
15759             Proc_Id : Entity_Id;
15760             Typ     : Entity_Id;
15761 
15762          begin
15763             Ada_2012_Pragma;
15764             Check_Arg_Count (2);
15765             Check_No_Identifiers;
15766             Check_Arg_Is_Identifier (Arg1);
15767             Check_Arg_Is_Local_Name (Arg1);
15768             Check_Arg_Is_One_Of (Arg2,
15769               Name_By_Any,
15770               Name_By_Entry,
15771               Name_By_Protected_Procedure,
15772               Name_Optional);
15773 
15774             --  Extract the name of the local procedure
15775 
15776             Proc_Id := Entity (Get_Pragma_Arg (Arg1));
15777 
15778             --  Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15779             --  primitive procedure of a synchronized tagged type.
15780 
15781             if Ekind (Proc_Id) = E_Procedure
15782               and then Is_Primitive (Proc_Id)
15783               and then Present (First_Formal (Proc_Id))
15784             then
15785                Typ := Etype (First_Formal (Proc_Id));
15786 
15787                if Is_Tagged_Type (Typ)
15788                  and then
15789 
15790                   --  Check for a protected, a synchronized or a task interface
15791 
15792                    ((Is_Interface (Typ)
15793                        and then Is_Synchronized_Interface (Typ))
15794 
15795                   --  Check for a protected type or a task type that implements
15796                   --  an interface.
15797 
15798                    or else
15799                     (Is_Concurrent_Record_Type (Typ)
15800                        and then Present (Interfaces (Typ)))
15801 
15802                   --  In analysis-only mode, examine original protected type
15803 
15804                   or else
15805                     (Nkind (Parent (Typ)) = N_Protected_Type_Declaration
15806                       and then Present (Interface_List (Parent (Typ))))
15807 
15808                   --  Check for a private record extension with keyword
15809                   --  "synchronized".
15810 
15811                    or else
15812                     (Ekind_In (Typ, E_Record_Type_With_Private,
15813                                     E_Record_Subtype_With_Private)
15814                        and then Synchronized_Present (Parent (Typ))))
15815                then
15816                   null;
15817                else
15818                   Error_Pragma_Arg
15819                     ("controlling formal must be of synchronized tagged type",
15820                      Arg1);
15821                   return;
15822                end if;
15823 
15824             --  Procedures declared inside a protected type must be accepted
15825 
15826             elsif Ekind (Proc_Id) = E_Procedure
15827               and then Is_Protected_Type (Scope (Proc_Id))
15828             then
15829                null;
15830 
15831             --  The first argument is not a primitive procedure
15832 
15833             else
15834                Error_Pragma_Arg
15835                  ("pragma % must be applied to a primitive procedure", Arg1);
15836                return;
15837             end if;
15838 
15839             --  Ada 2012 (AI05-0030): Cannot apply the implementation_kind
15840             --  By_Protected_Procedure to the primitive procedure of a task
15841             --  interface.
15842 
15843             if Chars (Arg2) = Name_By_Protected_Procedure
15844               and then Is_Interface (Typ)
15845               and then Is_Task_Interface (Typ)
15846             then
15847                Error_Pragma_Arg
15848                  ("implementation kind By_Protected_Procedure cannot be "
15849                   & "applied to a task interface primitive", Arg2);
15850                return;
15851             end if;
15852 
15853             Record_Rep_Item (Proc_Id, N);
15854          end Implemented;
15855 
15856          ----------------------
15857          -- Implicit_Packing --
15858          ----------------------
15859 
15860          --  pragma Implicit_Packing;
15861 
15862          when Pragma_Implicit_Packing =>
15863             GNAT_Pragma;
15864             Check_Arg_Count (0);
15865             Implicit_Packing := True;
15866 
15867          ------------
15868          -- Import --
15869          ------------
15870 
15871          --  pragma Import (
15872          --       [Convention    =>] convention_IDENTIFIER,
15873          --       [Entity        =>] LOCAL_NAME
15874          --    [, [External_Name =>] static_string_EXPRESSION ]
15875          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
15876 
15877          when Pragma_Import =>
15878             Check_Ada_83_Warning;
15879             Check_Arg_Order
15880               ((Name_Convention,
15881                 Name_Entity,
15882                 Name_External_Name,
15883                 Name_Link_Name));
15884 
15885             Check_At_Least_N_Arguments (2);
15886             Check_At_Most_N_Arguments  (4);
15887             Process_Import_Or_Interface;
15888 
15889          ---------------------
15890          -- Import_Function --
15891          ---------------------
15892 
15893          --  pragma Import_Function (
15894          --        [Internal                 =>] LOCAL_NAME,
15895          --     [, [External                 =>] EXTERNAL_SYMBOL]
15896          --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
15897          --     [, [Result_Type              =>] SUBTYPE_MARK]
15898          --     [, [Mechanism                =>] MECHANISM]
15899          --     [, [Result_Mechanism         =>] MECHANISM_NAME]);
15900 
15901          --  EXTERNAL_SYMBOL ::=
15902          --    IDENTIFIER
15903          --  | static_string_EXPRESSION
15904 
15905          --  PARAMETER_TYPES ::=
15906          --    null
15907          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15908 
15909          --  TYPE_DESIGNATOR ::=
15910          --    subtype_NAME
15911          --  | subtype_Name ' Access
15912 
15913          --  MECHANISM ::=
15914          --    MECHANISM_NAME
15915          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15916 
15917          --  MECHANISM_ASSOCIATION ::=
15918          --    [formal_parameter_NAME =>] MECHANISM_NAME
15919 
15920          --  MECHANISM_NAME ::=
15921          --    Value
15922          --  | Reference
15923 
15924          when Pragma_Import_Function => Import_Function : declare
15925             Args  : Args_List (1 .. 6);
15926             Names : constant Name_List (1 .. 6) := (
15927                       Name_Internal,
15928                       Name_External,
15929                       Name_Parameter_Types,
15930                       Name_Result_Type,
15931                       Name_Mechanism,
15932                       Name_Result_Mechanism);
15933 
15934             Internal                 : Node_Id renames Args (1);
15935             External                 : Node_Id renames Args (2);
15936             Parameter_Types          : Node_Id renames Args (3);
15937             Result_Type              : Node_Id renames Args (4);
15938             Mechanism                : Node_Id renames Args (5);
15939             Result_Mechanism         : Node_Id renames Args (6);
15940 
15941          begin
15942             GNAT_Pragma;
15943             Gather_Associations (Names, Args);
15944             Process_Extended_Import_Export_Subprogram_Pragma (
15945               Arg_Internal                 => Internal,
15946               Arg_External                 => External,
15947               Arg_Parameter_Types          => Parameter_Types,
15948               Arg_Result_Type              => Result_Type,
15949               Arg_Mechanism                => Mechanism,
15950               Arg_Result_Mechanism         => Result_Mechanism);
15951          end Import_Function;
15952 
15953          -------------------
15954          -- Import_Object --
15955          -------------------
15956 
15957          --  pragma Import_Object (
15958          --        [Internal =>] LOCAL_NAME
15959          --     [, [External =>] EXTERNAL_SYMBOL]
15960          --     [, [Size     =>] EXTERNAL_SYMBOL]);
15961 
15962          --  EXTERNAL_SYMBOL ::=
15963          --    IDENTIFIER
15964          --  | static_string_EXPRESSION
15965 
15966          when Pragma_Import_Object => Import_Object : declare
15967             Args  : Args_List (1 .. 3);
15968             Names : constant Name_List (1 .. 3) := (
15969                       Name_Internal,
15970                       Name_External,
15971                       Name_Size);
15972 
15973             Internal : Node_Id renames Args (1);
15974             External : Node_Id renames Args (2);
15975             Size     : Node_Id renames Args (3);
15976 
15977          begin
15978             GNAT_Pragma;
15979             Gather_Associations (Names, Args);
15980             Process_Extended_Import_Export_Object_Pragma (
15981               Arg_Internal => Internal,
15982               Arg_External => External,
15983               Arg_Size     => Size);
15984          end Import_Object;
15985 
15986          ----------------------
15987          -- Import_Procedure --
15988          ----------------------
15989 
15990          --  pragma Import_Procedure (
15991          --        [Internal                 =>] LOCAL_NAME
15992          --     [, [External                 =>] EXTERNAL_SYMBOL]
15993          --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
15994          --     [, [Mechanism                =>] MECHANISM]);
15995 
15996          --  EXTERNAL_SYMBOL ::=
15997          --    IDENTIFIER
15998          --  | static_string_EXPRESSION
15999 
16000          --  PARAMETER_TYPES ::=
16001          --    null
16002          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16003 
16004          --  TYPE_DESIGNATOR ::=
16005          --    subtype_NAME
16006          --  | subtype_Name ' Access
16007 
16008          --  MECHANISM ::=
16009          --    MECHANISM_NAME
16010          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16011 
16012          --  MECHANISM_ASSOCIATION ::=
16013          --    [formal_parameter_NAME =>] MECHANISM_NAME
16014 
16015          --  MECHANISM_NAME ::=
16016          --    Value
16017          --  | Reference
16018 
16019          when Pragma_Import_Procedure => Import_Procedure : declare
16020             Args  : Args_List (1 .. 4);
16021             Names : constant Name_List (1 .. 4) := (
16022                       Name_Internal,
16023                       Name_External,
16024                       Name_Parameter_Types,
16025                       Name_Mechanism);
16026 
16027             Internal                 : Node_Id renames Args (1);
16028             External                 : Node_Id renames Args (2);
16029             Parameter_Types          : Node_Id renames Args (3);
16030             Mechanism                : Node_Id renames Args (4);
16031 
16032          begin
16033             GNAT_Pragma;
16034             Gather_Associations (Names, Args);
16035             Process_Extended_Import_Export_Subprogram_Pragma (
16036               Arg_Internal                 => Internal,
16037               Arg_External                 => External,
16038               Arg_Parameter_Types          => Parameter_Types,
16039               Arg_Mechanism                => Mechanism);
16040          end Import_Procedure;
16041 
16042          -----------------------------
16043          -- Import_Valued_Procedure --
16044          -----------------------------
16045 
16046          --  pragma Import_Valued_Procedure (
16047          --        [Internal                 =>] LOCAL_NAME
16048          --     [, [External                 =>] EXTERNAL_SYMBOL]
16049          --     [, [Parameter_Types          =>] (PARAMETER_TYPES)]
16050          --     [, [Mechanism                =>] MECHANISM]);
16051 
16052          --  EXTERNAL_SYMBOL ::=
16053          --    IDENTIFIER
16054          --  | static_string_EXPRESSION
16055 
16056          --  PARAMETER_TYPES ::=
16057          --    null
16058          --  | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16059 
16060          --  TYPE_DESIGNATOR ::=
16061          --    subtype_NAME
16062          --  | subtype_Name ' Access
16063 
16064          --  MECHANISM ::=
16065          --    MECHANISM_NAME
16066          --  | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16067 
16068          --  MECHANISM_ASSOCIATION ::=
16069          --    [formal_parameter_NAME =>] MECHANISM_NAME
16070 
16071          --  MECHANISM_NAME ::=
16072          --    Value
16073          --  | Reference
16074 
16075          when Pragma_Import_Valued_Procedure =>
16076          Import_Valued_Procedure : declare
16077             Args  : Args_List (1 .. 4);
16078             Names : constant Name_List (1 .. 4) := (
16079                       Name_Internal,
16080                       Name_External,
16081                       Name_Parameter_Types,
16082                       Name_Mechanism);
16083 
16084             Internal                 : Node_Id renames Args (1);
16085             External                 : Node_Id renames Args (2);
16086             Parameter_Types          : Node_Id renames Args (3);
16087             Mechanism                : Node_Id renames Args (4);
16088 
16089          begin
16090             GNAT_Pragma;
16091             Gather_Associations (Names, Args);
16092             Process_Extended_Import_Export_Subprogram_Pragma (
16093               Arg_Internal                 => Internal,
16094               Arg_External                 => External,
16095               Arg_Parameter_Types          => Parameter_Types,
16096               Arg_Mechanism                => Mechanism);
16097          end Import_Valued_Procedure;
16098 
16099          -----------------
16100          -- Independent --
16101          -----------------
16102 
16103          --  pragma Independent (LOCAL_NAME);
16104 
16105          when Pragma_Independent =>
16106             Process_Atomic_Independent_Shared_Volatile;
16107 
16108          ----------------------------
16109          -- Independent_Components --
16110          ----------------------------
16111 
16112          --  pragma Independent_Components (array_or_record_LOCAL_NAME);
16113 
16114          when Pragma_Independent_Components => Independent_Components : declare
16115             C    : Node_Id;
16116             D    : Node_Id;
16117             E_Id : Node_Id;
16118             E    : Entity_Id;
16119             K    : Node_Kind;
16120 
16121          begin
16122             Check_Ada_83_Warning;
16123             Ada_2012_Pragma;
16124             Check_No_Identifiers;
16125             Check_Arg_Count (1);
16126             Check_Arg_Is_Local_Name (Arg1);
16127             E_Id := Get_Pragma_Arg (Arg1);
16128 
16129             if Etype (E_Id) = Any_Type then
16130                return;
16131             end if;
16132 
16133             E := Entity (E_Id);
16134 
16135             --  A pragma that applies to a Ghost entity becomes Ghost for the
16136             --  purposes of legality checks and removal of ignored Ghost code.
16137 
16138             Mark_Pragma_As_Ghost (N, E);
16139 
16140             --  Check duplicate before we chain ourselves
16141 
16142             Check_Duplicate_Pragma (E);
16143 
16144             --  Check appropriate entity
16145 
16146             if Rep_Item_Too_Early (E, N)
16147                  or else
16148                Rep_Item_Too_Late (E, N)
16149             then
16150                return;
16151             end if;
16152 
16153             D := Declaration_Node (E);
16154             K := Nkind (D);
16155 
16156             --  The flag is set on the base type, or on the object
16157 
16158             if K = N_Full_Type_Declaration
16159               and then (Is_Array_Type (E) or else Is_Record_Type (E))
16160             then
16161                Set_Has_Independent_Components (Base_Type (E));
16162                Record_Independence_Check (N, Base_Type (E));
16163 
16164                --  For record type, set all components independent
16165 
16166                if Is_Record_Type (E) then
16167                   C := First_Component (E);
16168                   while Present (C) loop
16169                      Set_Is_Independent (C);
16170                      Next_Component (C);
16171                   end loop;
16172                end if;
16173 
16174             elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
16175               and then Nkind (D) = N_Object_Declaration
16176               and then Nkind (Object_Definition (D)) =
16177                                            N_Constrained_Array_Definition
16178             then
16179                Set_Has_Independent_Components (E);
16180                Record_Independence_Check (N, E);
16181 
16182             else
16183                Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
16184             end if;
16185          end Independent_Components;
16186 
16187          -----------------------
16188          -- Initial_Condition --
16189          -----------------------
16190 
16191          --  pragma Initial_Condition (boolean_EXPRESSION);
16192 
16193          --  Characteristics:
16194 
16195          --    * Analysis - The annotation undergoes initial checks to verify
16196          --    the legal placement and context. Secondary checks preanalyze the
16197          --    expression in:
16198 
16199          --       Analyze_Initial_Condition_In_Decl_Part
16200 
16201          --    * Expansion - The annotation is expanded during the expansion of
16202          --    the package body whose declaration is subject to the annotation
16203          --    as done in:
16204 
16205          --       Expand_Pragma_Initial_Condition
16206 
16207          --    * Template - The annotation utilizes the generic template of the
16208          --    related package declaration.
16209 
16210          --    * Globals - Capture of global references must occur after full
16211          --    analysis.
16212 
16213          --    * Instance - The annotation is instantiated automatically when
16214          --    the related generic package is instantiated.
16215 
16216          when Pragma_Initial_Condition => Initial_Condition : declare
16217             Pack_Decl : Node_Id;
16218             Pack_Id   : Entity_Id;
16219 
16220          begin
16221             GNAT_Pragma;
16222             Check_No_Identifiers;
16223             Check_Arg_Count (1);
16224 
16225             Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16226 
16227             --  Ensure the proper placement of the pragma. Initial_Condition
16228             --  must be associated with a package declaration.
16229 
16230             if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16231                                     N_Package_Declaration)
16232             then
16233                null;
16234 
16235             --  Otherwise the pragma is associated with an illegal context
16236 
16237             else
16238                Pragma_Misplaced;
16239                return;
16240             end if;
16241 
16242             Pack_Id := Defining_Entity (Pack_Decl);
16243 
16244             --  Chain the pragma on the contract for further processing by
16245             --  Analyze_Initial_Condition_In_Decl_Part.
16246 
16247             Add_Contract_Item (N, Pack_Id);
16248 
16249             --  The legality checks of pragmas Abstract_State, Initializes, and
16250             --  Initial_Condition are affected by the SPARK mode in effect. In
16251             --  addition, these three pragmas are subject to an inherent order:
16252 
16253             --    1) Abstract_State
16254             --    2) Initializes
16255             --    3) Initial_Condition
16256 
16257             --  Analyze all these pragmas in the order outlined above
16258 
16259             Analyze_If_Present (Pragma_SPARK_Mode);
16260             Analyze_If_Present (Pragma_Abstract_State);
16261             Analyze_If_Present (Pragma_Initializes);
16262 
16263             --  A pragma that applies to a Ghost entity becomes Ghost for the
16264             --  purposes of legality checks and removal of ignored Ghost code.
16265 
16266             Mark_Pragma_As_Ghost (N, Pack_Id);
16267          end Initial_Condition;
16268 
16269          ------------------------
16270          -- Initialize_Scalars --
16271          ------------------------
16272 
16273          --  pragma Initialize_Scalars;
16274 
16275          when Pragma_Initialize_Scalars =>
16276             GNAT_Pragma;
16277             Check_Arg_Count (0);
16278             Check_Valid_Configuration_Pragma;
16279             Check_Restriction (No_Initialize_Scalars, N);
16280 
16281             --  Initialize_Scalars creates false positives in CodePeer, and
16282             --  incorrect negative results in GNATprove mode, so ignore this
16283             --  pragma in these modes.
16284 
16285             if not Restriction_Active (No_Initialize_Scalars)
16286               and then not (CodePeer_Mode or GNATprove_Mode)
16287             then
16288                Init_Or_Norm_Scalars := True;
16289                Initialize_Scalars := True;
16290             end if;
16291 
16292          -----------------
16293          -- Initializes --
16294          -----------------
16295 
16296          --  pragma Initializes (INITIALIZATION_LIST);
16297 
16298          --  INITIALIZATION_LIST ::=
16299          --     null
16300          --  | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
16301 
16302          --  INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
16303 
16304          --  INPUT_LIST ::=
16305          --     null
16306          --  |  INPUT
16307          --  | (INPUT {, INPUT})
16308 
16309          --  INPUT ::= name
16310 
16311          --  Characteristics:
16312 
16313          --    * Analysis - The annotation undergoes initial checks to verify
16314          --    the legal placement and context. Secondary checks preanalyze the
16315          --    expression in:
16316 
16317          --       Analyze_Initializes_In_Decl_Part
16318 
16319          --    * Expansion - None.
16320 
16321          --    * Template - The annotation utilizes the generic template of the
16322          --    related package declaration.
16323 
16324          --    * Globals - Capture of global references must occur after full
16325          --    analysis.
16326 
16327          --    * Instance - The annotation is instantiated automatically when
16328          --    the related generic package is instantiated.
16329 
16330          when Pragma_Initializes => Initializes : declare
16331             Pack_Decl : Node_Id;
16332             Pack_Id   : Entity_Id;
16333 
16334          begin
16335             GNAT_Pragma;
16336             Check_No_Identifiers;
16337             Check_Arg_Count (1);
16338 
16339             Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
16340 
16341             --  Ensure the proper placement of the pragma. Initializes must be
16342             --  associated with a package declaration.
16343 
16344             if Nkind_In (Pack_Decl, N_Generic_Package_Declaration,
16345                                     N_Package_Declaration)
16346             then
16347                null;
16348 
16349             --  Otherwise the pragma is associated with an illegal construc
16350 
16351             else
16352                Pragma_Misplaced;
16353                return;
16354             end if;
16355 
16356             Pack_Id := Defining_Entity (Pack_Decl);
16357 
16358             --  Chain the pragma on the contract for further processing by
16359             --  Analyze_Initializes_In_Decl_Part.
16360 
16361             Add_Contract_Item (N, Pack_Id);
16362 
16363             --  The legality checks of pragmas Abstract_State, Initializes, and
16364             --  Initial_Condition are affected by the SPARK mode in effect. In
16365             --  addition, these three pragmas are subject to an inherent order:
16366 
16367             --    1) Abstract_State
16368             --    2) Initializes
16369             --    3) Initial_Condition
16370 
16371             --  Analyze all these pragmas in the order outlined above
16372 
16373             Analyze_If_Present (Pragma_SPARK_Mode);
16374             Analyze_If_Present (Pragma_Abstract_State);
16375 
16376             --  A pragma that applies to a Ghost entity becomes Ghost for the
16377             --  purposes of legality checks and removal of ignored Ghost code.
16378 
16379             Mark_Pragma_As_Ghost (N, Pack_Id);
16380             Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
16381 
16382             Analyze_If_Present (Pragma_Initial_Condition);
16383          end Initializes;
16384 
16385          ------------
16386          -- Inline --
16387          ------------
16388 
16389          --  pragma Inline ( NAME {, NAME} );
16390 
16391          when Pragma_Inline =>
16392 
16393             --  Pragma always active unless in GNATprove mode. It is disabled
16394             --  in GNATprove mode because frontend inlining is applied
16395             --  independently of pragmas Inline and Inline_Always for
16396             --  formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16397             --  in inline.ads.
16398 
16399             if not GNATprove_Mode then
16400 
16401                --  Inline status is Enabled if inlining option is active
16402 
16403                if Inline_Active then
16404                   Process_Inline (Enabled);
16405                else
16406                   Process_Inline (Disabled);
16407                end if;
16408             end if;
16409 
16410          -------------------
16411          -- Inline_Always --
16412          -------------------
16413 
16414          --  pragma Inline_Always ( NAME {, NAME} );
16415 
16416          when Pragma_Inline_Always =>
16417             GNAT_Pragma;
16418 
16419             --  Pragma always active unless in CodePeer mode or GNATprove
16420             --  mode. It is disabled in CodePeer mode because inlining is
16421             --  not helpful, and enabling it caused walk order issues. It
16422             --  is disabled in GNATprove mode because frontend inlining is
16423             --  applied independently of pragmas Inline and Inline_Always for
16424             --  formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16425             --  inline.ads.
16426 
16427             if not CodePeer_Mode and not GNATprove_Mode then
16428                Process_Inline (Enabled);
16429             end if;
16430 
16431          --------------------
16432          -- Inline_Generic --
16433          --------------------
16434 
16435          --  pragma Inline_Generic (NAME {, NAME});
16436 
16437          when Pragma_Inline_Generic =>
16438             GNAT_Pragma;
16439             Process_Generic_List;
16440 
16441          ----------------------
16442          -- Inspection_Point --
16443          ----------------------
16444 
16445          --  pragma Inspection_Point [(object_NAME {, object_NAME})];
16446 
16447          when Pragma_Inspection_Point => Inspection_Point : declare
16448             Arg : Node_Id;
16449             Exp : Node_Id;
16450 
16451          begin
16452             ip;
16453 
16454             if Arg_Count > 0 then
16455                Arg := Arg1;
16456                loop
16457                   Exp := Get_Pragma_Arg (Arg);
16458                   Analyze (Exp);
16459 
16460                   if not Is_Entity_Name (Exp)
16461                     or else not Is_Object (Entity (Exp))
16462                   then
16463                      Error_Pragma_Arg ("object name required", Arg);
16464                   end if;
16465 
16466                   Next (Arg);
16467                   exit when No (Arg);
16468                end loop;
16469             end if;
16470          end Inspection_Point;
16471 
16472          ---------------
16473          -- Interface --
16474          ---------------
16475 
16476          --  pragma Interface (
16477          --    [   Convention    =>] convention_IDENTIFIER,
16478          --    [   Entity        =>] LOCAL_NAME
16479          --    [, [External_Name =>] static_string_EXPRESSION ]
16480          --    [, [Link_Name     =>] static_string_EXPRESSION ]);
16481 
16482          when Pragma_Interface =>
16483             GNAT_Pragma;
16484             Check_Arg_Order
16485               ((Name_Convention,
16486                 Name_Entity,
16487                 Name_External_Name,
16488                 Name_Link_Name));
16489             Check_At_Least_N_Arguments (2);
16490             Check_At_Most_N_Arguments  (4);
16491             Process_Import_Or_Interface;
16492 
16493             --  In Ada 2005, the permission to use Interface (a reserved word)
16494             --  as a pragma name is considered an obsolescent feature, and this
16495             --  pragma was already obsolescent in Ada 95.
16496 
16497             if Ada_Version >= Ada_95 then
16498                Check_Restriction
16499                  (No_Obsolescent_Features, Pragma_Identifier (N));
16500 
16501                if Warn_On_Obsolescent_Feature then
16502                   Error_Msg_N
16503                     ("pragma Interface is an obsolescent feature?j?", N);
16504                   Error_Msg_N
16505                     ("|use pragma Import instead?j?", N);
16506                end if;
16507             end if;
16508 
16509          --------------------
16510          -- Interface_Name --
16511          --------------------
16512 
16513          --  pragma Interface_Name (
16514          --    [  Entity        =>] LOCAL_NAME
16515          --    [,[External_Name =>] static_string_EXPRESSION ]
16516          --    [,[Link_Name     =>] static_string_EXPRESSION ]);
16517 
16518          when Pragma_Interface_Name => Interface_Name : declare
16519             Id     : Node_Id;
16520             Def_Id : Entity_Id;
16521             Hom_Id : Entity_Id;
16522             Found  : Boolean;
16523 
16524          begin
16525             GNAT_Pragma;
16526             Check_Arg_Order
16527               ((Name_Entity, Name_External_Name, Name_Link_Name));
16528             Check_At_Least_N_Arguments (2);
16529             Check_At_Most_N_Arguments  (3);
16530             Id := Get_Pragma_Arg (Arg1);
16531             Analyze (Id);
16532 
16533             --  This is obsolete from Ada 95 on, but it is an implementation
16534             --  defined pragma, so we do not consider that it violates the
16535             --  restriction (No_Obsolescent_Features).
16536 
16537             if Ada_Version >= Ada_95 then
16538                if Warn_On_Obsolescent_Feature then
16539                   Error_Msg_N
16540                     ("pragma Interface_Name is an obsolescent feature?j?", N);
16541                   Error_Msg_N
16542                     ("|use pragma Import instead?j?", N);
16543                end if;
16544             end if;
16545 
16546             if not Is_Entity_Name (Id) then
16547                Error_Pragma_Arg
16548                  ("first argument for pragma% must be entity name", Arg1);
16549             elsif Etype (Id) = Any_Type then
16550                return;
16551             else
16552                Def_Id := Entity (Id);
16553             end if;
16554 
16555             --  Special DEC-compatible processing for the object case, forces
16556             --  object to be imported.
16557 
16558             if Ekind (Def_Id) = E_Variable then
16559                Kill_Size_Check_Code (Def_Id);
16560                Note_Possible_Modification (Id, Sure => False);
16561 
16562                --  Initialization is not allowed for imported variable
16563 
16564                if Present (Expression (Parent (Def_Id)))
16565                  and then Comes_From_Source (Expression (Parent (Def_Id)))
16566                then
16567                   Error_Msg_Sloc := Sloc (Def_Id);
16568                   Error_Pragma_Arg
16569                     ("no initialization allowed for declaration of& #",
16570                      Arg2);
16571 
16572                else
16573                   --  For compatibility, support VADS usage of providing both
16574                   --  pragmas Interface and Interface_Name to obtain the effect
16575                   --  of a single Import pragma.
16576 
16577                   if Is_Imported (Def_Id)
16578                     and then Present (First_Rep_Item (Def_Id))
16579                     and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
16580                     and then
16581                       Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
16582                   then
16583                      null;
16584                   else
16585                      Set_Imported (Def_Id);
16586                   end if;
16587 
16588                   Set_Is_Public (Def_Id);
16589                   Process_Interface_Name (Def_Id, Arg2, Arg3);
16590                end if;
16591 
16592             --  Otherwise must be subprogram
16593 
16594             elsif not Is_Subprogram (Def_Id) then
16595                Error_Pragma_Arg
16596                  ("argument of pragma% is not subprogram", Arg1);
16597 
16598             else
16599                Check_At_Most_N_Arguments (3);
16600                Hom_Id := Def_Id;
16601                Found := False;
16602 
16603                --  Loop through homonyms
16604 
16605                loop
16606                   Def_Id := Get_Base_Subprogram (Hom_Id);
16607 
16608                   if Is_Imported (Def_Id) then
16609                      Process_Interface_Name (Def_Id, Arg2, Arg3);
16610                      Found := True;
16611                   end if;
16612 
16613                   exit when From_Aspect_Specification (N);
16614                   Hom_Id := Homonym (Hom_Id);
16615 
16616                   exit when No (Hom_Id)
16617                     or else Scope (Hom_Id) /= Current_Scope;
16618                end loop;
16619 
16620                if not Found then
16621                   Error_Pragma_Arg
16622                     ("argument of pragma% is not imported subprogram",
16623                      Arg1);
16624                end if;
16625             end if;
16626          end Interface_Name;
16627 
16628          -----------------------
16629          -- Interrupt_Handler --
16630          -----------------------
16631 
16632          --  pragma Interrupt_Handler (handler_NAME);
16633 
16634          when Pragma_Interrupt_Handler =>
16635             Check_Ada_83_Warning;
16636             Check_Arg_Count (1);
16637             Check_No_Identifiers;
16638 
16639             if No_Run_Time_Mode then
16640                Error_Msg_CRT ("Interrupt_Handler pragma", N);
16641             else
16642                Check_Interrupt_Or_Attach_Handler;
16643                Process_Interrupt_Or_Attach_Handler;
16644             end if;
16645 
16646          ------------------------
16647          -- Interrupt_Priority --
16648          ------------------------
16649 
16650          --  pragma Interrupt_Priority [(EXPRESSION)];
16651 
16652          when Pragma_Interrupt_Priority => Interrupt_Priority : declare
16653             P   : constant Node_Id := Parent (N);
16654             Arg : Node_Id;
16655             Ent : Entity_Id;
16656 
16657          begin
16658             Check_Ada_83_Warning;
16659 
16660             if Arg_Count /= 0 then
16661                Arg := Get_Pragma_Arg (Arg1);
16662                Check_Arg_Count (1);
16663                Check_No_Identifiers;
16664 
16665                --  The expression must be analyzed in the special manner
16666                --  described in "Handling of Default and Per-Object
16667                --  Expressions" in sem.ads.
16668 
16669                Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
16670             end if;
16671 
16672             if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
16673                Pragma_Misplaced;
16674                return;
16675 
16676             else
16677                Ent := Defining_Identifier (Parent (P));
16678 
16679                --  Check duplicate pragma before we chain the pragma in the Rep
16680                --  Item chain of Ent.
16681 
16682                Check_Duplicate_Pragma (Ent);
16683                Record_Rep_Item (Ent, N);
16684 
16685                --  Check the No_Task_At_Interrupt_Priority restriction
16686 
16687                if Nkind (P) = N_Task_Definition then
16688                   Check_Restriction (No_Task_At_Interrupt_Priority, N);
16689                end if;
16690             end if;
16691          end Interrupt_Priority;
16692 
16693          ---------------------
16694          -- Interrupt_State --
16695          ---------------------
16696 
16697          --  pragma Interrupt_State (
16698          --    [Name  =>] INTERRUPT_ID,
16699          --    [State =>] INTERRUPT_STATE);
16700 
16701          --  INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16702          --  INTERRUPT_STATE => System | Runtime | User
16703 
16704          --  Note: if the interrupt id is given as an identifier, then it must
16705          --  be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16706          --  given as a static integer expression which must be in the range of
16707          --  Ada.Interrupts.Interrupt_ID.
16708 
16709          when Pragma_Interrupt_State => Interrupt_State : declare
16710             Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
16711             --  This is the entity Ada.Interrupts.Interrupt_ID;
16712 
16713             State_Type : Character;
16714             --  Set to 's'/'r'/'u' for System/Runtime/User
16715 
16716             IST_Num : Pos;
16717             --  Index to entry in Interrupt_States table
16718 
16719             Int_Val : Uint;
16720             --  Value of interrupt
16721 
16722             Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
16723             --  The first argument to the pragma
16724 
16725             Int_Ent : Entity_Id;
16726             --  Interrupt entity in Ada.Interrupts.Names
16727 
16728          begin
16729             GNAT_Pragma;
16730             Check_Arg_Order ((Name_Name, Name_State));
16731             Check_Arg_Count (2);
16732 
16733             Check_Optional_Identifier (Arg1, Name_Name);
16734             Check_Optional_Identifier (Arg2, Name_State);
16735             Check_Arg_Is_Identifier (Arg2);
16736 
16737             --  First argument is identifier
16738 
16739             if Nkind (Arg1X) = N_Identifier then
16740 
16741                --  Search list of names in Ada.Interrupts.Names
16742 
16743                Int_Ent := First_Entity (RTE (RE_Names));
16744                loop
16745                   if No (Int_Ent) then
16746                      Error_Pragma_Arg ("invalid interrupt name", Arg1);
16747 
16748                   elsif Chars (Int_Ent) = Chars (Arg1X) then
16749                      Int_Val := Expr_Value (Constant_Value (Int_Ent));
16750                      exit;
16751                   end if;
16752 
16753                   Next_Entity (Int_Ent);
16754                end loop;
16755 
16756             --  First argument is not an identifier, so it must be a static
16757             --  expression of type Ada.Interrupts.Interrupt_ID.
16758 
16759             else
16760                Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
16761                Int_Val := Expr_Value (Arg1X);
16762 
16763                if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
16764                     or else
16765                   Int_Val > Expr_Value (Type_High_Bound (Int_Id))
16766                then
16767                   Error_Pragma_Arg
16768                     ("value not in range of type "
16769                      & """Ada.Interrupts.Interrupt_'I'D""", Arg1);
16770                end if;
16771             end if;
16772 
16773             --  Check OK state
16774 
16775             case Chars (Get_Pragma_Arg (Arg2)) is
16776                when Name_Runtime => State_Type := 'r';
16777                when Name_System  => State_Type := 's';
16778                when Name_User    => State_Type := 'u';
16779 
16780                when others =>
16781                   Error_Pragma_Arg ("invalid interrupt state", Arg2);
16782             end case;
16783 
16784             --  Check if entry is already stored
16785 
16786             IST_Num := Interrupt_States.First;
16787             loop
16788                --  If entry not found, add it
16789 
16790                if IST_Num > Interrupt_States.Last then
16791                   Interrupt_States.Append
16792                     ((Interrupt_Number => UI_To_Int (Int_Val),
16793                       Interrupt_State  => State_Type,
16794                       Pragma_Loc       => Loc));
16795                   exit;
16796 
16797                --  Case of entry for the same entry
16798 
16799                elsif Int_Val = Interrupt_States.Table (IST_Num).
16800                                                            Interrupt_Number
16801                then
16802                   --  If state matches, done, no need to make redundant entry
16803 
16804                   exit when
16805                     State_Type = Interrupt_States.Table (IST_Num).
16806                                                            Interrupt_State;
16807 
16808                   --  Otherwise if state does not match, error
16809 
16810                   Error_Msg_Sloc :=
16811                     Interrupt_States.Table (IST_Num).Pragma_Loc;
16812                   Error_Pragma_Arg
16813                     ("state conflicts with that given #", Arg2);
16814                   exit;
16815                end if;
16816 
16817                IST_Num := IST_Num + 1;
16818             end loop;
16819          end Interrupt_State;
16820 
16821          ---------------
16822          -- Invariant --
16823          ---------------
16824 
16825          --  pragma Invariant
16826          --    ([Entity =>]    type_LOCAL_NAME,
16827          --     [Check  =>]    EXPRESSION
16828          --     [,[Message =>] String_Expression]);
16829 
16830          when Pragma_Invariant => Invariant : declare
16831             Discard : Boolean;
16832             Typ     : Entity_Id;
16833             Typ_Arg : Node_Id;
16834 
16835             CRec_Typ : Entity_Id;
16836             --  The corresponding record type of Full_Typ
16837 
16838             Full_Base : Entity_Id;
16839             --  The base type of Full_Typ
16840 
16841             Full_Typ : Entity_Id;
16842             --  The full view of Typ
16843 
16844             Priv_Typ : Entity_Id;
16845             --  The partial view of Typ
16846 
16847          begin
16848             GNAT_Pragma;
16849             Check_At_Least_N_Arguments (2);
16850             Check_At_Most_N_Arguments  (3);
16851             Check_Optional_Identifier (Arg1, Name_Entity);
16852             Check_Optional_Identifier (Arg2, Name_Check);
16853 
16854             if Arg_Count = 3 then
16855                Check_Optional_Identifier (Arg3, Name_Message);
16856                Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
16857             end if;
16858 
16859             Check_Arg_Is_Local_Name (Arg1);
16860 
16861             Typ_Arg := Get_Pragma_Arg (Arg1);
16862             Find_Type (Typ_Arg);
16863             Typ := Entity (Typ_Arg);
16864 
16865             --  Nothing to do of the related type is erroneous in some way
16866 
16867             if Typ = Any_Type then
16868                return;
16869 
16870             --  AI12-0041: Invariants are allowed in interface types
16871 
16872             elsif Is_Interface (Typ) then
16873                null;
16874 
16875             --  An invariant must apply to a private type, or appear in the
16876             --  private part of a package spec and apply to a completion.
16877             --  a class-wide invariant can only appear on a private declaration
16878             --  or private extension, not a completion.
16879 
16880             --  A [class-wide] invariant may be associated a [limited] private
16881             --  type or a private extension.
16882 
16883             elsif Ekind_In (Typ, E_Limited_Private_Type,
16884                                  E_Private_Type,
16885                                  E_Record_Type_With_Private)
16886             then
16887                null;
16888 
16889             --  A non-class-wide invariant may be associated with the full view
16890             --  of a [limited] private type or a private extension.
16891 
16892             elsif Has_Private_Declaration (Typ)
16893               and then not Class_Present (N)
16894             then
16895                null;
16896 
16897             --  A class-wide invariant may appear on the partial view only
16898 
16899             elsif Class_Present (N) then
16900                Error_Pragma_Arg
16901                  ("pragma % only allowed for private type", Arg1);
16902                return;
16903 
16904             --  A regular invariant may appear on both views
16905 
16906             else
16907                Error_Pragma_Arg
16908                  ("pragma % only allowed for private type or corresponding "
16909                   & "full view", Arg1);
16910                return;
16911             end if;
16912 
16913             --  An invariant associated with an abstract type (this includes
16914             --  interfaces) must be class-wide.
16915 
16916             if Is_Abstract_Type (Typ) and then not Class_Present (N) then
16917                Error_Pragma_Arg
16918                  ("pragma % not allowed for abstract type", Arg1);
16919                return;
16920             end if;
16921 
16922             --  A pragma that applies to a Ghost entity becomes Ghost for the
16923             --  purposes of legality checks and removal of ignored Ghost code.
16924 
16925             Mark_Pragma_As_Ghost (N, Typ);
16926 
16927             --  The pragma defines a type-specific invariant, the type is said
16928             --  to have invariants of its "own".
16929 
16930             Set_Has_Own_Invariants (Typ);
16931 
16932             --  If the invariant is class-wide, then it can be inherited by
16933             --  derived or interface implementing types. The type is said to
16934             --  have "inheritable" invariants.
16935 
16936             if Class_Present (N) then
16937                Set_Has_Inheritable_Invariants (Typ);
16938             end if;
16939 
16940             Get_Views (Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
16941 
16942             --  Propagate invariant-related attributes to all views of the type
16943             --  and any additional types that may have been created.
16944 
16945             Propagate_Invariant_Attributes (Priv_Typ,  From_Typ => Typ);
16946             Propagate_Invariant_Attributes (Full_Typ,  From_Typ => Typ);
16947             Propagate_Invariant_Attributes (Full_Base, From_Typ => Typ);
16948             Propagate_Invariant_Attributes (CRec_Typ,  From_Typ => Typ);
16949 
16950             --  Chain the pragma on to the rep item chain, for processing when
16951             --  the type is frozen.
16952 
16953             Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
16954 
16955             --  Create the declaration of the invariant procedure which will
16956             --  verify the invariant at run-time. Note that interfaces do not
16957             --  carry such a declaration.
16958 
16959             Build_Invariant_Procedure_Declaration (Typ);
16960          end Invariant;
16961 
16962          ----------------
16963          -- Keep_Names --
16964          ----------------
16965 
16966          --  pragma Keep_Names ([On => ] LOCAL_NAME);
16967 
16968          when Pragma_Keep_Names => Keep_Names : declare
16969             Arg : Node_Id;
16970 
16971          begin
16972             GNAT_Pragma;
16973             Check_Arg_Count (1);
16974             Check_Optional_Identifier (Arg1, Name_On);
16975             Check_Arg_Is_Local_Name (Arg1);
16976 
16977             Arg := Get_Pragma_Arg (Arg1);
16978             Analyze (Arg);
16979 
16980             if Etype (Arg) = Any_Type then
16981                return;
16982             end if;
16983 
16984             if not Is_Entity_Name (Arg)
16985               or else Ekind (Entity (Arg)) /= E_Enumeration_Type
16986             then
16987                Error_Pragma_Arg
16988                  ("pragma% requires a local enumeration type", Arg1);
16989             end if;
16990 
16991             Set_Discard_Names (Entity (Arg), False);
16992          end Keep_Names;
16993 
16994          -------------
16995          -- License --
16996          -------------
16997 
16998          --  pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16999 
17000          when Pragma_License =>
17001             GNAT_Pragma;
17002 
17003             --  Do not analyze pragma any further in CodePeer mode, to avoid
17004             --  extraneous errors in this implementation-dependent pragma,
17005             --  which has a different profile on other compilers.
17006 
17007             if CodePeer_Mode then
17008                return;
17009             end if;
17010 
17011             Check_Arg_Count (1);
17012             Check_No_Identifiers;
17013             Check_Valid_Configuration_Pragma;
17014             Check_Arg_Is_Identifier (Arg1);
17015 
17016             declare
17017                Sind : constant Source_File_Index :=
17018                         Source_Index (Current_Sem_Unit);
17019 
17020             begin
17021                case Chars (Get_Pragma_Arg (Arg1)) is
17022                   when Name_GPL =>
17023                      Set_License (Sind, GPL);
17024 
17025                   when Name_Modified_GPL =>
17026                      Set_License (Sind, Modified_GPL);
17027 
17028                   when Name_Restricted =>
17029                      Set_License (Sind, Restricted);
17030 
17031                   when Name_Unrestricted =>
17032                      Set_License (Sind, Unrestricted);
17033 
17034                   when others =>
17035                      Error_Pragma_Arg ("invalid license name", Arg1);
17036                end case;
17037             end;
17038 
17039          ---------------
17040          -- Link_With --
17041          ---------------
17042 
17043          --  pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
17044 
17045          when Pragma_Link_With => Link_With : declare
17046             Arg : Node_Id;
17047 
17048          begin
17049             GNAT_Pragma;
17050 
17051             if Operating_Mode = Generate_Code
17052               and then In_Extended_Main_Source_Unit (N)
17053             then
17054                Check_At_Least_N_Arguments (1);
17055                Check_No_Identifiers;
17056                Check_Is_In_Decl_Part_Or_Package_Spec;
17057                Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17058                Start_String;
17059 
17060                Arg := Arg1;
17061                while Present (Arg) loop
17062                   Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
17063 
17064                   --  Store argument, converting sequences of spaces to a
17065                   --  single null character (this is one of the differences
17066                   --  in processing between Link_With and Linker_Options).
17067 
17068                   Arg_Store : declare
17069                      C : constant Char_Code := Get_Char_Code (' ');
17070                      S : constant String_Id :=
17071                            Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
17072                      L : constant Nat := String_Length (S);
17073                      F : Nat := 1;
17074 
17075                      procedure Skip_Spaces;
17076                      --  Advance F past any spaces
17077 
17078                      -----------------
17079                      -- Skip_Spaces --
17080                      -----------------
17081 
17082                      procedure Skip_Spaces is
17083                      begin
17084                         while F <= L and then Get_String_Char (S, F) = C loop
17085                            F := F + 1;
17086                         end loop;
17087                      end Skip_Spaces;
17088 
17089                   --  Start of processing for Arg_Store
17090 
17091                   begin
17092                      Skip_Spaces; -- skip leading spaces
17093 
17094                      --  Loop through characters, changing any embedded
17095                      --  sequence of spaces to a single null character (this
17096                      --  is how Link_With/Linker_Options differ)
17097 
17098                      while F <= L loop
17099                         if Get_String_Char (S, F) = C then
17100                            Skip_Spaces;
17101                            exit when F > L;
17102                            Store_String_Char (ASCII.NUL);
17103 
17104                         else
17105                            Store_String_Char (Get_String_Char (S, F));
17106                            F := F + 1;
17107                         end if;
17108                      end loop;
17109                   end Arg_Store;
17110 
17111                   Arg := Next (Arg);
17112 
17113                   if Present (Arg) then
17114                      Store_String_Char (ASCII.NUL);
17115                   end if;
17116                end loop;
17117 
17118                Store_Linker_Option_String (End_String);
17119             end if;
17120          end Link_With;
17121 
17122          ------------------
17123          -- Linker_Alias --
17124          ------------------
17125 
17126          --  pragma Linker_Alias (
17127          --      [Entity =>]  LOCAL_NAME
17128          --      [Target =>]  static_string_EXPRESSION);
17129 
17130          when Pragma_Linker_Alias =>
17131             GNAT_Pragma;
17132             Check_Arg_Order ((Name_Entity, Name_Target));
17133             Check_Arg_Count (2);
17134             Check_Optional_Identifier (Arg1, Name_Entity);
17135             Check_Optional_Identifier (Arg2, Name_Target);
17136             Check_Arg_Is_Library_Level_Local_Name (Arg1);
17137             Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17138 
17139             --  The only processing required is to link this item on to the
17140             --  list of rep items for the given entity. This is accomplished
17141             --  by the call to Rep_Item_Too_Late (when no error is detected
17142             --  and False is returned).
17143 
17144             if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
17145                return;
17146             else
17147                Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17148             end if;
17149 
17150          ------------------------
17151          -- Linker_Constructor --
17152          ------------------------
17153 
17154          --  pragma Linker_Constructor (procedure_LOCAL_NAME);
17155 
17156          --  Code is shared with Linker_Destructor
17157 
17158          -----------------------
17159          -- Linker_Destructor --
17160          -----------------------
17161 
17162          --  pragma Linker_Destructor (procedure_LOCAL_NAME);
17163 
17164          when Pragma_Linker_Constructor |
17165               Pragma_Linker_Destructor =>
17166          Linker_Constructor : declare
17167             Arg1_X : Node_Id;
17168             Proc   : Entity_Id;
17169 
17170          begin
17171             GNAT_Pragma;
17172             Check_Arg_Count (1);
17173             Check_No_Identifiers;
17174             Check_Arg_Is_Local_Name (Arg1);
17175             Arg1_X := Get_Pragma_Arg (Arg1);
17176             Analyze (Arg1_X);
17177             Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
17178 
17179             if not Is_Library_Level_Entity (Proc) then
17180                Error_Pragma_Arg
17181                 ("argument for pragma% must be library level entity", Arg1);
17182             end if;
17183 
17184             --  The only processing required is to link this item on to the
17185             --  list of rep items for the given entity. This is accomplished
17186             --  by the call to Rep_Item_Too_Late (when no error is detected
17187             --  and False is returned).
17188 
17189             if Rep_Item_Too_Late (Proc, N) then
17190                return;
17191             else
17192                Set_Has_Gigi_Rep_Item (Proc);
17193             end if;
17194          end Linker_Constructor;
17195 
17196          --------------------
17197          -- Linker_Options --
17198          --------------------
17199 
17200          --  pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
17201 
17202          when Pragma_Linker_Options => Linker_Options : declare
17203             Arg : Node_Id;
17204 
17205          begin
17206             Check_Ada_83_Warning;
17207             Check_No_Identifiers;
17208             Check_Arg_Count (1);
17209             Check_Is_In_Decl_Part_Or_Package_Spec;
17210             Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
17211             Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
17212 
17213             Arg := Arg2;
17214             while Present (Arg) loop
17215                Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
17216                Store_String_Char (ASCII.NUL);
17217                Store_String_Chars
17218                  (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
17219                Arg := Next (Arg);
17220             end loop;
17221 
17222             if Operating_Mode = Generate_Code
17223               and then In_Extended_Main_Source_Unit (N)
17224             then
17225                Store_Linker_Option_String (End_String);
17226             end if;
17227          end Linker_Options;
17228 
17229          --------------------
17230          -- Linker_Section --
17231          --------------------
17232 
17233          --  pragma Linker_Section (
17234          --      [Entity  =>] LOCAL_NAME
17235          --      [Section =>] static_string_EXPRESSION);
17236 
17237          when Pragma_Linker_Section => Linker_Section : declare
17238             Arg : Node_Id;
17239             Ent : Entity_Id;
17240             LPE : Node_Id;
17241 
17242             Ghost_Error_Posted : Boolean := False;
17243             --  Flag set when an error concerning the illegal mix of Ghost and
17244             --  non-Ghost subprograms is emitted.
17245 
17246             Ghost_Id : Entity_Id := Empty;
17247             --  The entity of the first Ghost subprogram encountered while
17248             --  processing the arguments of the pragma.
17249 
17250          begin
17251             GNAT_Pragma;
17252             Check_Arg_Order ((Name_Entity, Name_Section));
17253             Check_Arg_Count (2);
17254             Check_Optional_Identifier (Arg1, Name_Entity);
17255             Check_Optional_Identifier (Arg2, Name_Section);
17256             Check_Arg_Is_Library_Level_Local_Name (Arg1);
17257             Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17258 
17259             --  Check kind of entity
17260 
17261             Arg := Get_Pragma_Arg (Arg1);
17262             Ent := Entity (Arg);
17263 
17264             case Ekind (Ent) is
17265 
17266                --  Objects (constants and variables) and types. For these cases
17267                --  all we need to do is to set the Linker_Section_pragma field,
17268                --  checking that we do not have a duplicate.
17269 
17270                when E_Constant | E_Variable | Type_Kind =>
17271                   LPE := Linker_Section_Pragma (Ent);
17272 
17273                   if Present (LPE) then
17274                      Error_Msg_Sloc := Sloc (LPE);
17275                      Error_Msg_NE
17276                        ("Linker_Section already specified for &#", Arg1, Ent);
17277                   end if;
17278 
17279                   Set_Linker_Section_Pragma (Ent, N);
17280 
17281                   --  A pragma that applies to a Ghost entity becomes Ghost for
17282                   --  the purposes of legality checks and removal of ignored
17283                   --  Ghost code.
17284 
17285                   Mark_Pragma_As_Ghost (N, Ent);
17286 
17287                --  Subprograms
17288 
17289                when Subprogram_Kind =>
17290 
17291                   --  Aspect case, entity already set
17292 
17293                   if From_Aspect_Specification (N) then
17294                      Set_Linker_Section_Pragma
17295                        (Entity (Corresponding_Aspect (N)), N);
17296 
17297                   --  Pragma case, we must climb the homonym chain, but skip
17298                   --  any for which the linker section is already set.
17299 
17300                   else
17301                      loop
17302                         if No (Linker_Section_Pragma (Ent)) then
17303                            Set_Linker_Section_Pragma (Ent, N);
17304 
17305                            --  A pragma that applies to a Ghost entity becomes
17306                            --  Ghost for the purposes of legality checks and
17307                            --  removal of ignored Ghost code.
17308 
17309                            Mark_Pragma_As_Ghost (N, Ent);
17310 
17311                            --  Capture the entity of the first Ghost subprogram
17312                            --  being processed for error detection purposes.
17313 
17314                            if Is_Ghost_Entity (Ent) then
17315                               if No (Ghost_Id) then
17316                                  Ghost_Id := Ent;
17317                               end if;
17318 
17319                            --  Otherwise the subprogram is non-Ghost. It is
17320                            --  illegal to mix references to Ghost and non-Ghost
17321                            --  entities (SPARK RM 6.9).
17322 
17323                            elsif Present (Ghost_Id)
17324                              and then not Ghost_Error_Posted
17325                            then
17326                               Ghost_Error_Posted := True;
17327 
17328                               Error_Msg_Name_1 := Pname;
17329                               Error_Msg_N
17330                                 ("pragma % cannot mention ghost and "
17331                                  & "non-ghost subprograms", N);
17332 
17333                               Error_Msg_Sloc := Sloc (Ghost_Id);
17334                               Error_Msg_NE
17335                                 ("\& # declared as ghost", N, Ghost_Id);
17336 
17337                               Error_Msg_Sloc := Sloc (Ent);
17338                               Error_Msg_NE
17339                                 ("\& # declared as non-ghost", N, Ent);
17340                            end if;
17341                         end if;
17342 
17343                         Ent := Homonym (Ent);
17344                         exit when No (Ent)
17345                           or else Scope (Ent) /= Current_Scope;
17346                      end loop;
17347                   end if;
17348 
17349                --  All other cases are illegal
17350 
17351                when others =>
17352                   Error_Pragma_Arg
17353                     ("pragma% applies only to objects, subprograms, and types",
17354                      Arg1);
17355             end case;
17356          end Linker_Section;
17357 
17358          ----------
17359          -- List --
17360          ----------
17361 
17362          --  pragma List (On | Off)
17363 
17364          --  There is nothing to do here, since we did all the processing for
17365          --  this pragma in Par.Prag (so that it works properly even in syntax
17366          --  only mode).
17367 
17368          when Pragma_List =>
17369             null;
17370 
17371          ---------------
17372          -- Lock_Free --
17373          ---------------
17374 
17375          --  pragma Lock_Free [(Boolean_EXPRESSION)];
17376 
17377          when Pragma_Lock_Free => Lock_Free : declare
17378             P   : constant Node_Id := Parent (N);
17379             Arg : Node_Id;
17380             Ent : Entity_Id;
17381             Val : Boolean;
17382 
17383          begin
17384             Check_No_Identifiers;
17385             Check_At_Most_N_Arguments (1);
17386 
17387             --  Protected definition case
17388 
17389             if Nkind (P) = N_Protected_Definition then
17390                Ent := Defining_Identifier (Parent (P));
17391 
17392                --  One argument
17393 
17394                if Arg_Count = 1 then
17395                   Arg := Get_Pragma_Arg (Arg1);
17396                   Val := Is_True (Static_Boolean (Arg));
17397 
17398                --  No arguments (expression is considered to be True)
17399 
17400                else
17401                   Val := True;
17402                end if;
17403 
17404                --  Check duplicate pragma before we chain the pragma in the Rep
17405                --  Item chain of Ent.
17406 
17407                Check_Duplicate_Pragma (Ent);
17408                Record_Rep_Item        (Ent, N);
17409                Set_Uses_Lock_Free     (Ent, Val);
17410 
17411             --  Anything else is incorrect placement
17412 
17413             else
17414                Pragma_Misplaced;
17415             end if;
17416          end Lock_Free;
17417 
17418          --------------------
17419          -- Locking_Policy --
17420          --------------------
17421 
17422          --  pragma Locking_Policy (policy_IDENTIFIER);
17423 
17424          when Pragma_Locking_Policy => declare
17425             subtype LP_Range is Name_Id
17426               range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
17427             LP_Val : LP_Range;
17428             LP     : Character;
17429 
17430          begin
17431             Check_Ada_83_Warning;
17432             Check_Arg_Count (1);
17433             Check_No_Identifiers;
17434             Check_Arg_Is_Locking_Policy (Arg1);
17435             Check_Valid_Configuration_Pragma;
17436             LP_Val := Chars (Get_Pragma_Arg (Arg1));
17437 
17438             case LP_Val is
17439                when Name_Ceiling_Locking            =>
17440                   LP := 'C';
17441                when Name_Inheritance_Locking        =>
17442                   LP := 'I';
17443                when Name_Concurrent_Readers_Locking =>
17444                   LP := 'R';
17445             end case;
17446 
17447             if Locking_Policy /= ' '
17448               and then Locking_Policy /= LP
17449             then
17450                Error_Msg_Sloc := Locking_Policy_Sloc;
17451                Error_Pragma ("locking policy incompatible with policy#");
17452 
17453             --  Set new policy, but always preserve System_Location since we
17454             --  like the error message with the run time name.
17455 
17456             else
17457                Locking_Policy := LP;
17458 
17459                if Locking_Policy_Sloc /= System_Location then
17460                   Locking_Policy_Sloc := Loc;
17461                end if;
17462             end if;
17463          end;
17464 
17465          -------------------
17466          -- Loop_Optimize --
17467          -------------------
17468 
17469          --  pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17470 
17471          --  OPTIMIZATION_HINT ::=
17472          --    Ivdep | No_Unroll | Unroll | No_Vector | Vector
17473 
17474          when Pragma_Loop_Optimize => Loop_Optimize : declare
17475             Hint : Node_Id;
17476 
17477          begin
17478             GNAT_Pragma;
17479             Check_At_Least_N_Arguments (1);
17480             Check_No_Identifiers;
17481 
17482             Hint := First (Pragma_Argument_Associations (N));
17483             while Present (Hint) loop
17484                Check_Arg_Is_One_Of (Hint, Name_Ivdep,
17485                                           Name_No_Unroll,
17486                                           Name_Unroll,
17487                                           Name_No_Vector,
17488                                           Name_Vector);
17489                Next (Hint);
17490             end loop;
17491 
17492             Check_Loop_Pragma_Placement;
17493          end Loop_Optimize;
17494 
17495          ------------------
17496          -- Loop_Variant --
17497          ------------------
17498 
17499          --  pragma Loop_Variant
17500          --         ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17501 
17502          --  LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17503 
17504          --  CHANGE_DIRECTION ::= Increases | Decreases
17505 
17506          when Pragma_Loop_Variant => Loop_Variant : declare
17507             Variant : Node_Id;
17508 
17509          begin
17510             GNAT_Pragma;
17511             Check_At_Least_N_Arguments (1);
17512             Check_Loop_Pragma_Placement;
17513 
17514             --  Process all increasing / decreasing expressions
17515 
17516             Variant := First (Pragma_Argument_Associations (N));
17517             while Present (Variant) loop
17518                if not Nam_In (Chars (Variant), Name_Decreases,
17519                                                Name_Increases)
17520                then
17521                   Error_Pragma_Arg ("wrong change modifier", Variant);
17522                end if;
17523 
17524                Preanalyze_Assert_Expression
17525                  (Expression (Variant), Any_Discrete);
17526 
17527                Next (Variant);
17528             end loop;
17529          end Loop_Variant;
17530 
17531          -----------------------
17532          -- Machine_Attribute --
17533          -----------------------
17534 
17535          --  pragma Machine_Attribute (
17536          --       [Entity         =>] LOCAL_NAME,
17537          --       [Attribute_Name =>] static_string_EXPRESSION
17538          --    [, [Info           =>] static_EXPRESSION] );
17539 
17540          when Pragma_Machine_Attribute => Machine_Attribute : declare
17541             Def_Id : Entity_Id;
17542 
17543          begin
17544             GNAT_Pragma;
17545             Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
17546 
17547             if Arg_Count = 3 then
17548                Check_Optional_Identifier (Arg3, Name_Info);
17549                Check_Arg_Is_OK_Static_Expression (Arg3);
17550             else
17551                Check_Arg_Count (2);
17552             end if;
17553 
17554             Check_Optional_Identifier (Arg1, Name_Entity);
17555             Check_Optional_Identifier (Arg2, Name_Attribute_Name);
17556             Check_Arg_Is_Local_Name (Arg1);
17557             Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
17558             Def_Id := Entity (Get_Pragma_Arg (Arg1));
17559 
17560             if Is_Access_Type (Def_Id) then
17561                Def_Id := Designated_Type (Def_Id);
17562             end if;
17563 
17564             if Rep_Item_Too_Early (Def_Id, N) then
17565                return;
17566             end if;
17567 
17568             Def_Id := Underlying_Type (Def_Id);
17569 
17570             --  The only processing required is to link this item on to the
17571             --  list of rep items for the given entity. This is accomplished
17572             --  by the call to Rep_Item_Too_Late (when no error is detected
17573             --  and False is returned).
17574 
17575             if Rep_Item_Too_Late (Def_Id, N) then
17576                return;
17577             else
17578                Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
17579             end if;
17580          end Machine_Attribute;
17581 
17582          ----------
17583          -- Main --
17584          ----------
17585 
17586          --  pragma Main
17587          --   (MAIN_OPTION [, MAIN_OPTION]);
17588 
17589          --  MAIN_OPTION ::=
17590          --    [STACK_SIZE              =>] static_integer_EXPRESSION
17591          --  | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17592          --  | [TIME_SLICING_ENABLED    =>] static_boolean_EXPRESSION
17593 
17594          when Pragma_Main => Main : declare
17595             Args  : Args_List (1 .. 3);
17596             Names : constant Name_List (1 .. 3) := (
17597                       Name_Stack_Size,
17598                       Name_Task_Stack_Size_Default,
17599                       Name_Time_Slicing_Enabled);
17600 
17601             Nod : Node_Id;
17602 
17603          begin
17604             GNAT_Pragma;
17605             Gather_Associations (Names, Args);
17606 
17607             for J in 1 .. 2 loop
17608                if Present (Args (J)) then
17609                   Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17610                end if;
17611             end loop;
17612 
17613             if Present (Args (3)) then
17614                Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
17615             end if;
17616 
17617             Nod := Next (N);
17618             while Present (Nod) loop
17619                if Nkind (Nod) = N_Pragma
17620                  and then Pragma_Name (Nod) = Name_Main
17621                then
17622                   Error_Msg_Name_1 := Pname;
17623                   Error_Msg_N ("duplicate pragma% not permitted", Nod);
17624                end if;
17625 
17626                Next (Nod);
17627             end loop;
17628          end Main;
17629 
17630          ------------------
17631          -- Main_Storage --
17632          ------------------
17633 
17634          --  pragma Main_Storage
17635          --   (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17636 
17637          --  MAIN_STORAGE_OPTION ::=
17638          --    [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17639          --  | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17640 
17641          when Pragma_Main_Storage => Main_Storage : declare
17642             Args  : Args_List (1 .. 2);
17643             Names : constant Name_List (1 .. 2) := (
17644                       Name_Working_Storage,
17645                       Name_Top_Guard);
17646 
17647             Nod : Node_Id;
17648 
17649          begin
17650             GNAT_Pragma;
17651             Gather_Associations (Names, Args);
17652 
17653             for J in 1 .. 2 loop
17654                if Present (Args (J)) then
17655                   Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
17656                end if;
17657             end loop;
17658 
17659             Check_In_Main_Program;
17660 
17661             Nod := Next (N);
17662             while Present (Nod) loop
17663                if Nkind (Nod) = N_Pragma
17664                  and then Pragma_Name (Nod) = Name_Main_Storage
17665                then
17666                   Error_Msg_Name_1 := Pname;
17667                   Error_Msg_N ("duplicate pragma% not permitted", Nod);
17668                end if;
17669 
17670                Next (Nod);
17671             end loop;
17672          end Main_Storage;
17673 
17674          -----------------
17675          -- Memory_Size --
17676          -----------------
17677 
17678          --  pragma Memory_Size (NUMERIC_LITERAL)
17679 
17680          when Pragma_Memory_Size =>
17681             GNAT_Pragma;
17682 
17683             --  Memory size is simply ignored
17684 
17685             Check_No_Identifiers;
17686             Check_Arg_Count (1);
17687             Check_Arg_Is_Integer_Literal (Arg1);
17688 
17689          -------------
17690          -- No_Body --
17691          -------------
17692 
17693          --  pragma No_Body;
17694 
17695          --  The only correct use of this pragma is on its own in a file, in
17696          --  which case it is specially processed (see Gnat1drv.Check_Bad_Body
17697          --  and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
17698          --  check for a file containing nothing but a No_Body pragma). If we
17699          --  attempt to process it during normal semantics processing, it means
17700          --  it was misplaced.
17701 
17702          when Pragma_No_Body =>
17703             GNAT_Pragma;
17704             Pragma_Misplaced;
17705 
17706          -----------------------------
17707          -- No_Elaboration_Code_All --
17708          -----------------------------
17709 
17710          --  pragma No_Elaboration_Code_All;
17711 
17712          when Pragma_No_Elaboration_Code_All =>
17713             GNAT_Pragma;
17714             Check_Valid_Library_Unit_Pragma;
17715 
17716             if Nkind (N) = N_Null_Statement then
17717                return;
17718             end if;
17719 
17720             --  Must appear for a spec or generic spec
17721 
17722             if not Nkind_In (Unit (Cunit (Current_Sem_Unit)),
17723                              N_Generic_Package_Declaration,
17724                              N_Generic_Subprogram_Declaration,
17725                              N_Package_Declaration,
17726                              N_Subprogram_Declaration)
17727             then
17728                Error_Pragma
17729                  (Fix_Error
17730                     ("pragma% can only occur for package "
17731                      & "or subprogram spec"));
17732             end if;
17733 
17734             --  Set flag in unit table
17735 
17736             Set_No_Elab_Code_All (Current_Sem_Unit);
17737 
17738             --  Set restriction No_Elaboration_Code if this is the main unit
17739 
17740             if Current_Sem_Unit = Main_Unit then
17741                Set_Restriction (No_Elaboration_Code, N);
17742             end if;
17743 
17744             --  If we are in the main unit or in an extended main source unit,
17745             --  then we also add it to the configuration restrictions so that
17746             --  it will apply to all units in the extended main source.
17747 
17748             if Current_Sem_Unit = Main_Unit
17749               or else In_Extended_Main_Source_Unit (N)
17750             then
17751                Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
17752             end if;
17753 
17754             --  If in main extended unit, activate transitive with test
17755 
17756             if In_Extended_Main_Source_Unit (N) then
17757                Opt.No_Elab_Code_All_Pragma := N;
17758             end if;
17759 
17760          ---------------
17761          -- No_Inline --
17762          ---------------
17763 
17764          --  pragma No_Inline ( NAME {, NAME} );
17765 
17766          when Pragma_No_Inline =>
17767             GNAT_Pragma;
17768             Process_Inline (Suppressed);
17769 
17770          ---------------
17771          -- No_Return --
17772          ---------------
17773 
17774          --  pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
17775 
17776          when Pragma_No_Return => No_Return : declare
17777             Arg   : Node_Id;
17778             E     : Entity_Id;
17779             Found : Boolean;
17780             Id    : Node_Id;
17781 
17782             Ghost_Error_Posted : Boolean := False;
17783             --  Flag set when an error concerning the illegal mix of Ghost and
17784             --  non-Ghost subprograms is emitted.
17785 
17786             Ghost_Id : Entity_Id := Empty;
17787             --  The entity of the first Ghost procedure encountered while
17788             --  processing the arguments of the pragma.
17789 
17790          begin
17791             Ada_2005_Pragma;
17792             Check_At_Least_N_Arguments (1);
17793 
17794             --  Loop through arguments of pragma
17795 
17796             Arg := Arg1;
17797             while Present (Arg) loop
17798                Check_Arg_Is_Local_Name (Arg);
17799                Id := Get_Pragma_Arg (Arg);
17800                Analyze (Id);
17801 
17802                if not Is_Entity_Name (Id) then
17803                   Error_Pragma_Arg ("entity name required", Arg);
17804                end if;
17805 
17806                if Etype (Id) = Any_Type then
17807                   raise Pragma_Exit;
17808                end if;
17809 
17810                --  Loop to find matching procedures
17811 
17812                E := Entity (Id);
17813 
17814                Found := False;
17815                while Present (E)
17816                  and then Scope (E) = Current_Scope
17817                loop
17818                   if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
17819                      Set_No_Return (E);
17820 
17821                      --  A pragma that applies to a Ghost entity becomes Ghost
17822                      --  for the purposes of legality checks and removal of
17823                      --  ignored Ghost code.
17824 
17825                      Mark_Pragma_As_Ghost (N, E);
17826 
17827                      --  Capture the entity of the first Ghost procedure being
17828                      --  processed for error detection purposes.
17829 
17830                      if Is_Ghost_Entity (E) then
17831                         if No (Ghost_Id) then
17832                            Ghost_Id := E;
17833                         end if;
17834 
17835                      --  Otherwise the subprogram is non-Ghost. It is illegal
17836                      --  to mix references to Ghost and non-Ghost entities
17837                      --  (SPARK RM 6.9).
17838 
17839                      elsif Present (Ghost_Id)
17840                        and then not Ghost_Error_Posted
17841                      then
17842                         Ghost_Error_Posted := True;
17843 
17844                         Error_Msg_Name_1 := Pname;
17845                         Error_Msg_N
17846                           ("pragma % cannot mention ghost and non-ghost "
17847                            & "procedures", N);
17848 
17849                         Error_Msg_Sloc := Sloc (Ghost_Id);
17850                         Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
17851 
17852                         Error_Msg_Sloc := Sloc (E);
17853                         Error_Msg_NE ("\& # declared as non-ghost", N, E);
17854                      end if;
17855 
17856                      --  Set flag on any alias as well
17857 
17858                      if Is_Overloadable (E) and then Present (Alias (E)) then
17859                         Set_No_Return (Alias (E));
17860                      end if;
17861 
17862                      Found := True;
17863                   end if;
17864 
17865                   exit when From_Aspect_Specification (N);
17866                   E := Homonym (E);
17867                end loop;
17868 
17869                --  If entity in not in current scope it may be the enclosing
17870                --  suprogram body to which the aspect applies.
17871 
17872                if not Found then
17873                   if Entity (Id) = Current_Scope
17874                     and then From_Aspect_Specification (N)
17875                   then
17876                      Set_No_Return (Entity (Id));
17877                   else
17878                      Error_Pragma_Arg ("no procedure& found for pragma%", Arg);
17879                   end if;
17880                end if;
17881 
17882                Next (Arg);
17883             end loop;
17884          end No_Return;
17885 
17886          -----------------
17887          -- No_Run_Time --
17888          -----------------
17889 
17890          --  pragma No_Run_Time;
17891 
17892          --  Note: this pragma is retained for backwards compatibility. See
17893          --  body of Rtsfind for full details on its handling.
17894 
17895          when Pragma_No_Run_Time =>
17896             GNAT_Pragma;
17897             Check_Valid_Configuration_Pragma;
17898             Check_Arg_Count (0);
17899 
17900             --  Remove backward compatibility if Build_Type is FSF or GPL and
17901             --  generate a warning.
17902 
17903             declare
17904                Ignore : constant Boolean := Build_Type in FSF .. GPL;
17905             begin
17906                if Ignore then
17907                   Error_Pragma ("pragma% is ignored, has no effect??");
17908                else
17909                   No_Run_Time_Mode           := True;
17910                   Configurable_Run_Time_Mode := True;
17911 
17912                   --  Set Duration to 32 bits if word size is 32
17913 
17914                   if Ttypes.System_Word_Size = 32 then
17915                      Duration_32_Bits_On_Target := True;
17916                   end if;
17917 
17918                   --  Set appropriate restrictions
17919 
17920                   Set_Restriction (No_Finalization, N);
17921                   Set_Restriction (No_Exception_Handlers, N);
17922                   Set_Restriction (Max_Tasks, N, 0);
17923                   Set_Restriction (No_Tasking, N);
17924                end if;
17925             end;
17926 
17927          -----------------------
17928          -- No_Tagged_Streams --
17929          -----------------------
17930 
17931          --  pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
17932 
17933          when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
17934             E    : Entity_Id;
17935             E_Id : Node_Id;
17936 
17937          begin
17938             GNAT_Pragma;
17939             Check_At_Most_N_Arguments (1);
17940 
17941             --  One argument case
17942 
17943             if Arg_Count = 1 then
17944                Check_Optional_Identifier (Arg1, Name_Entity);
17945                Check_Arg_Is_Local_Name (Arg1);
17946                E_Id := Get_Pragma_Arg (Arg1);
17947 
17948                if Etype (E_Id) = Any_Type then
17949                   return;
17950                end if;
17951 
17952                E := Entity (E_Id);
17953 
17954                Check_Duplicate_Pragma (E);
17955 
17956                if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then
17957                   Error_Pragma_Arg
17958                     ("argument for pragma% must be root tagged type", Arg1);
17959                end if;
17960 
17961                if Rep_Item_Too_Early (E, N)
17962                     or else
17963                   Rep_Item_Too_Late (E, N)
17964                then
17965                   return;
17966                else
17967                   Set_No_Tagged_Streams_Pragma (E, N);
17968                end if;
17969 
17970             --  Zero argument case
17971 
17972             else
17973                Check_Is_In_Decl_Part_Or_Package_Spec;
17974                No_Tagged_Streams := N;
17975             end if;
17976          end No_Tagged_Strms;
17977 
17978          ------------------------
17979          -- No_Strict_Aliasing --
17980          ------------------------
17981 
17982          --  pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
17983 
17984          when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
17985             E_Id : Entity_Id;
17986 
17987          begin
17988             GNAT_Pragma;
17989             Check_At_Most_N_Arguments (1);
17990 
17991             if Arg_Count = 0 then
17992                Check_Valid_Configuration_Pragma;
17993                Opt.No_Strict_Aliasing := True;
17994 
17995             else
17996                Check_Optional_Identifier (Arg2, Name_Entity);
17997                Check_Arg_Is_Local_Name (Arg1);
17998                E_Id := Entity (Get_Pragma_Arg (Arg1));
17999 
18000                if E_Id = Any_Type then
18001                   return;
18002                elsif No (E_Id) or else not Is_Access_Type (E_Id) then
18003                   Error_Pragma_Arg ("pragma% requires access type", Arg1);
18004                end if;
18005 
18006                Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
18007             end if;
18008          end No_Strict_Aliasing;
18009 
18010          -----------------------
18011          -- Normalize_Scalars --
18012          -----------------------
18013 
18014          --  pragma Normalize_Scalars;
18015 
18016          when Pragma_Normalize_Scalars =>
18017             Check_Ada_83_Warning;
18018             Check_Arg_Count (0);
18019             Check_Valid_Configuration_Pragma;
18020 
18021             --  Normalize_Scalars creates false positives in CodePeer, and
18022             --  incorrect negative results in GNATprove mode, so ignore this
18023             --  pragma in these modes.
18024 
18025             if not (CodePeer_Mode or GNATprove_Mode) then
18026                Normalize_Scalars := True;
18027                Init_Or_Norm_Scalars := True;
18028             end if;
18029 
18030          -----------------
18031          -- Obsolescent --
18032          -----------------
18033 
18034          --  pragma Obsolescent;
18035 
18036          --  pragma Obsolescent (
18037          --    [Message =>] static_string_EXPRESSION
18038          --  [,[Version =>] Ada_05]]);
18039 
18040          --  pragma Obsolescent (
18041          --    [Entity  =>] NAME
18042          --  [,[Message =>] static_string_EXPRESSION
18043          --  [,[Version =>] Ada_05]] );
18044 
18045          when Pragma_Obsolescent => Obsolescent : declare
18046             Decl  : Node_Id;
18047             Ename : Node_Id;
18048 
18049             procedure Set_Obsolescent (E : Entity_Id);
18050             --  Given an entity Ent, mark it as obsolescent if appropriate
18051 
18052             ---------------------
18053             -- Set_Obsolescent --
18054             ---------------------
18055 
18056             procedure Set_Obsolescent (E : Entity_Id) is
18057                Active : Boolean;
18058                Ent    : Entity_Id;
18059                S      : String_Id;
18060 
18061             begin
18062                Active := True;
18063                Ent    := E;
18064 
18065                --  A pragma that applies to a Ghost entity becomes Ghost for
18066                --  the purposes of legality checks and removal of ignored Ghost
18067                --  code.
18068 
18069                Mark_Pragma_As_Ghost (N, E);
18070 
18071                --  Entity name was given
18072 
18073                if Present (Ename) then
18074 
18075                   --  If entity name matches, we are fine. Save entity in
18076                   --  pragma argument, for ASIS use.
18077 
18078                   if Chars (Ename) = Chars (Ent) then
18079                      Set_Entity (Ename, Ent);
18080                      Generate_Reference (Ent, Ename);
18081 
18082                   --  If entity name does not match, only possibility is an
18083                   --  enumeration literal from an enumeration type declaration.
18084 
18085                   elsif Ekind (Ent) /= E_Enumeration_Type then
18086                      Error_Pragma
18087                        ("pragma % entity name does not match declaration");
18088 
18089                   else
18090                      Ent := First_Literal (E);
18091                      loop
18092                         if No (Ent) then
18093                            Error_Pragma
18094                              ("pragma % entity name does not match any "
18095                               & "enumeration literal");
18096 
18097                         elsif Chars (Ent) = Chars (Ename) then
18098                            Set_Entity (Ename, Ent);
18099                            Generate_Reference (Ent, Ename);
18100                            exit;
18101 
18102                         else
18103                            Ent := Next_Literal (Ent);
18104                         end if;
18105                      end loop;
18106                   end if;
18107                end if;
18108 
18109                --  Ent points to entity to be marked
18110 
18111                if Arg_Count >= 1 then
18112 
18113                   --  Deal with static string argument
18114 
18115                   Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
18116                   S := Strval (Get_Pragma_Arg (Arg1));
18117 
18118                   for J in 1 .. String_Length (S) loop
18119                      if not In_Character_Range (Get_String_Char (S, J)) then
18120                         Error_Pragma_Arg
18121                           ("pragma% argument does not allow wide characters",
18122                            Arg1);
18123                      end if;
18124                   end loop;
18125 
18126                   Obsolescent_Warnings.Append
18127                     ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
18128 
18129                   --  Check for Ada_05 parameter
18130 
18131                   if Arg_Count /= 1 then
18132                      Check_Arg_Count (2);
18133 
18134                      declare
18135                         Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
18136 
18137                      begin
18138                         Check_Arg_Is_Identifier (Argx);
18139 
18140                         if Chars (Argx) /= Name_Ada_05 then
18141                            Error_Msg_Name_2 := Name_Ada_05;
18142                            Error_Pragma_Arg
18143                              ("only allowed argument for pragma% is %", Argx);
18144                         end if;
18145 
18146                         if Ada_Version_Explicit < Ada_2005
18147                           or else not Warn_On_Ada_2005_Compatibility
18148                         then
18149                            Active := False;
18150                         end if;
18151                      end;
18152                   end if;
18153                end if;
18154 
18155                --  Set flag if pragma active
18156 
18157                if Active then
18158                   Set_Is_Obsolescent (Ent);
18159                end if;
18160 
18161                return;
18162             end Set_Obsolescent;
18163 
18164          --  Start of processing for pragma Obsolescent
18165 
18166          begin
18167             GNAT_Pragma;
18168 
18169             Check_At_Most_N_Arguments (3);
18170 
18171             --  See if first argument specifies an entity name
18172 
18173             if Arg_Count >= 1
18174               and then
18175                 (Chars (Arg1) = Name_Entity
18176                    or else
18177                      Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
18178                                                       N_Identifier,
18179                                                       N_Operator_Symbol))
18180             then
18181                Ename := Get_Pragma_Arg (Arg1);
18182 
18183                --  Eliminate first argument, so we can share processing
18184 
18185                Arg1 := Arg2;
18186                Arg2 := Arg3;
18187                Arg_Count := Arg_Count - 1;
18188 
18189             --  No Entity name argument given
18190 
18191             else
18192                Ename := Empty;
18193             end if;
18194 
18195             if Arg_Count >= 1 then
18196                Check_Optional_Identifier (Arg1, Name_Message);
18197 
18198                if Arg_Count = 2 then
18199                   Check_Optional_Identifier (Arg2, Name_Version);
18200                end if;
18201             end if;
18202 
18203             --  Get immediately preceding declaration
18204 
18205             Decl := Prev (N);
18206             while Present (Decl) and then Nkind (Decl) = N_Pragma loop
18207                Prev (Decl);
18208             end loop;
18209 
18210             --  Cases where we do not follow anything other than another pragma
18211 
18212             if No (Decl) then
18213 
18214                --  First case: library level compilation unit declaration with
18215                --  the pragma immediately following the declaration.
18216 
18217                if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
18218                   Set_Obsolescent
18219                     (Defining_Entity (Unit (Parent (Parent (N)))));
18220                   return;
18221 
18222                --  Case 2: library unit placement for package
18223 
18224                else
18225                   declare
18226                      Ent : constant Entity_Id := Find_Lib_Unit_Name;
18227                   begin
18228                      if Is_Package_Or_Generic_Package (Ent) then
18229                         Set_Obsolescent (Ent);
18230                         return;
18231                      end if;
18232                   end;
18233                end if;
18234 
18235             --  Cases where we must follow a declaration, including an
18236             --  abstract subprogram declaration, which is not in the
18237             --  other node subtypes.
18238 
18239             else
18240                if         Nkind (Decl) not in N_Declaration
18241                  and then Nkind (Decl) not in N_Later_Decl_Item
18242                  and then Nkind (Decl) not in N_Generic_Declaration
18243                  and then Nkind (Decl) not in N_Renaming_Declaration
18244                  and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration
18245                then
18246                   Error_Pragma
18247                     ("pragma% misplaced, "
18248                      & "must immediately follow a declaration");
18249 
18250                else
18251                   Set_Obsolescent (Defining_Entity (Decl));
18252                   return;
18253                end if;
18254             end if;
18255          end Obsolescent;
18256 
18257          --------------
18258          -- Optimize --
18259          --------------
18260 
18261          --  pragma Optimize (Time | Space | Off);
18262 
18263          --  The actual check for optimize is done in Gigi. Note that this
18264          --  pragma does not actually change the optimization setting, it
18265          --  simply checks that it is consistent with the pragma.
18266 
18267          when Pragma_Optimize =>
18268             Check_No_Identifiers;
18269             Check_Arg_Count (1);
18270             Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
18271 
18272          ------------------------
18273          -- Optimize_Alignment --
18274          ------------------------
18275 
18276          --  pragma Optimize_Alignment (Time | Space | Off);
18277 
18278          when Pragma_Optimize_Alignment => Optimize_Alignment : begin
18279             GNAT_Pragma;
18280             Check_No_Identifiers;
18281             Check_Arg_Count (1);
18282             Check_Valid_Configuration_Pragma;
18283 
18284             declare
18285                Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
18286             begin
18287                case Nam is
18288                   when Name_Time =>
18289                      Opt.Optimize_Alignment := 'T';
18290                   when Name_Space =>
18291                      Opt.Optimize_Alignment := 'S';
18292                   when Name_Off =>
18293                      Opt.Optimize_Alignment := 'O';
18294                   when others =>
18295                      Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
18296                end case;
18297             end;
18298 
18299             --  Set indication that mode is set locally. If we are in fact in a
18300             --  configuration pragma file, this setting is harmless since the
18301             --  switch will get reset anyway at the start of each unit.
18302 
18303             Optimize_Alignment_Local := True;
18304          end Optimize_Alignment;
18305 
18306          -------------
18307          -- Ordered --
18308          -------------
18309 
18310          --  pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
18311 
18312          when Pragma_Ordered => Ordered : declare
18313             Assoc   : constant Node_Id := Arg1;
18314             Type_Id : Node_Id;
18315             Typ     : Entity_Id;
18316 
18317          begin
18318             GNAT_Pragma;
18319             Check_No_Identifiers;
18320             Check_Arg_Count (1);
18321             Check_Arg_Is_Local_Name (Arg1);
18322 
18323             Type_Id := Get_Pragma_Arg (Assoc);
18324             Find_Type (Type_Id);
18325             Typ := Entity (Type_Id);
18326 
18327             if Typ = Any_Type then
18328                return;
18329             else
18330                Typ := Underlying_Type (Typ);
18331             end if;
18332 
18333             if not Is_Enumeration_Type (Typ) then
18334                Error_Pragma ("pragma% must specify enumeration type");
18335             end if;
18336 
18337             Check_First_Subtype (Arg1);
18338             Set_Has_Pragma_Ordered (Base_Type (Typ));
18339          end Ordered;
18340 
18341          -------------------
18342          -- Overflow_Mode --
18343          -------------------
18344 
18345          --  pragma Overflow_Mode
18346          --    ([General => ] MODE [, [Assertions => ] MODE]);
18347 
18348          --  MODE := STRICT | MINIMIZED | ELIMINATED
18349 
18350          --  Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
18351          --  since System.Bignums makes this assumption. This is true of nearly
18352          --  all (all?) targets.
18353 
18354          when Pragma_Overflow_Mode => Overflow_Mode : declare
18355             function Get_Overflow_Mode
18356               (Name : Name_Id;
18357                Arg  : Node_Id) return Overflow_Mode_Type;
18358             --  Function to process one pragma argument, Arg. If an identifier
18359             --  is present, it must be Name. Mode type is returned if a valid
18360             --  argument exists, otherwise an error is signalled.
18361 
18362             -----------------------
18363             -- Get_Overflow_Mode --
18364             -----------------------
18365 
18366             function Get_Overflow_Mode
18367               (Name : Name_Id;
18368                Arg  : Node_Id) return Overflow_Mode_Type
18369             is
18370                Argx : constant Node_Id := Get_Pragma_Arg (Arg);
18371 
18372             begin
18373                Check_Optional_Identifier (Arg, Name);
18374                Check_Arg_Is_Identifier (Argx);
18375 
18376                if Chars (Argx) = Name_Strict then
18377                   return Strict;
18378 
18379                elsif Chars (Argx) = Name_Minimized then
18380                   return Minimized;
18381 
18382                elsif Chars (Argx) = Name_Eliminated then
18383                   if Ttypes.Standard_Long_Long_Integer_Size /= 64 then
18384                      Error_Pragma_Arg
18385                        ("Eliminated not implemented on this target", Argx);
18386                   else
18387                      return Eliminated;
18388                   end if;
18389 
18390                else
18391                   Error_Pragma_Arg ("invalid argument for pragma%", Argx);
18392                end if;
18393             end Get_Overflow_Mode;
18394 
18395          --  Start of processing for Overflow_Mode
18396 
18397          begin
18398             GNAT_Pragma;
18399             Check_At_Least_N_Arguments (1);
18400             Check_At_Most_N_Arguments  (2);
18401 
18402             --  Process first argument
18403 
18404             Scope_Suppress.Overflow_Mode_General :=
18405               Get_Overflow_Mode (Name_General, Arg1);
18406 
18407             --  Case of only one argument
18408 
18409             if Arg_Count = 1 then
18410                Scope_Suppress.Overflow_Mode_Assertions :=
18411                  Scope_Suppress.Overflow_Mode_General;
18412 
18413             --  Case of two arguments present
18414 
18415             else
18416                Scope_Suppress.Overflow_Mode_Assertions  :=
18417                  Get_Overflow_Mode (Name_Assertions, Arg2);
18418             end if;
18419          end Overflow_Mode;
18420 
18421          --------------------------
18422          -- Overriding Renamings --
18423          --------------------------
18424 
18425          --  pragma Overriding_Renamings;
18426 
18427          when Pragma_Overriding_Renamings =>
18428             GNAT_Pragma;
18429             Check_Arg_Count (0);
18430             Check_Valid_Configuration_Pragma;
18431             Overriding_Renamings := True;
18432 
18433          ----------
18434          -- Pack --
18435          ----------
18436 
18437          --  pragma Pack (first_subtype_LOCAL_NAME);
18438 
18439          when Pragma_Pack => Pack : declare
18440             Assoc   : constant Node_Id := Arg1;
18441             Ctyp    : Entity_Id;
18442             Ignore  : Boolean := False;
18443             Typ     : Entity_Id;
18444             Type_Id : Node_Id;
18445 
18446          begin
18447             Check_No_Identifiers;
18448             Check_Arg_Count (1);
18449             Check_Arg_Is_Local_Name (Arg1);
18450             Type_Id := Get_Pragma_Arg (Assoc);
18451 
18452             if not Is_Entity_Name (Type_Id)
18453               or else not Is_Type (Entity (Type_Id))
18454             then
18455                Error_Pragma_Arg
18456                  ("argument for pragma% must be type or subtype", Arg1);
18457             end if;
18458 
18459             Find_Type (Type_Id);
18460             Typ := Entity (Type_Id);
18461 
18462             if Typ = Any_Type
18463               or else Rep_Item_Too_Early (Typ, N)
18464             then
18465                return;
18466             else
18467                Typ := Underlying_Type (Typ);
18468             end if;
18469 
18470             --  A pragma that applies to a Ghost entity becomes Ghost for the
18471             --  purposes of legality checks and removal of ignored Ghost code.
18472 
18473             Mark_Pragma_As_Ghost (N, Typ);
18474 
18475             if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
18476                Error_Pragma ("pragma% must specify array or record type");
18477             end if;
18478 
18479             Check_First_Subtype (Arg1);
18480             Check_Duplicate_Pragma (Typ);
18481 
18482             --  Array type
18483 
18484             if Is_Array_Type (Typ) then
18485                Ctyp := Component_Type (Typ);
18486 
18487                --  Ignore pack that does nothing
18488 
18489                if Known_Static_Esize (Ctyp)
18490                  and then Known_Static_RM_Size (Ctyp)
18491                  and then Esize (Ctyp) = RM_Size (Ctyp)
18492                  and then Addressable (Esize (Ctyp))
18493                then
18494                   Ignore := True;
18495                end if;
18496 
18497                --  Process OK pragma Pack. Note that if there is a separate
18498                --  component clause present, the Pack will be cancelled. This
18499                --  processing is in Freeze.
18500 
18501                if not Rep_Item_Too_Late (Typ, N) then
18502 
18503                   --  In CodePeer mode, we do not need complex front-end
18504                   --  expansions related to pragma Pack, so disable handling
18505                   --  of pragma Pack.
18506 
18507                   if CodePeer_Mode then
18508                      null;
18509 
18510                   --  Normal case where we do the pack action
18511 
18512                   else
18513                      if not Ignore then
18514                         Set_Is_Packed            (Base_Type (Typ));
18515                         Set_Has_Non_Standard_Rep (Base_Type (Typ));
18516                      end if;
18517 
18518                      Set_Has_Pragma_Pack (Base_Type (Typ));
18519                   end if;
18520                end if;
18521 
18522             --  For record types, the pack is always effective
18523 
18524             else pragma Assert (Is_Record_Type (Typ));
18525                if not Rep_Item_Too_Late (Typ, N) then
18526                   Set_Is_Packed            (Base_Type (Typ));
18527                   Set_Has_Pragma_Pack      (Base_Type (Typ));
18528                   Set_Has_Non_Standard_Rep (Base_Type (Typ));
18529                end if;
18530             end if;
18531          end Pack;
18532 
18533          ----------
18534          -- Page --
18535          ----------
18536 
18537          --  pragma Page;
18538 
18539          --  There is nothing to do here, since we did all the processing for
18540          --  this pragma in Par.Prag (so that it works properly even in syntax
18541          --  only mode).
18542 
18543          when Pragma_Page =>
18544             null;
18545 
18546          -------------
18547          -- Part_Of --
18548          -------------
18549 
18550          --  pragma Part_Of (ABSTRACT_STATE);
18551 
18552          --  ABSTRACT_STATE ::= NAME
18553 
18554          when Pragma_Part_Of => Part_Of : declare
18555             procedure Propagate_Part_Of
18556               (Pack_Id  : Entity_Id;
18557                State_Id : Entity_Id;
18558                Instance : Node_Id);
18559             --  Propagate the Part_Of indicator to all abstract states and
18560             --  objects declared in the visible state space of a package
18561             --  denoted by Pack_Id. State_Id is the encapsulating state.
18562             --  Instance is the package instantiation node.
18563 
18564             -----------------------
18565             -- Propagate_Part_Of --
18566             -----------------------
18567 
18568             procedure Propagate_Part_Of
18569               (Pack_Id  : Entity_Id;
18570                State_Id : Entity_Id;
18571                Instance : Node_Id)
18572             is
18573                Has_Item : Boolean := False;
18574                --  Flag set when the visible state space contains at least one
18575                --  abstract state or variable.
18576 
18577                procedure Propagate_Part_Of (Pack_Id : Entity_Id);
18578                --  Propagate the Part_Of indicator to all abstract states and
18579                --  objects declared in the visible state space of a package
18580                --  denoted by Pack_Id.
18581 
18582                -----------------------
18583                -- Propagate_Part_Of --
18584                -----------------------
18585 
18586                procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
18587                   Constits : Elist_Id;
18588                   Item_Id  : Entity_Id;
18589 
18590                begin
18591                   --  Traverse the entity chain of the package and set relevant
18592                   --  attributes of abstract states and objects declared in the
18593                   --  visible state space of the package.
18594 
18595                   Item_Id := First_Entity (Pack_Id);
18596                   while Present (Item_Id)
18597                     and then not In_Private_Part (Item_Id)
18598                   loop
18599                      --  Do not consider internally generated items
18600 
18601                      if not Comes_From_Source (Item_Id) then
18602                         null;
18603 
18604                      --  The Part_Of indicator turns an abstract state or an
18605                      --  object into a constituent of the encapsulating state.
18606 
18607                      elsif Ekind_In (Item_Id, E_Abstract_State,
18608                                               E_Constant,
18609                                               E_Variable)
18610                      then
18611                         Has_Item := True;
18612                         Constits := Part_Of_Constituents (State_Id);
18613 
18614                         if No (Constits) then
18615                            Constits := New_Elmt_List;
18616                            Set_Part_Of_Constituents (State_Id, Constits);
18617                         end if;
18618 
18619                         Append_Elmt (Item_Id, Constits);
18620                         Set_Encapsulating_State (Item_Id, State_Id);
18621 
18622                      --  Recursively handle nested packages and instantiations
18623 
18624                      elsif Ekind (Item_Id) = E_Package then
18625                         Propagate_Part_Of (Item_Id);
18626                      end if;
18627 
18628                      Next_Entity (Item_Id);
18629                   end loop;
18630                end Propagate_Part_Of;
18631 
18632             --  Start of processing for Propagate_Part_Of
18633 
18634             begin
18635                Propagate_Part_Of (Pack_Id);
18636 
18637                --  Detect a package instantiation that is subject to a Part_Of
18638                --  indicator, but has no visible state.
18639 
18640                if not Has_Item then
18641                   SPARK_Msg_NE
18642                     ("package instantiation & has Part_Of indicator but "
18643                      & "lacks visible state", Instance, Pack_Id);
18644                end if;
18645             end Propagate_Part_Of;
18646 
18647             --  Local variables
18648 
18649             Constits : Elist_Id;
18650             Encap    : Node_Id;
18651             Encap_Id : Entity_Id;
18652             Item_Id  : Entity_Id;
18653             Legal    : Boolean;
18654             Stmt     : Node_Id;
18655 
18656          --  Start of processing for Part_Of
18657 
18658          begin
18659             GNAT_Pragma;
18660             Check_No_Identifiers;
18661             Check_Arg_Count (1);
18662 
18663             Stmt := Find_Related_Context (N, Do_Checks => True);
18664 
18665             --  Object declaration
18666 
18667             if Nkind (Stmt) = N_Object_Declaration then
18668                null;
18669 
18670             --  Package instantiation
18671 
18672             elsif Nkind (Stmt) = N_Package_Instantiation then
18673                null;
18674 
18675             --  Single concurrent type declaration
18676 
18677             elsif Is_Single_Concurrent_Type_Declaration (Stmt) then
18678                null;
18679 
18680             --  Otherwise the pragma is associated with an illegal construct
18681 
18682             else
18683                Pragma_Misplaced;
18684                return;
18685             end if;
18686 
18687             --  Extract the entity of the related object declaration or package
18688             --  instantiation. In the case of the instantiation, use the entity
18689             --  of the instance spec.
18690 
18691             if Nkind (Stmt) = N_Package_Instantiation then
18692                Stmt := Instance_Spec (Stmt);
18693             end if;
18694 
18695             Item_Id := Defining_Entity (Stmt);
18696             Encap   := Get_Pragma_Arg (Arg1);
18697 
18698             --  A pragma that applies to a Ghost entity becomes Ghost for the
18699             --  purposes of legality checks and removal of ignored Ghost code.
18700 
18701             Mark_Pragma_As_Ghost (N, Item_Id);
18702 
18703             --  Chain the pragma on the contract for further processing by
18704             --  Analyze_Part_Of_In_Decl_Part or for completeness.
18705 
18706             Add_Contract_Item (N, Item_Id);
18707 
18708             --  A variable may act as consituent of a single concurrent type
18709             --  which in turn could be declared after the variable. Due to this
18710             --  discrepancy, the full analysis of indicator Part_Of is delayed
18711             --  until the end of the enclosing declarative region (see routine
18712             --  Analyze_Part_Of_In_Decl_Part).
18713 
18714             if Ekind (Item_Id) = E_Variable then
18715                null;
18716 
18717             --  Otherwise indicator Part_Of applies to a constant or a package
18718             --  instantiation.
18719 
18720             else
18721                --  Detect any discrepancies between the placement of the
18722                --  constant or package instantiation with respect to state
18723                --  space and the encapsulating state.
18724 
18725                Analyze_Part_Of
18726                  (Indic    => N,
18727                   Item_Id  => Item_Id,
18728                   Encap    => Encap,
18729                   Encap_Id => Encap_Id,
18730                   Legal    => Legal);
18731 
18732                if Legal then
18733                   pragma Assert (Present (Encap_Id));
18734 
18735                   if Ekind (Item_Id) = E_Constant then
18736                      Constits := Part_Of_Constituents (Encap_Id);
18737 
18738                      if No (Constits) then
18739                         Constits := New_Elmt_List;
18740                         Set_Part_Of_Constituents (Encap_Id, Constits);
18741                      end if;
18742 
18743                      Append_Elmt (Item_Id, Constits);
18744                      Set_Encapsulating_State (Item_Id, Encap_Id);
18745 
18746                   --  Propagate the Part_Of indicator to the visible state
18747                   --  space of the package instantiation.
18748 
18749                   else
18750                      Propagate_Part_Of
18751                        (Pack_Id  => Item_Id,
18752                         State_Id => Encap_Id,
18753                         Instance => Stmt);
18754                   end if;
18755                end if;
18756             end if;
18757          end Part_Of;
18758 
18759          ----------------------------------
18760          -- Partition_Elaboration_Policy --
18761          ----------------------------------
18762 
18763          --  pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
18764 
18765          when Pragma_Partition_Elaboration_Policy => declare
18766             subtype PEP_Range is Name_Id
18767               range First_Partition_Elaboration_Policy_Name
18768                  .. Last_Partition_Elaboration_Policy_Name;
18769             PEP_Val : PEP_Range;
18770             PEP     : Character;
18771 
18772          begin
18773             Ada_2005_Pragma;
18774             Check_Arg_Count (1);
18775             Check_No_Identifiers;
18776             Check_Arg_Is_Partition_Elaboration_Policy (Arg1);
18777             Check_Valid_Configuration_Pragma;
18778             PEP_Val := Chars (Get_Pragma_Arg (Arg1));
18779 
18780             case PEP_Val is
18781                when Name_Concurrent =>
18782                   PEP := 'C';
18783                when Name_Sequential =>
18784                   PEP := 'S';
18785             end case;
18786 
18787             if Partition_Elaboration_Policy /= ' '
18788               and then Partition_Elaboration_Policy /= PEP
18789             then
18790                Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc;
18791                Error_Pragma
18792                  ("partition elaboration policy incompatible with policy#");
18793 
18794             --  Set new policy, but always preserve System_Location since we
18795             --  like the error message with the run time name.
18796 
18797             else
18798                Partition_Elaboration_Policy := PEP;
18799 
18800                if Partition_Elaboration_Policy_Sloc /= System_Location then
18801                   Partition_Elaboration_Policy_Sloc := Loc;
18802                end if;
18803             end if;
18804          end;
18805 
18806          -------------
18807          -- Passive --
18808          -------------
18809 
18810          --  pragma Passive [(PASSIVE_FORM)];
18811 
18812          --  PASSIVE_FORM ::= Semaphore | No
18813 
18814          when Pragma_Passive =>
18815             GNAT_Pragma;
18816 
18817             if Nkind (Parent (N)) /= N_Task_Definition then
18818                Error_Pragma ("pragma% must be within task definition");
18819             end if;
18820 
18821             if Arg_Count /= 0 then
18822                Check_Arg_Count (1);
18823                Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
18824             end if;
18825 
18826          ----------------------------------
18827          -- Preelaborable_Initialization --
18828          ----------------------------------
18829 
18830          --  pragma Preelaborable_Initialization (DIRECT_NAME);
18831 
18832          when Pragma_Preelaborable_Initialization => Preelab_Init : declare
18833             Ent : Entity_Id;
18834 
18835          begin
18836             Ada_2005_Pragma;
18837             Check_Arg_Count (1);
18838             Check_No_Identifiers;
18839             Check_Arg_Is_Identifier (Arg1);
18840             Check_Arg_Is_Local_Name (Arg1);
18841             Check_First_Subtype (Arg1);
18842             Ent := Entity (Get_Pragma_Arg (Arg1));
18843 
18844             --  A pragma that applies to a Ghost entity becomes Ghost for the
18845             --  purposes of legality checks and removal of ignored Ghost code.
18846 
18847             Mark_Pragma_As_Ghost (N, Ent);
18848 
18849             --  The pragma may come from an aspect on a private declaration,
18850             --  even if the freeze point at which this is analyzed in the
18851             --  private part after the full view.
18852 
18853             if Has_Private_Declaration (Ent)
18854               and then From_Aspect_Specification (N)
18855             then
18856                null;
18857 
18858             --  Check appropriate type argument
18859 
18860             elsif Is_Private_Type (Ent)
18861               or else Is_Protected_Type (Ent)
18862               or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))
18863 
18864               --  AI05-0028: The pragma applies to all composite types. Note
18865               --  that we apply this binding interpretation to earlier versions
18866               --  of Ada, so there is no Ada 2012 guard. Seems a reasonable
18867               --  choice since there are other compilers that do the same.
18868 
18869               or else Is_Composite_Type (Ent)
18870             then
18871                null;
18872 
18873             else
18874                Error_Pragma_Arg
18875                  ("pragma % can only be applied to private, formal derived, "
18876                   & "protected, or composite type", Arg1);
18877             end if;
18878 
18879             --  Give an error if the pragma is applied to a protected type that
18880             --  does not qualify (due to having entries, or due to components
18881             --  that do not qualify).
18882 
18883             if Is_Protected_Type (Ent)
18884               and then not Has_Preelaborable_Initialization (Ent)
18885             then
18886                Error_Msg_N
18887                  ("protected type & does not have preelaborable "
18888                   & "initialization", Ent);
18889 
18890             --  Otherwise mark the type as definitely having preelaborable
18891             --  initialization.
18892 
18893             else
18894                Set_Known_To_Have_Preelab_Init (Ent);
18895             end if;
18896 
18897             if Has_Pragma_Preelab_Init (Ent)
18898               and then Warn_On_Redundant_Constructs
18899             then
18900                Error_Pragma ("?r?duplicate pragma%!");
18901             else
18902                Set_Has_Pragma_Preelab_Init (Ent);
18903             end if;
18904          end Preelab_Init;
18905 
18906          --------------------
18907          -- Persistent_BSS --
18908          --------------------
18909 
18910          --  pragma Persistent_BSS [(object_NAME)];
18911 
18912          when Pragma_Persistent_BSS => Persistent_BSS :  declare
18913             Decl : Node_Id;
18914             Ent  : Entity_Id;
18915             Prag : Node_Id;
18916 
18917          begin
18918             GNAT_Pragma;
18919             Check_At_Most_N_Arguments (1);
18920 
18921             --  Case of application to specific object (one argument)
18922 
18923             if Arg_Count = 1 then
18924                Check_Arg_Is_Library_Level_Local_Name (Arg1);
18925 
18926                if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
18927                  or else not
18928                    Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
18929                                                              E_Constant)
18930                then
18931                   Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
18932                end if;
18933 
18934                Ent := Entity (Get_Pragma_Arg (Arg1));
18935                Decl := Parent (Ent);
18936 
18937                --  A pragma that applies to a Ghost entity becomes Ghost for
18938                --  the purposes of legality checks and removal of ignored Ghost
18939                --  code.
18940 
18941                Mark_Pragma_As_Ghost (N, Ent);
18942 
18943                --  Check for duplication before inserting in list of
18944                --  representation items.
18945 
18946                Check_Duplicate_Pragma (Ent);
18947 
18948                if Rep_Item_Too_Late (Ent, N) then
18949                   return;
18950                end if;
18951 
18952                if Present (Expression (Decl)) then
18953                   Error_Pragma_Arg
18954                     ("object for pragma% cannot have initialization", Arg1);
18955                end if;
18956 
18957                if not Is_Potentially_Persistent_Type (Etype (Ent)) then
18958                   Error_Pragma_Arg
18959                     ("object type for pragma% is not potentially persistent",
18960                      Arg1);
18961                end if;
18962 
18963                Prag :=
18964                  Make_Linker_Section_Pragma
18965                    (Ent, Sloc (N), ".persistent.bss");
18966                Insert_After (N, Prag);
18967                Analyze (Prag);
18968 
18969             --  Case of use as configuration pragma with no arguments
18970 
18971             else
18972                Check_Valid_Configuration_Pragma;
18973                Persistent_BSS_Mode := True;
18974             end if;
18975          end Persistent_BSS;
18976 
18977          -------------
18978          -- Polling --
18979          -------------
18980 
18981          --  pragma Polling (ON | OFF);
18982 
18983          when Pragma_Polling =>
18984             GNAT_Pragma;
18985             Check_Arg_Count (1);
18986             Check_No_Identifiers;
18987             Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
18988             Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
18989 
18990          -----------------------------------
18991          -- Post/Post_Class/Postcondition --
18992          -----------------------------------
18993 
18994          --  pragma Post (Boolean_EXPRESSION);
18995          --  pragma Post_Class (Boolean_EXPRESSION);
18996          --  pragma Postcondition ([Check   =>] Boolean_EXPRESSION
18997          --                      [,[Message =>] String_EXPRESSION]);
18998 
18999          --  Characteristics:
19000 
19001          --    * Analysis - The annotation undergoes initial checks to verify
19002          --    the legal placement and context. Secondary checks preanalyze the
19003          --    expression in:
19004 
19005          --       Analyze_Pre_Post_Condition_In_Decl_Part
19006 
19007          --    * Expansion - The annotation is expanded during the expansion of
19008          --    the related subprogram [body] contract as performed in:
19009 
19010          --       Expand_Subprogram_Contract
19011 
19012          --    * Template - The annotation utilizes the generic template of the
19013          --    related subprogram [body] when it is:
19014 
19015          --       aspect on subprogram declaration
19016          --       aspect on stand alone subprogram body
19017          --       pragma on stand alone subprogram body
19018 
19019          --    The annotation must prepare its own template when it is:
19020 
19021          --       pragma on subprogram declaration
19022 
19023          --    * Globals - Capture of global references must occur after full
19024          --    analysis.
19025 
19026          --    * Instance - The annotation is instantiated automatically when
19027          --    the related generic subprogram [body] is instantiated except for
19028          --    the "pragma on subprogram declaration" case. In that scenario
19029          --    the annotation must instantiate itself.
19030 
19031          when Pragma_Post          |
19032               Pragma_Post_Class    |
19033               Pragma_Postcondition =>
19034             Analyze_Pre_Post_Condition;
19035 
19036          --------------------------------
19037          -- Pre/Pre_Class/Precondition --
19038          --------------------------------
19039 
19040          --  pragma Pre (Boolean_EXPRESSION);
19041          --  pragma Pre_Class (Boolean_EXPRESSION);
19042          --  pragma Precondition ([Check   =>] Boolean_EXPRESSION
19043          --                     [,[Message =>] String_EXPRESSION]);
19044 
19045          --  Characteristics:
19046 
19047          --    * Analysis - The annotation undergoes initial checks to verify
19048          --    the legal placement and context. Secondary checks preanalyze the
19049          --    expression in:
19050 
19051          --       Analyze_Pre_Post_Condition_In_Decl_Part
19052 
19053          --    * Expansion - The annotation is expanded during the expansion of
19054          --    the related subprogram [body] contract as performed in:
19055 
19056          --       Expand_Subprogram_Contract
19057 
19058          --    * Template - The annotation utilizes the generic template of the
19059          --    related subprogram [body] when it is:
19060 
19061          --       aspect on subprogram declaration
19062          --       aspect on stand alone subprogram body
19063          --       pragma on stand alone subprogram body
19064 
19065          --    The annotation must prepare its own template when it is:
19066 
19067          --       pragma on subprogram declaration
19068 
19069          --    * Globals - Capture of global references must occur after full
19070          --    analysis.
19071 
19072          --    * Instance - The annotation is instantiated automatically when
19073          --    the related generic subprogram [body] is instantiated except for
19074          --    the "pragma on subprogram declaration" case. In that scenario
19075          --    the annotation must instantiate itself.
19076 
19077          when Pragma_Pre          |
19078               Pragma_Pre_Class    |
19079               Pragma_Precondition =>
19080             Analyze_Pre_Post_Condition;
19081 
19082          ---------------
19083          -- Predicate --
19084          ---------------
19085 
19086          --  pragma Predicate
19087          --    ([Entity =>] type_LOCAL_NAME,
19088          --     [Check  =>] boolean_EXPRESSION);
19089 
19090          when Pragma_Predicate => Predicate : declare
19091             Discard : Boolean;
19092             Typ     : Entity_Id;
19093             Type_Id : Node_Id;
19094 
19095          begin
19096             GNAT_Pragma;
19097             Check_Arg_Count (2);
19098             Check_Optional_Identifier (Arg1, Name_Entity);
19099             Check_Optional_Identifier (Arg2, Name_Check);
19100 
19101             Check_Arg_Is_Local_Name (Arg1);
19102 
19103             Type_Id := Get_Pragma_Arg (Arg1);
19104             Find_Type (Type_Id);
19105             Typ := Entity (Type_Id);
19106 
19107             if Typ = Any_Type then
19108                return;
19109             end if;
19110 
19111             --  A pragma that applies to a Ghost entity becomes Ghost for the
19112             --  purposes of legality checks and removal of ignored Ghost code.
19113 
19114             Mark_Pragma_As_Ghost (N, Typ);
19115 
19116             --  The remaining processing is simply to link the pragma on to
19117             --  the rep item chain, for processing when the type is frozen.
19118             --  This is accomplished by a call to Rep_Item_Too_Late. We also
19119             --  mark the type as having predicates.
19120             --  If the current policy is Ignore mark the subtype accordingly.
19121             --  In the case of predicates we consider them enabled unless an
19122             --  Ignore is specified, to preserve existing warnings.
19123 
19124             Set_Has_Predicates (Typ);
19125             Set_Predicates_Ignored (Typ,
19126               Present (Check_Policy_List)
19127                 and then
19128                   Policy_In_Effect (Name_Assertion_Policy) = Name_Ignore);
19129             Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
19130          end Predicate;
19131 
19132          -----------------------
19133          -- Predicate_Failure --
19134          -----------------------
19135 
19136          --  pragma Predicate_Failure
19137          --    ([Entity  =>] type_LOCAL_NAME,
19138          --     [Message =>] string_EXPRESSION);
19139 
19140          when Pragma_Predicate_Failure => Predicate_Failure : declare
19141             Discard : Boolean;
19142             Typ     : Entity_Id;
19143             Type_Id : Node_Id;
19144 
19145          begin
19146             GNAT_Pragma;
19147             Check_Arg_Count (2);
19148             Check_Optional_Identifier (Arg1, Name_Entity);
19149             Check_Optional_Identifier (Arg2, Name_Message);
19150 
19151             Check_Arg_Is_Local_Name (Arg1);
19152 
19153             Type_Id := Get_Pragma_Arg (Arg1);
19154             Find_Type (Type_Id);
19155             Typ := Entity (Type_Id);
19156 
19157             if Typ = Any_Type then
19158                return;
19159             end if;
19160 
19161             --  A pragma that applies to a Ghost entity becomes Ghost for the
19162             --  purposes of legality checks and removal of ignored Ghost code.
19163 
19164             Mark_Pragma_As_Ghost (N, Typ);
19165 
19166             --  The remaining processing is simply to link the pragma on to
19167             --  the rep item chain, for processing when the type is frozen.
19168             --  This is accomplished by a call to Rep_Item_Too_Late.
19169 
19170             Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
19171          end Predicate_Failure;
19172 
19173          ------------------
19174          -- Preelaborate --
19175          ------------------
19176 
19177          --  pragma Preelaborate [(library_unit_NAME)];
19178 
19179          --  Set the flag Is_Preelaborated of program unit name entity
19180 
19181          when Pragma_Preelaborate => Preelaborate : declare
19182             Pa  : constant Node_Id   := Parent (N);
19183             Pk  : constant Node_Kind := Nkind (Pa);
19184             Ent : Entity_Id;
19185 
19186          begin
19187             Check_Ada_83_Warning;
19188             Check_Valid_Library_Unit_Pragma;
19189 
19190             if Nkind (N) = N_Null_Statement then
19191                return;
19192             end if;
19193 
19194             Ent := Find_Lib_Unit_Name;
19195 
19196             --  A pragma that applies to a Ghost entity becomes Ghost for the
19197             --  purposes of legality checks and removal of ignored Ghost code.
19198 
19199             Mark_Pragma_As_Ghost (N, Ent);
19200             Check_Duplicate_Pragma (Ent);
19201 
19202             --  This filters out pragmas inside generic parents that show up
19203             --  inside instantiations. Pragmas that come from aspects in the
19204             --  unit are not ignored.
19205 
19206             if Present (Ent) then
19207                if Pk = N_Package_Specification
19208                  and then Present (Generic_Parent (Pa))
19209                  and then not From_Aspect_Specification (N)
19210                then
19211                   null;
19212 
19213                else
19214                   if not Debug_Flag_U then
19215                      Set_Is_Preelaborated (Ent);
19216                      Set_Suppress_Elaboration_Warnings (Ent);
19217                   end if;
19218                end if;
19219             end if;
19220          end Preelaborate;
19221 
19222          -------------------------------
19223          -- Prefix_Exception_Messages --
19224          -------------------------------
19225 
19226          --  pragma Prefix_Exception_Messages;
19227 
19228          when Pragma_Prefix_Exception_Messages =>
19229             GNAT_Pragma;
19230             Check_Valid_Configuration_Pragma;
19231             Check_Arg_Count (0);
19232             Prefix_Exception_Messages := True;
19233 
19234          --------------
19235          -- Priority --
19236          --------------
19237 
19238          --  pragma Priority (EXPRESSION);
19239 
19240          when Pragma_Priority => Priority : declare
19241             P   : constant Node_Id := Parent (N);
19242             Arg : Node_Id;
19243             Ent : Entity_Id;
19244 
19245          begin
19246             Check_No_Identifiers;
19247             Check_Arg_Count (1);
19248 
19249             --  Subprogram case
19250 
19251             if Nkind (P) = N_Subprogram_Body then
19252                Check_In_Main_Program;
19253 
19254                Ent := Defining_Unit_Name (Specification (P));
19255 
19256                if Nkind (Ent) = N_Defining_Program_Unit_Name then
19257                   Ent := Defining_Identifier (Ent);
19258                end if;
19259 
19260                Arg := Get_Pragma_Arg (Arg1);
19261                Analyze_And_Resolve (Arg, Standard_Integer);
19262 
19263                --  Must be static
19264 
19265                if not Is_OK_Static_Expression (Arg) then
19266                   Flag_Non_Static_Expr
19267                     ("main subprogram priority is not static!", Arg);
19268                   raise Pragma_Exit;
19269 
19270                --  If constraint error, then we already signalled an error
19271 
19272                elsif Raises_Constraint_Error (Arg) then
19273                   null;
19274 
19275                --  Otherwise check in range except if Relaxed_RM_Semantics
19276                --  where we ignore the value if out of range.
19277 
19278                else
19279                   if not Relaxed_RM_Semantics
19280                     and then not Is_In_Range (Arg, RTE (RE_Priority))
19281                   then
19282                      Error_Pragma_Arg
19283                        ("main subprogram priority is out of range", Arg1);
19284                   else
19285                      Set_Main_Priority
19286                        (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
19287                   end if;
19288                end if;
19289 
19290                --  Load an arbitrary entity from System.Tasking.Stages or
19291                --  System.Tasking.Restricted.Stages (depending on the
19292                --  supported profile) to make sure that one of these packages
19293                --  is implicitly with'ed, since we need to have the tasking
19294                --  run time active for the pragma Priority to have any effect.
19295                --  Previously we with'ed the package System.Tasking, but this
19296                --  package does not trigger the required initialization of the
19297                --  run-time library.
19298 
19299                declare
19300                   Discard : Entity_Id;
19301                   pragma Warnings (Off, Discard);
19302                begin
19303                   if Restricted_Profile then
19304                      Discard := RTE (RE_Activate_Restricted_Tasks);
19305                   else
19306                      Discard := RTE (RE_Activate_Tasks);
19307                   end if;
19308                end;
19309 
19310             --  Task or Protected, must be of type Integer
19311 
19312             elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
19313                Arg := Get_Pragma_Arg (Arg1);
19314                Ent := Defining_Identifier (Parent (P));
19315 
19316                --  The expression must be analyzed in the special manner
19317                --  described in "Handling of Default and Per-Object
19318                --  Expressions" in sem.ads.
19319 
19320                Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority));
19321 
19322                if not Is_OK_Static_Expression (Arg) then
19323                   Check_Restriction (Static_Priorities, Arg);
19324                end if;
19325 
19326             --  Anything else is incorrect
19327 
19328             else
19329                Pragma_Misplaced;
19330             end if;
19331 
19332             --  Check duplicate pragma before we chain the pragma in the Rep
19333             --  Item chain of Ent.
19334 
19335             Check_Duplicate_Pragma (Ent);
19336             Record_Rep_Item (Ent, N);
19337          end Priority;
19338 
19339          -----------------------------------
19340          -- Priority_Specific_Dispatching --
19341          -----------------------------------
19342 
19343          --  pragma Priority_Specific_Dispatching (
19344          --    policy_IDENTIFIER,
19345          --    first_priority_EXPRESSION,
19346          --    last_priority_EXPRESSION);
19347 
19348          when Pragma_Priority_Specific_Dispatching =>
19349          Priority_Specific_Dispatching : declare
19350             Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
19351             --  This is the entity System.Any_Priority;
19352 
19353             DP          : Character;
19354             Lower_Bound : Node_Id;
19355             Upper_Bound : Node_Id;
19356             Lower_Val   : Uint;
19357             Upper_Val   : Uint;
19358 
19359          begin
19360             Ada_2005_Pragma;
19361             Check_Arg_Count (3);
19362             Check_No_Identifiers;
19363             Check_Arg_Is_Task_Dispatching_Policy (Arg1);
19364             Check_Valid_Configuration_Pragma;
19365             Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19366             DP := Fold_Upper (Name_Buffer (1));
19367 
19368             Lower_Bound := Get_Pragma_Arg (Arg2);
19369             Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
19370             Lower_Val := Expr_Value (Lower_Bound);
19371 
19372             Upper_Bound := Get_Pragma_Arg (Arg3);
19373             Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
19374             Upper_Val := Expr_Value (Upper_Bound);
19375 
19376             --  It is not allowed to use Task_Dispatching_Policy and
19377             --  Priority_Specific_Dispatching in the same partition.
19378 
19379             if Task_Dispatching_Policy /= ' ' then
19380                Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19381                Error_Pragma
19382                  ("pragma% incompatible with Task_Dispatching_Policy#");
19383 
19384             --  Check lower bound in range
19385 
19386             elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19387                     or else
19388                   Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
19389             then
19390                Error_Pragma_Arg
19391                  ("first_priority is out of range", Arg2);
19392 
19393             --  Check upper bound in range
19394 
19395             elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
19396                     or else
19397                   Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
19398             then
19399                Error_Pragma_Arg
19400                  ("last_priority is out of range", Arg3);
19401 
19402             --  Check that the priority range is valid
19403 
19404             elsif Lower_Val > Upper_Val then
19405                Error_Pragma
19406                  ("last_priority_expression must be greater than or equal to "
19407                   & "first_priority_expression");
19408 
19409             --  Store the new policy, but always preserve System_Location since
19410             --  we like the error message with the run-time name.
19411 
19412             else
19413                --  Check overlapping in the priority ranges specified in other
19414                --  Priority_Specific_Dispatching pragmas within the same
19415                --  partition. We can only check those we know about.
19416 
19417                for J in
19418                   Specific_Dispatching.First .. Specific_Dispatching.Last
19419                loop
19420                   if Specific_Dispatching.Table (J).First_Priority in
19421                     UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19422                   or else Specific_Dispatching.Table (J).Last_Priority in
19423                     UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
19424                   then
19425                      Error_Msg_Sloc :=
19426                        Specific_Dispatching.Table (J).Pragma_Loc;
19427                         Error_Pragma
19428                           ("priority range overlaps with "
19429                            & "Priority_Specific_Dispatching#");
19430                   end if;
19431                end loop;
19432 
19433                --  The use of Priority_Specific_Dispatching is incompatible
19434                --  with Task_Dispatching_Policy.
19435 
19436                if Task_Dispatching_Policy /= ' ' then
19437                   Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
19438                      Error_Pragma
19439                        ("Priority_Specific_Dispatching incompatible "
19440                         & "with Task_Dispatching_Policy#");
19441                end if;
19442 
19443                --  The use of Priority_Specific_Dispatching forces ceiling
19444                --  locking policy.
19445 
19446                if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
19447                   Error_Msg_Sloc := Locking_Policy_Sloc;
19448                      Error_Pragma
19449                        ("Priority_Specific_Dispatching incompatible "
19450                         & "with Locking_Policy#");
19451 
19452                --  Set the Ceiling_Locking policy, but preserve System_Location
19453                --  since we like the error message with the run time name.
19454 
19455                else
19456                   Locking_Policy := 'C';
19457 
19458                   if Locking_Policy_Sloc /= System_Location then
19459                      Locking_Policy_Sloc := Loc;
19460                   end if;
19461                end if;
19462 
19463                --  Add entry in the table
19464 
19465                Specific_Dispatching.Append
19466                     ((Dispatching_Policy => DP,
19467                       First_Priority     => UI_To_Int (Lower_Val),
19468                       Last_Priority      => UI_To_Int (Upper_Val),
19469                       Pragma_Loc         => Loc));
19470             end if;
19471          end Priority_Specific_Dispatching;
19472 
19473          -------------
19474          -- Profile --
19475          -------------
19476 
19477          --  pragma Profile (profile_IDENTIFIER);
19478 
19479          --  profile_IDENTIFIER => Restricted | Ravenscar | Rational
19480 
19481          when Pragma_Profile =>
19482             Ada_2005_Pragma;
19483             Check_Arg_Count (1);
19484             Check_Valid_Configuration_Pragma;
19485             Check_No_Identifiers;
19486 
19487             declare
19488                Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19489 
19490             begin
19491                if Chars (Argx) = Name_Ravenscar then
19492                   Set_Ravenscar_Profile (Ravenscar, N);
19493 
19494                elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then
19495                   Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N);
19496 
19497                elsif Chars (Argx) = Name_Restricted then
19498                   Set_Profile_Restrictions
19499                     (Restricted,
19500                      N, Warn => Treat_Restrictions_As_Warnings);
19501 
19502                elsif Chars (Argx) = Name_Rational then
19503                   Set_Rational_Profile;
19504 
19505                elsif Chars (Argx) = Name_No_Implementation_Extensions then
19506                   Set_Profile_Restrictions
19507                     (No_Implementation_Extensions,
19508                      N, Warn => Treat_Restrictions_As_Warnings);
19509 
19510                else
19511                   Error_Pragma_Arg ("& is not a valid profile", Argx);
19512                end if;
19513             end;
19514 
19515          ----------------------
19516          -- Profile_Warnings --
19517          ----------------------
19518 
19519          --  pragma Profile_Warnings (profile_IDENTIFIER);
19520 
19521          --  profile_IDENTIFIER => Restricted | Ravenscar
19522 
19523          when Pragma_Profile_Warnings =>
19524             GNAT_Pragma;
19525             Check_Arg_Count (1);
19526             Check_Valid_Configuration_Pragma;
19527             Check_No_Identifiers;
19528 
19529             declare
19530                Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
19531 
19532             begin
19533                if Chars (Argx) = Name_Ravenscar then
19534                   Set_Profile_Restrictions (Ravenscar, N, Warn => True);
19535 
19536                elsif Chars (Argx) = Name_Restricted then
19537                   Set_Profile_Restrictions (Restricted, N, Warn => True);
19538 
19539                elsif Chars (Argx) = Name_No_Implementation_Extensions then
19540                   Set_Profile_Restrictions
19541                     (No_Implementation_Extensions, N, Warn => True);
19542 
19543                else
19544                   Error_Pragma_Arg ("& is not a valid profile", Argx);
19545                end if;
19546             end;
19547 
19548          --------------------------
19549          -- Propagate_Exceptions --
19550          --------------------------
19551 
19552          --  pragma Propagate_Exceptions;
19553 
19554          --  Note: this pragma is obsolete and has no effect
19555 
19556          when Pragma_Propagate_Exceptions =>
19557             GNAT_Pragma;
19558             Check_Arg_Count (0);
19559 
19560             if Warn_On_Obsolescent_Feature then
19561                Error_Msg_N
19562                  ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
19563                   "and has no effect?j?", N);
19564             end if;
19565 
19566          -----------------------------
19567          -- Provide_Shift_Operators --
19568          -----------------------------
19569 
19570          --  pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
19571 
19572          when Pragma_Provide_Shift_Operators =>
19573          Provide_Shift_Operators : declare
19574             Ent : Entity_Id;
19575 
19576             procedure Declare_Shift_Operator (Nam : Name_Id);
19577             --  Insert declaration and pragma Instrinsic for named shift op
19578 
19579             ----------------------------
19580             -- Declare_Shift_Operator --
19581             ----------------------------
19582 
19583             procedure Declare_Shift_Operator (Nam : Name_Id) is
19584                Func   : Node_Id;
19585                Import : Node_Id;
19586 
19587             begin
19588                Func :=
19589                  Make_Subprogram_Declaration (Loc,
19590                    Make_Function_Specification (Loc,
19591                      Defining_Unit_Name       =>
19592                        Make_Defining_Identifier (Loc, Chars => Nam),
19593 
19594                      Result_Definition        =>
19595                        Make_Identifier (Loc, Chars => Chars (Ent)),
19596 
19597                      Parameter_Specifications => New_List (
19598                        Make_Parameter_Specification (Loc,
19599                          Defining_Identifier  =>
19600                            Make_Defining_Identifier (Loc, Name_Value),
19601                          Parameter_Type       =>
19602                            Make_Identifier (Loc, Chars => Chars (Ent))),
19603 
19604                        Make_Parameter_Specification (Loc,
19605                          Defining_Identifier  =>
19606                            Make_Defining_Identifier (Loc, Name_Amount),
19607                          Parameter_Type       =>
19608                            New_Occurrence_Of (Standard_Natural, Loc)))));
19609 
19610                Import :=
19611                  Make_Pragma (Loc,
19612                    Pragma_Identifier => Make_Identifier (Loc, Name_Import),
19613                    Pragma_Argument_Associations => New_List (
19614                      Make_Pragma_Argument_Association (Loc,
19615                        Expression => Make_Identifier (Loc, Name_Intrinsic)),
19616                      Make_Pragma_Argument_Association (Loc,
19617                        Expression => Make_Identifier (Loc, Nam))));
19618 
19619                Insert_After (N, Import);
19620                Insert_After (N, Func);
19621             end Declare_Shift_Operator;
19622 
19623          --  Start of processing for Provide_Shift_Operators
19624 
19625          begin
19626             GNAT_Pragma;
19627             Check_Arg_Count (1);
19628             Check_Arg_Is_Local_Name (Arg1);
19629 
19630             Arg1 := Get_Pragma_Arg (Arg1);
19631 
19632             --  We must have an entity name
19633 
19634             if not Is_Entity_Name (Arg1) then
19635                Error_Pragma_Arg
19636                  ("pragma % must apply to integer first subtype", Arg1);
19637             end if;
19638 
19639             --  If no Entity, means there was a prior error so ignore
19640 
19641             if Present (Entity (Arg1)) then
19642                Ent := Entity (Arg1);
19643 
19644                --  Apply error checks
19645 
19646                if not Is_First_Subtype (Ent) then
19647                   Error_Pragma_Arg
19648                     ("cannot apply pragma %",
19649                      "\& is not a first subtype",
19650                      Arg1);
19651 
19652                elsif not Is_Integer_Type (Ent) then
19653                   Error_Pragma_Arg
19654                     ("cannot apply pragma %",
19655                      "\& is not an integer type",
19656                      Arg1);
19657 
19658                elsif Has_Shift_Operator (Ent) then
19659                   Error_Pragma_Arg
19660                     ("cannot apply pragma %",
19661                      "\& already has declared shift operators",
19662                      Arg1);
19663 
19664                elsif Is_Frozen (Ent) then
19665                   Error_Pragma_Arg
19666                     ("pragma % appears too late",
19667                      "\& is already frozen",
19668                      Arg1);
19669                end if;
19670 
19671                --  Now declare the operators. We do this during analysis rather
19672                --  than expansion, since we want the operators available if we
19673                --  are operating in -gnatc or ASIS mode.
19674 
19675                Declare_Shift_Operator (Name_Rotate_Left);
19676                Declare_Shift_Operator (Name_Rotate_Right);
19677                Declare_Shift_Operator (Name_Shift_Left);
19678                Declare_Shift_Operator (Name_Shift_Right);
19679                Declare_Shift_Operator (Name_Shift_Right_Arithmetic);
19680             end if;
19681          end Provide_Shift_Operators;
19682 
19683          ------------------
19684          -- Psect_Object --
19685          ------------------
19686 
19687          --  pragma Psect_Object (
19688          --        [Internal =>] LOCAL_NAME,
19689          --     [, [External =>] EXTERNAL_SYMBOL]
19690          --     [, [Size     =>] EXTERNAL_SYMBOL]);
19691 
19692          when Pragma_Psect_Object | Pragma_Common_Object =>
19693          Psect_Object : declare
19694             Args  : Args_List (1 .. 3);
19695             Names : constant Name_List (1 .. 3) := (
19696                       Name_Internal,
19697                       Name_External,
19698                       Name_Size);
19699 
19700             Internal : Node_Id renames Args (1);
19701             External : Node_Id renames Args (2);
19702             Size     : Node_Id renames Args (3);
19703 
19704             Def_Id : Entity_Id;
19705 
19706             procedure Check_Arg (Arg : Node_Id);
19707             --  Checks that argument is either a string literal or an
19708             --  identifier, and posts error message if not.
19709 
19710             ---------------
19711             -- Check_Arg --
19712             ---------------
19713 
19714             procedure Check_Arg (Arg : Node_Id) is
19715             begin
19716                if not Nkind_In (Original_Node (Arg),
19717                                 N_String_Literal,
19718                                 N_Identifier)
19719                then
19720                   Error_Pragma_Arg
19721                     ("inappropriate argument for pragma %", Arg);
19722                end if;
19723             end Check_Arg;
19724 
19725          --  Start of processing for Common_Object/Psect_Object
19726 
19727          begin
19728             GNAT_Pragma;
19729             Gather_Associations (Names, Args);
19730             Process_Extended_Import_Export_Internal_Arg (Internal);
19731 
19732             Def_Id := Entity (Internal);
19733 
19734             if not Ekind_In (Def_Id, E_Constant, E_Variable) then
19735                Error_Pragma_Arg
19736                  ("pragma% must designate an object", Internal);
19737             end if;
19738 
19739             Check_Arg (Internal);
19740 
19741             if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
19742                Error_Pragma_Arg
19743                  ("cannot use pragma% for imported/exported object",
19744                   Internal);
19745             end if;
19746 
19747             if Is_Concurrent_Type (Etype (Internal)) then
19748                Error_Pragma_Arg
19749                  ("cannot specify pragma % for task/protected object",
19750                   Internal);
19751             end if;
19752 
19753             if Has_Rep_Pragma (Def_Id, Name_Common_Object)
19754                  or else
19755                Has_Rep_Pragma (Def_Id, Name_Psect_Object)
19756             then
19757                Error_Msg_N ("??duplicate Common/Psect_Object pragma", N);
19758             end if;
19759 
19760             if Ekind (Def_Id) = E_Constant then
19761                Error_Pragma_Arg
19762                  ("cannot specify pragma % for a constant", Internal);
19763             end if;
19764 
19765             if Is_Record_Type (Etype (Internal)) then
19766                declare
19767                   Ent  : Entity_Id;
19768                   Decl : Entity_Id;
19769 
19770                begin
19771                   Ent := First_Entity (Etype (Internal));
19772                   while Present (Ent) loop
19773                      Decl := Declaration_Node (Ent);
19774 
19775                      if Ekind (Ent) = E_Component
19776                        and then Nkind (Decl) = N_Component_Declaration
19777                        and then Present (Expression (Decl))
19778                        and then Warn_On_Export_Import
19779                      then
19780                         Error_Msg_N
19781                           ("?x?object for pragma % has defaults", Internal);
19782                         exit;
19783 
19784                      else
19785                         Next_Entity (Ent);
19786                      end if;
19787                   end loop;
19788                end;
19789             end if;
19790 
19791             if Present (Size) then
19792                Check_Arg (Size);
19793             end if;
19794 
19795             if Present (External) then
19796                Check_Arg_Is_External_Name (External);
19797             end if;
19798 
19799             --  If all error tests pass, link pragma on to the rep item chain
19800 
19801             Record_Rep_Item (Def_Id, N);
19802          end Psect_Object;
19803 
19804          ----------
19805          -- Pure --
19806          ----------
19807 
19808          --  pragma Pure [(library_unit_NAME)];
19809 
19810          when Pragma_Pure => Pure : declare
19811             Ent : Entity_Id;
19812 
19813          begin
19814             Check_Ada_83_Warning;
19815 
19816             --  If the pragma comes from a subprogram instantiation, nothing to
19817             --  check, this can happen at any level of nesting.
19818 
19819             if Is_Wrapper_Package (Current_Scope) then
19820                return;
19821             else
19822                Check_Valid_Library_Unit_Pragma;
19823             end if;
19824 
19825             if Nkind (N) = N_Null_Statement then
19826                return;
19827             end if;
19828 
19829             Ent := Find_Lib_Unit_Name;
19830 
19831             --  A pragma that applies to a Ghost entity becomes Ghost for the
19832             --  purposes of legality checks and removal of ignored Ghost code.
19833 
19834             Mark_Pragma_As_Ghost (N, Ent);
19835 
19836             if not Debug_Flag_U then
19837                Set_Is_Pure (Ent);
19838                Set_Has_Pragma_Pure (Ent);
19839                Set_Suppress_Elaboration_Warnings (Ent);
19840             end if;
19841          end Pure;
19842 
19843          -------------------
19844          -- Pure_Function --
19845          -------------------
19846 
19847          --  pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
19848 
19849          when Pragma_Pure_Function => Pure_Function : declare
19850             Def_Id    : Entity_Id;
19851             E         : Entity_Id;
19852             E_Id      : Node_Id;
19853             Effective : Boolean := False;
19854 
19855          begin
19856             GNAT_Pragma;
19857             Check_Arg_Count (1);
19858             Check_Optional_Identifier (Arg1, Name_Entity);
19859             Check_Arg_Is_Local_Name (Arg1);
19860             E_Id := Get_Pragma_Arg (Arg1);
19861 
19862             if Error_Posted (E_Id) then
19863                return;
19864             end if;
19865 
19866             --  Loop through homonyms (overloadings) of referenced entity
19867 
19868             E := Entity (E_Id);
19869 
19870             --  A pragma that applies to a Ghost entity becomes Ghost for the
19871             --  purposes of legality checks and removal of ignored Ghost code.
19872 
19873             Mark_Pragma_As_Ghost (N, E);
19874 
19875             if Present (E) then
19876                loop
19877                   Def_Id := Get_Base_Subprogram (E);
19878 
19879                   if not Ekind_In (Def_Id, E_Function,
19880                                            E_Generic_Function,
19881                                            E_Operator)
19882                   then
19883                      Error_Pragma_Arg
19884                        ("pragma% requires a function name", Arg1);
19885                   end if;
19886 
19887                   Set_Is_Pure (Def_Id);
19888 
19889                   if not Has_Pragma_Pure_Function (Def_Id) then
19890                      Set_Has_Pragma_Pure_Function (Def_Id);
19891                      Effective := True;
19892                   end if;
19893 
19894                   exit when From_Aspect_Specification (N);
19895                   E := Homonym (E);
19896                   exit when No (E) or else Scope (E) /= Current_Scope;
19897                end loop;
19898 
19899                if not Effective
19900                  and then Warn_On_Redundant_Constructs
19901                then
19902                   Error_Msg_NE
19903                     ("pragma Pure_Function on& is redundant?r?",
19904                      N, Entity (E_Id));
19905                end if;
19906             end if;
19907          end Pure_Function;
19908 
19909          --------------------
19910          -- Queuing_Policy --
19911          --------------------
19912 
19913          --  pragma Queuing_Policy (policy_IDENTIFIER);
19914 
19915          when Pragma_Queuing_Policy => declare
19916             QP : Character;
19917 
19918          begin
19919             Check_Ada_83_Warning;
19920             Check_Arg_Count (1);
19921             Check_No_Identifiers;
19922             Check_Arg_Is_Queuing_Policy (Arg1);
19923             Check_Valid_Configuration_Pragma;
19924             Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
19925             QP := Fold_Upper (Name_Buffer (1));
19926 
19927             if Queuing_Policy /= ' '
19928               and then Queuing_Policy /= QP
19929             then
19930                Error_Msg_Sloc := Queuing_Policy_Sloc;
19931                Error_Pragma ("queuing policy incompatible with policy#");
19932 
19933             --  Set new policy, but always preserve System_Location since we
19934             --  like the error message with the run time name.
19935 
19936             else
19937                Queuing_Policy := QP;
19938 
19939                if Queuing_Policy_Sloc /= System_Location then
19940                   Queuing_Policy_Sloc := Loc;
19941                end if;
19942             end if;
19943          end;
19944 
19945          --------------
19946          -- Rational --
19947          --------------
19948 
19949          --  pragma Rational, for compatibility with foreign compiler
19950 
19951          when Pragma_Rational =>
19952             Set_Rational_Profile;
19953 
19954          ---------------------
19955          -- Refined_Depends --
19956          ---------------------
19957 
19958          --  pragma Refined_Depends (DEPENDENCY_RELATION);
19959 
19960          --  DEPENDENCY_RELATION ::=
19961          --     null
19962          --  | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
19963 
19964          --  DEPENDENCY_CLAUSE ::=
19965          --    OUTPUT_LIST =>[+] INPUT_LIST
19966          --  | NULL_DEPENDENCY_CLAUSE
19967 
19968          --  NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
19969 
19970          --  OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
19971 
19972          --  INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
19973 
19974          --  OUTPUT ::= NAME | FUNCTION_RESULT
19975          --  INPUT  ::= NAME
19976 
19977          --  where FUNCTION_RESULT is a function Result attribute_reference
19978 
19979          --  Characteristics:
19980 
19981          --    * Analysis - The annotation undergoes initial checks to verify
19982          --    the legal placement and context. Secondary checks fully analyze
19983          --    the dependency clauses/global list in:
19984 
19985          --       Analyze_Refined_Depends_In_Decl_Part
19986 
19987          --    * Expansion - None.
19988 
19989          --    * Template - The annotation utilizes the generic template of the
19990          --    related subprogram body.
19991 
19992          --    * Globals - Capture of global references must occur after full
19993          --    analysis.
19994 
19995          --    * Instance - The annotation is instantiated automatically when
19996          --    the related generic subprogram body is instantiated.
19997 
19998          when Pragma_Refined_Depends => Refined_Depends : declare
19999             Body_Id : Entity_Id;
20000             Legal   : Boolean;
20001             Spec_Id : Entity_Id;
20002 
20003          begin
20004             Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20005 
20006             if Legal then
20007 
20008                --  Chain the pragma on the contract for further processing by
20009                --  Analyze_Refined_Depends_In_Decl_Part.
20010 
20011                Add_Contract_Item (N, Body_Id);
20012 
20013                --  The legality checks of pragmas Refined_Depends and
20014                --  Refined_Global are affected by the SPARK mode in effect and
20015                --  the volatility of the context. In addition these two pragmas
20016                --  are subject to an inherent order:
20017 
20018                --    1) Refined_Global
20019                --    2) Refined_Depends
20020 
20021                --  Analyze all these pragmas in the order outlined above
20022 
20023                Analyze_If_Present (Pragma_SPARK_Mode);
20024                Analyze_If_Present (Pragma_Volatile_Function);
20025                Analyze_If_Present (Pragma_Refined_Global);
20026                Analyze_Refined_Depends_In_Decl_Part (N);
20027             end if;
20028          end Refined_Depends;
20029 
20030          --------------------
20031          -- Refined_Global --
20032          --------------------
20033 
20034          --  pragma Refined_Global (GLOBAL_SPECIFICATION);
20035 
20036          --  GLOBAL_SPECIFICATION ::=
20037          --     null
20038          --  | (GLOBAL_LIST)
20039          --  | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
20040 
20041          --  MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
20042 
20043          --  MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
20044          --  GLOBAL_LIST   ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
20045          --  GLOBAL_ITEM   ::= NAME
20046 
20047          --  Characteristics:
20048 
20049          --    * Analysis - The annotation undergoes initial checks to verify
20050          --    the legal placement and context. Secondary checks fully analyze
20051          --    the dependency clauses/global list in:
20052 
20053          --       Analyze_Refined_Global_In_Decl_Part
20054 
20055          --    * Expansion - None.
20056 
20057          --    * Template - The annotation utilizes the generic template of the
20058          --    related subprogram body.
20059 
20060          --    * Globals - Capture of global references must occur after full
20061          --    analysis.
20062 
20063          --    * Instance - The annotation is instantiated automatically when
20064          --    the related generic subprogram body is instantiated.
20065 
20066          when Pragma_Refined_Global => Refined_Global : declare
20067             Body_Id : Entity_Id;
20068             Legal   : Boolean;
20069             Spec_Id : Entity_Id;
20070 
20071          begin
20072             Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20073 
20074             if Legal then
20075 
20076                --  Chain the pragma on the contract for further processing by
20077                --  Analyze_Refined_Global_In_Decl_Part.
20078 
20079                Add_Contract_Item (N, Body_Id);
20080 
20081                --  The legality checks of pragmas Refined_Depends and
20082                --  Refined_Global are affected by the SPARK mode in effect and
20083                --  the volatility of the context. In addition these two pragmas
20084                --  are subject to an inherent order:
20085 
20086                --    1) Refined_Global
20087                --    2) Refined_Depends
20088 
20089                --  Analyze all these pragmas in the order outlined above
20090 
20091                Analyze_If_Present (Pragma_SPARK_Mode);
20092                Analyze_If_Present (Pragma_Volatile_Function);
20093                Analyze_Refined_Global_In_Decl_Part (N);
20094                Analyze_If_Present (Pragma_Refined_Depends);
20095             end if;
20096          end Refined_Global;
20097 
20098          ------------------
20099          -- Refined_Post --
20100          ------------------
20101 
20102          --  pragma Refined_Post (boolean_EXPRESSION);
20103 
20104          --  Characteristics:
20105 
20106          --    * Analysis - The annotation is fully analyzed immediately upon
20107          --    elaboration as it cannot forward reference entities.
20108 
20109          --    * Expansion - The annotation is expanded during the expansion of
20110          --    the related subprogram body contract as performed in:
20111 
20112          --       Expand_Subprogram_Contract
20113 
20114          --    * Template - The annotation utilizes the generic template of the
20115          --    related subprogram body.
20116 
20117          --    * Globals - Capture of global references must occur after full
20118          --    analysis.
20119 
20120          --    * Instance - The annotation is instantiated automatically when
20121          --    the related generic subprogram body is instantiated.
20122 
20123          when Pragma_Refined_Post => Refined_Post : declare
20124             Body_Id : Entity_Id;
20125             Legal   : Boolean;
20126             Spec_Id : Entity_Id;
20127 
20128          begin
20129             Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal);
20130 
20131             --  Fully analyze the pragma when it appears inside a subprogram
20132             --  body because it cannot benefit from forward references.
20133 
20134             if Legal then
20135 
20136                --  Chain the pragma on the contract for completeness
20137 
20138                Add_Contract_Item (N, Body_Id);
20139 
20140                --  The legality checks of pragma Refined_Post are affected by
20141                --  the SPARK mode in effect and the volatility of the context.
20142                --  Analyze all pragmas in a specific order.
20143 
20144                Analyze_If_Present (Pragma_SPARK_Mode);
20145                Analyze_If_Present (Pragma_Volatile_Function);
20146                Analyze_Pre_Post_Condition_In_Decl_Part (N);
20147 
20148                --  Currently it is not possible to inline pre/postconditions on
20149                --  a subprogram subject to pragma Inline_Always.
20150 
20151                Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
20152             end if;
20153          end Refined_Post;
20154 
20155          -------------------
20156          -- Refined_State --
20157          -------------------
20158 
20159          --  pragma Refined_State (REFINEMENT_LIST);
20160 
20161          --  REFINEMENT_LIST ::=
20162          --    (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
20163 
20164          --  REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
20165 
20166          --  CONSTITUENT_LIST ::=
20167          --     null
20168          --  |  CONSTITUENT
20169          --  | (CONSTITUENT {, CONSTITUENT})
20170 
20171          --  CONSTITUENT ::= object_NAME | state_NAME
20172 
20173          --  Characteristics:
20174 
20175          --    * Analysis - The annotation undergoes initial checks to verify
20176          --    the legal placement and context. Secondary checks preanalyze the
20177          --    refinement clauses in:
20178 
20179          --       Analyze_Refined_State_In_Decl_Part
20180 
20181          --    * Expansion - None.
20182 
20183          --    * Template - The annotation utilizes the template of the related
20184          --    package body.
20185 
20186          --    * Globals - Capture of global references must occur after full
20187          --    analysis.
20188 
20189          --    * Instance - The annotation is instantiated automatically when
20190          --    the related generic package body is instantiated.
20191 
20192          when Pragma_Refined_State => Refined_State : declare
20193             Pack_Decl : Node_Id;
20194             Spec_Id   : Entity_Id;
20195 
20196          begin
20197             GNAT_Pragma;
20198             Check_No_Identifiers;
20199             Check_Arg_Count (1);
20200 
20201             Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True);
20202 
20203             --  Ensure the proper placement of the pragma. Refined states must
20204             --  be associated with a package body.
20205 
20206             if Nkind (Pack_Decl) = N_Package_Body then
20207                null;
20208 
20209             --  Otherwise the pragma is associated with an illegal construct
20210 
20211             else
20212                Pragma_Misplaced;
20213                return;
20214             end if;
20215 
20216             Spec_Id := Corresponding_Spec (Pack_Decl);
20217 
20218             --  Chain the pragma on the contract for further processing by
20219             --  Analyze_Refined_State_In_Decl_Part.
20220 
20221             Add_Contract_Item (N, Defining_Entity (Pack_Decl));
20222 
20223             --  The legality checks of pragma Refined_State are affected by the
20224             --  SPARK mode in effect. Analyze all pragmas in a specific order.
20225 
20226             Analyze_If_Present (Pragma_SPARK_Mode);
20227 
20228             --  A pragma that applies to a Ghost entity becomes Ghost for the
20229             --  purposes of legality checks and removal of ignored Ghost code.
20230 
20231             Mark_Pragma_As_Ghost (N, Spec_Id);
20232 
20233             --  State refinement is allowed only when the corresponding package
20234             --  declaration has non-null pragma Abstract_State. Refinement not
20235             --  enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
20236 
20237             if SPARK_Mode /= Off
20238               and then
20239                 (No (Abstract_States (Spec_Id))
20240                   or else Has_Null_Abstract_State (Spec_Id))
20241             then
20242                Error_Msg_NE
20243                  ("useless refinement, package & does not define abstract "
20244                   & "states", N, Spec_Id);
20245                return;
20246             end if;
20247          end Refined_State;
20248 
20249          -----------------------
20250          -- Relative_Deadline --
20251          -----------------------
20252 
20253          --  pragma Relative_Deadline (time_span_EXPRESSION);
20254 
20255          when Pragma_Relative_Deadline => Relative_Deadline : declare
20256             P   : constant Node_Id := Parent (N);
20257             Arg : Node_Id;
20258 
20259          begin
20260             Ada_2005_Pragma;
20261             Check_No_Identifiers;
20262             Check_Arg_Count (1);
20263 
20264             Arg := Get_Pragma_Arg (Arg1);
20265 
20266             --  The expression must be analyzed in the special manner described
20267             --  in "Handling of Default and Per-Object Expressions" in sem.ads.
20268 
20269             Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
20270 
20271             --  Subprogram case
20272 
20273             if Nkind (P) = N_Subprogram_Body then
20274                Check_In_Main_Program;
20275 
20276             --  Only Task and subprogram cases allowed
20277 
20278             elsif Nkind (P) /= N_Task_Definition then
20279                Pragma_Misplaced;
20280             end if;
20281 
20282             --  Check duplicate pragma before we set the corresponding flag
20283 
20284             if Has_Relative_Deadline_Pragma (P) then
20285                Error_Pragma ("duplicate pragma% not allowed");
20286             end if;
20287 
20288             --  Set Has_Relative_Deadline_Pragma only for tasks. Note that
20289             --  Relative_Deadline pragma node cannot be inserted in the Rep
20290             --  Item chain of Ent since it is rewritten by the expander as a
20291             --  procedure call statement that will break the chain.
20292 
20293             Set_Has_Relative_Deadline_Pragma (P);
20294          end Relative_Deadline;
20295 
20296          ------------------------
20297          -- Remote_Access_Type --
20298          ------------------------
20299 
20300          --  pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
20301 
20302          when Pragma_Remote_Access_Type => Remote_Access_Type : declare
20303             E : Entity_Id;
20304 
20305          begin
20306             GNAT_Pragma;
20307             Check_Arg_Count (1);
20308             Check_Optional_Identifier (Arg1, Name_Entity);
20309             Check_Arg_Is_Local_Name (Arg1);
20310 
20311             E := Entity (Get_Pragma_Arg (Arg1));
20312 
20313             --  A pragma that applies to a Ghost entity becomes Ghost for the
20314             --  purposes of legality checks and removal of ignored Ghost code.
20315 
20316             Mark_Pragma_As_Ghost (N, E);
20317 
20318             if Nkind (Parent (E)) = N_Formal_Type_Declaration
20319               and then Ekind (E) = E_General_Access_Type
20320               and then Is_Class_Wide_Type (Directly_Designated_Type (E))
20321               and then Scope (Root_Type (Directly_Designated_Type (E)))
20322                          = Scope (E)
20323               and then Is_Valid_Remote_Object_Type
20324                          (Root_Type (Directly_Designated_Type (E)))
20325             then
20326                Set_Is_Remote_Types (E);
20327 
20328             else
20329                Error_Pragma_Arg
20330                  ("pragma% applies only to formal access to classwide types",
20331                   Arg1);
20332             end if;
20333          end Remote_Access_Type;
20334 
20335          ---------------------------
20336          -- Remote_Call_Interface --
20337          ---------------------------
20338 
20339          --  pragma Remote_Call_Interface [(library_unit_NAME)];
20340 
20341          when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
20342             Cunit_Node : Node_Id;
20343             Cunit_Ent  : Entity_Id;
20344             K          : Node_Kind;
20345 
20346          begin
20347             Check_Ada_83_Warning;
20348             Check_Valid_Library_Unit_Pragma;
20349 
20350             if Nkind (N) = N_Null_Statement then
20351                return;
20352             end if;
20353 
20354             Cunit_Node := Cunit (Current_Sem_Unit);
20355             K          := Nkind (Unit (Cunit_Node));
20356             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
20357 
20358             --  A pragma that applies to a Ghost entity becomes Ghost for the
20359             --  purposes of legality checks and removal of ignored Ghost code.
20360 
20361             Mark_Pragma_As_Ghost (N, Cunit_Ent);
20362 
20363             if K = N_Package_Declaration
20364               or else K = N_Generic_Package_Declaration
20365               or else K = N_Subprogram_Declaration
20366               or else K = N_Generic_Subprogram_Declaration
20367               or else (K = N_Subprogram_Body
20368                          and then Acts_As_Spec (Unit (Cunit_Node)))
20369             then
20370                null;
20371             else
20372                Error_Pragma (
20373                  "pragma% must apply to package or subprogram declaration");
20374             end if;
20375 
20376             Set_Is_Remote_Call_Interface (Cunit_Ent);
20377          end Remote_Call_Interface;
20378 
20379          ------------------
20380          -- Remote_Types --
20381          ------------------
20382 
20383          --  pragma Remote_Types [(library_unit_NAME)];
20384 
20385          when Pragma_Remote_Types => Remote_Types : declare
20386             Cunit_Node : Node_Id;
20387             Cunit_Ent  : Entity_Id;
20388 
20389          begin
20390             Check_Ada_83_Warning;
20391             Check_Valid_Library_Unit_Pragma;
20392 
20393             if Nkind (N) = N_Null_Statement then
20394                return;
20395             end if;
20396 
20397             Cunit_Node := Cunit (Current_Sem_Unit);
20398             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
20399 
20400             --  A pragma that applies to a Ghost entity becomes Ghost for the
20401             --  purposes of legality checks and removal of ignored Ghost code.
20402 
20403             Mark_Pragma_As_Ghost (N, Cunit_Ent);
20404 
20405             if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20406                                                 N_Generic_Package_Declaration)
20407             then
20408                Error_Pragma
20409                  ("pragma% can only apply to a package declaration");
20410             end if;
20411 
20412             Set_Is_Remote_Types (Cunit_Ent);
20413          end Remote_Types;
20414 
20415          ---------------
20416          -- Ravenscar --
20417          ---------------
20418 
20419          --  pragma Ravenscar;
20420 
20421          when Pragma_Ravenscar =>
20422             GNAT_Pragma;
20423             Check_Arg_Count (0);
20424             Check_Valid_Configuration_Pragma;
20425             Set_Ravenscar_Profile (Ravenscar, N);
20426 
20427             if Warn_On_Obsolescent_Feature then
20428                Error_Msg_N
20429                  ("pragma Ravenscar is an obsolescent feature?j?", N);
20430                Error_Msg_N
20431                  ("|use pragma Profile (Ravenscar) instead?j?", N);
20432             end if;
20433 
20434          -------------------------
20435          -- Restricted_Run_Time --
20436          -------------------------
20437 
20438          --  pragma Restricted_Run_Time;
20439 
20440          when Pragma_Restricted_Run_Time =>
20441             GNAT_Pragma;
20442             Check_Arg_Count (0);
20443             Check_Valid_Configuration_Pragma;
20444             Set_Profile_Restrictions
20445               (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
20446 
20447             if Warn_On_Obsolescent_Feature then
20448                Error_Msg_N
20449                  ("pragma Restricted_Run_Time is an obsolescent feature?j?",
20450                   N);
20451                Error_Msg_N
20452                  ("|use pragma Profile (Restricted) instead?j?", N);
20453             end if;
20454 
20455          ------------------
20456          -- Restrictions --
20457          ------------------
20458 
20459          --  pragma Restrictions (RESTRICTION {, RESTRICTION});
20460 
20461          --  RESTRICTION ::=
20462          --    restriction_IDENTIFIER
20463          --  | restriction_parameter_IDENTIFIER => EXPRESSION
20464 
20465          when Pragma_Restrictions =>
20466             Process_Restrictions_Or_Restriction_Warnings
20467               (Warn => Treat_Restrictions_As_Warnings);
20468 
20469          --------------------------
20470          -- Restriction_Warnings --
20471          --------------------------
20472 
20473          --  pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
20474 
20475          --  RESTRICTION ::=
20476          --    restriction_IDENTIFIER
20477          --  | restriction_parameter_IDENTIFIER => EXPRESSION
20478 
20479          when Pragma_Restriction_Warnings =>
20480             GNAT_Pragma;
20481             Process_Restrictions_Or_Restriction_Warnings (Warn => True);
20482 
20483          ----------------
20484          -- Reviewable --
20485          ----------------
20486 
20487          --  pragma Reviewable;
20488 
20489          when Pragma_Reviewable =>
20490             Check_Ada_83_Warning;
20491             Check_Arg_Count (0);
20492 
20493             --  Call dummy debugging function rv. This is done to assist front
20494             --  end debugging. By placing a Reviewable pragma in the source
20495             --  program, a breakpoint on rv catches this place in the source,
20496             --  allowing convenient stepping to the point of interest.
20497 
20498             rv;
20499 
20500          --------------------------
20501          -- Short_Circuit_And_Or --
20502          --------------------------
20503 
20504          --  pragma Short_Circuit_And_Or;
20505 
20506          when Pragma_Short_Circuit_And_Or =>
20507             GNAT_Pragma;
20508             Check_Arg_Count (0);
20509             Check_Valid_Configuration_Pragma;
20510             Short_Circuit_And_Or := True;
20511 
20512          -------------------
20513          -- Share_Generic --
20514          -------------------
20515 
20516          --  pragma Share_Generic (GNAME {, GNAME});
20517 
20518          --  GNAME ::= generic_unit_NAME | generic_instance_NAME
20519 
20520          when Pragma_Share_Generic =>
20521             GNAT_Pragma;
20522             Process_Generic_List;
20523 
20524          ------------
20525          -- Shared --
20526          ------------
20527 
20528          --  pragma Shared (LOCAL_NAME);
20529 
20530          when Pragma_Shared =>
20531             GNAT_Pragma;
20532             Process_Atomic_Independent_Shared_Volatile;
20533 
20534          --------------------
20535          -- Shared_Passive --
20536          --------------------
20537 
20538          --  pragma Shared_Passive [(library_unit_NAME)];
20539 
20540          --  Set the flag Is_Shared_Passive of program unit name entity
20541 
20542          when Pragma_Shared_Passive => Shared_Passive : declare
20543             Cunit_Node : Node_Id;
20544             Cunit_Ent  : Entity_Id;
20545 
20546          begin
20547             Check_Ada_83_Warning;
20548             Check_Valid_Library_Unit_Pragma;
20549 
20550             if Nkind (N) = N_Null_Statement then
20551                return;
20552             end if;
20553 
20554             Cunit_Node := Cunit (Current_Sem_Unit);
20555             Cunit_Ent  := Cunit_Entity (Current_Sem_Unit);
20556 
20557             --  A pragma that applies to a Ghost entity becomes Ghost for the
20558             --  purposes of legality checks and removal of ignored Ghost code.
20559 
20560             Mark_Pragma_As_Ghost (N, Cunit_Ent);
20561 
20562             if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
20563                                                 N_Generic_Package_Declaration)
20564             then
20565                Error_Pragma
20566                  ("pragma% can only apply to a package declaration");
20567             end if;
20568 
20569             Set_Is_Shared_Passive (Cunit_Ent);
20570          end Shared_Passive;
20571 
20572          -----------------------
20573          -- Short_Descriptors --
20574          -----------------------
20575 
20576          --  pragma Short_Descriptors;
20577 
20578          --  Recognize and validate, but otherwise ignore
20579 
20580          when Pragma_Short_Descriptors =>
20581             GNAT_Pragma;
20582             Check_Arg_Count (0);
20583             Check_Valid_Configuration_Pragma;
20584 
20585          ------------------------------
20586          -- Simple_Storage_Pool_Type --
20587          ------------------------------
20588 
20589          --  pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
20590 
20591          when Pragma_Simple_Storage_Pool_Type =>
20592          Simple_Storage_Pool_Type : declare
20593             Typ     : Entity_Id;
20594             Type_Id : Node_Id;
20595 
20596          begin
20597             GNAT_Pragma;
20598             Check_Arg_Count (1);
20599             Check_Arg_Is_Library_Level_Local_Name (Arg1);
20600 
20601             Type_Id := Get_Pragma_Arg (Arg1);
20602             Find_Type (Type_Id);
20603             Typ := Entity (Type_Id);
20604 
20605             if Typ = Any_Type then
20606                return;
20607             end if;
20608 
20609             --  A pragma that applies to a Ghost entity becomes Ghost for the
20610             --  purposes of legality checks and removal of ignored Ghost code.
20611 
20612             Mark_Pragma_As_Ghost (N, Typ);
20613 
20614             --  We require the pragma to apply to a type declared in a package
20615             --  declaration, but not (immediately) within a package body.
20616 
20617             if Ekind (Current_Scope) /= E_Package
20618               or else In_Package_Body (Current_Scope)
20619             then
20620                Error_Pragma
20621                  ("pragma% can only apply to type declared immediately "
20622                   & "within a package declaration");
20623             end if;
20624 
20625             --  A simple storage pool type must be an immutably limited record
20626             --  or private type. If the pragma is given for a private type,
20627             --  the full type is similarly restricted (which is checked later
20628             --  in Freeze_Entity).
20629 
20630             if Is_Record_Type (Typ)
20631               and then not Is_Limited_View (Typ)
20632             then
20633                Error_Pragma
20634                  ("pragma% can only apply to explicitly limited record type");
20635 
20636             elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
20637                Error_Pragma
20638                  ("pragma% can only apply to a private type that is limited");
20639 
20640             elsif not Is_Record_Type (Typ)
20641               and then not Is_Private_Type (Typ)
20642             then
20643                Error_Pragma
20644                  ("pragma% can only apply to limited record or private type");
20645             end if;
20646 
20647             Record_Rep_Item (Typ, N);
20648          end Simple_Storage_Pool_Type;
20649 
20650          ----------------------
20651          -- Source_File_Name --
20652          ----------------------
20653 
20654          --  There are five forms for this pragma:
20655 
20656          --  pragma Source_File_Name (
20657          --    [UNIT_NAME      =>] unit_NAME,
20658          --     BODY_FILE_NAME =>  STRING_LITERAL
20659          --    [, [INDEX =>] INTEGER_LITERAL]);
20660 
20661          --  pragma Source_File_Name (
20662          --    [UNIT_NAME      =>] unit_NAME,
20663          --     SPEC_FILE_NAME =>  STRING_LITERAL
20664          --    [, [INDEX =>] INTEGER_LITERAL]);
20665 
20666          --  pragma Source_File_Name (
20667          --     BODY_FILE_NAME  => STRING_LITERAL
20668          --  [, DOT_REPLACEMENT => STRING_LITERAL]
20669          --  [, CASING          => CASING_SPEC]);
20670 
20671          --  pragma Source_File_Name (
20672          --     SPEC_FILE_NAME  => STRING_LITERAL
20673          --  [, DOT_REPLACEMENT => STRING_LITERAL]
20674          --  [, CASING          => CASING_SPEC]);
20675 
20676          --  pragma Source_File_Name (
20677          --     SUBUNIT_FILE_NAME  => STRING_LITERAL
20678          --  [, DOT_REPLACEMENT    => STRING_LITERAL]
20679          --  [, CASING             => CASING_SPEC]);
20680 
20681          --  CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
20682 
20683          --  Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
20684          --  Source_File_Name (SFN), however their usage is exclusive: SFN can
20685          --  only be used when no project file is used, while SFNP can only be
20686          --  used when a project file is used.
20687 
20688          --  No processing here. Processing was completed during parsing, since
20689          --  we need to have file names set as early as possible. Units are
20690          --  loaded well before semantic processing starts.
20691 
20692          --  The only processing we defer to this point is the check for
20693          --  correct placement.
20694 
20695          when Pragma_Source_File_Name =>
20696             GNAT_Pragma;
20697             Check_Valid_Configuration_Pragma;
20698 
20699          ------------------------------
20700          -- Source_File_Name_Project --
20701          ------------------------------
20702 
20703          --  See Source_File_Name for syntax
20704 
20705          --  No processing here. Processing was completed during parsing, since
20706          --  we need to have file names set as early as possible. Units are
20707          --  loaded well before semantic processing starts.
20708 
20709          --  The only processing we defer to this point is the check for
20710          --  correct placement.
20711 
20712          when Pragma_Source_File_Name_Project =>
20713             GNAT_Pragma;
20714             Check_Valid_Configuration_Pragma;
20715 
20716             --  Check that a pragma Source_File_Name_Project is used only in a
20717             --  configuration pragmas file.
20718 
20719             --  Pragmas Source_File_Name_Project should only be generated by
20720             --  the Project Manager in configuration pragmas files.
20721 
20722             --  This is really an ugly test. It seems to depend on some
20723             --  accidental and undocumented property. At the very least it
20724             --  needs to be documented, but it would be better to have a
20725             --  clean way of testing if we are in a configuration file???
20726 
20727             if Present (Parent (N)) then
20728                Error_Pragma
20729                  ("pragma% can only appear in a configuration pragmas file");
20730             end if;
20731 
20732          ----------------------
20733          -- Source_Reference --
20734          ----------------------
20735 
20736          --  pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
20737 
20738          --  Nothing to do, all processing completed in Par.Prag, since we need
20739          --  the information for possible parser messages that are output.
20740 
20741          when Pragma_Source_Reference =>
20742             GNAT_Pragma;
20743 
20744          ----------------
20745          -- SPARK_Mode --
20746          ----------------
20747 
20748          --  pragma SPARK_Mode [(On | Off)];
20749 
20750          when Pragma_SPARK_Mode => Do_SPARK_Mode : declare
20751             Mode_Id : SPARK_Mode_Type;
20752 
20753             procedure Check_Pragma_Conformance
20754               (Context_Pragma : Node_Id;
20755                Entity         : Entity_Id;
20756                Entity_Pragma  : Node_Id);
20757             --  Subsidiary to routines Process_xxx. Verify the SPARK_Mode
20758             --  conformance of pragma N depending the following scenarios:
20759             --
20760             --  If pragma Context_Pragma is not Empty, verify that pragma N is
20761             --  compatible with the pragma Context_Pragma that was inherited
20762             --  from the context:
20763             --    * If the mode of Context_Pragma is ON, then the new mode can
20764             --      be anything.
20765             --    * If the mode of Context_Pragma is OFF, then the only allowed
20766             --      new mode is also OFF. Emit error if this is not the case.
20767             --
20768             --  If Entity is not Empty, verify that pragma N is compatible with
20769             --  pragma Entity_Pragma that belongs to Entity.
20770             --    * If Entity_Pragma is Empty, always issue an error as this
20771             --      corresponds to the case where a previous section of Entity
20772             --      has no SPARK_Mode set.
20773             --    * If the mode of Entity_Pragma is ON, then the new mode can
20774             --      be anything.
20775             --    * If the mode of Entity_Pragma is OFF, then the only allowed
20776             --      new mode is also OFF. Emit error if this is not the case.
20777 
20778             procedure Check_Library_Level_Entity (E : Entity_Id);
20779             --  Subsidiary to routines Process_xxx. Verify that the related
20780             --  entity E subject to pragma SPARK_Mode is library-level.
20781 
20782             procedure Process_Body (Decl : Node_Id);
20783             --  Verify the legality of pragma SPARK_Mode when it appears as the
20784             --  top of the body declarations of entry, package, protected unit,
20785             --  subprogram or task unit body denoted by Decl.
20786 
20787             procedure Process_Overloadable (Decl : Node_Id);
20788             --  Verify the legality of pragma SPARK_Mode when it applies to an
20789             --  entry or [generic] subprogram declaration denoted by Decl.
20790 
20791             procedure Process_Private_Part (Decl : Node_Id);
20792             --  Verify the legality of pragma SPARK_Mode when it appears at the
20793             --  top of the private declarations of a package spec, protected or
20794             --  task unit declaration denoted by Decl.
20795 
20796             procedure Process_Statement_Part (Decl : Node_Id);
20797             --  Verify the legality of pragma SPARK_Mode when it appears at the
20798             --  top of the statement sequence of a package body denoted by node
20799             --  Decl.
20800 
20801             procedure Process_Visible_Part (Decl : Node_Id);
20802             --  Verify the legality of pragma SPARK_Mode when it appears at the
20803             --  top of the visible declarations of a package spec, protected or
20804             --  task unit declaration denoted by Decl. The routine is also used
20805             --  on protected or task units declared without a definition.
20806 
20807             procedure Set_SPARK_Context;
20808             --  Subsidiary to routines Process_xxx. Set the global variables
20809             --  which represent the mode of the context from pragma N. Ensure
20810             --  that Dynamic_Elaboration_Checks are off if the new mode is On.
20811 
20812             ------------------------------
20813             -- Check_Pragma_Conformance --
20814             ------------------------------
20815 
20816             procedure Check_Pragma_Conformance
20817               (Context_Pragma : Node_Id;
20818                Entity         : Entity_Id;
20819                Entity_Pragma  : Node_Id)
20820             is
20821                Err_Id : Entity_Id;
20822                Err_N  : Node_Id;
20823 
20824             begin
20825                --  The current pragma may appear without an argument. If this
20826                --  is the case, associate all error messages with the pragma
20827                --  itself.
20828 
20829                if Present (Arg1) then
20830                   Err_N := Arg1;
20831                else
20832                   Err_N := N;
20833                end if;
20834 
20835                --  The mode of the current pragma is compared against that of
20836                --  an enclosing context.
20837 
20838                if Present (Context_Pragma) then
20839                   pragma Assert (Nkind (Context_Pragma) = N_Pragma);
20840 
20841                   --  Issue an error if the new mode is less restrictive than
20842                   --  that of the context.
20843 
20844                   if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
20845                     and then Get_SPARK_Mode_From_Annotation (N) = On
20846                   then
20847                      Error_Msg_N
20848                        ("cannot change SPARK_Mode from Off to On", Err_N);
20849                      Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
20850                      Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N);
20851                      raise Pragma_Exit;
20852                   end if;
20853                end if;
20854 
20855                --  The mode of the current pragma is compared against that of
20856                --  an initial package, protected type, subprogram or task type
20857                --  declaration.
20858 
20859                if Present (Entity) then
20860 
20861                   --  A simple protected or task type is transformed into an
20862                   --  anonymous type whose name cannot be used to issue error
20863                   --  messages. Recover the original entity of the type.
20864 
20865                   if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then
20866                      Err_Id :=
20867                        Defining_Entity
20868                          (Original_Node (Unit_Declaration_Node (Entity)));
20869                   else
20870                      Err_Id := Entity;
20871                   end if;
20872 
20873                   --  Both the initial declaration and the completion carry
20874                   --  SPARK_Mode pragmas.
20875 
20876                   if Present (Entity_Pragma) then
20877                      pragma Assert (Nkind (Entity_Pragma) = N_Pragma);
20878 
20879                      --  Issue an error if the new mode is less restrictive
20880                      --  than that of the initial declaration.
20881 
20882                      if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
20883                        and then Get_SPARK_Mode_From_Annotation (N) = On
20884                      then
20885                         Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
20886                         Error_Msg_Sloc := Sloc (Entity_Pragma);
20887                         Error_Msg_NE
20888                           ("\value Off was set for SPARK_Mode on&#",
20889                            Err_N, Err_Id);
20890                         raise Pragma_Exit;
20891                      end if;
20892 
20893                   --  Otherwise the initial declaration lacks a SPARK_Mode
20894                   --  pragma in which case the current pragma is illegal as
20895                   --  it cannot "complete".
20896 
20897                   else
20898                      Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
20899                      Error_Msg_Sloc := Sloc (Err_Id);
20900                      Error_Msg_NE
20901                        ("\no value was set for SPARK_Mode on&#",
20902                         Err_N, Err_Id);
20903                      raise Pragma_Exit;
20904                   end if;
20905                end if;
20906             end Check_Pragma_Conformance;
20907 
20908             --------------------------------
20909             -- Check_Library_Level_Entity --
20910             --------------------------------
20911 
20912             procedure Check_Library_Level_Entity (E : Entity_Id) is
20913                procedure Add_Entity_To_Name_Buffer;
20914                --  Add the E_Kind of entity E to the name buffer
20915 
20916                -------------------------------
20917                -- Add_Entity_To_Name_Buffer --
20918                -------------------------------
20919 
20920                procedure Add_Entity_To_Name_Buffer is
20921                begin
20922                   if Ekind_In (E, E_Entry, E_Entry_Family) then
20923                      Add_Str_To_Name_Buffer ("entry");
20924 
20925                   elsif Ekind_In (E, E_Generic_Package,
20926                                      E_Package,
20927                                      E_Package_Body)
20928                   then
20929                      Add_Str_To_Name_Buffer ("package");
20930 
20931                   elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then
20932                      Add_Str_To_Name_Buffer ("protected type");
20933 
20934                   elsif Ekind_In (E, E_Function,
20935                                      E_Generic_Function,
20936                                      E_Generic_Procedure,
20937                                      E_Procedure,
20938                                      E_Subprogram_Body)
20939                   then
20940                      Add_Str_To_Name_Buffer ("subprogram");
20941 
20942                   else
20943                      pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type));
20944                      Add_Str_To_Name_Buffer ("task type");
20945                   end if;
20946                end Add_Entity_To_Name_Buffer;
20947 
20948                --  Local variables
20949 
20950                Msg_1 : constant String := "incorrect placement of pragma%";
20951                Msg_2 : Name_Id;
20952 
20953             --  Start of processing for Check_Library_Level_Entity
20954 
20955             begin
20956                if not Is_Library_Level_Entity (E) then
20957                   Error_Msg_Name_1 := Pname;
20958                   Error_Msg_N (Fix_Error (Msg_1), N);
20959 
20960                   Name_Len := 0;
20961                   Add_Str_To_Name_Buffer ("\& is not a library-level ");
20962                   Add_Entity_To_Name_Buffer;
20963 
20964                   Msg_2 := Name_Find;
20965                   Error_Msg_NE (Get_Name_String (Msg_2), N, E);
20966 
20967                   raise Pragma_Exit;
20968                end if;
20969             end Check_Library_Level_Entity;
20970 
20971             ------------------
20972             -- Process_Body --
20973             ------------------
20974 
20975             procedure Process_Body (Decl : Node_Id) is
20976                Body_Id : constant Entity_Id := Defining_Entity (Decl);
20977                Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl);
20978 
20979             begin
20980                --  Ignore pragma when applied to the special body created for
20981                --  inlining, recognized by its internal name _Parent.
20982 
20983                if Chars (Body_Id) = Name_uParent then
20984                   return;
20985                end if;
20986 
20987                Check_Library_Level_Entity (Body_Id);
20988 
20989                --  For entry bodies, verify the legality against:
20990                --    * The mode of the context
20991                --    * The mode of the spec (if any)
20992 
20993                if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then
20994 
20995                   --  A stand alone subprogram body
20996 
20997                   if Body_Id = Spec_Id then
20998                      Check_Pragma_Conformance
20999                        (Context_Pragma => SPARK_Pragma (Body_Id),
21000                         Entity         => Empty,
21001                         Entity_Pragma  => Empty);
21002 
21003                   --  An entry or subprogram body that completes a previous
21004                   --  declaration.
21005 
21006                   else
21007                      Check_Pragma_Conformance
21008                        (Context_Pragma => SPARK_Pragma (Body_Id),
21009                         Entity         => Spec_Id,
21010                         Entity_Pragma  => SPARK_Pragma (Spec_Id));
21011                   end if;
21012 
21013                   Set_SPARK_Context;
21014                   Set_SPARK_Pragma           (Body_Id, N);
21015                   Set_SPARK_Pragma_Inherited (Body_Id, False);
21016 
21017                --  For package bodies, verify the legality against:
21018                --    * The mode of the context
21019                --    * The mode of the private part
21020 
21021                --  This case is separated from protected and task bodies
21022                --  because the statement part of the package body inherits
21023                --  the mode of the body declarations.
21024 
21025                elsif Nkind (Decl) = N_Package_Body then
21026                   Check_Pragma_Conformance
21027                     (Context_Pragma => SPARK_Pragma (Body_Id),
21028                      Entity         => Spec_Id,
21029                      Entity_Pragma  => SPARK_Aux_Pragma (Spec_Id));
21030 
21031                   Set_SPARK_Context;
21032                   Set_SPARK_Pragma               (Body_Id, N);
21033                   Set_SPARK_Pragma_Inherited     (Body_Id, False);
21034                   Set_SPARK_Aux_Pragma           (Body_Id, N);
21035                   Set_SPARK_Aux_Pragma_Inherited (Body_Id, True);
21036 
21037                --  For protected and task bodies, verify the legality against:
21038                --    * The mode of the context
21039                --    * The mode of the private part
21040 
21041                else
21042                   pragma Assert
21043                     (Nkind_In (Decl, N_Protected_Body, N_Task_Body));
21044 
21045                   Check_Pragma_Conformance
21046                     (Context_Pragma => SPARK_Pragma (Body_Id),
21047                      Entity         => Spec_Id,
21048                      Entity_Pragma  => SPARK_Aux_Pragma (Spec_Id));
21049 
21050                   Set_SPARK_Context;
21051                   Set_SPARK_Pragma           (Body_Id, N);
21052                   Set_SPARK_Pragma_Inherited (Body_Id, False);
21053                end if;
21054             end Process_Body;
21055 
21056             --------------------------
21057             -- Process_Overloadable --
21058             --------------------------
21059 
21060             procedure Process_Overloadable (Decl : Node_Id) is
21061                Spec_Id  : constant Entity_Id := Defining_Entity (Decl);
21062                Spec_Typ : constant Entity_Id := Etype (Spec_Id);
21063 
21064             begin
21065                Check_Library_Level_Entity (Spec_Id);
21066 
21067                --  Verify the legality against:
21068                --    * The mode of the context
21069 
21070                Check_Pragma_Conformance
21071                  (Context_Pragma => SPARK_Pragma (Spec_Id),
21072                   Entity         => Empty,
21073                   Entity_Pragma  => Empty);
21074 
21075                Set_SPARK_Pragma           (Spec_Id, N);
21076                Set_SPARK_Pragma_Inherited (Spec_Id, False);
21077 
21078                --  When the pragma applies to the anonymous object created for
21079                --  a single task type, decorate the type as well. This scenario
21080                --  arises when the single task type lacks a task definition,
21081                --  therefore there is no issue with respect to a potential
21082                --  pragma SPARK_Mode in the private part.
21083 
21084                --    task type Anon_Task_Typ;
21085                --    Obj : Anon_Task_Typ;
21086                --    pragma SPARK_Mode ...;
21087 
21088                if Is_Single_Task_Object (Spec_Id) then
21089                   Set_SPARK_Pragma               (Spec_Typ, N);
21090                   Set_SPARK_Pragma_Inherited     (Spec_Typ, False);
21091                   Set_SPARK_Aux_Pragma           (Spec_Typ, N);
21092                   Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True);
21093                end if;
21094             end Process_Overloadable;
21095 
21096             --------------------------
21097             -- Process_Private_Part --
21098             --------------------------
21099 
21100             procedure Process_Private_Part (Decl : Node_Id) is
21101                Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21102 
21103             begin
21104                Check_Library_Level_Entity (Spec_Id);
21105 
21106                --  Verify the legality against:
21107                --    * The mode of the visible declarations
21108 
21109                Check_Pragma_Conformance
21110                  (Context_Pragma => Empty,
21111                   Entity         => Spec_Id,
21112                   Entity_Pragma  => SPARK_Pragma (Spec_Id));
21113 
21114                Set_SPARK_Context;
21115                Set_SPARK_Aux_Pragma           (Spec_Id, N);
21116                Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False);
21117             end Process_Private_Part;
21118 
21119             ----------------------------
21120             -- Process_Statement_Part --
21121             ----------------------------
21122 
21123             procedure Process_Statement_Part (Decl : Node_Id) is
21124                Body_Id : constant Entity_Id := Defining_Entity (Decl);
21125 
21126             begin
21127                Check_Library_Level_Entity (Body_Id);
21128 
21129                --  Verify the legality against:
21130                --    * The mode of the body declarations
21131 
21132                Check_Pragma_Conformance
21133                  (Context_Pragma => Empty,
21134                   Entity         => Body_Id,
21135                   Entity_Pragma  => SPARK_Pragma (Body_Id));
21136 
21137                Set_SPARK_Context;
21138                Set_SPARK_Aux_Pragma           (Body_Id, N);
21139                Set_SPARK_Aux_Pragma_Inherited (Body_Id, False);
21140             end Process_Statement_Part;
21141 
21142             --------------------------
21143             -- Process_Visible_Part --
21144             --------------------------
21145 
21146             procedure Process_Visible_Part (Decl : Node_Id) is
21147                Spec_Id : constant Entity_Id := Defining_Entity (Decl);
21148                Obj_Id  : Entity_Id;
21149 
21150             begin
21151                Check_Library_Level_Entity (Spec_Id);
21152 
21153                --  Verify the legality against:
21154                --    * The mode of the context
21155 
21156                Check_Pragma_Conformance
21157                  (Context_Pragma => SPARK_Pragma (Spec_Id),
21158                   Entity         => Empty,
21159                   Entity_Pragma  => Empty);
21160 
21161                --  A task unit declared without a definition does not set the
21162                --  SPARK_Mode of the context because the task does not have any
21163                --  entries that could inherit the mode.
21164 
21165                if not Nkind_In (Decl, N_Single_Task_Declaration,
21166                                       N_Task_Type_Declaration)
21167                then
21168                   Set_SPARK_Context;
21169                end if;
21170 
21171                Set_SPARK_Pragma               (Spec_Id, N);
21172                Set_SPARK_Pragma_Inherited     (Spec_Id, False);
21173                Set_SPARK_Aux_Pragma           (Spec_Id, N);
21174                Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True);
21175 
21176                --  When the pragma applies to a single protected or task type,
21177                --  decorate the corresponding anonymous object as well.
21178 
21179                --    protected Anon_Prot_Typ is
21180                --       pragma SPARK_Mode ...;
21181                --       ...
21182                --    end Anon_Prot_Typ;
21183 
21184                --    Obj : Anon_Prot_Typ;
21185 
21186                if Is_Single_Concurrent_Type (Spec_Id) then
21187                   Obj_Id := Anonymous_Object (Spec_Id);
21188 
21189                   Set_SPARK_Pragma           (Obj_Id, N);
21190                   Set_SPARK_Pragma_Inherited (Obj_Id, False);
21191                end if;
21192             end Process_Visible_Part;
21193 
21194             -----------------------
21195             -- Set_SPARK_Context --
21196             -----------------------
21197 
21198             procedure Set_SPARK_Context is
21199             begin
21200                SPARK_Mode := Mode_Id;
21201                SPARK_Mode_Pragma := N;
21202             end Set_SPARK_Context;
21203 
21204             --  Local variables
21205 
21206             Context : Node_Id;
21207             Mode    : Name_Id;
21208             Stmt    : Node_Id;
21209 
21210          --  Start of processing for Do_SPARK_Mode
21211 
21212          begin
21213             --  When a SPARK_Mode pragma appears inside an instantiation whose
21214             --  enclosing context has SPARK_Mode set to "off", the pragma has
21215             --  no semantic effect.
21216 
21217             if Ignore_Pragma_SPARK_Mode then
21218                Rewrite (N, Make_Null_Statement (Loc));
21219                Analyze (N);
21220                return;
21221             end if;
21222 
21223             GNAT_Pragma;
21224             Check_No_Identifiers;
21225             Check_At_Most_N_Arguments (1);
21226 
21227             --  Check the legality of the mode (no argument = ON)
21228 
21229             if Arg_Count = 1 then
21230                Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21231                Mode := Chars (Get_Pragma_Arg (Arg1));
21232             else
21233                Mode := Name_On;
21234             end if;
21235 
21236             Mode_Id := Get_SPARK_Mode_Type (Mode);
21237             Context := Parent (N);
21238 
21239             --  The pragma appears in a configuration file
21240 
21241             if No (Context) then
21242                Check_Valid_Configuration_Pragma;
21243 
21244                if Present (SPARK_Mode_Pragma) then
21245                   Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma);
21246                   Error_Msg_N ("pragma% duplicates pragma declared#", N);
21247                   raise Pragma_Exit;
21248                end if;
21249 
21250                Set_SPARK_Context;
21251 
21252             --  The pragma acts as a configuration pragma in a compilation unit
21253 
21254             --    pragma SPARK_Mode ...;
21255             --    package Pack is ...;
21256 
21257             elsif Nkind (Context) = N_Compilation_Unit
21258               and then List_Containing (N) = Context_Items (Context)
21259             then
21260                Check_Valid_Configuration_Pragma;
21261                Set_SPARK_Context;
21262 
21263             --  Otherwise the placement of the pragma within the tree dictates
21264             --  its associated construct. Inspect the declarative list where
21265             --  the pragma resides to find a potential construct.
21266 
21267             else
21268                Stmt := Prev (N);
21269                while Present (Stmt) loop
21270 
21271                   --  Skip prior pragmas, but check for duplicates. Note that
21272                   --  this also takes care of pragmas generated for aspects.
21273 
21274                   if Nkind (Stmt) = N_Pragma then
21275                      if Pragma_Name (Stmt) = Pname then
21276                         Error_Msg_Name_1 := Pname;
21277                         Error_Msg_Sloc   := Sloc (Stmt);
21278                         Error_Msg_N ("pragma% duplicates pragma declared#", N);
21279                         raise Pragma_Exit;
21280                      end if;
21281 
21282                   --  The pragma applies to an expression function that has
21283                   --  already been rewritten into a subprogram declaration.
21284 
21285                   --    function Expr_Func return ... is (...);
21286                   --    pragma SPARK_Mode ...;
21287 
21288                   elsif Nkind (Stmt) = N_Subprogram_Declaration
21289                     and then Nkind (Original_Node (Stmt)) =
21290                                N_Expression_Function
21291                   then
21292                      Process_Overloadable (Stmt);
21293                      return;
21294 
21295                   --  The pragma applies to the anonymous object created for a
21296                   --  single concurrent type.
21297 
21298                   --    protected type Anon_Prot_Typ ...;
21299                   --    Obj : Anon_Prot_Typ;
21300                   --    pragma SPARK_Mode ...;
21301 
21302                   elsif Nkind (Stmt) = N_Object_Declaration
21303                     and then Is_Single_Concurrent_Object
21304                                (Defining_Entity (Stmt))
21305                   then
21306                      Process_Overloadable (Stmt);
21307                      return;
21308 
21309                   --  Skip internally generated code
21310 
21311                   elsif not Comes_From_Source (Stmt) then
21312                      null;
21313 
21314                   --  The pragma applies to an entry or [generic] subprogram
21315                   --  declaration.
21316 
21317                   --    entry Ent ...;
21318                   --    pragma SPARK_Mode ...;
21319 
21320                   --    [generic]
21321                   --    procedure Proc ...;
21322                   --    pragma SPARK_Mode ...;
21323 
21324                   elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration,
21325                                         N_Subprogram_Declaration)
21326                     or else (Nkind (Stmt) = N_Entry_Declaration
21327                               and then Is_Protected_Type
21328                                          (Scope (Defining_Entity (Stmt))))
21329                   then
21330                      Process_Overloadable (Stmt);
21331                      return;
21332 
21333                   --  Otherwise the pragma does not apply to a legal construct
21334                   --  or it does not appear at the top of a declarative or a
21335                   --  statement list. Issue an error and stop the analysis.
21336 
21337                   else
21338                      Pragma_Misplaced;
21339                      exit;
21340                   end if;
21341 
21342                   Prev (Stmt);
21343                end loop;
21344 
21345                --  The pragma applies to a package or a subprogram that acts as
21346                --  a compilation unit.
21347 
21348                --    procedure Proc ...;
21349                --    pragma SPARK_Mode ...;
21350 
21351                if Nkind (Context) = N_Compilation_Unit_Aux then
21352                   Context := Unit (Parent (Context));
21353                end if;
21354 
21355                --  The pragma appears at the top of entry, package, protected
21356                --  unit, subprogram or task unit body declarations.
21357 
21358                --    entry Ent when ... is
21359                --       pragma SPARK_Mode ...;
21360 
21361                --    package body Pack is
21362                --       pragma SPARK_Mode ...;
21363 
21364                --    procedure Proc ... is
21365                --       pragma SPARK_Mode;
21366 
21367                --    protected body Prot is
21368                --       pragma SPARK_Mode ...;
21369 
21370                if Nkind_In (Context, N_Entry_Body,
21371                                      N_Package_Body,
21372                                      N_Protected_Body,
21373                                      N_Subprogram_Body,
21374                                      N_Task_Body)
21375                then
21376                   Process_Body (Context);
21377 
21378                --  The pragma appears at the top of the visible or private
21379                --  declaration of a package spec, protected or task unit.
21380 
21381                --    package Pack is
21382                --       pragma SPARK_Mode ...;
21383                --    private
21384                --       pragma SPARK_Mode ...;
21385 
21386                --    protected [type] Prot is
21387                --       pragma SPARK_Mode ...;
21388                --    private
21389                --       pragma SPARK_Mode ...;
21390 
21391                elsif Nkind_In (Context, N_Package_Specification,
21392                                         N_Protected_Definition,
21393                                         N_Task_Definition)
21394                then
21395                   if List_Containing (N) = Visible_Declarations (Context) then
21396                      Process_Visible_Part (Parent (Context));
21397                   else
21398                      Process_Private_Part (Parent (Context));
21399                   end if;
21400 
21401                --  The pragma appears at the top of package body statements
21402 
21403                --    package body Pack is
21404                --    begin
21405                --       pragma SPARK_Mode;
21406 
21407                elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
21408                  and then Nkind (Parent (Context)) = N_Package_Body
21409                then
21410                   Process_Statement_Part (Parent (Context));
21411 
21412                --  The pragma appeared as an aspect of a [generic] subprogram
21413                --  declaration that acts as a compilation unit.
21414 
21415                --    [generic]
21416                --    procedure Proc ...;
21417                --    pragma SPARK_Mode ...;
21418 
21419                elsif Nkind_In (Context, N_Generic_Subprogram_Declaration,
21420                                         N_Subprogram_Declaration)
21421                then
21422                   Process_Overloadable (Context);
21423 
21424                --  The pragma does not apply to a legal construct, issue error
21425 
21426                else
21427                   Pragma_Misplaced;
21428                end if;
21429             end if;
21430          end Do_SPARK_Mode;
21431 
21432          --------------------------------
21433          -- Static_Elaboration_Desired --
21434          --------------------------------
21435 
21436          --  pragma Static_Elaboration_Desired (DIRECT_NAME);
21437 
21438          when Pragma_Static_Elaboration_Desired =>
21439             GNAT_Pragma;
21440             Check_At_Most_N_Arguments (1);
21441 
21442             if Is_Compilation_Unit (Current_Scope)
21443               and then Ekind (Current_Scope) = E_Package
21444             then
21445                Set_Static_Elaboration_Desired (Current_Scope, True);
21446             else
21447                Error_Pragma ("pragma% must apply to a library-level package");
21448             end if;
21449 
21450          ------------------
21451          -- Storage_Size --
21452          ------------------
21453 
21454          --  pragma Storage_Size (EXPRESSION);
21455 
21456          when Pragma_Storage_Size => Storage_Size : declare
21457             P   : constant Node_Id := Parent (N);
21458             Arg : Node_Id;
21459 
21460          begin
21461             Check_No_Identifiers;
21462             Check_Arg_Count (1);
21463 
21464             --  The expression must be analyzed in the special manner described
21465             --  in "Handling of Default Expressions" in sem.ads.
21466 
21467             Arg := Get_Pragma_Arg (Arg1);
21468             Preanalyze_Spec_Expression (Arg, Any_Integer);
21469 
21470             if not Is_OK_Static_Expression (Arg) then
21471                Check_Restriction (Static_Storage_Size, Arg);
21472             end if;
21473 
21474             if Nkind (P) /= N_Task_Definition then
21475                Pragma_Misplaced;
21476                return;
21477 
21478             else
21479                if Has_Storage_Size_Pragma (P) then
21480                   Error_Pragma ("duplicate pragma% not allowed");
21481                else
21482                   Set_Has_Storage_Size_Pragma (P, True);
21483                end if;
21484 
21485                Record_Rep_Item (Defining_Identifier (Parent (P)), N);
21486             end if;
21487          end Storage_Size;
21488 
21489          ------------------
21490          -- Storage_Unit --
21491          ------------------
21492 
21493          --  pragma Storage_Unit (NUMERIC_LITERAL);
21494 
21495          --  Only permitted argument is System'Storage_Unit value
21496 
21497          when Pragma_Storage_Unit =>
21498             Check_No_Identifiers;
21499             Check_Arg_Count (1);
21500             Check_Arg_Is_Integer_Literal (Arg1);
21501 
21502             if Intval (Get_Pragma_Arg (Arg1)) /=
21503               UI_From_Int (Ttypes.System_Storage_Unit)
21504             then
21505                Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
21506                Error_Pragma_Arg
21507                  ("the only allowed argument for pragma% is ^", Arg1);
21508             end if;
21509 
21510          --------------------
21511          -- Stream_Convert --
21512          --------------------
21513 
21514          --  pragma Stream_Convert (
21515          --    [Entity =>] type_LOCAL_NAME,
21516          --    [Read   =>] function_NAME,
21517          --    [Write  =>] function NAME);
21518 
21519          when Pragma_Stream_Convert => Stream_Convert : declare
21520 
21521             procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
21522             --  Check that the given argument is the name of a local function
21523             --  of one argument that is not overloaded earlier in the current
21524             --  local scope. A check is also made that the argument is a
21525             --  function with one parameter.
21526 
21527             --------------------------------------
21528             -- Check_OK_Stream_Convert_Function --
21529             --------------------------------------
21530 
21531             procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
21532                Ent : Entity_Id;
21533 
21534             begin
21535                Check_Arg_Is_Local_Name (Arg);
21536                Ent := Entity (Get_Pragma_Arg (Arg));
21537 
21538                if Has_Homonym (Ent) then
21539                   Error_Pragma_Arg
21540                     ("argument for pragma% may not be overloaded", Arg);
21541                end if;
21542 
21543                if Ekind (Ent) /= E_Function
21544                  or else No (First_Formal (Ent))
21545                  or else Present (Next_Formal (First_Formal (Ent)))
21546                then
21547                   Error_Pragma_Arg
21548                     ("argument for pragma% must be function of one argument",
21549                      Arg);
21550                end if;
21551             end Check_OK_Stream_Convert_Function;
21552 
21553          --  Start of processing for Stream_Convert
21554 
21555          begin
21556             GNAT_Pragma;
21557             Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
21558             Check_Arg_Count (3);
21559             Check_Optional_Identifier (Arg1, Name_Entity);
21560             Check_Optional_Identifier (Arg2, Name_Read);
21561             Check_Optional_Identifier (Arg3, Name_Write);
21562             Check_Arg_Is_Local_Name (Arg1);
21563             Check_OK_Stream_Convert_Function (Arg2);
21564             Check_OK_Stream_Convert_Function (Arg3);
21565 
21566             declare
21567                Typ   : constant Entity_Id :=
21568                          Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
21569                Read  : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
21570                Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
21571 
21572             begin
21573                Check_First_Subtype (Arg1);
21574 
21575                --  Check for too early or too late. Note that we don't enforce
21576                --  the rule about primitive operations in this case, since, as
21577                --  is the case for explicit stream attributes themselves, these
21578                --  restrictions are not appropriate. Note that the chaining of
21579                --  the pragma by Rep_Item_Too_Late is actually the critical
21580                --  processing done for this pragma.
21581 
21582                if Rep_Item_Too_Early (Typ, N)
21583                     or else
21584                   Rep_Item_Too_Late (Typ, N, FOnly => True)
21585                then
21586                   return;
21587                end if;
21588 
21589                --  Return if previous error
21590 
21591                if Etype (Typ) = Any_Type
21592                     or else
21593                   Etype (Read) = Any_Type
21594                     or else
21595                   Etype (Write) = Any_Type
21596                then
21597                   return;
21598                end if;
21599 
21600                --  Error checks
21601 
21602                if Underlying_Type (Etype (Read)) /= Typ then
21603                   Error_Pragma_Arg
21604                     ("incorrect return type for function&", Arg2);
21605                end if;
21606 
21607                if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
21608                   Error_Pragma_Arg
21609                     ("incorrect parameter type for function&", Arg3);
21610                end if;
21611 
21612                if Underlying_Type (Etype (First_Formal (Read))) /=
21613                   Underlying_Type (Etype (Write))
21614                then
21615                   Error_Pragma_Arg
21616                     ("result type of & does not match Read parameter type",
21617                      Arg3);
21618                end if;
21619             end;
21620          end Stream_Convert;
21621 
21622          ------------------
21623          -- Style_Checks --
21624          ------------------
21625 
21626          --  pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21627 
21628          --  This is processed by the parser since some of the style checks
21629          --  take place during source scanning and parsing. This means that
21630          --  we don't need to issue error messages here.
21631 
21632          when Pragma_Style_Checks => Style_Checks : declare
21633             A  : constant Node_Id   := Get_Pragma_Arg (Arg1);
21634             S  : String_Id;
21635             C  : Char_Code;
21636 
21637          begin
21638             GNAT_Pragma;
21639             Check_No_Identifiers;
21640 
21641             --  Two argument form
21642 
21643             if Arg_Count = 2 then
21644                Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
21645 
21646                declare
21647                   E_Id : Node_Id;
21648                   E    : Entity_Id;
21649 
21650                begin
21651                   E_Id := Get_Pragma_Arg (Arg2);
21652                   Analyze (E_Id);
21653 
21654                   if not Is_Entity_Name (E_Id) then
21655                      Error_Pragma_Arg
21656                        ("second argument of pragma% must be entity name",
21657                         Arg2);
21658                   end if;
21659 
21660                   E := Entity (E_Id);
21661 
21662                   if not Ignore_Style_Checks_Pragmas then
21663                      if E = Any_Id then
21664                         return;
21665                      else
21666                         loop
21667                            Set_Suppress_Style_Checks
21668                              (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off);
21669                            exit when No (Homonym (E));
21670                            E := Homonym (E);
21671                         end loop;
21672                      end if;
21673                   end if;
21674                end;
21675 
21676             --  One argument form
21677 
21678             else
21679                Check_Arg_Count (1);
21680 
21681                if Nkind (A) = N_String_Literal then
21682                   S := Strval (A);
21683 
21684                   declare
21685                      Slen    : constant Natural := Natural (String_Length (S));
21686                      Options : String (1 .. Slen);
21687                      J       : Positive;
21688 
21689                   begin
21690                      J := 1;
21691                      loop
21692                         C := Get_String_Char (S, Pos (J));
21693                         exit when not In_Character_Range (C);
21694                         Options (J) := Get_Character (C);
21695 
21696                         --  If at end of string, set options. As per discussion
21697                         --  above, no need to check for errors, since we issued
21698                         --  them in the parser.
21699 
21700                         if J = Slen then
21701                            if not Ignore_Style_Checks_Pragmas then
21702                               Set_Style_Check_Options (Options);
21703                            end if;
21704 
21705                            exit;
21706                         end if;
21707 
21708                         J := J + 1;
21709                      end loop;
21710                   end;
21711 
21712                elsif Nkind (A) = N_Identifier then
21713                   if Chars (A) = Name_All_Checks then
21714                      if not Ignore_Style_Checks_Pragmas then
21715                         if GNAT_Mode then
21716                            Set_GNAT_Style_Check_Options;
21717                         else
21718                            Set_Default_Style_Check_Options;
21719                         end if;
21720                      end if;
21721 
21722                   elsif Chars (A) = Name_On then
21723                      if not Ignore_Style_Checks_Pragmas then
21724                         Style_Check := True;
21725                      end if;
21726 
21727                   elsif Chars (A) = Name_Off then
21728                      if not Ignore_Style_Checks_Pragmas then
21729                         Style_Check := False;
21730                      end if;
21731                   end if;
21732                end if;
21733             end if;
21734          end Style_Checks;
21735 
21736          --------------
21737          -- Subtitle --
21738          --------------
21739 
21740          --  pragma Subtitle ([Subtitle =>] STRING_LITERAL);
21741 
21742          when Pragma_Subtitle =>
21743             GNAT_Pragma;
21744             Check_Arg_Count (1);
21745             Check_Optional_Identifier (Arg1, Name_Subtitle);
21746             Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
21747             Store_Note (N);
21748 
21749          --------------
21750          -- Suppress --
21751          --------------
21752 
21753          --  pragma Suppress (IDENTIFIER [, [On =>] NAME]);
21754 
21755          when Pragma_Suppress =>
21756             Process_Suppress_Unsuppress (Suppress_Case => True);
21757 
21758          ------------------
21759          -- Suppress_All --
21760          ------------------
21761 
21762          --  pragma Suppress_All;
21763 
21764          --  The only check made here is that the pragma has no arguments.
21765          --  There are no placement rules, and the processing required (setting
21766          --  the Has_Pragma_Suppress_All flag in the compilation unit node was
21767          --  taken care of by the parser). Process_Compilation_Unit_Pragmas
21768          --  then creates and inserts a pragma Suppress (All_Checks).
21769 
21770          when Pragma_Suppress_All =>
21771             GNAT_Pragma;
21772             Check_Arg_Count (0);
21773 
21774          -------------------------
21775          -- Suppress_Debug_Info --
21776          -------------------------
21777 
21778          --  pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
21779 
21780          when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare
21781             Nam_Id : Entity_Id;
21782 
21783          begin
21784             GNAT_Pragma;
21785             Check_Arg_Count (1);
21786             Check_Optional_Identifier (Arg1, Name_Entity);
21787             Check_Arg_Is_Local_Name (Arg1);
21788 
21789             Nam_Id := Entity (Get_Pragma_Arg (Arg1));
21790 
21791             --  A pragma that applies to a Ghost entity becomes Ghost for the
21792             --  purposes of legality checks and removal of ignored Ghost code.
21793 
21794             Mark_Pragma_As_Ghost (N, Nam_Id);
21795             Set_Debug_Info_Off (Nam_Id);
21796          end Suppress_Debug_Info;
21797 
21798          ----------------------------------
21799          -- Suppress_Exception_Locations --
21800          ----------------------------------
21801 
21802          --  pragma Suppress_Exception_Locations;
21803 
21804          when Pragma_Suppress_Exception_Locations =>
21805             GNAT_Pragma;
21806             Check_Arg_Count (0);
21807             Check_Valid_Configuration_Pragma;
21808             Exception_Locations_Suppressed := True;
21809 
21810          -----------------------------
21811          -- Suppress_Initialization --
21812          -----------------------------
21813 
21814          --  pragma Suppress_Initialization ([Entity =>] type_Name);
21815 
21816          when Pragma_Suppress_Initialization => Suppress_Init : declare
21817             E    : Entity_Id;
21818             E_Id : Node_Id;
21819 
21820          begin
21821             GNAT_Pragma;
21822             Check_Arg_Count (1);
21823             Check_Optional_Identifier (Arg1, Name_Entity);
21824             Check_Arg_Is_Local_Name (Arg1);
21825 
21826             E_Id := Get_Pragma_Arg (Arg1);
21827 
21828             if Etype (E_Id) = Any_Type then
21829                return;
21830             end if;
21831 
21832             E := Entity (E_Id);
21833 
21834             --  A pragma that applies to a Ghost entity becomes Ghost for the
21835             --  purposes of legality checks and removal of ignored Ghost code.
21836 
21837             Mark_Pragma_As_Ghost (N, E);
21838 
21839             if not Is_Type (E) and then Ekind (E) /= E_Variable then
21840                Error_Pragma_Arg
21841                  ("pragma% requires variable, type or subtype", Arg1);
21842             end if;
21843 
21844             if Rep_Item_Too_Early (E, N)
21845                  or else
21846                Rep_Item_Too_Late (E, N, FOnly => True)
21847             then
21848                return;
21849             end if;
21850 
21851             --  For incomplete/private type, set flag on full view
21852 
21853             if Is_Incomplete_Or_Private_Type (E) then
21854                if No (Full_View (Base_Type (E))) then
21855                   Error_Pragma_Arg
21856                     ("argument of pragma% cannot be an incomplete type", Arg1);
21857                else
21858                   Set_Suppress_Initialization (Full_View (Base_Type (E)));
21859                end if;
21860 
21861             --  For first subtype, set flag on base type
21862 
21863             elsif Is_First_Subtype (E) then
21864                Set_Suppress_Initialization (Base_Type (E));
21865 
21866             --  For other than first subtype, set flag on subtype or variable
21867 
21868             else
21869                Set_Suppress_Initialization (E);
21870             end if;
21871          end Suppress_Init;
21872 
21873          -----------------
21874          -- System_Name --
21875          -----------------
21876 
21877          --  pragma System_Name (DIRECT_NAME);
21878 
21879          --  Syntax check: one argument, which must be the identifier GNAT or
21880          --  the identifier GCC, no other identifiers are acceptable.
21881 
21882          when Pragma_System_Name =>
21883             GNAT_Pragma;
21884             Check_No_Identifiers;
21885             Check_Arg_Count (1);
21886             Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
21887 
21888          -----------------------------
21889          -- Task_Dispatching_Policy --
21890          -----------------------------
21891 
21892          --  pragma Task_Dispatching_Policy (policy_IDENTIFIER);
21893 
21894          when Pragma_Task_Dispatching_Policy => declare
21895             DP : Character;
21896 
21897          begin
21898             Check_Ada_83_Warning;
21899             Check_Arg_Count (1);
21900             Check_No_Identifiers;
21901             Check_Arg_Is_Task_Dispatching_Policy (Arg1);
21902             Check_Valid_Configuration_Pragma;
21903             Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
21904             DP := Fold_Upper (Name_Buffer (1));
21905 
21906             if Task_Dispatching_Policy /= ' '
21907               and then Task_Dispatching_Policy /= DP
21908             then
21909                Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
21910                Error_Pragma
21911                  ("task dispatching policy incompatible with policy#");
21912 
21913             --  Set new policy, but always preserve System_Location since we
21914             --  like the error message with the run time name.
21915 
21916             else
21917                Task_Dispatching_Policy := DP;
21918 
21919                if Task_Dispatching_Policy_Sloc /= System_Location then
21920                   Task_Dispatching_Policy_Sloc := Loc;
21921                end if;
21922             end if;
21923          end;
21924 
21925          ---------------
21926          -- Task_Info --
21927          ---------------
21928 
21929          --  pragma Task_Info (EXPRESSION);
21930 
21931          when Pragma_Task_Info => Task_Info : declare
21932             P   : constant Node_Id := Parent (N);
21933             Ent : Entity_Id;
21934 
21935          begin
21936             GNAT_Pragma;
21937 
21938             if Warn_On_Obsolescent_Feature then
21939                Error_Msg_N
21940                  ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
21941                   & "instead?j?", N);
21942             end if;
21943 
21944             if Nkind (P) /= N_Task_Definition then
21945                Error_Pragma ("pragma% must appear in task definition");
21946             end if;
21947 
21948             Check_No_Identifiers;
21949             Check_Arg_Count (1);
21950 
21951             Analyze_And_Resolve
21952               (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
21953 
21954             if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
21955                return;
21956             end if;
21957 
21958             Ent := Defining_Identifier (Parent (P));
21959 
21960             --  Check duplicate pragma before we chain the pragma in the Rep
21961             --  Item chain of Ent.
21962 
21963             if Has_Rep_Pragma
21964                  (Ent, Name_Task_Info, Check_Parents => False)
21965             then
21966                Error_Pragma ("duplicate pragma% not allowed");
21967             end if;
21968 
21969             Record_Rep_Item (Ent, N);
21970          end Task_Info;
21971 
21972          ---------------
21973          -- Task_Name --
21974          ---------------
21975 
21976          --  pragma Task_Name (string_EXPRESSION);
21977 
21978          when Pragma_Task_Name => Task_Name : declare
21979             P   : constant Node_Id := Parent (N);
21980             Arg : Node_Id;
21981             Ent : Entity_Id;
21982 
21983          begin
21984             Check_No_Identifiers;
21985             Check_Arg_Count (1);
21986 
21987             Arg := Get_Pragma_Arg (Arg1);
21988 
21989             --  The expression is used in the call to Create_Task, and must be
21990             --  expanded there, not in the context of the current spec. It must
21991             --  however be analyzed to capture global references, in case it
21992             --  appears in a generic context.
21993 
21994             Preanalyze_And_Resolve (Arg, Standard_String);
21995 
21996             if Nkind (P) /= N_Task_Definition then
21997                Pragma_Misplaced;
21998             end if;
21999 
22000             Ent := Defining_Identifier (Parent (P));
22001 
22002             --  Check duplicate pragma before we chain the pragma in the Rep
22003             --  Item chain of Ent.
22004 
22005             if Has_Rep_Pragma
22006                  (Ent, Name_Task_Name, Check_Parents => False)
22007             then
22008                Error_Pragma ("duplicate pragma% not allowed");
22009             end if;
22010 
22011             Record_Rep_Item (Ent, N);
22012          end Task_Name;
22013 
22014          ------------------
22015          -- Task_Storage --
22016          ------------------
22017 
22018          --  pragma Task_Storage (
22019          --     [Task_Type =>] LOCAL_NAME,
22020          --     [Top_Guard =>] static_integer_EXPRESSION);
22021 
22022          when Pragma_Task_Storage => Task_Storage : declare
22023             Args  : Args_List (1 .. 2);
22024             Names : constant Name_List (1 .. 2) := (
22025                       Name_Task_Type,
22026                       Name_Top_Guard);
22027 
22028             Task_Type : Node_Id renames Args (1);
22029             Top_Guard : Node_Id renames Args (2);
22030 
22031             Ent : Entity_Id;
22032 
22033          begin
22034             GNAT_Pragma;
22035             Gather_Associations (Names, Args);
22036 
22037             if No (Task_Type) then
22038                Error_Pragma
22039                  ("missing task_type argument for pragma%");
22040             end if;
22041 
22042             Check_Arg_Is_Local_Name (Task_Type);
22043 
22044             Ent := Entity (Task_Type);
22045 
22046             if not Is_Task_Type (Ent) then
22047                Error_Pragma_Arg
22048                  ("argument for pragma% must be task type", Task_Type);
22049             end if;
22050 
22051             if No (Top_Guard) then
22052                Error_Pragma_Arg
22053                  ("pragma% takes two arguments", Task_Type);
22054             else
22055                Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
22056             end if;
22057 
22058             Check_First_Subtype (Task_Type);
22059 
22060             if Rep_Item_Too_Late (Ent, N) then
22061                raise Pragma_Exit;
22062             end if;
22063          end Task_Storage;
22064 
22065          ---------------
22066          -- Test_Case --
22067          ---------------
22068 
22069          --  pragma Test_Case
22070          --    ([Name     =>] Static_String_EXPRESSION
22071          --    ,[Mode     =>] MODE_TYPE
22072          --   [, Requires =>  Boolean_EXPRESSION]
22073          --   [, Ensures  =>  Boolean_EXPRESSION]);
22074 
22075          --  MODE_TYPE ::= Nominal | Robustness
22076 
22077          --  Characteristics:
22078 
22079          --    * Analysis - The annotation undergoes initial checks to verify
22080          --    the legal placement and context. Secondary checks preanalyze the
22081          --    expressions in:
22082 
22083          --       Analyze_Test_Case_In_Decl_Part
22084 
22085          --    * Expansion - None.
22086 
22087          --    * Template - The annotation utilizes the generic template of the
22088          --    related subprogram when it is:
22089 
22090          --       aspect on subprogram declaration
22091 
22092          --    The annotation must prepare its own template when it is:
22093 
22094          --       pragma on subprogram declaration
22095 
22096          --    * Globals - Capture of global references must occur after full
22097          --    analysis.
22098 
22099          --    * Instance - The annotation is instantiated automatically when
22100          --    the related generic subprogram is instantiated except for the
22101          --    "pragma on subprogram declaration" case. In that scenario the
22102          --    annotation must instantiate itself.
22103 
22104          when Pragma_Test_Case => Test_Case : declare
22105             procedure Check_Distinct_Name (Subp_Id : Entity_Id);
22106             --  Ensure that the contract of subprogram Subp_Id does not contain
22107             --  another Test_Case pragma with the same Name as the current one.
22108 
22109             -------------------------
22110             -- Check_Distinct_Name --
22111             -------------------------
22112 
22113             procedure Check_Distinct_Name (Subp_Id : Entity_Id) is
22114                Items : constant Node_Id   := Contract (Subp_Id);
22115                Name  : constant String_Id := Get_Name_From_CTC_Pragma (N);
22116                Prag  : Node_Id;
22117 
22118             begin
22119                --  Inspect all Test_Case pragma of the related subprogram
22120                --  looking for one with a duplicate "Name" argument.
22121 
22122                if Present (Items) then
22123                   Prag := Contract_Test_Cases (Items);
22124                   while Present (Prag) loop
22125                      if Pragma_Name (Prag) = Name_Test_Case
22126                        and then Prag /= N
22127                        and then String_Equal
22128                                   (Name, Get_Name_From_CTC_Pragma (Prag))
22129                      then
22130                         Error_Msg_Sloc := Sloc (Prag);
22131                         Error_Pragma ("name for pragma % is already used #");
22132                      end if;
22133 
22134                      Prag := Next_Pragma (Prag);
22135                   end loop;
22136                end if;
22137             end Check_Distinct_Name;
22138 
22139             --  Local variables
22140 
22141             Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit));
22142             Asp_Arg   : Node_Id;
22143             Context   : Node_Id;
22144             Subp_Decl : Node_Id;
22145             Subp_Id   : Entity_Id;
22146 
22147          --  Start of processing for Test_Case
22148 
22149          begin
22150             GNAT_Pragma;
22151             Check_At_Least_N_Arguments (2);
22152             Check_At_Most_N_Arguments (4);
22153             Check_Arg_Order
22154               ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
22155 
22156             --  Argument "Name"
22157 
22158             Check_Optional_Identifier (Arg1, Name_Name);
22159             Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
22160 
22161             --  Argument "Mode"
22162 
22163             Check_Optional_Identifier (Arg2, Name_Mode);
22164             Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
22165 
22166             --  Arguments "Requires" and "Ensures"
22167 
22168             if Present (Arg3) then
22169                if Present (Arg4) then
22170                   Check_Identifier (Arg3, Name_Requires);
22171                   Check_Identifier (Arg4, Name_Ensures);
22172                else
22173                   Check_Identifier_Is_One_Of
22174                     (Arg3, Name_Requires, Name_Ensures);
22175                end if;
22176             end if;
22177 
22178             --  Pragma Test_Case must be associated with a subprogram declared
22179             --  in a library-level package. First determine whether the current
22180             --  compilation unit is a legal context.
22181 
22182             if Nkind_In (Pack_Decl, N_Package_Declaration,
22183                                     N_Generic_Package_Declaration)
22184             then
22185                null;
22186 
22187             --  Otherwise the placement is illegal
22188 
22189             else
22190                Error_Pragma
22191                  ("pragma % must be specified within a package declaration");
22192                return;
22193             end if;
22194 
22195             Subp_Decl := Find_Related_Declaration_Or_Body (N);
22196 
22197             --  Find the enclosing context
22198 
22199             Context := Parent (Subp_Decl);
22200 
22201             if Present (Context) then
22202                Context := Parent (Context);
22203             end if;
22204 
22205             --  Verify the placement of the pragma
22206 
22207             if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then
22208                Error_Pragma
22209                  ("pragma % cannot be applied to abstract subprogram");
22210                return;
22211 
22212             elsif Nkind (Subp_Decl) = N_Entry_Declaration then
22213                Error_Pragma ("pragma % cannot be applied to entry");
22214                return;
22215 
22216             --  The context is a [generic] subprogram declared at the top level
22217             --  of the [generic] package unit.
22218 
22219             elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
22220                                        N_Subprogram_Declaration)
22221               and then Present (Context)
22222               and then Nkind_In (Context, N_Generic_Package_Declaration,
22223                                           N_Package_Declaration)
22224             then
22225                null;
22226 
22227             --  Otherwise the placement is illegal
22228 
22229             else
22230                Error_Pragma
22231                  ("pragma % must be applied to a library-level subprogram "
22232                   & "declaration");
22233                return;
22234             end if;
22235 
22236             Subp_Id := Defining_Entity (Subp_Decl);
22237 
22238             --  Chain the pragma on the contract for further processing by
22239             --  Analyze_Test_Case_In_Decl_Part.
22240 
22241             Add_Contract_Item (N, Subp_Id);
22242 
22243             --  A pragma that applies to a Ghost entity becomes Ghost for the
22244             --  purposes of legality checks and removal of ignored Ghost code.
22245 
22246             Mark_Pragma_As_Ghost (N, Subp_Id);
22247 
22248             --  Preanalyze the original aspect argument "Name" for ASIS or for
22249             --  a generic subprogram to properly capture global references.
22250 
22251             if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then
22252                Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True);
22253 
22254                if Present (Asp_Arg) then
22255 
22256                   --  The argument appears with an identifier in association
22257                   --  form.
22258 
22259                   if Nkind (Asp_Arg) = N_Component_Association then
22260                      Asp_Arg := Expression (Asp_Arg);
22261                   end if;
22262 
22263                   Check_Expr_Is_OK_Static_Expression
22264                     (Asp_Arg, Standard_String);
22265                end if;
22266             end if;
22267 
22268             --  Ensure that the all Test_Case pragmas of the related subprogram
22269             --  have distinct names.
22270 
22271             Check_Distinct_Name (Subp_Id);
22272 
22273             --  Fully analyze the pragma when it appears inside an entry
22274             --  or subprogram body because it cannot benefit from forward
22275             --  references.
22276 
22277             if Nkind_In (Subp_Decl, N_Entry_Body,
22278                                     N_Subprogram_Body,
22279                                     N_Subprogram_Body_Stub)
22280             then
22281                --  The legality checks of pragma Test_Case are affected by the
22282                --  SPARK mode in effect and the volatility of the context.
22283                --  Analyze all pragmas in a specific order.
22284 
22285                Analyze_If_Present (Pragma_SPARK_Mode);
22286                Analyze_If_Present (Pragma_Volatile_Function);
22287                Analyze_Test_Case_In_Decl_Part (N);
22288             end if;
22289          end Test_Case;
22290 
22291          --------------------------
22292          -- Thread_Local_Storage --
22293          --------------------------
22294 
22295          --  pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
22296 
22297          when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
22298             E  : Entity_Id;
22299             Id : Node_Id;
22300 
22301          begin
22302             GNAT_Pragma;
22303             Check_Arg_Count (1);
22304             Check_Optional_Identifier (Arg1, Name_Entity);
22305             Check_Arg_Is_Library_Level_Local_Name (Arg1);
22306 
22307             Id := Get_Pragma_Arg (Arg1);
22308             Analyze (Id);
22309 
22310             if not Is_Entity_Name (Id)
22311               or else Ekind (Entity (Id)) /= E_Variable
22312             then
22313                Error_Pragma_Arg ("local variable name required", Arg1);
22314             end if;
22315 
22316             E := Entity (Id);
22317 
22318             --  A pragma that applies to a Ghost entity becomes Ghost for the
22319             --  purposes of legality checks and removal of ignored Ghost code.
22320 
22321             Mark_Pragma_As_Ghost (N, E);
22322 
22323             if Rep_Item_Too_Early (E, N)
22324                  or else
22325                Rep_Item_Too_Late (E, N)
22326             then
22327                raise Pragma_Exit;
22328             end if;
22329 
22330             Set_Has_Pragma_Thread_Local_Storage (E);
22331             Set_Has_Gigi_Rep_Item (E);
22332          end Thread_Local_Storage;
22333 
22334          ----------------
22335          -- Time_Slice --
22336          ----------------
22337 
22338          --  pragma Time_Slice (static_duration_EXPRESSION);
22339 
22340          when Pragma_Time_Slice => Time_Slice : declare
22341             Val : Ureal;
22342             Nod : Node_Id;
22343 
22344          begin
22345             GNAT_Pragma;
22346             Check_Arg_Count (1);
22347             Check_No_Identifiers;
22348             Check_In_Main_Program;
22349             Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
22350 
22351             if not Error_Posted (Arg1) then
22352                Nod := Next (N);
22353                while Present (Nod) loop
22354                   if Nkind (Nod) = N_Pragma
22355                     and then Pragma_Name (Nod) = Name_Time_Slice
22356                   then
22357                      Error_Msg_Name_1 := Pname;
22358                      Error_Msg_N ("duplicate pragma% not permitted", Nod);
22359                   end if;
22360 
22361                   Next (Nod);
22362                end loop;
22363             end if;
22364 
22365             --  Process only if in main unit
22366 
22367             if Get_Source_Unit (Loc) = Main_Unit then
22368                Opt.Time_Slice_Set := True;
22369                Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
22370 
22371                if Val <= Ureal_0 then
22372                   Opt.Time_Slice_Value := 0;
22373 
22374                elsif Val > UR_From_Uint (UI_From_Int (1000)) then
22375                   Opt.Time_Slice_Value := 1_000_000_000;
22376 
22377                else
22378                   Opt.Time_Slice_Value :=
22379                     UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
22380                end if;
22381             end if;
22382          end Time_Slice;
22383 
22384          -----------
22385          -- Title --
22386          -----------
22387 
22388          --  pragma Title (TITLING_OPTION [, TITLING OPTION]);
22389 
22390          --   TITLING_OPTION ::=
22391          --     [Title =>] STRING_LITERAL
22392          --   | [Subtitle =>] STRING_LITERAL
22393 
22394          when Pragma_Title => Title : declare
22395             Args  : Args_List (1 .. 2);
22396             Names : constant Name_List (1 .. 2) := (
22397                       Name_Title,
22398                       Name_Subtitle);
22399 
22400          begin
22401             GNAT_Pragma;
22402             Gather_Associations (Names, Args);
22403             Store_Note (N);
22404 
22405             for J in 1 .. 2 loop
22406                if Present (Args (J)) then
22407                   Check_Arg_Is_OK_Static_Expression
22408                     (Args (J), Standard_String);
22409                end if;
22410             end loop;
22411          end Title;
22412 
22413          ----------------------------
22414          -- Type_Invariant[_Class] --
22415          ----------------------------
22416 
22417          --  pragma Type_Invariant[_Class]
22418          --    ([Entity =>] type_LOCAL_NAME,
22419          --     [Check  =>] EXPRESSION);
22420 
22421          when Pragma_Type_Invariant       |
22422               Pragma_Type_Invariant_Class =>
22423          Type_Invariant : declare
22424             I_Pragma : Node_Id;
22425 
22426          begin
22427             Check_Arg_Count (2);
22428 
22429             --  Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
22430             --  setting Class_Present for the Type_Invariant_Class case.
22431 
22432             Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class);
22433             I_Pragma := New_Copy (N);
22434             Set_Pragma_Identifier
22435               (I_Pragma, Make_Identifier (Loc, Name_Invariant));
22436             Rewrite (N, I_Pragma);
22437             Set_Analyzed (N, False);
22438             Analyze (N);
22439          end Type_Invariant;
22440 
22441          ---------------------
22442          -- Unchecked_Union --
22443          ---------------------
22444 
22445          --  pragma Unchecked_Union (first_subtype_LOCAL_NAME)
22446 
22447          when Pragma_Unchecked_Union => Unchecked_Union : declare
22448             Assoc   : constant Node_Id := Arg1;
22449             Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
22450             Clist   : Node_Id;
22451             Comp    : Node_Id;
22452             Tdef    : Node_Id;
22453             Typ     : Entity_Id;
22454             Variant : Node_Id;
22455             Vpart   : Node_Id;
22456 
22457          begin
22458             Ada_2005_Pragma;
22459             Check_No_Identifiers;
22460             Check_Arg_Count (1);
22461             Check_Arg_Is_Local_Name (Arg1);
22462 
22463             Find_Type (Type_Id);
22464 
22465             Typ := Entity (Type_Id);
22466 
22467             --  A pragma that applies to a Ghost entity becomes Ghost for the
22468             --  purposes of legality checks and removal of ignored Ghost code.
22469 
22470             Mark_Pragma_As_Ghost (N, Typ);
22471 
22472             if Typ = Any_Type
22473               or else Rep_Item_Too_Early (Typ, N)
22474             then
22475                return;
22476             else
22477                Typ := Underlying_Type (Typ);
22478             end if;
22479 
22480             if Rep_Item_Too_Late (Typ, N) then
22481                return;
22482             end if;
22483 
22484             Check_First_Subtype (Arg1);
22485 
22486             --  Note remaining cases are references to a type in the current
22487             --  declarative part. If we find an error, we post the error on
22488             --  the relevant type declaration at an appropriate point.
22489 
22490             if not Is_Record_Type (Typ) then
22491                Error_Msg_N ("unchecked union must be record type", Typ);
22492                return;
22493 
22494             elsif Is_Tagged_Type (Typ) then
22495                Error_Msg_N ("unchecked union must not be tagged", Typ);
22496                return;
22497 
22498             elsif not Has_Discriminants (Typ) then
22499                Error_Msg_N
22500                  ("unchecked union must have one discriminant", Typ);
22501                return;
22502 
22503             --  Note: in previous versions of GNAT we used to check for limited
22504             --  types and give an error, but in fact the standard does allow
22505             --  Unchecked_Union on limited types, so this check was removed.
22506 
22507             --  Similarly, GNAT used to require that all discriminants have
22508             --  default values, but this is not mandated by the RM.
22509 
22510             --  Proceed with basic error checks completed
22511 
22512             else
22513                Tdef  := Type_Definition (Declaration_Node (Typ));
22514                Clist := Component_List (Tdef);
22515 
22516                --  Check presence of component list and variant part
22517 
22518                if No (Clist) or else No (Variant_Part (Clist)) then
22519                   Error_Msg_N
22520                     ("unchecked union must have variant part", Tdef);
22521                   return;
22522                end if;
22523 
22524                --  Check components
22525 
22526                Comp := First (Component_Items (Clist));
22527                while Present (Comp) loop
22528                   Check_Component (Comp, Typ);
22529                   Next (Comp);
22530                end loop;
22531 
22532                --  Check variant part
22533 
22534                Vpart := Variant_Part (Clist);
22535 
22536                Variant := First (Variants (Vpart));
22537                while Present (Variant) loop
22538                   Check_Variant (Variant, Typ);
22539                   Next (Variant);
22540                end loop;
22541             end if;
22542 
22543             Set_Is_Unchecked_Union  (Typ);
22544             Set_Convention (Typ, Convention_C);
22545             Set_Has_Unchecked_Union (Base_Type (Typ));
22546             Set_Is_Unchecked_Union  (Base_Type (Typ));
22547          end Unchecked_Union;
22548 
22549          ----------------------------
22550          -- Unevaluated_Use_Of_Old --
22551          ----------------------------
22552 
22553          --  pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
22554 
22555          when Pragma_Unevaluated_Use_Of_Old =>
22556             GNAT_Pragma;
22557             Check_Arg_Count (1);
22558             Check_No_Identifiers;
22559             Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
22560 
22561             --  Suppress/Unsuppress can appear as a configuration pragma, or in
22562             --  a declarative part or a package spec.
22563 
22564             if not Is_Configuration_Pragma then
22565                Check_Is_In_Decl_Part_Or_Package_Spec;
22566             end if;
22567 
22568             --  Store proper setting of Uneval_Old
22569 
22570             Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
22571             Uneval_Old := Fold_Upper (Name_Buffer (1));
22572 
22573          ------------------------
22574          -- Unimplemented_Unit --
22575          ------------------------
22576 
22577          --  pragma Unimplemented_Unit;
22578 
22579          --  Note: this only gives an error if we are generating code, or if
22580          --  we are in a generic library unit (where the pragma appears in the
22581          --  body, not in the spec).
22582 
22583          when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
22584             Cunitent : constant Entity_Id   :=
22585                          Cunit_Entity (Get_Source_Unit (Loc));
22586             Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
22587 
22588          begin
22589             GNAT_Pragma;
22590             Check_Arg_Count (0);
22591 
22592             if Operating_Mode = Generate_Code
22593               or else Ent_Kind = E_Generic_Function
22594               or else Ent_Kind = E_Generic_Procedure
22595               or else Ent_Kind = E_Generic_Package
22596             then
22597                Get_Name_String (Chars (Cunitent));
22598                Set_Casing (Mixed_Case);
22599                Write_Str (Name_Buffer (1 .. Name_Len));
22600                Write_Str (" is not supported in this configuration");
22601                Write_Eol;
22602                raise Unrecoverable_Error;
22603             end if;
22604          end Unimplemented_Unit;
22605 
22606          ------------------------
22607          -- Universal_Aliasing --
22608          ------------------------
22609 
22610          --  pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
22611 
22612          when Pragma_Universal_Aliasing => Universal_Alias : declare
22613             E_Id : Entity_Id;
22614 
22615          begin
22616             GNAT_Pragma;
22617             Check_Arg_Count (1);
22618             Check_Optional_Identifier (Arg2, Name_Entity);
22619             Check_Arg_Is_Local_Name (Arg1);
22620             E_Id := Entity (Get_Pragma_Arg (Arg1));
22621 
22622             if E_Id = Any_Type then
22623                return;
22624             elsif No (E_Id) or else not Is_Type (E_Id) then
22625                Error_Pragma_Arg ("pragma% requires type", Arg1);
22626             end if;
22627 
22628             --  A pragma that applies to a Ghost entity becomes Ghost for the
22629             --  purposes of legality checks and removal of ignored Ghost code.
22630 
22631             Mark_Pragma_As_Ghost (N, E_Id);
22632             Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
22633             Record_Rep_Item (E_Id, N);
22634          end Universal_Alias;
22635 
22636          --------------------
22637          -- Universal_Data --
22638          --------------------
22639 
22640          --  pragma Universal_Data [(library_unit_NAME)];
22641 
22642          when Pragma_Universal_Data =>
22643             GNAT_Pragma;
22644             Error_Pragma ("??pragma% ignored (applies only to AAMP)");
22645 
22646          ----------------
22647          -- Unmodified --
22648          ----------------
22649 
22650          --  pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
22651 
22652          when Pragma_Unmodified =>
22653             Analyze_Unmodified_Or_Unused;
22654 
22655          ------------------
22656          -- Unreferenced --
22657          ------------------
22658 
22659          --  pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
22660 
22661          --    or when used in a context clause:
22662 
22663          --  pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
22664 
22665          when Pragma_Unreferenced =>
22666             Analyze_Unreferenced_Or_Unused;
22667 
22668          --------------------------
22669          -- Unreferenced_Objects --
22670          --------------------------
22671 
22672          --  pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
22673 
22674          when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
22675             Arg      : Node_Id;
22676             Arg_Expr : Node_Id;
22677             Arg_Id   : Entity_Id;
22678 
22679             Ghost_Error_Posted : Boolean := False;
22680             --  Flag set when an error concerning the illegal mix of Ghost and
22681             --  non-Ghost types is emitted.
22682 
22683             Ghost_Id : Entity_Id := Empty;
22684             --  The entity of the first Ghost type encountered while processing
22685             --  the arguments of the pragma.
22686 
22687          begin
22688             GNAT_Pragma;
22689             Check_At_Least_N_Arguments (1);
22690 
22691             Arg := Arg1;
22692             while Present (Arg) loop
22693                Check_No_Identifier (Arg);
22694                Check_Arg_Is_Local_Name (Arg);
22695                Arg_Expr := Get_Pragma_Arg (Arg);
22696 
22697                if Is_Entity_Name (Arg_Expr) then
22698                   Arg_Id := Entity (Arg_Expr);
22699 
22700                   if Is_Type (Arg_Id) then
22701                      Set_Has_Pragma_Unreferenced_Objects (Arg_Id);
22702 
22703                      --  A pragma that applies to a Ghost entity becomes Ghost
22704                      --  for the purposes of legality checks and removal of
22705                      --  ignored Ghost code.
22706 
22707                      Mark_Pragma_As_Ghost (N, Arg_Id);
22708 
22709                      --  Capture the entity of the first Ghost type being
22710                      --  processed for error detection purposes.
22711 
22712                      if Is_Ghost_Entity (Arg_Id) then
22713                         if No (Ghost_Id) then
22714                            Ghost_Id := Arg_Id;
22715                         end if;
22716 
22717                      --  Otherwise the type is non-Ghost. It is illegal to mix
22718                      --  references to Ghost and non-Ghost entities
22719                      --  (SPARK RM 6.9).
22720 
22721                      elsif Present (Ghost_Id)
22722                        and then not Ghost_Error_Posted
22723                      then
22724                         Ghost_Error_Posted := True;
22725 
22726                         Error_Msg_Name_1 := Pname;
22727                         Error_Msg_N
22728                           ("pragma % cannot mention ghost and non-ghost types",
22729                            N);
22730 
22731                         Error_Msg_Sloc := Sloc (Ghost_Id);
22732                         Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
22733 
22734                         Error_Msg_Sloc := Sloc (Arg_Id);
22735                         Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
22736                      end if;
22737                   else
22738                      Error_Pragma_Arg
22739                        ("argument for pragma% must be type or subtype", Arg);
22740                   end if;
22741                else
22742                   Error_Pragma_Arg
22743                     ("argument for pragma% must be type or subtype", Arg);
22744                end if;
22745 
22746                Next (Arg);
22747             end loop;
22748          end Unreferenced_Objects;
22749 
22750          ------------------------------
22751          -- Unreserve_All_Interrupts --
22752          ------------------------------
22753 
22754          --  pragma Unreserve_All_Interrupts;
22755 
22756          when Pragma_Unreserve_All_Interrupts =>
22757             GNAT_Pragma;
22758             Check_Arg_Count (0);
22759 
22760             if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
22761                Unreserve_All_Interrupts := True;
22762             end if;
22763 
22764          ----------------
22765          -- Unsuppress --
22766          ----------------
22767 
22768          --  pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
22769 
22770          when Pragma_Unsuppress =>
22771             Ada_2005_Pragma;
22772             Process_Suppress_Unsuppress (Suppress_Case => False);
22773 
22774          ------------
22775          -- Unused --
22776          ------------
22777 
22778          --  pragma Unused (LOCAL_NAME {, LOCAL_NAME});
22779 
22780          when Pragma_Unused =>
22781             Analyze_Unmodified_Or_Unused   (Is_Unused => True);
22782             Analyze_Unreferenced_Or_Unused (Is_Unused => True);
22783 
22784          -------------------
22785          -- Use_VADS_Size --
22786          -------------------
22787 
22788          --  pragma Use_VADS_Size;
22789 
22790          when Pragma_Use_VADS_Size =>
22791             GNAT_Pragma;
22792             Check_Arg_Count (0);
22793             Check_Valid_Configuration_Pragma;
22794             Use_VADS_Size := True;
22795 
22796          ---------------------
22797          -- Validity_Checks --
22798          ---------------------
22799 
22800          --  pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22801 
22802          when Pragma_Validity_Checks => Validity_Checks : declare
22803             A  : constant Node_Id := Get_Pragma_Arg (Arg1);
22804             S  : String_Id;
22805             C  : Char_Code;
22806 
22807          begin
22808             GNAT_Pragma;
22809             Check_Arg_Count (1);
22810             Check_No_Identifiers;
22811 
22812             --  Pragma always active unless in CodePeer or GNATprove modes,
22813             --  which use a fixed configuration of validity checks.
22814 
22815             if not (CodePeer_Mode or GNATprove_Mode) then
22816                if Nkind (A) = N_String_Literal then
22817                   S := Strval (A);
22818 
22819                   declare
22820                      Slen    : constant Natural := Natural (String_Length (S));
22821                      Options : String (1 .. Slen);
22822                      J       : Positive;
22823 
22824                   begin
22825                      --  Couldn't we use a for loop here over Options'Range???
22826 
22827                      J := 1;
22828                      loop
22829                         C := Get_String_Char (S, Pos (J));
22830 
22831                         --  This is a weird test, it skips setting validity
22832                         --  checks entirely if any element of S is out of
22833                         --  range of Character, what is that about ???
22834 
22835                         exit when not In_Character_Range (C);
22836                         Options (J) := Get_Character (C);
22837 
22838                         if J = Slen then
22839                            Set_Validity_Check_Options (Options);
22840                            exit;
22841                         else
22842                            J := J + 1;
22843                         end if;
22844                      end loop;
22845                   end;
22846 
22847                elsif Nkind (A) = N_Identifier then
22848                   if Chars (A) = Name_All_Checks then
22849                      Set_Validity_Check_Options ("a");
22850                   elsif Chars (A) = Name_On then
22851                      Validity_Checks_On := True;
22852                   elsif Chars (A) = Name_Off then
22853                      Validity_Checks_On := False;
22854                   end if;
22855                end if;
22856             end if;
22857          end Validity_Checks;
22858 
22859          --------------
22860          -- Volatile --
22861          --------------
22862 
22863          --  pragma Volatile (LOCAL_NAME);
22864 
22865          when Pragma_Volatile =>
22866             Process_Atomic_Independent_Shared_Volatile;
22867 
22868          -------------------------
22869          -- Volatile_Components --
22870          -------------------------
22871 
22872          --  pragma Volatile_Components (array_LOCAL_NAME);
22873 
22874          --  Volatile is handled by the same circuit as Atomic_Components
22875 
22876          --------------------------
22877          -- Volatile_Full_Access --
22878          --------------------------
22879 
22880          --  pragma Volatile_Full_Access (LOCAL_NAME);
22881 
22882          when Pragma_Volatile_Full_Access =>
22883             GNAT_Pragma;
22884             Process_Atomic_Independent_Shared_Volatile;
22885 
22886          -----------------------
22887          -- Volatile_Function --
22888          -----------------------
22889 
22890          --  pragma Volatile_Function [ (boolean_EXPRESSION) ];
22891 
22892          when Pragma_Volatile_Function => Volatile_Function : declare
22893             Over_Id   : Entity_Id;
22894             Spec_Id   : Entity_Id;
22895             Subp_Decl : Node_Id;
22896 
22897          begin
22898             GNAT_Pragma;
22899             Check_No_Identifiers;
22900             Check_At_Most_N_Arguments (1);
22901 
22902             Subp_Decl :=
22903               Find_Related_Declaration_Or_Body (N, Do_Checks => True);
22904 
22905             --  Generic subprogram
22906 
22907             if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then
22908                null;
22909 
22910             --  Body acts as spec
22911 
22912             elsif Nkind (Subp_Decl) = N_Subprogram_Body
22913               and then No (Corresponding_Spec (Subp_Decl))
22914             then
22915                null;
22916 
22917             --  Body stub acts as spec
22918 
22919             elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
22920               and then No (Corresponding_Spec_Of_Stub (Subp_Decl))
22921             then
22922                null;
22923 
22924             --  Subprogram
22925 
22926             elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then
22927                null;
22928 
22929             else
22930                Pragma_Misplaced;
22931                return;
22932             end if;
22933 
22934             Spec_Id := Unique_Defining_Entity (Subp_Decl);
22935 
22936             if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
22937                Pragma_Misplaced;
22938                return;
22939             end if;
22940 
22941             --  Chain the pragma on the contract for completeness
22942 
22943             Add_Contract_Item (N, Spec_Id);
22944 
22945             --  The legality checks of pragma Volatile_Function are affected by
22946             --  the SPARK mode in effect. Analyze all pragmas in a specific
22947             --  order.
22948 
22949             Analyze_If_Present (Pragma_SPARK_Mode);
22950 
22951             --  A pragma that applies to a Ghost entity becomes Ghost for the
22952             --  purposes of legality checks and removal of ignored Ghost code.
22953 
22954             Mark_Pragma_As_Ghost (N, Spec_Id);
22955 
22956             --  A volatile function cannot override a non-volatile function
22957             --  (SPARK RM 7.1.2(15)). Overriding checks are usually performed
22958             --  in New_Overloaded_Entity, however at that point the pragma has
22959             --  not been processed yet.
22960 
22961             Over_Id := Overridden_Operation (Spec_Id);
22962 
22963             if Present (Over_Id)
22964               and then not Is_Volatile_Function (Over_Id)
22965             then
22966                Error_Msg_N
22967                  ("incompatible volatile function values in effect", Spec_Id);
22968 
22969                Error_Msg_Sloc := Sloc (Over_Id);
22970                Error_Msg_N
22971                  ("\& declared # with Volatile_Function value False",
22972                   Spec_Id);
22973 
22974                Error_Msg_Sloc := Sloc (Spec_Id);
22975                Error_Msg_N
22976                  ("\overridden # with Volatile_Function value True",
22977                   Spec_Id);
22978             end if;
22979 
22980             --  Analyze the Boolean expression (if any)
22981 
22982             if Present (Arg1) then
22983                Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1));
22984             end if;
22985          end Volatile_Function;
22986 
22987          ----------------------
22988          -- Warning_As_Error --
22989          ----------------------
22990 
22991          --  pragma Warning_As_Error (static_string_EXPRESSION);
22992 
22993          when Pragma_Warning_As_Error =>
22994             GNAT_Pragma;
22995             Check_Arg_Count (1);
22996             Check_No_Identifiers;
22997             Check_Valid_Configuration_Pragma;
22998 
22999             if not Is_Static_String_Expression (Arg1) then
23000                Error_Pragma_Arg
23001                  ("argument of pragma% must be static string expression",
23002                   Arg1);
23003 
23004             --  OK static string expression
23005 
23006             else
23007                Acquire_Warning_Match_String (Arg1);
23008                Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1;
23009                Warnings_As_Errors (Warnings_As_Errors_Count) :=
23010                  new String'(Name_Buffer (1 .. Name_Len));
23011             end if;
23012 
23013          --------------
23014          -- Warnings --
23015          --------------
23016 
23017          --  pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
23018 
23019          --  DETAILS ::= On | Off
23020          --  DETAILS ::= On | Off, local_NAME
23021          --  DETAILS ::= static_string_EXPRESSION
23022          --  DETAILS ::= On | Off, static_string_EXPRESSION
23023 
23024          --  TOOL_NAME ::= GNAT | GNATProve
23025 
23026          --  REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
23027 
23028          --  Note: If the first argument matches an allowed tool name, it is
23029          --  always considered to be a tool name, even if there is a string
23030          --  variable of that name.
23031 
23032          --  Note if the second argument of DETAILS is a local_NAME then the
23033          --  second form is always understood. If the intention is to use
23034          --  the fourth form, then you can write NAME & "" to force the
23035          --  intepretation as a static_string_EXPRESSION.
23036 
23037          when Pragma_Warnings => Warnings : declare
23038             Reason : String_Id;
23039 
23040          begin
23041             GNAT_Pragma;
23042             Check_At_Least_N_Arguments (1);
23043 
23044             --  See if last argument is labeled Reason. If so, make sure we
23045             --  have a string literal or a concatenation of string literals,
23046             --  and acquire the REASON string. Then remove the REASON argument
23047             --  by decreasing Num_Args by one; Remaining processing looks only
23048             --  at first Num_Args arguments).
23049 
23050             declare
23051                Last_Arg : constant Node_Id :=
23052                             Last (Pragma_Argument_Associations (N));
23053 
23054             begin
23055                if Nkind (Last_Arg) = N_Pragma_Argument_Association
23056                  and then Chars (Last_Arg) = Name_Reason
23057                then
23058                   Start_String;
23059                   Get_Reason_String (Get_Pragma_Arg (Last_Arg));
23060                   Reason := End_String;
23061                   Arg_Count := Arg_Count - 1;
23062 
23063                   --  Not allowed in compiler units (bootstrap issues)
23064 
23065                   Check_Compiler_Unit ("Reason for pragma Warnings", N);
23066 
23067                --  No REASON string, set null string as reason
23068 
23069                else
23070                   Reason := Null_String_Id;
23071                end if;
23072             end;
23073 
23074             --  Now proceed with REASON taken care of and eliminated
23075 
23076             Check_No_Identifiers;
23077 
23078             --  If debug flag -gnatd.i is set, pragma is ignored
23079 
23080             if Debug_Flag_Dot_I then
23081                return;
23082             end if;
23083 
23084             --  Process various forms of the pragma
23085 
23086             declare
23087                Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
23088                Shifted_Args : List_Id;
23089 
23090             begin
23091                --  See if first argument is a tool name, currently either
23092                --  GNAT or GNATprove. If so, either ignore the pragma if the
23093                --  tool used does not match, or continue as if no tool name
23094                --  was given otherwise, by shifting the arguments.
23095 
23096                if Nkind (Argx) = N_Identifier
23097                  and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
23098                then
23099                   if Chars (Argx) = Name_Gnat then
23100                      if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
23101                         Rewrite (N, Make_Null_Statement (Loc));
23102                         Analyze (N);
23103                         raise Pragma_Exit;
23104                      end if;
23105 
23106                   elsif Chars (Argx) = Name_Gnatprove then
23107                      if not GNATprove_Mode then
23108                         Rewrite (N, Make_Null_Statement (Loc));
23109                         Analyze (N);
23110                         raise Pragma_Exit;
23111                      end if;
23112 
23113                   else
23114                      raise Program_Error;
23115                   end if;
23116 
23117                   --  At this point, the pragma Warnings applies to the tool,
23118                   --  so continue with shifted arguments.
23119 
23120                   Arg_Count := Arg_Count - 1;
23121 
23122                   if Arg_Count = 1 then
23123                      Shifted_Args := New_List (New_Copy (Arg2));
23124                   elsif Arg_Count = 2 then
23125                      Shifted_Args := New_List (New_Copy (Arg2),
23126                                                New_Copy (Arg3));
23127                   elsif Arg_Count = 3 then
23128                      Shifted_Args := New_List (New_Copy (Arg2),
23129                                                New_Copy (Arg3),
23130                                                New_Copy (Arg4));
23131                   else
23132                      raise Program_Error;
23133                   end if;
23134 
23135                   Rewrite (N,
23136                     Make_Pragma (Loc,
23137                       Chars                        => Name_Warnings,
23138                       Pragma_Argument_Associations => Shifted_Args));
23139                   Analyze (N);
23140                   raise Pragma_Exit;
23141                end if;
23142 
23143                --  One argument case
23144 
23145                if Arg_Count = 1 then
23146 
23147                   --  On/Off one argument case was processed by parser
23148 
23149                   if Nkind (Argx) = N_Identifier
23150                     and then Nam_In (Chars (Argx), Name_On, Name_Off)
23151                   then
23152                      null;
23153 
23154                   --  One argument case must be ON/OFF or static string expr
23155 
23156                   elsif not Is_Static_String_Expression (Arg1) then
23157                      Error_Pragma_Arg
23158                        ("argument of pragma% must be On/Off or static string "
23159                         & "expression", Arg1);
23160 
23161                   --  One argument string expression case
23162 
23163                   else
23164                      declare
23165                         Lit : constant Node_Id   := Expr_Value_S (Argx);
23166                         Str : constant String_Id := Strval (Lit);
23167                         Len : constant Nat       := String_Length (Str);
23168                         C   : Char_Code;
23169                         J   : Nat;
23170                         OK  : Boolean;
23171                         Chr : Character;
23172 
23173                      begin
23174                         J := 1;
23175                         while J <= Len loop
23176                            C := Get_String_Char (Str, J);
23177                            OK := In_Character_Range (C);
23178 
23179                            if OK then
23180                               Chr := Get_Character (C);
23181 
23182                               --  Dash case: only -Wxxx is accepted
23183 
23184                               if J = 1
23185                                 and then J < Len
23186                                 and then Chr = '-'
23187                               then
23188                                  J := J + 1;
23189                                  C := Get_String_Char (Str, J);
23190                                  Chr := Get_Character (C);
23191                                  exit when Chr = 'W';
23192                                  OK := False;
23193 
23194                               --  Dot case
23195 
23196                               elsif J < Len and then Chr = '.' then
23197                                  J := J + 1;
23198                                  C := Get_String_Char (Str, J);
23199                                  Chr := Get_Character (C);
23200 
23201                                  if not Set_Dot_Warning_Switch (Chr) then
23202                                     Error_Pragma_Arg
23203                                       ("invalid warning switch character "
23204                                        & '.' & Chr, Arg1);
23205                                  end if;
23206 
23207                               --  Non-Dot case
23208 
23209                               else
23210                                  OK := Set_Warning_Switch (Chr);
23211                               end if;
23212                            end if;
23213 
23214                            if not OK then
23215                               Error_Pragma_Arg
23216                                 ("invalid warning switch character " & Chr,
23217                                  Arg1);
23218                            end if;
23219 
23220                            J := J + 1;
23221                         end loop;
23222                      end;
23223                   end if;
23224 
23225                --  Two or more arguments (must be two)
23226 
23227                else
23228                   Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23229                   Check_Arg_Count (2);
23230 
23231                   declare
23232                      E_Id : Node_Id;
23233                      E    : Entity_Id;
23234                      Err  : Boolean;
23235 
23236                   begin
23237                      E_Id := Get_Pragma_Arg (Arg2);
23238                      Analyze (E_Id);
23239 
23240                      --  In the expansion of an inlined body, a reference to
23241                      --  the formal may be wrapped in a conversion if the
23242                      --  actual is a conversion. Retrieve the real entity name.
23243 
23244                      if (In_Instance_Body or In_Inlined_Body)
23245                        and then Nkind (E_Id) = N_Unchecked_Type_Conversion
23246                      then
23247                         E_Id := Expression (E_Id);
23248                      end if;
23249 
23250                      --  Entity name case
23251 
23252                      if Is_Entity_Name (E_Id) then
23253                         E := Entity (E_Id);
23254 
23255                         if E = Any_Id then
23256                            return;
23257                         else
23258                            loop
23259                               Set_Warnings_Off
23260                                 (E, (Chars (Get_Pragma_Arg (Arg1)) =
23261                                       Name_Off));
23262 
23263                               --  For OFF case, make entry in warnings off
23264                               --  pragma table for later processing. But we do
23265                               --  not do that within an instance, since these
23266                               --  warnings are about what is needed in the
23267                               --  template, not an instance of it.
23268 
23269                               if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
23270                                 and then Warn_On_Warnings_Off
23271                                 and then not In_Instance
23272                               then
23273                                  Warnings_Off_Pragmas.Append ((N, E, Reason));
23274                               end if;
23275 
23276                               if Is_Enumeration_Type (E) then
23277                                  declare
23278                                     Lit : Entity_Id;
23279                                  begin
23280                                     Lit := First_Literal (E);
23281                                     while Present (Lit) loop
23282                                        Set_Warnings_Off (Lit);
23283                                        Next_Literal (Lit);
23284                                     end loop;
23285                                  end;
23286                               end if;
23287 
23288                               exit when No (Homonym (E));
23289                               E := Homonym (E);
23290                            end loop;
23291                         end if;
23292 
23293                      --  Error if not entity or static string expression case
23294 
23295                      elsif not Is_Static_String_Expression (Arg2) then
23296                         Error_Pragma_Arg
23297                           ("second argument of pragma% must be entity name "
23298                            & "or static string expression", Arg2);
23299 
23300                      --  Static string expression case
23301 
23302                      else
23303                         Acquire_Warning_Match_String (Arg2);
23304 
23305                         --  Note on configuration pragma case: If this is a
23306                         --  configuration pragma, then for an OFF pragma, we
23307                         --  just set Config True in the call, which is all
23308                         --  that needs to be done. For the case of ON, this
23309                         --  is normally an error, unless it is canceling the
23310                         --  effect of a previous OFF pragma in the same file.
23311                         --  In any other case, an error will be signalled (ON
23312                         --  with no matching OFF).
23313 
23314                         --  Note: We set Used if we are inside a generic to
23315                         --  disable the test that the non-config case actually
23316                         --  cancels a warning. That's because we can't be sure
23317                         --  there isn't an instantiation in some other unit
23318                         --  where a warning is suppressed.
23319 
23320                         --  We could do a little better here by checking if the
23321                         --  generic unit we are inside is public, but for now
23322                         --  we don't bother with that refinement.
23323 
23324                         if Chars (Argx) = Name_Off then
23325                            Set_Specific_Warning_Off
23326                              (Loc, Name_Buffer (1 .. Name_Len), Reason,
23327                               Config => Is_Configuration_Pragma,
23328                               Used   => Inside_A_Generic or else In_Instance);
23329 
23330                         elsif Chars (Argx) = Name_On then
23331                            Set_Specific_Warning_On
23332                              (Loc, Name_Buffer (1 .. Name_Len), Err);
23333 
23334                            if Err then
23335                               Error_Msg
23336                                 ("??pragma Warnings On with no matching "
23337                                  & "Warnings Off", Loc);
23338                            end if;
23339                         end if;
23340                      end if;
23341                   end;
23342                end if;
23343             end;
23344          end Warnings;
23345 
23346          -------------------
23347          -- Weak_External --
23348          -------------------
23349 
23350          --  pragma Weak_External ([Entity =>] LOCAL_NAME);
23351 
23352          when Pragma_Weak_External => Weak_External : declare
23353             Ent : Entity_Id;
23354 
23355          begin
23356             GNAT_Pragma;
23357             Check_Arg_Count (1);
23358             Check_Optional_Identifier (Arg1, Name_Entity);
23359             Check_Arg_Is_Library_Level_Local_Name (Arg1);
23360             Ent := Entity (Get_Pragma_Arg (Arg1));
23361 
23362             if Rep_Item_Too_Early (Ent, N) then
23363                return;
23364             else
23365                Ent := Underlying_Type (Ent);
23366             end if;
23367 
23368             --  The only processing required is to link this item on to the
23369             --  list of rep items for the given entity. This is accomplished
23370             --  by the call to Rep_Item_Too_Late (when no error is detected
23371             --  and False is returned).
23372 
23373             if Rep_Item_Too_Late (Ent, N) then
23374                return;
23375             else
23376                Set_Has_Gigi_Rep_Item (Ent);
23377             end if;
23378          end Weak_External;
23379 
23380          -----------------------------
23381          -- Wide_Character_Encoding --
23382          -----------------------------
23383 
23384          --  pragma Wide_Character_Encoding (IDENTIFIER);
23385 
23386          when Pragma_Wide_Character_Encoding =>
23387             GNAT_Pragma;
23388 
23389             --  Nothing to do, handled in parser. Note that we do not enforce
23390             --  configuration pragma placement, this pragma can appear at any
23391             --  place in the source, allowing mixed encodings within a single
23392             --  source program.
23393 
23394             null;
23395 
23396          --------------------
23397          -- Unknown_Pragma --
23398          --------------------
23399 
23400          --  Should be impossible, since the case of an unknown pragma is
23401          --  separately processed before the case statement is entered.
23402 
23403          when Unknown_Pragma =>
23404             raise Program_Error;
23405       end case;
23406 
23407       --  AI05-0144: detect dangerous order dependence. Disabled for now,
23408       --  until AI is formally approved.
23409 
23410       --  Check_Order_Dependence;
23411 
23412    exception
23413       when Pragma_Exit => null;
23414    end Analyze_Pragma;
23415 
23416    ---------------------------------------------
23417    -- Analyze_Pre_Post_Condition_In_Decl_Part --
23418    ---------------------------------------------
23419 
23420    procedure Analyze_Pre_Post_Condition_In_Decl_Part
23421      (N         : Node_Id;
23422       Freeze_Id : Entity_Id := Empty)
23423    is
23424       Disp_Typ : Entity_Id;
23425       --  The dispatching type of the subprogram subject to the pre- or
23426       --  postcondition.
23427 
23428       function Check_References (Nod : Node_Id) return Traverse_Result;
23429       --  Check that expression Nod does not mention non-primitives of the
23430       --  type, global objects of the type, or other illegalities described
23431       --  and implied by AI12-0113.
23432 
23433       ----------------------
23434       -- Check_References --
23435       ----------------------
23436 
23437       function Check_References (Nod : Node_Id) return Traverse_Result is
23438       begin
23439          if Nkind (Nod) = N_Function_Call
23440            and then Is_Entity_Name (Name (Nod))
23441          then
23442             declare
23443                Func : constant Entity_Id := Entity (Name (Nod));
23444                Form : Entity_Id;
23445 
23446             begin
23447                --  An operation of the type must be a primitive
23448 
23449                if No (Find_Dispatching_Type (Func)) then
23450                   Form := First_Formal (Func);
23451                   while Present (Form) loop
23452                      if Etype (Form) = Disp_Typ then
23453                         Error_Msg_NE
23454                           ("operation in class-wide condition must be "
23455                            & "primitive of &", Nod, Disp_Typ);
23456                      end if;
23457 
23458                      Next_Formal (Form);
23459                   end loop;
23460 
23461                   --  A return object of the type is illegal as well
23462 
23463                   if Etype (Func) = Disp_Typ
23464                     or else Etype (Func) = Class_Wide_Type (Disp_Typ)
23465                   then
23466                      Error_Msg_NE
23467                        ("operation in class-wide condition must be primitive "
23468                         & "of &", Nod, Disp_Typ);
23469                   end if;
23470                end if;
23471             end;
23472 
23473          elsif Is_Entity_Name (Nod)
23474            and then
23475              (Etype (Nod) = Disp_Typ
23476                or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
23477            and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
23478          then
23479             Error_Msg_NE
23480               ("object in class-wide condition must be formal of type &",
23481                 Nod, Disp_Typ);
23482 
23483          elsif Nkind (Nod) = N_Explicit_Dereference
23484            and then (Etype (Nod) = Disp_Typ
23485                       or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
23486            and then (not Is_Entity_Name (Prefix (Nod))
23487                       or else not Is_Formal (Entity (Prefix (Nod))))
23488          then
23489             Error_Msg_NE
23490               ("operation in class-wide condition must be primitive of &",
23491                Nod, Disp_Typ);
23492          end if;
23493 
23494          return OK;
23495       end Check_References;
23496 
23497       procedure Check_Class_Wide_Condition is
23498         new Traverse_Proc (Check_References);
23499 
23500       --  Local variables
23501 
23502       Subp_Decl : constant Node_Id   := Find_Related_Declaration_Or_Body (N);
23503       Spec_Id   : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
23504       Expr      : constant Node_Id   := Expression (Get_Argument (N, Spec_Id));
23505 
23506       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
23507 
23508       Errors        : Nat;
23509       Restore_Scope : Boolean := False;
23510 
23511    --  Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
23512 
23513    begin
23514       --  Do not analyze the pragma multiple times
23515 
23516       if Is_Analyzed_Pragma (N) then
23517          return;
23518       end if;
23519 
23520       --  Set the Ghost mode in effect from the pragma. Due to the delayed
23521       --  analysis of the pragma, the Ghost mode at point of declaration and
23522       --  point of analysis may not necessarily be the same. Use the mode in
23523       --  effect at the point of declaration.
23524 
23525       Set_Ghost_Mode (N);
23526 
23527       --  Ensure that the subprogram and its formals are visible when analyzing
23528       --  the expression of the pragma.
23529 
23530       if not In_Open_Scopes (Spec_Id) then
23531          Restore_Scope := True;
23532          Push_Scope (Spec_Id);
23533 
23534          if Is_Generic_Subprogram (Spec_Id) then
23535             Install_Generic_Formals (Spec_Id);
23536          else
23537             Install_Formals (Spec_Id);
23538          end if;
23539       end if;
23540 
23541       Errors := Serious_Errors_Detected;
23542       Preanalyze_Assert_Expression (Expr, Standard_Boolean);
23543 
23544       --  Emit a clarification message when the expression contains at least
23545       --  one undefined reference, possibly due to contract "freezing".
23546 
23547       if Errors /= Serious_Errors_Detected
23548         and then Present (Freeze_Id)
23549         and then Has_Undefined_Reference (Expr)
23550       then
23551          Contract_Freeze_Error (Spec_Id, Freeze_Id);
23552       end if;
23553 
23554       if Class_Present (N) then
23555 
23556          --  Verify that a class-wide condition is legal, i.e. the operation is
23557          --  a primitive of a tagged type. Note that a generic subprogram is
23558          --  not a primitive operation.
23559 
23560          Disp_Typ := Find_Dispatching_Type (Spec_Id);
23561 
23562          if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
23563             Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
23564 
23565             if From_Aspect_Specification (N) then
23566                Error_Msg_N
23567                  ("aspect % can only be specified for a primitive operation "
23568                   & "of a tagged type", Corresponding_Aspect (N));
23569 
23570             --  The pragma is a source construct
23571 
23572             else
23573                Error_Msg_N
23574                  ("pragma % can only be specified for a primitive operation "
23575                   & "of a tagged type", N);
23576             end if;
23577 
23578          --  Remaining semantic checks require a full tree traversal
23579 
23580          else
23581             Check_Class_Wide_Condition (Expr);
23582          end if;
23583 
23584       end if;
23585 
23586       if Restore_Scope then
23587          End_Scope;
23588       end if;
23589 
23590       --  Currently it is not possible to inline pre/postconditions on a
23591       --  subprogram subject to pragma Inline_Always.
23592 
23593       Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
23594       Ghost_Mode := Save_Ghost_Mode;
23595 
23596       Set_Is_Analyzed_Pragma (N);
23597    end Analyze_Pre_Post_Condition_In_Decl_Part;
23598 
23599    ------------------------------------------
23600    -- Analyze_Refined_Depends_In_Decl_Part --
23601    ------------------------------------------
23602 
23603    procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
23604       Body_Inputs  : Elist_Id := No_Elist;
23605       Body_Outputs : Elist_Id := No_Elist;
23606       --  The inputs and outputs of the subprogram body synthesized from pragma
23607       --  Refined_Depends.
23608 
23609       Dependencies : List_Id := No_List;
23610       Depends      : Node_Id;
23611       --  The corresponding Depends pragma along with its clauses
23612 
23613       Matched_Items : Elist_Id := No_Elist;
23614       --  A list containing the entities of all successfully matched items
23615       --  found in pragma Depends.
23616 
23617       Refinements : List_Id := No_List;
23618       --  The clauses of pragma Refined_Depends
23619 
23620       Spec_Id : Entity_Id;
23621       --  The entity of the subprogram subject to pragma Refined_Depends
23622 
23623       Spec_Inputs  : Elist_Id := No_Elist;
23624       Spec_Outputs : Elist_Id := No_Elist;
23625       --  The inputs and outputs of the subprogram spec synthesized from pragma
23626       --  Depends.
23627 
23628       procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
23629       --  Try to match a single dependency clause Dep_Clause against one or
23630       --  more refinement clauses found in list Refinements. Each successful
23631       --  match eliminates at least one refinement clause from Refinements.
23632 
23633       procedure Check_Output_States;
23634       --  Determine whether pragma Depends contains an output state with a
23635       --  visible refinement and if so, ensure that pragma Refined_Depends
23636       --  mentions all its constituents as outputs.
23637 
23638       procedure Normalize_Clauses (Clauses : List_Id);
23639       --  Given a list of dependence or refinement clauses Clauses, normalize
23640       --  each clause by creating multiple dependencies with exactly one input
23641       --  and one output.
23642 
23643       procedure Report_Extra_Clauses;
23644       --  Emit an error for each extra clause found in list Refinements
23645 
23646       -----------------------------
23647       -- Check_Dependency_Clause --
23648       -----------------------------
23649 
23650       procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
23651          Dep_Input  : constant Node_Id := Expression (Dep_Clause);
23652          Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
23653 
23654          function Is_In_Out_State_Clause return Boolean;
23655          --  Determine whether dependence clause Dep_Clause denotes an abstract
23656          --  state that depends on itself (State => State).
23657 
23658          function Is_Null_Refined_State (Item : Node_Id) return Boolean;
23659          --  Determine whether item Item denotes an abstract state with visible
23660          --  null refinement.
23661 
23662          procedure Match_Items
23663            (Dep_Item : Node_Id;
23664             Ref_Item : Node_Id;
23665             Matched  : out Boolean);
23666          --  Try to match dependence item Dep_Item against refinement item
23667          --  Ref_Item. To match against a possible null refinement (see 2, 7),
23668          --  set Ref_Item to Empty. Flag Matched is set to True when one of
23669          --  the following conformance scenarios is in effect:
23670          --    1) Both items denote null
23671          --    2) Dep_Item denotes null and Ref_Item is Empty (special case)
23672          --    3) Both items denote attribute 'Result
23673          --    4) Both items denote the same object
23674          --    5) Both items denote the same formal parameter
23675          --    6) Both items denote the same current instance of a type
23676          --    7) Both items denote the same discriminant
23677          --    8) Dep_Item is an abstract state with visible null refinement
23678          --       and Ref_Item denotes null.
23679          --    9) Dep_Item is an abstract state with visible null refinement
23680          --       and Ref_Item is Empty (special case).
23681          --   10) Dep_Item is an abstract state with visible non-null
23682          --       refinement and Ref_Item denotes one of its constituents.
23683          --   11) Dep_Item is an abstract state without a visible refinement
23684          --       and Ref_Item denotes the same state.
23685          --  When scenario 10 is in effect, the entity of the abstract state
23686          --  denoted by Dep_Item is added to list Refined_States.
23687 
23688          procedure Record_Item (Item_Id : Entity_Id);
23689          --  Store the entity of an item denoted by Item_Id in Matched_Items
23690 
23691          ----------------------------
23692          -- Is_In_Out_State_Clause --
23693          ----------------------------
23694 
23695          function Is_In_Out_State_Clause return Boolean is
23696             Dep_Input_Id  : Entity_Id;
23697             Dep_Output_Id : Entity_Id;
23698 
23699          begin
23700             --  Detect the following clause:
23701             --    State => State
23702 
23703             if Is_Entity_Name (Dep_Input)
23704               and then Is_Entity_Name (Dep_Output)
23705             then
23706                --  Handle abstract views generated for limited with clauses
23707 
23708                Dep_Input_Id  := Available_View (Entity_Of (Dep_Input));
23709                Dep_Output_Id := Available_View (Entity_Of (Dep_Output));
23710 
23711                return
23712                  Ekind (Dep_Input_Id) = E_Abstract_State
23713                    and then Dep_Input_Id = Dep_Output_Id;
23714             else
23715                return False;
23716             end if;
23717          end Is_In_Out_State_Clause;
23718 
23719          ---------------------------
23720          -- Is_Null_Refined_State --
23721          ---------------------------
23722 
23723          function Is_Null_Refined_State (Item : Node_Id) return Boolean is
23724             Item_Id : Entity_Id;
23725 
23726          begin
23727             if Is_Entity_Name (Item) then
23728 
23729                --  Handle abstract views generated for limited with clauses
23730 
23731                Item_Id := Available_View (Entity_Of (Item));
23732 
23733                return
23734                  Ekind (Item_Id) = E_Abstract_State
23735                    and then Has_Null_Visible_Refinement (Item_Id);
23736             else
23737                return False;
23738             end if;
23739          end Is_Null_Refined_State;
23740 
23741          -----------------
23742          -- Match_Items --
23743          -----------------
23744 
23745          procedure Match_Items
23746            (Dep_Item : Node_Id;
23747             Ref_Item : Node_Id;
23748             Matched  : out Boolean)
23749          is
23750             Dep_Item_Id : Entity_Id;
23751             Ref_Item_Id : Entity_Id;
23752 
23753          begin
23754             --  Assume that the two items do not match
23755 
23756             Matched := False;
23757 
23758             --  A null matches null or Empty (special case)
23759 
23760             if Nkind (Dep_Item) = N_Null
23761               and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
23762             then
23763                Matched := True;
23764 
23765             --  Attribute 'Result matches attribute 'Result
23766 
23767             elsif Is_Attribute_Result (Dep_Item)
23768               and then Is_Attribute_Result (Dep_Item)
23769             then
23770                Matched := True;
23771 
23772             --  Abstract states, current instances of concurrent types,
23773             --  discriminants, formal parameters and objects.
23774 
23775             elsif Is_Entity_Name (Dep_Item) then
23776 
23777                --  Handle abstract views generated for limited with clauses
23778 
23779                Dep_Item_Id := Available_View (Entity_Of (Dep_Item));
23780 
23781                if Ekind (Dep_Item_Id) = E_Abstract_State then
23782 
23783                   --  An abstract state with visible null refinement matches
23784                   --  null or Empty (special case).
23785 
23786                   if Has_Null_Visible_Refinement (Dep_Item_Id)
23787                     and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null)
23788                   then
23789                      Record_Item (Dep_Item_Id);
23790                      Matched := True;
23791 
23792                   --  An abstract state with visible non-null refinement
23793                   --  matches one of its constituents.
23794 
23795                   elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
23796                      if Is_Entity_Name (Ref_Item) then
23797                         Ref_Item_Id := Entity_Of (Ref_Item);
23798 
23799                         if Ekind_In (Ref_Item_Id, E_Abstract_State,
23800                                                   E_Constant,
23801                                                   E_Variable)
23802                           and then Present (Encapsulating_State (Ref_Item_Id))
23803                           and then Encapsulating_State (Ref_Item_Id) =
23804                                      Dep_Item_Id
23805                         then
23806                            Record_Item (Dep_Item_Id);
23807                            Matched := True;
23808                         end if;
23809                      end if;
23810 
23811                   --  An abstract state without a visible refinement matches
23812                   --  itself.
23813 
23814                   elsif Is_Entity_Name (Ref_Item)
23815                     and then Entity_Of (Ref_Item) = Dep_Item_Id
23816                   then
23817                      Record_Item (Dep_Item_Id);
23818                      Matched := True;
23819                   end if;
23820 
23821                --  A current instance of a concurrent type, discriminant,
23822                --  formal parameter or an object matches itself.
23823 
23824                elsif Is_Entity_Name (Ref_Item)
23825                  and then Entity_Of (Ref_Item) = Dep_Item_Id
23826                then
23827                   Record_Item (Dep_Item_Id);
23828                   Matched := True;
23829                end if;
23830             end if;
23831          end Match_Items;
23832 
23833          -----------------
23834          -- Record_Item --
23835          -----------------
23836 
23837          procedure Record_Item (Item_Id : Entity_Id) is
23838          begin
23839             if not Contains (Matched_Items, Item_Id) then
23840                Append_New_Elmt (Item_Id, Matched_Items);
23841             end if;
23842          end Record_Item;
23843 
23844          --  Local variables
23845 
23846          Clause_Matched  : Boolean := False;
23847          Dummy           : Boolean := False;
23848          Inputs_Match    : Boolean;
23849          Next_Ref_Clause : Node_Id;
23850          Outputs_Match   : Boolean;
23851          Ref_Clause      : Node_Id;
23852          Ref_Input       : Node_Id;
23853          Ref_Output      : Node_Id;
23854 
23855       --  Start of processing for Check_Dependency_Clause
23856 
23857       begin
23858          --  Do not perform this check in an instance because it was already
23859          --  performed successfully in the generic template.
23860 
23861          if Is_Generic_Instance (Spec_Id) then
23862             return;
23863          end if;
23864 
23865          --  Examine all refinement clauses and compare them against the
23866          --  dependence clause.
23867 
23868          Ref_Clause := First (Refinements);
23869          while Present (Ref_Clause) loop
23870             Next_Ref_Clause := Next (Ref_Clause);
23871 
23872             --  Obtain the attributes of the current refinement clause
23873 
23874             Ref_Input  := Expression (Ref_Clause);
23875             Ref_Output := First (Choices (Ref_Clause));
23876 
23877             --  The current refinement clause matches the dependence clause
23878             --  when both outputs match and both inputs match. See routine
23879             --  Match_Items for all possible conformance scenarios.
23880 
23881             --    Depends           Dep_Output => Dep_Input
23882             --                          ^             ^
23883             --                        match ?       match ?
23884             --                          v             v
23885             --    Refined_Depends   Ref_Output => Ref_Input
23886 
23887             Match_Items
23888               (Dep_Item => Dep_Input,
23889                Ref_Item => Ref_Input,
23890                Matched  => Inputs_Match);
23891 
23892             Match_Items
23893               (Dep_Item => Dep_Output,
23894                Ref_Item => Ref_Output,
23895                Matched  => Outputs_Match);
23896 
23897             --  An In_Out state clause may be matched against a refinement with
23898             --  a null input or null output as long as the non-null side of the
23899             --  relation contains a valid constituent of the In_Out_State.
23900 
23901             if Is_In_Out_State_Clause then
23902 
23903                --  Depends         => (State => State)
23904                --  Refined_Depends => (null => Constit)  --  OK
23905 
23906                if Inputs_Match
23907                  and then not Outputs_Match
23908                  and then Nkind (Ref_Output) = N_Null
23909                then
23910                   Outputs_Match := True;
23911                end if;
23912 
23913                --  Depends         => (State => State)
23914                --  Refined_Depends => (Constit => null)  --  OK
23915 
23916                if not Inputs_Match
23917                  and then Outputs_Match
23918                  and then Nkind (Ref_Input) = N_Null
23919                then
23920                   Inputs_Match := True;
23921                end if;
23922             end if;
23923 
23924             --  The current refinement clause is legally constructed following
23925             --  the rules in SPARK RM 7.2.5, therefore it can be removed from
23926             --  the pool of candidates. The seach continues because a single
23927             --  dependence clause may have multiple matching refinements.
23928 
23929             if Inputs_Match and Outputs_Match then
23930                Clause_Matched := True;
23931                Remove (Ref_Clause);
23932             end if;
23933 
23934             Ref_Clause := Next_Ref_Clause;
23935          end loop;
23936 
23937          --  Depending on the order or composition of refinement clauses, an
23938          --  In_Out state clause may not be directly refinable.
23939 
23940          --    Depends         => ((Output, State) => (Input, State))
23941          --    Refined_State   => (State => (Constit_1, Constit_2))
23942          --    Refined_Depends => (Constit_1 => Input, Output => Constit_2)
23943 
23944          --  Matching normalized clause (State => State) fails because there is
23945          --  no direct refinement capable of satisfying this relation. Another
23946          --  similar case arises when clauses (Constit_1 => Input) and (Output
23947          --  => Constit_2) are matched first, leaving no candidates for clause
23948          --  (State => State). Both scenarios are legal as long as one of the
23949          --  previous clauses mentioned a valid constituent of State.
23950 
23951          if not Clause_Matched
23952            and then Is_In_Out_State_Clause
23953            and then
23954              Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
23955          then
23956             Clause_Matched := True;
23957          end if;
23958 
23959          --  A clause where the input is an abstract state with visible null
23960          --  refinement is implicitly matched when the output has already been
23961          --  matched in a previous clause.
23962 
23963          --    Depends         => (Output => State)  --  implicitly OK
23964          --    Refined_State   => (State => null)
23965          --    Refined_Depends => (Output => ...)
23966 
23967          if not Clause_Matched
23968            and then Is_Null_Refined_State (Dep_Input)
23969            and then Is_Entity_Name (Dep_Output)
23970            and then
23971              Contains (Matched_Items, Available_View (Entity_Of (Dep_Output)))
23972          then
23973             Clause_Matched := True;
23974          end if;
23975 
23976          --  A clause where the output is an abstract state with visible null
23977          --  refinement is implicitly matched when the input has already been
23978          --  matched in a previous clause.
23979 
23980          --    Depends           => (State => Input)  --  implicitly OK
23981          --    Refined_State     => (State => null)
23982          --    Refined_Depends   => (... => Input)
23983 
23984          if not Clause_Matched
23985            and then Is_Null_Refined_State (Dep_Output)
23986            and then Is_Entity_Name (Dep_Input)
23987            and then
23988              Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
23989          then
23990             Clause_Matched := True;
23991          end if;
23992 
23993          --  At this point either all refinement clauses have been examined or
23994          --  pragma Refined_Depends contains a solitary null. Only an abstract
23995          --  state with null refinement can possibly match these cases.
23996 
23997          --    Depends         => (State => null)
23998          --    Refined_State   => (State => null)
23999          --    Refined_Depends =>  null            --  OK
24000 
24001          if not Clause_Matched then
24002             Match_Items
24003               (Dep_Item => Dep_Input,
24004                Ref_Item => Empty,
24005                Matched  => Inputs_Match);
24006 
24007             Match_Items
24008               (Dep_Item => Dep_Output,
24009                Ref_Item => Empty,
24010                Matched  => Outputs_Match);
24011 
24012             Clause_Matched := Inputs_Match and Outputs_Match;
24013          end if;
24014 
24015          --  If the contents of Refined_Depends are legal, then the current
24016          --  dependence clause should be satisfied either by an explicit match
24017          --  or by one of the special cases.
24018 
24019          if not Clause_Matched then
24020             SPARK_Msg_NE
24021               (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no "
24022                & "matching refinement in body"), Dep_Clause, Spec_Id);
24023          end if;
24024       end Check_Dependency_Clause;
24025 
24026       -------------------------
24027       -- Check_Output_States --
24028       -------------------------
24029 
24030       procedure Check_Output_States is
24031          procedure Check_Constituent_Usage (State_Id : Entity_Id);
24032          --  Determine whether all constituents of state State_Id with visible
24033          --  refinement are used as outputs in pragma Refined_Depends. Emit an
24034          --  error if this is not the case.
24035 
24036          -----------------------------
24037          -- Check_Constituent_Usage --
24038          -----------------------------
24039 
24040          procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24041             Constits     : constant Elist_Id :=
24042                              Refinement_Constituents (State_Id);
24043             Constit_Elmt : Elmt_Id;
24044             Constit_Id   : Entity_Id;
24045             Posted       : Boolean := False;
24046 
24047          begin
24048             if Present (Constits) then
24049                Constit_Elmt := First_Elmt (Constits);
24050                while Present (Constit_Elmt) loop
24051                   Constit_Id := Node (Constit_Elmt);
24052 
24053                   --  The constituent acts as an input (SPARK RM 7.2.5(3))
24054 
24055                   if Present (Body_Inputs)
24056                     and then Appears_In (Body_Inputs, Constit_Id)
24057                   then
24058                      Error_Msg_Name_1 := Chars (State_Id);
24059                      SPARK_Msg_NE
24060                        ("constituent & of state % must act as output in "
24061                         & "dependence refinement", N, Constit_Id);
24062 
24063                   --  The constituent is altogether missing (SPARK RM 7.2.5(3))
24064 
24065                   elsif No (Body_Outputs)
24066                     or else not Appears_In (Body_Outputs, Constit_Id)
24067                   then
24068                      if not Posted then
24069                         Posted := True;
24070                         SPARK_Msg_NE
24071                           ("output state & must be replaced by all its "
24072                            & "constituents in dependence refinement",
24073                            N, State_Id);
24074                      end if;
24075 
24076                      SPARK_Msg_NE
24077                        ("\constituent & is missing in output list",
24078                         N, Constit_Id);
24079                   end if;
24080 
24081                   Next_Elmt (Constit_Elmt);
24082                end loop;
24083             end if;
24084          end Check_Constituent_Usage;
24085 
24086          --  Local variables
24087 
24088          Item      : Node_Id;
24089          Item_Elmt : Elmt_Id;
24090          Item_Id   : Entity_Id;
24091 
24092       --  Start of processing for Check_Output_States
24093 
24094       begin
24095          --  Do not perform this check in an instance because it was already
24096          --  performed successfully in the generic template.
24097 
24098          if Is_Generic_Instance (Spec_Id) then
24099             null;
24100 
24101          --  Inspect the outputs of pragma Depends looking for a state with a
24102          --  visible refinement.
24103 
24104          elsif Present (Spec_Outputs) then
24105             Item_Elmt := First_Elmt (Spec_Outputs);
24106             while Present (Item_Elmt) loop
24107                Item := Node (Item_Elmt);
24108 
24109                --  Deal with the mixed nature of the input and output lists
24110 
24111                if Nkind (Item) = N_Defining_Identifier then
24112                   Item_Id := Item;
24113                else
24114                   Item_Id := Available_View (Entity_Of (Item));
24115                end if;
24116 
24117                if Ekind (Item_Id) = E_Abstract_State then
24118 
24119                   --  The state acts as an input-output, skip it
24120 
24121                   if Present (Spec_Inputs)
24122                     and then Appears_In (Spec_Inputs, Item_Id)
24123                   then
24124                      null;
24125 
24126                   --  Ensure that all of the constituents are utilized as
24127                   --  outputs in pragma Refined_Depends.
24128 
24129                   elsif Has_Non_Null_Visible_Refinement (Item_Id) then
24130                      Check_Constituent_Usage (Item_Id);
24131                   end if;
24132                end if;
24133 
24134                Next_Elmt (Item_Elmt);
24135             end loop;
24136          end if;
24137       end Check_Output_States;
24138 
24139       -----------------------
24140       -- Normalize_Clauses --
24141       -----------------------
24142 
24143       procedure Normalize_Clauses (Clauses : List_Id) is
24144          procedure Normalize_Inputs (Clause : Node_Id);
24145          --  Normalize clause Clause by creating multiple clauses for each
24146          --  input item of Clause. It is assumed that Clause has exactly one
24147          --  output. The transformation is as follows:
24148          --
24149          --    Output => (Input_1, Input_2)      --  original
24150          --
24151          --    Output => Input_1                 --  normalizations
24152          --    Output => Input_2
24153 
24154          procedure Normalize_Outputs (Clause : Node_Id);
24155          --  Normalize clause Clause by creating multiple clause for each
24156          --  output item of Clause. The transformation is as follows:
24157          --
24158          --    (Output_1, Output_2) => Input     --  original
24159          --
24160          --     Output_1 => Input                --  normalization
24161          --     Output_2 => Input
24162 
24163          ----------------------
24164          -- Normalize_Inputs --
24165          ----------------------
24166 
24167          procedure Normalize_Inputs (Clause : Node_Id) is
24168             Inputs     : constant Node_Id    := Expression (Clause);
24169             Loc        : constant Source_Ptr := Sloc (Clause);
24170             Output     : constant List_Id    := Choices (Clause);
24171             Last_Input : Node_Id;
24172             Input      : Node_Id;
24173             New_Clause : Node_Id;
24174             Next_Input : Node_Id;
24175 
24176          begin
24177             --  Normalization is performed only when the original clause has
24178             --  more than one input. Multiple inputs appear as an aggregate.
24179 
24180             if Nkind (Inputs) = N_Aggregate then
24181                Last_Input := Last (Expressions (Inputs));
24182 
24183                --  Create a new clause for each input
24184 
24185                Input := First (Expressions (Inputs));
24186                while Present (Input) loop
24187                   Next_Input := Next (Input);
24188 
24189                   --  Unhook the current input from the original input list
24190                   --  because it will be relocated to a new clause.
24191 
24192                   Remove (Input);
24193 
24194                   --  Special processing for the last input. At this point the
24195                   --  original aggregate has been stripped down to one element.
24196                   --  Replace the aggregate by the element itself.
24197 
24198                   if Input = Last_Input then
24199                      Rewrite (Inputs, Input);
24200 
24201                   --  Generate a clause of the form:
24202                   --    Output => Input
24203 
24204                   else
24205                      New_Clause :=
24206                        Make_Component_Association (Loc,
24207                          Choices    => New_Copy_List_Tree (Output),
24208                          Expression => Input);
24209 
24210                      --  The new clause contains replicated content that has
24211                      --  already been analyzed, mark the clause as analyzed.
24212 
24213                      Set_Analyzed (New_Clause);
24214                      Insert_After (Clause, New_Clause);
24215                   end if;
24216 
24217                   Input := Next_Input;
24218                end loop;
24219             end if;
24220          end Normalize_Inputs;
24221 
24222          -----------------------
24223          -- Normalize_Outputs --
24224          -----------------------
24225 
24226          procedure Normalize_Outputs (Clause : Node_Id) is
24227             Inputs      : constant Node_Id    := Expression (Clause);
24228             Loc         : constant Source_Ptr := Sloc (Clause);
24229             Outputs     : constant Node_Id    := First (Choices (Clause));
24230             Last_Output : Node_Id;
24231             New_Clause  : Node_Id;
24232             Next_Output : Node_Id;
24233             Output      : Node_Id;
24234 
24235          begin
24236             --  Multiple outputs appear as an aggregate. Nothing to do when
24237             --  the clause has exactly one output.
24238 
24239             if Nkind (Outputs) = N_Aggregate then
24240                Last_Output := Last (Expressions (Outputs));
24241 
24242                --  Create a clause for each output. Note that each time a new
24243                --  clause is created, the original output list slowly shrinks
24244                --  until there is one item left.
24245 
24246                Output := First (Expressions (Outputs));
24247                while Present (Output) loop
24248                   Next_Output := Next (Output);
24249 
24250                   --  Unhook the output from the original output list as it
24251                   --  will be relocated to a new clause.
24252 
24253                   Remove (Output);
24254 
24255                   --  Special processing for the last output. At this point
24256                   --  the original aggregate has been stripped down to one
24257                   --  element. Replace the aggregate by the element itself.
24258 
24259                   if Output = Last_Output then
24260                      Rewrite (Outputs, Output);
24261 
24262                   else
24263                      --  Generate a clause of the form:
24264                      --    (Output => Inputs)
24265 
24266                      New_Clause :=
24267                        Make_Component_Association (Loc,
24268                          Choices    => New_List (Output),
24269                          Expression => New_Copy_Tree (Inputs));
24270 
24271                      --  The new clause contains replicated content that has
24272                      --  already been analyzed. There is not need to reanalyze
24273                      --  them.
24274 
24275                      Set_Analyzed (New_Clause);
24276                      Insert_After (Clause, New_Clause);
24277                   end if;
24278 
24279                   Output := Next_Output;
24280                end loop;
24281             end if;
24282          end Normalize_Outputs;
24283 
24284          --  Local variables
24285 
24286          Clause : Node_Id;
24287 
24288       --  Start of processing for Normalize_Clauses
24289 
24290       begin
24291          Clause := First (Clauses);
24292          while Present (Clause) loop
24293             Normalize_Outputs (Clause);
24294             Next (Clause);
24295          end loop;
24296 
24297          Clause := First (Clauses);
24298          while Present (Clause) loop
24299             Normalize_Inputs (Clause);
24300             Next (Clause);
24301          end loop;
24302       end Normalize_Clauses;
24303 
24304       --------------------------
24305       -- Report_Extra_Clauses --
24306       --------------------------
24307 
24308       procedure Report_Extra_Clauses is
24309          Clause : Node_Id;
24310 
24311       begin
24312          --  Do not perform this check in an instance because it was already
24313          --  performed successfully in the generic template.
24314 
24315          if Is_Generic_Instance (Spec_Id) then
24316             null;
24317 
24318          elsif Present (Refinements) then
24319             Clause := First (Refinements);
24320             while Present (Clause) loop
24321 
24322                --  Do not complain about a null input refinement, since a null
24323                --  input legitimately matches anything.
24324 
24325                if Nkind (Clause) = N_Component_Association
24326                  and then Nkind (Expression (Clause)) = N_Null
24327                then
24328                   null;
24329 
24330                else
24331                   SPARK_Msg_N
24332                     ("unmatched or extra clause in dependence refinement",
24333                      Clause);
24334                end if;
24335 
24336                Next (Clause);
24337             end loop;
24338          end if;
24339       end Report_Extra_Clauses;
24340 
24341       --  Local variables
24342 
24343       Body_Decl : constant Node_Id   := Find_Related_Declaration_Or_Body (N);
24344       Body_Id   : constant Entity_Id := Defining_Entity (Body_Decl);
24345       Errors    : constant Nat       := Serious_Errors_Detected;
24346       Clause    : Node_Id;
24347       Deps      : Node_Id;
24348       Dummy     : Boolean;
24349       Refs      : Node_Id;
24350 
24351    --  Start of processing for Analyze_Refined_Depends_In_Decl_Part
24352 
24353    begin
24354       --  Do not analyze the pragma multiple times
24355 
24356       if Is_Analyzed_Pragma (N) then
24357          return;
24358       end if;
24359 
24360       Spec_Id := Unique_Defining_Entity (Body_Decl);
24361 
24362       --  Use the anonymous object as the proper spec when Refined_Depends
24363       --  applies to the body of a single task type. The object carries the
24364       --  proper Chars as well as all non-refined versions of pragmas.
24365 
24366       if Is_Single_Concurrent_Type (Spec_Id) then
24367          Spec_Id := Anonymous_Object (Spec_Id);
24368       end if;
24369 
24370       Depends := Get_Pragma (Spec_Id, Pragma_Depends);
24371 
24372       --  Subprogram declarations lacks pragma Depends. Refined_Depends is
24373       --  rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
24374 
24375       if No (Depends) then
24376          SPARK_Msg_NE
24377            (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
24378             & "& lacks aspect or pragma Depends"), N, Spec_Id);
24379          goto Leave;
24380       end if;
24381 
24382       Deps := Expression (Get_Argument (Depends, Spec_Id));
24383 
24384       --  A null dependency relation renders the refinement useless because it
24385       --  cannot possibly mention abstract states with visible refinement. Note
24386       --  that the inverse is not true as states may be refined to null
24387       --  (SPARK RM 7.2.5(2)).
24388 
24389       if Nkind (Deps) = N_Null then
24390          SPARK_Msg_NE
24391            (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
24392             & "depend on abstract state with visible refinement"), N, Spec_Id);
24393          goto Leave;
24394       end if;
24395 
24396       --  Analyze Refined_Depends as if it behaved as a regular pragma Depends.
24397       --  This ensures that the categorization of all refined dependency items
24398       --  is consistent with their role.
24399 
24400       Analyze_Depends_In_Decl_Part (N);
24401 
24402       --  Do not match dependencies against refinements if Refined_Depends is
24403       --  illegal to avoid emitting misleading error.
24404 
24405       if Serious_Errors_Detected = Errors then
24406 
24407          --  The related subprogram lacks pragma [Refined_]Global. Synthesize
24408          --  the inputs and outputs of the subprogram spec and body to verify
24409          --  the use of states with visible refinement and their constituents.
24410 
24411          if No (Get_Pragma (Spec_Id, Pragma_Global))
24412            or else No (Get_Pragma (Body_Id, Pragma_Refined_Global))
24413          then
24414             Collect_Subprogram_Inputs_Outputs
24415               (Subp_Id      => Spec_Id,
24416                Synthesize   => True,
24417                Subp_Inputs  => Spec_Inputs,
24418                Subp_Outputs => Spec_Outputs,
24419                Global_Seen  => Dummy);
24420 
24421             Collect_Subprogram_Inputs_Outputs
24422               (Subp_Id      => Body_Id,
24423                Synthesize   => True,
24424                Subp_Inputs  => Body_Inputs,
24425                Subp_Outputs => Body_Outputs,
24426                Global_Seen  => Dummy);
24427 
24428             --  For an output state with a visible refinement, ensure that all
24429             --  constituents appear as outputs in the dependency refinement.
24430 
24431             Check_Output_States;
24432          end if;
24433 
24434          --  Matching is disabled in ASIS because clauses are not normalized as
24435          --  this is a tree altering activity similar to expansion.
24436 
24437          if ASIS_Mode then
24438             goto Leave;
24439          end if;
24440 
24441          --  Multiple dependency clauses appear as component associations of an
24442          --  aggregate. Note that the clauses are copied because the algorithm
24443          --  modifies them and this should not be visible in Depends.
24444 
24445          pragma Assert (Nkind (Deps) = N_Aggregate);
24446          Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
24447          Normalize_Clauses (Dependencies);
24448 
24449          Refs := Expression (Get_Argument (N, Spec_Id));
24450 
24451          if Nkind (Refs) = N_Null then
24452             Refinements := No_List;
24453 
24454          --  Multiple dependency clauses appear as component associations of an
24455          --  aggregate. Note that the clauses are copied because the algorithm
24456          --  modifies them and this should not be visible in Refined_Depends.
24457 
24458          else pragma Assert (Nkind (Refs) = N_Aggregate);
24459             Refinements := New_Copy_List_Tree (Component_Associations (Refs));
24460             Normalize_Clauses (Refinements);
24461          end if;
24462 
24463          --  At this point the clauses of pragmas Depends and Refined_Depends
24464          --  have been normalized into simple dependencies between one output
24465          --  and one input. Examine all clauses of pragma Depends looking for
24466          --  matching clauses in pragma Refined_Depends.
24467 
24468          Clause := First (Dependencies);
24469          while Present (Clause) loop
24470             Check_Dependency_Clause (Clause);
24471             Next (Clause);
24472          end loop;
24473 
24474          if Serious_Errors_Detected = Errors then
24475             Report_Extra_Clauses;
24476          end if;
24477       end if;
24478 
24479       <<Leave>>
24480       Set_Is_Analyzed_Pragma (N);
24481    end Analyze_Refined_Depends_In_Decl_Part;
24482 
24483    -----------------------------------------
24484    -- Analyze_Refined_Global_In_Decl_Part --
24485    -----------------------------------------
24486 
24487    procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
24488       Global : Node_Id;
24489       --  The corresponding Global pragma
24490 
24491       Has_In_State       : Boolean := False;
24492       Has_In_Out_State   : Boolean := False;
24493       Has_Out_State      : Boolean := False;
24494       Has_Proof_In_State : Boolean := False;
24495       --  These flags are set when the corresponding Global pragma has a state
24496       --  of mode Input, In_Out, Output or Proof_In respectively with a visible
24497       --  refinement.
24498 
24499       Has_Null_State : Boolean := False;
24500       --  This flag is set when the corresponding Global pragma has at least
24501       --  one state with a null refinement.
24502 
24503       In_Constits       : Elist_Id := No_Elist;
24504       In_Out_Constits   : Elist_Id := No_Elist;
24505       Out_Constits      : Elist_Id := No_Elist;
24506       Proof_In_Constits : Elist_Id := No_Elist;
24507       --  These lists contain the entities of all Input, In_Out, Output and
24508       --  Proof_In constituents that appear in Refined_Global and participate
24509       --  in state refinement.
24510 
24511       In_Items       : Elist_Id := No_Elist;
24512       In_Out_Items   : Elist_Id := No_Elist;
24513       Out_Items      : Elist_Id := No_Elist;
24514       Proof_In_Items : Elist_Id := No_Elist;
24515       --  These list contain the entities of all Input, In_Out, Output and
24516       --  Proof_In items defined in the corresponding Global pragma.
24517 
24518       Spec_Id : Entity_Id;
24519       --  The entity of the subprogram subject to pragma Refined_Global
24520 
24521       States : Elist_Id := No_Elist;
24522       --  A list of all states with visible refinement found in pragma Global
24523 
24524       procedure Check_In_Out_States;
24525       --  Determine whether the corresponding Global pragma mentions In_Out
24526       --  states with visible refinement and if so, ensure that one of the
24527       --  following completions apply to the constituents of the state:
24528       --    1) there is at least one constituent of mode In_Out
24529       --    2) there is at least one Input and one Output constituent
24530       --    3) not all constituents are present and one of them is of mode
24531       --       Output.
24532       --  This routine may remove elements from In_Constits, In_Out_Constits,
24533       --  Out_Constits and Proof_In_Constits.
24534 
24535       procedure Check_Input_States;
24536       --  Determine whether the corresponding Global pragma mentions Input
24537       --  states with visible refinement and if so, ensure that at least one of
24538       --  its constituents appears as an Input item in Refined_Global.
24539       --  This routine may remove elements from In_Constits, In_Out_Constits,
24540       --  Out_Constits and Proof_In_Constits.
24541 
24542       procedure Check_Output_States;
24543       --  Determine whether the corresponding Global pragma mentions Output
24544       --  states with visible refinement and if so, ensure that all of its
24545       --  constituents appear as Output items in Refined_Global.
24546       --  This routine may remove elements from In_Constits, In_Out_Constits,
24547       --  Out_Constits and Proof_In_Constits.
24548 
24549       procedure Check_Proof_In_States;
24550       --  Determine whether the corresponding Global pragma mentions Proof_In
24551       --  states with visible refinement and if so, ensure that at least one of
24552       --  its constituents appears as a Proof_In item in Refined_Global.
24553       --  This routine may remove elements from In_Constits, In_Out_Constits,
24554       --  Out_Constits and Proof_In_Constits.
24555 
24556       procedure Check_Refined_Global_List
24557         (List        : Node_Id;
24558          Global_Mode : Name_Id := Name_Input);
24559       --  Verify the legality of a single global list declaration. Global_Mode
24560       --  denotes the current mode in effect.
24561 
24562       procedure Collect_Global_Items
24563         (List : Node_Id;
24564          Mode : Name_Id := Name_Input);
24565       --  Gather all input, in out, output and Proof_In items from node List
24566       --  and separate them in lists In_Items, In_Out_Items, Out_Items and
24567       --  Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
24568       --  and Has_Proof_In_State are set when there is at least one abstract
24569       --  state with visible refinement available in the corresponding mode.
24570       --  Flag Has_Null_State is set when at least state has a null refinement.
24571       --  Mode enotes the current global mode in effect.
24572 
24573       function Present_Then_Remove
24574         (List : Elist_Id;
24575          Item : Entity_Id) return Boolean;
24576       --  Search List for a particular entity Item. If Item has been found,
24577       --  remove it from List. This routine is used to strip lists In_Constits,
24578       --  In_Out_Constits and Out_Constits of valid constituents.
24579 
24580       procedure Report_Extra_Constituents;
24581       --  Emit an error for each constituent found in lists In_Constits,
24582       --  In_Out_Constits and Out_Constits.
24583 
24584       -------------------------
24585       -- Check_In_Out_States --
24586       -------------------------
24587 
24588       procedure Check_In_Out_States is
24589          procedure Check_Constituent_Usage (State_Id : Entity_Id);
24590          --  Determine whether one of the following coverage scenarios is in
24591          --  effect:
24592          --    1) there is at least one constituent of mode In_Out or Output
24593          --    2) there is at least one pair of constituents with modes Input
24594          --       and Output, or Proof_In and Output.
24595          --    3) there is at least one constituent of mode Output and not all
24596          --       constituents are present.
24597          --  If this is not the case, emit an error (SPARK RM 7.2.4(5)).
24598 
24599          -----------------------------
24600          -- Check_Constituent_Usage --
24601          -----------------------------
24602 
24603          procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24604             Constits      : constant Elist_Id :=
24605                               Refinement_Constituents (State_Id);
24606             Constit_Elmt  : Elmt_Id;
24607             Constit_Id    : Entity_Id;
24608             Has_Missing   : Boolean := False;
24609             In_Out_Seen   : Boolean := False;
24610             Input_Seen    : Boolean := False;
24611             Output_Seen   : Boolean := False;
24612             Proof_In_Seen : Boolean := False;
24613 
24614          begin
24615             --  Process all the constituents of the state and note their modes
24616             --  within the global refinement.
24617 
24618             if Present (Constits) then
24619                Constit_Elmt := First_Elmt (Constits);
24620                while Present (Constit_Elmt) loop
24621                   Constit_Id := Node (Constit_Elmt);
24622 
24623                   if Present_Then_Remove (In_Constits, Constit_Id) then
24624                      Input_Seen := True;
24625 
24626                   elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
24627                      In_Out_Seen := True;
24628 
24629                   elsif Present_Then_Remove (Out_Constits, Constit_Id) then
24630                      Output_Seen := True;
24631 
24632                   elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
24633                   then
24634                      Proof_In_Seen := True;
24635 
24636                   else
24637                      Has_Missing := True;
24638                   end if;
24639 
24640                   Next_Elmt (Constit_Elmt);
24641                end loop;
24642             end if;
24643 
24644             --  An In_Out constituent is a valid completion
24645 
24646             if In_Out_Seen then
24647                null;
24648 
24649             --  A pair of one Input/Proof_In and one Output constituent is a
24650             --  valid completion.
24651 
24652             elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
24653                null;
24654 
24655             elsif Output_Seen then
24656 
24657                --  A single Output constituent is a valid completion only when
24658                --  some of the other constituents are missing.
24659 
24660                if Has_Missing then
24661                   null;
24662 
24663                --  Otherwise all constituents are of mode Output
24664 
24665                else
24666                   SPARK_Msg_NE
24667                     ("global refinement of state & must include at least one "
24668                      & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
24669                      N, State_Id);
24670                end if;
24671 
24672             --  The state lacks a completion
24673 
24674             elsif not Input_Seen
24675               and not In_Out_Seen
24676               and not Output_Seen
24677               and not Proof_In_Seen
24678             then
24679                SPARK_Msg_NE
24680                  ("missing global refinement of state &", N, State_Id);
24681 
24682             --  Otherwise the state has a malformed completion where at least
24683             --  one of the constituents has a different mode.
24684 
24685             else
24686                SPARK_Msg_NE
24687                  ("global refinement of state & redefines the mode of its "
24688                   & "constituents", N, State_Id);
24689             end if;
24690          end Check_Constituent_Usage;
24691 
24692          --  Local variables
24693 
24694          Item_Elmt : Elmt_Id;
24695          Item_Id   : Entity_Id;
24696 
24697       --  Start of processing for Check_In_Out_States
24698 
24699       begin
24700          --  Do not perform this check in an instance because it was already
24701          --  performed successfully in the generic template.
24702 
24703          if Is_Generic_Instance (Spec_Id) then
24704             null;
24705 
24706          --  Inspect the In_Out items of the corresponding Global pragma
24707          --  looking for a state with a visible refinement.
24708 
24709          elsif Has_In_Out_State and then Present (In_Out_Items) then
24710             Item_Elmt := First_Elmt (In_Out_Items);
24711             while Present (Item_Elmt) loop
24712                Item_Id := Node (Item_Elmt);
24713 
24714                --  Ensure that one of the three coverage variants is satisfied
24715 
24716                if Ekind (Item_Id) = E_Abstract_State
24717                  and then Has_Non_Null_Visible_Refinement (Item_Id)
24718                then
24719                   Check_Constituent_Usage (Item_Id);
24720                end if;
24721 
24722                Next_Elmt (Item_Elmt);
24723             end loop;
24724          end if;
24725       end Check_In_Out_States;
24726 
24727       ------------------------
24728       -- Check_Input_States --
24729       ------------------------
24730 
24731       procedure Check_Input_States is
24732          procedure Check_Constituent_Usage (State_Id : Entity_Id);
24733          --  Determine whether at least one constituent of state State_Id with
24734          --  visible refinement is used and has mode Input. Ensure that the
24735          --  remaining constituents do not have In_Out or Output modes. Emit an
24736          --  error if this is not the case (SPARK RM 7.2.4(5)).
24737 
24738          -----------------------------
24739          -- Check_Constituent_Usage --
24740          -----------------------------
24741 
24742          procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24743             Constits     : constant Elist_Id :=
24744                              Refinement_Constituents (State_Id);
24745             Constit_Elmt : Elmt_Id;
24746             Constit_Id   : Entity_Id;
24747             In_Seen      : Boolean := False;
24748 
24749          begin
24750             if Present (Constits) then
24751                Constit_Elmt := First_Elmt (Constits);
24752                while Present (Constit_Elmt) loop
24753                   Constit_Id := Node (Constit_Elmt);
24754 
24755                   --  At least one of the constituents appears as an Input
24756 
24757                   if Present_Then_Remove (In_Constits, Constit_Id) then
24758                      In_Seen := True;
24759 
24760                   --  A Proof_In constituent can refine an Input state as long
24761                   --  as there is at least one Input constituent present.
24762 
24763                   elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
24764                   then
24765                      null;
24766 
24767                   --  The constituent appears in the global refinement, but has
24768                   --  mode In_Out or Output (SPARK RM 7.2.4(5)).
24769 
24770                   elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
24771                     or else Present_Then_Remove (Out_Constits, Constit_Id)
24772                   then
24773                      Error_Msg_Name_1 := Chars (State_Id);
24774                      SPARK_Msg_NE
24775                        ("constituent & of state % must have mode `Input` in "
24776                         & "global refinement", N, Constit_Id);
24777                   end if;
24778 
24779                   Next_Elmt (Constit_Elmt);
24780                end loop;
24781             end if;
24782 
24783             --  Not one of the constituents appeared as Input
24784 
24785             if not In_Seen then
24786                SPARK_Msg_NE
24787                  ("global refinement of state & must include at least one "
24788                   & "constituent of mode `Input`", N, State_Id);
24789             end if;
24790          end Check_Constituent_Usage;
24791 
24792          --  Local variables
24793 
24794          Item_Elmt : Elmt_Id;
24795          Item_Id   : Entity_Id;
24796 
24797       --  Start of processing for Check_Input_States
24798 
24799       begin
24800          --  Do not perform this check in an instance because it was already
24801          --  performed successfully in the generic template.
24802 
24803          if Is_Generic_Instance (Spec_Id) then
24804             null;
24805 
24806          --  Inspect the Input items of the corresponding Global pragma looking
24807          --  for a state with a visible refinement.
24808 
24809          elsif Has_In_State and then Present (In_Items) then
24810             Item_Elmt := First_Elmt (In_Items);
24811             while Present (Item_Elmt) loop
24812                Item_Id := Node (Item_Elmt);
24813 
24814                --  Ensure that at least one of the constituents is utilized and
24815                --  is of mode Input.
24816 
24817                if Ekind (Item_Id) = E_Abstract_State
24818                  and then Has_Non_Null_Visible_Refinement (Item_Id)
24819                then
24820                   Check_Constituent_Usage (Item_Id);
24821                end if;
24822 
24823                Next_Elmt (Item_Elmt);
24824             end loop;
24825          end if;
24826       end Check_Input_States;
24827 
24828       -------------------------
24829       -- Check_Output_States --
24830       -------------------------
24831 
24832       procedure Check_Output_States is
24833          procedure Check_Constituent_Usage (State_Id : Entity_Id);
24834          --  Determine whether all constituents of state State_Id with visible
24835          --  refinement are used and have mode Output. Emit an error if this is
24836          --  not the case (SPARK RM 7.2.4(5)).
24837 
24838          -----------------------------
24839          -- Check_Constituent_Usage --
24840          -----------------------------
24841 
24842          procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24843             Constits     : constant Elist_Id :=
24844                              Refinement_Constituents (State_Id);
24845             Constit_Elmt : Elmt_Id;
24846             Constit_Id   : Entity_Id;
24847             Posted       : Boolean := False;
24848 
24849          begin
24850             if Present (Constits) then
24851                Constit_Elmt := First_Elmt (Constits);
24852                while Present (Constit_Elmt) loop
24853                   Constit_Id := Node (Constit_Elmt);
24854 
24855                   if Present_Then_Remove (Out_Constits, Constit_Id) then
24856                      null;
24857 
24858                   --  The constituent appears in the global refinement, but has
24859                   --  mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
24860 
24861                   elsif Present_Then_Remove (In_Constits, Constit_Id)
24862                     or else Present_Then_Remove (In_Out_Constits, Constit_Id)
24863                     or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
24864                   then
24865                      Error_Msg_Name_1 := Chars (State_Id);
24866                      SPARK_Msg_NE
24867                        ("constituent & of state % must have mode `Output` in "
24868                         & "global refinement", N, Constit_Id);
24869 
24870                   --  The constituent is altogether missing (SPARK RM 7.2.5(3))
24871 
24872                   else
24873                      if not Posted then
24874                         Posted := True;
24875                         SPARK_Msg_NE
24876                           ("`Output` state & must be replaced by all its "
24877                            & "constituents in global refinement", N, State_Id);
24878                      end if;
24879 
24880                      SPARK_Msg_NE
24881                        ("\constituent & is missing in output list",
24882                         N, Constit_Id);
24883                   end if;
24884 
24885                   Next_Elmt (Constit_Elmt);
24886                end loop;
24887             end if;
24888          end Check_Constituent_Usage;
24889 
24890          --  Local variables
24891 
24892          Item_Elmt : Elmt_Id;
24893          Item_Id   : Entity_Id;
24894 
24895       --  Start of processing for Check_Output_States
24896 
24897       begin
24898          --  Do not perform this check in an instance because it was already
24899          --  performed successfully in the generic template.
24900 
24901          if Is_Generic_Instance (Spec_Id) then
24902             null;
24903 
24904          --  Inspect the Output items of the corresponding Global pragma
24905          --  looking for a state with a visible refinement.
24906 
24907          elsif Has_Out_State and then Present (Out_Items) then
24908             Item_Elmt := First_Elmt (Out_Items);
24909             while Present (Item_Elmt) loop
24910                Item_Id := Node (Item_Elmt);
24911 
24912                --  Ensure that all of the constituents are utilized and they
24913                --  have mode Output.
24914 
24915                if Ekind (Item_Id) = E_Abstract_State
24916                  and then Has_Non_Null_Visible_Refinement (Item_Id)
24917                then
24918                   Check_Constituent_Usage (Item_Id);
24919                end if;
24920 
24921                Next_Elmt (Item_Elmt);
24922             end loop;
24923          end if;
24924       end Check_Output_States;
24925 
24926       ---------------------------
24927       -- Check_Proof_In_States --
24928       ---------------------------
24929 
24930       procedure Check_Proof_In_States is
24931          procedure Check_Constituent_Usage (State_Id : Entity_Id);
24932          --  Determine whether at least one constituent of state State_Id with
24933          --  visible refinement is used and has mode Proof_In. Ensure that the
24934          --  remaining constituents do not have Input, In_Out or Output modes.
24935          --  Emit an error of this is not the case (SPARK RM 7.2.4(5)).
24936 
24937          -----------------------------
24938          -- Check_Constituent_Usage --
24939          -----------------------------
24940 
24941          procedure Check_Constituent_Usage (State_Id : Entity_Id) is
24942             Constits      : constant Elist_Id :=
24943                               Refinement_Constituents (State_Id);
24944             Constit_Elmt  : Elmt_Id;
24945             Constit_Id    : Entity_Id;
24946             Proof_In_Seen : Boolean := False;
24947 
24948          begin
24949             if Present (Constits) then
24950                Constit_Elmt := First_Elmt (Constits);
24951                while Present (Constit_Elmt) loop
24952                   Constit_Id := Node (Constit_Elmt);
24953 
24954                   --  At least one of the constituents appears as Proof_In
24955 
24956                   if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
24957                      Proof_In_Seen := True;
24958 
24959                   --  The constituent appears in the global refinement, but has
24960                   --  mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
24961 
24962                   elsif Present_Then_Remove (In_Constits, Constit_Id)
24963                     or else Present_Then_Remove (In_Out_Constits, Constit_Id)
24964                     or else Present_Then_Remove (Out_Constits, Constit_Id)
24965                   then
24966                      Error_Msg_Name_1 := Chars (State_Id);
24967                      SPARK_Msg_NE
24968                        ("constituent & of state % must have mode `Proof_In` "
24969                         & "in global refinement", N, Constit_Id);
24970                   end if;
24971 
24972                   Next_Elmt (Constit_Elmt);
24973                end loop;
24974             end if;
24975 
24976             --  Not one of the constituents appeared as Proof_In
24977 
24978             if not Proof_In_Seen then
24979                SPARK_Msg_NE
24980                  ("global refinement of state & must include at least one "
24981                   & "constituent of mode `Proof_In`", N, State_Id);
24982             end if;
24983          end Check_Constituent_Usage;
24984 
24985          --  Local variables
24986 
24987          Item_Elmt : Elmt_Id;
24988          Item_Id   : Entity_Id;
24989 
24990       --  Start of processing for Check_Proof_In_States
24991 
24992       begin
24993          --  Do not perform this check in an instance because it was already
24994          --  performed successfully in the generic template.
24995 
24996          if Is_Generic_Instance (Spec_Id) then
24997             null;
24998 
24999          --  Inspect the Proof_In items of the corresponding Global pragma
25000          --  looking for a state with a visible refinement.
25001 
25002          elsif Has_Proof_In_State and then Present (Proof_In_Items) then
25003             Item_Elmt := First_Elmt (Proof_In_Items);
25004             while Present (Item_Elmt) loop
25005                Item_Id := Node (Item_Elmt);
25006 
25007                --  Ensure that at least one of the constituents is utilized and
25008                --  is of mode Proof_In
25009 
25010                if Ekind (Item_Id) = E_Abstract_State
25011                  and then Has_Non_Null_Visible_Refinement (Item_Id)
25012                then
25013                   Check_Constituent_Usage (Item_Id);
25014                end if;
25015 
25016                Next_Elmt (Item_Elmt);
25017             end loop;
25018          end if;
25019       end Check_Proof_In_States;
25020 
25021       -------------------------------
25022       -- Check_Refined_Global_List --
25023       -------------------------------
25024 
25025       procedure Check_Refined_Global_List
25026         (List        : Node_Id;
25027          Global_Mode : Name_Id := Name_Input)
25028       is
25029          procedure Check_Refined_Global_Item
25030            (Item        : Node_Id;
25031             Global_Mode : Name_Id);
25032          --  Verify the legality of a single global item declaration. Parameter
25033          --  Global_Mode denotes the current mode in effect.
25034 
25035          -------------------------------
25036          -- Check_Refined_Global_Item --
25037          -------------------------------
25038 
25039          procedure Check_Refined_Global_Item
25040            (Item        : Node_Id;
25041             Global_Mode : Name_Id)
25042          is
25043             Item_Id : constant Entity_Id := Entity_Of (Item);
25044 
25045             procedure Inconsistent_Mode_Error (Expect : Name_Id);
25046             --  Issue a common error message for all mode mismatches. Expect
25047             --  denotes the expected mode.
25048 
25049             -----------------------------
25050             -- Inconsistent_Mode_Error --
25051             -----------------------------
25052 
25053             procedure Inconsistent_Mode_Error (Expect : Name_Id) is
25054             begin
25055                SPARK_Msg_NE
25056                  ("global item & has inconsistent modes", Item, Item_Id);
25057 
25058                Error_Msg_Name_1 := Global_Mode;
25059                Error_Msg_Name_2 := Expect;
25060                SPARK_Msg_N ("\expected mode %, found mode %", Item);
25061             end Inconsistent_Mode_Error;
25062 
25063          --  Start of processing for Check_Refined_Global_Item
25064 
25065          begin
25066             --  When the state or object acts as a constituent of another
25067             --  state with a visible refinement, collect it for the state
25068             --  completeness checks performed later on. Note that the item
25069             --  acts as a constituent only when the encapsulating state is
25070             --  present in pragma Global.
25071 
25072             if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
25073              and then Present (Encapsulating_State (Item_Id))
25074              and then Has_Visible_Refinement (Encapsulating_State (Item_Id))
25075              and then Contains (States, Encapsulating_State (Item_Id))
25076             then
25077                if Global_Mode = Name_Input then
25078                   Append_New_Elmt (Item_Id, In_Constits);
25079 
25080                elsif Global_Mode = Name_In_Out then
25081                   Append_New_Elmt (Item_Id, In_Out_Constits);
25082 
25083                elsif Global_Mode = Name_Output then
25084                   Append_New_Elmt (Item_Id, Out_Constits);
25085 
25086                elsif Global_Mode = Name_Proof_In then
25087                   Append_New_Elmt (Item_Id, Proof_In_Constits);
25088                end if;
25089 
25090             --  When not a constituent, ensure that both occurrences of the
25091             --  item in pragmas Global and Refined_Global match.
25092 
25093             elsif Contains (In_Items, Item_Id) then
25094                if Global_Mode /= Name_Input then
25095                   Inconsistent_Mode_Error (Name_Input);
25096                end if;
25097 
25098             elsif Contains (In_Out_Items, Item_Id) then
25099                if Global_Mode /= Name_In_Out then
25100                   Inconsistent_Mode_Error (Name_In_Out);
25101                end if;
25102 
25103             elsif Contains (Out_Items, Item_Id) then
25104                if Global_Mode /= Name_Output then
25105                   Inconsistent_Mode_Error (Name_Output);
25106                end if;
25107 
25108             elsif Contains (Proof_In_Items, Item_Id) then
25109                null;
25110 
25111             --  The item does not appear in the corresponding Global pragma,
25112             --  it must be an extra (SPARK RM 7.2.4(3)).
25113 
25114             else
25115                SPARK_Msg_NE ("extra global item &", Item, Item_Id);
25116             end if;
25117          end Check_Refined_Global_Item;
25118 
25119          --  Local variables
25120 
25121          Item : Node_Id;
25122 
25123       --  Start of processing for Check_Refined_Global_List
25124 
25125       begin
25126          --  Do not perform this check in an instance because it was already
25127          --  performed successfully in the generic template.
25128 
25129          if Is_Generic_Instance (Spec_Id) then
25130             null;
25131 
25132          elsif Nkind (List) = N_Null then
25133             null;
25134 
25135          --  Single global item declaration
25136 
25137          elsif Nkind_In (List, N_Expanded_Name,
25138                                N_Identifier,
25139                                N_Selected_Component)
25140          then
25141             Check_Refined_Global_Item (List, Global_Mode);
25142 
25143          --  Simple global list or moded global list declaration
25144 
25145          elsif Nkind (List) = N_Aggregate then
25146 
25147             --  The declaration of a simple global list appear as a collection
25148             --  of expressions.
25149 
25150             if Present (Expressions (List)) then
25151                Item := First (Expressions (List));
25152                while Present (Item) loop
25153                   Check_Refined_Global_Item (Item, Global_Mode);
25154                   Next (Item);
25155                end loop;
25156 
25157             --  The declaration of a moded global list appears as a collection
25158             --  of component associations where individual choices denote
25159             --  modes.
25160 
25161             elsif Present (Component_Associations (List)) then
25162                Item := First (Component_Associations (List));
25163                while Present (Item) loop
25164                   Check_Refined_Global_List
25165                     (List        => Expression (Item),
25166                      Global_Mode => Chars (First (Choices (Item))));
25167 
25168                   Next (Item);
25169                end loop;
25170 
25171             --  Invalid tree
25172 
25173             else
25174                raise Program_Error;
25175             end if;
25176 
25177          --  Invalid list
25178 
25179          else
25180             raise Program_Error;
25181          end if;
25182       end Check_Refined_Global_List;
25183 
25184       --------------------------
25185       -- Collect_Global_Items --
25186       --------------------------
25187 
25188       procedure Collect_Global_Items
25189         (List : Node_Id;
25190          Mode : Name_Id := Name_Input)
25191       is
25192          procedure Collect_Global_Item
25193            (Item      : Node_Id;
25194             Item_Mode : Name_Id);
25195          --  Add a single item to the appropriate list. Item_Mode denotes the
25196          --  current mode in effect.
25197 
25198          -------------------------
25199          -- Collect_Global_Item --
25200          -------------------------
25201 
25202          procedure Collect_Global_Item
25203            (Item      : Node_Id;
25204             Item_Mode : Name_Id)
25205          is
25206             Item_Id : constant Entity_Id := Available_View (Entity_Of (Item));
25207             --  The above handles abstract views of variables and states built
25208             --  for limited with clauses.
25209 
25210          begin
25211             --  Signal that the global list contains at least one abstract
25212             --  state with a visible refinement. Note that the refinement may
25213             --  be null in which case there are no constituents.
25214 
25215             if Ekind (Item_Id) = E_Abstract_State then
25216                if Has_Null_Visible_Refinement (Item_Id) then
25217                   Has_Null_State := True;
25218 
25219                elsif Has_Non_Null_Visible_Refinement (Item_Id) then
25220                   Append_New_Elmt (Item_Id, States);
25221 
25222                   if Item_Mode = Name_Input then
25223                      Has_In_State := True;
25224                   elsif Item_Mode = Name_In_Out then
25225                      Has_In_Out_State := True;
25226                   elsif Item_Mode = Name_Output then
25227                      Has_Out_State := True;
25228                   elsif Item_Mode = Name_Proof_In then
25229                      Has_Proof_In_State := True;
25230                   end if;
25231                end if;
25232             end if;
25233 
25234             --  Add the item to the proper list
25235 
25236             if Item_Mode = Name_Input then
25237                Append_New_Elmt (Item_Id, In_Items);
25238             elsif Item_Mode = Name_In_Out then
25239                Append_New_Elmt (Item_Id, In_Out_Items);
25240             elsif Item_Mode = Name_Output then
25241                Append_New_Elmt (Item_Id, Out_Items);
25242             elsif Item_Mode = Name_Proof_In then
25243                Append_New_Elmt (Item_Id, Proof_In_Items);
25244             end if;
25245          end Collect_Global_Item;
25246 
25247          --  Local variables
25248 
25249          Item : Node_Id;
25250 
25251       --  Start of processing for Collect_Global_Items
25252 
25253       begin
25254          if Nkind (List) = N_Null then
25255             null;
25256 
25257          --  Single global item declaration
25258 
25259          elsif Nkind_In (List, N_Expanded_Name,
25260                                N_Identifier,
25261                                N_Selected_Component)
25262          then
25263             Collect_Global_Item (List, Mode);
25264 
25265          --  Single global list or moded global list declaration
25266 
25267          elsif Nkind (List) = N_Aggregate then
25268 
25269             --  The declaration of a simple global list appear as a collection
25270             --  of expressions.
25271 
25272             if Present (Expressions (List)) then
25273                Item := First (Expressions (List));
25274                while Present (Item) loop
25275                   Collect_Global_Item (Item, Mode);
25276                   Next (Item);
25277                end loop;
25278 
25279             --  The declaration of a moded global list appears as a collection
25280             --  of component associations where individual choices denote mode.
25281 
25282             elsif Present (Component_Associations (List)) then
25283                Item := First (Component_Associations (List));
25284                while Present (Item) loop
25285                   Collect_Global_Items
25286                     (List => Expression (Item),
25287                      Mode => Chars (First (Choices (Item))));
25288 
25289                   Next (Item);
25290                end loop;
25291 
25292             --  Invalid tree
25293 
25294             else
25295                raise Program_Error;
25296             end if;
25297 
25298          --  To accomodate partial decoration of disabled SPARK features, this
25299          --  routine may be called with illegal input. If this is the case, do
25300          --  not raise Program_Error.
25301 
25302          else
25303             null;
25304          end if;
25305       end Collect_Global_Items;
25306 
25307       -------------------------
25308       -- Present_Then_Remove --
25309       -------------------------
25310 
25311       function Present_Then_Remove
25312         (List : Elist_Id;
25313          Item : Entity_Id) return Boolean
25314       is
25315          Elmt : Elmt_Id;
25316 
25317       begin
25318          if Present (List) then
25319             Elmt := First_Elmt (List);
25320             while Present (Elmt) loop
25321                if Node (Elmt) = Item then
25322                   Remove_Elmt (List, Elmt);
25323                   return True;
25324                end if;
25325 
25326                Next_Elmt (Elmt);
25327             end loop;
25328          end if;
25329 
25330          return False;
25331       end Present_Then_Remove;
25332 
25333       -------------------------------
25334       -- Report_Extra_Constituents --
25335       -------------------------------
25336 
25337       procedure Report_Extra_Constituents is
25338          procedure Report_Extra_Constituents_In_List (List : Elist_Id);
25339          --  Emit an error for every element of List
25340 
25341          ---------------------------------------
25342          -- Report_Extra_Constituents_In_List --
25343          ---------------------------------------
25344 
25345          procedure Report_Extra_Constituents_In_List (List : Elist_Id) is
25346             Constit_Elmt : Elmt_Id;
25347 
25348          begin
25349             if Present (List) then
25350                Constit_Elmt := First_Elmt (List);
25351                while Present (Constit_Elmt) loop
25352                   SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt));
25353                   Next_Elmt (Constit_Elmt);
25354                end loop;
25355             end if;
25356          end Report_Extra_Constituents_In_List;
25357 
25358       --  Start of processing for Report_Extra_Constituents
25359 
25360       begin
25361          --  Do not perform this check in an instance because it was already
25362          --  performed successfully in the generic template.
25363 
25364          if Is_Generic_Instance (Spec_Id) then
25365             null;
25366 
25367          else
25368             Report_Extra_Constituents_In_List (In_Constits);
25369             Report_Extra_Constituents_In_List (In_Out_Constits);
25370             Report_Extra_Constituents_In_List (Out_Constits);
25371             Report_Extra_Constituents_In_List (Proof_In_Constits);
25372          end if;
25373       end Report_Extra_Constituents;
25374 
25375       --  Local variables
25376 
25377       Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25378       Errors    : constant Nat     := Serious_Errors_Detected;
25379       Items     : Node_Id;
25380 
25381    --  Start of processing for Analyze_Refined_Global_In_Decl_Part
25382 
25383    begin
25384       --  Do not analyze the pragma multiple times
25385 
25386       if Is_Analyzed_Pragma (N) then
25387          return;
25388       end if;
25389 
25390       Spec_Id := Unique_Defining_Entity (Body_Decl);
25391 
25392       --  Use the anonymous object as the proper spec when Refined_Global
25393       --  applies to the body of a single task type. The object carries the
25394       --  proper Chars as well as all non-refined versions of pragmas.
25395 
25396       if Is_Single_Concurrent_Type (Spec_Id) then
25397          Spec_Id := Anonymous_Object (Spec_Id);
25398       end if;
25399 
25400       Global := Get_Pragma (Spec_Id, Pragma_Global);
25401       Items  := Expression (Get_Argument (N, Spec_Id));
25402 
25403       --  The subprogram declaration lacks pragma Global. This renders
25404       --  Refined_Global useless as there is nothing to refine.
25405 
25406       if No (Global) then
25407          SPARK_Msg_NE
25408            (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram "
25409             & "& lacks aspect or pragma Global"), N, Spec_Id);
25410          goto Leave;
25411       end if;
25412 
25413       --  Extract all relevant items from the corresponding Global pragma
25414 
25415       Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id)));
25416 
25417       --  Package and subprogram bodies are instantiated individually in
25418       --  a separate compiler pass. Due to this mode of instantiation, the
25419       --  refinement of a state may no longer be visible when a subprogram
25420       --  body contract is instantiated. Since the generic template is legal,
25421       --  do not perform this check in the instance to circumvent this oddity.
25422 
25423       if Is_Generic_Instance (Spec_Id) then
25424          null;
25425 
25426       --  Non-instance case
25427 
25428       else
25429          --  The corresponding Global pragma must mention at least one state
25430          --  witha visible refinement at the point Refined_Global is processed.
25431          --  States with null refinements need Refined_Global pragma
25432          --  (SPARK RM 7.2.4(2)).
25433 
25434          if not Has_In_State
25435            and then not Has_In_Out_State
25436            and then not Has_Out_State
25437            and then not Has_Proof_In_State
25438            and then not Has_Null_State
25439          then
25440             SPARK_Msg_NE
25441               (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not "
25442                & "depend on abstract state with visible refinement"),
25443                N, Spec_Id);
25444             goto Leave;
25445 
25446          --  The global refinement of inputs and outputs cannot be null when
25447          --  the corresponding Global pragma contains at least one item except
25448          --  in the case where we have states with null refinements.
25449 
25450          elsif Nkind (Items) = N_Null
25451            and then
25452              (Present (In_Items)
25453                or else Present (In_Out_Items)
25454                or else Present (Out_Items)
25455                or else Present (Proof_In_Items))
25456            and then not Has_Null_State
25457          then
25458             SPARK_Msg_NE
25459               (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has "
25460                & "global items"), N, Spec_Id);
25461             goto Leave;
25462          end if;
25463       end if;
25464 
25465       --  Analyze Refined_Global as if it behaved as a regular pragma Global.
25466       --  This ensures that the categorization of all refined global items is
25467       --  consistent with their role.
25468 
25469       Analyze_Global_In_Decl_Part (N);
25470 
25471       --  Perform all refinement checks with respect to completeness and mode
25472       --  matching.
25473 
25474       if Serious_Errors_Detected = Errors then
25475          Check_Refined_Global_List (Items);
25476       end if;
25477 
25478       --  For Input states with visible refinement, at least one constituent
25479       --  must be used as an Input in the global refinement.
25480 
25481       if Serious_Errors_Detected = Errors then
25482          Check_Input_States;
25483       end if;
25484 
25485       --  Verify all possible completion variants for In_Out states with
25486       --  visible refinement.
25487 
25488       if Serious_Errors_Detected = Errors then
25489          Check_In_Out_States;
25490       end if;
25491 
25492       --  For Output states with visible refinement, all constituents must be
25493       --  used as Outputs in the global refinement.
25494 
25495       if Serious_Errors_Detected = Errors then
25496          Check_Output_States;
25497       end if;
25498 
25499       --  For Proof_In states with visible refinement, at least one constituent
25500       --  must be used as Proof_In in the global refinement.
25501 
25502       if Serious_Errors_Detected = Errors then
25503          Check_Proof_In_States;
25504       end if;
25505 
25506       --  Emit errors for all constituents that belong to other states with
25507       --  visible refinement that do not appear in Global.
25508 
25509       if Serious_Errors_Detected = Errors then
25510          Report_Extra_Constituents;
25511       end if;
25512 
25513       <<Leave>>
25514       Set_Is_Analyzed_Pragma (N);
25515    end Analyze_Refined_Global_In_Decl_Part;
25516 
25517    ----------------------------------------
25518    -- Analyze_Refined_State_In_Decl_Part --
25519    ----------------------------------------
25520 
25521    procedure Analyze_Refined_State_In_Decl_Part
25522      (N         : Node_Id;
25523       Freeze_Id : Entity_Id := Empty)
25524    is
25525       Body_Decl : constant Node_Id   := Find_Related_Package_Or_Body (N);
25526       Body_Id   : constant Entity_Id := Defining_Entity (Body_Decl);
25527       Spec_Id   : constant Entity_Id := Corresponding_Spec (Body_Decl);
25528 
25529       Available_States : Elist_Id := No_Elist;
25530       --  A list of all abstract states defined in the package declaration that
25531       --  are available for refinement. The list is used to report unrefined
25532       --  states.
25533 
25534       Body_States : Elist_Id := No_Elist;
25535       --  A list of all hidden states that appear in the body of the related
25536       --  package. The list is used to report unused hidden states.
25537 
25538       Constituents_Seen : Elist_Id := No_Elist;
25539       --  A list that contains all constituents processed so far. The list is
25540       --  used to detect multiple uses of the same constituent.
25541 
25542       Freeze_Posted : Boolean := False;
25543       --  A flag that controls the output of a freezing-related error (see use
25544       --  below).
25545 
25546       Refined_States_Seen : Elist_Id := No_Elist;
25547       --  A list that contains all refined states processed so far. The list is
25548       --  used to detect duplicate refinements.
25549 
25550       procedure Analyze_Refinement_Clause (Clause : Node_Id);
25551       --  Perform full analysis of a single refinement clause
25552 
25553       procedure Report_Unrefined_States (States : Elist_Id);
25554       --  Emit errors for all unrefined abstract states found in list States
25555 
25556       -------------------------------
25557       -- Analyze_Refinement_Clause --
25558       -------------------------------
25559 
25560       procedure Analyze_Refinement_Clause (Clause : Node_Id) is
25561          AR_Constit : Entity_Id := Empty;
25562          AW_Constit : Entity_Id := Empty;
25563          ER_Constit : Entity_Id := Empty;
25564          EW_Constit : Entity_Id := Empty;
25565          --  The entities of external constituents that contain one of the
25566          --  following enabled properties: Async_Readers, Async_Writers,
25567          --  Effective_Reads and Effective_Writes.
25568 
25569          External_Constit_Seen : Boolean := False;
25570          --  Flag used to mark when at least one external constituent is part
25571          --  of the state refinement.
25572 
25573          Non_Null_Seen : Boolean := False;
25574          Null_Seen     : Boolean := False;
25575          --  Flags used to detect multiple uses of null in a single clause or a
25576          --  mixture of null and non-null constituents.
25577 
25578          Part_Of_Constits : Elist_Id := No_Elist;
25579          --  A list of all candidate constituents subject to indicator Part_Of
25580          --  where the encapsulating state is the current state.
25581 
25582          State    : Node_Id;
25583          State_Id : Entity_Id;
25584          --  The current state being refined
25585 
25586          procedure Analyze_Constituent (Constit : Node_Id);
25587          --  Perform full analysis of a single constituent
25588 
25589          procedure Check_External_Property
25590            (Prop_Nam : Name_Id;
25591             Enabled  : Boolean;
25592             Constit  : Entity_Id);
25593          --  Determine whether a property denoted by name Prop_Nam is present
25594          --  in the refined state. Emit an error if this is not the case. Flag
25595          --  Enabled should be set when the property applies to the refined
25596          --  state. Constit denotes the constituent (if any) which introduces
25597          --  the property in the refinement.
25598 
25599          procedure Match_State;
25600          --  Determine whether the state being refined appears in list
25601          --  Available_States. Emit an error when attempting to re-refine the
25602          --  state or when the state is not defined in the package declaration,
25603          --  otherwise remove the state from Available_States.
25604 
25605          procedure Report_Unused_Constituents (Constits : Elist_Id);
25606          --  Emit errors for all unused Part_Of constituents in list Constits
25607 
25608          -------------------------
25609          -- Analyze_Constituent --
25610          -------------------------
25611 
25612          procedure Analyze_Constituent (Constit : Node_Id) is
25613             procedure Match_Constituent (Constit_Id : Entity_Id);
25614             --  Determine whether constituent Constit denoted by its entity
25615             --  Constit_Id appears in Body_States. Emit an error when the
25616             --  constituent is not a valid hidden state of the related package
25617             --  or when it is used more than once. Otherwise remove the
25618             --  constituent from Body_States.
25619 
25620             -----------------------
25621             -- Match_Constituent --
25622             -----------------------
25623 
25624             procedure Match_Constituent (Constit_Id : Entity_Id) is
25625                procedure Collect_Constituent;
25626                --  Verify the legality of constituent Constit_Id and add it to
25627                --  the refinements of State_Id.
25628 
25629                -------------------------
25630                -- Collect_Constituent --
25631                -------------------------
25632 
25633                procedure Collect_Constituent is
25634                   Constits : Elist_Id;
25635 
25636                begin
25637                   --  The Ghost policy in effect at the point of abstract state
25638                   --  declaration and constituent must match (SPARK RM 6.9(15))
25639 
25640                   Check_Ghost_Refinement
25641                     (State, State_Id, Constit, Constit_Id);
25642 
25643                   --  A synchronized state must be refined by a synchronized
25644                   --  object or another synchronized state (SPARK RM 9.6).
25645 
25646                   if Is_Synchronized_State (State_Id)
25647                     and then not Is_Synchronized_Object (Constit_Id)
25648                     and then not Is_Synchronized_State (Constit_Id)
25649                   then
25650                      SPARK_Msg_NE
25651                        ("constituent of synchronized state & must be "
25652                         & "synchronized", Constit, State_Id);
25653                   end if;
25654 
25655                   --  Add the constituent to the list of processed items to aid
25656                   --  with the detection of duplicates.
25657 
25658                   Append_New_Elmt (Constit_Id, Constituents_Seen);
25659 
25660                   --  Collect the constituent in the list of refinement items
25661                   --  and establish a relation between the refined state and
25662                   --  the item.
25663 
25664                   Constits := Refinement_Constituents (State_Id);
25665 
25666                   if No (Constits) then
25667                      Constits := New_Elmt_List;
25668                      Set_Refinement_Constituents (State_Id, Constits);
25669                   end if;
25670 
25671                   Append_Elmt (Constit_Id, Constits);
25672                   Set_Encapsulating_State (Constit_Id, State_Id);
25673 
25674                   --  The state has at least one legal constituent, mark the
25675                   --  start of the refinement region. The region ends when the
25676                   --  body declarations end (see routine Analyze_Declarations).
25677 
25678                   Set_Has_Visible_Refinement (State_Id);
25679 
25680                   --  When the constituent is external, save its relevant
25681                   --  property for further checks.
25682 
25683                   if Async_Readers_Enabled (Constit_Id) then
25684                      AR_Constit := Constit_Id;
25685                      External_Constit_Seen := True;
25686                   end if;
25687 
25688                   if Async_Writers_Enabled (Constit_Id) then
25689                      AW_Constit := Constit_Id;
25690                      External_Constit_Seen := True;
25691                   end if;
25692 
25693                   if Effective_Reads_Enabled (Constit_Id) then
25694                      ER_Constit := Constit_Id;
25695                      External_Constit_Seen := True;
25696                   end if;
25697 
25698                   if Effective_Writes_Enabled (Constit_Id) then
25699                      EW_Constit := Constit_Id;
25700                      External_Constit_Seen := True;
25701                   end if;
25702                end Collect_Constituent;
25703 
25704                --  Local variables
25705 
25706                State_Elmt : Elmt_Id;
25707 
25708             --  Start of processing for Match_Constituent
25709 
25710             begin
25711                --  Detect a duplicate use of a constituent
25712 
25713                if Contains (Constituents_Seen, Constit_Id) then
25714                   SPARK_Msg_NE
25715                     ("duplicate use of constituent &", Constit, Constit_Id);
25716                   return;
25717                end if;
25718 
25719                --  The constituent is subject to a Part_Of indicator
25720 
25721                if Present (Encapsulating_State (Constit_Id)) then
25722                   if Encapsulating_State (Constit_Id) = State_Id then
25723                      Remove (Part_Of_Constits, Constit_Id);
25724                      Collect_Constituent;
25725 
25726                   --  The constituent is part of another state and is used
25727                   --  incorrectly in the refinement of the current state.
25728 
25729                   else
25730                      Error_Msg_Name_1 := Chars (State_Id);
25731                      SPARK_Msg_NE
25732                        ("& cannot act as constituent of state %",
25733                         Constit, Constit_Id);
25734                      SPARK_Msg_NE
25735                        ("\Part_Of indicator specifies encapsulator &",
25736                         Constit, Encapsulating_State (Constit_Id));
25737                   end if;
25738 
25739                --  The only other source of legal constituents is the body
25740                --  state space of the related package.
25741 
25742                else
25743                   if Present (Body_States) then
25744                      State_Elmt := First_Elmt (Body_States);
25745                      while Present (State_Elmt) loop
25746 
25747                         --  Consume a valid constituent to signal that it has
25748                         --  been encountered.
25749 
25750                         if Node (State_Elmt) = Constit_Id then
25751                            Remove_Elmt (Body_States, State_Elmt);
25752                            Collect_Constituent;
25753                            return;
25754                         end if;
25755 
25756                         Next_Elmt (State_Elmt);
25757                      end loop;
25758                   end if;
25759 
25760                   --  Constants are part of the hidden state of a package, but
25761                   --  the compiler cannot determine whether they have variable
25762                   --  input (SPARK RM 7.1.1(2)) and cannot classify them as a
25763                   --  hidden state. Accept the constant quietly even if it is
25764                   --  a visible state or lacks a Part_Of indicator.
25765 
25766                   if Ekind (Constit_Id) = E_Constant then
25767                      Collect_Constituent;
25768 
25769                   --  If we get here, then the constituent is not a hidden
25770                   --  state of the related package and may not be used in a
25771                   --  refinement (SPARK RM 7.2.2(9)).
25772 
25773                   else
25774                      Error_Msg_Name_1 := Chars (Spec_Id);
25775                      SPARK_Msg_NE
25776                        ("cannot use & in refinement, constituent is not a "
25777                         & "hidden state of package %", Constit, Constit_Id);
25778                   end if;
25779                end if;
25780             end Match_Constituent;
25781 
25782             --  Local variables
25783 
25784             Constit_Id : Entity_Id;
25785             Constits   : Elist_Id;
25786 
25787          --  Start of processing for Analyze_Constituent
25788 
25789          begin
25790             --  Detect multiple uses of null in a single refinement clause or a
25791             --  mixture of null and non-null constituents.
25792 
25793             if Nkind (Constit) = N_Null then
25794                if Null_Seen then
25795                   SPARK_Msg_N
25796                     ("multiple null constituents not allowed", Constit);
25797 
25798                elsif Non_Null_Seen then
25799                   SPARK_Msg_N
25800                     ("cannot mix null and non-null constituents", Constit);
25801 
25802                else
25803                   Null_Seen := True;
25804 
25805                   --  Collect the constituent in the list of refinement items
25806 
25807                   Constits := Refinement_Constituents (State_Id);
25808 
25809                   if No (Constits) then
25810                      Constits := New_Elmt_List;
25811                      Set_Refinement_Constituents (State_Id, Constits);
25812                   end if;
25813 
25814                   Append_Elmt (Constit, Constits);
25815 
25816                   --  The state has at least one legal constituent, mark the
25817                   --  start of the refinement region. The region ends when the
25818                   --  body declarations end (see Analyze_Declarations).
25819 
25820                   Set_Has_Visible_Refinement (State_Id);
25821                end if;
25822 
25823             --  Non-null constituents
25824 
25825             else
25826                Non_Null_Seen := True;
25827 
25828                if Null_Seen then
25829                   SPARK_Msg_N
25830                     ("cannot mix null and non-null constituents", Constit);
25831                end if;
25832 
25833                Analyze       (Constit);
25834                Resolve_State (Constit);
25835 
25836                --  Ensure that the constituent denotes a valid state or a
25837                --  whole object (SPARK RM 7.2.2(5)).
25838 
25839                if Is_Entity_Name (Constit) then
25840                   Constit_Id := Entity_Of (Constit);
25841 
25842                   --  When a constituent is declared after a subprogram body
25843                   --  that caused "freezing" of the related contract where
25844                   --  pragma Refined_State resides, the constituent appears
25845                   --  undefined and carries Any_Id as its entity.
25846 
25847                   --    package body Pack
25848                   --      with Refined_State => (State => Constit)
25849                   --    is
25850                   --       procedure Proc
25851                   --         with Refined_Global => (Input => Constit)
25852                   --       is
25853                   --          ...
25854                   --       end Proc;
25855 
25856                   --       Constit : ...;
25857                   --    end Pack;
25858 
25859                   if Constit_Id = Any_Id then
25860                      SPARK_Msg_NE ("& is undefined", Constit, Constit_Id);
25861 
25862                      --  Emit a specialized info message when the contract of
25863                      --  the related package body was "frozen" by another body.
25864                      --  Note that it is not possible to precisely identify why
25865                      --  the constituent is undefined because it is not visible
25866                      --  when pragma Refined_State is analyzed. This message is
25867                      --  a reasonable approximation.
25868 
25869                      if Present (Freeze_Id) and then not Freeze_Posted then
25870                         Freeze_Posted := True;
25871 
25872                         Error_Msg_Name_1 := Chars (Body_Id);
25873                         Error_Msg_Sloc   := Sloc (Freeze_Id);
25874                         SPARK_Msg_NE
25875                           ("body & declared # freezes the contract of %",
25876                            N, Freeze_Id);
25877                         SPARK_Msg_N
25878                           ("\all constituents must be declared before body #",
25879                            N);
25880 
25881                         --  A misplaced constituent is a critical error because
25882                         --  pragma Refined_Depends or Refined_Global depends on
25883                         --  the proper link between a state and a constituent.
25884                         --  Stop the compilation, as this leads to a multitude
25885                         --  of misleading cascaded errors.
25886 
25887                         raise Program_Error;
25888                      end if;
25889 
25890                   --  The constituent is a valid state or object
25891 
25892                   elsif Ekind_In (Constit_Id, E_Abstract_State,
25893                                               E_Constant,
25894                                               E_Variable)
25895                   then
25896                      Match_Constituent (Constit_Id);
25897 
25898                      --  The variable may eventually become a constituent of a
25899                      --  single protected/task type. Record the reference now
25900                      --  and verify its legality when analyzing the contract of
25901                      --  the variable (SPARK RM 9.3).
25902 
25903                      if Ekind (Constit_Id) = E_Variable then
25904                         Record_Possible_Part_Of_Reference
25905                           (Var_Id => Constit_Id,
25906                            Ref    => Constit);
25907                      end if;
25908 
25909                   --  Otherwise the constituent is illegal
25910 
25911                   else
25912                      SPARK_Msg_NE
25913                        ("constituent & must denote object or state",
25914                         Constit, Constit_Id);
25915                   end if;
25916 
25917                --  The constituent is illegal
25918 
25919                else
25920                   SPARK_Msg_N ("malformed constituent", Constit);
25921                end if;
25922             end if;
25923          end Analyze_Constituent;
25924 
25925          -----------------------------
25926          -- Check_External_Property --
25927          -----------------------------
25928 
25929          procedure Check_External_Property
25930            (Prop_Nam : Name_Id;
25931             Enabled  : Boolean;
25932             Constit  : Entity_Id)
25933          is
25934          begin
25935             --  The property is missing in the declaration of the state, but
25936             --  a constituent is introducing it in the state refinement
25937             --  (SPARK RM 7.2.8(2)).
25938 
25939             if not Enabled and then Present (Constit) then
25940                Error_Msg_Name_1 := Prop_Nam;
25941                Error_Msg_Name_2 := Chars (State_Id);
25942                SPARK_Msg_NE
25943                  ("constituent & introduces external property % in refinement "
25944                   & "of state %", State, Constit);
25945 
25946                Error_Msg_Sloc := Sloc (State_Id);
25947                SPARK_Msg_N
25948                  ("\property is missing in abstract state declaration #",
25949                   State);
25950             end if;
25951          end Check_External_Property;
25952 
25953          -----------------
25954          -- Match_State --
25955          -----------------
25956 
25957          procedure Match_State is
25958             State_Elmt : Elmt_Id;
25959 
25960          begin
25961             --  Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
25962 
25963             if Contains (Refined_States_Seen, State_Id) then
25964                SPARK_Msg_NE
25965                  ("duplicate refinement of state &", State, State_Id);
25966                return;
25967             end if;
25968 
25969             --  Inspect the abstract states defined in the package declaration
25970             --  looking for a match.
25971 
25972             State_Elmt := First_Elmt (Available_States);
25973             while Present (State_Elmt) loop
25974 
25975                --  A valid abstract state is being refined in the body. Add
25976                --  the state to the list of processed refined states to aid
25977                --  with the detection of duplicate refinements. Remove the
25978                --  state from Available_States to signal that it has already
25979                --  been refined.
25980 
25981                if Node (State_Elmt) = State_Id then
25982                   Append_New_Elmt (State_Id, Refined_States_Seen);
25983                   Remove_Elmt (Available_States, State_Elmt);
25984                   return;
25985                end if;
25986 
25987                Next_Elmt (State_Elmt);
25988             end loop;
25989 
25990             --  If we get here, we are refining a state that is not defined in
25991             --  the package declaration.
25992 
25993             Error_Msg_Name_1 := Chars (Spec_Id);
25994             SPARK_Msg_NE
25995               ("cannot refine state, & is not defined in package %",
25996                State, State_Id);
25997          end Match_State;
25998 
25999          --------------------------------
26000          -- Report_Unused_Constituents --
26001          --------------------------------
26002 
26003          procedure Report_Unused_Constituents (Constits : Elist_Id) is
26004             Constit_Elmt : Elmt_Id;
26005             Constit_Id   : Entity_Id;
26006             Posted       : Boolean := False;
26007 
26008          begin
26009             if Present (Constits) then
26010                Constit_Elmt := First_Elmt (Constits);
26011                while Present (Constit_Elmt) loop
26012                   Constit_Id := Node (Constit_Elmt);
26013 
26014                   --  Generate an error message of the form:
26015 
26016                   --    state ... has unused Part_Of constituents
26017                   --      abstract state ... defined at ...
26018                   --      constant ... defined at ...
26019                   --      variable ... defined at ...
26020 
26021                   if not Posted then
26022                      Posted := True;
26023                      SPARK_Msg_NE
26024                        ("state & has unused Part_Of constituents",
26025                         State, State_Id);
26026                   end if;
26027 
26028                   Error_Msg_Sloc := Sloc (Constit_Id);
26029 
26030                   if Ekind (Constit_Id) = E_Abstract_State then
26031                      SPARK_Msg_NE
26032                        ("\abstract state & defined #", State, Constit_Id);
26033 
26034                   elsif Ekind (Constit_Id) = E_Constant then
26035                      SPARK_Msg_NE
26036                        ("\constant & defined #", State, Constit_Id);
26037 
26038                   else
26039                      pragma Assert (Ekind (Constit_Id) = E_Variable);
26040                      SPARK_Msg_NE ("\variable & defined #", State, Constit_Id);
26041                   end if;
26042 
26043                   Next_Elmt (Constit_Elmt);
26044                end loop;
26045             end if;
26046          end Report_Unused_Constituents;
26047 
26048          --  Local declarations
26049 
26050          Body_Ref      : Node_Id;
26051          Body_Ref_Elmt : Elmt_Id;
26052          Constit       : Node_Id;
26053          Extra_State   : Node_Id;
26054 
26055       --  Start of processing for Analyze_Refinement_Clause
26056 
26057       begin
26058          --  A refinement clause appears as a component association where the
26059          --  sole choice is the state and the expressions are the constituents.
26060          --  This is a syntax error, always report.
26061 
26062          if Nkind (Clause) /= N_Component_Association then
26063             Error_Msg_N ("malformed state refinement clause", Clause);
26064             return;
26065          end if;
26066 
26067          --  Analyze the state name of a refinement clause
26068 
26069          State := First (Choices (Clause));
26070 
26071          Analyze       (State);
26072          Resolve_State (State);
26073 
26074          --  Ensure that the state name denotes a valid abstract state that is
26075          --  defined in the spec of the related package.
26076 
26077          if Is_Entity_Name (State) then
26078             State_Id := Entity_Of (State);
26079 
26080             --  When the abstract state is undefined, it appears as Any_Id. Do
26081             --  not continue with the analysis of the clause.
26082 
26083             if State_Id = Any_Id then
26084                return;
26085 
26086             --  Catch any attempts to re-refine a state or refine a state that
26087             --  is not defined in the package declaration.
26088 
26089             elsif Ekind (State_Id) = E_Abstract_State then
26090                Match_State;
26091 
26092             else
26093                SPARK_Msg_NE ("& must denote abstract state", State, State_Id);
26094                return;
26095             end if;
26096 
26097             --  References to a state with visible refinement are illegal.
26098             --  When nested packages are involved, detecting such references is
26099             --  tricky because pragma Refined_State is analyzed later than the
26100             --  offending pragma Depends or Global. References that occur in
26101             --  such nested context are stored in a list. Emit errors for all
26102             --  references found in Body_References (SPARK RM 6.1.4(8)).
26103 
26104             if Present (Body_References (State_Id)) then
26105                Body_Ref_Elmt := First_Elmt (Body_References (State_Id));
26106                while Present (Body_Ref_Elmt) loop
26107                   Body_Ref := Node (Body_Ref_Elmt);
26108 
26109                   SPARK_Msg_N ("reference to & not allowed", Body_Ref);
26110                   Error_Msg_Sloc := Sloc (State);
26111                   SPARK_Msg_N ("\refinement of & is visible#", Body_Ref);
26112 
26113                   Next_Elmt (Body_Ref_Elmt);
26114                end loop;
26115             end if;
26116 
26117          --  The state name is illegal. This is a syntax error, always report.
26118 
26119          else
26120             Error_Msg_N ("malformed state name in refinement clause", State);
26121             return;
26122          end if;
26123 
26124          --  A refinement clause may only refine one state at a time
26125 
26126          Extra_State := Next (State);
26127 
26128          if Present (Extra_State) then
26129             SPARK_Msg_N
26130               ("refinement clause cannot cover multiple states", Extra_State);
26131          end if;
26132 
26133          --  Replicate the Part_Of constituents of the refined state because
26134          --  the algorithm will consume items.
26135 
26136          Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id));
26137 
26138          --  Analyze all constituents of the refinement. Multiple constituents
26139          --  appear as an aggregate.
26140 
26141          Constit := Expression (Clause);
26142 
26143          if Nkind (Constit) = N_Aggregate then
26144             if Present (Component_Associations (Constit)) then
26145                SPARK_Msg_N
26146                  ("constituents of refinement clause must appear in "
26147                   & "positional form", Constit);
26148 
26149             else pragma Assert (Present (Expressions (Constit)));
26150                Constit := First (Expressions (Constit));
26151                while Present (Constit) loop
26152                   Analyze_Constituent (Constit);
26153                   Next (Constit);
26154                end loop;
26155             end if;
26156 
26157          --  Various forms of a single constituent. Note that these may include
26158          --  malformed constituents.
26159 
26160          else
26161             Analyze_Constituent (Constit);
26162          end if;
26163 
26164          --  Verify that external constituents do not introduce new external
26165          --  property in the state refinement (SPARK RM 7.2.8(2)).
26166 
26167          if Is_External_State (State_Id) then
26168             Check_External_Property
26169               (Prop_Nam => Name_Async_Readers,
26170                Enabled  => Async_Readers_Enabled (State_Id),
26171                Constit  => AR_Constit);
26172 
26173             Check_External_Property
26174               (Prop_Nam => Name_Async_Writers,
26175                Enabled  => Async_Writers_Enabled (State_Id),
26176                Constit  => AW_Constit);
26177 
26178             Check_External_Property
26179               (Prop_Nam => Name_Effective_Reads,
26180                Enabled  => Effective_Reads_Enabled (State_Id),
26181                Constit  => ER_Constit);
26182 
26183             Check_External_Property
26184               (Prop_Nam => Name_Effective_Writes,
26185                Enabled  => Effective_Writes_Enabled (State_Id),
26186                Constit  => EW_Constit);
26187 
26188          --  When a refined state is not external, it should not have external
26189          --  constituents (SPARK RM 7.2.8(1)).
26190 
26191          elsif External_Constit_Seen then
26192             SPARK_Msg_NE
26193               ("non-external state & cannot contain external constituents in "
26194                & "refinement", State, State_Id);
26195          end if;
26196 
26197          --  Ensure that all Part_Of candidate constituents have been mentioned
26198          --  in the refinement clause.
26199 
26200          Report_Unused_Constituents (Part_Of_Constits);
26201       end Analyze_Refinement_Clause;
26202 
26203       -----------------------------
26204       -- Report_Unrefined_States --
26205       -----------------------------
26206 
26207       procedure Report_Unrefined_States (States : Elist_Id) is
26208          State_Elmt : Elmt_Id;
26209 
26210       begin
26211          if Present (States) then
26212             State_Elmt := First_Elmt (States);
26213             while Present (State_Elmt) loop
26214                SPARK_Msg_N
26215                  ("abstract state & must be refined", Node (State_Elmt));
26216 
26217                Next_Elmt (State_Elmt);
26218             end loop;
26219          end if;
26220       end Report_Unrefined_States;
26221 
26222       --  Local declarations
26223 
26224       Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
26225       Clause  : Node_Id;
26226 
26227    --  Start of processing for Analyze_Refined_State_In_Decl_Part
26228 
26229    begin
26230       --  Do not analyze the pragma multiple times
26231 
26232       if Is_Analyzed_Pragma (N) then
26233          return;
26234       end if;
26235 
26236       --  Replicate the abstract states declared by the package because the
26237       --  matching algorithm will consume states.
26238 
26239       Available_States := New_Copy_Elist (Abstract_States (Spec_Id));
26240 
26241       --  Gather all abstract states and objects declared in the visible
26242       --  state space of the package body. These items must be utilized as
26243       --  constituents in a state refinement.
26244 
26245       Body_States := Collect_Body_States (Body_Id);
26246 
26247       --  Multiple non-null state refinements appear as an aggregate
26248 
26249       if Nkind (Clauses) = N_Aggregate then
26250          if Present (Expressions (Clauses)) then
26251             SPARK_Msg_N
26252               ("state refinements must appear as component associations",
26253                Clauses);
26254 
26255          else pragma Assert (Present (Component_Associations (Clauses)));
26256             Clause := First (Component_Associations (Clauses));
26257             while Present (Clause) loop
26258                Analyze_Refinement_Clause (Clause);
26259                Next (Clause);
26260             end loop;
26261          end if;
26262 
26263       --  Various forms of a single state refinement. Note that these may
26264       --  include malformed refinements.
26265 
26266       else
26267          Analyze_Refinement_Clause (Clauses);
26268       end if;
26269 
26270       --  List all abstract states that were left unrefined
26271 
26272       Report_Unrefined_States (Available_States);
26273 
26274       Set_Is_Analyzed_Pragma (N);
26275    end Analyze_Refined_State_In_Decl_Part;
26276 
26277    ------------------------------------
26278    -- Analyze_Test_Case_In_Decl_Part --
26279    ------------------------------------
26280 
26281    procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is
26282       Subp_Decl : constant Node_Id   := Find_Related_Declaration_Or_Body (N);
26283       Spec_Id   : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
26284 
26285       procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id);
26286       --  Preanalyze one of the optional arguments "Requires" or "Ensures"
26287       --  denoted by Arg_Nam.
26288 
26289       ------------------------------
26290       -- Preanalyze_Test_Case_Arg --
26291       ------------------------------
26292 
26293       procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is
26294          Arg : Node_Id;
26295 
26296       begin
26297          --  Preanalyze the original aspect argument for ASIS or for a generic
26298          --  subprogram to properly capture global references.
26299 
26300          if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then
26301             Arg :=
26302               Test_Case_Arg
26303                 (Prag        => N,
26304                  Arg_Nam     => Arg_Nam,
26305                  From_Aspect => True);
26306 
26307             if Present (Arg) then
26308                Preanalyze_Assert_Expression
26309                  (Expression (Arg), Standard_Boolean);
26310             end if;
26311          end if;
26312 
26313          Arg := Test_Case_Arg (N, Arg_Nam);
26314 
26315          if Present (Arg) then
26316             Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean);
26317          end if;
26318       end Preanalyze_Test_Case_Arg;
26319 
26320       --  Local variables
26321 
26322       Restore_Scope : Boolean := False;
26323 
26324    --  Start of processing for Analyze_Test_Case_In_Decl_Part
26325 
26326    begin
26327       --  Do not analyze the pragma multiple times
26328 
26329       if Is_Analyzed_Pragma (N) then
26330          return;
26331       end if;
26332 
26333       --  Ensure that the formal parameters are visible when analyzing all
26334       --  clauses. This falls out of the general rule of aspects pertaining
26335       --  to subprogram declarations.
26336 
26337       if not In_Open_Scopes (Spec_Id) then
26338          Restore_Scope := True;
26339          Push_Scope (Spec_Id);
26340 
26341          if Is_Generic_Subprogram (Spec_Id) then
26342             Install_Generic_Formals (Spec_Id);
26343          else
26344             Install_Formals (Spec_Id);
26345          end if;
26346       end if;
26347 
26348       Preanalyze_Test_Case_Arg (Name_Requires);
26349       Preanalyze_Test_Case_Arg (Name_Ensures);
26350 
26351       if Restore_Scope then
26352          End_Scope;
26353       end if;
26354 
26355       --  Currently it is not possible to inline pre/postconditions on a
26356       --  subprogram subject to pragma Inline_Always.
26357 
26358       Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
26359 
26360       Set_Is_Analyzed_Pragma (N);
26361    end Analyze_Test_Case_In_Decl_Part;
26362 
26363    ----------------
26364    -- Appears_In --
26365    ----------------
26366 
26367    function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is
26368       Elmt : Elmt_Id;
26369       Id   : Entity_Id;
26370 
26371    begin
26372       if Present (List) then
26373          Elmt := First_Elmt (List);
26374          while Present (Elmt) loop
26375             if Nkind (Node (Elmt)) = N_Defining_Identifier then
26376                Id := Node (Elmt);
26377             else
26378                Id := Entity_Of (Node (Elmt));
26379             end if;
26380 
26381             if Id = Item_Id then
26382                return True;
26383             end if;
26384 
26385             Next_Elmt (Elmt);
26386          end loop;
26387       end if;
26388 
26389       return False;
26390    end Appears_In;
26391 
26392    --------------------------------
26393    -- Build_Classwide_Expression --
26394    --------------------------------
26395 
26396    procedure Build_Classwide_Expression
26397      (Prag        : Node_Id;
26398       Subp        : Entity_Id;
26399       Adjust_Sloc : Boolean)
26400    is
26401       function Replace_Entity (N : Node_Id) return Traverse_Result;
26402       --  Replace reference to formal of inherited operation or to primitive
26403       --  operation of root type, with corresponding entity for derived type,
26404       --  when constructing the classwide condition of an overridding
26405       --  subprogram.
26406 
26407       --------------------
26408       -- Replace_Entity --
26409       --------------------
26410 
26411       function Replace_Entity (N : Node_Id) return Traverse_Result is
26412          New_E : Entity_Id;
26413 
26414       begin
26415          if Adjust_Sloc then
26416             Adjust_Inherited_Pragma_Sloc (N);
26417          end if;
26418 
26419          if Nkind (N) = N_Identifier
26420            and then Present (Entity (N))
26421            and then
26422              (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
26423            and then
26424              (Nkind (Parent (N)) /= N_Attribute_Reference
26425                or else Attribute_Name (Parent (N)) /= Name_Class)
26426          then
26427             --  The replacement does not apply to dispatching calls within the
26428             --  condition, but only to calls whose static tag is that of the
26429             --  parent type.
26430 
26431             if Is_Subprogram (Entity (N))
26432               and then Nkind (Parent (N)) = N_Function_Call
26433               and then Present (Controlling_Argument (Parent (N)))
26434             then
26435                return OK;
26436             end if;
26437 
26438             --  Determine whether entity has a renaming
26439 
26440             New_E := Primitives_Mapping.Get (Entity (N));
26441 
26442             if Present (New_E) then
26443                Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
26444             end if;
26445 
26446             --  Check that there are no calls left to abstract operations if
26447             --  the current subprogram is not abstract.
26448 
26449             if Nkind (Parent (N)) = N_Function_Call
26450               and then N = Name (Parent (N))
26451             then
26452                if not Is_Abstract_Subprogram (Subp)
26453                  and then Is_Abstract_Subprogram (Entity (N))
26454                then
26455                   Error_Msg_Sloc := Sloc (Current_Scope);
26456                   Error_Msg_NE
26457                     ("cannot call abstract subprogram in inherited condition "
26458                       & "for&#", N, Current_Scope);
26459 
26460                --  In SPARK mode, reject an inherited condition for an
26461                --  inherited operation if it contains a call to an overriding
26462                --  operation, because this implies that the pre/postcondition
26463                --  of the inherited operation have changed silently.
26464 
26465                elsif SPARK_Mode = On
26466                  and then Warn_On_Suspicious_Contract
26467                  and then Present (Alias (Subp))
26468                  and then Present (New_E)
26469                  and then Comes_From_Source (New_E)
26470                then
26471                   Error_Msg_N
26472                     ("cannot modify inherited condition (SPARK RM 6.1.1(1))",
26473                      Parent (Subp));
26474                   Error_Msg_Sloc   := Sloc (New_E);
26475                   Error_Msg_Node_2 := Subp;
26476                   Error_Msg_NE
26477                     ("\overriding of&# forces overriding of&",
26478                      Parent (Subp), New_E);
26479                end if;
26480             end if;
26481 
26482             --  Update type of function call node, which should be the same as
26483             --  the function's return type.
26484 
26485             if Is_Subprogram (Entity (N))
26486               and then Nkind (Parent (N)) = N_Function_Call
26487             then
26488                Set_Etype (Parent (N), Etype (Entity (N)));
26489             end if;
26490 
26491          --  The whole expression will be reanalyzed
26492 
26493          elsif Nkind (N) in N_Has_Etype then
26494             Set_Analyzed (N, False);
26495          end if;
26496 
26497          return OK;
26498       end Replace_Entity;
26499 
26500       procedure Replace_Condition_Entities is
26501         new Traverse_Proc (Replace_Entity);
26502 
26503    --  Start of processing for Build_Classwide_Expression
26504 
26505    begin
26506       Replace_Condition_Entities (Prag);
26507    end Build_Classwide_Expression;
26508 
26509    -----------------------------------
26510    -- Build_Pragma_Check_Equivalent --
26511    -----------------------------------
26512 
26513    function Build_Pragma_Check_Equivalent
26514      (Prag           : Node_Id;
26515       Subp_Id        : Entity_Id := Empty;
26516       Inher_Id       : Entity_Id := Empty;
26517       Keep_Pragma_Id : Boolean := False) return Node_Id
26518    is
26519       function Suppress_Reference (N : Node_Id) return Traverse_Result;
26520       --  Detect whether node N references a formal parameter subject to
26521       --  pragma Unreferenced. If this is the case, set Comes_From_Source
26522       --  to False to suppress the generation of a reference when analyzing
26523       --  N later on.
26524 
26525       ------------------------
26526       -- Suppress_Reference --
26527       ------------------------
26528 
26529       function Suppress_Reference (N : Node_Id) return Traverse_Result is
26530          Formal : Entity_Id;
26531 
26532       begin
26533          if Is_Entity_Name (N) and then Present (Entity (N)) then
26534             Formal := Entity (N);
26535 
26536             --  The formal parameter is subject to pragma Unreferenced. Prevent
26537             --  the generation of references by resetting the Comes_From_Source
26538             --  flag.
26539 
26540             if Is_Formal (Formal)
26541               and then Has_Pragma_Unreferenced (Formal)
26542             then
26543                Set_Comes_From_Source (N, False);
26544             end if;
26545          end if;
26546 
26547          return OK;
26548       end Suppress_Reference;
26549 
26550       procedure Suppress_References is
26551         new Traverse_Proc (Suppress_Reference);
26552 
26553       --  Local variables
26554 
26555       Loc          : constant Source_Ptr := Sloc (Prag);
26556       Prag_Nam     : constant Name_Id    := Pragma_Name (Prag);
26557       Check_Prag   : Node_Id;
26558       Inher_Formal : Entity_Id;
26559       Msg_Arg      : Node_Id;
26560       Nam          : Name_Id;
26561       Subp_Formal  : Entity_Id;
26562 
26563    --  Start of processing for Build_Pragma_Check_Equivalent
26564 
26565    begin
26566       --  When the pre- or postcondition is inherited, map the formals of the
26567       --  inherited subprogram to those of the current subprogram. In addition,
26568       --  map primitive operations of the parent type into the corresponding
26569       --  primitive operations of the descendant.
26570 
26571       if Present (Inher_Id) then
26572          pragma Assert (Present (Subp_Id));
26573 
26574          Update_Primitives_Mapping (Inher_Id, Subp_Id);
26575 
26576          --  Add mapping from old formals to new formals.
26577 
26578          Inher_Formal := First_Formal (Inher_Id);
26579          Subp_Formal  := First_Formal (Subp_Id);
26580          while Present (Inher_Formal) and then Present (Subp_Formal) loop
26581             Primitives_Mapping.Set (Inher_Formal, Subp_Formal);
26582             Next_Formal (Inher_Formal);
26583             Next_Formal (Subp_Formal);
26584          end loop;
26585 
26586          --  Use generic machinery to copy inherited pragma, as if it were an
26587          --  instantiation, resetting source locations appropriately, so that
26588          --  expressions inside the inherited pragma use chained locations.
26589          --  This is used in particular in GNATprove to locate precisely
26590          --  messages on a given inherited pragma.
26591 
26592          Set_Copied_Sloc_For_Inherited_Pragma
26593            (Unit_Declaration_Node (Subp_Id), Inher_Id);
26594          Check_Prag := New_Copy_Tree (Source => Prag);
26595          Build_Classwide_Expression (Check_Prag, Subp_Id, Adjust_Sloc => True);
26596 
26597       --  Otherwise simply copy the original pragma
26598 
26599       else
26600          Check_Prag := New_Copy_Tree (Source => Prag);
26601       end if;
26602 
26603       --  Mark the pragma as being internally generated and reset the Analyzed
26604       --  flag.
26605 
26606       Set_Analyzed          (Check_Prag, False);
26607       Set_Comes_From_Source (Check_Prag, False);
26608 
26609       --  The tree of the original pragma may contain references to the
26610       --  formal parameters of the related subprogram. At the same time
26611       --  the corresponding body may mark the formals as unreferenced:
26612 
26613       --     procedure Proc (Formal : ...)
26614       --       with Pre => Formal ...;
26615 
26616       --     procedure Proc (Formal : ...) is
26617       --        pragma Unreferenced (Formal);
26618       --     ...
26619 
26620       --  This creates problems because all pragma Check equivalents are
26621       --  analyzed at the end of the body declarations. Since all source
26622       --  references have already been accounted for, reset any references
26623       --  to such formals in the generated pragma Check equivalent.
26624 
26625       Suppress_References (Check_Prag);
26626 
26627       if Present (Corresponding_Aspect (Prag)) then
26628          Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
26629       else
26630          Nam := Prag_Nam;
26631       end if;
26632 
26633       --  Unless Keep_Pragma_Id is True in order to keep the identifier of
26634       --  the copied pragma in the newly created pragma, convert the copy into
26635       --  pragma Check by correcting the name and adding a check_kind argument.
26636 
26637       if not Keep_Pragma_Id then
26638          Set_Class_Present (Check_Prag, False);
26639 
26640          Set_Pragma_Identifier
26641            (Check_Prag, Make_Identifier (Loc, Name_Check));
26642 
26643          Prepend_To (Pragma_Argument_Associations (Check_Prag),
26644            Make_Pragma_Argument_Association (Loc,
26645              Expression => Make_Identifier (Loc, Nam)));
26646       end if;
26647 
26648       --  Update the error message when the pragma is inherited
26649 
26650       if Present (Inher_Id) then
26651          Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
26652 
26653          if Chars (Msg_Arg) = Name_Message then
26654             String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
26655 
26656             --  Insert "inherited" to improve the error message
26657 
26658             if Name_Buffer (1 .. 8) = "failed p" then
26659                Insert_Str_In_Name_Buffer ("inherited ", 8);
26660                Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
26661             end if;
26662          end if;
26663       end if;
26664 
26665       return Check_Prag;
26666    end Build_Pragma_Check_Equivalent;
26667 
26668    -----------------------------
26669    -- Check_Applicable_Policy --
26670    -----------------------------
26671 
26672    procedure Check_Applicable_Policy (N : Node_Id) is
26673       PP     : Node_Id;
26674       Policy : Name_Id;
26675 
26676       Ename : constant Name_Id := Original_Aspect_Pragma_Name (N);
26677 
26678    begin
26679       --  No effect if not valid assertion kind name
26680 
26681       if not Is_Valid_Assertion_Kind (Ename) then
26682          return;
26683       end if;
26684 
26685       --  Loop through entries in check policy list
26686 
26687       PP := Opt.Check_Policy_List;
26688       while Present (PP) loop
26689          declare
26690             PPA : constant List_Id := Pragma_Argument_Associations (PP);
26691             Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
26692 
26693          begin
26694             if Ename = Pnm
26695               or else Pnm = Name_Assertion
26696               or else (Pnm = Name_Statement_Assertions
26697                         and then Nam_In (Ename, Name_Assert,
26698                                                 Name_Assert_And_Cut,
26699                                                 Name_Assume,
26700                                                 Name_Loop_Invariant,
26701                                                 Name_Loop_Variant))
26702             then
26703                Policy := Chars (Get_Pragma_Arg (Last (PPA)));
26704 
26705                case Policy is
26706                   when Name_Off | Name_Ignore =>
26707                      Set_Is_Ignored (N, True);
26708                      Set_Is_Checked (N, False);
26709 
26710                   when Name_On | Name_Check =>
26711                      Set_Is_Checked (N, True);
26712                      Set_Is_Ignored (N, False);
26713 
26714                   when Name_Disable =>
26715                      Set_Is_Ignored  (N, True);
26716                      Set_Is_Checked  (N, False);
26717                      Set_Is_Disabled (N, True);
26718 
26719                   --  That should be exhaustive, the null here is a defence
26720                   --  against a malformed tree from previous errors.
26721 
26722                   when others =>
26723                      null;
26724                end case;
26725 
26726                return;
26727             end if;
26728 
26729             PP := Next_Pragma (PP);
26730          end;
26731       end loop;
26732 
26733       --  If there are no specific entries that matched, then we let the
26734       --  setting of assertions govern. Note that this provides the needed
26735       --  compatibility with the RM for the cases of assertion, invariant,
26736       --  precondition, predicate, and postcondition.
26737 
26738       if Assertions_Enabled then
26739          Set_Is_Checked (N, True);
26740          Set_Is_Ignored (N, False);
26741       else
26742          Set_Is_Checked (N, False);
26743          Set_Is_Ignored (N, True);
26744       end if;
26745    end Check_Applicable_Policy;
26746 
26747    -------------------------------
26748    -- Check_External_Properties --
26749    -------------------------------
26750 
26751    procedure Check_External_Properties
26752      (Item : Node_Id;
26753       AR   : Boolean;
26754       AW   : Boolean;
26755       ER   : Boolean;
26756       EW   : Boolean)
26757    is
26758    begin
26759       --  All properties enabled
26760 
26761       if AR and AW and ER and EW then
26762          null;
26763 
26764       --  Async_Readers + Effective_Writes
26765       --  Async_Readers + Async_Writers + Effective_Writes
26766 
26767       elsif AR and EW and not ER then
26768          null;
26769 
26770       --  Async_Writers + Effective_Reads
26771       --  Async_Readers + Async_Writers + Effective_Reads
26772 
26773       elsif AW and ER and not EW then
26774          null;
26775 
26776       --  Async_Readers + Async_Writers
26777 
26778       elsif AR and AW and not ER and not EW then
26779          null;
26780 
26781       --  Async_Readers
26782 
26783       elsif AR and not AW and not ER and not EW then
26784          null;
26785 
26786       --  Async_Writers
26787 
26788       elsif AW and not AR and not ER and not EW then
26789          null;
26790 
26791       else
26792          SPARK_Msg_N
26793            ("illegal combination of external properties (SPARK RM 7.1.2(6))",
26794             Item);
26795       end if;
26796    end Check_External_Properties;
26797 
26798    ----------------
26799    -- Check_Kind --
26800    ----------------
26801 
26802    function Check_Kind (Nam : Name_Id) return Name_Id is
26803       PP : Node_Id;
26804 
26805    begin
26806       --  Loop through entries in check policy list
26807 
26808       PP := Opt.Check_Policy_List;
26809       while Present (PP) loop
26810          declare
26811             PPA : constant List_Id := Pragma_Argument_Associations (PP);
26812             Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA)));
26813 
26814          begin
26815             if Nam = Pnm
26816               or else (Pnm = Name_Assertion
26817                         and then Is_Valid_Assertion_Kind (Nam))
26818               or else (Pnm = Name_Statement_Assertions
26819                         and then Nam_In (Nam, Name_Assert,
26820                                               Name_Assert_And_Cut,
26821                                               Name_Assume,
26822                                               Name_Loop_Invariant,
26823                                               Name_Loop_Variant))
26824             then
26825                case (Chars (Get_Pragma_Arg (Last (PPA)))) is
26826                   when Name_On | Name_Check =>
26827                      return Name_Check;
26828                   when Name_Off | Name_Ignore =>
26829                      return Name_Ignore;
26830                   when Name_Disable =>
26831                      return Name_Disable;
26832                   when others =>
26833                      raise Program_Error;
26834                end case;
26835 
26836             else
26837                PP := Next_Pragma (PP);
26838             end if;
26839          end;
26840       end loop;
26841 
26842       --  If there are no specific entries that matched, then we let the
26843       --  setting of assertions govern. Note that this provides the needed
26844       --  compatibility with the RM for the cases of assertion, invariant,
26845       --  precondition, predicate, and postcondition.
26846 
26847       if Assertions_Enabled then
26848          return Name_Check;
26849       else
26850          return Name_Ignore;
26851       end if;
26852    end Check_Kind;
26853 
26854    ---------------------------
26855    -- Check_Missing_Part_Of --
26856    ---------------------------
26857 
26858    procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is
26859       function Has_Visible_State (Pack_Id : Entity_Id) return Boolean;
26860       --  Determine whether a package denoted by Pack_Id declares at least one
26861       --  visible state.
26862 
26863       -----------------------
26864       -- Has_Visible_State --
26865       -----------------------
26866 
26867       function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is
26868          Item_Id : Entity_Id;
26869 
26870       begin
26871          --  Traverse the entity chain of the package trying to find at least
26872          --  one visible abstract state, variable or a package [instantiation]
26873          --  that declares a visible state.
26874 
26875          Item_Id := First_Entity (Pack_Id);
26876          while Present (Item_Id)
26877            and then not In_Private_Part (Item_Id)
26878          loop
26879             --  Do not consider internally generated items
26880 
26881             if not Comes_From_Source (Item_Id) then
26882                null;
26883 
26884             --  A visible state has been found
26885 
26886             elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then
26887                return True;
26888 
26889             --  Recursively peek into nested packages and instantiations
26890 
26891             elsif Ekind (Item_Id) = E_Package
26892               and then Has_Visible_State (Item_Id)
26893             then
26894                return True;
26895             end if;
26896 
26897             Next_Entity (Item_Id);
26898          end loop;
26899 
26900          return False;
26901       end Has_Visible_State;
26902 
26903       --  Local variables
26904 
26905       Pack_Id   : Entity_Id;
26906       Placement : State_Space_Kind;
26907 
26908    --  Start of processing for Check_Missing_Part_Of
26909 
26910    begin
26911       --  Do not consider abstract states, variables or package instantiations
26912       --  coming from an instance as those always inherit the Part_Of indicator
26913       --  of the instance itself.
26914 
26915       if In_Instance then
26916          return;
26917 
26918       --  Do not consider internally generated entities as these can never
26919       --  have a Part_Of indicator.
26920 
26921       elsif not Comes_From_Source (Item_Id) then
26922          return;
26923 
26924       --  Perform these checks only when SPARK_Mode is enabled as they will
26925       --  interfere with standard Ada rules and produce false positives.
26926 
26927       elsif SPARK_Mode /= On then
26928          return;
26929 
26930       --  Do not consider constants, because the compiler cannot accurately
26931       --  determine whether they have variable input (SPARK RM 7.1.1(2)) and
26932       --  act as a hidden state of a package.
26933 
26934       elsif Ekind (Item_Id) = E_Constant then
26935          return;
26936       end if;
26937 
26938       --  Find where the abstract state, variable or package instantiation
26939       --  lives with respect to the state space.
26940 
26941       Find_Placement_In_State_Space
26942         (Item_Id   => Item_Id,
26943          Placement => Placement,
26944          Pack_Id   => Pack_Id);
26945 
26946       --  Items that appear in a non-package construct (subprogram, block, etc)
26947       --  do not require a Part_Of indicator because they can never act as a
26948       --  hidden state.
26949 
26950       if Placement = Not_In_Package then
26951          null;
26952 
26953       --  An item declared in the body state space of a package always act as a
26954       --  constituent and does not need explicit Part_Of indicator.
26955 
26956       elsif Placement = Body_State_Space then
26957          null;
26958 
26959       --  In general an item declared in the visible state space of a package
26960       --  does not require a Part_Of indicator. The only exception is when the
26961       --  related package is a private child unit in which case Part_Of must
26962       --  denote a state in the parent unit or in one of its descendants.
26963 
26964       elsif Placement = Visible_State_Space then
26965          if Is_Child_Unit (Pack_Id)
26966            and then Is_Private_Descendant (Pack_Id)
26967          then
26968             --  A package instantiation does not need a Part_Of indicator when
26969             --  the related generic template has no visible state.
26970 
26971             if Ekind (Item_Id) = E_Package
26972               and then Is_Generic_Instance (Item_Id)
26973               and then not Has_Visible_State (Item_Id)
26974             then
26975                null;
26976 
26977             --  All other cases require Part_Of
26978 
26979             else
26980                Error_Msg_N
26981                  ("indicator Part_Of is required in this context "
26982                   & "(SPARK RM 7.2.6(3))", Item_Id);
26983                Error_Msg_Name_1 := Chars (Pack_Id);
26984                Error_Msg_N
26985                  ("\& is declared in the visible part of private child "
26986                   & "unit %", Item_Id);
26987             end if;
26988          end if;
26989 
26990       --  When the item appears in the private state space of a packge, it must
26991       --  be a part of some state declared by the said package.
26992 
26993       else pragma Assert (Placement = Private_State_Space);
26994 
26995          --  The related package does not declare a state, the item cannot act
26996          --  as a Part_Of constituent.
26997 
26998          if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then
26999             null;
27000 
27001          --  A package instantiation does not need a Part_Of indicator when the
27002          --  related generic template has no visible state.
27003 
27004          elsif Ekind (Pack_Id) = E_Package
27005            and then Is_Generic_Instance (Pack_Id)
27006            and then not Has_Visible_State (Pack_Id)
27007          then
27008             null;
27009 
27010          --  All other cases require Part_Of
27011 
27012          else
27013             Error_Msg_N
27014               ("indicator Part_Of is required in this context "
27015                & "(SPARK RM 7.2.6(2))", Item_Id);
27016             Error_Msg_Name_1 := Chars (Pack_Id);
27017             Error_Msg_N
27018               ("\& is declared in the private part of package %", Item_Id);
27019          end if;
27020       end if;
27021    end Check_Missing_Part_Of;
27022 
27023    ---------------------------------------------------
27024    -- Check_Postcondition_Use_In_Inlined_Subprogram --
27025    ---------------------------------------------------
27026 
27027    procedure Check_Postcondition_Use_In_Inlined_Subprogram
27028      (Prag    : Node_Id;
27029       Spec_Id : Entity_Id)
27030    is
27031    begin
27032       if Warn_On_Redundant_Constructs
27033         and then Has_Pragma_Inline_Always (Spec_Id)
27034       then
27035          Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
27036 
27037          if From_Aspect_Specification (Prag) then
27038             Error_Msg_NE
27039               ("aspect % not enforced on inlined subprogram &?r?",
27040                Corresponding_Aspect (Prag), Spec_Id);
27041          else
27042             Error_Msg_NE
27043               ("pragma % not enforced on inlined subprogram &?r?",
27044                Prag, Spec_Id);
27045          end if;
27046       end if;
27047    end Check_Postcondition_Use_In_Inlined_Subprogram;
27048 
27049    -------------------------------------
27050    -- Check_State_And_Constituent_Use --
27051    -------------------------------------
27052 
27053    procedure Check_State_And_Constituent_Use
27054      (States   : Elist_Id;
27055       Constits : Elist_Id;
27056       Context  : Node_Id)
27057    is
27058       function Find_Encapsulating_State
27059         (Constit_Id : Entity_Id) return Entity_Id;
27060       --  Given the entity of a constituent, try to find a corresponding
27061       --  encapsulating state that appears in the same context. The routine
27062       --  returns Empty is no such state is found.
27063 
27064       ------------------------------
27065       -- Find_Encapsulating_State --
27066       ------------------------------
27067 
27068       function Find_Encapsulating_State
27069         (Constit_Id : Entity_Id) return Entity_Id
27070       is
27071          State_Id : Entity_Id;
27072 
27073       begin
27074          --  Since a constituent may be part of a larger constituent set, climb
27075          --  the encapsulating state chain looking for a state that appears in
27076          --  the same context.
27077 
27078          State_Id := Encapsulating_State (Constit_Id);
27079          while Present (State_Id) loop
27080             if Contains (States, State_Id) then
27081                return State_Id;
27082             end if;
27083 
27084             State_Id := Encapsulating_State (State_Id);
27085          end loop;
27086 
27087          return Empty;
27088       end Find_Encapsulating_State;
27089 
27090       --  Local variables
27091 
27092       Constit_Elmt : Elmt_Id;
27093       Constit_Id   : Entity_Id;
27094       State_Id     : Entity_Id;
27095 
27096    --  Start of processing for Check_State_And_Constituent_Use
27097 
27098    begin
27099       --  Nothing to do if there are no states or constituents
27100 
27101       if No (States) or else No (Constits) then
27102          return;
27103       end if;
27104 
27105       --  Inspect the list of constituents and try to determine whether its
27106       --  encapsulating state is in list States.
27107 
27108       Constit_Elmt := First_Elmt (Constits);
27109       while Present (Constit_Elmt) loop
27110          Constit_Id := Node (Constit_Elmt);
27111 
27112          --  Determine whether the constituent is part of an encapsulating
27113          --  state that appears in the same context and if this is the case,
27114          --  emit an error (SPARK RM 7.2.6(7)).
27115 
27116          State_Id := Find_Encapsulating_State (Constit_Id);
27117 
27118          if Present (State_Id) then
27119             Error_Msg_Name_1 := Chars (Constit_Id);
27120             SPARK_Msg_NE
27121               ("cannot mention state & and its constituent % in the same "
27122                & "context", Context, State_Id);
27123             exit;
27124          end if;
27125 
27126          Next_Elmt (Constit_Elmt);
27127       end loop;
27128    end Check_State_And_Constituent_Use;
27129 
27130    ---------------------------------------------
27131    -- Collect_Inherited_Class_Wide_Conditions --
27132    ---------------------------------------------
27133 
27134    procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
27135       Parent_Subp  : constant Entity_Id := Overridden_Operation (Subp);
27136       Prags        : constant Node_Id   := Contract (Parent_Subp);
27137       In_Spec_Expr : Boolean;
27138       Installed    : Boolean;
27139       Prag         : Node_Id;
27140       New_Prag     : Node_Id;
27141 
27142    begin
27143       Installed := False;
27144 
27145       --  Iterate over the contract of the overridden subprogram to find all
27146       --  inherited class-wide pre- and postconditions.
27147 
27148       if Present (Prags) then
27149          Prag := Pre_Post_Conditions (Prags);
27150 
27151          while Present (Prag) loop
27152             if Nam_In (Pragma_Name (Prag), Name_Precondition,
27153                                            Name_Postcondition)
27154               and then Class_Present (Prag)
27155             then
27156                --  The generated pragma must be analyzed in the context of
27157                --  the subprogram, to make its formals visible. In addition,
27158                --  we must inhibit freezing and full analysis because the
27159                --  controlling type of the subprogram is not frozen yet, and
27160                --  may have further primitives.
27161 
27162                if not Installed then
27163                   Installed := True;
27164                   Push_Scope (Subp);
27165                   Install_Formals (Subp);
27166                   In_Spec_Expr := In_Spec_Expression;
27167                   In_Spec_Expression := True;
27168                end if;
27169 
27170                New_Prag :=
27171                  Build_Pragma_Check_Equivalent
27172                    (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
27173 
27174                Insert_After (Unit_Declaration_Node (Subp), New_Prag);
27175                Preanalyze (New_Prag);
27176 
27177                --  Prevent further analysis in subsequent processing of the
27178                --  current list of declarations
27179 
27180                Set_Analyzed (New_Prag);
27181             end if;
27182 
27183             Prag := Next_Pragma (Prag);
27184          end loop;
27185 
27186          if Installed then
27187             In_Spec_Expression := In_Spec_Expr;
27188             End_Scope;
27189          end if;
27190       end if;
27191    end Collect_Inherited_Class_Wide_Conditions;
27192 
27193    ---------------------------------------
27194    -- Collect_Subprogram_Inputs_Outputs --
27195    ---------------------------------------
27196 
27197    procedure Collect_Subprogram_Inputs_Outputs
27198      (Subp_Id      : Entity_Id;
27199       Synthesize   : Boolean := False;
27200       Subp_Inputs  : in out Elist_Id;
27201       Subp_Outputs : in out Elist_Id;
27202       Global_Seen  : out Boolean)
27203    is
27204       procedure Collect_Dependency_Clause (Clause : Node_Id);
27205       --  Collect all relevant items from a dependency clause
27206 
27207       procedure Collect_Global_List
27208         (List : Node_Id;
27209          Mode : Name_Id := Name_Input);
27210       --  Collect all relevant items from a global list
27211 
27212       -------------------------------
27213       -- Collect_Dependency_Clause --
27214       -------------------------------
27215 
27216       procedure Collect_Dependency_Clause (Clause : Node_Id) is
27217          procedure Collect_Dependency_Item
27218            (Item     : Node_Id;
27219             Is_Input : Boolean);
27220          --  Add an item to the proper subprogram input or output collection
27221 
27222          -----------------------------
27223          -- Collect_Dependency_Item --
27224          -----------------------------
27225 
27226          procedure Collect_Dependency_Item
27227            (Item     : Node_Id;
27228             Is_Input : Boolean)
27229          is
27230             Extra : Node_Id;
27231 
27232          begin
27233             --  Nothing to collect when the item is null
27234 
27235             if Nkind (Item) = N_Null then
27236                null;
27237 
27238             --  Ditto for attribute 'Result
27239 
27240             elsif Is_Attribute_Result (Item) then
27241                null;
27242 
27243             --  Multiple items appear as an aggregate
27244 
27245             elsif Nkind (Item) = N_Aggregate then
27246                Extra := First (Expressions (Item));
27247                while Present (Extra) loop
27248                   Collect_Dependency_Item (Extra, Is_Input);
27249                   Next (Extra);
27250                end loop;
27251 
27252             --  Otherwise this is a solitary item
27253 
27254             else
27255                if Is_Input then
27256                   Append_New_Elmt (Item, Subp_Inputs);
27257                else
27258                   Append_New_Elmt (Item, Subp_Outputs);
27259                end if;
27260             end if;
27261          end Collect_Dependency_Item;
27262 
27263       --  Start of processing for Collect_Dependency_Clause
27264 
27265       begin
27266          if Nkind (Clause) = N_Null then
27267             null;
27268 
27269          --  A dependency cause appears as component association
27270 
27271          elsif Nkind (Clause) = N_Component_Association then
27272             Collect_Dependency_Item
27273               (Item     => Expression (Clause),
27274                Is_Input => True);
27275 
27276             Collect_Dependency_Item
27277               (Item     => First (Choices (Clause)),
27278                Is_Input => False);
27279 
27280          --  To accomodate partial decoration of disabled SPARK features, this
27281          --  routine may be called with illegal input. If this is the case, do
27282          --  not raise Program_Error.
27283 
27284          else
27285             null;
27286          end if;
27287       end Collect_Dependency_Clause;
27288 
27289       -------------------------
27290       -- Collect_Global_List --
27291       -------------------------
27292 
27293       procedure Collect_Global_List
27294         (List : Node_Id;
27295          Mode : Name_Id := Name_Input)
27296       is
27297          procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id);
27298          --  Add an item to the proper subprogram input or output collection
27299 
27300          -------------------------
27301          -- Collect_Global_Item --
27302          -------------------------
27303 
27304          procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is
27305          begin
27306             if Nam_In (Mode, Name_In_Out, Name_Input) then
27307                Append_New_Elmt (Item, Subp_Inputs);
27308             end if;
27309 
27310             if Nam_In (Mode, Name_In_Out, Name_Output) then
27311                Append_New_Elmt (Item, Subp_Outputs);
27312             end if;
27313          end Collect_Global_Item;
27314 
27315          --  Local variables
27316 
27317          Assoc : Node_Id;
27318          Item  : Node_Id;
27319 
27320       --  Start of processing for Collect_Global_List
27321 
27322       begin
27323          if Nkind (List) = N_Null then
27324             null;
27325 
27326          --  Single global item declaration
27327 
27328          elsif Nkind_In (List, N_Expanded_Name,
27329                                N_Identifier,
27330                                N_Selected_Component)
27331          then
27332             Collect_Global_Item (List, Mode);
27333 
27334          --  Simple global list or moded global list declaration
27335 
27336          elsif Nkind (List) = N_Aggregate then
27337             if Present (Expressions (List)) then
27338                Item := First (Expressions (List));
27339                while Present (Item) loop
27340                   Collect_Global_Item (Item, Mode);
27341                   Next (Item);
27342                end loop;
27343 
27344             else
27345                Assoc := First (Component_Associations (List));
27346                while Present (Assoc) loop
27347                   Collect_Global_List
27348                     (List => Expression (Assoc),
27349                      Mode => Chars (First (Choices (Assoc))));
27350                   Next (Assoc);
27351                end loop;
27352             end if;
27353 
27354          --  To accomodate partial decoration of disabled SPARK features, this
27355          --  routine may be called with illegal input. If this is the case, do
27356          --  not raise Program_Error.
27357 
27358          else
27359             null;
27360          end if;
27361       end Collect_Global_List;
27362 
27363       --  Local variables
27364 
27365       Clause    : Node_Id;
27366       Clauses   : Node_Id;
27367       Depends   : Node_Id;
27368       Formal    : Entity_Id;
27369       Global    : Node_Id;
27370       Spec_Id   : Entity_Id;
27371       Subp_Decl : Node_Id;
27372       Typ       : Entity_Id;
27373 
27374    --  Start of processing for Collect_Subprogram_Inputs_Outputs
27375 
27376    begin
27377       Global_Seen := False;
27378 
27379       --  Process all formal parameters of entries, [generic] subprograms, and
27380       --  their bodies.
27381 
27382       if Ekind_In (Subp_Id, E_Entry,
27383                             E_Entry_Family,
27384                             E_Function,
27385                             E_Generic_Function,
27386                             E_Generic_Procedure,
27387                             E_Procedure,
27388                             E_Subprogram_Body)
27389       then
27390          Subp_Decl := Unit_Declaration_Node (Subp_Id);
27391          Spec_Id   := Unique_Defining_Entity (Subp_Decl);
27392 
27393          --  Process all [generic] formal parameters
27394 
27395          Formal := First_Entity (Spec_Id);
27396          while Present (Formal) loop
27397             if Ekind_In (Formal, E_Generic_In_Parameter,
27398                                  E_In_Out_Parameter,
27399                                  E_In_Parameter)
27400             then
27401                Append_New_Elmt (Formal, Subp_Inputs);
27402             end if;
27403 
27404             if Ekind_In (Formal, E_Generic_In_Out_Parameter,
27405                                  E_In_Out_Parameter,
27406                                  E_Out_Parameter)
27407             then
27408                Append_New_Elmt (Formal, Subp_Outputs);
27409 
27410                --  Out parameters can act as inputs when the related type is
27411                --  tagged, unconstrained array, unconstrained record, or record
27412                --  with unconstrained components.
27413 
27414                if Ekind (Formal) = E_Out_Parameter
27415                  and then Is_Unconstrained_Or_Tagged_Item (Formal)
27416                then
27417                   Append_New_Elmt (Formal, Subp_Inputs);
27418                end if;
27419             end if;
27420 
27421             Next_Entity (Formal);
27422          end loop;
27423 
27424       --  Otherwise the input denotes a task type, a task body, or the
27425       --  anonymous object created for a single task type.
27426 
27427       elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body)
27428         or else Is_Single_Task_Object (Subp_Id)
27429       then
27430          Subp_Decl := Declaration_Node (Subp_Id);
27431          Spec_Id   := Unique_Defining_Entity (Subp_Decl);
27432       end if;
27433 
27434       --  When processing an entry, subprogram or task body, look for pragmas
27435       --  Refined_Depends and Refined_Global as they specify the inputs and
27436       --  outputs.
27437 
27438       if Is_Entry_Body (Subp_Id)
27439         or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body)
27440       then
27441          Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends);
27442          Global  := Get_Pragma (Subp_Id, Pragma_Refined_Global);
27443 
27444       --  Subprogram declaration or stand alone body case, look for pragmas
27445       --  Depends and Global
27446 
27447       else
27448          Depends := Get_Pragma (Spec_Id, Pragma_Depends);
27449          Global  := Get_Pragma (Spec_Id, Pragma_Global);
27450       end if;
27451 
27452       --  Pragma [Refined_]Global takes precedence over [Refined_]Depends
27453       --  because it provides finer granularity of inputs and outputs.
27454 
27455       if Present (Global) then
27456          Global_Seen := True;
27457          Collect_Global_List (Expression (Get_Argument (Global, Spec_Id)));
27458 
27459       --  When the related subprogram lacks pragma [Refined_]Global, fall back
27460       --  to [Refined_]Depends if the caller requests this behavior. Synthesize
27461       --  the inputs and outputs from [Refined_]Depends.
27462 
27463       elsif Synthesize and then Present (Depends) then
27464          Clauses := Expression (Get_Argument (Depends, Spec_Id));
27465 
27466          --  Multiple dependency clauses appear as an aggregate
27467 
27468          if Nkind (Clauses) = N_Aggregate then
27469             Clause := First (Component_Associations (Clauses));
27470             while Present (Clause) loop
27471                Collect_Dependency_Clause (Clause);
27472                Next (Clause);
27473             end loop;
27474 
27475          --  Otherwise this is a single dependency clause
27476 
27477          else
27478             Collect_Dependency_Clause (Clauses);
27479          end if;
27480       end if;
27481 
27482       --  The current instance of a protected type acts as a formal parameter
27483       --  of mode IN for functions and IN OUT for entries and procedures
27484       --  (SPARK RM 6.1.4).
27485 
27486       if Ekind (Scope (Spec_Id)) = E_Protected_Type then
27487          Typ := Scope (Spec_Id);
27488 
27489          --  Use the anonymous object when the type is single protected
27490 
27491          if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
27492             Typ := Anonymous_Object (Typ);
27493          end if;
27494 
27495          Append_New_Elmt (Typ, Subp_Inputs);
27496 
27497          if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then
27498             Append_New_Elmt (Typ, Subp_Outputs);
27499          end if;
27500 
27501       --  The current instance of a task type acts as a formal parameter of
27502       --  mode IN OUT (SPARK RM 6.1.4).
27503 
27504       elsif Ekind (Spec_Id) = E_Task_Type then
27505          Typ := Spec_Id;
27506 
27507          --  Use the anonymous object when the type is single task
27508 
27509          if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then
27510             Typ := Anonymous_Object (Typ);
27511          end if;
27512 
27513          Append_New_Elmt (Typ, Subp_Inputs);
27514          Append_New_Elmt (Typ, Subp_Outputs);
27515 
27516       elsif Is_Single_Task_Object (Spec_Id) then
27517          Append_New_Elmt (Spec_Id, Subp_Inputs);
27518          Append_New_Elmt (Spec_Id, Subp_Outputs);
27519       end if;
27520    end Collect_Subprogram_Inputs_Outputs;
27521 
27522    ---------------------------
27523    -- Contract_Freeze_Error --
27524    ---------------------------
27525 
27526    procedure Contract_Freeze_Error
27527      (Contract_Id : Entity_Id;
27528       Freeze_Id   : Entity_Id)
27529    is
27530    begin
27531       Error_Msg_Name_1 := Chars (Contract_Id);
27532       Error_Msg_Sloc   := Sloc (Freeze_Id);
27533 
27534       SPARK_Msg_NE
27535         ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id);
27536       SPARK_Msg_N
27537         ("\all contractual items must be declared before body #", Contract_Id);
27538    end Contract_Freeze_Error;
27539 
27540    ---------------------------------
27541    -- Delay_Config_Pragma_Analyze --
27542    ---------------------------------
27543 
27544    function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
27545    begin
27546       return Nam_In (Pragma_Name (N), Name_Interrupt_State,
27547                                       Name_Priority_Specific_Dispatching);
27548    end Delay_Config_Pragma_Analyze;
27549 
27550    -----------------------
27551    -- Duplication_Error --
27552    -----------------------
27553 
27554    procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is
27555       Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag);
27556       Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev);
27557 
27558    begin
27559       Error_Msg_Sloc   := Sloc (Prev);
27560       Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
27561 
27562       --  Emit a precise message to distinguish between source pragmas and
27563       --  pragmas generated from aspects. The ordering of the two pragmas is
27564       --  the following:
27565 
27566       --    Prev  --  ok
27567       --    Prag  --  duplicate
27568 
27569       --  No error is emitted when both pragmas come from aspects because this
27570       --  is already detected by the general aspect analysis mechanism.
27571 
27572       if Prag_From_Asp and Prev_From_Asp then
27573          null;
27574       elsif Prag_From_Asp then
27575          Error_Msg_N ("aspect % duplicates pragma declared #", Prag);
27576       elsif Prev_From_Asp then
27577          Error_Msg_N ("pragma % duplicates aspect declared #", Prag);
27578       else
27579          Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
27580       end if;
27581    end Duplication_Error;
27582 
27583    -----------------
27584    -- Entity_Hash --
27585    -----------------
27586 
27587    function Entity_Hash (E : Entity_Id) return Num_Primitives is
27588    begin
27589       return Num_Primitives (E mod 511);
27590    end Entity_Hash;
27591 
27592    --------------------------
27593    -- Find_Related_Context --
27594    --------------------------
27595 
27596    function Find_Related_Context
27597      (Prag      : Node_Id;
27598       Do_Checks : Boolean := False) return Node_Id
27599    is
27600       Stmt : Node_Id;
27601 
27602    begin
27603       Stmt := Prev (Prag);
27604       while Present (Stmt) loop
27605 
27606          --  Skip prior pragmas, but check for duplicates
27607 
27608          if Nkind (Stmt) = N_Pragma then
27609             if Do_Checks and then Pragma_Name (Stmt) = Pragma_Name (Prag) then
27610                Duplication_Error
27611                  (Prag => Prag,
27612                   Prev => Stmt);
27613             end if;
27614 
27615          --  Skip internally generated code
27616 
27617          elsif not Comes_From_Source (Stmt) then
27618 
27619             --  The anonymous object created for a single concurrent type is a
27620             --  suitable context.
27621 
27622             if Nkind (Stmt) = N_Object_Declaration
27623               and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
27624             then
27625                return Stmt;
27626             end if;
27627 
27628          --  Return the current source construct
27629 
27630          else
27631             return Stmt;
27632          end if;
27633 
27634          Prev (Stmt);
27635       end loop;
27636 
27637       return Empty;
27638    end Find_Related_Context;
27639 
27640    --------------------------------------
27641    -- Find_Related_Declaration_Or_Body --
27642    --------------------------------------
27643 
27644    function Find_Related_Declaration_Or_Body
27645      (Prag      : Node_Id;
27646       Do_Checks : Boolean := False) return Node_Id
27647    is
27648       Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
27649 
27650       procedure Expression_Function_Error;
27651       --  Emit an error concerning pragma Prag that illegaly applies to an
27652       --  expression function.
27653 
27654       -------------------------------
27655       -- Expression_Function_Error --
27656       -------------------------------
27657 
27658       procedure Expression_Function_Error is
27659       begin
27660          Error_Msg_Name_1 := Prag_Nam;
27661 
27662          --  Emit a precise message to distinguish between source pragmas and
27663          --  pragmas generated from aspects.
27664 
27665          if From_Aspect_Specification (Prag) then
27666             Error_Msg_N
27667               ("aspect % cannot apply to a stand alone expression function",
27668                Prag);
27669          else
27670             Error_Msg_N
27671               ("pragma % cannot apply to a stand alone expression function",
27672                Prag);
27673          end if;
27674       end Expression_Function_Error;
27675 
27676       --  Local variables
27677 
27678       Context : constant Node_Id := Parent (Prag);
27679       Stmt    : Node_Id;
27680 
27681       Look_For_Body : constant Boolean :=
27682                         Nam_In (Prag_Nam, Name_Refined_Depends,
27683                                           Name_Refined_Global,
27684                                           Name_Refined_Post);
27685       --  Refinement pragmas must be associated with a subprogram body [stub]
27686 
27687    --  Start of processing for Find_Related_Declaration_Or_Body
27688 
27689    begin
27690       Stmt := Prev (Prag);
27691       while Present (Stmt) loop
27692 
27693          --  Skip prior pragmas, but check for duplicates. Pragmas produced
27694          --  by splitting a complex pre/postcondition are not considered to
27695          --  be duplicates.
27696 
27697          if Nkind (Stmt) = N_Pragma then
27698             if Do_Checks
27699               and then not Split_PPC (Stmt)
27700               and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam
27701             then
27702                Duplication_Error
27703                  (Prag => Prag,
27704                   Prev => Stmt);
27705             end if;
27706 
27707          --  Emit an error when a refinement pragma appears on an expression
27708          --  function without a completion.
27709 
27710          elsif Do_Checks
27711            and then Look_For_Body
27712            and then Nkind (Stmt) = N_Subprogram_Declaration
27713            and then Nkind (Original_Node (Stmt)) = N_Expression_Function
27714            and then not Has_Completion (Defining_Entity (Stmt))
27715          then
27716             Expression_Function_Error;
27717             return Empty;
27718 
27719          --  The refinement pragma applies to a subprogram body stub
27720 
27721          elsif Look_For_Body
27722            and then Nkind (Stmt) = N_Subprogram_Body_Stub
27723          then
27724             return Stmt;
27725 
27726          --  Skip internally generated code
27727 
27728          elsif not Comes_From_Source (Stmt) then
27729 
27730             --  The anonymous object created for a single concurrent type is a
27731             --  suitable context.
27732 
27733             if Nkind (Stmt) = N_Object_Declaration
27734               and then Is_Single_Concurrent_Object (Defining_Entity (Stmt))
27735             then
27736                return Stmt;
27737 
27738             elsif Nkind (Stmt) = N_Subprogram_Declaration then
27739 
27740                --  The subprogram declaration is an internally generated spec
27741                --  for an expression function.
27742 
27743                if Nkind (Original_Node (Stmt)) = N_Expression_Function then
27744                   return Stmt;
27745 
27746                --  The subprogram is actually an instance housed within an
27747                --  anonymous wrapper package.
27748 
27749                elsif Present (Generic_Parent (Specification (Stmt))) then
27750                   return Stmt;
27751                end if;
27752             end if;
27753 
27754          --  Return the current construct which is either a subprogram body,
27755          --  a subprogram declaration or is illegal.
27756 
27757          else
27758             return Stmt;
27759          end if;
27760 
27761          Prev (Stmt);
27762       end loop;
27763 
27764       --  If we fall through, then the pragma was either the first declaration
27765       --  or it was preceded by other pragmas and no source constructs.
27766 
27767       --  The pragma is associated with a library-level subprogram
27768 
27769       if Nkind (Context) = N_Compilation_Unit_Aux then
27770          return Unit (Parent (Context));
27771 
27772       --  The pragma appears inside the declarations of an entry body
27773 
27774       elsif Nkind (Context) = N_Entry_Body then
27775          return Context;
27776 
27777       --  The pragma appears inside the statements of a subprogram body. This
27778       --  placement is the result of subprogram contract expansion.
27779 
27780       elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
27781          return Parent (Context);
27782 
27783       --  The pragma appears inside the declarative part of a subprogram body
27784 
27785       elsif Nkind (Context) = N_Subprogram_Body then
27786          return Context;
27787 
27788       --  The pragma appears inside the declarative part of a task body
27789 
27790       elsif Nkind (Context) = N_Task_Body then
27791          return Context;
27792 
27793       --  The pragma is a byproduct of aspect expansion, return the related
27794       --  context of the original aspect. This case has a lower priority as
27795       --  the above circuitry pinpoints precisely the related context.
27796 
27797       elsif Present (Corresponding_Aspect (Prag)) then
27798          return Parent (Corresponding_Aspect (Prag));
27799 
27800       --  No candidate subprogram [body] found
27801 
27802       else
27803          return Empty;
27804       end if;
27805    end Find_Related_Declaration_Or_Body;
27806 
27807    ----------------------------------
27808    -- Find_Related_Package_Or_Body --
27809    ----------------------------------
27810 
27811    function Find_Related_Package_Or_Body
27812      (Prag      : Node_Id;
27813       Do_Checks : Boolean := False) return Node_Id
27814    is
27815       Context  : constant Node_Id := Parent (Prag);
27816       Prag_Nam : constant Name_Id := Pragma_Name (Prag);
27817       Stmt     : Node_Id;
27818 
27819    begin
27820       Stmt := Prev (Prag);
27821       while Present (Stmt) loop
27822 
27823          --  Skip prior pragmas, but check for duplicates
27824 
27825          if Nkind (Stmt) = N_Pragma then
27826             if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then
27827                Duplication_Error
27828                  (Prag => Prag,
27829                   Prev => Stmt);
27830             end if;
27831 
27832          --  Skip internally generated code
27833 
27834          elsif not Comes_From_Source (Stmt) then
27835             if Nkind (Stmt) = N_Subprogram_Declaration then
27836 
27837                --  The subprogram declaration is an internally generated spec
27838                --  for an expression function.
27839 
27840                if Nkind (Original_Node (Stmt)) = N_Expression_Function then
27841                   return Stmt;
27842 
27843                --  The subprogram is actually an instance housed within an
27844                --  anonymous wrapper package.
27845 
27846                elsif Present (Generic_Parent (Specification (Stmt))) then
27847                   return Stmt;
27848                end if;
27849             end if;
27850 
27851          --  Return the current source construct which is illegal
27852 
27853          else
27854             return Stmt;
27855          end if;
27856 
27857          Prev (Stmt);
27858       end loop;
27859 
27860       --  If we fall through, then the pragma was either the first declaration
27861       --  or it was preceded by other pragmas and no source constructs.
27862 
27863       --  The pragma is associated with a package. The immediate context in
27864       --  this case is the specification of the package.
27865 
27866       if Nkind (Context) = N_Package_Specification then
27867          return Parent (Context);
27868 
27869       --  The pragma appears in the declarations of a package body
27870 
27871       elsif Nkind (Context) = N_Package_Body then
27872          return Context;
27873 
27874       --  The pragma appears in the statements of a package body
27875 
27876       elsif Nkind (Context) = N_Handled_Sequence_Of_Statements
27877         and then Nkind (Parent (Context)) = N_Package_Body
27878       then
27879          return Parent (Context);
27880 
27881       --  The pragma is a byproduct of aspect expansion, return the related
27882       --  context of the original aspect. This case has a lower priority as
27883       --  the above circuitry pinpoints precisely the related context.
27884 
27885       elsif Present (Corresponding_Aspect (Prag)) then
27886          return Parent (Corresponding_Aspect (Prag));
27887 
27888       --  No candidate packge [body] found
27889 
27890       else
27891          return Empty;
27892       end if;
27893    end Find_Related_Package_Or_Body;
27894 
27895    ------------------
27896    -- Get_Argument --
27897    ------------------
27898 
27899    function Get_Argument
27900      (Prag       : Node_Id;
27901       Context_Id : Entity_Id := Empty) return Node_Id
27902    is
27903       Args : constant List_Id := Pragma_Argument_Associations (Prag);
27904 
27905    begin
27906       --  Use the expression of the original aspect when compiling for ASIS or
27907       --  when analyzing the template of a generic unit. In both cases the
27908       --  aspect's tree must be decorated to allow for ASIS queries or to save
27909       --  the global references in the generic context.
27910 
27911       if From_Aspect_Specification (Prag)
27912         and then (ASIS_Mode or else (Present (Context_Id)
27913                                       and then Is_Generic_Unit (Context_Id)))
27914       then
27915          return Corresponding_Aspect (Prag);
27916 
27917       --  Otherwise use the expression of the pragma
27918 
27919       elsif Present (Args) then
27920          return First (Args);
27921 
27922       else
27923          return Empty;
27924       end if;
27925    end Get_Argument;
27926 
27927    -------------------------
27928    -- Get_Base_Subprogram --
27929    -------------------------
27930 
27931    function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
27932       Result : Entity_Id;
27933 
27934    begin
27935       --  Follow subprogram renaming chain
27936 
27937       Result := Def_Id;
27938 
27939       if Is_Subprogram (Result)
27940         and then
27941           Nkind (Parent (Declaration_Node (Result))) =
27942                                          N_Subprogram_Renaming_Declaration
27943         and then Present (Alias (Result))
27944       then
27945          Result := Alias (Result);
27946       end if;
27947 
27948       return Result;
27949    end Get_Base_Subprogram;
27950 
27951    -----------------------
27952    -- Get_SPARK_Mode_Type --
27953    -----------------------
27954 
27955    function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is
27956    begin
27957       if N = Name_On then
27958          return On;
27959       elsif N = Name_Off then
27960          return Off;
27961 
27962       --  Any other argument is illegal
27963 
27964       else
27965          raise Program_Error;
27966       end if;
27967    end Get_SPARK_Mode_Type;
27968 
27969    ------------------------------------
27970    -- Get_SPARK_Mode_From_Annotation --
27971    ------------------------------------
27972 
27973    function Get_SPARK_Mode_From_Annotation
27974      (N : Node_Id) return SPARK_Mode_Type
27975    is
27976       Mode : Node_Id;
27977 
27978    begin
27979       if Nkind (N) = N_Aspect_Specification then
27980          Mode := Expression (N);
27981 
27982       else pragma Assert (Nkind (N) = N_Pragma);
27983          Mode := First (Pragma_Argument_Associations (N));
27984 
27985          if Present (Mode) then
27986             Mode := Get_Pragma_Arg (Mode);
27987          end if;
27988       end if;
27989 
27990       --  Aspect or pragma SPARK_Mode specifies an explicit mode
27991 
27992       if Present (Mode) then
27993          if Nkind (Mode) = N_Identifier then
27994             return Get_SPARK_Mode_Type (Chars (Mode));
27995 
27996          --  In case of a malformed aspect or pragma, return the default None
27997 
27998          else
27999             return None;
28000          end if;
28001 
28002       --  Otherwise the lack of an expression defaults SPARK_Mode to On
28003 
28004       else
28005          return On;
28006       end if;
28007    end Get_SPARK_Mode_From_Annotation;
28008 
28009    ---------------------------
28010    -- Has_Extra_Parentheses --
28011    ---------------------------
28012 
28013    function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is
28014       Expr : Node_Id;
28015 
28016    begin
28017       --  The aggregate should not have an expression list because a clause
28018       --  is always interpreted as a component association. The only way an
28019       --  expression list can sneak in is by adding extra parentheses around
28020       --  the individual clauses:
28021 
28022       --    Depends  (Output => Input)   --  proper form
28023       --    Depends ((Output => Input))  --  extra parentheses
28024 
28025       --  Since the extra parentheses are not allowed by the syntax of the
28026       --  pragma, flag them now to avoid emitting misleading errors down the
28027       --  line.
28028 
28029       if Nkind (Clause) = N_Aggregate
28030         and then Present (Expressions (Clause))
28031       then
28032          Expr := First (Expressions (Clause));
28033          while Present (Expr) loop
28034 
28035             --  A dependency clause surrounded by extra parentheses appears
28036             --  as an aggregate of component associations with an optional
28037             --  Paren_Count set.
28038 
28039             if Nkind (Expr) = N_Aggregate
28040               and then Present (Component_Associations (Expr))
28041             then
28042                SPARK_Msg_N
28043                  ("dependency clause contains extra parentheses", Expr);
28044 
28045             --  Otherwise the expression is a malformed construct
28046 
28047             else
28048                SPARK_Msg_N ("malformed dependency clause", Expr);
28049             end if;
28050 
28051             Next (Expr);
28052          end loop;
28053 
28054          return True;
28055       end if;
28056 
28057       return False;
28058    end Has_Extra_Parentheses;
28059 
28060    ----------------
28061    -- Initialize --
28062    ----------------
28063 
28064    procedure Initialize is
28065    begin
28066       Externals.Init;
28067    end Initialize;
28068 
28069    --------
28070    -- ip --
28071    --------
28072 
28073    procedure ip is
28074    begin
28075       Dummy := Dummy + 1;
28076    end ip;
28077 
28078    -----------------------------
28079    -- Is_Config_Static_String --
28080    -----------------------------
28081 
28082    function Is_Config_Static_String (Arg : Node_Id) return Boolean is
28083 
28084       function Add_Config_Static_String (Arg : Node_Id) return Boolean;
28085       --  This is an internal recursive function that is just like the outer
28086       --  function except that it adds the string to the name buffer rather
28087       --  than placing the string in the name buffer.
28088 
28089       ------------------------------
28090       -- Add_Config_Static_String --
28091       ------------------------------
28092 
28093       function Add_Config_Static_String (Arg : Node_Id) return Boolean is
28094          N : Node_Id;
28095          C : Char_Code;
28096 
28097       begin
28098          N := Arg;
28099 
28100          if Nkind (N) = N_Op_Concat then
28101             if Add_Config_Static_String (Left_Opnd (N)) then
28102                N := Right_Opnd (N);
28103             else
28104                return False;
28105             end if;
28106          end if;
28107 
28108          if Nkind (N) /= N_String_Literal then
28109             Error_Msg_N ("string literal expected for pragma argument", N);
28110             return False;
28111 
28112          else
28113             for J in 1 .. String_Length (Strval (N)) loop
28114                C := Get_String_Char (Strval (N), J);
28115 
28116                if not In_Character_Range (C) then
28117                   Error_Msg
28118                     ("string literal contains invalid wide character",
28119                      Sloc (N) + 1 + Source_Ptr (J));
28120                   return False;
28121                end if;
28122 
28123                Add_Char_To_Name_Buffer (Get_Character (C));
28124             end loop;
28125          end if;
28126 
28127          return True;
28128       end Add_Config_Static_String;
28129 
28130    --  Start of processing for Is_Config_Static_String
28131 
28132    begin
28133       Name_Len := 0;
28134 
28135       return Add_Config_Static_String (Arg);
28136    end Is_Config_Static_String;
28137 
28138    ---------------------
28139    -- Is_CCT_Instance --
28140    ---------------------
28141 
28142    function Is_CCT_Instance
28143      (Ref_Id     : Entity_Id;
28144       Context_Id : Entity_Id) return Boolean
28145    is
28146       S   : Entity_Id;
28147       Typ : Entity_Id;
28148 
28149    begin
28150       --  When the reference denotes a single protected type, the context is
28151       --  either a protected subprogram or its body.
28152 
28153       if Is_Single_Protected_Object (Ref_Id) then
28154          Typ := Scope (Context_Id);
28155 
28156          return
28157            Ekind (Typ) = E_Protected_Type
28158              and then Present (Anonymous_Object (Typ))
28159              and then Anonymous_Object (Typ) = Ref_Id;
28160 
28161       --  When the reference denotes a single task type, the context is either
28162       --  the same type or if inside the body, the anonymous task type.
28163 
28164       elsif Is_Single_Task_Object (Ref_Id) then
28165          if Ekind (Context_Id) = E_Task_Type then
28166             return
28167               Present (Anonymous_Object (Context_Id))
28168                 and then Anonymous_Object (Context_Id) = Ref_Id;
28169          else
28170             return Ref_Id = Context_Id;
28171          end if;
28172 
28173       --  Otherwise the reference denotes a protected or a task type. Climb the
28174       --  scope chain looking for an enclosing concurrent type that matches the
28175       --  referenced entity.
28176 
28177       else
28178          pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
28179 
28180          S := Current_Scope;
28181          while Present (S) and then S /= Standard_Standard loop
28182             if Ekind_In (S, E_Protected_Type, E_Task_Type)
28183               and then S = Ref_Id
28184             then
28185                return True;
28186             end if;
28187 
28188             S := Scope (S);
28189          end loop;
28190       end if;
28191 
28192       return False;
28193    end Is_CCT_Instance;
28194 
28195    -------------------------------
28196    -- Is_Elaboration_SPARK_Mode --
28197    -------------------------------
28198 
28199    function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is
28200    begin
28201       pragma Assert
28202         (Nkind (N) = N_Pragma
28203           and then Pragma_Name (N) = Name_SPARK_Mode
28204           and then Is_List_Member (N));
28205 
28206       --  Pragma SPARK_Mode affects the elaboration of a package body when it
28207       --  appears in the statement part of the body.
28208 
28209       return
28210          Present (Parent (N))
28211            and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
28212            and then List_Containing (N) = Statements (Parent (N))
28213            and then Present (Parent (Parent (N)))
28214            and then Nkind (Parent (Parent (N))) = N_Package_Body;
28215    end Is_Elaboration_SPARK_Mode;
28216 
28217    -----------------------
28218    -- Is_Enabled_Pragma --
28219    -----------------------
28220 
28221    function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is
28222       Arg : Node_Id;
28223 
28224    begin
28225       if Present (Prag) then
28226          Arg := First (Pragma_Argument_Associations (Prag));
28227 
28228          if Present (Arg) then
28229             return Is_True (Expr_Value (Get_Pragma_Arg (Arg)));
28230 
28231          --  The lack of a Boolean argument automatically enables the pragma
28232 
28233          else
28234             return True;
28235          end if;
28236 
28237       --  The pragma is missing, therefore it is not enabled
28238 
28239       else
28240          return False;
28241       end if;
28242    end Is_Enabled_Pragma;
28243 
28244    -----------------------------------------
28245    -- Is_Non_Significant_Pragma_Reference --
28246    -----------------------------------------
28247 
28248    --  This function makes use of the following static table which indicates
28249    --  whether appearance of some name in a given pragma is to be considered
28250    --  as a reference for the purposes of warnings about unreferenced objects.
28251 
28252    --  -1  indicates that appearence in any argument is significant
28253    --  0   indicates that appearance in any argument is not significant
28254    --  +n  indicates that appearance as argument n is significant, but all
28255    --      other arguments are not significant
28256    --  9n  arguments from n on are significant, before n insignificant
28257 
28258    Sig_Flags : constant array (Pragma_Id) of Int :=
28259      (Pragma_Abort_Defer                    => -1,
28260       Pragma_Abstract_State                 => -1,
28261       Pragma_Ada_83                         => -1,
28262       Pragma_Ada_95                         => -1,
28263       Pragma_Ada_05                         => -1,
28264       Pragma_Ada_2005                       => -1,
28265       Pragma_Ada_12                         => -1,
28266       Pragma_Ada_2012                       => -1,
28267       Pragma_All_Calls_Remote               => -1,
28268       Pragma_Allow_Integer_Address          => -1,
28269       Pragma_Annotate                       => 93,
28270       Pragma_Assert                         => -1,
28271       Pragma_Assert_And_Cut                 => -1,
28272       Pragma_Assertion_Policy               =>  0,
28273       Pragma_Assume                         => -1,
28274       Pragma_Assume_No_Invalid_Values       =>  0,
28275       Pragma_Async_Readers                  =>  0,
28276       Pragma_Async_Writers                  =>  0,
28277       Pragma_Asynchronous                   =>  0,
28278       Pragma_Atomic                         =>  0,
28279       Pragma_Atomic_Components              =>  0,
28280       Pragma_Attach_Handler                 => -1,
28281       Pragma_Attribute_Definition           => 92,
28282       Pragma_Check                          => -1,
28283       Pragma_Check_Float_Overflow           =>  0,
28284       Pragma_Check_Name                     =>  0,
28285       Pragma_Check_Policy                   =>  0,
28286       Pragma_CPP_Class                      =>  0,
28287       Pragma_CPP_Constructor                =>  0,
28288       Pragma_CPP_Virtual                    =>  0,
28289       Pragma_CPP_Vtable                     =>  0,
28290       Pragma_CPU                            => -1,
28291       Pragma_C_Pass_By_Copy                 =>  0,
28292       Pragma_Comment                        => -1,
28293       Pragma_Common_Object                  =>  0,
28294       Pragma_Compile_Time_Error             => -1,
28295       Pragma_Compile_Time_Warning           => -1,
28296       Pragma_Compiler_Unit                  => -1,
28297       Pragma_Compiler_Unit_Warning          => -1,
28298       Pragma_Complete_Representation        =>  0,
28299       Pragma_Complex_Representation         =>  0,
28300       Pragma_Component_Alignment            =>  0,
28301       Pragma_Constant_After_Elaboration     =>  0,
28302       Pragma_Contract_Cases                 => -1,
28303       Pragma_Controlled                     =>  0,
28304       Pragma_Convention                     =>  0,
28305       Pragma_Convention_Identifier          =>  0,
28306       Pragma_Debug                          => -1,
28307       Pragma_Debug_Policy                   =>  0,
28308       Pragma_Detect_Blocking                =>  0,
28309       Pragma_Default_Initial_Condition      => -1,
28310       Pragma_Default_Scalar_Storage_Order   =>  0,
28311       Pragma_Default_Storage_Pool           =>  0,
28312       Pragma_Depends                        => -1,
28313       Pragma_Disable_Atomic_Synchronization =>  0,
28314       Pragma_Discard_Names                  =>  0,
28315       Pragma_Dispatching_Domain             => -1,
28316       Pragma_Effective_Reads                =>  0,
28317       Pragma_Effective_Writes               =>  0,
28318       Pragma_Elaborate                      =>  0,
28319       Pragma_Elaborate_All                  =>  0,
28320       Pragma_Elaborate_Body                 =>  0,
28321       Pragma_Elaboration_Checks             =>  0,
28322       Pragma_Eliminate                      =>  0,
28323       Pragma_Enable_Atomic_Synchronization  =>  0,
28324       Pragma_Export                         => -1,
28325       Pragma_Export_Function                => -1,
28326       Pragma_Export_Object                  => -1,
28327       Pragma_Export_Procedure               => -1,
28328       Pragma_Export_Value                   => -1,
28329       Pragma_Export_Valued_Procedure        => -1,
28330       Pragma_Extend_System                  => -1,
28331       Pragma_Extensions_Allowed             =>  0,
28332       Pragma_Extensions_Visible             =>  0,
28333       Pragma_External                       => -1,
28334       Pragma_Favor_Top_Level                =>  0,
28335       Pragma_External_Name_Casing           =>  0,
28336       Pragma_Fast_Math                      =>  0,
28337       Pragma_Finalize_Storage_Only          =>  0,
28338       Pragma_Ghost                          =>  0,
28339       Pragma_Global                         => -1,
28340       Pragma_Ident                          => -1,
28341       Pragma_Ignore_Pragma                  =>  0,
28342       Pragma_Implementation_Defined         => -1,
28343       Pragma_Implemented                    => -1,
28344       Pragma_Implicit_Packing               =>  0,
28345       Pragma_Import                         => 93,
28346       Pragma_Import_Function                =>  0,
28347       Pragma_Import_Object                  =>  0,
28348       Pragma_Import_Procedure               =>  0,
28349       Pragma_Import_Valued_Procedure        =>  0,
28350       Pragma_Independent                    =>  0,
28351       Pragma_Independent_Components         =>  0,
28352       Pragma_Initial_Condition              => -1,
28353       Pragma_Initialize_Scalars             =>  0,
28354       Pragma_Initializes                    => -1,
28355       Pragma_Inline                         =>  0,
28356       Pragma_Inline_Always                  =>  0,
28357       Pragma_Inline_Generic                 =>  0,
28358       Pragma_Inspection_Point               => -1,
28359       Pragma_Interface                      => 92,
28360       Pragma_Interface_Name                 =>  0,
28361       Pragma_Interrupt_Handler              => -1,
28362       Pragma_Interrupt_Priority             => -1,
28363       Pragma_Interrupt_State                => -1,
28364       Pragma_Invariant                      => -1,
28365       Pragma_Keep_Names                     =>  0,
28366       Pragma_License                        =>  0,
28367       Pragma_Link_With                      => -1,
28368       Pragma_Linker_Alias                   => -1,
28369       Pragma_Linker_Constructor             => -1,
28370       Pragma_Linker_Destructor              => -1,
28371       Pragma_Linker_Options                 => -1,
28372       Pragma_Linker_Section                 =>  0,
28373       Pragma_List                           =>  0,
28374       Pragma_Lock_Free                      =>  0,
28375       Pragma_Locking_Policy                 =>  0,
28376       Pragma_Loop_Invariant                 => -1,
28377       Pragma_Loop_Optimize                  =>  0,
28378       Pragma_Loop_Variant                   => -1,
28379       Pragma_Machine_Attribute              => -1,
28380       Pragma_Main                           => -1,
28381       Pragma_Main_Storage                   => -1,
28382       Pragma_Memory_Size                    =>  0,
28383       Pragma_No_Return                      =>  0,
28384       Pragma_No_Body                        =>  0,
28385       Pragma_No_Elaboration_Code_All        =>  0,
28386       Pragma_No_Inline                      =>  0,
28387       Pragma_No_Run_Time                    => -1,
28388       Pragma_No_Strict_Aliasing             => -1,
28389       Pragma_No_Tagged_Streams              =>  0,
28390       Pragma_Normalize_Scalars              =>  0,
28391       Pragma_Obsolescent                    =>  0,
28392       Pragma_Optimize                       =>  0,
28393       Pragma_Optimize_Alignment             =>  0,
28394       Pragma_Overflow_Mode                  =>  0,
28395       Pragma_Overriding_Renamings           =>  0,
28396       Pragma_Ordered                        =>  0,
28397       Pragma_Pack                           =>  0,
28398       Pragma_Page                           =>  0,
28399       Pragma_Part_Of                        =>  0,
28400       Pragma_Partition_Elaboration_Policy   =>  0,
28401       Pragma_Passive                        =>  0,
28402       Pragma_Persistent_BSS                 =>  0,
28403       Pragma_Polling                        =>  0,
28404       Pragma_Prefix_Exception_Messages      =>  0,
28405       Pragma_Post                           => -1,
28406       Pragma_Postcondition                  => -1,
28407       Pragma_Post_Class                     => -1,
28408       Pragma_Pre                            => -1,
28409       Pragma_Precondition                   => -1,
28410       Pragma_Predicate                      => -1,
28411       Pragma_Predicate_Failure              => -1,
28412       Pragma_Preelaborable_Initialization   => -1,
28413       Pragma_Preelaborate                   =>  0,
28414       Pragma_Pre_Class                      => -1,
28415       Pragma_Priority                       => -1,
28416       Pragma_Priority_Specific_Dispatching  =>  0,
28417       Pragma_Profile                        =>  0,
28418       Pragma_Profile_Warnings               =>  0,
28419       Pragma_Propagate_Exceptions           =>  0,
28420       Pragma_Provide_Shift_Operators        =>  0,
28421       Pragma_Psect_Object                   =>  0,
28422       Pragma_Pure                           =>  0,
28423       Pragma_Pure_Function                  =>  0,
28424       Pragma_Queuing_Policy                 =>  0,
28425       Pragma_Rational                       =>  0,
28426       Pragma_Ravenscar                      =>  0,
28427       Pragma_Refined_Depends                => -1,
28428       Pragma_Refined_Global                 => -1,
28429       Pragma_Refined_Post                   => -1,
28430       Pragma_Refined_State                  => -1,
28431       Pragma_Relative_Deadline              =>  0,
28432       Pragma_Remote_Access_Type             => -1,
28433       Pragma_Remote_Call_Interface          => -1,
28434       Pragma_Remote_Types                   => -1,
28435       Pragma_Restricted_Run_Time            =>  0,
28436       Pragma_Restriction_Warnings           =>  0,
28437       Pragma_Restrictions                   =>  0,
28438       Pragma_Reviewable                     => -1,
28439       Pragma_Short_Circuit_And_Or           =>  0,
28440       Pragma_Share_Generic                  =>  0,
28441       Pragma_Shared                         =>  0,
28442       Pragma_Shared_Passive                 =>  0,
28443       Pragma_Short_Descriptors              =>  0,
28444       Pragma_Simple_Storage_Pool_Type       =>  0,
28445       Pragma_Source_File_Name               =>  0,
28446       Pragma_Source_File_Name_Project       =>  0,
28447       Pragma_Source_Reference               =>  0,
28448       Pragma_SPARK_Mode                     =>  0,
28449       Pragma_Storage_Size                   => -1,
28450       Pragma_Storage_Unit                   =>  0,
28451       Pragma_Static_Elaboration_Desired     =>  0,
28452       Pragma_Stream_Convert                 =>  0,
28453       Pragma_Style_Checks                   =>  0,
28454       Pragma_Subtitle                       =>  0,
28455       Pragma_Suppress                       =>  0,
28456       Pragma_Suppress_Exception_Locations   =>  0,
28457       Pragma_Suppress_All                   =>  0,
28458       Pragma_Suppress_Debug_Info            =>  0,
28459       Pragma_Suppress_Initialization        =>  0,
28460       Pragma_System_Name                    =>  0,
28461       Pragma_Task_Dispatching_Policy        =>  0,
28462       Pragma_Task_Info                      => -1,
28463       Pragma_Task_Name                      => -1,
28464       Pragma_Task_Storage                   => -1,
28465       Pragma_Test_Case                      => -1,
28466       Pragma_Thread_Local_Storage           => -1,
28467       Pragma_Time_Slice                     => -1,
28468       Pragma_Title                          =>  0,
28469       Pragma_Type_Invariant                 => -1,
28470       Pragma_Type_Invariant_Class           => -1,
28471       Pragma_Unchecked_Union                =>  0,
28472       Pragma_Unevaluated_Use_Of_Old         =>  0,
28473       Pragma_Unimplemented_Unit             =>  0,
28474       Pragma_Universal_Aliasing             =>  0,
28475       Pragma_Universal_Data                 =>  0,
28476       Pragma_Unmodified                     =>  0,
28477       Pragma_Unreferenced                   =>  0,
28478       Pragma_Unreferenced_Objects           =>  0,
28479       Pragma_Unreserve_All_Interrupts       =>  0,
28480       Pragma_Unsuppress                     =>  0,
28481       Pragma_Unused                         =>  0,
28482       Pragma_Use_VADS_Size                  =>  0,
28483       Pragma_Validity_Checks                =>  0,
28484       Pragma_Volatile                       =>  0,
28485       Pragma_Volatile_Components            =>  0,
28486       Pragma_Volatile_Full_Access           =>  0,
28487       Pragma_Volatile_Function              =>  0,
28488       Pragma_Warning_As_Error               =>  0,
28489       Pragma_Warnings                       =>  0,
28490       Pragma_Weak_External                  =>  0,
28491       Pragma_Wide_Character_Encoding        =>  0,
28492       Unknown_Pragma                        =>  0);
28493 
28494    function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
28495       Id : Pragma_Id;
28496       P  : Node_Id;
28497       C  : Int;
28498       AN : Nat;
28499 
28500       function Arg_No return Nat;
28501       --  Returns an integer showing what argument we are in. A value of
28502       --  zero means we are not in any of the arguments.
28503 
28504       ------------
28505       -- Arg_No --
28506       ------------
28507 
28508       function Arg_No return Nat is
28509          A : Node_Id;
28510          N : Nat;
28511 
28512       begin
28513          A := First (Pragma_Argument_Associations (Parent (P)));
28514          N := 1;
28515          loop
28516             if No (A) then
28517                return 0;
28518             elsif A = P then
28519                return N;
28520             end if;
28521 
28522             Next (A);
28523             N := N + 1;
28524          end loop;
28525       end Arg_No;
28526 
28527    --  Start of processing for Non_Significant_Pragma_Reference
28528 
28529    begin
28530       P := Parent (N);
28531 
28532       if Nkind (P) /= N_Pragma_Argument_Association then
28533          return False;
28534 
28535       else
28536          Id := Get_Pragma_Id (Parent (P));
28537          C := Sig_Flags (Id);
28538          AN := Arg_No;
28539 
28540          if AN = 0 then
28541             return False;
28542          end if;
28543 
28544          case C is
28545             when -1 =>
28546                return False;
28547 
28548             when 0 =>
28549                return True;
28550 
28551             when 92 .. 99 =>
28552                return AN < (C - 90);
28553 
28554             when others =>
28555                return AN /= C;
28556          end case;
28557       end if;
28558    end Is_Non_Significant_Pragma_Reference;
28559 
28560    ------------------------------
28561    -- Is_Pragma_String_Literal --
28562    ------------------------------
28563 
28564    --  This function returns true if the corresponding pragma argument is a
28565    --  static string expression. These are the only cases in which string
28566    --  literals can appear as pragma arguments. We also allow a string literal
28567    --  as the first argument to pragma Assert (although it will of course
28568    --  always generate a type error).
28569 
28570    function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
28571       Pragn : constant Node_Id := Parent (Par);
28572       Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
28573       Pname : constant Name_Id := Pragma_Name (Pragn);
28574       Argn  : Natural;
28575       N     : Node_Id;
28576 
28577    begin
28578       Argn := 1;
28579       N := First (Assoc);
28580       loop
28581          exit when N = Par;
28582          Argn := Argn + 1;
28583          Next (N);
28584       end loop;
28585 
28586       if Pname = Name_Assert then
28587          return True;
28588 
28589       elsif Pname = Name_Export then
28590          return Argn > 2;
28591 
28592       elsif Pname = Name_Ident then
28593          return Argn = 1;
28594 
28595       elsif Pname = Name_Import then
28596          return Argn > 2;
28597 
28598       elsif Pname = Name_Interface_Name then
28599          return Argn > 1;
28600 
28601       elsif Pname = Name_Linker_Alias then
28602          return Argn = 2;
28603 
28604       elsif Pname = Name_Linker_Section then
28605          return Argn = 2;
28606 
28607       elsif Pname = Name_Machine_Attribute then
28608          return Argn = 2;
28609 
28610       elsif Pname = Name_Source_File_Name then
28611          return True;
28612 
28613       elsif Pname = Name_Source_Reference then
28614          return Argn = 2;
28615 
28616       elsif Pname = Name_Title then
28617          return True;
28618 
28619       elsif Pname = Name_Subtitle then
28620          return True;
28621 
28622       else
28623          return False;
28624       end if;
28625    end Is_Pragma_String_Literal;
28626 
28627    ---------------------------
28628    -- Is_Private_SPARK_Mode --
28629    ---------------------------
28630 
28631    function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is
28632    begin
28633       pragma Assert
28634         (Nkind (N) = N_Pragma
28635           and then Pragma_Name (N) = Name_SPARK_Mode
28636           and then Is_List_Member (N));
28637 
28638       --  For pragma SPARK_Mode to be private, it has to appear in the private
28639       --  declarations of a package.
28640 
28641       return
28642         Present (Parent (N))
28643           and then Nkind (Parent (N)) = N_Package_Specification
28644           and then List_Containing (N) = Private_Declarations (Parent (N));
28645    end Is_Private_SPARK_Mode;
28646 
28647    -------------------------------------
28648    -- Is_Unconstrained_Or_Tagged_Item --
28649    -------------------------------------
28650 
28651    function Is_Unconstrained_Or_Tagged_Item
28652      (Item : Entity_Id) return Boolean
28653    is
28654       function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean;
28655       --  Determine whether record type Typ has at least one unconstrained
28656       --  component.
28657 
28658       ---------------------------------
28659       -- Has_Unconstrained_Component --
28660       ---------------------------------
28661 
28662       function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is
28663          Comp : Entity_Id;
28664 
28665       begin
28666          Comp := First_Component (Typ);
28667          while Present (Comp) loop
28668             if Is_Unconstrained_Or_Tagged_Item (Comp) then
28669                return True;
28670             end if;
28671 
28672             Next_Component (Comp);
28673          end loop;
28674 
28675          return False;
28676       end Has_Unconstrained_Component;
28677 
28678       --  Local variables
28679 
28680       Typ : constant Entity_Id := Etype (Item);
28681 
28682    --  Start of processing for Is_Unconstrained_Or_Tagged_Item
28683 
28684    begin
28685       if Is_Tagged_Type (Typ) then
28686          return True;
28687 
28688       elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then
28689          return True;
28690 
28691       elsif Is_Record_Type (Typ) then
28692          if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then
28693             return True;
28694          else
28695             return Has_Unconstrained_Component (Typ);
28696          end if;
28697 
28698       elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then
28699          return True;
28700 
28701       else
28702          return False;
28703       end if;
28704    end Is_Unconstrained_Or_Tagged_Item;
28705 
28706    -----------------------------
28707    -- Is_Valid_Assertion_Kind --
28708    -----------------------------
28709 
28710    function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is
28711    begin
28712       case Nam is
28713          when
28714             --  RM defined
28715 
28716             Name_Assert                    |
28717             Name_Assertion_Policy          |
28718             Name_Static_Predicate          |
28719             Name_Dynamic_Predicate         |
28720             Name_Pre                       |
28721             Name_uPre                      |
28722             Name_Post                      |
28723             Name_uPost                     |
28724             Name_Type_Invariant            |
28725             Name_uType_Invariant           |
28726 
28727             --  Impl defined
28728 
28729             Name_Assert_And_Cut            |
28730             Name_Assume                    |
28731             Name_Contract_Cases            |
28732             Name_Debug                     |
28733             Name_Default_Initial_Condition |
28734             Name_Ghost                     |
28735             Name_Initial_Condition         |
28736             Name_Invariant                 |
28737             Name_uInvariant                |
28738             Name_Loop_Invariant            |
28739             Name_Loop_Variant              |
28740             Name_Postcondition             |
28741             Name_Precondition              |
28742             Name_Predicate                 |
28743             Name_Refined_Post              |
28744             Name_Statement_Assertions      => return True;
28745 
28746          when others                       => return False;
28747       end case;
28748    end Is_Valid_Assertion_Kind;
28749 
28750    --------------------------------------
28751    -- Process_Compilation_Unit_Pragmas --
28752    --------------------------------------
28753 
28754    procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
28755    begin
28756       --  A special check for pragma Suppress_All, a very strange DEC pragma,
28757       --  strange because it comes at the end of the unit. Rational has the
28758       --  same name for a pragma, but treats it as a program unit pragma, In
28759       --  GNAT we just decide to allow it anywhere at all. If it appeared then
28760       --  the flag Has_Pragma_Suppress_All was set on the compilation unit
28761       --  node, and we insert a pragma Suppress (All_Checks) at the start of
28762       --  the context clause to ensure the correct processing.
28763 
28764       if Has_Pragma_Suppress_All (N) then
28765          Prepend_To (Context_Items (N),
28766            Make_Pragma (Sloc (N),
28767              Chars                        => Name_Suppress,
28768              Pragma_Argument_Associations => New_List (
28769                Make_Pragma_Argument_Association (Sloc (N),
28770                  Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
28771       end if;
28772 
28773       --  Nothing else to do at the current time
28774 
28775    end Process_Compilation_Unit_Pragmas;
28776 
28777    ------------------------------------
28778    -- Record_Possible_Body_Reference --
28779    ------------------------------------
28780 
28781    procedure Record_Possible_Body_Reference
28782      (State_Id : Entity_Id;
28783       Ref      : Node_Id)
28784    is
28785       Context : Node_Id;
28786       Spec_Id : Entity_Id;
28787 
28788    begin
28789       --  Ensure that we are dealing with a reference to a state
28790 
28791       pragma Assert (Ekind (State_Id) = E_Abstract_State);
28792 
28793       --  Climb the tree starting from the reference looking for a package body
28794       --  whose spec declares the referenced state. This criteria automatically
28795       --  excludes references in package specs which are legal. Note that it is
28796       --  not wise to emit an error now as the package body may lack pragma
28797       --  Refined_State or the referenced state may not be mentioned in the
28798       --  refinement. This approach avoids the generation of misleading errors.
28799 
28800       Context := Ref;
28801       while Present (Context) loop
28802          if Nkind (Context) = N_Package_Body then
28803             Spec_Id := Corresponding_Spec (Context);
28804 
28805             if Present (Abstract_States (Spec_Id))
28806               and then Contains (Abstract_States (Spec_Id), State_Id)
28807             then
28808                if No (Body_References (State_Id)) then
28809                   Set_Body_References (State_Id, New_Elmt_List);
28810                end if;
28811 
28812                Append_Elmt (Ref, To => Body_References (State_Id));
28813                exit;
28814             end if;
28815          end if;
28816 
28817          Context := Parent (Context);
28818       end loop;
28819    end Record_Possible_Body_Reference;
28820 
28821    ------------------------------------------
28822    -- Relocate_Pragmas_To_Anonymous_Object --
28823    ------------------------------------------
28824 
28825    procedure Relocate_Pragmas_To_Anonymous_Object
28826      (Typ_Decl : Node_Id;
28827       Obj_Decl : Node_Id)
28828    is
28829       Decl      : Node_Id;
28830       Def       : Node_Id;
28831       Next_Decl : Node_Id;
28832 
28833    begin
28834       if Nkind (Typ_Decl) = N_Protected_Type_Declaration then
28835          Def := Protected_Definition (Typ_Decl);
28836       else
28837          pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration);
28838          Def := Task_Definition (Typ_Decl);
28839       end if;
28840 
28841       --  The concurrent definition has a visible declaration list. Inspect it
28842       --  and relocate all canidate pragmas.
28843 
28844       if Present (Def) and then Present (Visible_Declarations (Def)) then
28845          Decl := First (Visible_Declarations (Def));
28846          while Present (Decl) loop
28847 
28848             --  Preserve the following declaration for iteration purposes due
28849             --  to possible relocation of a pragma.
28850 
28851             Next_Decl := Next (Decl);
28852 
28853             if Nkind (Decl) = N_Pragma
28854               and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl))
28855             then
28856                Remove (Decl);
28857                Insert_After (Obj_Decl, Decl);
28858 
28859             --  Skip internally generated code
28860 
28861             elsif not Comes_From_Source (Decl) then
28862                null;
28863 
28864             --  No candidate pragmas are available for relocation
28865 
28866             else
28867                exit;
28868             end if;
28869 
28870             Decl := Next_Decl;
28871          end loop;
28872       end if;
28873    end Relocate_Pragmas_To_Anonymous_Object;
28874 
28875    ------------------------------
28876    -- Relocate_Pragmas_To_Body --
28877    ------------------------------
28878 
28879    procedure Relocate_Pragmas_To_Body
28880      (Subp_Body   : Node_Id;
28881       Target_Body : Node_Id := Empty)
28882    is
28883       procedure Relocate_Pragma (Prag : Node_Id);
28884       --  Remove a single pragma from its current list and add it to the
28885       --  declarations of the proper body (either Subp_Body or Target_Body).
28886 
28887       ---------------------
28888       -- Relocate_Pragma --
28889       ---------------------
28890 
28891       procedure Relocate_Pragma (Prag : Node_Id) is
28892          Decls  : List_Id;
28893          Target : Node_Id;
28894 
28895       begin
28896          --  When subprogram stubs or expression functions are involves, the
28897          --  destination declaration list belongs to the proper body.
28898 
28899          if Present (Target_Body) then
28900             Target := Target_Body;
28901          else
28902             Target := Subp_Body;
28903          end if;
28904 
28905          Decls := Declarations (Target);
28906 
28907          if No (Decls) then
28908             Decls := New_List;
28909             Set_Declarations (Target, Decls);
28910          end if;
28911 
28912          --  Unhook the pragma from its current list
28913 
28914          Remove  (Prag);
28915          Prepend (Prag, Decls);
28916       end Relocate_Pragma;
28917 
28918       --  Local variables
28919 
28920       Body_Id   : constant Entity_Id :=
28921                     Defining_Unit_Name (Specification (Subp_Body));
28922       Next_Stmt : Node_Id;
28923       Stmt      : Node_Id;
28924 
28925    --  Start of processing for Relocate_Pragmas_To_Body
28926 
28927    begin
28928       --  Do not process a body that comes from a separate unit as no construct
28929       --  can possibly follow it.
28930 
28931       if not Is_List_Member (Subp_Body) then
28932          return;
28933 
28934       --  Do not relocate pragmas that follow a stub if the stub does not have
28935       --  a proper body.
28936 
28937       elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub
28938         and then No (Target_Body)
28939       then
28940          return;
28941 
28942       --  Do not process internally generated routine _Postconditions
28943 
28944       elsif Ekind (Body_Id) = E_Procedure
28945         and then Chars (Body_Id) = Name_uPostconditions
28946       then
28947          return;
28948       end if;
28949 
28950       --  Look at what is following the body. We are interested in certain kind
28951       --  of pragmas (either from source or byproducts of expansion) that can
28952       --  apply to a body [stub].
28953 
28954       Stmt := Next (Subp_Body);
28955       while Present (Stmt) loop
28956 
28957          --  Preserve the following statement for iteration purposes due to a
28958          --  possible relocation of a pragma.
28959 
28960          Next_Stmt := Next (Stmt);
28961 
28962          --  Move a candidate pragma following the body to the declarations of
28963          --  the body.
28964 
28965          if Nkind (Stmt) = N_Pragma
28966            and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt))
28967          then
28968             Relocate_Pragma (Stmt);
28969 
28970          --  Skip internally generated code
28971 
28972          elsif not Comes_From_Source (Stmt) then
28973             null;
28974 
28975          --  No candidate pragmas are available for relocation
28976 
28977          else
28978             exit;
28979          end if;
28980 
28981          Stmt := Next_Stmt;
28982       end loop;
28983    end Relocate_Pragmas_To_Body;
28984 
28985    -------------------
28986    -- Resolve_State --
28987    -------------------
28988 
28989    procedure Resolve_State (N : Node_Id) is
28990       Func  : Entity_Id;
28991       State : Entity_Id;
28992 
28993    begin
28994       if Is_Entity_Name (N) and then Present (Entity (N)) then
28995          Func := Entity (N);
28996 
28997          --  Handle overloading of state names by functions. Traverse the
28998          --  homonym chain looking for an abstract state.
28999 
29000          if Ekind (Func) = E_Function and then Has_Homonym (Func) then
29001             State := Homonym (Func);
29002             while Present (State) loop
29003 
29004                --  Resolve the overloading by setting the proper entity of the
29005                --  reference to that of the state.
29006 
29007                if Ekind (State) = E_Abstract_State then
29008                   Set_Etype           (N, Standard_Void_Type);
29009                   Set_Entity          (N, State);
29010                   Set_Associated_Node (N, State);
29011                   return;
29012                end if;
29013 
29014                State := Homonym (State);
29015             end loop;
29016 
29017             --  A function can never act as a state. If the homonym chain does
29018             --  not contain a corresponding state, then something went wrong in
29019             --  the overloading mechanism.
29020 
29021             raise Program_Error;
29022          end if;
29023       end if;
29024    end Resolve_State;
29025 
29026    ----------------------------
29027    -- Rewrite_Assertion_Kind --
29028    ----------------------------
29029 
29030    procedure Rewrite_Assertion_Kind (N : Node_Id) is
29031       Nam : Name_Id;
29032 
29033    begin
29034       if Nkind (N) = N_Attribute_Reference
29035         and then Attribute_Name (N) = Name_Class
29036         and then Nkind (Prefix (N)) = N_Identifier
29037       then
29038          case Chars (Prefix (N)) is
29039             when Name_Pre =>
29040                Nam := Name_uPre;
29041             when Name_Post =>
29042                Nam := Name_uPost;
29043             when Name_Type_Invariant =>
29044                Nam := Name_uType_Invariant;
29045             when Name_Invariant =>
29046                Nam := Name_uInvariant;
29047             when others =>
29048                return;
29049          end case;
29050 
29051          Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
29052       end if;
29053    end Rewrite_Assertion_Kind;
29054 
29055    --------
29056    -- rv --
29057    --------
29058 
29059    procedure rv is
29060    begin
29061       Dummy := Dummy + 1;
29062    end rv;
29063 
29064    --------------------------------
29065    -- Set_Encoded_Interface_Name --
29066    --------------------------------
29067 
29068    procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
29069       Str : constant String_Id := Strval (S);
29070       Len : constant Nat       := String_Length (Str);
29071       CC  : Char_Code;
29072       C   : Character;
29073       J   : Pos;
29074 
29075       Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
29076 
29077       procedure Encode;
29078       --  Stores encoded value of character code CC. The encoding we use an
29079       --  underscore followed by four lower case hex digits.
29080 
29081       ------------
29082       -- Encode --
29083       ------------
29084 
29085       procedure Encode is
29086       begin
29087          Store_String_Char (Get_Char_Code ('_'));
29088          Store_String_Char
29089            (Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
29090          Store_String_Char
29091            (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
29092          Store_String_Char
29093            (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
29094          Store_String_Char
29095            (Get_Char_Code (Hex (Integer (CC and 16#0F#))));
29096       end Encode;
29097 
29098    --  Start of processing for Set_Encoded_Interface_Name
29099 
29100    begin
29101       --  If first character is asterisk, this is a link name, and we leave it
29102       --  completely unmodified. We also ignore null strings (the latter case
29103       --  happens only in error cases).
29104 
29105       if Len = 0
29106         or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
29107       then
29108          Set_Interface_Name (E, S);
29109 
29110       else
29111          J := 1;
29112          loop
29113             CC := Get_String_Char (Str, J);
29114 
29115             exit when not In_Character_Range (CC);
29116 
29117             C := Get_Character (CC);
29118 
29119             exit when C /= '_' and then C /= '$'
29120               and then C not in '0' .. '9'
29121               and then C not in 'a' .. 'z'
29122               and then C not in 'A' .. 'Z';
29123 
29124             if J = Len then
29125                Set_Interface_Name (E, S);
29126                return;
29127 
29128             else
29129                J := J + 1;
29130             end if;
29131          end loop;
29132 
29133          --  Here we need to encode. The encoding we use as follows:
29134          --     three underscores  + four hex digits (lower case)
29135 
29136          Start_String;
29137 
29138          for J in 1 .. String_Length (Str) loop
29139             CC := Get_String_Char (Str, J);
29140 
29141             if not In_Character_Range (CC) then
29142                Encode;
29143             else
29144                C := Get_Character (CC);
29145 
29146                if C = '_' or else C = '$'
29147                  or else C in '0' .. '9'
29148                  or else C in 'a' .. 'z'
29149                  or else C in 'A' .. 'Z'
29150                then
29151                   Store_String_Char (CC);
29152                else
29153                   Encode;
29154                end if;
29155             end if;
29156          end loop;
29157 
29158          Set_Interface_Name (E,
29159            Make_String_Literal (Sloc (S),
29160              Strval => End_String));
29161       end if;
29162    end Set_Encoded_Interface_Name;
29163 
29164    ------------------------
29165    -- Set_Elab_Unit_Name --
29166    ------------------------
29167 
29168    procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is
29169       Pref : Node_Id;
29170       Scop : Entity_Id;
29171 
29172    begin
29173       if Nkind (N) = N_Identifier
29174         and then Nkind (With_Item) = N_Identifier
29175       then
29176          Set_Entity (N, Entity (With_Item));
29177 
29178       elsif Nkind (N) = N_Selected_Component then
29179          Change_Selected_Component_To_Expanded_Name (N);
29180          Set_Entity (N, Entity (With_Item));
29181          Set_Entity (Selector_Name (N), Entity (N));
29182 
29183          Pref := Prefix (N);
29184          Scop := Scope (Entity (N));
29185          while Nkind (Pref) = N_Selected_Component loop
29186             Change_Selected_Component_To_Expanded_Name (Pref);
29187             Set_Entity (Selector_Name (Pref), Scop);
29188             Set_Entity (Pref, Scop);
29189             Pref := Prefix (Pref);
29190             Scop := Scope (Scop);
29191          end loop;
29192 
29193          Set_Entity (Pref, Scop);
29194       end if;
29195 
29196       Generate_Reference (Entity (With_Item), N, Set_Ref => False);
29197    end Set_Elab_Unit_Name;
29198 
29199    -------------------
29200    -- Test_Case_Arg --
29201    -------------------
29202 
29203    function Test_Case_Arg
29204      (Prag        : Node_Id;
29205       Arg_Nam     : Name_Id;
29206       From_Aspect : Boolean := False) return Node_Id
29207    is
29208       Aspect : constant Node_Id := Corresponding_Aspect (Prag);
29209       Arg    : Node_Id;
29210       Args   : Node_Id;
29211 
29212    begin
29213       pragma Assert (Nam_In (Arg_Nam, Name_Ensures,
29214                                       Name_Mode,
29215                                       Name_Name,
29216                                       Name_Requires));
29217 
29218       --  The caller requests the aspect argument
29219 
29220       if From_Aspect then
29221          if Present (Aspect)
29222            and then Nkind (Expression (Aspect)) = N_Aggregate
29223          then
29224             Args := Expression (Aspect);
29225 
29226             --  "Name" and "Mode" may appear without an identifier as a
29227             --  positional association.
29228 
29229             if Present (Expressions (Args)) then
29230                Arg := First (Expressions (Args));
29231 
29232                if Present (Arg) and then Arg_Nam = Name_Name then
29233                   return Arg;
29234                end if;
29235 
29236                --  Skip "Name"
29237 
29238                Arg := Next (Arg);
29239 
29240                if Present (Arg) and then Arg_Nam = Name_Mode then
29241                   return Arg;
29242                end if;
29243             end if;
29244 
29245             --  Some or all arguments may appear as component associatons
29246 
29247             if Present (Component_Associations (Args)) then
29248                Arg := First (Component_Associations (Args));
29249                while Present (Arg) loop
29250                   if Chars (First (Choices (Arg))) = Arg_Nam then
29251                      return Arg;
29252                   end if;
29253 
29254                   Next (Arg);
29255                end loop;
29256             end if;
29257          end if;
29258 
29259       --  Otherwise retrieve the argument directly from the pragma
29260 
29261       else
29262          Arg := First (Pragma_Argument_Associations (Prag));
29263 
29264          if Present (Arg) and then Arg_Nam = Name_Name then
29265             return Arg;
29266          end if;
29267 
29268          --  Skip argument "Name"
29269 
29270          Arg := Next (Arg);
29271 
29272          if Present (Arg) and then Arg_Nam = Name_Mode then
29273             return Arg;
29274          end if;
29275 
29276          --  Skip argument "Mode"
29277 
29278          Arg := Next (Arg);
29279 
29280          --  Arguments "Requires" and "Ensures" are optional and may not be
29281          --  present at all.
29282 
29283          while Present (Arg) loop
29284             if Chars (Arg) = Arg_Nam then
29285                return Arg;
29286             end if;
29287 
29288             Next (Arg);
29289          end loop;
29290       end if;
29291 
29292       return Empty;
29293    end Test_Case_Arg;
29294 
29295    -------------------------------
29296    -- Update_Primitives_Mapping --
29297    -------------------------------
29298 
29299    procedure Update_Primitives_Mapping
29300      (Inher_Id : Entity_Id;
29301       Subp_Id  : Entity_Id)
29302    is
29303       function Overridden_Ancestor (S : Entity_Id) return Entity_Id;
29304       --  ??? what does this routine do?
29305 
29306       -------------------------
29307       -- Overridden_Ancestor --
29308       -------------------------
29309 
29310       function Overridden_Ancestor (S : Entity_Id) return Entity_Id is
29311          Par : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
29312          Anc : Entity_Id;
29313 
29314       begin
29315          Anc := S;
29316 
29317          --  Locate the ancestor subprogram with the proper controlling type
29318 
29319          while Present (Overridden_Operation (Anc)) loop
29320             Anc := Overridden_Operation (Anc);
29321             exit when Find_Dispatching_Type (Anc) = Par;
29322          end loop;
29323 
29324          return Anc;
29325       end Overridden_Ancestor;
29326 
29327       --  Local variables
29328 
29329       Old_Typ  : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
29330       Typ      : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
29331       Decl     : Node_Id;
29332       Old_Elmt : Elmt_Id;
29333       Old_Prim : Entity_Id;
29334       Prim     : Entity_Id;
29335 
29336    --  Start of processing for Primitive_Mapping
29337 
29338    begin
29339       --  If the types are already in the map, it has been previously built for
29340       --  some other overriding primitive.
29341 
29342       if Primitives_Mapping.Get (Old_Typ) = Typ then
29343          return;
29344 
29345       else
29346          --  Initialize new mapping with the primitive operations
29347 
29348          Decl := First (List_Containing (Unit_Declaration_Node (Subp_Id)));
29349 
29350          --  Look for primitive operations of the current type that have
29351          --  overridden an operation of the type related to the original
29352          --  class-wide precondition. There may be several intermediate
29353          --  overridings between them.
29354 
29355          while Present (Decl) loop
29356             if Nkind_In (Decl, N_Abstract_Subprogram_Declaration,
29357                                N_Subprogram_Declaration)
29358             then
29359                Prim := Defining_Entity (Decl);
29360 
29361                if Is_Subprogram (Prim)
29362                  and then Present (Overridden_Operation (Prim))
29363                  and then Find_Dispatching_Type (Prim) = Typ
29364                then
29365                   Old_Prim := Overridden_Ancestor (Prim);
29366 
29367                   Primitives_Mapping.Set (Old_Prim, Prim);
29368                end if;
29369             end if;
29370 
29371             Next (Decl);
29372          end loop;
29373 
29374          --  Now examine inherited operations. these do not override, but have
29375          --  an alias, which is the entity used in a call. That alias may be
29376          --  inherited or come from source, in which case it may override an
29377          --  earlier operation. We only need to examine inherited functions,
29378          --  that can appear within the inherited expression.
29379 
29380          Prim := First_Entity (Scope (Subp_Id));
29381          while Present (Prim) loop
29382             if not Comes_From_Source (Prim)
29383               and then Ekind (Prim) = E_Function
29384               and then Present (Alias (Prim))
29385             then
29386                Old_Prim := Alias (Prim);
29387 
29388                if Comes_From_Source (Old_Prim) then
29389                   Old_Prim := Overridden_Ancestor (Old_Prim);
29390 
29391                else
29392                   while Present (Alias (Old_Prim))
29393                     and then Scope (Old_Prim) /= Scope (Inher_Id)
29394                   loop
29395                      Old_Prim := Alias (Old_Prim);
29396 
29397                      if Comes_From_Source (Old_Prim) then
29398                         Old_Prim := Overridden_Ancestor (Old_Prim);
29399                         exit;
29400                      end if;
29401                   end loop;
29402                end if;
29403 
29404                Primitives_Mapping.Set (Old_Prim, Prim);
29405             end if;
29406 
29407             Next_Entity (Prim);
29408          end loop;
29409 
29410          --  If the parent operation is an interface operation, the overriding
29411          --  indicator is not present. Instead, we get from the interface
29412          --  operation the primitive of the current type that implements it.
29413 
29414          if Is_Interface (Old_Typ) then
29415             Old_Elmt := First_Elmt (Collect_Primitive_Operations (Old_Typ));
29416             while Present (Old_Elmt) loop
29417                Old_Prim := Node (Old_Elmt);
29418                Prim := Find_Primitive_Covering_Interface (Typ, Old_Prim);
29419 
29420                if Present (Prim) then
29421                   Primitives_Mapping.Set (Old_Prim, Prim);
29422                end if;
29423 
29424                Next_Elmt (Old_Elmt);
29425             end loop;
29426          end if;
29427       end if;
29428 
29429       --  Map the types themselves, so that the process is not repeated for
29430       --  other overriding primitives.
29431 
29432       Primitives_Mapping.Set (Old_Typ, Typ);
29433    end Update_Primitives_Mapping;
29434 
29435 end Sem_Prag;