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