File : exp_prag.adb


   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ 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 with Atree;    use Atree;
  27 with Casing;   use Casing;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Errout;   use Errout;
  32 with Exp_Ch11; use Exp_Ch11;
  33 with Exp_Util; use Exp_Util;
  34 with Expander; use Expander;
  35 with Ghost;    use Ghost;
  36 with Inline;   use Inline;
  37 with Namet;    use Namet;
  38 with Nlists;   use Nlists;
  39 with Nmake;    use Nmake;
  40 with Opt;      use Opt;
  41 with Restrict; use Restrict;
  42 with Rident;   use Rident;
  43 with Rtsfind;  use Rtsfind;
  44 with Sem;      use Sem;
  45 with Sem_Ch8;  use Sem_Ch8;
  46 with Sem_Util; use Sem_Util;
  47 with Sinfo;    use Sinfo;
  48 with Sinput;   use Sinput;
  49 with Snames;   use Snames;
  50 with Stringt;  use Stringt;
  51 with Stand;    use Stand;
  52 with Tbuild;   use Tbuild;
  53 with Uintp;    use Uintp;
  54 with Validsw;  use Validsw;
  55 
  56 package body Exp_Prag is
  57 
  58    -----------------------
  59    -- Local Subprograms --
  60    -----------------------
  61 
  62    function Arg1 (N : Node_Id) return Node_Id;
  63    function Arg2 (N : Node_Id) return Node_Id;
  64    function Arg3 (N : Node_Id) return Node_Id;
  65    --  Obtain specified pragma argument expression
  66 
  67    procedure Expand_Pragma_Abort_Defer             (N : Node_Id);
  68    procedure Expand_Pragma_Check                   (N : Node_Id);
  69    procedure Expand_Pragma_Common_Object           (N : Node_Id);
  70    procedure Expand_Pragma_Import_Or_Interface     (N : Node_Id);
  71    procedure Expand_Pragma_Inspection_Point        (N : Node_Id);
  72    procedure Expand_Pragma_Interrupt_Priority      (N : Node_Id);
  73    procedure Expand_Pragma_Loop_Variant            (N : Node_Id);
  74    procedure Expand_Pragma_Psect_Object            (N : Node_Id);
  75    procedure Expand_Pragma_Relative_Deadline       (N : Node_Id);
  76    procedure Expand_Pragma_Suppress_Initialization (N : Node_Id);
  77 
  78    procedure Undo_Initialization (Def_Id : Entity_Id; N : Node_Id);
  79    --  This procedure is used to undo initialization already done for Def_Id,
  80    --  which is always an E_Variable, in response to the occurrence of the
  81    --  pragma N, a pragma Interface, Import, or Suppress_Initialization. In all
  82    --  these cases we want no initialization to occur, but we have already done
  83    --  the initialization by the time we see the pragma, so we have to undo it.
  84 
  85    ----------
  86    -- Arg1 --
  87    ----------
  88 
  89    function Arg1 (N : Node_Id) return Node_Id is
  90       Arg : constant Node_Id := First (Pragma_Argument_Associations (N));
  91    begin
  92       if Present (Arg)
  93         and then Nkind (Arg) = N_Pragma_Argument_Association
  94       then
  95          return Expression (Arg);
  96       else
  97          return Arg;
  98       end if;
  99    end Arg1;
 100 
 101    ----------
 102    -- Arg2 --
 103    ----------
 104 
 105    function Arg2 (N : Node_Id) return Node_Id is
 106       Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
 107 
 108    begin
 109       if No (Arg1) then
 110          return Empty;
 111 
 112       else
 113          declare
 114             Arg : constant Node_Id := Next (Arg1);
 115          begin
 116             if Present (Arg)
 117               and then Nkind (Arg) = N_Pragma_Argument_Association
 118             then
 119                return Expression (Arg);
 120             else
 121                return Arg;
 122             end if;
 123          end;
 124       end if;
 125    end Arg2;
 126 
 127    ----------
 128    -- Arg3 --
 129    ----------
 130 
 131    function Arg3 (N : Node_Id) return Node_Id is
 132       Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
 133 
 134    begin
 135       if No (Arg1) then
 136          return Empty;
 137 
 138       else
 139          declare
 140             Arg : Node_Id := Next (Arg1);
 141          begin
 142             if No (Arg) then
 143                return Empty;
 144 
 145             else
 146                Next (Arg);
 147 
 148                if Present (Arg)
 149                  and then Nkind (Arg) = N_Pragma_Argument_Association
 150                then
 151                   return Expression (Arg);
 152                else
 153                   return Arg;
 154                end if;
 155             end if;
 156          end;
 157       end if;
 158    end Arg3;
 159 
 160    ---------------------
 161    -- Expand_N_Pragma --
 162    ---------------------
 163 
 164    procedure Expand_N_Pragma (N : Node_Id) is
 165       Pname : constant Name_Id := Pragma_Name (N);
 166 
 167    begin
 168       --  Rewrite pragma ignored by Ignore_Pragma to null statement, so that
 169       --  the back end or the expander here does not get overenthusiastic and
 170       --  start processing such a pragma!
 171 
 172       if Get_Name_Table_Boolean3 (Pname) then
 173          Rewrite (N, Make_Null_Statement (Sloc (N)));
 174          return;
 175       end if;
 176 
 177       --  Note: we may have a pragma whose Pragma_Identifier field is not a
 178       --  recognized pragma, and we must ignore it at this stage.
 179 
 180       if Is_Pragma_Name (Pname) then
 181          case Get_Pragma_Id (Pname) is
 182 
 183             --  Pragmas requiring special expander action
 184 
 185             when Pragma_Abort_Defer =>
 186                Expand_Pragma_Abort_Defer (N);
 187 
 188             when Pragma_Check =>
 189                Expand_Pragma_Check (N);
 190 
 191             when Pragma_Common_Object =>
 192                Expand_Pragma_Common_Object (N);
 193 
 194             when Pragma_Import =>
 195                Expand_Pragma_Import_Or_Interface (N);
 196 
 197             when Pragma_Inspection_Point =>
 198                Expand_Pragma_Inspection_Point (N);
 199 
 200             when Pragma_Interface =>
 201                Expand_Pragma_Import_Or_Interface (N);
 202 
 203             when Pragma_Interrupt_Priority =>
 204                Expand_Pragma_Interrupt_Priority (N);
 205 
 206             when Pragma_Loop_Variant =>
 207                Expand_Pragma_Loop_Variant (N);
 208 
 209             when Pragma_Psect_Object =>
 210                Expand_Pragma_Psect_Object (N);
 211 
 212             when Pragma_Relative_Deadline =>
 213                Expand_Pragma_Relative_Deadline (N);
 214 
 215             when Pragma_Suppress_Initialization =>
 216                Expand_Pragma_Suppress_Initialization (N);
 217 
 218             --  All other pragmas need no expander action
 219 
 220             when others => null;
 221          end case;
 222       end if;
 223 
 224    end Expand_N_Pragma;
 225 
 226    -------------------------------
 227    -- Expand_Pragma_Abort_Defer --
 228    -------------------------------
 229 
 230    --  An Abort_Defer pragma appears as the first statement in a handled
 231    --  statement sequence (right after the begin). It defers aborts for
 232    --  the entire statement sequence, but not for any declarations or
 233    --  handlers (if any) associated with this statement sequence.
 234 
 235    --  The transformation is to transform
 236 
 237    --    pragma Abort_Defer;
 238    --    statements;
 239 
 240    --  into
 241 
 242    --    begin
 243    --       Abort_Defer.all;
 244    --       statements
 245    --    exception
 246    --       when all others =>
 247    --          Abort_Undefer.all;
 248    --          raise;
 249    --    at end
 250    --       Abort_Undefer_Direct;
 251    --    end;
 252 
 253    procedure Expand_Pragma_Abort_Defer (N : Node_Id) is
 254    begin
 255       --  Abort_Defer has no useful effect if Abort's are not allowed
 256 
 257       if not Abort_Allowed then
 258          return;
 259       end if;
 260 
 261       --  Normal case where abort is possible
 262 
 263       declare
 264          Loc  : constant Source_Ptr := Sloc (N);
 265          Stm  : Node_Id;
 266          Stms : List_Id;
 267          HSS  : Node_Id;
 268          Blk  : constant Entity_Id :=
 269                   New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
 270          AUD  : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
 271 
 272       begin
 273          Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer));
 274          loop
 275             Stm := Remove_Next (N);
 276             exit when No (Stm);
 277             Append (Stm, Stms);
 278          end loop;
 279 
 280          HSS :=
 281            Make_Handled_Sequence_Of_Statements (Loc,
 282              Statements  => Stms,
 283              At_End_Proc => New_Occurrence_Of (AUD, Loc));
 284 
 285          --  Present the Abort_Undefer_Direct function to the backend so that
 286          --  it can inline the call to the function.
 287 
 288          Add_Inlined_Body (AUD, N);
 289 
 290          Rewrite (N,
 291            Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS));
 292 
 293          Set_Scope (Blk, Current_Scope);
 294          Set_Etype (Blk, Standard_Void_Type);
 295          Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
 296          Expand_At_End_Handler (HSS, Blk);
 297          Analyze (N);
 298       end;
 299    end Expand_Pragma_Abort_Defer;
 300 
 301    --------------------------
 302    -- Expand_Pragma_Check --
 303    --------------------------
 304 
 305    procedure Expand_Pragma_Check (N : Node_Id) is
 306       Cond : constant Node_Id := Arg2 (N);
 307       Nam  : constant Name_Id := Chars (Arg1 (N));
 308       Msg  : Node_Id;
 309 
 310       Loc : constant Source_Ptr := Sloc (First_Node (Cond));
 311       --  Source location used in the case of a failed assertion: point to the
 312       --  failing condition, not Loc. Note that the source location of the
 313       --  expression is not usually the best choice here, because it points to
 314       --  the location of the topmost tree node, which may be an operator in
 315       --  the middle of the source text of the expression. For example, it gets
 316       --  located on the last AND keyword in a chain of boolean expressiond
 317       --  AND'ed together. It is best to put the message on the first character
 318       --  of the condition, which is the effect of the First_Node call here.
 319       --  This source location is used to build the default exception message,
 320       --  and also as the sloc of the call to the runtime subprogram raising
 321       --  Assert_Failure, so that coverage analysis tools can relate the
 322       --  call to the failed check.
 323 
 324       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
 325 
 326    begin
 327       --  Nothing to do if pragma is ignored
 328 
 329       if Is_Ignored (N) then
 330          return;
 331       end if;
 332 
 333       --  Pragmas Assert, Assert_And_Cut, Assume, Check and Loop_Invariant are
 334       --  Ghost when they apply to a Ghost entity. Set the mode now to ensure
 335       --  that any nodes generated during expansion are properly flagged as
 336       --  Ghost.
 337 
 338       Set_Ghost_Mode (N);
 339 
 340       --  Since this check is active, we rewrite the pragma into a
 341       --  corresponding if statement, and then analyze the statement.
 342 
 343       --  The normal case expansion transforms:
 344 
 345       --    pragma Check (name, condition [,message]);
 346 
 347       --  into
 348 
 349       --    if not condition then
 350       --       System.Assertions.Raise_Assert_Failure (Str);
 351       --    end if;
 352 
 353       --  where Str is the message if one is present, or the default of
 354       --  name failed at file:line if no message is given (the "name failed
 355       --  at" is omitted for name = Assertion, since it is redundant, given
 356       --  that the name of the exception is Assert_Failure.)
 357 
 358       --  Also, instead of "XXX failed at", we generate slightly
 359       --  different messages for some of the contract assertions (see
 360       --  code below for details).
 361 
 362       --  An alternative expansion is used when the No_Exception_Propagation
 363       --  restriction is active and there is a local Assert_Failure handler.
 364       --  This is not a common combination of circumstances, but it occurs in
 365       --  the context of Aunit and the zero footprint profile. In this case we
 366       --  generate:
 367 
 368       --    if not condition then
 369       --       raise Assert_Failure;
 370       --    end if;
 371 
 372       --  This will then be transformed into a goto, and the local handler will
 373       --  be able to handle the assert error (which would not be the case if a
 374       --  call is made to the Raise_Assert_Failure procedure).
 375 
 376       --  We also generate the direct raise if the Suppress_Exception_Locations
 377       --  is active, since we don't want to generate messages in this case.
 378 
 379       --  Note that the reason we do not always generate a direct raise is that
 380       --  the form in which the procedure is called allows for more efficient
 381       --  breakpointing of assertion errors.
 382 
 383       --  Generate the appropriate if statement. Note that we consider this to
 384       --  be an explicit conditional in the source, not an implicit if, so we
 385       --  do not call Make_Implicit_If_Statement.
 386 
 387       --  Case where we generate a direct raise
 388 
 389       if ((Debug_Flag_Dot_G
 390             or else Restriction_Active (No_Exception_Propagation))
 391            and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N)))
 392         or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N)))
 393       then
 394          Rewrite (N,
 395            Make_If_Statement (Loc,
 396              Condition       => Make_Op_Not (Loc, Right_Opnd => Cond),
 397              Then_Statements => New_List (
 398                Make_Raise_Statement (Loc,
 399                  Name => New_Occurrence_Of (RTE (RE_Assert_Failure), Loc)))));
 400 
 401       --  Case where we call the procedure
 402 
 403       else
 404          --  If we have a message given, use it
 405 
 406          if Present (Arg3 (N)) then
 407             Msg := Get_Pragma_Arg (Arg3 (N));
 408 
 409          --  Here we have no string, so prepare one
 410 
 411          else
 412             declare
 413                Loc_Str : constant String := Build_Location_String (Loc);
 414 
 415             begin
 416                Name_Len := 0;
 417 
 418                --  For Assert, we just use the location
 419 
 420                if Nam = Name_Assert then
 421                   null;
 422 
 423                --  For predicate, we generate the string "predicate failed at
 424                --  yyy". We prefer all lower case for predicate.
 425 
 426                elsif Nam = Name_Predicate then
 427                   Add_Str_To_Name_Buffer ("predicate failed at ");
 428 
 429                --  For special case of Precondition/Postcondition the string is
 430                --  "failed xx from yy" where xx is precondition/postcondition
 431                --  in all lower case. The reason for this different wording is
 432                --  that the failure is not at the point of occurrence of the
 433                --  pragma, unlike the other Check cases.
 434 
 435                elsif Nam_In (Nam, Name_Precondition, Name_Postcondition) then
 436                   Get_Name_String (Nam);
 437                   Insert_Str_In_Name_Buffer ("failed ", 1);
 438                   Add_Str_To_Name_Buffer (" from ");
 439 
 440                --  For special case of Invariant, the string is "failed
 441                --  invariant from yy", to be consistent with the string that is
 442                --  generated for the aspect case (the code later on checks for
 443                --  this specific string to modify it in some cases, so this is
 444                --  functionally important).
 445 
 446                elsif Nam = Name_Invariant then
 447                   Add_Str_To_Name_Buffer ("failed invariant from ");
 448 
 449                --  For all other checks, the string is "xxx failed at yyy"
 450                --  where xxx is the check name with current source file casing.
 451 
 452                else
 453                   Get_Name_String (Nam);
 454                   Set_Casing (Identifier_Casing (Current_Source_File));
 455                   Add_Str_To_Name_Buffer (" failed at ");
 456                end if;
 457 
 458                --  In all cases, add location string
 459 
 460                Add_Str_To_Name_Buffer (Loc_Str);
 461 
 462                --  Build the message
 463 
 464                Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
 465             end;
 466          end if;
 467 
 468          --  Now rewrite as an if statement
 469 
 470          Rewrite (N,
 471            Make_If_Statement (Loc,
 472              Condition       => Make_Op_Not (Loc, Right_Opnd => Cond),
 473              Then_Statements => New_List (
 474                Make_Procedure_Call_Statement (Loc,
 475                  Name                   =>
 476                    New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
 477                  Parameter_Associations => New_List (Relocate_Node (Msg))))));
 478       end if;
 479 
 480       Analyze (N);
 481 
 482       --  If new condition is always false, give a warning
 483 
 484       if Warn_On_Assertion_Failure
 485         and then Nkind (N) = N_Procedure_Call_Statement
 486         and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure)
 487       then
 488          --  If original condition was a Standard.False, we assume that this is
 489          --  indeed intended to raise assert error and no warning is required.
 490 
 491          if Is_Entity_Name (Original_Node (Cond))
 492            and then Entity (Original_Node (Cond)) = Standard_False
 493          then
 494             null;
 495 
 496          elsif Nam = Name_Assert then
 497             Error_Msg_N ("?A?assertion will fail at run time", N);
 498          else
 499 
 500             Error_Msg_N ("?A?check will fail at run time", N);
 501          end if;
 502       end if;
 503 
 504       Ghost_Mode := Save_Ghost_Mode;
 505    end Expand_Pragma_Check;
 506 
 507    ---------------------------------
 508    -- Expand_Pragma_Common_Object --
 509    ---------------------------------
 510 
 511    --  Use a machine attribute to replicate semantic effect in DEC Ada
 512 
 513    --    pragma Machine_Attribute (intern_name, "common_object", extern_name);
 514 
 515    --  For now we do nothing with the size attribute ???
 516 
 517    --  Note: Psect_Object shares this processing
 518 
 519    procedure Expand_Pragma_Common_Object (N : Node_Id) is
 520       Loc : constant Source_Ptr := Sloc (N);
 521 
 522       Internal : constant Node_Id := Arg1 (N);
 523       External : constant Node_Id := Arg2 (N);
 524 
 525       Psect : Node_Id;
 526       --  Psect value upper cased as string literal
 527 
 528       Iloc : constant Source_Ptr := Sloc (Internal);
 529       Eloc : constant Source_Ptr := Sloc (External);
 530       Ploc : Source_Ptr;
 531 
 532    begin
 533       --  Acquire Psect value and fold to upper case
 534 
 535       if Present (External) then
 536          if Nkind (External) = N_String_Literal then
 537             String_To_Name_Buffer (Strval (External));
 538          else
 539             Get_Name_String (Chars (External));
 540          end if;
 541 
 542          Set_All_Upper_Case;
 543 
 544          Psect :=
 545            Make_String_Literal (Eloc, Strval => String_From_Name_Buffer);
 546 
 547       else
 548          Get_Name_String (Chars (Internal));
 549          Set_All_Upper_Case;
 550          Psect :=
 551            Make_String_Literal (Iloc, Strval => String_From_Name_Buffer);
 552       end if;
 553 
 554       Ploc := Sloc (Psect);
 555 
 556       --  Insert the pragma
 557 
 558       Insert_After_And_Analyze (N,
 559         Make_Pragma (Loc,
 560           Chars                        => Name_Machine_Attribute,
 561           Pragma_Argument_Associations => New_List (
 562             Make_Pragma_Argument_Association (Iloc,
 563               Expression => New_Copy_Tree (Internal)),
 564             Make_Pragma_Argument_Association (Eloc,
 565               Expression =>
 566                 Make_String_Literal (Sloc => Ploc, Strval => "common_object")),
 567             Make_Pragma_Argument_Association (Ploc,
 568               Expression => New_Copy_Tree (Psect)))));
 569    end Expand_Pragma_Common_Object;
 570 
 571    ----------------------------------
 572    -- Expand_Pragma_Contract_Cases --
 573    ----------------------------------
 574 
 575    --  Pragma Contract_Cases is expanded in the following manner:
 576 
 577    --    subprogram S is
 578    --       Count    : Natural := 0;
 579    --       Flag_1   : Boolean := False;
 580    --       . . .
 581    --       Flag_N   : Boolean := False;
 582    --       Flag_N+1 : Boolean := False;  --  when "others" present
 583    --       Pref_1   : ...;
 584    --       . . .
 585    --       Pref_M   : ...;
 586 
 587    --       <preconditions (if any)>
 588 
 589    --       --  Evaluate all case guards
 590 
 591    --       if Case_Guard_1 then
 592    --          Flag_1 := True;
 593    --          Count  := Count + 1;
 594    --       end if;
 595    --       . . .
 596    --       if Case_Guard_N then
 597    --          Flag_N := True;
 598    --          Count  := Count + 1;
 599    --       end if;
 600 
 601    --       --  Emit errors depending on the number of case guards that
 602    --       --  evaluated to True.
 603 
 604    --       if Count = 0 then
 605    --          raise Assertion_Error with "xxx contract cases incomplete";
 606    --            <or>
 607    --          Flag_N+1 := True;  --  when "others" present
 608 
 609    --       elsif Count > 1 then
 610    --          declare
 611    --             Str0 : constant String :=
 612    --                      "contract cases overlap for subprogram ABC";
 613    --             Str1 : constant String :=
 614    --                      (if Flag_1 then
 615    --                         Str0 & "case guard at xxx evaluates to True"
 616    --                       else Str0);
 617    --             StrN : constant String :=
 618    --                      (if Flag_N then
 619    --                         StrN-1 & "case guard at xxx evaluates to True"
 620    --                       else StrN-1);
 621    --          begin
 622    --             raise Assertion_Error with StrN;
 623    --          end;
 624    --       end if;
 625 
 626    --       --  Evaluate all attribute 'Old prefixes found in the selected
 627    --       --  consequence.
 628 
 629    --       if Flag_1 then
 630    --          Pref_1 := <prefix of 'Old found in Consequence_1>
 631    --       . . .
 632    --       elsif Flag_N then
 633    --          Pref_M := <prefix of 'Old found in Consequence_N>
 634    --       end if;
 635 
 636    --       procedure _Postconditions is
 637    --       begin
 638    --          <postconditions (if any)>
 639 
 640    --          if Flag_1 and then not Consequence_1 then
 641    --             raise Assertion_Error with "failed contract case at xxx";
 642    --          end if;
 643    --          . . .
 644    --          if Flag_N[+1] and then not Consequence_N[+1] then
 645    --             raise Assertion_Error with "failed contract case at xxx";
 646    --          end if;
 647    --       end _Postconditions;
 648    --    begin
 649    --       . . .
 650    --    end S;
 651 
 652    procedure Expand_Pragma_Contract_Cases
 653      (CCs     : Node_Id;
 654       Subp_Id : Entity_Id;
 655       Decls   : List_Id;
 656       Stmts   : in out List_Id)
 657    is
 658       Loc : constant Source_Ptr := Sloc (CCs);
 659 
 660       procedure Case_Guard_Error
 661         (Decls     : List_Id;
 662          Flag      : Entity_Id;
 663          Error_Loc : Source_Ptr;
 664          Msg       : in out Entity_Id);
 665       --  Given a declarative list Decls, status flag Flag, the location of the
 666       --  error and a string Msg, construct the following check:
 667       --    Msg : constant String :=
 668       --            (if Flag then
 669       --                Msg & "case guard at Error_Loc evaluates to True"
 670       --             else Msg);
 671       --  The resulting code is added to Decls
 672 
 673       procedure Consequence_Error
 674         (Checks : in out Node_Id;
 675          Flag   : Entity_Id;
 676          Conseq : Node_Id);
 677       --  Given an if statement Checks, status flag Flag and a consequence
 678       --  Conseq, construct the following check:
 679       --    [els]if Flag and then not Conseq then
 680       --       raise Assertion_Error
 681       --         with "failed contract case at Sloc (Conseq)";
 682       --    [end if;]
 683       --  The resulting code is added to Checks
 684 
 685       function Declaration_Of (Id : Entity_Id) return Node_Id;
 686       --  Given the entity Id of a boolean flag, generate:
 687       --    Id : Boolean := False;
 688 
 689       procedure Expand_Attributes_In_Consequence
 690         (Decls  : List_Id;
 691          Evals  : in out Node_Id;
 692          Flag   : Entity_Id;
 693          Conseq : Node_Id);
 694       --  Perform specialized expansion of all attribute 'Old references found
 695       --  in consequence Conseq such that at runtime only prefixes coming from
 696       --  the selected consequence are evaluated. Similarly expand attribute
 697       --  'Result references by replacing them with identifier _result which
 698       --  resolves to the sole formal parameter of procedure _Postconditions.
 699       --  Any temporaries generated in the process are added to declarations
 700       --  Decls. Evals is a complex if statement tasked with the evaluation of
 701       --  all prefixes coming from a single selected consequence. Flag is the
 702       --  corresponding case guard flag. Conseq is the consequence expression.
 703 
 704       function Increment (Id : Entity_Id) return Node_Id;
 705       --  Given the entity Id of a numerical variable, generate:
 706       --    Id := Id + 1;
 707 
 708       function Set (Id : Entity_Id) return Node_Id;
 709       --  Given the entity Id of a boolean variable, generate:
 710       --    Id := True;
 711 
 712       ----------------------
 713       -- Case_Guard_Error --
 714       ----------------------
 715 
 716       procedure Case_Guard_Error
 717         (Decls     : List_Id;
 718          Flag      : Entity_Id;
 719          Error_Loc : Source_Ptr;
 720          Msg       : in out Entity_Id)
 721       is
 722          New_Line : constant Character := Character'Val (10);
 723          New_Msg  : constant Entity_Id := Make_Temporary (Loc, 'S');
 724 
 725       begin
 726          Start_String;
 727          Store_String_Char  (New_Line);
 728          Store_String_Chars ("  case guard at ");
 729          Store_String_Chars (Build_Location_String (Error_Loc));
 730          Store_String_Chars (" evaluates to True");
 731 
 732          --  Generate:
 733          --    New_Msg : constant String :=
 734          --      (if Flag then
 735          --          Msg & "case guard at Error_Loc evaluates to True"
 736          --       else Msg);
 737 
 738          Append_To (Decls,
 739            Make_Object_Declaration (Loc,
 740              Defining_Identifier => New_Msg,
 741              Constant_Present    => True,
 742              Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
 743              Expression          =>
 744                Make_If_Expression (Loc,
 745                  Expressions => New_List (
 746                    New_Occurrence_Of (Flag, Loc),
 747 
 748                    Make_Op_Concat (Loc,
 749                      Left_Opnd  => New_Occurrence_Of (Msg, Loc),
 750                      Right_Opnd => Make_String_Literal (Loc, End_String)),
 751 
 752                    New_Occurrence_Of (Msg, Loc)))));
 753 
 754          Msg := New_Msg;
 755       end Case_Guard_Error;
 756 
 757       -----------------------
 758       -- Consequence_Error --
 759       -----------------------
 760 
 761       procedure Consequence_Error
 762         (Checks : in out Node_Id;
 763          Flag   : Entity_Id;
 764          Conseq : Node_Id)
 765       is
 766          Cond  : Node_Id;
 767          Error : Node_Id;
 768 
 769       begin
 770          --  Generate:
 771          --    Flag and then not Conseq
 772 
 773          Cond :=
 774            Make_And_Then (Loc,
 775              Left_Opnd  => New_Occurrence_Of (Flag, Loc),
 776              Right_Opnd =>
 777                Make_Op_Not (Loc,
 778                  Right_Opnd => Relocate_Node (Conseq)));
 779 
 780          --  Generate:
 781          --    raise Assertion_Error
 782          --      with "failed contract case at Sloc (Conseq)";
 783 
 784          Start_String;
 785          Store_String_Chars ("failed contract case at ");
 786          Store_String_Chars (Build_Location_String (Sloc (Conseq)));
 787 
 788          Error :=
 789            Make_Procedure_Call_Statement (Loc,
 790              Name                   =>
 791                New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
 792              Parameter_Associations => New_List (
 793                Make_String_Literal (Loc, End_String)));
 794 
 795          if No (Checks) then
 796             Checks :=
 797               Make_Implicit_If_Statement (CCs,
 798                 Condition       => Cond,
 799                 Then_Statements => New_List (Error));
 800 
 801          else
 802             if No (Elsif_Parts (Checks)) then
 803                Set_Elsif_Parts (Checks, New_List);
 804             end if;
 805 
 806             Append_To (Elsif_Parts (Checks),
 807               Make_Elsif_Part (Loc,
 808                 Condition       => Cond,
 809                 Then_Statements => New_List (Error)));
 810          end if;
 811       end Consequence_Error;
 812 
 813       --------------------
 814       -- Declaration_Of --
 815       --------------------
 816 
 817       function Declaration_Of (Id : Entity_Id) return Node_Id is
 818       begin
 819          return
 820            Make_Object_Declaration (Loc,
 821              Defining_Identifier => Id,
 822              Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc),
 823              Expression          => New_Occurrence_Of (Standard_False, Loc));
 824       end Declaration_Of;
 825 
 826       --------------------------------------
 827       -- Expand_Attributes_In_Consequence --
 828       --------------------------------------
 829 
 830       procedure Expand_Attributes_In_Consequence
 831         (Decls  : List_Id;
 832          Evals  : in out Node_Id;
 833          Flag   : Entity_Id;
 834          Conseq : Node_Id)
 835       is
 836          Eval_Stmts : List_Id := No_List;
 837          --  The evaluation sequence expressed as assignment statements of all
 838          --  prefixes of attribute 'Old found in the current consequence.
 839 
 840          function Expand_Attributes (N : Node_Id) return Traverse_Result;
 841          --  Determine whether an arbitrary node denotes attribute 'Old or
 842          --  'Result and if it does, perform all expansion-related actions.
 843 
 844          -----------------------
 845          -- Expand_Attributes --
 846          -----------------------
 847 
 848          function Expand_Attributes (N : Node_Id) return Traverse_Result is
 849             Decl : Node_Id;
 850             Pref : Node_Id;
 851             Temp : Entity_Id;
 852 
 853          begin
 854             --  Attribute 'Old
 855 
 856             if Nkind (N) = N_Attribute_Reference
 857               and then Attribute_Name (N) = Name_Old
 858             then
 859                Pref := Prefix (N);
 860                Temp := Make_Temporary (Loc, 'T', Pref);
 861                Set_Etype (Temp, Etype (Pref));
 862 
 863                --  Generate a temporary to capture the value of the prefix:
 864                --    Temp : <Pref type>;
 865 
 866                Decl :=
 867                  Make_Object_Declaration (Loc,
 868                    Defining_Identifier => Temp,
 869                    Object_Definition   =>
 870                      New_Occurrence_Of (Etype (Pref), Loc));
 871 
 872                --  Place that temporary at the beginning of declarations, to
 873                --  prevent anomalies in the GNATprove flow-analysis pass in
 874                --  the precondition procedure that follows.
 875 
 876                Prepend_To (Decls, Decl);
 877 
 878                --  If the type is unconstrained, the prefix provides its
 879                --  value and constraint, so add it to declaration.
 880 
 881                if not Is_Constrained (Etype (Pref))
 882                  and then Is_Entity_Name (Pref)
 883                then
 884                   Set_Expression (Decl, Pref);
 885                   Analyze (Decl);
 886 
 887                --  Otherwise add an assignment statement to temporary using
 888                --  prefix as RHS.
 889 
 890                else
 891                   Analyze (Decl);
 892 
 893                   if No (Eval_Stmts) then
 894                      Eval_Stmts := New_List;
 895                   end if;
 896 
 897                   Append_To (Eval_Stmts,
 898                     Make_Assignment_Statement (Loc,
 899                       Name       => New_Occurrence_Of (Temp, Loc),
 900                       Expression => Pref));
 901 
 902                end if;
 903 
 904                --  Ensure that the prefix is valid
 905 
 906                if Validity_Checks_On and then Validity_Check_Operands then
 907                   Ensure_Valid (Pref);
 908                end if;
 909 
 910                --  Replace the original attribute 'Old by a reference to the
 911                --  generated temporary.
 912 
 913                Rewrite (N, New_Occurrence_Of (Temp, Loc));
 914 
 915             --  Attribute 'Result
 916 
 917             elsif Is_Attribute_Result (N) then
 918                Rewrite (N, Make_Identifier (Loc, Name_uResult));
 919             end if;
 920 
 921             return OK;
 922          end Expand_Attributes;
 923 
 924          procedure Expand_Attributes_In is
 925            new Traverse_Proc (Expand_Attributes);
 926 
 927       --  Start of processing for Expand_Attributes_In_Consequence
 928 
 929       begin
 930          --  Inspect the consequence and expand any attribute 'Old and 'Result
 931          --  references found within.
 932 
 933          Expand_Attributes_In (Conseq);
 934 
 935          --  The consequence does not contain any attribute 'Old references
 936 
 937          if No (Eval_Stmts) then
 938             return;
 939          end if;
 940 
 941          --  Augment the machinery to trigger the evaluation of all prefixes
 942          --  found in the step above. If Eval is empty, then this is the first
 943          --  consequence to yield expansion of 'Old. Generate:
 944 
 945          --    if Flag then
 946          --       <evaluation statements>
 947          --    end if;
 948 
 949          if No (Evals) then
 950             Evals :=
 951               Make_Implicit_If_Statement (CCs,
 952                 Condition       => New_Occurrence_Of (Flag, Loc),
 953                 Then_Statements => Eval_Stmts);
 954 
 955          --  Otherwise generate:
 956          --    elsif Flag then
 957          --       <evaluation statements>
 958          --    end if;
 959 
 960          else
 961             if No (Elsif_Parts (Evals)) then
 962                Set_Elsif_Parts (Evals, New_List);
 963             end if;
 964 
 965             Append_To (Elsif_Parts (Evals),
 966               Make_Elsif_Part (Loc,
 967                 Condition       => New_Occurrence_Of (Flag, Loc),
 968                 Then_Statements => Eval_Stmts));
 969          end if;
 970       end Expand_Attributes_In_Consequence;
 971 
 972       ---------------
 973       -- Increment --
 974       ---------------
 975 
 976       function Increment (Id : Entity_Id) return Node_Id is
 977       begin
 978          return
 979            Make_Assignment_Statement (Loc,
 980              Name       => New_Occurrence_Of (Id, Loc),
 981              Expression =>
 982                Make_Op_Add (Loc,
 983                  Left_Opnd  => New_Occurrence_Of (Id, Loc),
 984                  Right_Opnd => Make_Integer_Literal (Loc, 1)));
 985       end Increment;
 986 
 987       ---------
 988       -- Set --
 989       ---------
 990 
 991       function Set (Id : Entity_Id) return Node_Id is
 992       begin
 993          return
 994            Make_Assignment_Statement (Loc,
 995              Name       => New_Occurrence_Of (Id, Loc),
 996              Expression => New_Occurrence_Of (Standard_True, Loc));
 997       end Set;
 998 
 999       --  Local variables
1000 
1001       Aggr : constant Node_Id :=
1002                Expression (First (Pragma_Argument_Associations (CCs)));
1003 
1004       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
1005 
1006       Case_Guard    : Node_Id;
1007       CG_Checks     : Node_Id;
1008       CG_Stmts      : List_Id;
1009       Conseq        : Node_Id;
1010       Conseq_Checks : Node_Id   := Empty;
1011       Count         : Entity_Id;
1012       Count_Decl    : Node_Id;
1013       Error_Decls   : List_Id;
1014       Flag          : Entity_Id;
1015       Flag_Decl     : Node_Id;
1016       If_Stmt       : Node_Id;
1017       Msg_Str       : Entity_Id;
1018       Multiple_PCs  : Boolean;
1019       Old_Evals     : Node_Id   := Empty;
1020       Others_Decl   : Node_Id;
1021       Others_Flag   : Entity_Id := Empty;
1022       Post_Case     : Node_Id;
1023 
1024    --  Start of processing for Expand_Pragma_Contract_Cases
1025 
1026    begin
1027       --  Do nothing if pragma is not enabled. If pragma is disabled, it has
1028       --  already been rewritten as a Null statement.
1029 
1030       if Is_Ignored (CCs) then
1031          return;
1032 
1033       --  Guard against malformed contract cases
1034 
1035       elsif Nkind (Aggr) /= N_Aggregate then
1036          return;
1037       end if;
1038 
1039       --  The contract cases is Ghost when it applies to a Ghost entity. Set
1040       --  the mode now to ensure that any nodes generated during expansion are
1041       --  properly flagged as Ghost.
1042 
1043       Set_Ghost_Mode (CCs);
1044 
1045       --  The expansion of contract cases is quite distributed as it produces
1046       --  various statements to evaluate the case guards and consequences. To
1047       --  preserve the original context, set the Is_Assertion_Expr flag. This
1048       --  aids the Ghost legality checks when verifying the placement of a
1049       --  reference to a Ghost entity.
1050 
1051       In_Assertion_Expr := In_Assertion_Expr + 1;
1052 
1053       Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1;
1054 
1055       --  Create the counter which tracks the number of case guards that
1056       --  evaluate to True.
1057 
1058       --    Count : Natural := 0;
1059 
1060       Count := Make_Temporary (Loc, 'C');
1061       Count_Decl :=
1062         Make_Object_Declaration (Loc,
1063           Defining_Identifier => Count,
1064           Object_Definition   => New_Occurrence_Of (Standard_Natural, Loc),
1065           Expression          => Make_Integer_Literal (Loc, 0));
1066 
1067       Prepend_To (Decls, Count_Decl);
1068       Analyze (Count_Decl);
1069 
1070       --  Create the base error message for multiple overlapping case guards
1071 
1072       --    Msg_Str : constant String :=
1073       --                "contract cases overlap for subprogram Subp_Id";
1074 
1075       if Multiple_PCs then
1076          Msg_Str := Make_Temporary (Loc, 'S');
1077 
1078          Start_String;
1079          Store_String_Chars ("contract cases overlap for subprogram ");
1080          Store_String_Chars (Get_Name_String (Chars (Subp_Id)));
1081 
1082          Error_Decls := New_List (
1083            Make_Object_Declaration (Loc,
1084              Defining_Identifier => Msg_Str,
1085              Constant_Present    => True,
1086              Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
1087              Expression          => Make_String_Literal (Loc, End_String)));
1088       end if;
1089 
1090       --  Process individual post cases
1091 
1092       Post_Case := First (Component_Associations (Aggr));
1093       while Present (Post_Case) loop
1094          Case_Guard := First (Choices (Post_Case));
1095          Conseq     := Expression (Post_Case);
1096 
1097          --  The "others" choice requires special processing
1098 
1099          if Nkind (Case_Guard) = N_Others_Choice then
1100             Others_Flag := Make_Temporary (Loc, 'F');
1101             Others_Decl := Declaration_Of (Others_Flag);
1102 
1103             Prepend_To (Decls, Others_Decl);
1104             Analyze (Others_Decl);
1105 
1106             --  Check possible overlap between a case guard and "others"
1107 
1108             if Multiple_PCs and Exception_Extra_Info then
1109                Case_Guard_Error
1110                  (Decls     => Error_Decls,
1111                   Flag      => Others_Flag,
1112                   Error_Loc => Sloc (Case_Guard),
1113                   Msg       => Msg_Str);
1114             end if;
1115 
1116             --  Inspect the consequence and perform special expansion of any
1117             --  attribute 'Old and 'Result references found within.
1118 
1119             Expand_Attributes_In_Consequence
1120               (Decls  => Decls,
1121                Evals  => Old_Evals,
1122                Flag   => Others_Flag,
1123                Conseq => Conseq);
1124 
1125             --  Check the corresponding consequence of "others"
1126 
1127             Consequence_Error
1128               (Checks => Conseq_Checks,
1129                Flag   => Others_Flag,
1130                Conseq => Conseq);
1131 
1132          --  Regular post case
1133 
1134          else
1135             --  Create the flag which tracks the state of its associated case
1136             --  guard.
1137 
1138             Flag := Make_Temporary (Loc, 'F');
1139             Flag_Decl := Declaration_Of (Flag);
1140 
1141             Prepend_To (Decls, Flag_Decl);
1142             Analyze (Flag_Decl);
1143 
1144             --  The flag is set when the case guard is evaluated to True
1145             --    if Case_Guard then
1146             --       Flag  := True;
1147             --       Count := Count + 1;
1148             --    end if;
1149 
1150             If_Stmt :=
1151               Make_Implicit_If_Statement (CCs,
1152                 Condition       => Relocate_Node (Case_Guard),
1153                 Then_Statements => New_List (
1154                   Set (Flag),
1155                   Increment (Count)));
1156 
1157             Append_To (Decls, If_Stmt);
1158             Analyze (If_Stmt);
1159 
1160             --  Check whether this case guard overlaps with another one
1161 
1162             if Multiple_PCs and Exception_Extra_Info then
1163                Case_Guard_Error
1164                  (Decls     => Error_Decls,
1165                   Flag      => Flag,
1166                   Error_Loc => Sloc (Case_Guard),
1167                   Msg       => Msg_Str);
1168             end if;
1169 
1170             --  Inspect the consequence and perform special expansion of any
1171             --  attribute 'Old and 'Result references found within.
1172 
1173             Expand_Attributes_In_Consequence
1174               (Decls  => Decls,
1175                Evals  => Old_Evals,
1176                Flag   => Flag,
1177                Conseq => Conseq);
1178 
1179             --  The corresponding consequence of the case guard which evaluated
1180             --  to True must hold on exit from the subprogram.
1181 
1182             Consequence_Error
1183               (Checks => Conseq_Checks,
1184                Flag   => Flag,
1185                Conseq => Conseq);
1186          end if;
1187 
1188          Next (Post_Case);
1189       end loop;
1190 
1191       --  Raise Assertion_Error when none of the case guards evaluate to True.
1192       --  The only exception is when we have "others", in which case there is
1193       --  no error because "others" acts as a default True.
1194 
1195       --  Generate:
1196       --    Flag := True;
1197 
1198       if Present (Others_Flag) then
1199          CG_Stmts := New_List (Set (Others_Flag));
1200 
1201       --  Generate:
1202       --    raise Assertion_Error with "xxx contract cases incomplete";
1203 
1204       else
1205          Start_String;
1206          Store_String_Chars (Build_Location_String (Loc));
1207          Store_String_Chars (" contract cases incomplete");
1208 
1209          CG_Stmts := New_List (
1210            Make_Procedure_Call_Statement (Loc,
1211              Name                   =>
1212                New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
1213              Parameter_Associations => New_List (
1214                Make_String_Literal (Loc, End_String))));
1215       end if;
1216 
1217       CG_Checks :=
1218         Make_Implicit_If_Statement (CCs,
1219           Condition       =>
1220             Make_Op_Eq (Loc,
1221               Left_Opnd  => New_Occurrence_Of (Count, Loc),
1222               Right_Opnd => Make_Integer_Literal (Loc, 0)),
1223           Then_Statements => CG_Stmts);
1224 
1225       --  Detect a possible failure due to several case guards evaluating to
1226       --  True.
1227 
1228       --  Generate:
1229       --    elsif Count > 0 then
1230       --       declare
1231       --          <Error_Decls>
1232       --       begin
1233       --          raise Assertion_Error with <Msg_Str>;
1234       --    end if;
1235 
1236       if Multiple_PCs then
1237          Set_Elsif_Parts (CG_Checks, New_List (
1238            Make_Elsif_Part (Loc,
1239              Condition       =>
1240                Make_Op_Gt (Loc,
1241                  Left_Opnd  => New_Occurrence_Of (Count, Loc),
1242                  Right_Opnd => Make_Integer_Literal (Loc, 1)),
1243 
1244              Then_Statements => New_List (
1245                Make_Block_Statement (Loc,
1246                  Declarations               => Error_Decls,
1247                  Handled_Statement_Sequence =>
1248                    Make_Handled_Sequence_Of_Statements (Loc,
1249                      Statements => New_List (
1250                        Make_Procedure_Call_Statement (Loc,
1251                          Name                   =>
1252                            New_Occurrence_Of
1253                              (RTE (RE_Raise_Assert_Failure), Loc),
1254                          Parameter_Associations => New_List (
1255                            New_Occurrence_Of (Msg_Str, Loc))))))))));
1256       end if;
1257 
1258       Append_To (Decls, CG_Checks);
1259       Analyze (CG_Checks);
1260 
1261       --  Once all case guards are evaluated and checked, evaluate any prefixes
1262       --  of attribute 'Old founds in the selected consequence.
1263 
1264       if Present (Old_Evals) then
1265          Append_To (Decls, Old_Evals);
1266          Analyze (Old_Evals);
1267       end if;
1268 
1269       --  Raise Assertion_Error when the corresponding consequence of a case
1270       --  guard that evaluated to True fails.
1271 
1272       if No (Stmts) then
1273          Stmts := New_List;
1274       end if;
1275 
1276       Append_To (Stmts, Conseq_Checks);
1277 
1278       In_Assertion_Expr := In_Assertion_Expr - 1;
1279       Ghost_Mode := Save_Ghost_Mode;
1280    end Expand_Pragma_Contract_Cases;
1281 
1282    ---------------------------------------
1283    -- Expand_Pragma_Import_Or_Interface --
1284    ---------------------------------------
1285 
1286    procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is
1287       Def_Id : Entity_Id;
1288 
1289    begin
1290       --  In Relaxed_RM_Semantics, support old Ada 83 style:
1291       --  pragma Import (Entity, "external name");
1292 
1293       if Relaxed_RM_Semantics
1294         and then List_Length (Pragma_Argument_Associations (N)) = 2
1295         and then Chars (Pragma_Identifier (N)) = Name_Import
1296         and then Nkind (Arg2 (N)) = N_String_Literal
1297       then
1298          Def_Id := Entity (Arg1 (N));
1299       else
1300          Def_Id := Entity (Arg2 (N));
1301       end if;
1302 
1303       --  Variable case (we have to undo any initialization already done)
1304 
1305       if Ekind (Def_Id) = E_Variable then
1306          Undo_Initialization (Def_Id, N);
1307 
1308       --  Case of exception with convention C++
1309 
1310       elsif Ekind (Def_Id) = E_Exception
1311         and then Convention (Def_Id) = Convention_CPP
1312       then
1313          --  Import a C++ convention
1314 
1315          declare
1316             Loc          : constant Source_Ptr := Sloc (N);
1317             Rtti_Name    : constant Node_Id    := Arg3 (N);
1318             Dum          : constant Entity_Id  := Make_Temporary (Loc, 'D');
1319             Exdata       : List_Id;
1320             Lang_Char    : Node_Id;
1321             Foreign_Data : Node_Id;
1322 
1323          begin
1324             Exdata := Component_Associations (Expression (Parent (Def_Id)));
1325 
1326             Lang_Char := Next (First (Exdata));
1327 
1328             --  Change the one-character language designator to 'C'
1329 
1330             Rewrite (Expression (Lang_Char),
1331               Make_Character_Literal (Loc,
1332                 Chars              => Name_uC,
1333                 Char_Literal_Value => UI_From_Int (Character'Pos ('C'))));
1334             Analyze (Expression (Lang_Char));
1335 
1336             --  Change the value of Foreign_Data
1337 
1338             Foreign_Data := Next (Next (Next (Next (Lang_Char))));
1339 
1340             Insert_Actions (Def_Id, New_List (
1341               Make_Object_Declaration (Loc,
1342                 Defining_Identifier => Dum,
1343                 Object_Definition   =>
1344                   New_Occurrence_Of (Standard_Character, Loc)),
1345 
1346               Make_Pragma (Loc,
1347                 Chars                        => Name_Import,
1348                 Pragma_Argument_Associations => New_List (
1349                   Make_Pragma_Argument_Association (Loc,
1350                     Expression => Make_Identifier (Loc, Name_Ada)),
1351 
1352                   Make_Pragma_Argument_Association (Loc,
1353                     Expression => Make_Identifier (Loc, Chars (Dum))),
1354 
1355                   Make_Pragma_Argument_Association (Loc,
1356                     Chars      => Name_External_Name,
1357                     Expression => Relocate_Node (Rtti_Name))))));
1358 
1359             Rewrite (Expression (Foreign_Data),
1360               Unchecked_Convert_To (Standard_A_Char,
1361                 Make_Attribute_Reference (Loc,
1362                   Prefix         => Make_Identifier (Loc, Chars (Dum)),
1363                   Attribute_Name => Name_Address)));
1364             Analyze (Expression (Foreign_Data));
1365          end;
1366 
1367       --  No special expansion required for any other case
1368 
1369       else
1370          null;
1371       end if;
1372    end Expand_Pragma_Import_Or_Interface;
1373 
1374    -------------------------------------
1375    -- Expand_Pragma_Initial_Condition --
1376    -------------------------------------
1377 
1378    procedure Expand_Pragma_Initial_Condition (Spec_Or_Body : Node_Id) is
1379       Loc       : constant Source_Ptr := Sloc (Spec_Or_Body);
1380       Check     : Node_Id;
1381       Expr      : Node_Id;
1382       Init_Cond : Node_Id;
1383       List      : List_Id;
1384       Pack_Id   : Entity_Id;
1385 
1386       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
1387 
1388    begin
1389       if Nkind (Spec_Or_Body) = N_Package_Body then
1390          Pack_Id := Corresponding_Spec (Spec_Or_Body);
1391 
1392          if Present (Handled_Statement_Sequence (Spec_Or_Body)) then
1393             List := Statements (Handled_Statement_Sequence (Spec_Or_Body));
1394 
1395          --  The package body lacks statements, create an empty list
1396 
1397          else
1398             List := New_List;
1399 
1400             Set_Handled_Statement_Sequence (Spec_Or_Body,
1401               Make_Handled_Sequence_Of_Statements (Loc, Statements => List));
1402          end if;
1403 
1404       elsif Nkind (Spec_Or_Body) = N_Package_Declaration then
1405          Pack_Id := Defining_Entity (Spec_Or_Body);
1406 
1407          if Present (Visible_Declarations (Specification (Spec_Or_Body))) then
1408             List := Visible_Declarations (Specification (Spec_Or_Body));
1409 
1410          --  The package lacks visible declarations, create an empty list
1411 
1412          else
1413             List := New_List;
1414 
1415             Set_Visible_Declarations (Specification (Spec_Or_Body), List);
1416          end if;
1417 
1418       --  This routine should not be used on anything other than packages
1419 
1420       else
1421          raise Program_Error;
1422       end if;
1423 
1424       Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition);
1425 
1426       --  The initial condition is Ghost when it applies to a Ghost entity. Set
1427       --  the mode now to ensure that any nodes generated during expansion are
1428       --  properly flagged as Ghost.
1429 
1430       Set_Ghost_Mode (Init_Cond);
1431 
1432       --  The caller should check whether the package is subject to pragma
1433       --  Initial_Condition.
1434 
1435       pragma Assert (Present (Init_Cond));
1436 
1437       Expr :=
1438         Get_Pragma_Arg (First (Pragma_Argument_Associations (Init_Cond)));
1439 
1440       --  The assertion expression was found to be illegal, do not generate the
1441       --  runtime check as it will repeat the illegality.
1442 
1443       if Error_Posted (Init_Cond) or else Error_Posted (Expr) then
1444          Ghost_Mode := Save_Ghost_Mode;
1445          return;
1446       end if;
1447 
1448       --  Generate:
1449       --    pragma Check (Initial_Condition, <Expr>);
1450 
1451       Check :=
1452         Make_Pragma (Loc,
1453           Chars                        => Name_Check,
1454           Pragma_Argument_Associations => New_List (
1455             Make_Pragma_Argument_Association (Loc,
1456               Expression => Make_Identifier (Loc, Name_Initial_Condition)),
1457             Make_Pragma_Argument_Association (Loc,
1458               Expression => New_Copy_Tree (Expr))));
1459 
1460       Append_To (List, Check);
1461       Analyze (Check);
1462 
1463       Ghost_Mode := Save_Ghost_Mode;
1464    end Expand_Pragma_Initial_Condition;
1465 
1466    ------------------------------------
1467    -- Expand_Pragma_Inspection_Point --
1468    ------------------------------------
1469 
1470    --  If no argument is given, then we supply a default argument list that
1471    --  includes all objects declared at the source level in all subprograms
1472    --  that enclose the inspection point pragma.
1473 
1474    procedure Expand_Pragma_Inspection_Point (N : Node_Id) is
1475       Loc : constant Source_Ptr := Sloc (N);
1476       A     : List_Id;
1477       Assoc : Node_Id;
1478       S     : Entity_Id;
1479       E     : Entity_Id;
1480 
1481    begin
1482       if No (Pragma_Argument_Associations (N)) then
1483          A := New_List;
1484          S := Current_Scope;
1485 
1486          while S /= Standard_Standard loop
1487             E := First_Entity (S);
1488             while Present (E) loop
1489                if Comes_From_Source (E)
1490                  and then Is_Object (E)
1491                  and then not Is_Entry_Formal (E)
1492                  and then Ekind (E) /= E_Component
1493                  and then Ekind (E) /= E_Discriminant
1494                  and then Ekind (E) /= E_Generic_In_Parameter
1495                  and then Ekind (E) /= E_Generic_In_Out_Parameter
1496                then
1497                   Append_To (A,
1498                     Make_Pragma_Argument_Association (Loc,
1499                       Expression => New_Occurrence_Of (E, Loc)));
1500                end if;
1501 
1502                Next_Entity (E);
1503             end loop;
1504 
1505             S := Scope (S);
1506          end loop;
1507 
1508          Set_Pragma_Argument_Associations (N, A);
1509       end if;
1510 
1511       --  Expand the arguments of the pragma. Expanding an entity reference
1512       --  is a noop, except in a protected operation, where a reference may
1513       --  have to be transformed into a reference to the corresponding prival.
1514       --  Are there other pragmas that may require this ???
1515 
1516       Assoc := First (Pragma_Argument_Associations (N));
1517       while Present (Assoc) loop
1518          Expand (Expression (Assoc));
1519          Next (Assoc);
1520       end loop;
1521    end Expand_Pragma_Inspection_Point;
1522 
1523    --------------------------------------
1524    -- Expand_Pragma_Interrupt_Priority --
1525    --------------------------------------
1526 
1527    --  Supply default argument if none exists (System.Interrupt_Priority'Last)
1528 
1529    procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is
1530       Loc : constant Source_Ptr := Sloc (N);
1531    begin
1532       if No (Pragma_Argument_Associations (N)) then
1533          Set_Pragma_Argument_Associations (N, New_List (
1534            Make_Pragma_Argument_Association (Loc,
1535              Expression =>
1536                Make_Attribute_Reference (Loc,
1537                  Prefix         =>
1538                    New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc),
1539                  Attribute_Name => Name_Last))));
1540       end if;
1541    end Expand_Pragma_Interrupt_Priority;
1542 
1543    --------------------------------
1544    -- Expand_Pragma_Loop_Variant --
1545    --------------------------------
1546 
1547    --  Pragma Loop_Variant is expanded in the following manner:
1548 
1549    --  Original code
1550 
1551    --     for | while ... loop
1552    --        <preceding source statements>
1553    --        pragma Loop_Variant
1554    --                 (Increases => Incr_Expr,
1555    --                  Decreases => Decr_Expr);
1556    --        <succeeding source statements>
1557    --     end loop;
1558 
1559    --  Expanded code
1560 
1561    --     Curr_1 : <type of Incr_Expr>;
1562    --     Curr_2 : <type of Decr_Expr>;
1563    --     Old_1  : <type of Incr_Expr>;
1564    --     Old_2  : <type of Decr_Expr>;
1565    --     Flag   : Boolean := False;
1566 
1567    --     for | while ... loop
1568    --        <preceding source statements>
1569 
1570    --        if Flag then
1571    --           Old_1 := Curr_1;
1572    --           Old_2 := Curr_2;
1573    --        end if;
1574 
1575    --        Curr_1 := <Incr_Expr>;
1576    --        Curr_2 := <Decr_Expr>;
1577 
1578    --        if Flag then
1579    --           if Curr_1 /= Old_1 then
1580    --              pragma Check (Loop_Variant, Curr_1 > Old_1);
1581    --           else
1582    --              pragma Check (Loop_Variant, Curr_2 < Old_2);
1583    --           end if;
1584    --        else
1585    --           Flag := True;
1586    --        end if;
1587 
1588    --        <succeeding source statements>
1589    --     end loop;
1590 
1591    procedure Expand_Pragma_Loop_Variant (N : Node_Id) is
1592       Loc      : constant Source_Ptr := Sloc (N);
1593       Last_Var : constant Node_Id    :=
1594                    Last (Pragma_Argument_Associations (N));
1595 
1596       Curr_Assign : List_Id   := No_List;
1597       Flag_Id     : Entity_Id := Empty;
1598       If_Stmt     : Node_Id   := Empty;
1599       Old_Assign  : List_Id   := No_List;
1600       Loop_Scop   : Entity_Id;
1601       Loop_Stmt   : Node_Id;
1602       Variant     : Node_Id;
1603 
1604       procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean);
1605       --  Process a single increasing / decreasing termination variant. Flag
1606       --  Is_Last should be set when processing the last variant.
1607 
1608       ---------------------
1609       -- Process_Variant --
1610       ---------------------
1611 
1612       procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean) is
1613          function Make_Op
1614            (Loc      : Source_Ptr;
1615             Curr_Val : Node_Id;
1616             Old_Val  : Node_Id) return Node_Id;
1617          --  Generate a comparison between Curr_Val and Old_Val depending on
1618          --  the change mode (Increases / Decreases) of the variant.
1619 
1620          -------------
1621          -- Make_Op --
1622          -------------
1623 
1624          function Make_Op
1625            (Loc      : Source_Ptr;
1626             Curr_Val : Node_Id;
1627             Old_Val  : Node_Id) return Node_Id
1628          is
1629          begin
1630             if Chars (Variant) = Name_Increases then
1631                return Make_Op_Gt (Loc, Curr_Val, Old_Val);
1632             else pragma Assert (Chars (Variant) = Name_Decreases);
1633                return Make_Op_Lt (Loc, Curr_Val, Old_Val);
1634             end if;
1635          end Make_Op;
1636 
1637          --  Local variables
1638 
1639          Expr     : constant Node_Id := Expression (Variant);
1640          Expr_Typ : constant Entity_Id := Etype (Expr);
1641          Loc      : constant Source_Ptr := Sloc (Expr);
1642          Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt);
1643          Curr_Id  : Entity_Id;
1644          Old_Id   : Entity_Id;
1645          Prag     : Node_Id;
1646 
1647       --  Start of processing for Process_Variant
1648 
1649       begin
1650          --  All temporaries generated in this routine must be inserted before
1651          --  the related loop statement. Ensure that the proper scope is on the
1652          --  stack when analyzing the temporaries. Note that we also use the
1653          --  Sloc of the related loop.
1654 
1655          Push_Scope (Scope (Loop_Scop));
1656 
1657          --  Step 1: Create the declaration of the flag which controls the
1658          --  behavior of the assertion on the first iteration of the loop.
1659 
1660          if No (Flag_Id) then
1661 
1662             --  Generate:
1663             --    Flag : Boolean := False;
1664 
1665             Flag_Id := Make_Temporary (Loop_Loc, 'F');
1666 
1667             Insert_Action (Loop_Stmt,
1668               Make_Object_Declaration (Loop_Loc,
1669                 Defining_Identifier => Flag_Id,
1670                 Object_Definition   =>
1671                   New_Occurrence_Of (Standard_Boolean, Loop_Loc),
1672                 Expression          =>
1673                   New_Occurrence_Of (Standard_False, Loop_Loc)));
1674 
1675             --  Prevent an unwanted optimization where the Current_Value of
1676             --  the flag eliminates the if statement which stores the variant
1677             --  values coming from the previous iteration.
1678 
1679             --     Flag : Boolean := False;
1680             --     loop
1681             --        if Flag then         --  condition rewritten to False
1682             --           Old_N := Curr_N;  --  and if statement eliminated
1683             --        end if;
1684             --        . . .
1685             --        Flag := True;
1686             --     end loop;
1687 
1688             Set_Current_Value (Flag_Id, Empty);
1689          end if;
1690 
1691          --  Step 2: Create the temporaries which store the old and current
1692          --  values of the associated expression.
1693 
1694          --  Generate:
1695          --    Curr : <type of Expr>;
1696 
1697          Curr_Id := Make_Temporary (Loc, 'C');
1698 
1699          Insert_Action (Loop_Stmt,
1700            Make_Object_Declaration (Loop_Loc,
1701              Defining_Identifier => Curr_Id,
1702              Object_Definition   => New_Occurrence_Of (Expr_Typ, Loop_Loc)));
1703 
1704          --  Generate:
1705          --    Old : <type of Expr>;
1706 
1707          Old_Id := Make_Temporary (Loc, 'P');
1708 
1709          Insert_Action (Loop_Stmt,
1710            Make_Object_Declaration (Loop_Loc,
1711              Defining_Identifier => Old_Id,
1712              Object_Definition   => New_Occurrence_Of (Expr_Typ, Loop_Loc)));
1713 
1714          --  Restore original scope after all temporaries have been analyzed
1715 
1716          Pop_Scope;
1717 
1718          --  Step 3: Store value of the expression from the previous iteration
1719 
1720          if No (Old_Assign) then
1721             Old_Assign := New_List;
1722          end if;
1723 
1724          --  Generate:
1725          --    Old := Curr;
1726 
1727          Append_To (Old_Assign,
1728            Make_Assignment_Statement (Loc,
1729              Name       => New_Occurrence_Of (Old_Id, Loc),
1730              Expression => New_Occurrence_Of (Curr_Id, Loc)));
1731 
1732          --  Step 4: Store the current value of the expression
1733 
1734          if No (Curr_Assign) then
1735             Curr_Assign := New_List;
1736          end if;
1737 
1738          --  Generate:
1739          --    Curr := <Expr>;
1740 
1741          Append_To (Curr_Assign,
1742            Make_Assignment_Statement (Loc,
1743              Name       => New_Occurrence_Of (Curr_Id, Loc),
1744              Expression => Relocate_Node (Expr)));
1745 
1746          --  Step 5: Create corresponding assertion to verify change of value
1747 
1748          --  Generate:
1749          --    pragma Check (Loop_Variant, Curr <|> Old);
1750 
1751          Prag :=
1752            Make_Pragma (Loc,
1753              Chars                        => Name_Check,
1754              Pragma_Argument_Associations => New_List (
1755                Make_Pragma_Argument_Association (Loc,
1756                  Expression => Make_Identifier (Loc, Name_Loop_Variant)),
1757                Make_Pragma_Argument_Association (Loc,
1758                  Expression =>
1759                    Make_Op (Loc,
1760                      Curr_Val => New_Occurrence_Of (Curr_Id, Loc),
1761                      Old_Val  => New_Occurrence_Of (Old_Id, Loc)))));
1762 
1763          --  Generate:
1764          --    if Curr /= Old then
1765          --       <Prag>;
1766 
1767          if No (If_Stmt) then
1768 
1769             --  When there is just one termination variant, do not compare the
1770             --  old and current value for equality, just check the pragma.
1771 
1772             if Is_Last then
1773                If_Stmt := Prag;
1774             else
1775                If_Stmt :=
1776                  Make_If_Statement (Loc,
1777                    Condition       =>
1778                      Make_Op_Ne (Loc,
1779                        Left_Opnd  => New_Occurrence_Of (Curr_Id, Loc),
1780                        Right_Opnd => New_Occurrence_Of (Old_Id, Loc)),
1781                    Then_Statements => New_List (Prag));
1782             end if;
1783 
1784          --  Generate:
1785          --    else
1786          --       <Prag>;
1787          --    end if;
1788 
1789          elsif Is_Last then
1790             Set_Else_Statements (If_Stmt, New_List (Prag));
1791 
1792          --  Generate:
1793          --    elsif Curr /= Old then
1794          --       <Prag>;
1795 
1796          else
1797             if Elsif_Parts (If_Stmt) = No_List then
1798                Set_Elsif_Parts (If_Stmt, New_List);
1799             end if;
1800 
1801             Append_To (Elsif_Parts (If_Stmt),
1802               Make_Elsif_Part (Loc,
1803                 Condition       =>
1804                   Make_Op_Ne (Loc,
1805                     Left_Opnd  => New_Occurrence_Of (Curr_Id, Loc),
1806                     Right_Opnd => New_Occurrence_Of (Old_Id, Loc)),
1807                 Then_Statements => New_List (Prag)));
1808          end if;
1809       end Process_Variant;
1810 
1811       --  Local variables
1812 
1813       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
1814 
1815    --  Start of processing for Expand_Pragma_Loop_Variant
1816 
1817    begin
1818       --  If pragma is not enabled, rewrite as Null statement. If pragma is
1819       --  disabled, it has already been rewritten as a Null statement.
1820 
1821       if Is_Ignored (N) then
1822          Rewrite (N, Make_Null_Statement (Loc));
1823          Analyze (N);
1824          return;
1825       end if;
1826 
1827       --  The loop variant is Ghost when it applies to a Ghost entity. Set
1828       --  the mode now to ensure that any nodes generated during expansion
1829       --  are properly flagged as Ghost.
1830 
1831       Set_Ghost_Mode (N);
1832 
1833       --  The expansion of Loop_Variant is quite distributed as it produces
1834       --  various statements to capture and compare the arguments. To preserve
1835       --  the original context, set the Is_Assertion_Expr flag. This aids the
1836       --  Ghost legality checks when verifying the placement of a reference to
1837       --  a Ghost entity.
1838 
1839       In_Assertion_Expr := In_Assertion_Expr + 1;
1840 
1841       --  Locate the enclosing loop for which this assertion applies. In the
1842       --  case of Ada 2012 array iteration, we might be dealing with nested
1843       --  loops. Only the outermost loop has an identifier.
1844 
1845       Loop_Stmt := N;
1846       while Present (Loop_Stmt) loop
1847          if Nkind (Loop_Stmt) = N_Loop_Statement
1848            and then Present (Identifier (Loop_Stmt))
1849          then
1850             exit;
1851          end if;
1852 
1853          Loop_Stmt := Parent (Loop_Stmt);
1854       end loop;
1855 
1856       Loop_Scop := Entity (Identifier (Loop_Stmt));
1857 
1858       --  Create the circuitry which verifies individual variants
1859 
1860       Variant := First (Pragma_Argument_Associations (N));
1861       while Present (Variant) loop
1862          Process_Variant (Variant, Is_Last => Variant = Last_Var);
1863          Next (Variant);
1864       end loop;
1865 
1866       --  Construct the segment which stores the old values of all expressions.
1867       --  Generate:
1868       --    if Flag then
1869       --       <Old_Assign>
1870       --    end if;
1871 
1872       Insert_Action (N,
1873         Make_If_Statement (Loc,
1874           Condition       => New_Occurrence_Of (Flag_Id, Loc),
1875           Then_Statements => Old_Assign));
1876 
1877       --  Update the values of all expressions
1878 
1879       Insert_Actions (N, Curr_Assign);
1880 
1881       --  Add the assertion circuitry to test all changes in expressions.
1882       --  Generate:
1883       --    if Flag then
1884       --       <If_Stmt>
1885       --    else
1886       --       Flag := True;
1887       --    end if;
1888 
1889       Insert_Action (N,
1890         Make_If_Statement (Loc,
1891           Condition       => New_Occurrence_Of (Flag_Id, Loc),
1892           Then_Statements => New_List (If_Stmt),
1893           Else_Statements => New_List (
1894             Make_Assignment_Statement (Loc,
1895               Name       => New_Occurrence_Of (Flag_Id, Loc),
1896               Expression => New_Occurrence_Of (Standard_True, Loc)))));
1897 
1898       --  Note: the pragma has been completely transformed into a sequence of
1899       --  corresponding declarations and statements. We leave it in the tree
1900       --  for documentation purposes. It will be ignored by the backend.
1901 
1902       In_Assertion_Expr := In_Assertion_Expr - 1;
1903       Ghost_Mode := Save_Ghost_Mode;
1904    end Expand_Pragma_Loop_Variant;
1905 
1906    --------------------------------
1907    -- Expand_Pragma_Psect_Object --
1908    --------------------------------
1909 
1910    --  Convert to Common_Object, and expand the resulting pragma
1911 
1912    procedure Expand_Pragma_Psect_Object (N : Node_Id)
1913      renames Expand_Pragma_Common_Object;
1914 
1915    -------------------------------------
1916    -- Expand_Pragma_Relative_Deadline --
1917    -------------------------------------
1918 
1919    procedure Expand_Pragma_Relative_Deadline (N : Node_Id) is
1920       P    : constant Node_Id    := Parent (N);
1921       Loc  : constant Source_Ptr := Sloc (N);
1922 
1923    begin
1924       --  Expand the pragma only in the case of the main subprogram. For tasks
1925       --  the expansion is done in exp_ch9. Generate a call to Set_Deadline
1926       --  at Clock plus the relative deadline specified in the pragma. Time
1927       --  values are translated into Duration to allow for non-private
1928       --  addition operation.
1929 
1930       if Nkind (P) = N_Subprogram_Body then
1931          Rewrite
1932            (N,
1933             Make_Procedure_Call_Statement (Loc,
1934               Name => New_Occurrence_Of (RTE (RE_Set_Deadline), Loc),
1935               Parameter_Associations => New_List (
1936                 Unchecked_Convert_To (RTE (RO_RT_Time),
1937                   Make_Op_Add (Loc,
1938                     Left_Opnd  =>
1939                       Make_Function_Call (Loc,
1940                         New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc),
1941                         New_List
1942                           (Make_Function_Call
1943                              (Loc, New_Occurrence_Of (RTE (RE_Clock), Loc)))),
1944                     Right_Opnd  =>
1945                       Unchecked_Convert_To (Standard_Duration, Arg1 (N)))))));
1946 
1947          Analyze (N);
1948       end if;
1949    end Expand_Pragma_Relative_Deadline;
1950 
1951    -------------------------------------------
1952    -- Expand_Pragma_Suppress_Initialization --
1953    -------------------------------------------
1954 
1955    procedure Expand_Pragma_Suppress_Initialization (N : Node_Id) is
1956       Def_Id : constant Entity_Id  := Entity (Arg1 (N));
1957 
1958    begin
1959       --  Variable case (we have to undo any initialization already done)
1960 
1961       if Ekind (Def_Id) = E_Variable then
1962          Undo_Initialization (Def_Id, N);
1963       end if;
1964    end Expand_Pragma_Suppress_Initialization;
1965 
1966    -------------------------
1967    -- Undo_Initialization --
1968    -------------------------
1969 
1970    procedure Undo_Initialization (Def_Id : Entity_Id; N : Node_Id) is
1971       Init_Call : Node_Id;
1972 
1973    begin
1974       --  When applied to a variable, the default initialization must not be
1975       --  done. As it is already done when the pragma is found, we just get rid
1976       --  of the call the initialization procedure which followed the object
1977       --  declaration. The call is inserted after the declaration, but validity
1978       --  checks may also have been inserted and thus the initialization call
1979       --  does not necessarily appear immediately after the object declaration.
1980 
1981       --  We can't use the freezing mechanism for this purpose, since we have
1982       --  to elaborate the initialization expression when it is first seen (so
1983       --  this elaboration cannot be deferred to the freeze point).
1984 
1985       --  Find and remove generated initialization call for object, if any
1986 
1987       Init_Call := Remove_Init_Call (Def_Id, Rep_Clause => N);
1988 
1989       --  Any default initialization expression should be removed (e.g.
1990       --  null defaults for access objects, zero initialization of packed
1991       --  bit arrays). Imported objects aren't allowed to have explicit
1992       --  initialization, so the expression must have been generated by
1993       --  the compiler.
1994 
1995       if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then
1996          Set_Expression (Parent (Def_Id), Empty);
1997       end if;
1998 
1999       --  The object may not have any initialization, but in the presence of
2000       --  Initialize_Scalars code is inserted after then declaration, which
2001       --  must now be removed as well. The code carries the same source
2002       --  location as the declaration itself.
2003 
2004       if Initialize_Scalars and then Is_Array_Type (Etype (Def_Id)) then
2005          declare
2006             Init : Node_Id;
2007             Nxt  : Node_Id;
2008          begin
2009             Init := Next (Parent (Def_Id));
2010             while not Comes_From_Source (Init)
2011               and then Sloc (Init) = Sloc (Def_Id)
2012             loop
2013                Nxt := Next (Init);
2014                Remove (Init);
2015                Init := Nxt;
2016             end loop;
2017          end;
2018       end if;
2019    end Undo_Initialization;
2020 
2021 end Exp_Prag;