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