gcc/ada/exp_ch7.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              E X P _ C H 7                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision$
  10 --                                                                          --
  11 --          Copyright (C) 1992-2002, Free Software Foundation, Inc.         --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 --  This package contains virtually all expansion mechanisms related to
  30 --    - controlled types
  31 --    - transient scopes
  32
  33 with Atree;    use Atree;
  34 with Debug;    use Debug;
  35 with Einfo;    use Einfo;
  36 with Exp_Ch9;  use Exp_Ch9;
  37 with Exp_Ch11; use Exp_Ch11;
  38 with Exp_Dbug; use Exp_Dbug;
  39 with Exp_Tss;  use Exp_Tss;
  40 with Exp_Util; use Exp_Util;
  41 with Freeze;   use Freeze;
  42 with Hostparm; use Hostparm;
  43 with Lib;      use Lib;
  44 with Lib.Xref; use Lib.Xref;
  45 with Nlists;   use Nlists;
  46 with Nmake;    use Nmake;
  47 with Opt;      use Opt;
  48 with Output;   use Output;
  49 with Restrict; use Restrict;
  50 with Rtsfind;  use Rtsfind;
  51 with Targparm; use Targparm;
  52 with Sinfo;    use Sinfo;
  53 with Sem;      use Sem;
  54 with Sem_Ch3;  use Sem_Ch3;
  55 with Sem_Ch7;  use Sem_Ch7;
  56 with Sem_Ch8;  use Sem_Ch8;
  57 with Sem_Res;  use Sem_Res;
  58 with Sem_Type; use Sem_Type;
  59 with Sem_Util; use Sem_Util;
  60 with Snames;   use Snames;
  61 with Stand;    use Stand;
  62 with Tbuild;   use Tbuild;
  63 with Uintp;    use Uintp;
  64
  65 package body Exp_Ch7 is
  66
  67    --------------------------------
  68    -- Transient Scope Management --
  69    --------------------------------
  70
  71    --  A transient scope is created when temporary objects are created by the
  72    --  compiler. These temporary objects are allocated on the secondary stack
  73    --  and the transient scope is responsible for finalizing the object when
  74    --  appropriate and reclaiming the memory at the right time. The temporary
  75    --  objects are generally the objects allocated to store the result of a
  76    --  function returning an unconstrained or a tagged value. Expressions
  77    --  needing to be wrapped in a transient scope (functions calls returning
  78    --  unconstrained or tagged values) may appear in 3 different contexts which
  79    --  lead to 3 different kinds of transient scope expansion:
  80
  81    --   1. In a simple statement (procedure call, assignment, ...). In
  82    --      this case the instruction is wrapped into a transient block.
  83    --      (See Wrap_Transient_Statement for details)
  84
  85    --   2. In an expression of a control structure (test in a IF statement,
  86    --      expression in a CASE statement, ...).
  87    --      (See Wrap_Transient_Expression for details)
  88
  89    --   3. In a expression of an object_declaration. No wrapping is possible
  90    --      here, so the finalization actions, if any are done right after the
  91    --      declaration and the secondary stack deallocation is done in the
  92    --      proper enclosing scope (see Wrap_Transient_Declaration for details)
  93
  94    --  Note about function returning tagged types: It has been decided to
  95    --  always allocate their result in the secondary stack while it is not
  96    --  absolutely mandatory when the tagged type is constrained because the
  97    --  caller knows the size of the returned object and thus could allocate the
  98    --  result in the primary stack. But, allocating them always in the
  99    --  secondary stack simplifies many implementation hassles:
 100
 101    --    - If it is dispatching function call, the computation of the size of
 102    --      the result is possible but complex from the outside.
 103
 104    --    - If the returned type is controlled, the assignment of the returned
 105    --      value to the anonymous object involves an Adjust, and we have no
 106    --      easy way to access the anonymous object created by the back-end
 107
 108    --    - If the returned type is class-wide, this is an unconstrained type
 109    --      anyway
 110
 111    --  Furthermore, the little loss in efficiency which is the result of this
 112    --  decision is not such a big deal because function returning tagged types
 113    --  are not very much used in real life as opposed to functions returning
 114    --  access to a tagged type
 115
 116    --------------------------------------------------
 117    -- Transient Blocks and Finalization Management --
 118    --------------------------------------------------
 119
 120    function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id;
 121    --  N is a node wich may generate a transient scope. Loop over the
 122    --  parent pointers of N until it find the appropriate node to
 123    --  wrap. It it returns Empty, it means that no transient scope is
 124    --  needed in this context.
 125
 126    function Make_Clean
 127      (N                          : Node_Id;
 128       Clean                      : Entity_Id;
 129       Mark                       : Entity_Id;
 130       Flist                      : Entity_Id;
 131       Is_Task                    : Boolean;
 132       Is_Master                  : Boolean;
 133       Is_Protected_Subprogram    : Boolean;
 134       Is_Task_Allocation_Block   : Boolean;
 135       Is_Asynchronous_Call_Block : Boolean)
 136       return      Node_Id;
 137    --  Expand a the clean-up procedure for controlled and/or transient
 138    --  block, and/or task master or task body, or blocks used to
 139    --  implement task allocation or asynchronous entry calls, or
 140    --  procedures used to implement protected procedures. Clean is the
 141    --  entity for such a procedure. Mark is the entity for the secondary
 142    --  stack mark, if empty only controlled block clean-up will be
 143    --  performed. Flist is the entity for the local final list, if empty
 144    --  only transient scope clean-up will be performed. The flags
 145    --  Is_Task and Is_Master control the calls to the corresponding
 146    --  finalization actions for a task body or for an entity that is a
 147    --  task master.
 148
 149    procedure Set_Node_To_Be_Wrapped (N : Node_Id);
 150    --  Set the field Node_To_Be_Wrapped of the current scope
 151
 152    procedure Insert_Actions_In_Scope_Around (N : Node_Id);
 153    --  Insert the before-actions kept in the scope stack before N, and the
 154    --  after after-actions, after N which must be a member of a list.
 155
 156    function Make_Transient_Block
 157      (Loc    : Source_Ptr;
 158       Action : Node_Id)
 159       return   Node_Id;
 160    --  Create a transient block whose name is Scope, which is also a
 161    --  controlled block if Flist is not empty and whose only code is
 162    --  Action (either a single statement or single declaration).
 163
 164    type Final_Primitives is (Initialize_Case, Adjust_Case, Finalize_Case);
 165    --  This enumeration type is defined in order to ease sharing code for
 166    --  building finalization procedures for composite types.
 167
 168    Name_Of      : constant array (Final_Primitives) of Name_Id :=
 169                     (Initialize_Case => Name_Initialize,
 170                      Adjust_Case     => Name_Adjust,
 171                      Finalize_Case   => Name_Finalize);
 172
 173    Deep_Name_Of : constant array (Final_Primitives) of Name_Id :=
 174                     (Initialize_Case => Name_uDeep_Initialize,
 175                      Adjust_Case     => Name_uDeep_Adjust,
 176                      Finalize_Case   => Name_uDeep_Finalize);
 177
 178    procedure Build_Record_Deep_Procs (Typ : Entity_Id);
 179    --  Build the deep Initialize/Adjust/Finalize for a record Typ with
 180    --  Has_Component_Component set and store them using the TSS mechanism.
 181
 182    procedure Build_Array_Deep_Procs (Typ : Entity_Id);
 183    --  Build the deep Initialize/Adjust/Finalize for a record Typ with
 184    --  Has_Controlled_Component set and store them using the TSS mechanism.
 185
 186    function Make_Deep_Proc
 187      (Prim  : Final_Primitives;
 188       Typ   : Entity_Id;
 189       Stmts : List_Id)
 190       return  Node_Id;
 191    --  This function generates the tree for Deep_Initialize, Deep_Adjust
 192    --  or Deep_Finalize procedures according to the first parameter,
 193    --  these procedures operate on the type Typ. The Stmts parameter
 194    --  gives the body of the procedure.
 195
 196    function Make_Deep_Array_Body
 197      (Prim : Final_Primitives;
 198       Typ  : Entity_Id)
 199       return List_Id;
 200    --  This function generates the list of statements for implementing
 201    --  Deep_Initialize, Deep_Adjust or Deep_Finalize procedures
 202    --  according to the first parameter, these procedures operate on the
 203    --  array type Typ.
 204
 205    function Make_Deep_Record_Body
 206      (Prim : Final_Primitives;
 207       Typ  : Entity_Id)
 208       return List_Id;
 209    --  This function generates the list of statements for implementing
 210    --  Deep_Initialize, Deep_Adjust or Deep_Finalize procedures
 211    --  according to the first parameter, these procedures operate on the
 212    --  record type Typ.
 213
 214    function Convert_View
 215      (Proc : Entity_Id;
 216       Arg  : Node_Id;
 217       Ind  : Pos := 1)
 218       return Node_Id;
 219    --  Proc is one of the Initialize/Adjust/Finalize operations, and
 220    --  Arg is the argument being passed to it. Ind indicates which
 221    --  formal of procedure Proc we are trying to match. This function
 222    --  will, if necessary, generate an conversion between the partial
 223    --  and full view of Arg to match the type of the formal of Proc,
 224    --  or force a conversion to the class-wide type in the case where
 225    --  the operation is abstract.
 226
 227    -----------------------------
 228    -- Finalization Management --
 229    -----------------------------
 230
 231    --  This part describe how Initialization/Adjusment/Finalization procedures
 232    --  are generated and called. Two cases must be considered, types that are
 233    --  Controlled (Is_Controlled flag set) and composite types that contain
 234    --  controlled components (Has_Controlled_Component flag set). In the first
 235    --  case the procedures to call are the user-defined primitive operations
 236    --  Initialize/Adjust/Finalize. In the second case, GNAT generates
 237    --  Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge of
 238    --  calling the former procedures on the controlled components.
 239
 240    --  For records with Has_Controlled_Component set, a hidden "controller"
 241    --  component is inserted. This controller component contains its own
 242    --  finalization list on which all controlled components are attached
 243    --  creating an indirection on the upper-level Finalization list. This
 244    --  technique facilitates the management of objects whose number of
 245    --  controlled components changes during execution. This controller
 246    --  component is itself controlled and is attached to the upper-level
 247    --  finalization chain. Its adjust primitive is in charge of calling
 248    --  adjust on the components and adusting the finalization pointer to
 249    --  match their new location (see a-finali.adb)
 250
 251    --  It is not possible to use a similar technique for arrays that have
 252    --  Has_Controlled_Component set. In this case, deep procedures are
 253    --  generated that call initialize/adjust/finalize + attachment or
 254    --  detachment on the finalization list for all component.
 255
 256    --  Initialize calls: they are generated for declarations or dynamic
 257    --  allocations of Controlled objects with no initial value. They are
 258    --  always followed by an attachment to the current Finalization
 259    --  Chain. For the dynamic allocation case this the chain attached to
 260    --  the scope of the access type definition otherwise, this is the chain
 261    --  of the current scope.
 262
 263    --  Adjust Calls: They are generated on 2 occasions: (1) for
 264    --  declarations or dynamic allocations of Controlled objects with an
 265    --  initial value. (2) after an assignment. In the first case they are
 266    --  followed by an attachment to the final chain, in the second case
 267    --  they are not.
 268
 269    --  Finalization Calls: They are generated on (1) scope exit, (2)
 270    --  assignments, (3) unchecked deallocations. In case (3) they have to
 271    --  be detached from the final chain, in case (2) they must not and in
 272    --  case (1) this is not important since we are exiting the scope
 273    --  anyway.
 274
 275    --  Here is a simple example of the expansion of a controlled block :
 276
 277    --    declare
 278    --       X : Controlled ;
 279    --       Y : Controlled := Init;
 280    --
 281    --       type R is record
 282    --          C : Controlled;
 283    --       end record;
 284    --       W : R;
 285    --       Z : R := (C => X);
 286    --    begin
 287    --       X := Y;
 288    --       W := Z;
 289    --    end;
 290    --
 291    --  is expanded into
 292    --
 293    --    declare
 294    --       _L : System.FI.Finalizable_Ptr;
 295
 296    --       procedure _Clean is
 297    --       begin
 298    --          Abort_Defer;
 299    --          System.FI.Finalize_List (_L);
 300    --          Abort_Undefer;
 301    --       end _Clean;
 302
 303    --       X : Controlled;
 304    --       Initialize (X);
 305    --       Attach_To_Final_List (_L, Finalizable (X), 1);
 306    --       Y : Controlled := Init;
 307    --       Adjust (Y);
 308    --       Attach_To_Final_List (_L, Finalizable (Y), 1);
 309    --
 310    --       type R is record
 311    --         _C : Record_Controller;
 312    --          C : Controlled;
 313    --       end record;
 314    --       W : R;
 315    --       Deep_Initialize (W, _L, 1);
 316    --       Z : R := (C => X);
 317    --       Deep_Adjust (Z, _L, 1);
 318
 319    --    begin
 320    --       Finalize (X);
 321    --       X := Y;
 322    --       Adjust (X);
 323
 324    --       Deep_Finalize (W, False);
 325    --       W := Z;
 326    --       Deep_Adjust (W, _L, 0);
 327    --    at end
 328    --       _Clean;
 329    --    end;
 330
 331    function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean;
 332    --  Return True if Flist_Ref refers to a global final list, either
 333    --  the object GLobal_Final_List which is used to attach standalone
 334    --  objects, or any of the list controllers associated with library
 335    --  level access to controlled objects
 336
 337    ----------------------------
 338    -- Build_Array_Deep_Procs --
 339    ----------------------------
 340
 341    procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
 342    begin
 343       Set_TSS (Typ,
 344         Make_Deep_Proc (
 345           Prim  => Initialize_Case,
 346           Typ   => Typ,
 347           Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
 348
 349       if not Is_Return_By_Reference_Type (Typ) then
 350          Set_TSS (Typ,
 351            Make_Deep_Proc (
 352              Prim  => Adjust_Case,
 353              Typ   => Typ,
 354              Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
 355       end if;
 356
 357       Set_TSS (Typ,
 358         Make_Deep_Proc (
 359           Prim  => Finalize_Case,
 360           Typ   => Typ,
 361           Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
 362    end Build_Array_Deep_Procs;
 363
 364    -----------------------------
 365    -- Build_Controlling_Procs --
 366    -----------------------------
 367
 368    procedure Build_Controlling_Procs (Typ : Entity_Id) is
 369    begin
 370       if Is_Array_Type (Typ) then
 371          Build_Array_Deep_Procs (Typ);
 372
 373       else pragma Assert (Is_Record_Type (Typ));
 374          Build_Record_Deep_Procs (Typ);
 375       end if;
 376    end Build_Controlling_Procs;
 377
 378    ----------------------
 379    -- Build_Final_List --
 380    ----------------------
 381
 382    procedure Build_Final_List (N : Node_Id; Typ : Entity_Id) is
 383       Loc  : constant Source_Ptr := Sloc (N);
 384       Decl : Node_Id;
 385
 386    begin
 387       Set_Associated_Final_Chain (Typ,
 388         Make_Defining_Identifier (Loc,
 389           New_External_Name (Chars (Typ), 'L')));
 390
 391       Decl :=
 392         Make_Object_Declaration (Loc,
 393           Defining_Identifier =>
 394              Associated_Final_Chain (Typ),
 395           Object_Definition   =>
 396             New_Reference_To
 397               (RTE (RE_List_Controller), Loc));
 398
 399       --  The type may have been frozen already, and this is a late
 400       --  freezing action, in which case the declaration must be elaborated
 401       --  at once. If the call is for an allocator, the chain must also be
 402       --  created now, because the freezing of the type does not build one.
 403       --  Otherwise, the declaration is one of the freezing actions for a
 404       --  user-defined type.
 405
 406       if Is_Frozen (Typ)
 407         or else (Nkind (N) = N_Allocator
 408                   and then Ekind (Etype (N)) = E_Anonymous_Access_Type)
 409       then
 410          Insert_Action (N, Decl);
 411       else
 412          Append_Freeze_Action (Typ, Decl);
 413       end if;
 414    end Build_Final_List;
 415
 416    ---------------------
 417    -- Build_Late_Proc --
 418    ---------------------
 419
 420    procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
 421    begin
 422       for Final_Prim in Name_Of'Range loop
 423          if Name_Of (Final_Prim) = Nam then
 424             Set_TSS (Typ,
 425               Make_Deep_Proc (
 426                 Prim  => Final_Prim,
 427                 Typ   => Typ,
 428                 Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
 429          end if;
 430       end loop;
 431    end Build_Late_Proc;
 432
 433    -----------------------------
 434    -- Build_Record_Deep_Procs --
 435    -----------------------------
 436
 437    procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
 438    begin
 439       Set_TSS (Typ,
 440         Make_Deep_Proc (
 441           Prim  => Initialize_Case,
 442           Typ   => Typ,
 443           Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
 444
 445       if not Is_Return_By_Reference_Type (Typ) then
 446          Set_TSS (Typ,
 447            Make_Deep_Proc (
 448              Prim  => Adjust_Case,
 449              Typ   => Typ,
 450              Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
 451       end if;
 452
 453       Set_TSS (Typ,
 454         Make_Deep_Proc (
 455           Prim  => Finalize_Case,
 456           Typ   => Typ,
 457           Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
 458    end Build_Record_Deep_Procs;
 459
 460    ---------------------
 461    -- Controlled_Type --
 462    ---------------------
 463
 464    function Controlled_Type (T : Entity_Id) return Boolean is
 465
 466       function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
 467       --  If type is not frozen yet, check explicitly among its components,
 468       --  because flag is not necessarily set.
 469
 470       ------------------------------------
 471       --  Has_Some_Controlled_Component --
 472       ------------------------------------
 473
 474       function Has_Some_Controlled_Component (Rec : Entity_Id)
 475         return Boolean
 476       is
 477          Comp : Entity_Id;
 478
 479       begin
 480          if Has_Controlled_Component (Rec) then
 481             return True;
 482
 483          elsif not Is_Frozen (Rec) then
 484             if Is_Record_Type (Rec) then
 485                Comp := First_Entity (Rec);
 486
 487                while Present (Comp) loop
 488                   if not Is_Type (Comp)
 489                     and then Controlled_Type (Etype (Comp))
 490                   then
 491                      return True;
 492                   end if;
 493
 494                   Next_Entity (Comp);
 495                end loop;
 496
 497                return False;
 498
 499             elsif Is_Array_Type (Rec) then
 500                return Is_Controlled (Component_Type (Rec));
 501
 502             else
 503                return Has_Controlled_Component (Rec);
 504             end if;
 505          else
 506             return False;
 507          end if;
 508       end Has_Some_Controlled_Component;
 509
 510    --  Start of processing for Controlled_Type
 511
 512    begin
 513       --  Class-wide types must be treated as controlled because they may
 514       --  contain an extension that has controlled components
 515
 516       return (Is_Class_Wide_Type (T)
 517                 and then not No_Run_Time
 518                 and then not In_Finalization_Root (T))
 519         or else Is_Controlled (T)
 520         or else Has_Some_Controlled_Component (T)
 521         or else (Is_Concurrent_Type (T)
 522                    and then Present (Corresponding_Record_Type (T))
 523                    and then Controlled_Type (Corresponding_Record_Type (T)));
 524    end Controlled_Type;
 525
 526    --------------------------
 527    -- Controller_Component --
 528    --------------------------
 529
 530    function Controller_Component (Typ : Entity_Id) return Entity_Id is
 531       T         : Entity_Id := Base_Type (Typ);
 532       Comp      : Entity_Id;
 533       Comp_Scop : Entity_Id;
 534       Res       : Entity_Id := Empty;
 535       Res_Scop  : Entity_Id := Empty;
 536
 537    begin
 538       if Is_Class_Wide_Type (T) then
 539          T := Root_Type (T);
 540       end if;
 541
 542       if Is_Private_Type (T) then
 543          T := Underlying_Type (T);
 544       end if;
 545
 546       --  Fetch the outermost controller
 547
 548       Comp := First_Entity (T);
 549       while Present (Comp) loop
 550          if Chars (Comp) = Name_uController then
 551             Comp_Scop := Scope (Original_Record_Component (Comp));
 552
 553             --  If this controller is at the outermost level, no need to
 554             --  look for another one
 555
 556             if Comp_Scop = T then
 557                return Comp;
 558
 559             --  Otherwise record the outermost one and continue looking
 560
 561             elsif Res = Empty or else Is_Ancestor (Res_Scop, Comp_Scop) then
 562                Res      := Comp;
 563                Res_Scop := Comp_Scop;
 564             end if;
 565          end if;
 566
 567          Next_Entity (Comp);
 568       end loop;
 569
 570       --  If we fall through the loop, there is no controller component
 571
 572       return Res;
 573    end Controller_Component;
 574
 575    ------------------
 576    -- Convert_View --
 577    ------------------
 578
 579    function Convert_View
 580      (Proc : Entity_Id;
 581       Arg  : Node_Id;
 582       Ind  : Pos := 1)
 583       return Node_Id
 584    is
 585       Fent : Entity_Id := First_Entity (Proc);
 586       Ftyp : Entity_Id;
 587       Atyp : Entity_Id;
 588
 589    begin
 590       for J in 2 .. Ind loop
 591          Next_Entity (Fent);
 592       end loop;
 593
 594       Ftyp := Etype (Fent);
 595
 596       if Nkind (Arg) = N_Type_Conversion
 597         or else Nkind (Arg) = N_Unchecked_Type_Conversion
 598       then
 599          Atyp := Entity (Subtype_Mark (Arg));
 600       else
 601          Atyp := Etype (Arg);
 602       end if;
 603
 604       if Is_Abstract (Proc) and then Is_Tagged_Type (Ftyp) then
 605          return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
 606
 607       elsif Ftyp /= Atyp
 608         and then Present (Atyp)
 609         and then
 610           (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
 611         and then Underlying_Type (Atyp) = Underlying_Type (Ftyp)
 612       then
 613          return Unchecked_Convert_To (Ftyp, Arg);
 614
 615       --  If the argument is already a conversion, as generated by
 616       --  Make_Init_Call, set the target type to the type of the formal
 617       --  directly, to avoid spurious typing problems.
 618
 619       elsif (Nkind (Arg) = N_Unchecked_Type_Conversion
 620               or else Nkind (Arg) = N_Type_Conversion)
 621         and then not Is_Class_Wide_Type (Atyp)
 622       then
 623          Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
 624          Set_Etype (Arg, Ftyp);
 625          return Arg;
 626
 627       else
 628          return Arg;
 629       end if;
 630    end Convert_View;
 631
 632    -------------------------------
 633    -- Establish_Transient_Scope --
 634    -------------------------------
 635
 636    --  This procedure is called each time a transient block has to be inserted
 637    --  that is to say for each call to a function with unconstrained ot tagged
 638    --  result. It creates a new scope on the stack scope in order to enclose
 639    --  all transient variables generated
 640
 641    procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
 642       Loc       : constant Source_Ptr := Sloc (N);
 643       Wrap_Node : Node_Id;
 644
 645       Sec_Stk : constant Boolean :=
 646                   Sec_Stack and not Functions_Return_By_DSP_On_Target;
 647       --  We never need a secondary stack if functions return by DSP
 648
 649    begin
 650       --  Do not create a transient scope if we are already inside one
 651
 652       for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
 653
 654          if Scope_Stack.Table (S).Is_Transient then
 655             if Sec_Stk then
 656                Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity);
 657             end if;
 658
 659             return;
 660
 661          --  If we have encountered Standard there are no enclosing
 662          --  transient scopes.
 663
 664          elsif Scope_Stack.Table (S).Entity = Standard_Standard then
 665             exit;
 666
 667          end if;
 668       end loop;
 669
 670       Wrap_Node := Find_Node_To_Be_Wrapped (N);
 671
 672       --  Case of no wrap node, false alert, no transient scope needed
 673
 674       if No (Wrap_Node) then
 675          null;
 676
 677       --  Transient scope is required
 678
 679       else
 680          New_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
 681          Set_Scope_Is_Transient;
 682
 683          if Sec_Stk then
 684             Set_Uses_Sec_Stack (Current_Scope);
 685             Check_Restriction (No_Secondary_Stack, N);
 686          end if;
 687
 688          Set_Etype (Current_Scope, Standard_Void_Type);
 689          Set_Node_To_Be_Wrapped (Wrap_Node);
 690
 691          if Debug_Flag_W then
 692             Write_Str ("    <Transient>");
 693             Write_Eol;
 694          end if;
 695       end if;
 696    end Establish_Transient_Scope;
 697
 698    ----------------------------
 699    -- Expand_Cleanup_Actions --
 700    ----------------------------
 701
 702    procedure Expand_Cleanup_Actions (N : Node_Id) is
 703       Loc                  :  Source_Ptr;
 704       S                    : constant Entity_Id  :=
 705                                Current_Scope;
 706       Flist                : constant Entity_Id  :=
 707                                Finalization_Chain_Entity (S);
 708       Is_Task              : constant Boolean    :=
 709                                (Nkind (Original_Node (N)) = N_Task_Body);
 710       Is_Master            : constant Boolean    :=
 711                                Nkind (N) /= N_Entry_Body
 712                                  and then Is_Task_Master (N);
 713       Is_Protected         : constant Boolean    :=
 714                                Nkind (N) = N_Subprogram_Body
 715                                  and then Is_Protected_Subprogram_Body (N);
 716       Is_Task_Allocation   : constant Boolean    :=
 717                                Nkind (N) = N_Block_Statement
 718                                  and then Is_Task_Allocation_Block (N);
 719       Is_Asynchronous_Call : constant Boolean    :=
 720                                Nkind (N) = N_Block_Statement
 721                                  and then Is_Asynchronous_Call_Block (N);
 722
 723       Clean     : Entity_Id;
 724       Mark      : Entity_Id := Empty;
 725       New_Decls : List_Id   := New_List;
 726       Blok      : Node_Id;
 727       Wrapped   : Boolean;
 728       Chain     : Entity_Id := Empty;
 729       Decl      : Node_Id;
 730       Old_Poll  : Boolean;
 731
 732    begin
 733
 734       --  Compute a location that is not directly in the user code in
 735       --  order to avoid to generate confusing debug info. A good
 736       --  approximation is the name of the outer user-defined scope
 737
 738       declare
 739          S1 : Entity_Id := S;
 740
 741       begin
 742          while not Comes_From_Source (S1) and then S1 /= Standard_Standard loop
 743             S1 := Scope (S1);
 744          end loop;
 745
 746          Loc := Sloc (S1);
 747       end;
 748
 749       --  There are cleanup actions only if the secondary stack needs
 750       --  releasing or some finalizations are needed or in the context
 751       --  of tasking
 752
 753       if Uses_Sec_Stack  (Current_Scope)
 754         and then not Sec_Stack_Needed_For_Return (Current_Scope)
 755       then
 756          null;
 757       elsif No (Flist)
 758         and then not Is_Master
 759         and then not Is_Task
 760         and then not Is_Protected
 761         and then not Is_Task_Allocation
 762         and then not Is_Asynchronous_Call
 763       then
 764          return;
 765       end if;
 766
 767       --  Set polling off, since we don't need to poll during cleanup
 768       --  actions, and indeed for the cleanup routine, which is executed
 769       --  with aborts deferred, we don't want polling.
 770
 771       Old_Poll := Polling_Required;
 772       Polling_Required := False;
 773
 774       --  Make sure we have a declaration list, since we will add to it
 775
 776       if No (Declarations (N)) then
 777          Set_Declarations (N, New_List);
 778       end if;
 779
 780       --  The task activation call has already been built for task
 781       --  allocation blocks.
 782
 783       if not Is_Task_Allocation then
 784          Build_Task_Activation_Call (N);
 785       end if;
 786
 787       if Is_Master then
 788          Establish_Task_Master (N);
 789       end if;
 790
 791       --  If secondary stack is in use, expand:
 792       --    _Mxx : constant Mark_Id := SS_Mark;
 793
 794       --  Suppress calls to SS_Mark and SS_Release if Java_VM,
 795       --  since we never use the secondary stack on the JVM.
 796
 797       if Uses_Sec_Stack (Current_Scope)
 798         and then not Sec_Stack_Needed_For_Return (Current_Scope)
 799         and then not Java_VM
 800       then
 801          Mark := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
 802          Append_To (New_Decls,
 803            Make_Object_Declaration (Loc,
 804              Defining_Identifier => Mark,
 805              Object_Definition   => New_Reference_To (RTE (RE_Mark_Id), Loc),
 806              Expression =>
 807                Make_Function_Call (Loc,
 808                  Name => New_Reference_To (RTE (RE_SS_Mark), Loc))));
 809
 810          Set_Uses_Sec_Stack (Current_Scope, False);
 811       end if;
 812
 813       --  If finalization list is present then expand:
 814       --   Local_Final_List : System.FI.Finalizable_Ptr;
 815
 816       if Present (Flist) then
 817          Append_To (New_Decls,
 818            Make_Object_Declaration (Loc,
 819              Defining_Identifier => Flist,
 820              Object_Definition   =>
 821                New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
 822       end if;
 823
 824       --  Clean-up procedure definition
 825
 826       Clean := Make_Defining_Identifier (Loc, Name_uClean);
 827       Set_Suppress_Elaboration_Warnings (Clean);
 828       Append_To (New_Decls,
 829         Make_Clean (N, Clean, Mark, Flist,
 830           Is_Task,
 831           Is_Master,
 832           Is_Protected,
 833           Is_Task_Allocation,
 834           Is_Asynchronous_Call));
 835
 836       --  If exception handlers are present, wrap the Sequence of
 837       --  statements in a block because it is not possible to get
 838       --  exception handlers and an AT END call in the same scope.
 839
 840       if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
 841          Blok :=
 842            Make_Block_Statement (Loc,
 843              Handled_Statement_Sequence => Handled_Statement_Sequence (N));
 844          Set_Handled_Statement_Sequence (N,
 845            Make_Handled_Sequence_Of_Statements (Loc, New_List (Blok)));
 846          Wrapped := True;
 847
 848       --  Otherwise we do not wrap
 849
 850       else
 851          Wrapped := False;
 852          Blok    := Empty;
 853       end if;
 854
 855       --  Don't move the _chain Activation_Chain declaration in task
 856       --  allocation blocks. Task allocation blocks use this object
 857       --  in their cleanup handlers, and gigi complains if it is declared
 858       --  in the sequence of statements of the scope that declares the
 859       --  handler.
 860
 861       if Is_Task_Allocation then
 862          Chain := Activation_Chain_Entity (N);
 863          Decl := First (Declarations (N));
 864
 865          while Nkind (Decl) /= N_Object_Declaration
 866            or else Defining_Identifier (Decl) /= Chain
 867          loop
 868             Next (Decl);
 869             pragma Assert (Present (Decl));
 870          end loop;
 871
 872          Remove (Decl);
 873          Prepend_To (New_Decls, Decl);
 874       end if;
 875
 876       --  Now we move the declarations into the Sequence of statements
 877       --  in order to get them protected by the AT END call. It may seem
 878       --  weird to put declarations in the sequence of statement but in
 879       --  fact nothing forbids that at the tree level. We also set the
 880       --  First_Real_Statement field so that we remember where the real
 881       --  statements (i.e. original statements) begin. Note that if we
 882       --  wrapped the statements, the first real statement is inside the
 883       --  inner block. If the First_Real_Statement is already set (as is
 884       --  the case for subprogram bodies that are expansions of task bodies)
 885       --  then do not reset it, because its declarative part would migrate
 886       --  to the statement part.
 887
 888       if not Wrapped then
 889          if No (First_Real_Statement (Handled_Statement_Sequence (N))) then
 890             Set_First_Real_Statement (Handled_Statement_Sequence (N),
 891               First (Statements (Handled_Statement_Sequence (N))));
 892          end if;
 893
 894       else
 895          Set_First_Real_Statement (Handled_Statement_Sequence (N), Blok);
 896       end if;
 897
 898       Append_List_To (Declarations (N),
 899         Statements (Handled_Statement_Sequence (N)));
 900       Set_Statements (Handled_Statement_Sequence (N), Declarations (N));
 901
 902       --  We need to reset the Sloc of the handled statement sequence to
 903       --  properly reflect the new initial "statement" in the sequence.
 904
 905       Set_Sloc
 906         (Handled_Statement_Sequence (N), Sloc (First (Declarations (N))));
 907
 908       --  The declarations of the _Clean procedure and finalization chain
 909       --  replace the old declarations that have been moved inward
 910
 911       Set_Declarations (N, New_Decls);
 912       Analyze_Declarations (New_Decls);
 913
 914       --  The At_End call is attached to the sequence of statements.
 915
 916       declare
 917          HSS : Node_Id;
 918
 919       begin
 920          --  If the construct is a protected subprogram, then the call to
 921          --  the corresponding unprotected program appears in a block which
 922          --  is the last statement in the body, and it is this block that
 923          --  must be covered by the At_End handler.
 924
 925          if Is_Protected then
 926             HSS := Handled_Statement_Sequence
 927               (Last (Statements (Handled_Statement_Sequence (N))));
 928          else
 929             HSS := Handled_Statement_Sequence (N);
 930          end if;
 931
 932          Set_At_End_Proc (HSS, New_Occurrence_Of (Clean, Loc));
 933          Expand_At_End_Handler (HSS, Empty);
 934       end;
 935
 936       --  Restore saved polling mode
 937
 938       Polling_Required := Old_Poll;
 939    end Expand_Cleanup_Actions;
 940
 941    -------------------------------
 942    -- Expand_Ctrl_Function_Call --
 943    -------------------------------
 944
 945    procedure Expand_Ctrl_Function_Call (N : Node_Id) is
 946       Loc    : constant Source_Ptr := Sloc (N);
 947       Rtype  : constant Entity_Id  := Etype (N);
 948       Utype  : constant Entity_Id  := Underlying_Type (Rtype);
 949       Ref    : Node_Id;
 950       Action : Node_Id;
 951
 952       Attach_Level : Uint    := Uint_1;
 953       Len_Ref      : Node_Id := Empty;
 954
 955       function Last_Array_Component
 956         (Ref :  Node_Id;
 957          Typ :  Entity_Id)
 958          return Node_Id;
 959       --  Creates a reference to the last component of the array object
 960       --  designated by Ref whose type is Typ.
 961
 962       function Last_Array_Component
 963         (Ref :  Node_Id;
 964          Typ :  Entity_Id)
 965          return Node_Id
 966       is
 967          N          : Int;
 968          Index_List : List_Id := New_List;
 969
 970       begin
 971          N := 1;
 972          while N <= Number_Dimensions (Typ) loop
 973             Append_To (Index_List,
 974               Make_Attribute_Reference (Loc,
 975                 Prefix         => Duplicate_Subexpr (Ref),
 976                 Attribute_Name => Name_Last,
 977                 Expressions    => New_List (
 978                   Make_Integer_Literal (Loc, N))));
 979
 980             N := N + 1;
 981          end loop;
 982
 983          return
 984            Make_Indexed_Component (Loc,
 985              Prefix      => Duplicate_Subexpr (Ref),
 986              Expressions => Index_List);
 987       end Last_Array_Component;
 988
 989    --  Start of processing for Expand_Ctrl_Function_Call
 990
 991    begin
 992       --  Optimization, if the returned value (which is on the sec-stack)
 993       --  is returned again, no need to copy/readjust/finalize, we can just
 994       --  pass the value thru (see Expand_N_Return_Statement), and thus no
 995       --  attachment is needed
 996
 997       if Nkind (Parent (N)) = N_Return_Statement then
 998          return;
 999       end if;
1000
1001       --  Resolution is now finished, make sure we don't start analysis again
1002       --  because of the duplication
1003
1004       Set_Analyzed (N);
1005       Ref := Duplicate_Subexpr (N);
1006
1007       --  Now we can generate the Attach Call, note that this value is
1008       --  always in the (secondary) stack and thus is attached to a singly
1009       --  linked final list:
1010       --
1011       --    Resx := F (X)'reference;
1012       --    Attach_To_Final_List (_Lx, Resx.all, 1);
1013       --  or when there are controlled components
1014       --    Attach_To_Final_List (_Lx, Resx._controller, 1);
1015       --  or if it is an array with is_controlled components
1016       --    Attach_To_Final_List (_Lx, Resx (Resx'last), 3);
1017       --    An attach level of 3 means that a whole array is to be
1018       --    attached to the finalization list
1019       --  or if it is an array with has_controlled components
1020       --    Attach_To_Final_List (_Lx, Resx (Resx'last)._controller, 3);
1021
1022       if Has_Controlled_Component (Rtype) then
1023          declare
1024             T1 : Entity_Id := Rtype;
1025             T2 : Entity_Id := Utype;
1026
1027          begin
1028             if Is_Array_Type (T2) then
1029                Len_Ref :=
1030                  Make_Attribute_Reference (Loc,
1031                  Prefix => Duplicate_Subexpr (Unchecked_Convert_To (T2, Ref)),
1032                  Attribute_Name => Name_Length);
1033             end if;
1034
1035             while Is_Array_Type (T2) loop
1036                if T1 /= T2 then
1037                   Ref := Unchecked_Convert_To (T2, Ref);
1038                end if;
1039                Ref := Last_Array_Component (Ref, T2);
1040                Attach_Level := Uint_3;
1041                T1 := Component_Type (T2);
1042                T2 := Underlying_Type (T1);
1043             end loop;
1044
1045             if Has_Controlled_Component (T2) then
1046                if T1 /= T2 then
1047                   Ref := Unchecked_Convert_To (T2, Ref);
1048                end if;
1049                Ref :=
1050                  Make_Selected_Component (Loc,
1051                    Prefix        => Ref,
1052                    Selector_Name => Make_Identifier (Loc, Name_uController));
1053             end if;
1054          end;
1055
1056          --  Here we know that 'Ref' has a controller so we may as well
1057          --  attach it directly
1058
1059          Action :=
1060            Make_Attach_Call (
1061              Obj_Ref      => Ref,
1062              Flist_Ref    => Find_Final_List (Current_Scope),
1063              With_Attach  => Make_Integer_Literal (Loc, Attach_Level));
1064
1065       else
1066          --  Here, we have a controlled type that does not seem to have
1067          --  controlled components but it could be a class wide type whose
1068          --  further derivations have controlled components. So we don't know
1069          --  if the object itself needs to be attached or if it
1070          --  has a record controller. We need to call a runtime function
1071          --  (Deep_Tag_Attach) which knows what to do thanks to the
1072          --  RC_Offset in the dispatch table.
1073
1074          Action :=
1075            Make_Procedure_Call_Statement (Loc,
1076              Name => New_Reference_To (RTE (RE_Deep_Tag_Attach), Loc),
1077              Parameter_Associations => New_List (
1078                Find_Final_List (Current_Scope),
1079
1080                Make_Attribute_Reference (Loc,
1081                    Prefix => Ref,
1082                    Attribute_Name => Name_Address),
1083
1084                Make_Integer_Literal (Loc, Attach_Level)));
1085       end if;
1086
1087       if Present (Len_Ref) then
1088          Action :=
1089            Make_Implicit_If_Statement (N,
1090              Condition => Make_Op_Gt (Loc,
1091                Left_Opnd  => Len_Ref,
1092                Right_Opnd => Make_Integer_Literal (Loc, 0)),
1093              Then_Statements => New_List (Action));
1094       end if;
1095
1096       Insert_Action (N, Action);
1097    end Expand_Ctrl_Function_Call;
1098
1099    ---------------------------
1100    -- Expand_N_Package_Body --
1101    ---------------------------
1102
1103    --  Add call to Activate_Tasks if body is an activator (actual
1104    --  processing is in chapter 9).
1105
1106    --  Generate subprogram descriptor for elaboration routine
1107
1108    --  ENcode entity names in package body
1109
1110    procedure Expand_N_Package_Body (N : Node_Id) is
1111       Ent : Entity_Id := Corresponding_Spec (N);
1112
1113    begin
1114       --  This is done only for non-generic packages
1115
1116       if Ekind (Ent) = E_Package then
1117          New_Scope (Corresponding_Spec (N));
1118          Build_Task_Activation_Call (N);
1119          Pop_Scope;
1120       end if;
1121
1122       Set_Elaboration_Flag (N, Corresponding_Spec (N));
1123
1124       --  Generate a subprogram descriptor for the elaboration routine of
1125       --  a package body if the package body has no pending instantiations
1126       --  and it has generated at least one exception handler
1127
1128       if Present (Handler_Records (Body_Entity (Ent)))
1129         and then Is_Compilation_Unit (Ent)
1130         and then not Delay_Subprogram_Descriptors (Body_Entity (Ent))
1131       then
1132          Generate_Subprogram_Descriptor_For_Package
1133            (N, Body_Entity (Ent));
1134       end if;
1135
1136       Set_In_Package_Body (Ent, False);
1137
1138       --  Set to encode entity names in package body before gigi is called
1139
1140       Qualify_Entity_Names (N);
1141    end Expand_N_Package_Body;
1142
1143    ----------------------------------
1144    -- Expand_N_Package_Declaration --
1145    ----------------------------------
1146
1147    --  Add call to Activate_Tasks if there are tasks declared and the
1148    --  package has no body. Note that in Ada83,  this may result in
1149    --  premature activation of some tasks, given that we cannot tell
1150    --  whether a body will eventually appear.
1151
1152    procedure Expand_N_Package_Declaration (N : Node_Id) is
1153    begin
1154       if Nkind (Parent (N)) = N_Compilation_Unit
1155         and then not Body_Required (Parent (N))
1156         and then not Unit_Requires_Body (Defining_Entity (N))
1157         and then Present (Activation_Chain_Entity (N))
1158       then
1159          New_Scope (Defining_Entity (N));
1160          Build_Task_Activation_Call (N);
1161          Pop_Scope;
1162       end if;
1163
1164       --  Note: it is not necessary to worry about generating a subprogram
1165       --  descriptor, since the only way to get exception handlers into a
1166       --  package spec is to include instantiations, and that would cause
1167       --  generation of subprogram descriptors to be delayed in any case.
1168
1169       --  Set to encode entity names in package spec before gigi is called
1170
1171       Qualify_Entity_Names (N);
1172    end Expand_N_Package_Declaration;
1173
1174    ---------------------
1175    -- Find_Final_List --
1176    ---------------------
1177
1178    function Find_Final_List
1179      (E    : Entity_Id;
1180       Ref  : Node_Id := Empty)
1181       return Node_Id
1182    is
1183       Loc : constant Source_Ptr := Sloc (Ref);
1184       S   : Entity_Id;
1185       Id  : Entity_Id;
1186       R   : Node_Id;
1187
1188    begin
1189       --  Case of an internal component. The Final list is the record
1190       --  controller of the enclosing record
1191
1192       if Present (Ref) then
1193          R := Ref;
1194          loop
1195             case Nkind (R) is
1196                when N_Unchecked_Type_Conversion | N_Type_Conversion =>
1197                   R := Expression (R);
1198
1199                when N_Indexed_Component | N_Explicit_Dereference =>
1200                   R := Prefix (R);
1201
1202                when  N_Selected_Component =>
1203                   R := Prefix (R);
1204                   exit;
1205
1206                when  N_Identifier =>
1207                   exit;
1208
1209                when others =>
1210                   raise Program_Error;
1211             end case;
1212          end loop;
1213
1214          return
1215            Make_Selected_Component (Loc,
1216              Prefix =>
1217                Make_Selected_Component (Loc,
1218                  Prefix        => R,
1219                  Selector_Name => Make_Identifier (Loc, Name_uController)),
1220              Selector_Name => Make_Identifier (Loc, Name_F));
1221
1222       --  Case of a dynamically allocated object. The final list is the
1223       --  corresponding list controller (The next entity in the scope of
1224       --  the access type with the right type). If the type comes from a
1225       --  With_Type clause, no controller was created, and we use the
1226       --  global chain instead.
1227
1228       elsif Is_Access_Type (E) then
1229          if not From_With_Type (E) then
1230             return
1231               Make_Selected_Component (Loc,
1232                 Prefix        =>
1233                   New_Reference_To
1234                     (Associated_Final_Chain (Base_Type (E)), Loc),
1235                 Selector_Name => Make_Identifier (Loc, Name_F));
1236          else
1237             return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E));
1238          end if;
1239
1240       else
1241          if Is_Dynamic_Scope (E) then
1242             S := E;
1243          else
1244             S := Enclosing_Dynamic_Scope (E);
1245          end if;
1246
1247          --  When the finalization chain entity is 'Error', it means that
1248          --  there should not be any chain at that level and that the
1249          --  enclosing one should be used
1250
1251          --  This is a nasty kludge, see ??? note in exp_ch11
1252
1253          while Finalization_Chain_Entity (S) = Error loop
1254             S := Enclosing_Dynamic_Scope (S);
1255          end loop;
1256
1257          if S = Standard_Standard then
1258             return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E));
1259          else
1260             if No (Finalization_Chain_Entity (S)) then
1261
1262                Id := Make_Defining_Identifier (Sloc (S),
1263                  New_Internal_Name ('F'));
1264                Set_Finalization_Chain_Entity (S, Id);
1265
1266                --  Set momentarily some semantics attributes to allow normal
1267                --  analysis of expansions containing references to this chain.
1268                --  Will be fully decorated during the expansion of the scope
1269                --  itself
1270
1271                Set_Ekind (Id, E_Variable);
1272                Set_Etype (Id, RTE (RE_Finalizable_Ptr));
1273             end if;
1274
1275             return New_Reference_To (Finalization_Chain_Entity (S), Sloc (E));
1276          end if;
1277       end if;
1278    end Find_Final_List;
1279
1280    -----------------------------
1281    -- Find_Node_To_Be_Wrapped --
1282    -----------------------------
1283
1284    function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
1285       P          : Node_Id;
1286       The_Parent : Node_Id;
1287
1288    begin
1289       The_Parent := N;
1290       loop
1291          P := The_Parent;
1292          pragma Assert (P /= Empty);
1293          The_Parent := Parent (P);
1294
1295          case Nkind (The_Parent) is
1296
1297             --  Simple statement can be wrapped
1298
1299             when N_Pragma               =>
1300                return The_Parent;
1301
1302             --  Usually assignments are good candidate for wrapping
1303             --  except when they have been generated as part of a
1304             --  controlled aggregate where the wrapping should take
1305             --  place more globally.
1306
1307             when N_Assignment_Statement =>
1308                if No_Ctrl_Actions (The_Parent) then
1309                   null;
1310                else
1311                   return The_Parent;
1312                end if;
1313
1314             --  An entry call statement is a special case if it occurs in
1315             --  the context of a Timed_Entry_Call. In this case we wrap
1316             --  the entire timed entry call.
1317
1318             when N_Entry_Call_Statement     |
1319                  N_Procedure_Call_Statement =>
1320                if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
1321                  and then
1322                    Nkind (Parent (Parent (The_Parent))) = N_Timed_Entry_Call
1323                then
1324                   return Parent (Parent (The_Parent));
1325                else
1326                   return The_Parent;
1327                end if;
1328
1329             --  Object declarations are also a boundary for the transient scope
1330             --  even if they are not really wrapped
1331             --  (see Wrap_Transient_Declaration)
1332
1333             when N_Object_Declaration          |
1334                  N_Object_Renaming_Declaration |
1335                  N_Subtype_Declaration         =>
1336                return The_Parent;
1337
1338             --  The expression itself is to be wrapped if its parent is a
1339             --  compound statement or any other statement where the expression
1340             --  is known to be scalar
1341
1342             when N_Accept_Alternative               |
1343                  N_Attribute_Definition_Clause      |
1344                  N_Case_Statement                   |
1345                  N_Code_Statement                   |
1346                  N_Delay_Alternative                |
1347                  N_Delay_Until_Statement            |
1348                  N_Delay_Relative_Statement         |
1349                  N_Discriminant_Association         |
1350                  N_Elsif_Part                       |
1351                  N_Entry_Body_Formal_Part           |
1352                  N_Exit_Statement                   |
1353                  N_If_Statement                     |
1354                  N_Iteration_Scheme                 |
1355                  N_Terminate_Alternative            =>
1356                return P;
1357
1358             when N_Attribute_Reference              =>
1359
1360                if Is_Procedure_Attribute_Name
1361                     (Attribute_Name (The_Parent))
1362                then
1363                   return The_Parent;
1364                end if;
1365
1366             --  ??? No scheme yet for "for I in Expression'Range loop"
1367             --  ??? the current scheme for Expression wrapping doesn't apply
1368             --  ??? because a RANGE is NOT an expression. Tricky problem...
1369             --  ??? while this problem is not solved we have a potential for
1370             --  ??? leak and unfinalized intermediate objects here.
1371
1372             when N_Loop_Parameter_Specification =>
1373                return Empty;
1374
1375             --  The following nodes contains "dummy calls" which don't
1376             --  need to be wrapped.
1377
1378             when N_Parameter_Specification     |
1379                  N_Discriminant_Specification  |
1380                  N_Component_Declaration       =>
1381                return Empty;
1382
1383             --  The return statement is not to be wrapped when the function
1384             --  itself needs wrapping at the outer-level
1385
1386             when N_Return_Statement            =>
1387                if Requires_Transient_Scope (Return_Type (The_Parent)) then
1388                   return Empty;
1389                else
1390                   return The_Parent;
1391                end if;
1392
1393             --  If we leave a scope without having been able to find a node to
1394             --  wrap, something is going wrong but this can happen in error
1395             --  situation that are not detected yet (such as a dynamic string
1396             --  in a pragma export)
1397
1398             when N_Subprogram_Body     |
1399                  N_Package_Declaration |
1400                  N_Package_Body        |
1401                  N_Block_Statement     =>
1402                return Empty;
1403
1404             --  otherwise continue the search
1405
1406             when others =>
1407                null;
1408          end case;
1409       end loop;
1410    end Find_Node_To_Be_Wrapped;
1411
1412    ----------------------
1413    -- Global_Flist_Ref --
1414    ----------------------
1415
1416    function Global_Flist_Ref  (Flist_Ref : Node_Id) return Boolean is
1417       Flist : Entity_Id;
1418
1419    begin
1420       --  Look for the Global_Final_List
1421
1422       if Is_Entity_Name (Flist_Ref) then
1423          Flist := Entity (Flist_Ref);
1424
1425       --  Look for the final list associated with an access to controlled
1426
1427       elsif  Nkind (Flist_Ref) = N_Selected_Component
1428         and then Is_Entity_Name (Prefix (Flist_Ref))
1429       then
1430          Flist :=  Entity (Prefix (Flist_Ref));
1431       else
1432          return False;
1433       end if;
1434
1435       return Present (Flist)
1436         and then Present (Scope (Flist))
1437         and then Enclosing_Dynamic_Scope (Flist) = Standard_Standard;
1438    end Global_Flist_Ref;
1439
1440    ----------------------------------
1441    -- Has_New_Controlled_Component --
1442    ----------------------------------
1443
1444    function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
1445       Comp : Entity_Id;
1446
1447    begin
1448       if not Is_Tagged_Type (E) then
1449          return Has_Controlled_Component (E);
1450       elsif not Is_Derived_Type (E) then
1451          return Has_Controlled_Component (E);
1452       end if;
1453
1454       Comp := First_Component (E);
1455       while Present (Comp) loop
1456
1457          if Chars (Comp) = Name_uParent then
1458             null;
1459
1460          elsif Scope (Original_Record_Component (Comp)) = E
1461            and then Controlled_Type (Etype (Comp))
1462          then
1463             return True;
1464          end if;
1465
1466          Next_Component (Comp);
1467       end loop;
1468
1469       return False;
1470    end Has_New_Controlled_Component;
1471
1472    --------------------------
1473    -- In_Finalization_Root --
1474    --------------------------
1475
1476    --  It would seem simpler to test Scope (RTE (RE_Root_Controlled)) but
1477    --  the purpose of this function is to avoid a circular call to Rtsfind
1478    --  which would been caused by such a test.
1479
1480    function In_Finalization_Root (E : Entity_Id) return Boolean is
1481       S : constant Entity_Id := Scope (E);
1482
1483    begin
1484       return Chars (Scope (S))     = Name_System
1485         and then Chars (S)         = Name_Finalization_Root
1486         and then Scope (Scope (S)) = Standard_Standard;
1487    end  In_Finalization_Root;
1488
1489    ------------------------------------
1490    -- Insert_Actions_In_Scope_Around --
1491    ------------------------------------
1492
1493    procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
1494       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
1495
1496    begin
1497       if Present (SE.Actions_To_Be_Wrapped_Before) then
1498          Insert_List_Before (N, SE.Actions_To_Be_Wrapped_Before);
1499          SE.Actions_To_Be_Wrapped_Before := No_List;
1500       end if;
1501
1502       if Present (SE.Actions_To_Be_Wrapped_After) then
1503          Insert_List_After (N, SE.Actions_To_Be_Wrapped_After);
1504          SE.Actions_To_Be_Wrapped_After := No_List;
1505       end if;
1506    end Insert_Actions_In_Scope_Around;
1507
1508    -----------------------
1509    -- Make_Adjust_Call --
1510    -----------------------
1511
1512    function Make_Adjust_Call
1513      (Ref          : Node_Id;
1514       Typ          : Entity_Id;
1515       Flist_Ref    : Node_Id;
1516       With_Attach  : Node_Id)
1517       return         List_Id
1518    is
1519       Loc    : constant Source_Ptr := Sloc (Ref);
1520       Res    : constant List_Id    := New_List;
1521       Utyp   : Entity_Id;
1522       Proc   : Entity_Id;
1523       Cref   : Node_Id := Ref;
1524       Cref2  : Node_Id;
1525       Attach : Node_Id := With_Attach;
1526
1527    begin
1528       if Is_Class_Wide_Type (Typ) then
1529          Utyp := Underlying_Type (Base_Type (Root_Type (Typ)));
1530       else
1531          Utyp := Underlying_Type (Base_Type (Typ));
1532       end if;
1533
1534       Set_Assignment_OK (Cref);
1535
1536       --  Deal with non-tagged derivation of private views
1537
1538       if Is_Untagged_Derivation (Typ) then
1539          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
1540          Cref := Unchecked_Convert_To (Utyp, Cref);
1541          Set_Assignment_OK (Cref);
1542          --  To prevent problems with UC see 1.156 RH ???
1543       end if;
1544
1545       --  If the underlying_type is a subtype, we are dealing with
1546       --  the completion of a private type. We need to access
1547       --  the base type and generate a conversion to it.
1548
1549       if Utyp /= Base_Type (Utyp) then
1550          pragma Assert (Is_Private_Type (Typ));
1551          Utyp := Base_Type (Utyp);
1552          Cref := Unchecked_Convert_To (Utyp, Cref);
1553       end if;
1554
1555       --  We do not need to attach to one of the Global Final Lists
1556       --  the objects whose type is Finalize_Storage_Only
1557
1558       if Finalize_Storage_Only (Typ)
1559         and then (Global_Flist_Ref (Flist_Ref)
1560           or else Entity (Constant_Value (RTE (RE_Garbage_Collected)))
1561                   = Standard_True)
1562       then
1563          Attach := Make_Integer_Literal (Loc, 0);
1564       end if;
1565
1566       --  Generate:
1567       --    Deep_Adjust (Flist_Ref, Ref, With_Attach);
1568
1569       if Has_Controlled_Component (Utyp)
1570         or else Is_Class_Wide_Type (Typ)
1571       then
1572          if Is_Tagged_Type (Utyp) then
1573             Proc := Find_Prim_Op (Utyp, Deep_Name_Of (Adjust_Case));
1574
1575          else
1576             Proc := TSS (Utyp, Deep_Name_Of (Adjust_Case));
1577          end if;
1578
1579          Cref := Convert_View (Proc, Cref, 2);
1580
1581          Append_To (Res,
1582            Make_Procedure_Call_Statement (Loc,
1583              Name => New_Reference_To (Proc, Loc),
1584              Parameter_Associations =>
1585                New_List (Flist_Ref, Cref, Attach)));
1586
1587       --  Generate:
1588       --    if With_Attach then
1589       --       Attach_To_Final_List (Ref, Flist_Ref);
1590       --    end if;
1591       --    Adjust (Ref);
1592
1593       else -- Is_Controlled (Utyp)
1594
1595          Proc  := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
1596          Cref  := Convert_View (Proc, Cref);
1597          Cref2 := New_Copy_Tree (Cref);
1598
1599          Append_To (Res,
1600            Make_Procedure_Call_Statement (Loc,
1601            Name => New_Reference_To (Proc, Loc),
1602            Parameter_Associations => New_List (Cref2)));
1603
1604          Append_To (Res, Make_Attach_Call (Cref, Flist_Ref, Attach));
1605
1606          --  Treat this as a reference to Adjust if the Adjust routine
1607          --  comes from source. The call is not explicit, but it is near
1608          --  enough, and we won't typically get explicit adjust calls.
1609
1610          if Comes_From_Source (Proc) then
1611             Generate_Reference (Proc, Ref);
1612          end if;
1613       end if;
1614
1615       return Res;
1616    end Make_Adjust_Call;
1617
1618    ----------------------
1619    -- Make_Attach_Call --
1620    ----------------------
1621
1622    --  Generate:
1623    --    System.FI.Attach_To_Final_List (Flist, Ref, Nb_Link)
1624
1625    function Make_Attach_Call
1626      (Obj_Ref      : Node_Id;
1627       Flist_Ref    : Node_Id;
1628       With_Attach  : Node_Id)
1629       return Node_Id
1630    is
1631       Loc : constant Source_Ptr := Sloc (Obj_Ref);
1632
1633    begin
1634       --  Optimization: If the number of links is statically '0', don't
1635       --  call the attach_proc.
1636
1637       if Nkind (With_Attach) = N_Integer_Literal
1638         and then Intval (With_Attach) = Uint_0
1639       then
1640          return Make_Null_Statement (Loc);
1641       end if;
1642
1643       return
1644         Make_Procedure_Call_Statement (Loc,
1645           Name => New_Reference_To (RTE (RE_Attach_To_Final_List), Loc),
1646           Parameter_Associations => New_List (
1647             Flist_Ref,
1648             OK_Convert_To (RTE (RE_Finalizable), Obj_Ref),
1649             With_Attach));
1650    end Make_Attach_Call;
1651
1652    ----------------
1653    -- Make_Clean --
1654    ----------------
1655
1656    function Make_Clean
1657      (N                          : Node_Id;
1658       Clean                      : Entity_Id;
1659       Mark                       : Entity_Id;
1660       Flist                      : Entity_Id;
1661       Is_Task                    : Boolean;
1662       Is_Master                  : Boolean;
1663       Is_Protected_Subprogram    : Boolean;
1664       Is_Task_Allocation_Block   : Boolean;
1665       Is_Asynchronous_Call_Block : Boolean)
1666       return      Node_Id
1667    is
1668       Loc : constant Source_Ptr := Sloc (Clean);
1669
1670       Stmt         : List_Id := New_List;
1671       Sbody        : Node_Id;
1672       Spec         : Node_Id;
1673       Name         : Node_Id;
1674       Param        : Node_Id;
1675       Unlock       : Node_Id;
1676       Param_Type   : Entity_Id;
1677       Pid          : Entity_Id := Empty;
1678       Cancel_Param : Entity_Id;
1679
1680    begin
1681       if Is_Task then
1682          if Restricted_Profile then
1683             Append_To
1684               (Stmt, Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
1685          else
1686             Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Task));
1687          end if;
1688
1689       elsif Is_Master then
1690          if Restrictions (No_Task_Hierarchy) = False then
1691             Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Master));
1692          end if;
1693
1694       elsif Is_Protected_Subprogram then
1695
1696          --  Add statements to the cleanup handler of the (ordinary)
1697          --  subprogram expanded to implement a protected subprogram,
1698          --  unlocking the protected object parameter and undeferring abortion.
1699          --  If this is a protected procedure, and the object contains
1700          --  entries, this also calls the entry service routine.
1701
1702          --  NOTE: This cleanup handler references _object, a parameter
1703          --        to the procedure.
1704
1705          --  Find the _object parameter representing the protected object.
1706
1707          Spec := Parent (Corresponding_Spec (N));
1708
1709          Param := First (Parameter_Specifications (Spec));
1710          loop
1711             Param_Type := Etype (Parameter_Type (Param));
1712
1713             if Ekind (Param_Type) = E_Record_Type then
1714                Pid := Corresponding_Concurrent_Type (Param_Type);
1715             end if;
1716
1717             exit when not Present (Param) or else Present (Pid);
1718             Next (Param);
1719          end loop;
1720
1721          pragma Assert (Present (Param));
1722
1723          --  If the associated protected object declares entries,
1724          --  a protected procedure has to service entry queues.
1725          --  In this case, add
1726
1727          --  Service_Entries (_object._object'Access);
1728
1729          --  _object is the record used to implement the protected object.
1730          --  It is a parameter to the protected subprogram.
1731
1732          if Nkind (Specification (N)) = N_Procedure_Specification
1733            and then Has_Entries (Pid)
1734          then
1735             if Abort_Allowed
1736               or else Restrictions (No_Entry_Queue) = False
1737               or else Number_Entries (Pid) > 1
1738             then
1739                Name := New_Reference_To (RTE (RE_Service_Entries), Loc);
1740             else
1741                Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
1742             end if;
1743
1744             Append_To (Stmt,
1745               Make_Procedure_Call_Statement (Loc,
1746                 Name => Name,
1747                 Parameter_Associations => New_List (
1748                   Make_Attribute_Reference (Loc,
1749                     Prefix =>
1750                       Make_Selected_Component (Loc,
1751                         Prefix => New_Reference_To (
1752                           Defining_Identifier (Param), Loc),
1753                         Selector_Name =>
1754                           Make_Identifier (Loc, Name_uObject)),
1755                     Attribute_Name => Name_Unchecked_Access))));
1756          end if;
1757
1758          --  Unlock (_object._object'Access);
1759
1760          --  _object is the record used to implement the protected object.
1761          --  It is a parameter to the protected subprogram.
1762
1763          --  If the protected object is controlled (i.e it has entries or
1764          --  needs finalization for interrupt handling), call Unlock_Entries,
1765          --  except if the protected object follows the ravenscar profile, in
1766          --  which case call Unlock_Entry, otherwise call the simplified
1767          --  version, Unlock.
1768
1769          if Has_Entries (Pid)
1770            or else Has_Interrupt_Handler (Pid)
1771            or else Has_Attach_Handler (Pid)
1772          then
1773             if Abort_Allowed
1774               or else Restrictions (No_Entry_Queue) = False
1775               or else Number_Entries (Pid) > 1
1776             then
1777                Unlock := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
1778             else
1779                Unlock := New_Reference_To (RTE (RE_Unlock_Entry), Loc);
1780             end if;
1781
1782          else
1783             Unlock := New_Reference_To (RTE (RE_Unlock), Loc);
1784          end if;
1785
1786          Append_To (Stmt,
1787            Make_Procedure_Call_Statement (Loc,
1788              Name => Unlock,
1789              Parameter_Associations => New_List (
1790                Make_Attribute_Reference (Loc,
1791                  Prefix =>
1792                    Make_Selected_Component (Loc,
1793                      Prefix =>
1794                        New_Reference_To (Defining_Identifier (Param), Loc),
1795                      Selector_Name =>
1796                        Make_Identifier (Loc, Name_uObject)),
1797                  Attribute_Name => Name_Unchecked_Access))));
1798
1799          if Abort_Allowed then
1800             --  Abort_Undefer;
1801
1802             Append_To (Stmt,
1803               Make_Procedure_Call_Statement (Loc,
1804                 Name =>
1805                   New_Reference_To (
1806                     RTE (RE_Abort_Undefer), Loc),
1807                 Parameter_Associations => Empty_List));
1808          end if;
1809
1810       elsif Is_Task_Allocation_Block then
1811
1812          --  Add a call to Expunge_Unactivated_Tasks to the cleanup
1813          --  handler of a block created for the dynamic allocation of
1814          --  tasks:
1815
1816          --  Expunge_Unactivated_Tasks (_chain);
1817
1818          --  where _chain is the list of tasks created by the allocator
1819          --  but not yet activated. This list will be empty unless
1820          --  the block completes abnormally.
1821
1822          --  This only applies to dynamically allocated tasks;
1823          --  other unactivated tasks are completed by Complete_Task or
1824          --  Complete_Master.
1825
1826          --  NOTE: This cleanup handler references _chain, a local
1827          --        object.
1828
1829          Append_To (Stmt,
1830            Make_Procedure_Call_Statement (Loc,
1831              Name =>
1832                New_Reference_To (
1833                  RTE (RE_Expunge_Unactivated_Tasks), Loc),
1834              Parameter_Associations => New_List (
1835                New_Reference_To (Activation_Chain_Entity (N), Loc))));
1836
1837       elsif Is_Asynchronous_Call_Block then
1838
1839          --  Add a call to attempt to cancel the asynchronous entry call
1840          --  whenever the block containing the abortable part is exited.
1841
1842          --  NOTE: This cleanup handler references C, a local object
1843
1844          --  Get the argument to the Cancel procedure
1845          Cancel_Param := Entry_Cancel_Parameter (Entity (Identifier (N)));
1846
1847          --  If it is of type Communication_Block, this must be a
1848          --  protected entry call.
1849
1850          if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
1851
1852             Append_To (Stmt,
1853
1854             --  if Enqueued (Cancel_Parameter) then
1855
1856               Make_Implicit_If_Statement (Clean,
1857                 Condition => Make_Function_Call (Loc,
1858                   Name => New_Reference_To (
1859                     RTE (RE_Enqueued), Loc),
1860                   Parameter_Associations => New_List (
1861                     New_Reference_To (Cancel_Param, Loc))),
1862                 Then_Statements => New_List (
1863
1864             --  Cancel_Protected_Entry_Call (Cancel_Param);
1865
1866                   Make_Procedure_Call_Statement (Loc,
1867                     Name => New_Reference_To (
1868                       RTE (RE_Cancel_Protected_Entry_Call), Loc),
1869                     Parameter_Associations => New_List (
1870                       New_Reference_To (Cancel_Param, Loc))))));
1871
1872          --  Asynchronous delay
1873
1874          elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
1875             Append_To (Stmt,
1876               Make_Procedure_Call_Statement (Loc,
1877                 Name => New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc),
1878                 Parameter_Associations => New_List (
1879                   Make_Attribute_Reference (Loc,
1880                     Prefix => New_Reference_To (Cancel_Param, Loc),
1881                     Attribute_Name => Name_Unchecked_Access))));
1882
1883          --  Task entry call
1884
1885          else
1886             --  Append call to Cancel_Task_Entry_Call (C);
1887
1888             Append_To (Stmt,
1889               Make_Procedure_Call_Statement (Loc,
1890                 Name => New_Reference_To (
1891                   RTE (RE_Cancel_Task_Entry_Call),
1892                   Loc),
1893                 Parameter_Associations => New_List (
1894                   New_Reference_To (Cancel_Param, Loc))));
1895
1896          end if;
1897       end if;
1898
1899       if Present (Flist) then
1900          Append_To (Stmt,
1901            Make_Procedure_Call_Statement (Loc,
1902              Name => New_Reference_To (RTE (RE_Finalize_List), Loc),
1903              Parameter_Associations => New_List (
1904                     New_Reference_To (Flist, Loc))));
1905       end if;
1906
1907       if Present (Mark) then
1908          Append_To (Stmt,
1909            Make_Procedure_Call_Statement (Loc,
1910              Name => New_Reference_To (RTE (RE_SS_Release), Loc),
1911              Parameter_Associations => New_List (
1912                     New_Reference_To (Mark, Loc))));
1913       end if;
1914
1915       Sbody :=
1916         Make_Subprogram_Body (Loc,
1917           Specification =>
1918             Make_Procedure_Specification (Loc,
1919               Defining_Unit_Name => Clean),
1920
1921           Declarations  => New_List,
1922
1923           Handled_Statement_Sequence =>
1924             Make_Handled_Sequence_Of_Statements (Loc,
1925               Statements => Stmt));
1926
1927       if Present (Flist) or else Is_Task or else Is_Master then
1928          Wrap_Cleanup_Procedure (Sbody);
1929       end if;
1930
1931       --  We do not want debug information for _Clean routines,
1932       --  since it just confuses the debugging operation unless
1933       --  we are debugging generated code.
1934
1935       if not Debug_Generated_Code then
1936          Set_Debug_Info_Off (Clean, True);
1937       end if;
1938
1939       return Sbody;
1940    end Make_Clean;
1941
1942    --------------------------
1943    -- Make_Deep_Array_Body --
1944    --------------------------
1945
1946    --  Array components are initialized and adjusted in the normal order
1947    --  and finalized in the reverse order. Exceptions are handled and
1948    --  Program_Error is re-raise in the Adjust and Finalize case
1949    --  (RM 7.6.1(12)). Generate the following code :
1950    --
1951    --  procedure Deep_<P>   --  with <P> being Initialize or Adjust or Finalize
1952    --   (L : in out Finalizable_Ptr;
1953    --    V : in out Typ)
1954    --  is
1955    --  begin
1956    --     for J1 in             Typ'First (1) .. Typ'Last (1) loop
1957    --               ^ reverse ^  --  in the finalization case
1958    --        ...
1959    --           for J2 in Typ'First (n) .. Typ'Last (n) loop
1960    --                 Make_<P>_Call (Typ, V (J1, .. , Jn), L, V);
1961    --           end loop;
1962    --        ...
1963    --     end loop;
1964    --  exception                                --  not in the
1965    --     when others => raise Program_Error;   --     Initialize case
1966    --  end Deep_<P>;
1967
1968    function Make_Deep_Array_Body
1969      (Prim : Final_Primitives;
1970       Typ  : Entity_Id)
1971       return List_Id
1972    is
1973       Loc : constant Source_Ptr := Sloc (Typ);
1974
1975       Index_List : constant List_Id := New_List;
1976       --  Stores the list of references to the indexes (one per dimension)
1977
1978       function One_Component return List_Id;
1979       --  Create one statement to initialize/adjust/finalize one array
1980       --  component, designated by a full set of indices.
1981
1982       function One_Dimension (N : Int) return List_Id;
1983       --  Create loop to deal with one dimension of the array. The single
1984       --  statement in the body of the loop initializes the inner dimensions if
1985       --  any, or else a single component.
1986
1987       -------------------
1988       -- One_Component --
1989       -------------------
1990
1991       function One_Component return List_Id is
1992          Comp_Typ : constant Entity_Id := Component_Type (Typ);
1993          Comp_Ref : constant Node_Id :=
1994                       Make_Indexed_Component (Loc,
1995                         Prefix      => Make_Identifier (Loc, Name_V),
1996                         Expressions => Index_List);
1997
1998       begin
1999          --  Set the etype of the component Reference, which is used to
2000          --  determine whether a conversion to a parent type is needed.
2001
2002          Set_Etype (Comp_Ref, Comp_Typ);
2003
2004          case Prim is
2005             when Initialize_Case =>
2006                return Make_Init_Call (Comp_Ref, Comp_Typ,
2007                         Make_Identifier (Loc, Name_L),
2008                         Make_Identifier (Loc, Name_B));
2009
2010             when Adjust_Case =>
2011                return Make_Adjust_Call (Comp_Ref, Comp_Typ,
2012                         Make_Identifier (Loc, Name_L),
2013                         Make_Identifier (Loc, Name_B));
2014
2015             when Finalize_Case =>
2016                return Make_Final_Call (Comp_Ref, Comp_Typ,
2017                         Make_Identifier (Loc, Name_B));
2018          end case;
2019       end One_Component;
2020
2021       -------------------
2022       -- One_Dimension --
2023       -------------------
2024
2025       function One_Dimension (N : Int) return List_Id is
2026          Index : Entity_Id;
2027
2028       begin
2029          if N > Number_Dimensions (Typ) then
2030             return One_Component;
2031
2032          else
2033             Index :=
2034               Make_Defining_Identifier (Loc, New_External_Name ('J', N));
2035
2036             Append_To (Index_List, New_Reference_To (Index, Loc));
2037
2038             return New_List (
2039               Make_Implicit_Loop_Statement (Typ,
2040                 Identifier => Empty,
2041                 Iteration_Scheme =>
2042                   Make_Iteration_Scheme (Loc,
2043                     Loop_Parameter_Specification =>
2044                       Make_Loop_Parameter_Specification (Loc,
2045                         Defining_Identifier => Index,
2046                         Discrete_Subtype_Definition =>
2047                           Make_Attribute_Reference (Loc,
2048                             Prefix => Make_Identifier (Loc, Name_V),
2049                             Attribute_Name  => Name_Range,
2050                             Expressions => New_List (
2051                               Make_Integer_Literal (Loc, N))),
2052                         Reverse_Present => Prim = Finalize_Case)),
2053                 Statements => One_Dimension (N + 1)));
2054          end if;
2055       end One_Dimension;
2056
2057    --  Start of processing for Make_Deep_Array_Body
2058
2059    begin
2060       return One_Dimension (1);
2061    end Make_Deep_Array_Body;
2062
2063    --------------------
2064    -- Make_Deep_Proc --
2065    --------------------
2066
2067    --  Generate:
2068    --    procedure DEEP_<prim>
2069    --      (L : IN OUT Finalizable_Ptr;    -- not for Finalize
2070    --       V : IN OUT <typ>;
2071    --       B : IN Short_Short_Integer) is
2072    --    begin
2073    --       <stmts>;
2074    --    exception                   --  Finalize and Adjust Cases only
2075    --       raise Program_Error;     --  idem
2076    --    end DEEP_<prim>;
2077
2078    function Make_Deep_Proc
2079      (Prim  : Final_Primitives;
2080       Typ   : Entity_Id;
2081       Stmts : List_Id)
2082       return Entity_Id
2083    is
2084       Loc       : constant Source_Ptr := Sloc (Typ);
2085       Formals   : List_Id;
2086       Proc_Name : Entity_Id;
2087       Handler   : List_Id := No_List;
2088       Subp_Body : Node_Id;
2089       Type_B    : Entity_Id;
2090
2091    begin
2092       if Prim = Finalize_Case then
2093          Formals := New_List;
2094          Type_B := Standard_Boolean;
2095
2096       else
2097          Formals := New_List (
2098            Make_Parameter_Specification (Loc,
2099              Defining_Identifier => Make_Defining_Identifier (Loc, Name_L),
2100              In_Present          => True,
2101              Out_Present         => True,
2102              Parameter_Type      =>
2103                New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
2104          Type_B := Standard_Short_Short_Integer;
2105       end if;
2106
2107       Append_To (Formals,
2108         Make_Parameter_Specification (Loc,
2109            Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
2110           In_Present          => True,
2111           Out_Present         => True,
2112           Parameter_Type      => New_Reference_To (Typ, Loc)));
2113
2114       Append_To (Formals,
2115         Make_Parameter_Specification (Loc,
2116           Defining_Identifier => Make_Defining_Identifier (Loc, Name_B),
2117           Parameter_Type      => New_Reference_To (Type_B, Loc)));
2118
2119       if Prim = Finalize_Case or else Prim = Adjust_Case then
2120          Handler := New_List (
2121            Make_Exception_Handler (Loc,
2122              Exception_Choices => New_List (Make_Others_Choice (Loc)),
2123              Statements        => New_List (
2124                Make_Raise_Program_Error (Loc,
2125                  Reason => PE_Finalize_Raised_Exception))));
2126       end if;
2127
2128       Proc_Name := Make_Defining_Identifier (Loc, Deep_Name_Of (Prim));
2129
2130       Subp_Body :=
2131         Make_Subprogram_Body (Loc,
2132           Specification =>
2133             Make_Procedure_Specification (Loc,
2134               Defining_Unit_Name       => Proc_Name,
2135               Parameter_Specifications => Formals),
2136
2137           Declarations =>  Empty_List,
2138           Handled_Statement_Sequence =>
2139             Make_Handled_Sequence_Of_Statements (Loc,
2140               Statements         => Stmts,
2141               Exception_Handlers => Handler));
2142
2143       return Proc_Name;
2144    end Make_Deep_Proc;
2145
2146    ---------------------------
2147    -- Make_Deep_Record_Body --
2148    ---------------------------
2149
2150    --  The Deep procedures call the appropriate Controlling proc on the
2151    --  the controller component. In the init case, it also attach the
2152    --  controller to the current finalization list.
2153
2154    function Make_Deep_Record_Body
2155      (Prim : Final_Primitives;
2156       Typ  : Entity_Id)
2157       return List_Id
2158    is
2159       Loc            : constant Source_Ptr := Sloc (Typ);
2160       Controller_Typ : Entity_Id;
2161       Obj_Ref        : constant Node_Id := Make_Identifier (Loc, Name_V);
2162       Controller_Ref : constant Node_Id :=
2163                          Make_Selected_Component (Loc,
2164                            Prefix        => Obj_Ref,
2165                            Selector_Name =>
2166                              Make_Identifier (Loc, Name_uController));
2167
2168    begin
2169       if Is_Return_By_Reference_Type (Typ) then
2170          Controller_Typ := RTE (RE_Limited_Record_Controller);
2171       else
2172          Controller_Typ := RTE (RE_Record_Controller);
2173       end if;
2174
2175       case Prim is
2176          when Initialize_Case =>
2177             declare
2178                Res  : constant List_Id := New_List;
2179
2180             begin
2181                Append_List_To (Res,
2182                  Make_Init_Call (
2183                    Ref          => Controller_Ref,
2184                    Typ          => Controller_Typ,
2185                    Flist_Ref    => Make_Identifier (Loc, Name_L),
2186                    With_Attach  => Make_Identifier (Loc, Name_B)));
2187
2188                --  When the type is also a controlled type by itself,
2189                --  Initialize it and attach it at the end of the internal
2190                --  finalization chain
2191
2192                if Is_Controlled (Typ) then
2193                   Append_To (Res,
2194                     Make_Procedure_Call_Statement (Loc,
2195                       Name => New_Reference_To (
2196                         Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
2197
2198                       Parameter_Associations =>
2199                         New_List (New_Copy_Tree (Obj_Ref))));
2200
2201                   Append_To (Res, Make_Attach_Call (
2202                     Obj_Ref      => New_Copy_Tree (Obj_Ref),
2203                     Flist_Ref    =>
2204                       Make_Selected_Component (Loc,
2205                         Prefix        => New_Copy_Tree (Controller_Ref),
2206                         Selector_Name => Make_Identifier (Loc, Name_F)),
2207                     With_Attach => Make_Integer_Literal (Loc, 1)));
2208                end if;
2209
2210                return Res;
2211             end;
2212
2213          when Adjust_Case =>
2214             return
2215               Make_Adjust_Call (Controller_Ref, Controller_Typ,
2216                 Make_Identifier (Loc, Name_L),
2217                 Make_Identifier (Loc, Name_B));
2218
2219          when Finalize_Case =>
2220             return
2221               Make_Final_Call (Controller_Ref, Controller_Typ,
2222                 Make_Identifier (Loc, Name_B));
2223       end case;
2224    end Make_Deep_Record_Body;
2225
2226    ----------------------
2227    -- Make_Final_Call --
2228    ----------------------
2229
2230    function Make_Final_Call
2231      (Ref         : Node_Id;
2232       Typ         : Entity_Id;
2233       With_Detach : Node_Id)
2234       return        List_Id
2235    is
2236       Loc   : constant Source_Ptr := Sloc (Ref);
2237       Res   : constant List_Id    := New_List;
2238       Cref  : Node_Id;
2239       Cref2 : Node_Id;
2240       Proc  : Entity_Id;
2241       Utyp  : Entity_Id;
2242
2243    begin
2244       if Is_Class_Wide_Type (Typ) then
2245          Utyp := Root_Type (Typ);
2246          Cref := Ref;
2247
2248       elsif Is_Concurrent_Type (Typ) then
2249          Utyp := Corresponding_Record_Type (Typ);
2250          Cref := Convert_Concurrent (Ref, Typ);
2251
2252       elsif Is_Private_Type (Typ)
2253         and then Present (Full_View (Typ))
2254         and then Is_Concurrent_Type (Full_View (Typ))
2255       then
2256          Utyp := Corresponding_Record_Type (Full_View (Typ));
2257          Cref := Convert_Concurrent (Ref, Full_View (Typ));
2258       else
2259          Utyp := Typ;
2260          Cref := Ref;
2261       end if;
2262
2263       Utyp := Underlying_Type (Base_Type (Utyp));
2264       Set_Assignment_OK (Cref);
2265
2266       --  Deal with non-tagged derivation of private views
2267
2268       if Is_Untagged_Derivation (Typ) then
2269          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
2270          Cref := Unchecked_Convert_To (Utyp, Cref);
2271          Set_Assignment_OK (Cref);
2272          --  To prevent problems with UC see 1.156 RH ???
2273       end if;
2274
2275       --  If the underlying_type is a subtype, we are dealing with
2276       --  the completion of a private type. We need to access
2277       --  the base type and generate a conversion to it.
2278
2279       if Utyp /= Base_Type (Utyp) then
2280          pragma Assert (Is_Private_Type (Typ));
2281          Utyp := Base_Type (Utyp);
2282          Cref := Unchecked_Convert_To (Utyp, Cref);
2283       end if;
2284
2285       --  Generate:
2286       --    Deep_Finalize (Ref, With_Detach);
2287
2288       if Has_Controlled_Component (Utyp)
2289         or else Is_Class_Wide_Type (Typ)
2290       then
2291          if Is_Tagged_Type (Utyp) then
2292             Proc := Find_Prim_Op (Utyp, Deep_Name_Of (Finalize_Case));
2293          else
2294             Proc := TSS (Utyp, Deep_Name_Of (Finalize_Case));
2295          end if;
2296
2297          Cref := Convert_View (Proc, Cref);
2298
2299          Append_To (Res,
2300            Make_Procedure_Call_Statement (Loc,
2301              Name => New_Reference_To (Proc, Loc),
2302              Parameter_Associations =>
2303                New_List (Cref, With_Detach)));
2304
2305       --  Generate:
2306       --    if With_Detach then
2307       --       Finalize_One (Ref);
2308       --    else
2309       --       Finalize (Ref);
2310       --    end if;
2311
2312       else
2313          Proc := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
2314
2315          if Chars (With_Detach) = Chars (Standard_True) then
2316             Append_To (Res,
2317               Make_Procedure_Call_Statement (Loc,
2318                 Name => New_Reference_To (RTE (RE_Finalize_One), Loc),
2319                 Parameter_Associations => New_List (
2320                   OK_Convert_To (RTE (RE_Finalizable), Cref))));
2321
2322          elsif Chars (With_Detach) = Chars (Standard_False) then
2323             Append_To (Res,
2324               Make_Procedure_Call_Statement (Loc,
2325                 Name => New_Reference_To (Proc, Loc),
2326                 Parameter_Associations =>
2327                   New_List (Convert_View (Proc, Cref))));
2328
2329          else
2330             Cref2 := New_Copy_Tree (Cref);
2331             Append_To (Res,
2332               Make_Implicit_If_Statement (Ref,
2333                 Condition => With_Detach,
2334                 Then_Statements => New_List (
2335                   Make_Procedure_Call_Statement (Loc,
2336                     Name => New_Reference_To (RTE (RE_Finalize_One), Loc),
2337                     Parameter_Associations => New_List (
2338                       OK_Convert_To (RTE (RE_Finalizable), Cref)))),
2339
2340                 Else_Statements => New_List (
2341                   Make_Procedure_Call_Statement (Loc,
2342                     Name => New_Reference_To (Proc, Loc),
2343                     Parameter_Associations =>
2344                       New_List (Convert_View (Proc, Cref2))))));
2345          end if;
2346       end if;
2347
2348          --  Treat this as a reference to Finalize if the Finalize routine
2349          --  comes from source. The call is not explicit, but it is near
2350          --  enough, and we won't typically get explicit adjust calls.
2351
2352          if Comes_From_Source (Proc) then
2353             Generate_Reference (Proc, Ref);
2354          end if;
2355       return Res;
2356    end Make_Final_Call;
2357
2358    --------------------
2359    -- Make_Init_Call --
2360    --------------------
2361
2362    function Make_Init_Call
2363      (Ref          : Node_Id;
2364       Typ          : Entity_Id;
2365       Flist_Ref    : Node_Id;
2366       With_Attach  : Node_Id)
2367       return         List_Id
2368    is
2369       Loc     : constant Source_Ptr := Sloc (Ref);
2370       Is_Conc : Boolean;
2371       Res     : constant List_Id := New_List;
2372       Proc    : Entity_Id;
2373       Utyp    : Entity_Id;
2374       Cref    : Node_Id;
2375       Cref2   : Node_Id;
2376       Attach  : Node_Id := With_Attach;
2377
2378    begin
2379       if Is_Concurrent_Type (Typ) then
2380          Is_Conc := True;
2381          Utyp    := Corresponding_Record_Type (Typ);
2382          Cref    := Convert_Concurrent (Ref, Typ);
2383
2384       elsif Is_Private_Type (Typ)
2385         and then Present (Full_View (Typ))
2386         and then Is_Concurrent_Type (Underlying_Type (Typ))
2387       then
2388          Is_Conc := True;
2389          Utyp    := Corresponding_Record_Type (Underlying_Type (Typ));
2390          Cref    := Convert_Concurrent (Ref, Underlying_Type (Typ));
2391
2392       else
2393          Is_Conc := False;
2394          Utyp    := Typ;
2395          Cref    := Ref;
2396       end if;
2397
2398       Utyp := Underlying_Type (Base_Type (Utyp));
2399
2400       Set_Assignment_OK (Cref);
2401
2402       --  Deal with non-tagged derivation of private views
2403
2404       if Is_Untagged_Derivation (Typ)
2405         and then not Is_Conc
2406       then
2407          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
2408          Cref := Unchecked_Convert_To (Utyp, Cref);
2409          Set_Assignment_OK (Cref);
2410          --  To prevent problems with UC see 1.156 RH ???
2411       end if;
2412
2413       --  If the underlying_type is a subtype, we are dealing with
2414       --  the completion of a private type. We need to access
2415       --  the base type and generate a conversion to it.
2416
2417       if Utyp /= Base_Type (Utyp) then
2418          pragma Assert (Is_Private_Type (Typ));
2419          Utyp := Base_Type (Utyp);
2420          Cref := Unchecked_Convert_To (Utyp, Cref);
2421       end if;
2422
2423       --  We do not need to attach to one of the Global Final Lists
2424       --  the objects whose type is Finalize_Storage_Only
2425
2426       if Finalize_Storage_Only (Typ)
2427         and then (Global_Flist_Ref (Flist_Ref)
2428           or else Entity (Constant_Value (RTE (RE_Garbage_Collected)))
2429                   = Standard_True)
2430       then
2431          Attach := Make_Integer_Literal (Loc, 0);
2432       end if;
2433
2434       --  Generate:
2435       --    Deep_Initialize (Ref, Flist_Ref);
2436
2437       if Has_Controlled_Component (Utyp) then
2438          Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
2439
2440          Cref := Convert_View (Proc, Cref, 2);
2441
2442          Append_To (Res,
2443            Make_Procedure_Call_Statement (Loc,
2444              Name => New_Reference_To (Proc, Loc),
2445              Parameter_Associations => New_List (
2446                Node1 => Flist_Ref,
2447                Node2 => Cref,
2448                Node3 => Attach)));
2449
2450       --  Generate:
2451       --    Attach_To_Final_List (Ref, Flist_Ref);
2452       --    Initialize (Ref);
2453
2454       else -- Is_Controlled (Utyp)
2455          Proc  := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
2456          Cref  := Convert_View (Proc, Cref);
2457          Cref2 := New_Copy_Tree (Cref);
2458
2459          Append_To (Res,
2460            Make_Procedure_Call_Statement (Loc,
2461            Name => New_Reference_To (Proc, Loc),
2462            Parameter_Associations => New_List (Cref2)));
2463
2464          Append_To (Res,
2465            Make_Attach_Call (Cref, Flist_Ref, Attach));
2466
2467          --  Treat this as a reference to Initialize if Initialize routine
2468          --  comes from source. The call is not explicit, but it is near
2469          --  enough, and we won't typically get explicit adjust calls.
2470
2471          if Comes_From_Source (Proc) then
2472             Generate_Reference (Proc, Ref);
2473          end if;
2474       end if;
2475
2476       return Res;
2477    end Make_Init_Call;
2478
2479    --------------------------
2480    -- Make_Transient_Block --
2481    --------------------------
2482
2483    --  If finalization is involved, this function just wraps the instruction
2484    --  into a block whose name is the transient block entity, and then
2485    --  Expand_Cleanup_Actions (called on the expansion of the handled
2486    --  sequence of statements will do the necessary expansions for
2487    --  cleanups).
2488
2489    function Make_Transient_Block
2490      (Loc    : Source_Ptr;
2491       Action : Node_Id)
2492       return   Node_Id
2493    is
2494       Flist  : constant Entity_Id := Finalization_Chain_Entity (Current_Scope);
2495       Decls  : constant List_Id   := New_List;
2496       Par    : constant Node_Id   := Parent (Action);
2497       Instrs : constant List_Id   := New_List (Action);
2498       Blk    : Node_Id;
2499
2500    begin
2501       --  Case where only secondary stack use is involved
2502
2503       if Uses_Sec_Stack (Current_Scope)
2504         and then No (Flist)
2505         and then Nkind (Action) /= N_Return_Statement
2506         and then Nkind (Par) /= N_Exception_Handler
2507       then
2508
2509          declare
2510             S  : Entity_Id;
2511             K  : Entity_Kind;
2512          begin
2513             S := Scope (Current_Scope);
2514             loop
2515                K := Ekind (S);
2516
2517                --  At the outer level, no need to release the sec stack
2518
2519                if S = Standard_Standard then
2520                   Set_Uses_Sec_Stack (Current_Scope, False);
2521                   exit;
2522
2523                --  In a function, only release the sec stack if the
2524                --  function does not return on the sec stack otherwise
2525                --  the result may be lost. The caller is responsible for
2526                --  releasing.
2527
2528                elsif K = E_Function then
2529                   Set_Uses_Sec_Stack (Current_Scope, False);
2530
2531                   if not Requires_Transient_Scope (Etype (S)) then
2532                      if not Functions_Return_By_DSP_On_Target then
2533                         Set_Uses_Sec_Stack (S, True);
2534                         Check_Restriction (No_Secondary_Stack, Action);
2535                      end if;
2536                   end if;
2537
2538                   exit;
2539
2540                --  In a loop or entry we should install a block encompassing
2541                --  all the construct. For now just release right away.
2542
2543                elsif K = E_Loop or else K = E_Entry then
2544                   exit;
2545
2546                --  In a procedure or a block, we release on exit of the
2547                --  procedure or block. ??? memory leak can be created by
2548                --  recursive calls.
2549
2550                elsif K = E_Procedure
2551                  or else K = E_Block
2552                then
2553                   if not Functions_Return_By_DSP_On_Target then
2554                      Set_Uses_Sec_Stack (S, True);
2555                      Check_Restriction (No_Secondary_Stack, Action);
2556                   end if;
2557
2558                   Set_Uses_Sec_Stack (Current_Scope, False);
2559                   exit;
2560
2561                else
2562                   S := Scope (S);
2563                end if;
2564             end loop;
2565          end;
2566       end if;
2567
2568       --  Insert actions stuck in the transient scopes as well as all
2569       --  freezing nodes needed by those actions
2570
2571       Insert_Actions_In_Scope_Around (Action);
2572
2573       declare
2574          Last_Inserted : Node_Id := Prev (Action);
2575
2576       begin
2577          if Present (Last_Inserted) then
2578             Freeze_All (First_Entity (Current_Scope), Last_Inserted);
2579          end if;
2580       end;
2581
2582       Blk :=
2583         Make_Block_Statement (Loc,
2584           Identifier => New_Reference_To (Current_Scope, Loc),
2585           Declarations => Decls,
2586           Handled_Statement_Sequence =>
2587             Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
2588           Has_Created_Identifier => True);
2589
2590       --  When the transient scope was established, we pushed the entry for
2591       --  the transient scope onto the scope stack, so that the scope was
2592       --  active for the installation of finalizable entities etc. Now we
2593       --  must remove this entry, since we have constructed a proper block.
2594
2595       Pop_Scope;
2596
2597       return Blk;
2598    end Make_Transient_Block;
2599
2600    ------------------------
2601    -- Node_To_Be_Wrapped --
2602    ------------------------
2603
2604    function Node_To_Be_Wrapped return Node_Id is
2605    begin
2606       return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
2607    end Node_To_Be_Wrapped;
2608
2609    ----------------------------
2610    -- Set_Node_To_Be_Wrapped --
2611    ----------------------------
2612
2613    procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
2614    begin
2615       Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
2616    end Set_Node_To_Be_Wrapped;
2617
2618    ----------------------------------
2619    -- Store_After_Actions_In_Scope --
2620    ----------------------------------
2621
2622    procedure Store_After_Actions_In_Scope (L : List_Id) is
2623       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
2624
2625    begin
2626       if Present (SE.Actions_To_Be_Wrapped_After) then
2627          Insert_List_Before_And_Analyze (
2628           First (SE.Actions_To_Be_Wrapped_After), L);
2629
2630       else
2631          SE.Actions_To_Be_Wrapped_After := L;
2632
2633          if Is_List_Member (SE.Node_To_Be_Wrapped) then
2634             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
2635          else
2636             Set_Parent (L, SE.Node_To_Be_Wrapped);
2637          end if;
2638
2639          Analyze_List (L);
2640       end if;
2641    end Store_After_Actions_In_Scope;
2642
2643    -----------------------------------
2644    -- Store_Before_Actions_In_Scope --
2645    -----------------------------------
2646
2647    procedure Store_Before_Actions_In_Scope (L : List_Id) is
2648       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
2649
2650    begin
2651       if Present (SE.Actions_To_Be_Wrapped_Before) then
2652          Insert_List_After_And_Analyze (
2653            Last (SE.Actions_To_Be_Wrapped_Before), L);
2654
2655       else
2656          SE.Actions_To_Be_Wrapped_Before := L;
2657
2658          if Is_List_Member (SE.Node_To_Be_Wrapped) then
2659             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
2660          else
2661             Set_Parent (L, SE.Node_To_Be_Wrapped);
2662          end if;
2663
2664          Analyze_List (L);
2665       end if;
2666    end Store_Before_Actions_In_Scope;
2667
2668    --------------------------------
2669    -- Wrap_Transient_Declaration --
2670    --------------------------------
2671
2672    --  If a transient scope has been established during the processing of the
2673    --  Expression of an Object_Declaration, it is not possible to wrap the
2674    --  declaration into a transient block as usual case, otherwise the object
2675    --  would be itself declared in the wrong scope. Therefore, all entities (if
2676    --  any) defined in the transient block are moved to the proper enclosing
2677    --  scope, furthermore, if they are controlled variables they are finalized
2678    --  right after the declaration. The finalization list of the transient
2679    --  scope is defined as a renaming of the enclosing one so during their
2680    --  initialization they will be attached to the proper finalization
2681    --  list. For instance, the following declaration :
2682
2683    --        X : Typ := F (G (A), G (B));
2684
2685    --  (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
2686    --  is expanded into :
2687
2688    --    _local_final_list_1 : Finalizable_Ptr;
2689    --    X : Typ := [ complex Expression-Action ];
2690    --    Finalize_One(_v1);
2691    --    Finalize_One (_v2);
2692
2693    procedure Wrap_Transient_Declaration (N : Node_Id) is
2694       S           : Entity_Id;
2695       LC          : Entity_Id := Empty;
2696       Nodes       : List_Id;
2697       Loc         : constant Source_Ptr := Sloc (N);
2698       Enclosing_S : Entity_Id;
2699       Uses_SS     : Boolean;
2700       Next_N      : constant Node_Id := Next (N);
2701
2702    begin
2703       S := Current_Scope;
2704       Enclosing_S := Scope (S);
2705
2706       --  Insert Actions kept in the Scope stack
2707
2708       Insert_Actions_In_Scope_Around (N);
2709
2710       --  If the declaration is consuming some secondary stack, mark the
2711       --  Enclosing scope appropriately.
2712
2713       Uses_SS := Uses_Sec_Stack (S);
2714       Pop_Scope;
2715
2716       --  Create a List controller and rename the final list to be its
2717       --  internal final pointer:
2718       --       Lxxx : Simple_List_Controller;
2719       --       Fxxx : Finalizable_Ptr renames Lxxx.F;
2720
2721       if Present (Finalization_Chain_Entity (S)) then
2722          LC := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
2723
2724          Nodes := New_List (
2725            Make_Object_Declaration (Loc,
2726              Defining_Identifier => LC,
2727              Object_Definition   =>
2728                New_Reference_To (RTE (RE_Simple_List_Controller), Loc)),
2729
2730            Make_Object_Renaming_Declaration (Loc,
2731              Defining_Identifier => Finalization_Chain_Entity (S),
2732              Subtype_Mark => New_Reference_To (RTE (RE_Finalizable_Ptr), Loc),
2733              Name =>
2734                Make_Selected_Component (Loc,
2735                  Prefix        => New_Reference_To (LC, Loc),
2736                  Selector_Name => Make_Identifier (Loc, Name_F))));
2737
2738          --  Put the declaration at the beginning of the declaration part
2739          --  to make sure it will be before all other actions that have been
2740          --  inserted before N.
2741
2742          Insert_List_Before_And_Analyze (First (List_Containing (N)), Nodes);
2743
2744          --  Generate the Finalization calls by finalizing the list
2745          --  controller right away. It will be re-finalized on scope
2746          --  exit but it doesn't matter. It cannot be done when the
2747          --  call initializes a renaming object though because in this
2748          --  case, the object becomes a pointer to the temporary and thus
2749          --  increases its life span.
2750
2751          if Nkind (N) = N_Object_Renaming_Declaration
2752            and then Controlled_Type (Etype (Defining_Identifier (N)))
2753          then
2754             null;
2755
2756          else
2757             Nodes :=
2758               Make_Final_Call (
2759                    Ref         => New_Reference_To (LC, Loc),
2760                    Typ         => Etype (LC),
2761                    With_Detach => New_Reference_To (Standard_False, Loc));
2762             if Present (Next_N) then
2763                Insert_List_Before_And_Analyze (Next_N, Nodes);
2764             else
2765                Append_List_To (List_Containing (N), Nodes);
2766             end if;
2767          end if;
2768       end if;
2769
2770       --  Put the local entities back in the enclosing scope, and set the
2771       --  Is_Public flag appropriately.
2772
2773       Transfer_Entities (S, Enclosing_S);
2774
2775       --  Mark the enclosing dynamic scope so that the sec stack will be
2776       --  released upon its exit unless this is a function that returns on
2777       --  the sec stack in which case this will be done by the caller.
2778
2779       if Uses_SS then
2780          S := Enclosing_Dynamic_Scope (S);
2781
2782          if Ekind (S) = E_Function
2783            and then Requires_Transient_Scope (Etype (S))
2784          then
2785             null;
2786          else
2787             Set_Uses_Sec_Stack (S);
2788             Check_Restriction (No_Secondary_Stack, N);
2789          end if;
2790       end if;
2791    end Wrap_Transient_Declaration;
2792
2793    -------------------------------
2794    -- Wrap_Transient_Expression --
2795    -------------------------------
2796
2797    --  Insert actions before <Expression>:
2798
2799    --  (lines marked with <CTRL> are expanded only in presence of Controlled
2800    --   objects needing finalization)
2801
2802    --     _E : Etyp;
2803    --     declare
2804    --        _M : constant Mark_Id := SS_Mark;
2805    --        Local_Final_List : System.FI.Finalizable_Ptr;    <CTRL>
2806
2807    --        procedure _Clean is
2808    --        begin
2809    --           Abort_Defer;
2810    --           System.FI.Finalize_List (Local_Final_List);   <CTRL>
2811    --           SS_Release (M);
2812    --           Abort_Undefer;
2813    --        end _Clean;
2814
2815    --     begin
2816    --        _E := <Expression>;
2817    --     at end
2818    --        _Clean;
2819    --     end;
2820
2821    --    then expression is replaced by _E
2822
2823    procedure Wrap_Transient_Expression (N : Node_Id) is
2824       Loc  : constant Source_Ptr := Sloc (N);
2825       E    : constant Entity_Id :=
2826                Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
2827       Etyp : Entity_Id := Etype (N);
2828
2829    begin
2830       Insert_Actions (N, New_List (
2831         Make_Object_Declaration (Loc,
2832           Defining_Identifier => E,
2833           Object_Definition   => New_Reference_To (Etyp, Loc)),
2834
2835         Make_Transient_Block (Loc,
2836           Action =>
2837             Make_Assignment_Statement (Loc,
2838               Name       => New_Reference_To (E, Loc),
2839               Expression => Relocate_Node (N)))));
2840
2841       Rewrite (N, New_Reference_To (E, Loc));
2842       Analyze_And_Resolve (N, Etyp);
2843    end Wrap_Transient_Expression;
2844
2845    ------------------------------
2846    -- Wrap_Transient_Statement --
2847    ------------------------------
2848
2849    --  Transform <Instruction> into
2850
2851    --  (lines marked with <CTRL> are expanded only in presence of Controlled
2852    --   objects needing finalization)
2853
2854    --    declare
2855    --       _M : Mark_Id := SS_Mark;
2856    --       Local_Final_List : System.FI.Finalizable_Ptr ;    <CTRL>
2857
2858    --       procedure _Clean is
2859    --       begin
2860    --          Abort_Defer;
2861    --          System.FI.Finalize_List (Local_Final_List);    <CTRL>
2862    --          SS_Release (_M);
2863    --          Abort_Undefer;
2864    --       end _Clean;
2865
2866    --    begin
2867    --       <Instr uction>;
2868    --    at end
2869    --       _Clean;
2870    --    end;
2871
2872    procedure Wrap_Transient_Statement (N : Node_Id) is
2873       Loc           : constant Source_Ptr := Sloc (N);
2874       New_Statement : constant Node_Id := Relocate_Node (N);
2875
2876    begin
2877       Rewrite (N, Make_Transient_Block (Loc, New_Statement));
2878
2879       --  With the scope stack back to normal, we can call analyze on the
2880       --  resulting block. At this point, the transient scope is being
2881       --  treated like a perfectly normal scope, so there is nothing
2882       --  special about it.
2883
2884       --  Note: Wrap_Transient_Statement is called with the node already
2885       --  analyzed (i.e. Analyzed (N) is True). This is important, since
2886       --  otherwise we would get a recursive processing of the node when
2887       --  we do this Analyze call.
2888
2889       Analyze (N);
2890    end Wrap_Transient_Statement;
2891
2892 end Exp_Ch7;