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