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)
1144
1145       elsif Is_Access_Type (E) then
1146          return
1147            Make_Selected_Component (Loc,
1148              Prefix        =>
1149                New_Reference_To (Associated_Final_Chain (Base_Type (E)), Loc),
1150              Selector_Name => Make_Identifier (Loc, Name_F));
1151
1152       else
1153          if Is_Dynamic_Scope (E) then
1154             S := E;
1155          else
1156             S := Enclosing_Dynamic_Scope (E);
1157          end if;
1158
1159          --  When the finalization chain entity is 'Error', it means that
1160          --  there should not be any chain at that level and that the
1161          --  enclosing one should be used
1162
1163          --  This is a nasty kludge, see ??? note in exp_ch11
1164
1165          while Finalization_Chain_Entity (S) = Error loop
1166             S := Enclosing_Dynamic_Scope (S);
1167          end loop;
1168
1169          if S = Standard_Standard then
1170             return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E));
1171          else
1172             if No (Finalization_Chain_Entity (S)) then
1173
1174                Id := Make_Defining_Identifier (Sloc (S),
1175                  New_Internal_Name ('F'));
1176                Set_Finalization_Chain_Entity (S, Id);
1177
1178                --  Set momentarily some semantics attributes to allow normal
1179                --  analysis of expansions containing references to this chain.
1180                --  Will be fully decorated during the expansion of the scope
1181                --  itself
1182
1183                Set_Ekind (Id, E_Variable);
1184                Set_Etype (Id, RTE (RE_Finalizable_Ptr));
1185             end if;
1186
1187             return New_Reference_To (Finalization_Chain_Entity (S), Sloc (E));
1188          end if;
1189       end if;
1190    end Find_Final_List;
1191
1192    -----------------------------
1193    -- Find_Node_To_Be_Wrapped --
1194    -----------------------------
1195
1196    function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
1197       P          : Node_Id;
1198       The_Parent : Node_Id;
1199
1200    begin
1201       The_Parent := N;
1202       loop
1203          P := The_Parent;
1204          pragma Assert (P /= Empty);
1205          The_Parent := Parent (P);
1206
1207          case Nkind (The_Parent) is
1208
1209             --  Simple statement can be wrapped
1210
1211             when N_Pragma               =>
1212                return The_Parent;
1213
1214             --  Usually assignments are good candidate for wrapping
1215             --  except when they have been generated as part of a
1216             --  controlled aggregate where the wrapping should take
1217             --  place more globally.
1218
1219             when N_Assignment_Statement =>
1220                if No_Ctrl_Actions (The_Parent) then
1221                   null;
1222                else
1223                   return The_Parent;
1224                end if;
1225
1226             --  An entry call statement is a special case if it occurs in
1227             --  the context of a Timed_Entry_Call. In this case we wrap
1228             --  the entire timed entry call.
1229
1230             when N_Entry_Call_Statement     |
1231                  N_Procedure_Call_Statement =>
1232                if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
1233                  and then
1234                    Nkind (Parent (Parent (The_Parent))) = N_Timed_Entry_Call
1235                then
1236                   return Parent (Parent (The_Parent));
1237                else
1238                   return The_Parent;
1239                end if;
1240
1241             --  Object declarations are also a boundary for the transient scope
1242             --  even if they are not really wrapped
1243             --  (see Wrap_Transient_Declaration)
1244
1245             when N_Object_Declaration          |
1246                  N_Object_Renaming_Declaration |
1247                  N_Subtype_Declaration         =>
1248                return The_Parent;
1249
1250             --  The expression itself is to be wrapped if its parent is a
1251             --  compound statement or any other statement where the expression
1252             --  is known to be scalar
1253
1254             when N_Accept_Alternative               |
1255                  N_Attribute_Definition_Clause      |
1256                  N_Case_Statement                   |
1257                  N_Code_Statement                   |
1258                  N_Delay_Alternative                |
1259                  N_Delay_Until_Statement            |
1260                  N_Delay_Relative_Statement         |
1261                  N_Discriminant_Association         |
1262                  N_Elsif_Part                       |
1263                  N_Entry_Body_Formal_Part           |
1264                  N_Exit_Statement                   |
1265                  N_If_Statement                     |
1266                  N_Iteration_Scheme                 |
1267                  N_Terminate_Alternative            =>
1268                return P;
1269
1270             when N_Attribute_Reference              =>
1271
1272                if Is_Procedure_Attribute_Name
1273                     (Attribute_Name (The_Parent))
1274                then
1275                   return The_Parent;
1276                end if;
1277
1278             --  ??? No scheme yet for "for I in Expression'Range loop"
1279             --  ??? the current scheme for Expression wrapping doesn't apply
1280             --  ??? because a RANGE is NOT an expression. Tricky problem...
1281             --  ??? while this problem is not solved we have a potential for
1282             --  ??? leak and unfinalized intermediate objects here.
1283
1284             when N_Loop_Parameter_Specification =>
1285                return Empty;
1286
1287             --  The following nodes contains "dummy calls" which don't
1288             --  need to be wrapped.
1289
1290             when N_Parameter_Specification     |
1291                  N_Discriminant_Specification  |
1292                  N_Component_Declaration       =>
1293                return Empty;
1294
1295             --  The return statement is not to be wrapped when the function
1296             --  itself needs wrapping at the outer-level
1297
1298             when N_Return_Statement            =>
1299                if Requires_Transient_Scope (Return_Type (The_Parent)) then
1300                   return Empty;
1301                else
1302                   return The_Parent;
1303                end if;
1304
1305             --  If we leave a scope without having been able to find a node to
1306             --  wrap, something is going wrong but this can happen in error
1307             --  situation that are not detected yet (such as a dynamic string
1308             --  in a pragma export)
1309
1310             when N_Subprogram_Body     |
1311                  N_Package_Declaration |
1312                  N_Package_Body        |
1313                  N_Block_Statement     =>
1314                return Empty;
1315
1316             --  otherwise continue the search
1317
1318             when others =>
1319                null;
1320          end case;
1321       end loop;
1322    end Find_Node_To_Be_Wrapped;
1323
1324    ----------------------
1325    -- Global_Flist_Ref --
1326    ----------------------
1327
1328    function Global_Flist_Ref  (Flist_Ref : Node_Id) return Boolean is
1329       Flist : Entity_Id;
1330
1331    begin
1332       --  Look for the Global_Final_List
1333
1334       if Is_Entity_Name (Flist_Ref) then
1335          Flist := Entity (Flist_Ref);
1336
1337       --  Look for the final list associated with an access to controlled
1338
1339       elsif  Nkind (Flist_Ref) = N_Selected_Component
1340         and then Is_Entity_Name (Prefix (Flist_Ref))
1341       then
1342          Flist :=  Entity (Prefix (Flist_Ref));
1343       else
1344          return False;
1345       end if;
1346
1347       return Present (Flist)
1348         and then Present (Scope (Flist))
1349         and then Enclosing_Dynamic_Scope (Flist) = Standard_Standard;
1350    end Global_Flist_Ref;
1351
1352    ----------------------------------
1353    -- Has_New_Controlled_Component --
1354    ----------------------------------
1355
1356    function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
1357       Comp : Entity_Id;
1358
1359    begin
1360       if not Is_Tagged_Type (E) then
1361          return Has_Controlled_Component (E);
1362       elsif not Is_Derived_Type (E) then
1363          return Has_Controlled_Component (E);
1364       end if;
1365
1366       Comp := First_Component (E);
1367       while Present (Comp) loop
1368
1369          if Chars (Comp) = Name_uParent then
1370             null;
1371
1372          elsif Scope (Original_Record_Component (Comp)) = E
1373            and then Controlled_Type (Etype (Comp))
1374          then
1375             return True;
1376          end if;
1377
1378          Next_Component (Comp);
1379       end loop;
1380
1381       return False;
1382    end Has_New_Controlled_Component;
1383
1384    --------------------------
1385    -- In_Finalization_Root --
1386    --------------------------
1387
1388    --  It would seem simpler to test Scope (RTE (RE_Root_Controlled)) but
1389    --  the purpose of this function is to avoid a circular call to Rtsfind
1390    --  which would been caused by such a test.
1391
1392    function In_Finalization_Root (E : Entity_Id) return Boolean is
1393       S : constant Entity_Id := Scope (E);
1394
1395    begin
1396       return Chars (Scope (S))     = Name_System
1397         and then Chars (S)         = Name_Finalization_Root
1398         and then Scope (Scope (S)) = Standard_Standard;
1399    end  In_Finalization_Root;
1400
1401    ------------------------------------
1402    -- Insert_Actions_In_Scope_Around --
1403    ------------------------------------
1404
1405    procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
1406       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
1407
1408    begin
1409       if Present (SE.Actions_To_Be_Wrapped_Before) then
1410          Insert_List_Before (N, SE.Actions_To_Be_Wrapped_Before);
1411          SE.Actions_To_Be_Wrapped_Before := No_List;
1412       end if;
1413
1414       if Present (SE.Actions_To_Be_Wrapped_After) then
1415          Insert_List_After (N, SE.Actions_To_Be_Wrapped_After);
1416          SE.Actions_To_Be_Wrapped_After := No_List;
1417       end if;
1418    end Insert_Actions_In_Scope_Around;
1419
1420    -----------------------
1421    -- Make_Adjust_Call --
1422    -----------------------
1423
1424    function Make_Adjust_Call
1425      (Ref          : Node_Id;
1426       Typ          : Entity_Id;
1427       Flist_Ref    : Node_Id;
1428       With_Attach  : Node_Id)
1429       return         List_Id
1430    is
1431       Loc    : constant Source_Ptr := Sloc (Ref);
1432       Res    : constant List_Id    := New_List;
1433       Utyp   : Entity_Id;
1434       Proc   : Entity_Id;
1435       Cref   : Node_Id := Ref;
1436       Cref2  : Node_Id;
1437       Attach : Node_Id := With_Attach;
1438
1439    begin
1440       if Is_Class_Wide_Type (Typ) then
1441          Utyp := Underlying_Type (Base_Type (Root_Type (Typ)));
1442       else
1443          Utyp := Underlying_Type (Base_Type (Typ));
1444       end if;
1445
1446       Set_Assignment_OK (Cref);
1447
1448       --  Deal with non-tagged derivation of private views
1449
1450       if Is_Untagged_Derivation (Typ) then
1451          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
1452          Cref := Unchecked_Convert_To (Utyp, Cref);
1453          Set_Assignment_OK (Cref);
1454          --  To prevent problems with UC see 1.156 RH ???
1455       end if;
1456
1457       --  If the underlying_type is a subtype, we are dealing with
1458       --  the completion of a private type. We need to access
1459       --  the base type and generate a conversion to it.
1460
1461       if Utyp /= Base_Type (Utyp) then
1462          pragma Assert (Is_Private_Type (Typ));
1463          Utyp := Base_Type (Utyp);
1464          Cref := Unchecked_Convert_To (Utyp, Cref);
1465       end if;
1466
1467       --  We do not need to attach to one of the Global Final Lists
1468       --  the objects whose type is Finalize_Storage_Only
1469
1470       if Finalize_Storage_Only (Typ)
1471         and then (Global_Flist_Ref (Flist_Ref)
1472           or else Entity (Constant_Value (RTE (RE_Garbage_Collected)))
1473                   = Standard_True)
1474       then
1475          Attach := Make_Integer_Literal (Loc, 0);
1476       end if;
1477
1478       --  Generate:
1479       --    Deep_Adjust (Flist_Ref, Ref, With_Attach);
1480
1481       if Has_Controlled_Component (Utyp)
1482         or else Is_Class_Wide_Type (Typ)
1483       then
1484          if Is_Tagged_Type (Utyp) then
1485             Proc := Find_Prim_Op (Utyp, Deep_Name_Of (Adjust_Case));
1486
1487          else
1488             Proc := TSS (Utyp, Deep_Name_Of (Adjust_Case));
1489          end if;
1490
1491          Cref := Convert_View (Proc, Cref, 2);
1492
1493          Append_To (Res,
1494            Make_Procedure_Call_Statement (Loc,
1495              Name => New_Reference_To (Proc, Loc),
1496              Parameter_Associations =>
1497                New_List (Flist_Ref, Cref, Attach)));
1498
1499       --  Generate:
1500       --    if With_Attach then
1501       --       Attach_To_Final_List (Ref, Flist_Ref);
1502       --    end if;
1503       --    Adjust (Ref);
1504
1505       else -- Is_Controlled (Utyp)
1506
1507          Proc  := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
1508          Cref  := Convert_View (Proc, Cref);
1509          Cref2 := New_Copy_Tree (Cref);
1510
1511          Append_To (Res,
1512            Make_Procedure_Call_Statement (Loc,
1513            Name => New_Reference_To (Proc, Loc),
1514            Parameter_Associations => New_List (Cref2)));
1515
1516          Append_To (Res, Make_Attach_Call (Cref, Flist_Ref, Attach));
1517
1518          --  Treat this as a reference to Adjust if the Adjust routine
1519          --  comes from source. The call is not explicit, but it is near
1520          --  enough, and we won't typically get explicit adjust calls.
1521
1522          if Comes_From_Source (Proc) then
1523             Generate_Reference (Proc, Ref);
1524          end if;
1525       end if;
1526
1527       return Res;
1528    end Make_Adjust_Call;
1529
1530    ----------------------
1531    -- Make_Attach_Call --
1532    ----------------------
1533
1534    --  Generate:
1535    --    System.FI.Attach_To_Final_List (Flist, Ref, Nb_Link)
1536
1537    function Make_Attach_Call
1538      (Obj_Ref      : Node_Id;
1539       Flist_Ref    : Node_Id;
1540       With_Attach  : Node_Id)
1541       return Node_Id
1542    is
1543       Loc : constant Source_Ptr := Sloc (Obj_Ref);
1544
1545    begin
1546       --  Optimization: If the number of links is statically '0', don't
1547       --  call the attach_proc.
1548
1549       if Nkind (With_Attach) = N_Integer_Literal
1550         and then Intval (With_Attach) = Uint_0
1551       then
1552          return Make_Null_Statement (Loc);
1553       end if;
1554
1555       return
1556         Make_Procedure_Call_Statement (Loc,
1557           Name => New_Reference_To (RTE (RE_Attach_To_Final_List), Loc),
1558           Parameter_Associations => New_List (
1559             Flist_Ref,
1560             OK_Convert_To (RTE (RE_Finalizable), Obj_Ref),
1561             With_Attach));
1562    end Make_Attach_Call;
1563
1564    ----------------
1565    -- Make_Clean --
1566    ----------------
1567
1568    function Make_Clean
1569      (N                          : Node_Id;
1570       Clean                      : Entity_Id;
1571       Mark                       : Entity_Id;
1572       Flist                      : Entity_Id;
1573       Is_Task                    : Boolean;
1574       Is_Master                  : Boolean;
1575       Is_Protected_Subprogram    : Boolean;
1576       Is_Task_Allocation_Block   : Boolean;
1577       Is_Asynchronous_Call_Block : Boolean)
1578       return      Node_Id
1579    is
1580       Loc : constant Source_Ptr := Sloc (Clean);
1581
1582       Stmt         : List_Id := New_List;
1583       Sbody        : Node_Id;
1584       Spec         : Node_Id;
1585       Name         : Node_Id;
1586       Param        : Node_Id;
1587       Unlock       : Node_Id;
1588       Param_Type   : Entity_Id;
1589       Pid          : Entity_Id := Empty;
1590       Cancel_Param : Entity_Id;
1591
1592    begin
1593       if Is_Task then
1594          if Restricted_Profile then
1595             Append_To
1596               (Stmt, Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
1597          else
1598             Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Task));
1599          end if;
1600
1601       elsif Is_Master then
1602          if Restrictions (No_Task_Hierarchy) = False then
1603             Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Master));
1604          end if;
1605
1606       elsif Is_Protected_Subprogram then
1607
1608          --  Add statements to the cleanup handler of the (ordinary)
1609          --  subprogram expanded to implement a protected subprogram,
1610          --  unlocking the protected object parameter and undeferring abortion.
1611          --  If this is a protected procedure, and the object contains
1612          --  entries, this also calls the entry service routine.
1613
1614          --  NOTE: This cleanup handler references _object, a parameter
1615          --        to the procedure.
1616
1617          --  Find the _object parameter representing the protected object.
1618
1619          Spec := Parent (Corresponding_Spec (N));
1620
1621          Param := First (Parameter_Specifications (Spec));
1622          loop
1623             Param_Type := Etype (Parameter_Type (Param));
1624
1625             if Ekind (Param_Type) = E_Record_Type then
1626                Pid := Corresponding_Concurrent_Type (Param_Type);
1627             end if;
1628
1629             exit when not Present (Param) or else Present (Pid);
1630             Next (Param);
1631          end loop;
1632
1633          pragma Assert (Present (Param));
1634
1635          --  If the associated protected object declares entries,
1636          --  a protected procedure has to service entry queues.
1637          --  In this case, add
1638
1639          --  Service_Entries (_object._object'Access);
1640
1641          --  _object is the record used to implement the protected object.
1642          --  It is a parameter to the protected subprogram.
1643
1644          if Nkind (Specification (N)) = N_Procedure_Specification
1645            and then Has_Entries (Pid)
1646          then
1647             if Abort_Allowed
1648               or else Restrictions (No_Entry_Queue) = False
1649               or else Number_Entries (Pid) > 1
1650             then
1651                Name := New_Reference_To (RTE (RE_Service_Entries), Loc);
1652             else
1653                Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
1654             end if;
1655
1656             Append_To (Stmt,
1657               Make_Procedure_Call_Statement (Loc,
1658                 Name => Name,
1659                 Parameter_Associations => New_List (
1660                   Make_Attribute_Reference (Loc,
1661                     Prefix =>
1662                       Make_Selected_Component (Loc,
1663                         Prefix => New_Reference_To (
1664                           Defining_Identifier (Param), Loc),
1665                         Selector_Name =>
1666                           Make_Identifier (Loc, Name_uObject)),
1667                     Attribute_Name => Name_Unchecked_Access))));
1668          end if;
1669
1670          --  Unlock (_object._object'Access);
1671
1672          --  _object is the record used to implement the protected object.
1673          --  It is a parameter to the protected subprogram.
1674
1675          --  If the protected object is controlled (i.e it has entries or
1676          --  needs finalization for interrupt handling), call Unlock_Entries,
1677          --  except if the protected object follows the ravenscar profile, in
1678          --  which case call Unlock_Entry, otherwise call the simplified
1679          --  version, Unlock.
1680
1681          if Has_Entries (Pid)
1682            or else Has_Interrupt_Handler (Pid)
1683            or else Has_Attach_Handler (Pid)
1684          then
1685             if Abort_Allowed
1686               or else Restrictions (No_Entry_Queue) = False
1687               or else Number_Entries (Pid) > 1
1688             then
1689                Unlock := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
1690             else
1691                Unlock := New_Reference_To (RTE (RE_Unlock_Entry), Loc);
1692             end if;
1693
1694          else
1695             Unlock := New_Reference_To (RTE (RE_Unlock), Loc);
1696          end if;
1697
1698          Append_To (Stmt,
1699            Make_Procedure_Call_Statement (Loc,
1700              Name => Unlock,
1701              Parameter_Associations => New_List (
1702                Make_Attribute_Reference (Loc,
1703                  Prefix =>
1704                    Make_Selected_Component (Loc,
1705                      Prefix =>
1706                        New_Reference_To (Defining_Identifier (Param), Loc),
1707                      Selector_Name =>
1708                        Make_Identifier (Loc, Name_uObject)),
1709                  Attribute_Name => Name_Unchecked_Access))));
1710
1711          if Abort_Allowed then
1712             --  Abort_Undefer;
1713
1714             Append_To (Stmt,
1715               Make_Procedure_Call_Statement (Loc,
1716                 Name =>
1717                   New_Reference_To (
1718                     RTE (RE_Abort_Undefer), Loc),
1719                 Parameter_Associations => Empty_List));
1720          end if;
1721
1722       elsif Is_Task_Allocation_Block then
1723
1724          --  Add a call to Expunge_Unactivated_Tasks to the cleanup
1725          --  handler of a block created for the dynamic allocation of
1726          --  tasks:
1727
1728          --  Expunge_Unactivated_Tasks (_chain);
1729
1730          --  where _chain is the list of tasks created by the allocator
1731          --  but not yet activated. This list will be empty unless
1732          --  the block completes abnormally.
1733
1734          --  This only applies to dynamically allocated tasks;
1735          --  other unactivated tasks are completed by Complete_Task or
1736          --  Complete_Master.
1737
1738          --  NOTE: This cleanup handler references _chain, a local
1739          --        object.
1740
1741          Append_To (Stmt,
1742            Make_Procedure_Call_Statement (Loc,
1743              Name =>
1744                New_Reference_To (
1745                  RTE (RE_Expunge_Unactivated_Tasks), Loc),
1746              Parameter_Associations => New_List (
1747                New_Reference_To (Activation_Chain_Entity (N), Loc))));
1748
1749       elsif Is_Asynchronous_Call_Block then
1750
1751          --  Add a call to attempt to cancel the asynchronous entry call
1752          --  whenever the block containing the abortable part is exited.
1753
1754          --  NOTE: This cleanup handler references C, a local object
1755
1756          --  Get the argument to the Cancel procedure
1757          Cancel_Param := Entry_Cancel_Parameter (Entity (Identifier (N)));
1758
1759          --  If it is of type Communication_Block, this must be a
1760          --  protected entry call.
1761
1762          if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
1763
1764             Append_To (Stmt,
1765
1766             --  if Enqueued (Cancel_Parameter) then
1767
1768               Make_Implicit_If_Statement (Clean,
1769                 Condition => Make_Function_Call (Loc,
1770                   Name => New_Reference_To (
1771                     RTE (RE_Enqueued), Loc),
1772                   Parameter_Associations => New_List (
1773                     New_Reference_To (Cancel_Param, Loc))),
1774                 Then_Statements => New_List (
1775
1776             --  Cancel_Protected_Entry_Call (Cancel_Param);
1777
1778                   Make_Procedure_Call_Statement (Loc,
1779                     Name => New_Reference_To (
1780                       RTE (RE_Cancel_Protected_Entry_Call), Loc),
1781                     Parameter_Associations => New_List (
1782                       New_Reference_To (Cancel_Param, Loc))))));
1783
1784          --  Asynchronous delay
1785
1786          elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
1787             Append_To (Stmt,
1788               Make_Procedure_Call_Statement (Loc,
1789                 Name => New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc),
1790                 Parameter_Associations => New_List (
1791                   Make_Attribute_Reference (Loc,
1792                     Prefix => New_Reference_To (Cancel_Param, Loc),
1793                     Attribute_Name => Name_Unchecked_Access))));
1794
1795          --  Task entry call
1796
1797          else
1798             --  Append call to Cancel_Task_Entry_Call (C);
1799
1800             Append_To (Stmt,
1801               Make_Procedure_Call_Statement (Loc,
1802                 Name => New_Reference_To (
1803                   RTE (RE_Cancel_Task_Entry_Call),
1804                   Loc),
1805                 Parameter_Associations => New_List (
1806                   New_Reference_To (Cancel_Param, Loc))));
1807
1808          end if;
1809       end if;
1810
1811       if Present (Flist) then
1812          Append_To (Stmt,
1813            Make_Procedure_Call_Statement (Loc,
1814              Name => New_Reference_To (RTE (RE_Finalize_List), Loc),
1815              Parameter_Associations => New_List (
1816                     New_Reference_To (Flist, Loc))));
1817       end if;
1818
1819       if Present (Mark) then
1820          Append_To (Stmt,
1821            Make_Procedure_Call_Statement (Loc,
1822              Name => New_Reference_To (RTE (RE_SS_Release), Loc),
1823              Parameter_Associations => New_List (
1824                     New_Reference_To (Mark, Loc))));
1825       end if;
1826
1827       Sbody :=
1828         Make_Subprogram_Body (Loc,
1829           Specification =>
1830             Make_Procedure_Specification (Loc,
1831               Defining_Unit_Name => Clean),
1832
1833           Declarations  => New_List,
1834
1835           Handled_Statement_Sequence =>
1836             Make_Handled_Sequence_Of_Statements (Loc,
1837               Statements => Stmt));
1838
1839       if Present (Flist) or else Is_Task or else Is_Master then
1840          Wrap_Cleanup_Procedure (Sbody);
1841       end if;
1842
1843       --  We do not want debug information for _Clean routines,
1844       --  since it just confuses the debugging operation unless
1845       --  we are debugging generated code.
1846
1847       if not Debug_Generated_Code then
1848          Set_Debug_Info_Off (Clean, True);
1849       end if;
1850
1851       return Sbody;
1852    end Make_Clean;
1853
1854    --------------------------
1855    -- Make_Deep_Array_Body --
1856    --------------------------
1857
1858    --  Array components are initialized and adjusted in the normal order
1859    --  and finalized in the reverse order. Exceptions are handled and
1860    --  Program_Error is re-raise in the Adjust and Finalize case
1861    --  (RM 7.6.1(12)). Generate the following code :
1862    --
1863    --  procedure Deep_<P>   --  with <P> being Initialize or Adjust or Finalize
1864    --   (L : in out Finalizable_Ptr;
1865    --    V : in out Typ)
1866    --  is
1867    --  begin
1868    --     for J1 in             Typ'First (1) .. Typ'Last (1) loop
1869    --               ^ reverse ^  --  in the finalization case
1870    --        ...
1871    --           for J2 in Typ'First (n) .. Typ'Last (n) loop
1872    --                 Make_<P>_Call (Typ, V (J1, .. , Jn), L, V);
1873    --           end loop;
1874    --        ...
1875    --     end loop;
1876    --  exception                                --  not in the
1877    --     when others => raise Program_Error;   --     Initialize case
1878    --  end Deep_<P>;
1879
1880    function Make_Deep_Array_Body
1881      (Prim : Final_Primitives;
1882       Typ  : Entity_Id)
1883       return List_Id
1884    is
1885       Loc : constant Source_Ptr := Sloc (Typ);
1886
1887       Index_List : constant List_Id := New_List;
1888       --  Stores the list of references to the indexes (one per dimension)
1889
1890       function One_Component return List_Id;
1891       --  Create one statement to initialize/adjust/finalize one array
1892       --  component, designated by a full set of indices.
1893
1894       function One_Dimension (N : Int) return List_Id;
1895       --  Create loop to deal with one dimension of the array. The single
1896       --  statement in the body of the loop initializes the inner dimensions if
1897       --  any, or else a single component.
1898
1899       -------------------
1900       -- One_Component --
1901       -------------------
1902
1903       function One_Component return List_Id is
1904          Comp_Typ : constant Entity_Id := Component_Type (Typ);
1905          Comp_Ref : constant Node_Id :=
1906                       Make_Indexed_Component (Loc,
1907                         Prefix      => Make_Identifier (Loc, Name_V),
1908                         Expressions => Index_List);
1909
1910       begin
1911          --  Set the etype of the component Reference, which is used to
1912          --  determine whether a conversion to a parent type is needed.
1913
1914          Set_Etype (Comp_Ref, Comp_Typ);
1915
1916          case Prim is
1917             when Initialize_Case =>
1918                return Make_Init_Call (Comp_Ref, Comp_Typ,
1919                         Make_Identifier (Loc, Name_L),
1920                         Make_Identifier (Loc, Name_B));
1921
1922             when Adjust_Case =>
1923                return Make_Adjust_Call (Comp_Ref, Comp_Typ,
1924                         Make_Identifier (Loc, Name_L),
1925                         Make_Identifier (Loc, Name_B));
1926
1927             when Finalize_Case =>
1928                return Make_Final_Call (Comp_Ref, Comp_Typ,
1929                         Make_Identifier (Loc, Name_B));
1930          end case;
1931       end One_Component;
1932
1933       -------------------
1934       -- One_Dimension --
1935       -------------------
1936
1937       function One_Dimension (N : Int) return List_Id is
1938          Index : Entity_Id;
1939
1940       begin
1941          if N > Number_Dimensions (Typ) then
1942             return One_Component;
1943
1944          else
1945             Index :=
1946               Make_Defining_Identifier (Loc, New_External_Name ('J', N));
1947
1948             Append_To (Index_List, New_Reference_To (Index, Loc));
1949
1950             return New_List (
1951               Make_Implicit_Loop_Statement (Typ,
1952                 Identifier => Empty,
1953                 Iteration_Scheme =>
1954                   Make_Iteration_Scheme (Loc,
1955                     Loop_Parameter_Specification =>
1956                       Make_Loop_Parameter_Specification (Loc,
1957                         Defining_Identifier => Index,
1958                         Discrete_Subtype_Definition =>
1959                           Make_Attribute_Reference (Loc,
1960                             Prefix => Make_Identifier (Loc, Name_V),
1961                             Attribute_Name  => Name_Range,
1962                             Expressions => New_List (
1963                               Make_Integer_Literal (Loc, N))),
1964                         Reverse_Present => Prim = Finalize_Case)),
1965                 Statements => One_Dimension (N + 1)));
1966          end if;
1967       end One_Dimension;
1968
1969    --  Start of processing for Make_Deep_Array_Body
1970
1971    begin
1972       return One_Dimension (1);
1973    end Make_Deep_Array_Body;
1974
1975    --------------------
1976    -- Make_Deep_Proc --
1977    --------------------
1978
1979    --  Generate:
1980    --    procedure DEEP_<prim>
1981    --      (L : IN OUT Finalizable_Ptr;    -- not for Finalize
1982    --       V : IN OUT <typ>;
1983    --       B : IN Short_Short_Integer) is
1984    --    begin
1985    --       <stmts>;
1986    --    exception                   --  Finalize and Adjust Cases only
1987    --       raise Program_Error;     --  idem
1988    --    end DEEP_<prim>;
1989
1990    function Make_Deep_Proc
1991      (Prim  : Final_Primitives;
1992       Typ   : Entity_Id;
1993       Stmts : List_Id)
1994       return Entity_Id
1995    is
1996       Loc       : constant Source_Ptr := Sloc (Typ);
1997       Formals   : List_Id;
1998       Proc_Name : Entity_Id;
1999       Handler   : List_Id := No_List;
2000       Subp_Body : Node_Id;
2001       Type_B    : Entity_Id;
2002
2003    begin
2004       if Prim = Finalize_Case then
2005          Formals := New_List;
2006          Type_B := Standard_Boolean;
2007
2008       else
2009          Formals := New_List (
2010            Make_Parameter_Specification (Loc,
2011              Defining_Identifier => Make_Defining_Identifier (Loc, Name_L),
2012              In_Present          => True,
2013              Out_Present         => True,
2014              Parameter_Type      =>
2015                New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
2016          Type_B := Standard_Short_Short_Integer;
2017       end if;
2018
2019       Append_To (Formals,
2020         Make_Parameter_Specification (Loc,
2021            Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
2022           In_Present          => True,
2023           Out_Present         => True,
2024           Parameter_Type      => New_Reference_To (Typ, Loc)));
2025
2026       Append_To (Formals,
2027         Make_Parameter_Specification (Loc,
2028           Defining_Identifier => Make_Defining_Identifier (Loc, Name_B),
2029           Parameter_Type      => New_Reference_To (Type_B, Loc)));
2030
2031       if Prim = Finalize_Case or else Prim = Adjust_Case then
2032          Handler := New_List (
2033            Make_Exception_Handler (Loc,
2034              Exception_Choices => New_List (Make_Others_Choice (Loc)),
2035              Statements        => New_List (
2036                Make_Raise_Program_Error (Loc))));
2037       end if;
2038
2039       Proc_Name := Make_Defining_Identifier (Loc, Deep_Name_Of (Prim));
2040
2041       Subp_Body :=
2042         Make_Subprogram_Body (Loc,
2043           Specification =>
2044             Make_Procedure_Specification (Loc,
2045               Defining_Unit_Name       => Proc_Name,
2046               Parameter_Specifications => Formals),
2047
2048           Declarations =>  Empty_List,
2049           Handled_Statement_Sequence =>
2050             Make_Handled_Sequence_Of_Statements (Loc,
2051               Statements         => Stmts,
2052               Exception_Handlers => Handler));
2053
2054       return Proc_Name;
2055    end Make_Deep_Proc;
2056
2057    ---------------------------
2058    -- Make_Deep_Record_Body --
2059    ---------------------------
2060
2061    --  The Deep procedures call the appropriate Controlling proc on the
2062    --  the controller component. In the init case, it also attach the
2063    --  controller to the current finalization list.
2064
2065    function Make_Deep_Record_Body
2066      (Prim : Final_Primitives;
2067       Typ  : Entity_Id)
2068       return List_Id
2069    is
2070       Loc            : constant Source_Ptr := Sloc (Typ);
2071       Controller_Typ : Entity_Id;
2072       Obj_Ref        : constant Node_Id := Make_Identifier (Loc, Name_V);
2073       Controller_Ref : constant Node_Id :=
2074                          Make_Selected_Component (Loc,
2075                            Prefix        => Obj_Ref,
2076                            Selector_Name =>
2077                              Make_Identifier (Loc, Name_uController));
2078
2079    begin
2080       if Is_Return_By_Reference_Type (Typ) then
2081          Controller_Typ := RTE (RE_Limited_Record_Controller);
2082       else
2083          Controller_Typ := RTE (RE_Record_Controller);
2084       end if;
2085
2086       case Prim is
2087          when Initialize_Case =>
2088             declare
2089                Res  : constant List_Id := New_List;
2090
2091             begin
2092                Append_List_To (Res,
2093                  Make_Init_Call (
2094                    Ref          => Controller_Ref,
2095                    Typ          => Controller_Typ,
2096                    Flist_Ref    => Make_Identifier (Loc, Name_L),
2097                    With_Attach  => Make_Identifier (Loc, Name_B)));
2098
2099                --  When the type is also a controlled type by itself,
2100                --  Initialize it and attach it at the end of the internal
2101                --  finalization chain
2102
2103                if Is_Controlled (Typ) then
2104                   Append_To (Res,
2105                     Make_Procedure_Call_Statement (Loc,
2106                       Name => New_Reference_To (
2107                         Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
2108
2109                       Parameter_Associations =>
2110                         New_List (New_Copy_Tree (Obj_Ref))));
2111
2112                   Append_To (Res, Make_Attach_Call (
2113                     Obj_Ref      => New_Copy_Tree (Obj_Ref),
2114                     Flist_Ref    =>
2115                       Make_Selected_Component (Loc,
2116                         Prefix        => New_Copy_Tree (Controller_Ref),
2117                         Selector_Name => Make_Identifier (Loc, Name_F)),
2118                     With_Attach => Make_Integer_Literal (Loc, 1)));
2119                end if;
2120
2121                return Res;
2122             end;
2123
2124          when Adjust_Case =>
2125             return
2126               Make_Adjust_Call (Controller_Ref, Controller_Typ,
2127                 Make_Identifier (Loc, Name_L),
2128                 Make_Identifier (Loc, Name_B));
2129
2130          when Finalize_Case =>
2131             return
2132               Make_Final_Call (Controller_Ref, Controller_Typ,
2133                 Make_Identifier (Loc, Name_B));
2134       end case;
2135    end Make_Deep_Record_Body;
2136
2137    ----------------------
2138    -- Make_Final_Call --
2139    ----------------------
2140
2141    function Make_Final_Call
2142      (Ref         : Node_Id;
2143       Typ         : Entity_Id;
2144       With_Detach : Node_Id)
2145       return        List_Id
2146    is
2147       Loc   : constant Source_Ptr := Sloc (Ref);
2148       Res   : constant List_Id    := New_List;
2149       Cref  : Node_Id;
2150       Cref2 : Node_Id;
2151       Proc  : Entity_Id;
2152       Utyp  : Entity_Id;
2153
2154    begin
2155       if Is_Class_Wide_Type (Typ) then
2156          Utyp := Root_Type (Typ);
2157          Cref := Ref;
2158
2159       elsif Is_Concurrent_Type (Typ) then
2160          Utyp := Corresponding_Record_Type (Typ);
2161          Cref := Convert_Concurrent (Ref, Typ);
2162
2163       elsif Is_Private_Type (Typ)
2164         and then Present (Full_View (Typ))
2165         and then Is_Concurrent_Type (Full_View (Typ))
2166       then
2167          Utyp := Corresponding_Record_Type (Full_View (Typ));
2168          Cref := Convert_Concurrent (Ref, Full_View (Typ));
2169       else
2170          Utyp := Typ;
2171          Cref := Ref;
2172       end if;
2173
2174       Utyp := Underlying_Type (Base_Type (Utyp));
2175       Set_Assignment_OK (Cref);
2176
2177       --  Deal with non-tagged derivation of private views
2178
2179       if Is_Untagged_Derivation (Typ) then
2180          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
2181          Cref := Unchecked_Convert_To (Utyp, Cref);
2182          Set_Assignment_OK (Cref);
2183          --  To prevent problems with UC see 1.156 RH ???
2184       end if;
2185
2186       --  If the underlying_type is a subtype, we are dealing with
2187       --  the completion of a private type. We need to access
2188       --  the base type and generate a conversion to it.
2189
2190       if Utyp /= Base_Type (Utyp) then
2191          pragma Assert (Is_Private_Type (Typ));
2192          Utyp := Base_Type (Utyp);
2193          Cref := Unchecked_Convert_To (Utyp, Cref);
2194       end if;
2195
2196       --  Generate:
2197       --    Deep_Finalize (Ref, With_Detach);
2198
2199       if Has_Controlled_Component (Utyp)
2200         or else Is_Class_Wide_Type (Typ)
2201       then
2202          if Is_Tagged_Type (Utyp) then
2203             Proc := Find_Prim_Op (Utyp, Deep_Name_Of (Finalize_Case));
2204          else
2205             Proc := TSS (Utyp, Deep_Name_Of (Finalize_Case));
2206          end if;
2207
2208          Cref := Convert_View (Proc, Cref);
2209
2210          Append_To (Res,
2211            Make_Procedure_Call_Statement (Loc,
2212              Name => New_Reference_To (Proc, Loc),
2213              Parameter_Associations =>
2214                New_List (Cref, With_Detach)));
2215
2216       --  Generate:
2217       --    if With_Detach then
2218       --       Finalize_One (Ref);
2219       --    else
2220       --       Finalize (Ref);
2221       --    end if;
2222
2223       else
2224          Proc := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
2225
2226          if Chars (With_Detach) = Chars (Standard_True) then
2227             Append_To (Res,
2228               Make_Procedure_Call_Statement (Loc,
2229                 Name => New_Reference_To (RTE (RE_Finalize_One), Loc),
2230                 Parameter_Associations => New_List (
2231                   OK_Convert_To (RTE (RE_Finalizable), Cref))));
2232
2233          elsif Chars (With_Detach) = Chars (Standard_False) then
2234             Append_To (Res,
2235               Make_Procedure_Call_Statement (Loc,
2236                 Name => New_Reference_To (Proc, Loc),
2237                 Parameter_Associations =>
2238                   New_List (Convert_View (Proc, Cref))));
2239
2240          else
2241             Cref2 := New_Copy_Tree (Cref);
2242             Append_To (Res,
2243               Make_Implicit_If_Statement (Ref,
2244                 Condition => With_Detach,
2245                 Then_Statements => New_List (
2246                   Make_Procedure_Call_Statement (Loc,
2247                     Name => New_Reference_To (RTE (RE_Finalize_One), Loc),
2248                     Parameter_Associations => New_List (
2249                       OK_Convert_To (RTE (RE_Finalizable), Cref)))),
2250
2251                 Else_Statements => New_List (
2252                   Make_Procedure_Call_Statement (Loc,
2253                     Name => New_Reference_To (Proc, Loc),
2254                     Parameter_Associations =>
2255                       New_List (Convert_View (Proc, Cref2))))));
2256          end if;
2257       end if;
2258
2259          --  Treat this as a reference to Finalize if the Finalize routine
2260          --  comes from source. The call is not explicit, but it is near
2261          --  enough, and we won't typically get explicit adjust calls.
2262
2263          if Comes_From_Source (Proc) then
2264             Generate_Reference (Proc, Ref);
2265          end if;
2266       return Res;
2267    end Make_Final_Call;
2268
2269    --------------------
2270    -- Make_Init_Call --
2271    --------------------
2272
2273    function Make_Init_Call
2274      (Ref          : Node_Id;
2275       Typ          : Entity_Id;
2276       Flist_Ref    : Node_Id;
2277       With_Attach  : Node_Id)
2278       return         List_Id
2279    is
2280       Loc     : constant Source_Ptr := Sloc (Ref);
2281       Is_Conc : Boolean;
2282       Res     : constant List_Id := New_List;
2283       Proc    : Entity_Id;
2284       Utyp    : Entity_Id;
2285       Cref    : Node_Id;
2286       Cref2   : Node_Id;
2287       Attach  : Node_Id := With_Attach;
2288
2289    begin
2290       if Is_Concurrent_Type (Typ) then
2291          Is_Conc := True;
2292          Utyp    := Corresponding_Record_Type (Typ);
2293          Cref    := Convert_Concurrent (Ref, Typ);
2294
2295       elsif Is_Private_Type (Typ)
2296         and then Present (Full_View (Typ))
2297         and then Is_Concurrent_Type (Underlying_Type (Typ))
2298       then
2299          Is_Conc := True;
2300          Utyp    := Corresponding_Record_Type (Underlying_Type (Typ));
2301          Cref    := Convert_Concurrent (Ref, Underlying_Type (Typ));
2302
2303       else
2304          Is_Conc := False;
2305          Utyp    := Typ;
2306          Cref    := Ref;
2307       end if;
2308
2309       Utyp := Underlying_Type (Base_Type (Utyp));
2310
2311       Set_Assignment_OK (Cref);
2312
2313       --  Deal with non-tagged derivation of private views
2314
2315       if Is_Untagged_Derivation (Typ)
2316         and then not Is_Conc
2317       then
2318          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
2319          Cref := Unchecked_Convert_To (Utyp, Cref);
2320          Set_Assignment_OK (Cref);
2321          --  To prevent problems with UC see 1.156 RH ???
2322       end if;
2323
2324       --  If the underlying_type is a subtype, we are dealing with
2325       --  the completion of a private type. We need to access
2326       --  the base type and generate a conversion to it.
2327
2328       if Utyp /= Base_Type (Utyp) then
2329          pragma Assert (Is_Private_Type (Typ));
2330          Utyp := Base_Type (Utyp);
2331          Cref := Unchecked_Convert_To (Utyp, Cref);
2332       end if;
2333
2334       --  We do not need to attach to one of the Global Final Lists
2335       --  the objects whose type is Finalize_Storage_Only
2336
2337       if Finalize_Storage_Only (Typ)
2338         and then (Global_Flist_Ref (Flist_Ref)
2339           or else Entity (Constant_Value (RTE (RE_Garbage_Collected)))
2340                   = Standard_True)
2341       then
2342          Attach := Make_Integer_Literal (Loc, 0);
2343       end if;
2344
2345       --  Generate:
2346       --    Deep_Initialize (Ref, Flist_Ref);
2347
2348       if Has_Controlled_Component (Utyp) then
2349          Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
2350
2351          Cref := Convert_View (Proc, Cref, 2);
2352
2353          Append_To (Res,
2354            Make_Procedure_Call_Statement (Loc,
2355              Name => New_Reference_To (Proc, Loc),
2356              Parameter_Associations => New_List (
2357                Node1 => Flist_Ref,
2358                Node2 => Cref,
2359                Node3 => Attach)));
2360
2361       --  Generate:
2362       --    Attach_To_Final_List (Ref, Flist_Ref);
2363       --    Initialize (Ref);
2364
2365       else -- Is_Controlled (Utyp)
2366          Proc  := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
2367          Cref  := Convert_View (Proc, Cref);
2368          Cref2 := New_Copy_Tree (Cref);
2369
2370          Append_To (Res,
2371            Make_Procedure_Call_Statement (Loc,
2372            Name => New_Reference_To (Proc, Loc),
2373            Parameter_Associations => New_List (Cref2)));
2374
2375          Append_To (Res,
2376            Make_Attach_Call (Cref, Flist_Ref, Attach));
2377
2378          --  Treat this as a reference to Initialize if Initialize routine
2379          --  comes from source. The call is not explicit, but it is near
2380          --  enough, and we won't typically get explicit adjust calls.
2381
2382          if Comes_From_Source (Proc) then
2383             Generate_Reference (Proc, Ref);
2384          end if;
2385       end if;
2386
2387       return Res;
2388    end Make_Init_Call;
2389
2390    --------------------------
2391    -- Make_Transient_Block --
2392    --------------------------
2393
2394    --  If finalization is involved, this function just wraps the instruction
2395    --  into a block whose name is the transient block entity, and then
2396    --  Expand_Cleanup_Actions (called on the expansion of the handled
2397    --  sequence of statements will do the necessary expansions for
2398    --  cleanups).
2399
2400    function Make_Transient_Block
2401      (Loc    : Source_Ptr;
2402       Action : Node_Id)
2403       return   Node_Id
2404    is
2405       Flist  : constant Entity_Id := Finalization_Chain_Entity (Current_Scope);
2406       Decls  : constant List_Id   := New_List;
2407       Par    : constant Node_Id   := Parent (Action);
2408       Instrs : constant List_Id   := New_List (Action);
2409       Blk    : Node_Id;
2410
2411    begin
2412       --  Case where only secondary stack use is involved
2413
2414       if Uses_Sec_Stack (Current_Scope)
2415         and then No (Flist)
2416         and then Nkind (Action) /= N_Return_Statement
2417         and then Nkind (Par) /= N_Exception_Handler
2418       then
2419
2420          declare
2421             S  : Entity_Id;
2422             K  : Entity_Kind;
2423          begin
2424             S := Scope (Current_Scope);
2425             loop
2426                K := Ekind (S);
2427
2428                --  At the outer level, no need to release the sec stack
2429
2430                if S = Standard_Standard then
2431                   Set_Uses_Sec_Stack (Current_Scope, False);
2432                   exit;
2433
2434                --  In a function, only release the sec stack if the
2435                --  function does not return on the sec stack otherwise
2436                --  the result may be lost. The caller is responsible for
2437                --  releasing.
2438
2439                elsif K = E_Function then
2440                   Set_Uses_Sec_Stack (Current_Scope, False);
2441
2442                   if not Requires_Transient_Scope (Etype (S)) then
2443                      if not Functions_Return_By_DSP_On_Target then
2444                         Set_Uses_Sec_Stack (S, True);
2445                         Disallow_In_No_Run_Time_Mode (Action);
2446                      end if;
2447                   end if;
2448
2449                   exit;
2450
2451                --  In a loop or entry we should install a block encompassing
2452                --  all the construct. For now just release right away.
2453
2454                elsif K = E_Loop or else K = E_Entry then
2455                   exit;
2456
2457                --  In a procedure or a block, we release on exit of the
2458                --  procedure or block. ??? memory leak can be created by
2459                --  recursive calls.
2460
2461                elsif K = E_Procedure
2462                  or else K = E_Block
2463                then
2464                   if not Functions_Return_By_DSP_On_Target then
2465                      Set_Uses_Sec_Stack (S, True);
2466                      Disallow_In_No_Run_Time_Mode (Action);
2467                   end if;
2468
2469                   Set_Uses_Sec_Stack (Current_Scope, False);
2470                   exit;
2471
2472                else
2473                   S := Scope (S);
2474                end if;
2475             end loop;
2476          end;
2477       end if;
2478
2479       --  Insert actions stuck in the transient scopes as well as all
2480       --  freezing nodes needed by those actions
2481
2482       Insert_Actions_In_Scope_Around (Action);
2483
2484       declare
2485          Last_Inserted : Node_Id := Prev (Action);
2486
2487       begin
2488          if Present (Last_Inserted) then
2489             Freeze_All (First_Entity (Current_Scope), Last_Inserted);
2490          end if;
2491       end;
2492
2493       Blk :=
2494         Make_Block_Statement (Loc,
2495           Identifier => New_Reference_To (Current_Scope, Loc),
2496           Declarations => Decls,
2497           Handled_Statement_Sequence =>
2498             Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
2499           Has_Created_Identifier => True);
2500
2501       --  When the transient scope was established, we pushed the entry for
2502       --  the transient scope onto the scope stack, so that the scope was
2503       --  active for the installation of finalizable entities etc. Now we
2504       --  must remove this entry, since we have constructed a proper block.
2505
2506       Pop_Scope;
2507
2508       return Blk;
2509    end Make_Transient_Block;
2510
2511    ------------------------
2512    -- Node_To_Be_Wrapped --
2513    ------------------------
2514
2515    function Node_To_Be_Wrapped return Node_Id is
2516    begin
2517       return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
2518    end Node_To_Be_Wrapped;
2519
2520    ----------------------------
2521    -- Set_Node_To_Be_Wrapped --
2522    ----------------------------
2523
2524    procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
2525    begin
2526       Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
2527    end Set_Node_To_Be_Wrapped;
2528
2529    ----------------------------------
2530    -- Store_After_Actions_In_Scope --
2531    ----------------------------------
2532
2533    procedure Store_After_Actions_In_Scope (L : List_Id) is
2534       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
2535
2536    begin
2537       if Present (SE.Actions_To_Be_Wrapped_After) then
2538          Insert_List_Before_And_Analyze (
2539           First (SE.Actions_To_Be_Wrapped_After), L);
2540
2541       else
2542          SE.Actions_To_Be_Wrapped_After := L;
2543
2544          if Is_List_Member (SE.Node_To_Be_Wrapped) then
2545             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
2546          else
2547             Set_Parent (L, SE.Node_To_Be_Wrapped);
2548          end if;
2549
2550          Analyze_List (L);
2551       end if;
2552    end Store_After_Actions_In_Scope;
2553
2554    -----------------------------------
2555    -- Store_Before_Actions_In_Scope --
2556    -----------------------------------
2557
2558    procedure Store_Before_Actions_In_Scope (L : List_Id) is
2559       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
2560
2561    begin
2562       if Present (SE.Actions_To_Be_Wrapped_Before) then
2563          Insert_List_After_And_Analyze (
2564            Last (SE.Actions_To_Be_Wrapped_Before), L);
2565
2566       else
2567          SE.Actions_To_Be_Wrapped_Before := L;
2568
2569          if Is_List_Member (SE.Node_To_Be_Wrapped) then
2570             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
2571          else
2572             Set_Parent (L, SE.Node_To_Be_Wrapped);
2573          end if;
2574
2575          Analyze_List (L);
2576       end if;
2577    end Store_Before_Actions_In_Scope;
2578
2579    --------------------------------
2580    -- Wrap_Transient_Declaration --
2581    --------------------------------
2582
2583    --  If a transient scope has been established during the processing of the
2584    --  Expression of an Object_Declaration, it is not possible to wrap the
2585    --  declaration into a transient block as usual case, otherwise the object
2586    --  would be itself declared in the wrong scope. Therefore, all entities (if
2587    --  any) defined in the transient block are moved to the proper enclosing
2588    --  scope, furthermore, if they are controlled variables they are finalized
2589    --  right after the declaration. The finalization list of the transient
2590    --  scope is defined as a renaming of the enclosing one so during their
2591    --  initialization they will be attached to the proper finalization
2592    --  list. For instance, the following declaration :
2593
2594    --        X : Typ := F (G (A), G (B));
2595
2596    --  (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
2597    --  is expanded into :
2598
2599    --    _local_final_list_1 : Finalizable_Ptr;
2600    --    X : Typ := [ complex Expression-Action ];
2601    --    Finalize_One(_v1);
2602    --    Finalize_One (_v2);
2603
2604    procedure Wrap_Transient_Declaration (N : Node_Id) is
2605       S           : Entity_Id;
2606       LC          : Entity_Id := Empty;
2607       Nodes       : List_Id;
2608       Loc         : constant Source_Ptr := Sloc (N);
2609       Enclosing_S : Entity_Id;
2610       Uses_SS     : Boolean;
2611       Next_N      : constant Node_Id := Next (N);
2612
2613    begin
2614       S := Current_Scope;
2615       Enclosing_S := Scope (S);
2616
2617       --  Insert Actions kept in the Scope stack
2618
2619       Insert_Actions_In_Scope_Around (N);
2620
2621       --  If the declaration is consuming some secondary stack, mark the
2622       --  Enclosing scope appropriately.
2623
2624       Uses_SS := Uses_Sec_Stack (S);
2625       Pop_Scope;
2626
2627       --  Create a List controller and rename the final list to be its
2628       --  internal final pointer:
2629       --       Lxxx : Simple_List_Controller;
2630       --       Fxxx : Finalizable_Ptr renames Lxxx.F;
2631
2632       if Present (Finalization_Chain_Entity (S)) then
2633          LC := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
2634
2635          Nodes := New_List (
2636            Make_Object_Declaration (Loc,
2637              Defining_Identifier => LC,
2638              Object_Definition   =>
2639                New_Reference_To (RTE (RE_Simple_List_Controller), Loc)),
2640
2641            Make_Object_Renaming_Declaration (Loc,
2642              Defining_Identifier => Finalization_Chain_Entity (S),
2643              Subtype_Mark => New_Reference_To (RTE (RE_Finalizable_Ptr), Loc),
2644              Name =>
2645                Make_Selected_Component (Loc,
2646                  Prefix        => New_Reference_To (LC, Loc),
2647                  Selector_Name => Make_Identifier (Loc, Name_F))));
2648
2649          --  Put the declaration at the beginning of the declaration part
2650          --  to make sure it will be before all other actions that have been
2651          --  inserted before N.
2652
2653          Insert_List_Before_And_Analyze (First (List_Containing (N)), Nodes);
2654
2655          --  Generate the Finalization calls by finalizing the list
2656          --  controller right away. It will be re-finalized on scope
2657          --  exit but it doesn't matter. It cannot be done when the
2658          --  call initializes a renaming object though because in this
2659          --  case, the object becomes a pointer to the temporary and thus
2660          --  increases its life span.
2661
2662          if Nkind (N) = N_Object_Renaming_Declaration
2663            and then Controlled_Type (Etype (Defining_Identifier (N)))
2664          then
2665             null;
2666
2667          else
2668             Nodes :=
2669               Make_Final_Call (
2670                    Ref         => New_Reference_To (LC, Loc),
2671                    Typ         => Etype (LC),
2672                    With_Detach => New_Reference_To (Standard_False, Loc));
2673             if Present (Next_N) then
2674                Insert_List_Before_And_Analyze (Next_N, Nodes);
2675             else
2676                Append_List_To (List_Containing (N), Nodes);
2677             end if;
2678          end if;
2679       end if;
2680
2681       --  Put the local entities back in the enclosing scope, and set the
2682       --  Is_Public flag appropriately.
2683
2684       Transfer_Entities (S, Enclosing_S);
2685
2686       --  Mark the enclosing dynamic scope so that the sec stack will be
2687       --  released upon its exit unless this is a function that returns on
2688       --  the sec stack in which case this will be done by the caller.
2689
2690       if Uses_SS then
2691          S := Enclosing_Dynamic_Scope (S);
2692
2693          if Ekind (S) = E_Function
2694            and then Requires_Transient_Scope (Etype (S))
2695          then
2696             null;
2697          else
2698             Set_Uses_Sec_Stack (S);
2699             Disallow_In_No_Run_Time_Mode (N);
2700          end if;
2701       end if;
2702    end Wrap_Transient_Declaration;
2703
2704    -------------------------------
2705    -- Wrap_Transient_Expression --
2706    -------------------------------
2707
2708    --  Insert actions before <Expression>:
2709
2710    --  (lines marked with <CTRL> are expanded only in presence of Controlled
2711    --   objects needing finalization)
2712
2713    --     _E : Etyp;
2714    --     declare
2715    --        _M : constant Mark_Id := SS_Mark;
2716    --        Local_Final_List : System.FI.Finalizable_Ptr;    <CTRL>
2717
2718    --        procedure _Clean is
2719    --        begin
2720    --           Abort_Defer;
2721    --           System.FI.Finalize_List (Local_Final_List);   <CTRL>
2722    --           SS_Release (M);
2723    --           Abort_Undefer;
2724    --        end _Clean;
2725
2726    --     begin
2727    --        _E := <Expression>;
2728    --     at end
2729    --        _Clean;
2730    --     end;
2731
2732    --    then expression is replaced by _E
2733
2734    procedure Wrap_Transient_Expression (N : Node_Id) is
2735       Loc  : constant Source_Ptr := Sloc (N);
2736       E    : constant Entity_Id :=
2737                Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
2738       Etyp : Entity_Id := Etype (N);
2739
2740    begin
2741       Insert_Actions (N, New_List (
2742         Make_Object_Declaration (Loc,
2743           Defining_Identifier => E,
2744           Object_Definition   => New_Reference_To (Etyp, Loc)),
2745
2746         Make_Transient_Block (Loc,
2747           Action =>
2748             Make_Assignment_Statement (Loc,
2749               Name       => New_Reference_To (E, Loc),
2750               Expression => Relocate_Node (N)))));
2751
2752       Rewrite (N, New_Reference_To (E, Loc));
2753       Analyze_And_Resolve (N, Etyp);
2754    end Wrap_Transient_Expression;
2755
2756    ------------------------------
2757    -- Wrap_Transient_Statement --
2758    ------------------------------
2759
2760    --  Transform <Instruction> into
2761
2762    --  (lines marked with <CTRL> are expanded only in presence of Controlled
2763    --   objects needing finalization)
2764
2765    --    declare
2766    --       _M : Mark_Id := SS_Mark;
2767    --       Local_Final_List : System.FI.Finalizable_Ptr ;    <CTRL>
2768
2769    --       procedure _Clean is
2770    --       begin
2771    --          Abort_Defer;
2772    --          System.FI.Finalize_List (Local_Final_List);    <CTRL>
2773    --          SS_Release (_M);
2774    --          Abort_Undefer;
2775    --       end _Clean;
2776
2777    --    begin
2778    --       <Instr uction>;
2779    --    at end
2780    --       _Clean;
2781    --    end;
2782
2783    procedure Wrap_Transient_Statement (N : Node_Id) is
2784       Loc           : constant Source_Ptr := Sloc (N);
2785       New_Statement : constant Node_Id := Relocate_Node (N);
2786
2787    begin
2788       Rewrite (N, Make_Transient_Block (Loc, New_Statement));
2789
2790       --  With the scope stack back to normal, we can call analyze on the
2791       --  resulting block. At this point, the transient scope is being
2792       --  treated like a perfectly normal scope, so there is nothing
2793       --  special about it.
2794
2795       --  Note: Wrap_Transient_Statement is called with the node already
2796       --  analyzed (i.e. Analyzed (N) is True). This is important, since
2797       --  otherwise we would get a recursive processing of the node when
2798       --  we do this Analyze call.
2799
2800       Analyze (N);
2801    end Wrap_Transient_Statement;
2802
2803 end Exp_Ch7;