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-2008, 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 which 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 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/Adjustment/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 adjusting 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_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
 994          Atyp := Entity (Subtype_Mark (Arg));
 995       else
 996          Atyp := Etype (Arg);
 997       end if;
 998
 999       if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
1000          return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
1001
1002       elsif Ftyp /= Atyp
1003         and then Present (Atyp)
1004         and then
1005           (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
1006         and then
1007            Base_Type (Underlying_Type (Atyp)) =
1008              Base_Type (Underlying_Type (Ftyp))
1009       then
1010          return Unchecked_Convert_To (Ftyp, Arg);
1011
1012       --  If the argument is already a conversion, as generated by
1013       --  Make_Init_Call, set the target type to the type of the formal
1014       --  directly, to avoid spurious typing problems.
1015
1016       elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
1017         and then not Is_Class_Wide_Type (Atyp)
1018       then
1019          Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
1020          Set_Etype (Arg, Ftyp);
1021          return Arg;
1022
1023       else
1024          return Arg;
1025       end if;
1026    end Convert_View;
1027
1028    -------------------------------
1029    -- Establish_Transient_Scope --
1030    -------------------------------
1031
1032    --  This procedure is called each time a transient block has to be inserted
1033    --  that is to say for each call to a function with unconstrained or tagged
1034    --  result. It creates a new scope on the stack scope in order to enclose
1035    --  all transient variables generated
1036
1037    procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
1038       Loc       : constant Source_Ptr := Sloc (N);
1039       Wrap_Node : Node_Id;
1040
1041    begin
1042       --  Nothing to do for virtual machines where memory is GCed
1043
1044       if VM_Target /= No_VM then
1045          return;
1046       end if;
1047
1048       --  Do not create a transient scope if we are already inside one
1049
1050       for S in reverse Scope_Stack.First .. Scope_Stack.Last loop
1051          if Scope_Stack.Table (S).Is_Transient then
1052             if Sec_Stack then
1053                Set_Uses_Sec_Stack (Scope_Stack.Table (S).Entity);
1054             end if;
1055
1056             return;
1057
1058          --  If we have encountered Standard there are no enclosing
1059          --  transient scopes.
1060
1061          elsif Scope_Stack.Table (S).Entity = Standard_Standard then
1062             exit;
1063
1064          end if;
1065       end loop;
1066
1067       Wrap_Node := Find_Node_To_Be_Wrapped (N);
1068
1069       --  Case of no wrap node, false alert, no transient scope needed
1070
1071       if No (Wrap_Node) then
1072          null;
1073
1074       --  If the node to wrap is an iteration_scheme, the expression is
1075       --  one of the bounds, and the expansion will make an explicit
1076       --  declaration for it (see Analyze_Iteration_Scheme, sem_ch5.adb),
1077       --  so do not apply any transformations here.
1078
1079       elsif Nkind (Wrap_Node) = N_Iteration_Scheme then
1080          null;
1081
1082       else
1083          Push_Scope (New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'));
1084          Set_Scope_Is_Transient;
1085
1086          if Sec_Stack then
1087             Set_Uses_Sec_Stack (Current_Scope);
1088             Check_Restriction (No_Secondary_Stack, N);
1089          end if;
1090
1091          Set_Etype (Current_Scope, Standard_Void_Type);
1092          Set_Node_To_Be_Wrapped (Wrap_Node);
1093
1094          if Debug_Flag_W then
1095             Write_Str ("    <Transient>");
1096             Write_Eol;
1097          end if;
1098       end if;
1099    end Establish_Transient_Scope;
1100
1101    ----------------------------
1102    -- Expand_Cleanup_Actions --
1103    ----------------------------
1104
1105    procedure Expand_Cleanup_Actions (N : Node_Id) is
1106       S       : constant Entity_Id  := Current_Scope;
1107       Flist   : constant Entity_Id := Finalization_Chain_Entity (S);
1108       Is_Task : constant Boolean := Nkind (Original_Node (N)) = N_Task_Body;
1109
1110       Is_Master            : constant Boolean :=
1111                                Nkind (N) /= N_Entry_Body
1112                                  and then Is_Task_Master (N);
1113       Is_Protected         : constant Boolean :=
1114                                Nkind (N) = N_Subprogram_Body
1115                                  and then Is_Protected_Subprogram_Body (N);
1116       Is_Task_Allocation   : constant Boolean :=
1117                                Nkind (N) = N_Block_Statement
1118                                  and then Is_Task_Allocation_Block (N);
1119       Is_Asynchronous_Call : constant Boolean :=
1120                                Nkind (N) = N_Block_Statement
1121                                  and then Is_Asynchronous_Call_Block (N);
1122
1123       Clean     : Entity_Id;
1124       Loc       : Source_Ptr;
1125       Mark      : Entity_Id := Empty;
1126       New_Decls : constant List_Id := New_List;
1127       Blok      : Node_Id;
1128       End_Lab   : Node_Id;
1129       Wrapped   : Boolean;
1130       Chain     : Entity_Id := Empty;
1131       Decl      : Node_Id;
1132       Old_Poll  : Boolean;
1133
1134    begin
1135       --  If we are generating expanded code for debugging purposes, use
1136       --  the Sloc of the point of insertion for the cleanup code. The Sloc
1137       --  will be updated subsequently to reference the proper line in the
1138       --  .dg file.  If we are not debugging generated code, use instead
1139       --  No_Location, so that no debug information is generated for the
1140       --  cleanup code. This makes the behavior of the NEXT command in GDB
1141       --  monotonic, and makes the placement of breakpoints more accurate.
1142
1143       if Debug_Generated_Code then
1144          Loc := Sloc (S);
1145       else
1146          Loc := No_Location;
1147       end if;
1148
1149       --  There are cleanup actions only if the secondary stack needs
1150       --  releasing or some finalizations are needed or in the context
1151       --  of tasking
1152
1153       if Uses_Sec_Stack  (Current_Scope)
1154         and then not Sec_Stack_Needed_For_Return (Current_Scope)
1155       then
1156          null;
1157       elsif No (Flist)
1158         and then not Is_Master
1159         and then not Is_Task
1160         and then not Is_Protected
1161         and then not Is_Task_Allocation
1162         and then not Is_Asynchronous_Call
1163       then
1164          Clean_Simple_Protected_Objects (N);
1165          return;
1166       end if;
1167
1168       --  If the current scope is the subprogram body that is the rewriting
1169       --  of a task body, and the descriptors have not been delayed (due to
1170       --  some nested instantiations) do not generate redundant cleanup
1171       --  actions: the cleanup procedure already exists for this body.
1172
1173       if Nkind (N) = N_Subprogram_Body
1174         and then Nkind (Original_Node (N)) = N_Task_Body
1175         and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
1176       then
1177          return;
1178       end if;
1179
1180       --  Set polling off, since we don't need to poll during cleanup
1181       --  actions, and indeed for the cleanup routine, which is executed
1182       --  with aborts deferred, we don't want polling.
1183
1184       Old_Poll := Polling_Required;
1185       Polling_Required := False;
1186
1187       --  Make sure we have a declaration list, since we will add to it
1188
1189       if No (Declarations (N)) then
1190          Set_Declarations (N, New_List);
1191       end if;
1192
1193       --  The task activation call has already been built for task
1194       --  allocation blocks.
1195
1196       if not Is_Task_Allocation then
1197          Build_Task_Activation_Call (N);
1198       end if;
1199
1200       if Is_Master then
1201          Establish_Task_Master (N);
1202       end if;
1203
1204       --  If secondary stack is in use, expand:
1205       --    _Mxx : constant Mark_Id := SS_Mark;
1206
1207       --  Suppress calls to SS_Mark and SS_Release if VM_Target,
1208       --  since we never use the secondary stack on the VM.
1209
1210       if Uses_Sec_Stack (Current_Scope)
1211         and then not Sec_Stack_Needed_For_Return (Current_Scope)
1212         and then VM_Target = No_VM
1213       then
1214          Mark := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
1215          Append_To (New_Decls,
1216            Make_Object_Declaration (Loc,
1217              Defining_Identifier => Mark,
1218              Object_Definition   => New_Reference_To (RTE (RE_Mark_Id), Loc),
1219              Expression =>
1220                Make_Function_Call (Loc,
1221                  Name => New_Reference_To (RTE (RE_SS_Mark), Loc))));
1222
1223          Set_Uses_Sec_Stack (Current_Scope, False);
1224       end if;
1225
1226       --  If finalization list is present then expand:
1227       --   Local_Final_List : System.FI.Finalizable_Ptr;
1228
1229       if Present (Flist) then
1230          Append_To (New_Decls,
1231            Make_Object_Declaration (Loc,
1232              Defining_Identifier => Flist,
1233              Object_Definition   =>
1234                New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
1235       end if;
1236
1237       --  Clean-up procedure definition
1238
1239       Clean := Make_Defining_Identifier (Loc, Name_uClean);
1240       Set_Suppress_Elaboration_Warnings (Clean);
1241       Append_To (New_Decls,
1242         Make_Clean (N, Clean, Mark, Flist,
1243           Is_Task,
1244           Is_Master,
1245           Is_Protected,
1246           Is_Task_Allocation,
1247           Is_Asynchronous_Call));
1248
1249       --  If exception handlers are present, wrap the Sequence of
1250       --  statements in a block because it is not possible to get
1251       --  exception handlers and an AT END call in the same scope.
1252
1253       if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
1254
1255          --  Preserve end label to provide proper cross-reference information
1256
1257          End_Lab := End_Label (Handled_Statement_Sequence (N));
1258          Blok :=
1259            Make_Block_Statement (Loc,
1260              Handled_Statement_Sequence => Handled_Statement_Sequence (N));
1261          Set_Handled_Statement_Sequence (N,
1262            Make_Handled_Sequence_Of_Statements (Loc, New_List (Blok)));
1263          Set_End_Label (Handled_Statement_Sequence (N), End_Lab);
1264          Wrapped := True;
1265
1266          --  Comment needed here, see RH for 1.306 ???
1267
1268          if Nkind (N) = N_Subprogram_Body then
1269             Set_Has_Nested_Block_With_Handler (Current_Scope);
1270          end if;
1271
1272       --  Otherwise we do not wrap
1273
1274       else
1275          Wrapped := False;
1276          Blok    := Empty;
1277       end if;
1278
1279       --  Don't move the _chain Activation_Chain declaration in task
1280       --  allocation blocks. Task allocation blocks use this object
1281       --  in their cleanup handlers, and gigi complains if it is declared
1282       --  in the sequence of statements of the scope that declares the
1283       --  handler.
1284
1285       if Is_Task_Allocation then
1286          Chain := Activation_Chain_Entity (N);
1287          Decl := First (Declarations (N));
1288
1289          while Nkind (Decl) /= N_Object_Declaration
1290            or else Defining_Identifier (Decl) /= Chain
1291          loop
1292             Next (Decl);
1293             pragma Assert (Present (Decl));
1294          end loop;
1295
1296          Remove (Decl);
1297          Prepend_To (New_Decls, Decl);
1298       end if;
1299
1300       --  Now we move the declarations into the Sequence of statements
1301       --  in order to get them protected by the AT END call. It may seem
1302       --  weird to put declarations in the sequence of statement but in
1303       --  fact nothing forbids that at the tree level. We also set the
1304       --  First_Real_Statement field so that we remember where the real
1305       --  statements (i.e. original statements) begin. Note that if we
1306       --  wrapped the statements, the first real statement is inside the
1307       --  inner block. If the First_Real_Statement is already set (as is
1308       --  the case for subprogram bodies that are expansions of task bodies)
1309       --  then do not reset it, because its declarative part would migrate
1310       --  to the statement part.
1311
1312       if not Wrapped then
1313          if No (First_Real_Statement (Handled_Statement_Sequence (N))) then
1314             Set_First_Real_Statement (Handled_Statement_Sequence (N),
1315               First (Statements (Handled_Statement_Sequence (N))));
1316          end if;
1317
1318       else
1319          Set_First_Real_Statement (Handled_Statement_Sequence (N), Blok);
1320       end if;
1321
1322       Append_List_To (Declarations (N),
1323         Statements (Handled_Statement_Sequence (N)));
1324       Set_Statements (Handled_Statement_Sequence (N), Declarations (N));
1325
1326       --  We need to reset the Sloc of the handled statement sequence to
1327       --  properly reflect the new initial "statement" in the sequence.
1328
1329       Set_Sloc
1330         (Handled_Statement_Sequence (N), Sloc (First (Declarations (N))));
1331
1332       --  The declarations of the _Clean procedure and finalization chain
1333       --  replace the old declarations that have been moved inward
1334
1335       Set_Declarations (N, New_Decls);
1336       Analyze_Declarations (New_Decls);
1337
1338       --  The At_End call is attached to the sequence of statements
1339
1340       declare
1341          HSS : Node_Id;
1342
1343       begin
1344          --  If the construct is a protected subprogram, then the call to
1345          --  the corresponding unprotected program appears in a block which
1346          --  is the last statement in the body, and it is this block that
1347          --  must be covered by the At_End handler.
1348
1349          if Is_Protected then
1350             HSS := Handled_Statement_Sequence
1351               (Last (Statements (Handled_Statement_Sequence (N))));
1352          else
1353             HSS := Handled_Statement_Sequence (N);
1354          end if;
1355
1356          Set_At_End_Proc (HSS, New_Occurrence_Of (Clean, Loc));
1357          Expand_At_End_Handler (HSS, Empty);
1358       end;
1359
1360       --  Restore saved polling mode
1361
1362       Polling_Required := Old_Poll;
1363    end Expand_Cleanup_Actions;
1364
1365    -------------------------------
1366    -- Expand_Ctrl_Function_Call --
1367    -------------------------------
1368
1369    procedure Expand_Ctrl_Function_Call (N : Node_Id) is
1370       Loc     : constant Source_Ptr := Sloc (N);
1371       Rtype   : constant Entity_Id  := Etype (N);
1372       Utype   : constant Entity_Id  := Underlying_Type (Rtype);
1373       Ref     : Node_Id;
1374       Action  : Node_Id;
1375       Action2 : Node_Id := Empty;
1376
1377       Attach_Level : Uint    := Uint_1;
1378       Len_Ref      : Node_Id := Empty;
1379
1380       function Last_Array_Component
1381         (Ref : Node_Id;
1382          Typ : Entity_Id) return Node_Id;
1383       --  Creates a reference to the last component of the array object
1384       --  designated by Ref whose type is Typ.
1385
1386       --------------------------
1387       -- Last_Array_Component --
1388       --------------------------
1389
1390       function Last_Array_Component
1391         (Ref : Node_Id;
1392          Typ : Entity_Id) return Node_Id
1393       is
1394          Index_List : constant List_Id := New_List;
1395
1396       begin
1397          for N in 1 .. Number_Dimensions (Typ) loop
1398             Append_To (Index_List,
1399               Make_Attribute_Reference (Loc,
1400                 Prefix         => Duplicate_Subexpr_No_Checks (Ref),
1401                 Attribute_Name => Name_Last,
1402                 Expressions    => New_List (
1403                   Make_Integer_Literal (Loc, N))));
1404          end loop;
1405
1406          return
1407            Make_Indexed_Component (Loc,
1408              Prefix      => Duplicate_Subexpr (Ref),
1409              Expressions => Index_List);
1410       end Last_Array_Component;
1411
1412    --  Start of processing for Expand_Ctrl_Function_Call
1413
1414    begin
1415       --  Optimization, if the returned value (which is on the sec-stack) is
1416       --  returned again, no need to copy/readjust/finalize, we can just pass
1417       --  the value thru (see Expand_N_Simple_Return_Statement), and thus no
1418       --  attachment is needed
1419
1420       if Nkind (Parent (N)) = N_Simple_Return_Statement then
1421          return;
1422       end if;
1423
1424       --  Resolution is now finished, make sure we don't start analysis again
1425       --  because of the duplication
1426
1427       Set_Analyzed (N);
1428       Ref := Duplicate_Subexpr_No_Checks (N);
1429
1430       --  Now we can generate the Attach Call, note that this value is
1431       --  always in the (secondary) stack and thus is attached to a singly
1432       --  linked final list:
1433
1434       --    Resx := F (X)'reference;
1435       --    Attach_To_Final_List (_Lx, Resx.all, 1);
1436
1437       --  or when there are controlled components
1438
1439       --    Attach_To_Final_List (_Lx, Resx._controller, 1);
1440
1441       --  or when it is both is_controlled and has_controlled_components
1442
1443       --    Attach_To_Final_List (_Lx, Resx._controller, 1);
1444       --    Attach_To_Final_List (_Lx, Resx, 1);
1445
1446       --  or if it is an array with is_controlled (and has_controlled)
1447
1448       --    Attach_To_Final_List (_Lx, Resx (Resx'last), 3);
1449       --    An attach level of 3 means that a whole array is to be
1450       --    attached to the finalization list (including the controlled
1451       --    components)
1452
1453       --  or if it is an array with has_controlled components but not
1454       --  is_controlled
1455
1456       --    Attach_To_Final_List (_Lx, Resx (Resx'last)._controller, 3);
1457
1458       if Has_Controlled_Component (Rtype) then
1459          declare
1460             T1 : Entity_Id := Rtype;
1461             T2 : Entity_Id := Utype;
1462
1463          begin
1464             if Is_Array_Type (T2) then
1465                Len_Ref :=
1466                  Make_Attribute_Reference (Loc,
1467                  Prefix =>
1468                    Duplicate_Subexpr_Move_Checks
1469                      (Unchecked_Convert_To (T2, Ref)),
1470                  Attribute_Name => Name_Length);
1471             end if;
1472
1473             while Is_Array_Type (T2) loop
1474                if T1 /= T2 then
1475                   Ref := Unchecked_Convert_To (T2, Ref);
1476                end if;
1477
1478                Ref := Last_Array_Component (Ref, T2);
1479                Attach_Level := Uint_3;
1480                T1 := Component_Type (T2);
1481                T2 := Underlying_Type (T1);
1482             end loop;
1483
1484             --  If the type has controlled components, go to the controller
1485             --  except in the case of arrays of controlled objects since in
1486             --  this case objects and their components are already chained
1487             --  and the head of the chain is the last array element.
1488
1489             if Is_Array_Type (Rtype) and then Is_Controlled (T2) then
1490                null;
1491
1492             elsif Has_Controlled_Component (T2) then
1493                if T1 /= T2 then
1494                   Ref := Unchecked_Convert_To (T2, Ref);
1495                end if;
1496
1497                Ref :=
1498                  Make_Selected_Component (Loc,
1499                    Prefix        => Ref,
1500                    Selector_Name => Make_Identifier (Loc, Name_uController));
1501             end if;
1502          end;
1503
1504          --  Here we know that 'Ref' has a controller so we may as well
1505          --  attach it directly
1506
1507          Action :=
1508            Make_Attach_Call (
1509              Obj_Ref      => Ref,
1510              Flist_Ref    => Find_Final_List (Current_Scope),
1511              With_Attach  => Make_Integer_Literal (Loc, Attach_Level));
1512
1513          --  If it is also Is_Controlled we need to attach the global object
1514
1515          if Is_Controlled (Rtype) then
1516             Action2 :=
1517               Make_Attach_Call (
1518                 Obj_Ref      => Duplicate_Subexpr_No_Checks (N),
1519                 Flist_Ref    => Find_Final_List (Current_Scope),
1520                 With_Attach  => Make_Integer_Literal (Loc, Attach_Level));
1521          end if;
1522
1523       else
1524          --  Here, we have a controlled type that does not seem to have
1525          --  controlled components but it could be a class wide type whose
1526          --  further derivations have controlled components. So we don't know
1527          --  if the object itself needs to be attached or if it
1528          --  has a record controller. We need to call a runtime function
1529          --  (Deep_Tag_Attach) which knows what to do thanks to the
1530          --  RC_Offset in the dispatch table.
1531
1532          Action :=
1533            Make_Procedure_Call_Statement (Loc,
1534              Name => New_Reference_To (RTE (RE_Deep_Tag_Attach), Loc),
1535              Parameter_Associations => New_List (
1536                Find_Final_List (Current_Scope),
1537
1538                Make_Attribute_Reference (Loc,
1539                    Prefix => Ref,
1540                    Attribute_Name => Name_Address),
1541
1542                Make_Integer_Literal (Loc, Attach_Level)));
1543       end if;
1544
1545       if Present (Len_Ref) then
1546          Action :=
1547            Make_Implicit_If_Statement (N,
1548              Condition => Make_Op_Gt (Loc,
1549                Left_Opnd  => Len_Ref,
1550                Right_Opnd => Make_Integer_Literal (Loc, 0)),
1551              Then_Statements => New_List (Action));
1552       end if;
1553
1554       Insert_Action (N, Action);
1555       if Present (Action2) then
1556          Insert_Action (N, Action2);
1557       end if;
1558    end Expand_Ctrl_Function_Call;
1559
1560    ---------------------------
1561    -- Expand_N_Package_Body --
1562    ---------------------------
1563
1564    --  Add call to Activate_Tasks if body is an activator (actual processing
1565    --  is in chapter 9).
1566
1567    --  Generate subprogram descriptor for elaboration routine
1568
1569    --  Encode entity names in package body
1570
1571    procedure Expand_N_Package_Body (N : Node_Id) is
1572       Ent : constant Entity_Id := Corresponding_Spec (N);
1573
1574    begin
1575       --  This is done only for non-generic packages
1576
1577       if Ekind (Ent) = E_Package then
1578          Push_Scope (Corresponding_Spec (N));
1579
1580          --  Build dispatch tables of library level tagged types
1581
1582          if Is_Library_Level_Entity (Ent) then
1583             Build_Static_Dispatch_Tables (N);
1584          end if;
1585
1586          Build_Task_Activation_Call (N);
1587          Pop_Scope;
1588       end if;
1589
1590       Set_Elaboration_Flag (N, Corresponding_Spec (N));
1591       Set_In_Package_Body (Ent, False);
1592
1593       --  Set to encode entity names in package body before gigi is called
1594
1595       Qualify_Entity_Names (N);
1596    end Expand_N_Package_Body;
1597
1598    ----------------------------------
1599    -- Expand_N_Package_Declaration --
1600    ----------------------------------
1601
1602    --  Add call to Activate_Tasks if there are tasks declared and the package
1603    --  has no body. Note that in Ada83, this may result in premature activation
1604    --  of some tasks, given that we cannot tell whether a body will eventually
1605    --  appear.
1606
1607    procedure Expand_N_Package_Declaration (N : Node_Id) is
1608       Spec    : constant Node_Id   := Specification (N);
1609       Id      : constant Entity_Id := Defining_Entity (N);
1610       Decls   : List_Id;
1611       No_Body : Boolean := False;
1612       --  True in the case of a package declaration that is a compilation unit
1613       --  and for which no associated body will be compiled in
1614       --  this compilation.
1615
1616    begin
1617       --  Case of a package declaration other than a compilation unit
1618
1619       if Nkind (Parent (N)) /= N_Compilation_Unit then
1620          null;
1621
1622       --  Case of a compilation unit that does not require a body
1623
1624       elsif not Body_Required (Parent (N))
1625         and then not Unit_Requires_Body (Id)
1626       then
1627          No_Body := True;
1628
1629       --  Special case of generating calling stubs for a remote call interface
1630       --  package: even though the package declaration requires one, the
1631       --  body won't be processed in this compilation (so any stubs for RACWs
1632       --  declared in the package must be generated here, along with the
1633       --  spec).
1634
1635       elsif Parent (N) = Cunit (Main_Unit)
1636         and then Is_Remote_Call_Interface (Id)
1637         and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
1638       then
1639          No_Body := True;
1640       end if;
1641
1642       --  For a package declaration that implies no associated body, generate
1643       --  task activation call and RACW supporting bodies now (since we won't
1644       --  have a specific separate compilation unit for that).
1645
1646       if No_Body then
1647          Push_Scope (Id);
1648
1649          if Has_RACW (Id) then
1650
1651             --  Generate RACW subprogram bodies
1652
1653             Decls := Private_Declarations (Spec);
1654
1655             if No (Decls) then
1656                Decls := Visible_Declarations (Spec);
1657             end if;
1658
1659             if No (Decls) then
1660                Decls := New_List;
1661                Set_Visible_Declarations (Spec, Decls);
1662             end if;
1663
1664             Append_RACW_Bodies (Decls, Id);
1665             Analyze_List (Decls);
1666          end if;
1667
1668          if Present (Activation_Chain_Entity (N)) then
1669
1670             --  Generate task activation call as last step of elaboration
1671
1672             Build_Task_Activation_Call (N);
1673          end if;
1674
1675          Pop_Scope;
1676       end if;
1677
1678       --  Build dispatch tables of library level tagged types
1679
1680       if Is_Compilation_Unit (Id)
1681         or else (Is_Generic_Instance (Id)
1682                    and then Is_Library_Level_Entity (Id))
1683       then
1684          Build_Static_Dispatch_Tables (N);
1685       end if;
1686
1687       --  Note: it is not necessary to worry about generating a subprogram
1688       --  descriptor, since the only way to get exception handlers into a
1689       --  package spec is to include instantiations, and that would cause
1690       --  generation of subprogram descriptors to be delayed in any case.
1691
1692       --  Set to encode entity names in package spec before gigi is called
1693
1694       Qualify_Entity_Names (N);
1695    end Expand_N_Package_Declaration;
1696
1697    ---------------------
1698    -- Find_Final_List --
1699    ---------------------
1700
1701    function Find_Final_List
1702      (E   : Entity_Id;
1703       Ref : Node_Id := Empty) return Node_Id
1704    is
1705       Loc : constant Source_Ptr := Sloc (Ref);
1706       S   : Entity_Id;
1707       Id  : Entity_Id;
1708       R   : Node_Id;
1709
1710    begin
1711       --  Case of an internal component. The Final list is the record
1712       --  controller of the enclosing record.
1713
1714       if Present (Ref) then
1715          R := Ref;
1716          loop
1717             case Nkind (R) is
1718                when N_Unchecked_Type_Conversion | N_Type_Conversion =>
1719                   R := Expression (R);
1720
1721                when N_Indexed_Component | N_Explicit_Dereference =>
1722                   R := Prefix (R);
1723
1724                when  N_Selected_Component =>
1725                   R := Prefix (R);
1726                   exit;
1727
1728                when  N_Identifier =>
1729                   exit;
1730
1731                when others =>
1732                   raise Program_Error;
1733             end case;
1734          end loop;
1735
1736          return
1737            Make_Selected_Component (Loc,
1738              Prefix =>
1739                Make_Selected_Component (Loc,
1740                  Prefix        => R,
1741                  Selector_Name => Make_Identifier (Loc, Name_uController)),
1742              Selector_Name => Make_Identifier (Loc, Name_F));
1743
1744       --  Case of a dynamically allocated object. The final list is the
1745       --  corresponding list controller (the next entity in the scope of the
1746       --  access type with the right type). If the type comes from a With_Type
1747       --  clause, no controller was created, we use the global chain instead.
1748
1749       --  An anonymous access type either has a list created for it when the
1750       --  allocator is a for an access parameter or an access discriminant,
1751       --  or else it uses the list of the enclosing dynamic scope, when the
1752       --  context is a declaration or an assignment.
1753
1754       elsif Is_Access_Type (E)
1755         and then (Ekind (E) /= E_Anonymous_Access_Type
1756                     or else
1757                   Present (Associated_Final_Chain (E)))
1758       then
1759          if not From_With_Type (E) then
1760             return
1761               Make_Selected_Component (Loc,
1762                 Prefix        =>
1763                   New_Reference_To
1764                     (Associated_Final_Chain (Base_Type (E)), Loc),
1765                 Selector_Name => Make_Identifier (Loc, Name_F));
1766          else
1767             return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E));
1768          end if;
1769
1770       else
1771          if Is_Dynamic_Scope (E) then
1772             S := E;
1773          else
1774             S := Enclosing_Dynamic_Scope (E);
1775          end if;
1776
1777          --  When the finalization chain entity is 'Error', it means that
1778          --  there should not be any chain at that level and that the
1779          --  enclosing one should be used
1780
1781          --  This is a nasty kludge, see ??? note in exp_ch11
1782
1783          while Finalization_Chain_Entity (S) = Error loop
1784             S := Enclosing_Dynamic_Scope (S);
1785          end loop;
1786
1787          if S = Standard_Standard then
1788             return New_Reference_To (RTE (RE_Global_Final_List), Sloc (E));
1789          else
1790             if No (Finalization_Chain_Entity (S)) then
1791                Id :=
1792                  Make_Defining_Identifier (Sloc (S),
1793                    Chars => New_Internal_Name ('F'));
1794                Set_Finalization_Chain_Entity (S, Id);
1795
1796                --  Set momentarily some semantics attributes to allow normal
1797                --  analysis of expansions containing references to this chain.
1798                --  Will be fully decorated during the expansion of the scope
1799                --  itself.
1800
1801                Set_Ekind (Id, E_Variable);
1802                Set_Etype (Id, RTE (RE_Finalizable_Ptr));
1803             end if;
1804
1805             return New_Reference_To (Finalization_Chain_Entity (S), Sloc (E));
1806          end if;
1807       end if;
1808    end Find_Final_List;
1809
1810    -----------------------------
1811    -- Find_Node_To_Be_Wrapped --
1812    -----------------------------
1813
1814    function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id is
1815       P          : Node_Id;
1816       The_Parent : Node_Id;
1817
1818    begin
1819       The_Parent := N;
1820       loop
1821          P := The_Parent;
1822          pragma Assert (P /= Empty);
1823          The_Parent := Parent (P);
1824
1825          case Nkind (The_Parent) is
1826
1827             --  Simple statement can be wrapped
1828
1829             when N_Pragma =>
1830                return The_Parent;
1831
1832             --  Usually assignments are good candidate for wrapping
1833             --  except when they have been generated as part of a
1834             --  controlled aggregate where the wrapping should take
1835             --  place more globally.
1836
1837             when N_Assignment_Statement =>
1838                if No_Ctrl_Actions (The_Parent) then
1839                   null;
1840                else
1841                   return The_Parent;
1842                end if;
1843
1844             --  An entry call statement is a special case if it occurs in
1845             --  the context of a Timed_Entry_Call. In this case we wrap
1846             --  the entire timed entry call.
1847
1848             when N_Entry_Call_Statement     |
1849                  N_Procedure_Call_Statement =>
1850                if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
1851                  and then Nkind_In (Parent (Parent (The_Parent)),
1852                                     N_Timed_Entry_Call,
1853                                     N_Conditional_Entry_Call)
1854                then
1855                   return Parent (Parent (The_Parent));
1856                else
1857                   return The_Parent;
1858                end if;
1859
1860             --  Object declarations are also a boundary for the transient scope
1861             --  even if they are not really wrapped
1862             --  (see Wrap_Transient_Declaration)
1863
1864             when N_Object_Declaration          |
1865                  N_Object_Renaming_Declaration |
1866                  N_Subtype_Declaration         =>
1867                return The_Parent;
1868
1869             --  The expression itself is to be wrapped if its parent is a
1870             --  compound statement or any other statement where the expression
1871             --  is known to be scalar
1872
1873             when N_Accept_Alternative               |
1874                  N_Attribute_Definition_Clause      |
1875                  N_Case_Statement                   |
1876                  N_Code_Statement                   |
1877                  N_Delay_Alternative                |
1878                  N_Delay_Until_Statement            |
1879                  N_Delay_Relative_Statement         |
1880                  N_Discriminant_Association         |
1881                  N_Elsif_Part                       |
1882                  N_Entry_Body_Formal_Part           |
1883                  N_Exit_Statement                   |
1884                  N_If_Statement                     |
1885                  N_Iteration_Scheme                 |
1886                  N_Terminate_Alternative            =>
1887                return P;
1888
1889             when N_Attribute_Reference =>
1890
1891                if Is_Procedure_Attribute_Name
1892                     (Attribute_Name (The_Parent))
1893                then
1894                   return The_Parent;
1895                end if;
1896
1897             --  A raise statement can be wrapped. This will arise when the
1898             --  expression in a raise_with_expression uses the secondary
1899             --  stack, for example.
1900
1901             when N_Raise_Statement =>
1902                return The_Parent;
1903
1904             --  If the expression is within the iteration scheme of a loop,
1905             --  we must create a declaration for it, followed by an assignment
1906             --  in order to have a usable statement to wrap.
1907
1908             when N_Loop_Parameter_Specification =>
1909                return Parent (The_Parent);
1910
1911             --  The following nodes contains "dummy calls" which don't
1912             --  need to be wrapped.
1913
1914             when N_Parameter_Specification     |
1915                  N_Discriminant_Specification  |
1916                  N_Component_Declaration       =>
1917                return Empty;
1918
1919             --  The return statement is not to be wrapped when the function
1920             --  itself needs wrapping at the outer-level
1921
1922             when N_Simple_Return_Statement =>
1923                declare
1924                   Applies_To : constant Entity_Id :=
1925                                  Return_Applies_To
1926                                    (Return_Statement_Entity (The_Parent));
1927                   Return_Type : constant Entity_Id := Etype (Applies_To);
1928                begin
1929                   if Requires_Transient_Scope (Return_Type) then
1930                      return Empty;
1931                   else
1932                      return The_Parent;
1933                   end if;
1934                end;
1935
1936             --  If we leave a scope without having been able to find a node to
1937             --  wrap, something is going wrong but this can happen in error
1938             --  situation that are not detected yet (such as a dynamic string
1939             --  in a pragma export)
1940
1941             when N_Subprogram_Body     |
1942                  N_Package_Declaration |
1943                  N_Package_Body        |
1944                  N_Block_Statement     =>
1945                return Empty;
1946
1947             --  otherwise continue the search
1948
1949             when others =>
1950                null;
1951          end case;
1952       end loop;
1953    end Find_Node_To_Be_Wrapped;
1954
1955    ----------------------
1956    -- Global_Flist_Ref --
1957    ----------------------
1958
1959    function Global_Flist_Ref  (Flist_Ref : Node_Id) return Boolean is
1960       Flist : Entity_Id;
1961
1962    begin
1963       --  Look for the Global_Final_List
1964
1965       if Is_Entity_Name (Flist_Ref) then
1966          Flist := Entity (Flist_Ref);
1967
1968       --  Look for the final list associated with an access to controlled
1969
1970       elsif  Nkind (Flist_Ref) = N_Selected_Component
1971         and then Is_Entity_Name (Prefix (Flist_Ref))
1972       then
1973          Flist :=  Entity (Prefix (Flist_Ref));
1974       else
1975          return False;
1976       end if;
1977
1978       return Present (Flist)
1979         and then Present (Scope (Flist))
1980         and then Enclosing_Dynamic_Scope (Flist) = Standard_Standard;
1981    end Global_Flist_Ref;
1982
1983    ----------------------------------
1984    -- Has_New_Controlled_Component --
1985    ----------------------------------
1986
1987    function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
1988       Comp : Entity_Id;
1989
1990    begin
1991       if not Is_Tagged_Type (E) then
1992          return Has_Controlled_Component (E);
1993       elsif not Is_Derived_Type (E) then
1994          return Has_Controlled_Component (E);
1995       end if;
1996
1997       Comp := First_Component (E);
1998       while Present (Comp) loop
1999
2000          if Chars (Comp) = Name_uParent then
2001             null;
2002
2003          elsif Scope (Original_Record_Component (Comp)) = E
2004            and then Controlled_Type (Etype (Comp))
2005          then
2006             return True;
2007          end if;
2008
2009          Next_Component (Comp);
2010       end loop;
2011
2012       return False;
2013    end Has_New_Controlled_Component;
2014
2015    --------------------------
2016    -- In_Finalization_Root --
2017    --------------------------
2018
2019    --  It would seem simpler to test Scope (RTE (RE_Root_Controlled)) but
2020    --  the purpose of this function is to avoid a circular call to Rtsfind
2021    --  which would been caused by such a test.
2022
2023    function In_Finalization_Root (E : Entity_Id) return Boolean is
2024       S : constant Entity_Id := Scope (E);
2025
2026    begin
2027       return Chars (Scope (S))     = Name_System
2028         and then Chars (S)         = Name_Finalization_Root
2029         and then Scope (Scope (S)) = Standard_Standard;
2030    end  In_Finalization_Root;
2031
2032    ------------------------------------
2033    -- Insert_Actions_In_Scope_Around --
2034    ------------------------------------
2035
2036    procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
2037       SE     : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
2038       Target : Node_Id;
2039
2040    begin
2041       --  If the node to be wrapped is the triggering statement of an
2042       --  asynchronous select, it is not part of a statement list. The
2043       --  actions must be inserted before the Select itself, which is
2044       --  part of some list of statements. Note that the triggering
2045       --  alternative includes the triggering statement and an optional
2046       --  statement list. If the node to be wrapped is part of that list,
2047       --  the normal insertion applies.
2048
2049       if Nkind (Parent (Node_To_Be_Wrapped)) = N_Triggering_Alternative
2050         and then not Is_List_Member (Node_To_Be_Wrapped)
2051       then
2052          Target := Parent (Parent (Node_To_Be_Wrapped));
2053       else
2054          Target := N;
2055       end if;
2056
2057       if Present (SE.Actions_To_Be_Wrapped_Before) then
2058          Insert_List_Before (Target, SE.Actions_To_Be_Wrapped_Before);
2059          SE.Actions_To_Be_Wrapped_Before := No_List;
2060       end if;
2061
2062       if Present (SE.Actions_To_Be_Wrapped_After) then
2063          Insert_List_After (Target, SE.Actions_To_Be_Wrapped_After);
2064          SE.Actions_To_Be_Wrapped_After := No_List;
2065       end if;
2066    end Insert_Actions_In_Scope_Around;
2067
2068    -----------------------
2069    -- Make_Adjust_Call --
2070    -----------------------
2071
2072    function Make_Adjust_Call
2073      (Ref         : Node_Id;
2074       Typ         : Entity_Id;
2075       Flist_Ref   : Node_Id;
2076       With_Attach : Node_Id;
2077       Allocator   : Boolean := False) return List_Id
2078    is
2079       Loc    : constant Source_Ptr := Sloc (Ref);
2080       Res    : constant List_Id    := New_List;
2081       Utyp   : Entity_Id;
2082       Proc   : Entity_Id;
2083       Cref   : Node_Id := Ref;
2084       Cref2  : Node_Id;
2085       Attach : Node_Id := With_Attach;
2086
2087    begin
2088       if Is_Class_Wide_Type (Typ) then
2089          Utyp := Underlying_Type (Base_Type (Root_Type (Typ)));
2090       else
2091          Utyp := Underlying_Type (Base_Type (Typ));
2092       end if;
2093
2094       Set_Assignment_OK (Cref);
2095
2096       --  Deal with non-tagged derivation of private views
2097
2098       if Is_Untagged_Derivation (Typ) then
2099          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
2100          Cref := Unchecked_Convert_To (Utyp, Cref);
2101          Set_Assignment_OK (Cref);
2102          --  To prevent problems with UC see 1.156 RH ???
2103       end if;
2104
2105       --  If the underlying_type is a subtype, we are dealing with
2106       --  the completion of a private type. We need to access
2107       --  the base type and generate a conversion to it.
2108
2109       if Utyp /= Base_Type (Utyp) then
2110          pragma Assert (Is_Private_Type (Typ));
2111          Utyp := Base_Type (Utyp);
2112          Cref := Unchecked_Convert_To (Utyp, Cref);
2113       end if;
2114
2115       --  If the object is unanalyzed, set its expected type for use
2116       --  in Convert_View in case an additional conversion is needed.
2117
2118       if No (Etype (Cref))
2119         and then Nkind (Cref) /= N_Unchecked_Type_Conversion
2120       then
2121          Set_Etype (Cref, Typ);
2122       end if;
2123
2124       --  We do not need to attach to one of the Global Final Lists
2125       --  the objects whose type is Finalize_Storage_Only
2126
2127       if Finalize_Storage_Only (Typ)
2128         and then (Global_Flist_Ref (Flist_Ref)
2129           or else Entity (Constant_Value (RTE (RE_Garbage_Collected)))
2130                   = Standard_True)
2131       then
2132          Attach := Make_Integer_Literal (Loc, 0);
2133       end if;
2134
2135       --  Special case for allocators: need initialization of the chain
2136       --  pointers. For the 0 case, reset them to null.
2137
2138       if Allocator then
2139          pragma Assert (Nkind (Attach) = N_Integer_Literal);
2140
2141          if Intval (Attach) = 0 then
2142             Set_Intval (Attach, Uint_4);
2143          end if;
2144       end if;
2145
2146       --  Generate:
2147       --    Deep_Adjust (Flist_Ref, Ref, Attach);
2148
2149       if Has_Controlled_Component (Utyp)
2150         or else Is_Class_Wide_Type (Typ)
2151       then
2152          if Is_Tagged_Type (Utyp) then
2153             Proc := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
2154
2155          else
2156             Proc := TSS (Utyp, TSS_Deep_Adjust);
2157          end if;
2158
2159          Cref := Convert_View (Proc, Cref, 2);
2160
2161          Append_To (Res,
2162            Make_Procedure_Call_Statement (Loc,
2163              Name => New_Reference_To (Proc, Loc),
2164              Parameter_Associations =>
2165                New_List (Flist_Ref, Cref, Attach)));
2166
2167       --  Generate:
2168       --    if With_Attach then
2169       --       Attach_To_Final_List (Ref, Flist_Ref);
2170       --    end if;
2171       --    Adjust (Ref);
2172
2173       else -- Is_Controlled (Utyp)
2174
2175          Proc  := Find_Prim_Op (Utyp, Name_Of (Adjust_Case));
2176          Cref  := Convert_View (Proc, Cref);
2177          Cref2 := New_Copy_Tree (Cref);
2178
2179          Append_To (Res,
2180            Make_Procedure_Call_Statement (Loc,
2181            Name => New_Reference_To (Proc, Loc),
2182            Parameter_Associations => New_List (Cref2)));
2183
2184          Append_To (Res, Make_Attach_Call (Cref, Flist_Ref, Attach));
2185       end if;
2186
2187       return Res;
2188    end Make_Adjust_Call;
2189
2190    ----------------------
2191    -- Make_Attach_Call --
2192    ----------------------
2193
2194    --  Generate:
2195    --    System.FI.Attach_To_Final_List (Flist, Ref, Nb_Link)
2196
2197    function Make_Attach_Call
2198      (Obj_Ref     : Node_Id;
2199       Flist_Ref   : Node_Id;
2200       With_Attach : Node_Id) return Node_Id
2201    is
2202       Loc : constant Source_Ptr := Sloc (Obj_Ref);
2203
2204    begin
2205       --  Optimization: If the number of links is statically '0', don't
2206       --  call the attach_proc.
2207
2208       if Nkind (With_Attach) = N_Integer_Literal
2209         and then Intval (With_Attach) = Uint_0
2210       then
2211          return Make_Null_Statement (Loc);
2212       end if;
2213
2214       return
2215         Make_Procedure_Call_Statement (Loc,
2216           Name => New_Reference_To (RTE (RE_Attach_To_Final_List), Loc),
2217           Parameter_Associations => New_List (
2218             Flist_Ref,
2219             OK_Convert_To (RTE (RE_Finalizable), Obj_Ref),
2220             With_Attach));
2221    end Make_Attach_Call;
2222
2223    ----------------
2224    -- Make_Clean --
2225    ----------------
2226
2227    function Make_Clean
2228      (N                          : Node_Id;
2229       Clean                      : Entity_Id;
2230       Mark                       : Entity_Id;
2231       Flist                      : Entity_Id;
2232       Is_Task                    : Boolean;
2233       Is_Master                  : Boolean;
2234       Is_Protected_Subprogram    : Boolean;
2235       Is_Task_Allocation_Block   : Boolean;
2236       Is_Asynchronous_Call_Block : Boolean) return Node_Id
2237    is
2238       Loc  : constant Source_Ptr := Sloc (Clean);
2239       Stmt : constant List_Id    := New_List;
2240
2241       Sbody        : Node_Id;
2242       Spec         : Node_Id;
2243       Name         : Node_Id;
2244       Param        : Node_Id;
2245       Param_Type   : Entity_Id;
2246       Pid          : Entity_Id := Empty;
2247       Cancel_Param : Entity_Id;
2248
2249    begin
2250       if Is_Task then
2251          if Restricted_Profile then
2252             Append_To
2253               (Stmt, Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
2254          else
2255             Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Task));
2256          end if;
2257
2258       elsif Is_Master then
2259          if Restriction_Active (No_Task_Hierarchy) = False then
2260             Append_To (Stmt, Build_Runtime_Call (Loc, RE_Complete_Master));
2261          end if;
2262
2263       elsif Is_Protected_Subprogram then
2264
2265          --  Add statements to the cleanup handler of the (ordinary)
2266          --  subprogram expanded to implement a protected subprogram,
2267          --  unlocking the protected object parameter and undeferring abort.
2268          --  If this is a protected procedure, and the object contains
2269          --  entries, this also calls the entry service routine.
2270
2271          --  NOTE: This cleanup handler references _object, a parameter
2272          --        to the procedure.
2273
2274          --  Find the _object parameter representing the protected object
2275
2276          Spec := Parent (Corresponding_Spec (N));
2277
2278          Param := First (Parameter_Specifications (Spec));
2279          loop
2280             Param_Type := Etype (Parameter_Type (Param));
2281
2282             if Ekind (Param_Type) = E_Record_Type then
2283                Pid := Corresponding_Concurrent_Type (Param_Type);
2284             end if;
2285
2286             exit when No (Param) or else Present (Pid);
2287             Next (Param);
2288          end loop;
2289
2290          pragma Assert (Present (Param));
2291
2292          --  If the associated protected object declares entries,
2293          --  a protected procedure has to service entry queues.
2294          --  In this case, add
2295
2296          --  Service_Entries (_object._object'Access);
2297
2298          --  _object is the record used to implement the protected object.
2299          --  It is a parameter to the protected subprogram.
2300
2301          if Nkind (Specification (N)) = N_Procedure_Specification
2302            and then Has_Entries (Pid)
2303          then
2304             case Corresponding_Runtime_Package (Pid) is
2305                when System_Tasking_Protected_Objects_Entries =>
2306                   Name := New_Reference_To (RTE (RE_Service_Entries), Loc);
2307
2308                when System_Tasking_Protected_Objects_Single_Entry =>
2309                   Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
2310
2311                when others =>
2312                   raise Program_Error;
2313             end case;
2314
2315             Append_To (Stmt,
2316               Make_Procedure_Call_Statement (Loc,
2317                 Name => Name,
2318                 Parameter_Associations => New_List (
2319                   Make_Attribute_Reference (Loc,
2320                     Prefix =>
2321                       Make_Selected_Component (Loc,
2322                         Prefix => New_Reference_To (
2323                           Defining_Identifier (Param), Loc),
2324                         Selector_Name =>
2325                           Make_Identifier (Loc, Name_uObject)),
2326                     Attribute_Name => Name_Unchecked_Access))));
2327
2328          else
2329             --  Unlock (_object._object'Access);
2330
2331             --  object is the record used to implement the protected object.
2332             --  It is a parameter to the protected subprogram.
2333
2334             case Corresponding_Runtime_Package (Pid) is
2335                when System_Tasking_Protected_Objects_Entries =>
2336                   Name := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
2337
2338                when System_Tasking_Protected_Objects_Single_Entry =>
2339                   Name := New_Reference_To (RTE (RE_Unlock_Entry), Loc);
2340
2341                when System_Tasking_Protected_Objects =>
2342                   Name := New_Reference_To (RTE (RE_Unlock), Loc);
2343
2344                when others =>
2345                   raise Program_Error;
2346             end case;
2347
2348             Append_To (Stmt,
2349               Make_Procedure_Call_Statement (Loc,
2350                 Name => Name,
2351                 Parameter_Associations => New_List (
2352                   Make_Attribute_Reference (Loc,
2353                     Prefix =>
2354                       Make_Selected_Component (Loc,
2355                         Prefix =>
2356                           New_Reference_To (Defining_Identifier (Param), Loc),
2357                         Selector_Name =>
2358                           Make_Identifier (Loc, Name_uObject)),
2359                     Attribute_Name => Name_Unchecked_Access))));
2360          end if;
2361
2362          if Abort_Allowed then
2363
2364             --  Abort_Undefer;
2365
2366             Append_To (Stmt,
2367               Make_Procedure_Call_Statement (Loc,
2368                 Name =>
2369                   New_Reference_To (
2370                     RTE (RE_Abort_Undefer), Loc),
2371                 Parameter_Associations => Empty_List));
2372          end if;
2373
2374       elsif Is_Task_Allocation_Block then
2375
2376          --  Add a call to Expunge_Unactivated_Tasks to the cleanup
2377          --  handler of a block created for the dynamic allocation of
2378          --  tasks:
2379
2380          --  Expunge_Unactivated_Tasks (_chain);
2381
2382          --  where _chain is the list of tasks created by the allocator
2383          --  but not yet activated. This list will be empty unless
2384          --  the block completes abnormally.
2385
2386          --  This only applies to dynamically allocated tasks;
2387          --  other unactivated tasks are completed by Complete_Task or
2388          --  Complete_Master.
2389
2390          --  NOTE: This cleanup handler references _chain, a local
2391          --        object.
2392
2393          Append_To (Stmt,
2394            Make_Procedure_Call_Statement (Loc,
2395              Name =>
2396                New_Reference_To (
2397                  RTE (RE_Expunge_Unactivated_Tasks), Loc),
2398              Parameter_Associations => New_List (
2399                New_Reference_To (Activation_Chain_Entity (N), Loc))));
2400
2401       elsif Is_Asynchronous_Call_Block then
2402
2403          --  Add a call to attempt to cancel the asynchronous entry call
2404          --  whenever the block containing the abortable part is exited.
2405
2406          --  NOTE: This cleanup handler references C, a local object
2407
2408          --  Get the argument to the Cancel procedure
2409          Cancel_Param := Entry_Cancel_Parameter (Entity (Identifier (N)));
2410
2411          --  If it is of type Communication_Block, this must be a
2412          --  protected entry call.
2413
2414          if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
2415
2416             Append_To (Stmt,
2417
2418             --  if Enqueued (Cancel_Parameter) then
2419
2420               Make_Implicit_If_Statement (Clean,
2421                 Condition => Make_Function_Call (Loc,
2422                   Name => New_Reference_To (
2423                     RTE (RE_Enqueued), Loc),
2424                   Parameter_Associations => New_List (
2425                     New_Reference_To (Cancel_Param, Loc))),
2426                 Then_Statements => New_List (
2427
2428             --  Cancel_Protected_Entry_Call (Cancel_Param);
2429
2430                   Make_Procedure_Call_Statement (Loc,
2431                     Name => New_Reference_To (
2432                       RTE (RE_Cancel_Protected_Entry_Call), Loc),
2433                     Parameter_Associations => New_List (
2434                       New_Reference_To (Cancel_Param, Loc))))));
2435
2436          --  Asynchronous delay
2437
2438          elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
2439             Append_To (Stmt,
2440               Make_Procedure_Call_Statement (Loc,
2441                 Name => New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc),
2442                 Parameter_Associations => New_List (
2443                   Make_Attribute_Reference (Loc,
2444                     Prefix => New_Reference_To (Cancel_Param, Loc),
2445                     Attribute_Name => Name_Unchecked_Access))));
2446
2447          --  Task entry call
2448
2449          else
2450             --  Append call to Cancel_Task_Entry_Call (C);
2451
2452             Append_To (Stmt,
2453               Make_Procedure_Call_Statement (Loc,
2454                 Name => New_Reference_To (
2455                   RTE (RE_Cancel_Task_Entry_Call),
2456                   Loc),
2457                 Parameter_Associations => New_List (
2458                   New_Reference_To (Cancel_Param, Loc))));
2459
2460          end if;
2461       end if;
2462
2463       if Present (Flist) then
2464          Append_To (Stmt,
2465            Make_Procedure_Call_Statement (Loc,
2466              Name => New_Reference_To (RTE (RE_Finalize_List), Loc),
2467              Parameter_Associations => New_List (
2468                     New_Reference_To (Flist, Loc))));
2469       end if;
2470
2471       if Present (Mark) then
2472          Append_To (Stmt,
2473            Make_Procedure_Call_Statement (Loc,
2474              Name => New_Reference_To (RTE (RE_SS_Release), Loc),
2475              Parameter_Associations => New_List (
2476                     New_Reference_To (Mark, Loc))));
2477       end if;
2478
2479       Sbody :=
2480         Make_Subprogram_Body (Loc,
2481           Specification =>
2482             Make_Procedure_Specification (Loc,
2483               Defining_Unit_Name => Clean),
2484
2485           Declarations  => New_List,
2486
2487           Handled_Statement_Sequence =>
2488             Make_Handled_Sequence_Of_Statements (Loc,
2489               Statements => Stmt));
2490
2491       if Present (Flist) or else Is_Task or else Is_Master then
2492          Wrap_Cleanup_Procedure (Sbody);
2493       end if;
2494
2495       --  We do not want debug information for _Clean routines,
2496       --  since it just confuses the debugging operation unless
2497       --  we are debugging generated code.
2498
2499       if not Debug_Generated_Code then
2500          Set_Debug_Info_Off (Clean, True);
2501       end if;
2502
2503       return Sbody;
2504    end Make_Clean;
2505
2506    --------------------------
2507    -- Make_Deep_Array_Body --
2508    --------------------------
2509
2510    --  Array components are initialized and adjusted in the normal order
2511    --  and finalized in the reverse order. Exceptions are handled and
2512    --  Program_Error is re-raise in the Adjust and Finalize case
2513    --  (RM 7.6.1(12)). Generate the following code :
2514    --
2515    --  procedure Deep_<P>   --  with <P> being Initialize or Adjust or Finalize
2516    --   (L : in out Finalizable_Ptr;
2517    --    V : in out Typ)
2518    --  is
2519    --  begin
2520    --     for J1 in             Typ'First (1) .. Typ'Last (1) loop
2521    --               ^ reverse ^  --  in the finalization case
2522    --        ...
2523    --           for J2 in Typ'First (n) .. Typ'Last (n) loop
2524    --                 Make_<P>_Call (Typ, V (J1, .. , Jn), L, V);
2525    --           end loop;
2526    --        ...
2527    --     end loop;
2528    --  exception                                --  not in the
2529    --     when others => raise Program_Error;   --     Initialize case
2530    --  end Deep_<P>;
2531
2532    function Make_Deep_Array_Body
2533      (Prim : Final_Primitives;
2534       Typ  : Entity_Id) return List_Id
2535    is
2536       Loc : constant Source_Ptr := Sloc (Typ);
2537
2538       Index_List : constant List_Id := New_List;
2539       --  Stores the list of references to the indexes (one per dimension)
2540
2541       function One_Component return List_Id;
2542       --  Create one statement to initialize/adjust/finalize one array
2543       --  component, designated by a full set of indices.
2544
2545       function One_Dimension (N : Int) return List_Id;
2546       --  Create loop to deal with one dimension of the array. The single
2547       --  statement in the body of the loop initializes the inner dimensions if
2548       --  any, or else a single component.
2549
2550       -------------------
2551       -- One_Component --
2552       -------------------
2553
2554       function One_Component return List_Id is
2555          Comp_Typ : constant Entity_Id := Component_Type (Typ);
2556          Comp_Ref : constant Node_Id :=
2557                       Make_Indexed_Component (Loc,
2558                         Prefix      => Make_Identifier (Loc, Name_V),
2559                         Expressions => Index_List);
2560
2561       begin
2562          --  Set the etype of the component Reference, which is used to
2563          --  determine whether a conversion to a parent type is needed.
2564
2565          Set_Etype (Comp_Ref, Comp_Typ);
2566
2567          case Prim is
2568             when Initialize_Case =>
2569                return Make_Init_Call (Comp_Ref, Comp_Typ,
2570                         Make_Identifier (Loc, Name_L),
2571                         Make_Identifier (Loc, Name_B));
2572
2573             when Adjust_Case =>
2574                return Make_Adjust_Call (Comp_Ref, Comp_Typ,
2575                         Make_Identifier (Loc, Name_L),
2576                         Make_Identifier (Loc, Name_B));
2577
2578             when Finalize_Case =>
2579                return Make_Final_Call (Comp_Ref, Comp_Typ,
2580                         Make_Identifier (Loc, Name_B));
2581          end case;
2582       end One_Component;
2583
2584       -------------------
2585       -- One_Dimension --
2586       -------------------
2587
2588       function One_Dimension (N : Int) return List_Id is
2589          Index : Entity_Id;
2590
2591       begin
2592          if N > Number_Dimensions (Typ) then
2593             return One_Component;
2594
2595          else
2596             Index :=
2597               Make_Defining_Identifier (Loc, New_External_Name ('J', N));
2598
2599             Append_To (Index_List, New_Reference_To (Index, Loc));
2600
2601             return New_List (
2602               Make_Implicit_Loop_Statement (Typ,
2603                 Identifier => Empty,
2604                 Iteration_Scheme =>
2605                   Make_Iteration_Scheme (Loc,
2606                     Loop_Parameter_Specification =>
2607                       Make_Loop_Parameter_Specification (Loc,
2608                         Defining_Identifier => Index,
2609                         Discrete_Subtype_Definition =>
2610                           Make_Attribute_Reference (Loc,
2611                             Prefix => Make_Identifier (Loc, Name_V),
2612                             Attribute_Name  => Name_Range,
2613                             Expressions => New_List (
2614                               Make_Integer_Literal (Loc, N))),
2615                         Reverse_Present => Prim = Finalize_Case)),
2616                 Statements => One_Dimension (N + 1)));
2617          end if;
2618       end One_Dimension;
2619
2620    --  Start of processing for Make_Deep_Array_Body
2621
2622    begin
2623       return One_Dimension (1);
2624    end Make_Deep_Array_Body;
2625
2626    --------------------
2627    -- Make_Deep_Proc --
2628    --------------------
2629
2630    --  Generate:
2631    --    procedure DEEP_<prim>
2632    --      (L : IN OUT Finalizable_Ptr;    -- not for Finalize
2633    --       V : IN OUT <typ>;
2634    --       B : IN Short_Short_Integer) is
2635    --    begin
2636    --       <stmts>;
2637    --    exception                   --  Finalize and Adjust Cases only
2638    --       raise Program_Error;     --  idem
2639    --    end DEEP_<prim>;
2640
2641    function Make_Deep_Proc
2642      (Prim  : Final_Primitives;
2643       Typ   : Entity_Id;
2644       Stmts : List_Id) return Entity_Id
2645    is
2646       Loc       : constant Source_Ptr := Sloc (Typ);
2647       Formals   : List_Id;
2648       Proc_Name : Entity_Id;
2649       Handler   : List_Id := No_List;
2650       Type_B    : Entity_Id;
2651
2652    begin
2653       if Prim = Finalize_Case then
2654          Formals := New_List;
2655          Type_B := Standard_Boolean;
2656
2657       else
2658          Formals := New_List (
2659            Make_Parameter_Specification (Loc,
2660              Defining_Identifier => Make_Defining_Identifier (Loc, Name_L),
2661              In_Present          => True,
2662              Out_Present         => True,
2663              Parameter_Type      =>
2664                New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
2665          Type_B := Standard_Short_Short_Integer;
2666       end if;
2667
2668       Append_To (Formals,
2669         Make_Parameter_Specification (Loc,
2670           Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
2671           In_Present          => True,
2672           Out_Present         => True,
2673           Parameter_Type      => New_Reference_To (Typ, Loc)));
2674
2675       Append_To (Formals,
2676         Make_Parameter_Specification (Loc,
2677           Defining_Identifier => Make_Defining_Identifier (Loc, Name_B),
2678           Parameter_Type      => New_Reference_To (Type_B, Loc)));
2679
2680       if Prim = Finalize_Case or else Prim = Adjust_Case then
2681          Handler := New_List (Make_Handler_For_Ctrl_Operation (Loc));
2682       end if;
2683
2684       Proc_Name :=
2685         Make_Defining_Identifier (Loc,
2686           Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
2687
2688       Discard_Node (
2689         Make_Subprogram_Body (Loc,
2690           Specification =>
2691             Make_Procedure_Specification (Loc,
2692               Defining_Unit_Name       => Proc_Name,
2693               Parameter_Specifications => Formals),
2694
2695           Declarations =>  Empty_List,
2696           Handled_Statement_Sequence =>
2697             Make_Handled_Sequence_Of_Statements (Loc,
2698               Statements         => Stmts,
2699               Exception_Handlers => Handler)));
2700
2701       return Proc_Name;
2702    end Make_Deep_Proc;
2703
2704    ---------------------------
2705    -- Make_Deep_Record_Body --
2706    ---------------------------
2707
2708    --  The Deep procedures call the appropriate Controlling proc on the
2709    --  the controller component. In the init case, it also attach the
2710    --  controller to the current finalization list.
2711
2712    function Make_Deep_Record_Body
2713      (Prim : Final_Primitives;
2714       Typ  : Entity_Id) return List_Id
2715    is
2716       Loc            : constant Source_Ptr := Sloc (Typ);
2717       Controller_Typ : Entity_Id;
2718       Obj_Ref        : constant Node_Id := Make_Identifier (Loc, Name_V);
2719       Controller_Ref : constant Node_Id :=
2720                          Make_Selected_Component (Loc,
2721                            Prefix        => Obj_Ref,
2722                            Selector_Name =>
2723                              Make_Identifier (Loc, Name_uController));
2724       Res            : constant List_Id := New_List;
2725
2726    begin
2727       if Is_Inherently_Limited_Type (Typ) then
2728          Controller_Typ := RTE (RE_Limited_Record_Controller);
2729       else
2730          Controller_Typ := RTE (RE_Record_Controller);
2731       end if;
2732
2733       case Prim is
2734          when Initialize_Case =>
2735             Append_List_To (Res,
2736               Make_Init_Call (
2737                 Ref          => Controller_Ref,
2738                 Typ          => Controller_Typ,
2739                 Flist_Ref    => Make_Identifier (Loc, Name_L),
2740                 With_Attach  => Make_Identifier (Loc, Name_B)));
2741
2742             --  When the type is also a controlled type by itself,
2743             --  Initialize it and attach it to the finalization chain
2744
2745             if Is_Controlled (Typ) then
2746                Append_To (Res,
2747                  Make_Procedure_Call_Statement (Loc,
2748                    Name => New_Reference_To (
2749                      Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
2750                    Parameter_Associations =>
2751                      New_List (New_Copy_Tree (Obj_Ref))));
2752
2753                Append_To (Res, Make_Attach_Call (
2754                  Obj_Ref      => New_Copy_Tree (Obj_Ref),
2755                  Flist_Ref    => Make_Identifier (Loc, Name_L),
2756                  With_Attach => Make_Identifier (Loc, Name_B)));
2757             end if;
2758
2759          when Adjust_Case =>
2760             Append_List_To (Res,
2761               Make_Adjust_Call (Controller_Ref, Controller_Typ,
2762                 Make_Identifier (Loc, Name_L),
2763                 Make_Identifier (Loc, Name_B)));
2764
2765             --  When the type is also a controlled type by itself,
2766             --  Adjust it it and attach it to the finalization chain
2767
2768             if Is_Controlled (Typ) then
2769                Append_To (Res,
2770                  Make_Procedure_Call_Statement (Loc,
2771                    Name => New_Reference_To (
2772                      Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
2773                    Parameter_Associations =>
2774                      New_List (New_Copy_Tree (Obj_Ref))));
2775
2776                Append_To (Res, Make_Attach_Call (
2777                  Obj_Ref      => New_Copy_Tree (Obj_Ref),
2778                  Flist_Ref    => Make_Identifier (Loc, Name_L),
2779                  With_Attach => Make_Identifier (Loc, Name_B)));
2780             end if;
2781
2782          when Finalize_Case =>
2783             if Is_Controlled (Typ) then
2784                Append_To (Res,
2785                  Make_Implicit_If_Statement (Obj_Ref,
2786                    Condition => Make_Identifier (Loc, Name_B),
2787                    Then_Statements => New_List (
2788                      Make_Procedure_Call_Statement (Loc,
2789                        Name => New_Reference_To (RTE (RE_Finalize_One), Loc),
2790                        Parameter_Associations => New_List (
2791                          OK_Convert_To (RTE (RE_Finalizable),
2792                            New_Copy_Tree (Obj_Ref))))),
2793
2794                    Else_Statements => New_List (
2795                      Make_Procedure_Call_Statement (Loc,
2796                        Name => New_Reference_To (
2797                          Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
2798                        Parameter_Associations =>
2799                         New_List (New_Copy_Tree (Obj_Ref))))));
2800             end if;
2801
2802             Append_List_To (Res,
2803               Make_Final_Call (Controller_Ref, Controller_Typ,
2804                 Make_Identifier (Loc, Name_B)));
2805       end case;
2806       return Res;
2807    end Make_Deep_Record_Body;
2808
2809    ----------------------
2810    -- Make_Final_Call --
2811    ----------------------
2812
2813    function Make_Final_Call
2814      (Ref         : Node_Id;
2815       Typ         : Entity_Id;
2816       With_Detach : Node_Id) return List_Id
2817    is
2818       Loc   : constant Source_Ptr := Sloc (Ref);
2819       Res   : constant List_Id    := New_List;
2820       Cref  : Node_Id;
2821       Cref2 : Node_Id;
2822       Proc  : Entity_Id;
2823       Utyp  : Entity_Id;
2824
2825    begin
2826       if Is_Class_Wide_Type (Typ) then
2827          Utyp := Root_Type (Typ);
2828          Cref := Ref;
2829
2830       elsif Is_Concurrent_Type (Typ) then
2831          Utyp := Corresponding_Record_Type (Typ);
2832          Cref := Convert_Concurrent (Ref, Typ);
2833
2834       elsif Is_Private_Type (Typ)
2835         and then Present (Full_View (Typ))
2836         and then Is_Concurrent_Type (Full_View (Typ))
2837       then
2838          Utyp := Corresponding_Record_Type (Full_View (Typ));
2839          Cref := Convert_Concurrent (Ref, Full_View (Typ));
2840       else
2841          Utyp := Typ;
2842          Cref := Ref;
2843       end if;
2844
2845       Utyp := Underlying_Type (Base_Type (Utyp));
2846       Set_Assignment_OK (Cref);
2847
2848       --  Deal with non-tagged derivation of private views. If the parent is
2849       --  now known to be protected, the finalization routine is the one
2850       --  defined on the corresponding record of the ancestor (corresponding
2851       --  records do not automatically inherit operations, but maybe they
2852       --  should???)
2853
2854       if Is_Untagged_Derivation (Typ) then
2855          if Is_Protected_Type (Typ) then
2856             Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
2857          else
2858             Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
2859          end if;
2860
2861          Cref := Unchecked_Convert_To (Utyp, Cref);
2862
2863          --  We need to set Assignment_OK to prevent problems with unchecked
2864          --  conversions, where we do not want them to be converted back in the
2865          --  case of untagged record derivation (see code in Make_*_Call
2866          --  procedures for similar situations).
2867
2868          Set_Assignment_OK (Cref);
2869       end if;
2870
2871       --  If the underlying_type is a subtype, we are dealing with
2872       --  the completion of a private type. We need to access
2873       --  the base type and generate a conversion to it.
2874
2875       if Utyp /= Base_Type (Utyp) then
2876          pragma Assert (Is_Private_Type (Typ));
2877          Utyp := Base_Type (Utyp);
2878          Cref := Unchecked_Convert_To (Utyp, Cref);
2879       end if;
2880
2881       --  Generate:
2882       --    Deep_Finalize (Ref, With_Detach);
2883
2884       if Has_Controlled_Component (Utyp)
2885         or else Is_Class_Wide_Type (Typ)
2886       then
2887          if Is_Tagged_Type (Utyp) then
2888             Proc := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
2889          else
2890             Proc := TSS (Utyp, TSS_Deep_Finalize);
2891          end if;
2892
2893          Cref := Convert_View (Proc, Cref);
2894
2895          Append_To (Res,
2896            Make_Procedure_Call_Statement (Loc,
2897              Name => New_Reference_To (Proc, Loc),
2898              Parameter_Associations =>
2899                New_List (Cref, With_Detach)));
2900
2901       --  Generate:
2902       --    if With_Detach then
2903       --       Finalize_One (Ref);
2904       --    else
2905       --       Finalize (Ref);
2906       --    end if;
2907
2908       else
2909          Proc := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
2910
2911          if Chars (With_Detach) = Chars (Standard_True) then
2912             Append_To (Res,
2913               Make_Procedure_Call_Statement (Loc,
2914                 Name => New_Reference_To (RTE (RE_Finalize_One), Loc),
2915                 Parameter_Associations => New_List (
2916                   OK_Convert_To (RTE (RE_Finalizable), Cref))));
2917
2918          elsif Chars (With_Detach) = Chars (Standard_False) then
2919             Append_To (Res,
2920               Make_Procedure_Call_Statement (Loc,
2921                 Name => New_Reference_To (Proc, Loc),
2922                 Parameter_Associations =>
2923                   New_List (Convert_View (Proc, Cref))));
2924
2925          else
2926             Cref2 := New_Copy_Tree (Cref);
2927             Append_To (Res,
2928               Make_Implicit_If_Statement (Ref,
2929                 Condition => With_Detach,
2930                 Then_Statements => New_List (
2931                   Make_Procedure_Call_Statement (Loc,
2932                     Name => New_Reference_To (RTE (RE_Finalize_One), Loc),
2933                     Parameter_Associations => New_List (
2934                       OK_Convert_To (RTE (RE_Finalizable), Cref)))),
2935
2936                 Else_Statements => New_List (
2937                   Make_Procedure_Call_Statement (Loc,
2938                     Name => New_Reference_To (Proc, Loc),
2939                     Parameter_Associations =>
2940                       New_List (Convert_View (Proc, Cref2))))));
2941          end if;
2942       end if;
2943
2944       return Res;
2945    end Make_Final_Call;
2946
2947    -------------------------------------
2948    -- Make_Handler_For_Ctrl_Operation --
2949    -------------------------------------
2950
2951    --  Generate:
2952
2953    --    when E : others =>
2954    --      Raise_From_Controlled_Operation (X => E);
2955
2956    --  or:
2957
2958    --    when others =>
2959    --      raise Program_Error [finalize raised exception];
2960
2961    --  depending on whether Raise_From_Controlled_Operation is available
2962
2963    function Make_Handler_For_Ctrl_Operation
2964      (Loc : Source_Ptr) return Node_Id
2965    is
2966       E_Occ : Entity_Id;
2967       --  Choice parameter (for the first case above)
2968
2969       Raise_Node : Node_Id;
2970       --  Procedure call or raise statement
2971
2972    begin
2973       if RTE_Available (RE_Raise_From_Controlled_Operation) then
2974
2975          --  Standard runtime: add choice parameter E, and pass it to
2976          --  Raise_From_Controlled_Operation so that the original exception
2977          --  name and message can be recorded in the exception message for
2978          --  Program_Error.
2979
2980          E_Occ := Make_Defining_Identifier (Loc, Name_E);
2981          Raise_Node := Make_Procedure_Call_Statement (Loc,
2982                          Name =>
2983                            New_Occurrence_Of (
2984                              RTE (RE_Raise_From_Controlled_Operation), Loc),
2985                          Parameter_Associations => New_List (
2986                            New_Occurrence_Of (E_Occ, Loc)));
2987
2988       else
2989          --  Restricted runtime: exception messages are not supported
2990
2991          E_Occ := Empty;
2992          Raise_Node := Make_Raise_Program_Error (Loc,
2993                          Reason => PE_Finalize_Raised_Exception);
2994       end if;
2995
2996       return Make_Implicit_Exception_Handler (Loc,
2997                Exception_Choices => New_List (Make_Others_Choice (Loc)),
2998                Choice_Parameter  => E_Occ,
2999                Statements        => New_List (Raise_Node));
3000    end Make_Handler_For_Ctrl_Operation;
3001
3002    --------------------
3003    -- Make_Init_Call --
3004    --------------------
3005
3006    function Make_Init_Call
3007      (Ref          : Node_Id;
3008       Typ          : Entity_Id;
3009       Flist_Ref    : Node_Id;
3010       With_Attach  : Node_Id) return List_Id
3011    is
3012       Loc     : constant Source_Ptr := Sloc (Ref);
3013       Is_Conc : Boolean;
3014       Res     : constant List_Id := New_List;
3015       Proc    : Entity_Id;
3016       Utyp    : Entity_Id;
3017       Cref    : Node_Id;
3018       Cref2   : Node_Id;
3019       Attach  : Node_Id := With_Attach;
3020
3021    begin
3022       if Is_Concurrent_Type (Typ) then
3023          Is_Conc := True;
3024          Utyp    := Corresponding_Record_Type (Typ);
3025          Cref    := Convert_Concurrent (Ref, Typ);
3026
3027       elsif Is_Private_Type (Typ)
3028         and then Present (Full_View (Typ))
3029         and then Is_Concurrent_Type (Underlying_Type (Typ))
3030       then
3031          Is_Conc := True;
3032          Utyp    := Corresponding_Record_Type (Underlying_Type (Typ));
3033          Cref    := Convert_Concurrent (Ref, Underlying_Type (Typ));
3034
3035       else
3036          Is_Conc := False;
3037          Utyp    := Typ;
3038          Cref    := Ref;
3039       end if;
3040
3041       Utyp := Underlying_Type (Base_Type (Utyp));
3042
3043       Set_Assignment_OK (Cref);
3044
3045       --  Deal with non-tagged derivation of private views
3046
3047       if Is_Untagged_Derivation (Typ)
3048         and then not Is_Conc
3049       then
3050          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
3051          Cref := Unchecked_Convert_To (Utyp, Cref);
3052          Set_Assignment_OK (Cref);
3053          --  To prevent problems with UC see 1.156 RH ???
3054       end if;
3055
3056       --  If the underlying_type is a subtype, we are dealing with
3057       --  the completion of a private type. We need to access
3058       --  the base type and generate a conversion to it.
3059
3060       if Utyp /= Base_Type (Utyp) then
3061          pragma Assert (Is_Private_Type (Typ));
3062          Utyp := Base_Type (Utyp);
3063          Cref := Unchecked_Convert_To (Utyp, Cref);
3064       end if;
3065
3066       --  We do not need to attach to one of the Global Final Lists
3067       --  the objects whose type is Finalize_Storage_Only
3068
3069       if Finalize_Storage_Only (Typ)
3070         and then (Global_Flist_Ref (Flist_Ref)
3071           or else Entity (Constant_Value (RTE (RE_Garbage_Collected)))
3072                   = Standard_True)
3073       then
3074          Attach := Make_Integer_Literal (Loc, 0);
3075       end if;
3076
3077       --  Generate:
3078       --    Deep_Initialize (Ref, Flist_Ref);
3079
3080       if Has_Controlled_Component (Utyp) then
3081          Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
3082
3083          Cref := Convert_View (Proc, Cref, 2);
3084
3085          Append_To (Res,
3086            Make_Procedure_Call_Statement (Loc,
3087              Name => New_Reference_To (Proc, Loc),
3088              Parameter_Associations => New_List (
3089                Node1 => Flist_Ref,
3090                Node2 => Cref,
3091                Node3 => Attach)));
3092
3093       --  Generate:
3094       --    Attach_To_Final_List (Ref, Flist_Ref);
3095       --    Initialize (Ref);
3096
3097       else -- Is_Controlled (Utyp)
3098          Proc  := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
3099          Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Cref);
3100
3101          Cref  := Convert_View (Proc, Cref);
3102          Cref2 := New_Copy_Tree (Cref);
3103
3104          Append_To (Res,
3105            Make_Procedure_Call_Statement (Loc,
3106            Name => New_Reference_To (Proc, Loc),
3107            Parameter_Associations => New_List (Cref2)));
3108
3109          Append_To (Res,
3110            Make_Attach_Call (Cref, Flist_Ref, Attach));
3111       end if;
3112
3113       return Res;
3114    end Make_Init_Call;
3115
3116    --------------------------
3117    -- Make_Transient_Block --
3118    --------------------------
3119
3120    --  If finalization is involved, this function just wraps the instruction
3121    --  into a block whose name is the transient block entity, and then
3122    --  Expand_Cleanup_Actions (called on the expansion of the handled
3123    --  sequence of statements will do the necessary expansions for
3124    --  cleanups).
3125
3126    function Make_Transient_Block
3127      (Loc    : Source_Ptr;
3128       Action : Node_Id) return Node_Id
3129    is
3130       Flist  : constant Entity_Id := Finalization_Chain_Entity (Current_Scope);
3131       Decls  : constant List_Id   := New_List;
3132       Par    : constant Node_Id   := Parent (Action);
3133       Instrs : constant List_Id   := New_List (Action);
3134       Blk    : Node_Id;
3135
3136    begin
3137       --  Case where only secondary stack use is involved
3138
3139       if VM_Target = No_VM
3140         and then Uses_Sec_Stack (Current_Scope)
3141         and then No (Flist)
3142         and then Nkind (Action) /= N_Simple_Return_Statement
3143         and then Nkind (Par) /= N_Exception_Handler
3144       then
3145
3146          declare
3147             S  : Entity_Id;
3148             K  : Entity_Kind;
3149          begin
3150             S := Scope (Current_Scope);
3151             loop
3152                K := Ekind (S);
3153
3154                --  At the outer level, no need to release the sec stack
3155
3156                if S = Standard_Standard then
3157                   Set_Uses_Sec_Stack (Current_Scope, False);
3158                   exit;
3159
3160                --  In a function, only release the sec stack if the
3161                --  function does not return on the sec stack otherwise
3162                --  the result may be lost. The caller is responsible for
3163                --  releasing.
3164
3165                elsif K = E_Function then
3166                   Set_Uses_Sec_Stack (Current_Scope, False);
3167
3168                   if not Requires_Transient_Scope (Etype (S)) then
3169                      Set_Uses_Sec_Stack (S, True);
3170                      Check_Restriction (No_Secondary_Stack, Action);
3171                   end if;
3172
3173                   exit;
3174
3175                --  In a loop or entry we should install a block encompassing
3176                --  all the construct. For now just release right away.
3177
3178                elsif K = E_Loop or else K = E_Entry then
3179                   exit;
3180
3181                --  In a procedure or a block, we release on exit of the
3182                --  procedure or block. ??? memory leak can be created by
3183                --  recursive calls.
3184
3185                elsif K = E_Procedure
3186                  or else K = E_Block
3187                then
3188                   Set_Uses_Sec_Stack (S, True);
3189                   Check_Restriction (No_Secondary_Stack, Action);
3190                   Set_Uses_Sec_Stack (Current_Scope, False);
3191                   exit;
3192
3193                else
3194                   S := Scope (S);
3195                end if;
3196             end loop;
3197          end;
3198       end if;
3199
3200       --  Insert actions stuck in the transient scopes as well as all
3201       --  freezing nodes needed by those actions
3202
3203       Insert_Actions_In_Scope_Around (Action);
3204
3205       declare
3206          Last_Inserted : Node_Id := Prev (Action);
3207       begin
3208          if Present (Last_Inserted) then
3209             Freeze_All (First_Entity (Current_Scope), Last_Inserted);
3210          end if;
3211       end;
3212
3213       Blk :=
3214         Make_Block_Statement (Loc,
3215           Identifier => New_Reference_To (Current_Scope, Loc),
3216           Declarations => Decls,
3217           Handled_Statement_Sequence =>
3218             Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
3219           Has_Created_Identifier => True);
3220
3221       --  When the transient scope was established, we pushed the entry for
3222       --  the transient scope onto the scope stack, so that the scope was
3223       --  active for the installation of finalizable entities etc. Now we
3224       --  must remove this entry, since we have constructed a proper block.
3225
3226       Pop_Scope;
3227
3228       return Blk;
3229    end Make_Transient_Block;
3230
3231    ------------------------
3232    -- Node_To_Be_Wrapped --
3233    ------------------------
3234
3235    function Node_To_Be_Wrapped return Node_Id is
3236    begin
3237       return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
3238    end Node_To_Be_Wrapped;
3239
3240    ----------------------------
3241    -- Set_Node_To_Be_Wrapped --
3242    ----------------------------
3243
3244    procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
3245    begin
3246       Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
3247    end Set_Node_To_Be_Wrapped;
3248
3249    ----------------------------------
3250    -- Store_After_Actions_In_Scope --
3251    ----------------------------------
3252
3253    procedure Store_After_Actions_In_Scope (L : List_Id) is
3254       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
3255
3256    begin
3257       if Present (SE.Actions_To_Be_Wrapped_After) then
3258          Insert_List_Before_And_Analyze (
3259           First (SE.Actions_To_Be_Wrapped_After), L);
3260
3261       else
3262          SE.Actions_To_Be_Wrapped_After := L;
3263
3264          if Is_List_Member (SE.Node_To_Be_Wrapped) then
3265             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
3266          else
3267             Set_Parent (L, SE.Node_To_Be_Wrapped);
3268          end if;
3269
3270          Analyze_List (L);
3271       end if;
3272    end Store_After_Actions_In_Scope;
3273
3274    -----------------------------------
3275    -- Store_Before_Actions_In_Scope --
3276    -----------------------------------
3277
3278    procedure Store_Before_Actions_In_Scope (L : List_Id) is
3279       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
3280
3281    begin
3282       if Present (SE.Actions_To_Be_Wrapped_Before) then
3283          Insert_List_After_And_Analyze (
3284            Last (SE.Actions_To_Be_Wrapped_Before), L);
3285
3286       else
3287          SE.Actions_To_Be_Wrapped_Before := L;
3288
3289          if Is_List_Member (SE.Node_To_Be_Wrapped) then
3290             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
3291          else
3292             Set_Parent (L, SE.Node_To_Be_Wrapped);
3293          end if;
3294
3295          Analyze_List (L);
3296       end if;
3297    end Store_Before_Actions_In_Scope;
3298
3299    --------------------------------
3300    -- Wrap_Transient_Declaration --
3301    --------------------------------
3302
3303    --  If a transient scope has been established during the processing of the
3304    --  Expression of an Object_Declaration, it is not possible to wrap the
3305    --  declaration into a transient block as usual case, otherwise the object
3306    --  would be itself declared in the wrong scope. Therefore, all entities (if
3307    --  any) defined in the transient block are moved to the proper enclosing
3308    --  scope, furthermore, if they are controlled variables they are finalized
3309    --  right after the declaration. The finalization list of the transient
3310    --  scope is defined as a renaming of the enclosing one so during their
3311    --  initialization they will be attached to the proper finalization
3312    --  list. For instance, the following declaration :
3313
3314    --        X : Typ := F (G (A), G (B));
3315
3316    --  (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
3317    --  is expanded into :
3318
3319    --    _local_final_list_1 : Finalizable_Ptr;
3320    --    X : Typ := [ complex Expression-Action ];
3321    --    Finalize_One(_v1);
3322    --    Finalize_One (_v2);
3323
3324    procedure Wrap_Transient_Declaration (N : Node_Id) is
3325       S           : Entity_Id;
3326       LC          : Entity_Id := Empty;
3327       Nodes       : List_Id;
3328       Loc         : constant Source_Ptr := Sloc (N);
3329       Enclosing_S : Entity_Id;
3330       Uses_SS     : Boolean;
3331       Next_N      : constant Node_Id := Next (N);
3332
3333    begin
3334       S := Current_Scope;
3335       Enclosing_S := Scope (S);
3336
3337       --  Insert Actions kept in the Scope stack
3338
3339       Insert_Actions_In_Scope_Around (N);
3340
3341       --  If the declaration is consuming some secondary stack, mark the
3342       --  Enclosing scope appropriately.
3343
3344       Uses_SS := Uses_Sec_Stack (S);
3345       Pop_Scope;
3346
3347       --  Create a List controller and rename the final list to be its
3348       --  internal final pointer:
3349       --       Lxxx : Simple_List_Controller;
3350       --       Fxxx : Finalizable_Ptr renames Lxxx.F;
3351
3352       if Present (Finalization_Chain_Entity (S)) then
3353          LC := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
3354
3355          Nodes := New_List (
3356            Make_Object_Declaration (Loc,
3357              Defining_Identifier => LC,
3358              Object_Definition   =>
3359                New_Reference_To (RTE (RE_Simple_List_Controller), Loc)),
3360
3361            Make_Object_Renaming_Declaration (Loc,
3362              Defining_Identifier => Finalization_Chain_Entity (S),
3363              Subtype_Mark => New_Reference_To (RTE (RE_Finalizable_Ptr), Loc),
3364              Name =>
3365                Make_Selected_Component (Loc,
3366                  Prefix        => New_Reference_To (LC, Loc),
3367                  Selector_Name => Make_Identifier (Loc, Name_F))));
3368
3369          --  Put the declaration at the beginning of the declaration part
3370          --  to make sure it will be before all other actions that have been
3371          --  inserted before N.
3372
3373          Insert_List_Before_And_Analyze (First (List_Containing (N)), Nodes);
3374
3375          --  Generate the Finalization calls by finalizing the list
3376          --  controller right away. It will be re-finalized on scope
3377          --  exit but it doesn't matter. It cannot be done when the
3378          --  call initializes a renaming object though because in this
3379          --  case, the object becomes a pointer to the temporary and thus
3380          --  increases its life span. Ditto if this is a renaming of a
3381          --  component of an expression (such as a function call). .
3382          --  Note that there is a problem if an actual in the call needs
3383          --  finalization, because in that case the call itself is the master,
3384          --  and the actual should be finalized on return from the call ???
3385
3386          if Nkind (N) = N_Object_Renaming_Declaration
3387            and then Controlled_Type (Etype (Defining_Identifier (N)))
3388          then
3389             null;
3390
3391          elsif Nkind (N) = N_Object_Renaming_Declaration
3392            and then
3393              Nkind_In (Renamed_Object (Defining_Identifier (N)),
3394                        N_Selected_Component,
3395                        N_Indexed_Component)
3396            and then
3397              Controlled_Type
3398                (Etype (Prefix (Renamed_Object (Defining_Identifier (N)))))
3399          then
3400             null;
3401
3402          else
3403             Nodes :=
3404               Make_Final_Call
3405                 (Ref         => New_Reference_To (LC, Loc),
3406                  Typ         => Etype (LC),
3407                  With_Detach => New_Reference_To (Standard_False, Loc));
3408
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;