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