gcc/ada/exp_ch7.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              E X P _ C H 7                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 --  This package contains virtually all expansion mechanisms related to
  27 --    - controlled types
  28 --    - transient scopes
  29
  30 with Atree;    use Atree;
  31 with Debug;    use Debug;
  32 with Einfo;    use Einfo;
  33 with Errout;   use Errout;
  34 with Exp_Ch9;  use Exp_Ch9;
  35 with Exp_Ch11; use Exp_Ch11;
  36 with Exp_Dbug; use Exp_Dbug;
  37 with Exp_Dist; use Exp_Dist;
  38 with Exp_Disp; use Exp_Disp;
  39 with Exp_Tss;  use Exp_Tss;
  40 with Exp_Util; use Exp_Util;
  41 with Freeze;   use Freeze;
  42 with Lib;      use Lib;
  43 with Nlists;   use Nlists;
  44 with Nmake;    use Nmake;
  45 with Opt;      use Opt;
  46 with Output;   use Output;
  47 with Restrict; use Restrict;
  48 with Rident;   use Rident;
  49 with Rtsfind;  use Rtsfind;
  50 with Sinfo;    use Sinfo;
  51 with Sem;      use Sem;
  52 with Sem_Ch3;  use Sem_Ch3;
  53 with Sem_Ch7;  use Sem_Ch7;
  54 with Sem_Ch8;  use Sem_Ch8;
  55 with Sem_Res;  use Sem_Res;
  56 with Sem_Type; use Sem_Type;
  57 with Sem_Util; use Sem_Util;
  58 with Snames;   use Snames;
  59 with Stand;    use Stand;
  60 with Targparm; use Targparm;
  61 with Tbuild;   use Tbuild;
  62 with Uintp;    use Uintp;
  63
  64 package body Exp_Ch7 is
  65
  66    --------------------------------
  67    -- Transient Scope Management --
  68    --------------------------------
  69
  70    --  A transient scope is created when temporary objects are created by the
  71    --  compiler. These temporary objects are allocated on the secondary stack
  72    --  and the transient scope is responsible for finalizing the object when
  73    --  appropriate and reclaiming the memory at the right time. The temporary
  74    --  objects are generally the objects allocated to store the result of a
  75    --  function returning an unconstrained or a tagged value. Expressions
  76    --  needing to be wrapped in a transient scope (functions calls returning
  77    --  unconstrained or tagged values) may appear in 3 different contexts which
  78    --  lead to 3 different kinds of transient scope expansion:
  79
  80    --   1. In a simple statement (procedure call, assignment, ...). In
  81    --      this case the instruction is wrapped into a transient block.
  82    --      (See Wrap_Transient_Statement for details)
  83
  84    --   2. In an expression of a control structure (test in a IF statement,
  85    --      expression in a CASE statement, ...).
  86    --      (See Wrap_Transient_Expression for details)
  87
  88    --   3. In a expression of an object_declaration. No wrapping is possible
  89    --      here, so the finalization actions, if any are done right after the
  90    --      declaration and the secondary stack deallocation is done in the
  91    --      proper enclosing scope (see Wrap_Transient_Declaration for details)
  92
  93    --  Note about functions returning tagged types: It has been decided to
  94    --  always allocate their result in the secondary stack, even though is not
  95    --  absolutely mandatory when the tagged type is constrained because the
  96    --  caller knows the size of the returned object and thus could allocate the
  97    --  result in the primary stack. An exception to this is when the function
  98    --  builds its result in place, as is done for functions with inherently
  99    --  limited result types for Ada 2005. In that case, certain callers may
 100    --  pass the address of a constrained object as the target object for the
 101    --  function result.
 102
 103    --  By allocating tagged results in the secondary stack a number of
 104    --  implementation difficulties are avoided:
 105
 106    --    - If it is a dispatching function call, the computation of the size of
 107    --      the result is possible but complex from the outside.
 108
 109    --    - If the returned type is controlled, the assignment of the returned
 110    --      value to the anonymous object involves an Adjust, and we have no
 111    --      easy way to access the anonymous object created by the back end.
 112
 113    --    - If the returned type is class-wide, this is an unconstrained type
 114    --      anyway.
 115
 116    --  Furthermore, the small loss in efficiency which is the result of this
 117    --  decision is not such a big deal because functions returning tagged types
 118    --  are not as common in practice compared to functions returning access to
 119    --  a tagged type.
 120
 121    --------------------------------------------------
 122    -- Transient Blocks and Finalization Management --
 123    --------------------------------------------------
 124
 125    function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id;
 126    --  N is a node wich may generate a transient scope. Loop over the
 127    --  parent pointers of N until it find the appropriate node to
 128    --  wrap. It it returns Empty, it means that no transient scope is
 129    --  needed in this context.
 130
 131    function Make_Clean
 132      (N                          : Node_Id;
 133       Clean                      : Entity_Id;
 134       Mark                       : Entity_Id;
 135       Flist                      : Entity_Id;
 136       Is_Task                    : Boolean;
 137       Is_Master                  : Boolean;
 138       Is_Protected_Subprogram    : Boolean;
 139       Is_Task_Allocation_Block   : Boolean;
 140       Is_Asynchronous_Call_Block : Boolean) return Node_Id;
 141    --  Expand a the clean-up procedure for controlled and/or transient
 142    --  block, and/or task master or task body, or blocks used to
 143    --  implement task allocation or asynchronous entry calls, or
 144    --  procedures used to implement protected procedures. Clean is the
 145    --  entity for such a procedure. Mark is the entity for the secondary
 146    --  stack mark, if empty only controlled block clean-up will be
 147    --  performed. Flist is the entity for the local final list, if empty
 148    --  only transient scope clean-up will be performed. The flags
 149    --  Is_Task and Is_Master control the calls to the corresponding
 150    --  finalization actions for a task body or for an entity that is a
 151    --  task master.
 152
 153    procedure Set_Node_To_Be_Wrapped (N : Node_Id);
 154    --  Set the field Node_To_Be_Wrapped of the current scope
 155
 156    procedure Insert_Actions_In_Scope_Around (N : Node_Id);
 157    --  Insert the before-actions kept in the scope stack before N, and the
 158    --  after after-actions, after N which must be a member of a list.
 159
 160    function Make_Transient_Block
 161      (Loc    : Source_Ptr;
 162       Action : Node_Id) return Node_Id;
 163    --  Create a transient block whose name is Scope, which is also a
 164    --  controlled block if Flist is not empty and whose only code is
 165    --  Action (either a single statement or single declaration).
 166
 167    type Final_Primitives is (Initialize_Case, Adjust_Case, Finalize_Case);
 168    --  This enumeration type is defined in order to ease sharing code for
 169    --  building finalization procedures for composite types.
 170
 171    Name_Of      : constant array (Final_Primitives) of Name_Id :=
 172                     (Initialize_Case => Name_Initialize,
 173                      Adjust_Case     => Name_Adjust,
 174                      Finalize_Case   => Name_Finalize);
 175
 176    Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
 177                     (Initialize_Case => TSS_Deep_Initialize,
 178                      Adjust_Case     => TSS_Deep_Adjust,
 179                      Finalize_Case   => TSS_Deep_Finalize);
 180
 181    procedure Build_Record_Deep_Procs (Typ : Entity_Id);
 182    --  Build the deep Initialize/Adjust/Finalize for a record Typ with
 183    --  Has_Component_Component set and store them using the TSS mechanism.
 184
 185    procedure Build_Array_Deep_Procs (Typ : Entity_Id);
 186    --  Build the deep Initialize/Adjust/Finalize for a record Typ with
 187    --  Has_Controlled_Component set and store them using the TSS mechanism.
 188
 189    function Make_Deep_Proc
 190      (Prim  : Final_Primitives;
 191       Typ   : Entity_Id;
 192       Stmts : List_Id) return Node_Id;
 193    --  This function generates the tree for Deep_Initialize, Deep_Adjust
 194    --  or Deep_Finalize procedures according to the first parameter,
 195    --  these procedures operate on the type Typ. The Stmts parameter
 196    --  gives the body of the procedure.
 197
 198    function Make_Deep_Array_Body
 199      (Prim : Final_Primitives;
 200       Typ  : Entity_Id) return List_Id;
 201    --  This function generates the list of statements for implementing
 202    --  Deep_Initialize, Deep_Adjust or Deep_Finalize procedures
 203    --  according to the first parameter, these procedures operate on the
 204    --  array type Typ.
 205
 206    function Make_Deep_Record_Body
 207      (Prim : Final_Primitives;
 208       Typ  : Entity_Id) return List_Id;
 209    --  This function generates the list of statements for implementing
 210    --  Deep_Initialize, Deep_Adjust or Deep_Finalize procedures
 211    --  according to the first parameter, these procedures operate on the
 212    --  record type Typ.
 213
 214    procedure Check_Visibly_Controlled
 215      (Prim : Final_Primitives;
 216       Typ  : Entity_Id;
 217       E    : in out Entity_Id;
 218       Cref : in out Node_Id);
 219    --  The controlled operation declared for a derived type may not be
 220    --  overriding, if the controlled operations of the parent type are
 221    --  hidden, for example when the parent is a private type whose full
 222    --  view is controlled. For other primitive operations we modify the
 223    --  name of the operation to indicate that it is not overriding, but
 224    --  this is not possible for Initialize, etc. because they have to be
 225    --  retrievable by name. Before generating the proper call to one of
 226    --  these operations we check whether Typ is known to be controlled at
 227    --  the point of definition. If it is not then we must retrieve the
 228    --  hidden operation of the parent and use it instead.  This is one
 229    --  case that might be solved more cleanly once Overriding pragmas or
 230    --  declarations are in place.
 231
 232    function Convert_View
 233      (Proc : Entity_Id;
 234       Arg  : Node_Id;
 235       Ind  : Pos := 1) return Node_Id;
 236    --  Proc is one of the Initialize/Adjust/Finalize operations, and
 237    --  Arg is the argument being passed to it. Ind indicates which
 238    --  formal of procedure Proc we are trying to match. This function
 239    --  will, if necessary, generate an conversion between the partial
 240    --  and full view of Arg to match the type of the formal of Proc,
 241    --  or force a conversion to the class-wide type in the case where
 242    --  the operation is abstract.
 243
 244    -----------------------------
 245    -- Finalization Management --
 246    -----------------------------
 247
 248    --  This part describe how Initialization/Adjusment/Finalization procedures
 249    --  are generated and called. Two cases must be considered, types that are
 250    --  Controlled (Is_Controlled flag set) and composite types that contain
 251    --  controlled components (Has_Controlled_Component flag set). In the first
 252    --  case the procedures to call are the user-defined primitive operations
 253    --  Initialize/Adjust/Finalize. In the second case, GNAT generates
 254    --  Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
 255    --  of calling the former procedures on the controlled components.
 256
 257    --  For records with Has_Controlled_Component set, a hidden "controller"
 258    --  component is inserted. This controller component contains its own
 259    --  finalization list on which all controlled components are attached
 260    --  creating an indirection on the upper-level Finalization list. This
 261    --  technique facilitates the management of objects whose number of
 262    --  controlled components changes during execution. This controller
 263    --  component is itself controlled and is attached to the upper-level
 264    --  finalization chain. Its adjust primitive is in charge of calling adjust
 265    --  on the components and adusting the finalization pointer to match their
 266    --  new location (see a-finali.adb).
 267
 268    --  It is not possible to use a similar technique for arrays that have
 269    --  Has_Controlled_Component set. In this case, deep procedures are
 270    --  generated that call initialize/adjust/finalize + attachment or
 271    --  detachment on the finalization list for all component.
 272
 273    --  Initialize calls: they are generated for declarations or dynamic
 274    --  allocations of Controlled objects with no initial value. They are always
 275    --  followed by an attachment to the current Finalization Chain. For the
 276    --  dynamic allocation case this the chain attached to the scope of the
 277    --  access type definition otherwise, this is the chain of the current
 278    --  scope.
 279
 280    --  Adjust Calls: They are generated on 2 occasions: (1) for
 281    --  declarations or dynamic allocations of Controlled objects with an
 282    --  initial value. (2) after an assignment. In the first case they are
 283    --  followed by an attachment to the final chain, in the second case
 284    --  they are not.
 285
 286    --  Finalization Calls: They are generated on (1) scope exit, (2)
 287    --  assignments, (3) unchecked deallocations. In case (3) they have to
 288    --  be detached from the final chain, in case (2) they must not and in
 289    --  case (1) this is not important since we are exiting the scope anyway.
 290
 291    --  Other details:
 292
 293    --    Type extensions will have a new record controller at each derivation
 294    --    level containing controlled components. The record controller for
 295    --    the parent/ancestor is attached to the finalization list of the
 296    --    extension's record controller (i.e. the parent is like a component
 297    --    of the extension).
 298
 299    --    For types that are both Is_Controlled and Has_Controlled_Components,
 300    --    the record controller and the object itself are handled separately.
 301    --    It could seem simpler to attach the object at the end of its record
 302    --    controller but this would not tackle view conversions properly.
 303
 304    --    A classwide type can always potentially have controlled components
 305    --    but the record controller of the corresponding actual type may not
 306    --    be known at compile time so the dispatch table contains a special
 307    --    field that allows to compute the offset of the record controller
 308    --    dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
 309
 310    --  Here is a simple example of the expansion of a controlled block :
 311
 312    --    declare
 313    --       X : Controlled;
 314    --       Y : Controlled := Init;
 315    --
 316    --       type R is record
 317    --          C : Controlled;
 318    --       end record;
 319    --       W : R;
 320    --       Z : R := (C => X);
 321    --    begin
 322    --       X := Y;
 323    --       W := Z;
 324    --    end;
 325    --
 326    --  is expanded into
 327    --
 328    --    declare
 329    --       _L : System.FI.Finalizable_Ptr;
 330
 331    --       procedure _Clean is
 332    --       begin
 333    --          Abort_Defer;
 334    --          System.FI.Finalize_List (_L);
 335    --          Abort_Undefer;
 336    --       end _Clean;
 337
 338    --       X : Controlled;
 339    --       begin
 340    --          Abort_Defer;
 341    --          Initialize (X);
 342    --          Attach_To_Final_List (_L, Finalizable (X), 1);
 343    --       at end: Abort_Undefer;
 344    --       Y : Controlled := Init;
 345    --       Adjust (Y);
 346    --       Attach_To_Final_List (_L, Finalizable (Y), 1);
 347    --
 348    --       type R is record
 349    --         _C : Record_Controller;
 350    --          C : Controlled;
 351    --       end record;
 352    --       W : R;
 353    --       begin
 354    --          Abort_Defer;
 355    --          Deep_Initialize (W, _L, 1);
 356    --       at end: Abort_Under;
 357    --       Z : R := (C => X);
 358    --       Deep_Adjust (Z, _L, 1);
 359
 360    --    begin
 361    --       _Assign (X, Y);
 362    --       Deep_Finalize (W, False);
 363    --       <save W's final pointers>
 364    --       W := Z;
 365    --       <restore W's final pointers>
 366    --       Deep_Adjust (W, _L, 0);
 367    --    at end
 368    --       _Clean;
 369    --    end;
 370
 371    function Global_Flist_Ref (Flist_Ref : Node_Id) return Boolean;
 372    --  Return True if Flist_Ref refers to a global final list, either the
 373    --  object Global_Final_List which is used to attach standalone objects,
 374    --  or any of the list controllers associated with library-level access
 375    --  to controlled objects.
 376
 377    procedure Clean_Simple_Protected_Objects (N : Node_Id);
 378    --  Protected objects without entries are not controlled types, and the
 379    --  locks have to be released explicitly when such an object goes out
 380    --  of scope. Traverse declarations in scope to determine whether such
 381    --  objects are present.
 382
 383    ----------------------------
 384    -- Build_Array_Deep_Procs --
 385    ----------------------------
 386
 387    procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
 388    begin
 389       Set_TSS (Typ,
 390         Make_Deep_Proc (
 391           Prim  => Initialize_Case,
 392           Typ   => Typ,
 393           Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
 394
 395       if not Is_Inherently_Limited_Type (Typ) then
 396          Set_TSS (Typ,
 397            Make_Deep_Proc (
 398              Prim  => Adjust_Case,
 399              Typ   => Typ,
 400              Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
 401       end if;
 402
 403       Set_TSS (Typ,
 404         Make_Deep_Proc (
 405           Prim  => Finalize_Case,
 406           Typ   => Typ,
 407           Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
 408    end Build_Array_Deep_Procs;
 409
 410    -----------------------------
 411    -- Build_Controlling_Procs --
 412    -----------------------------
 413
 414    procedure Build_Controlling_Procs (Typ : Entity_Id) is
 415    begin
 416       if Is_Array_Type (Typ) then
 417          Build_Array_Deep_Procs (Typ);
 418
 419       else pragma Assert (Is_Record_Type (Typ));
 420          Build_Record_Deep_Procs (Typ);
 421       end if;
 422    end Build_Controlling_Procs;
 423
 424    ----------------------
 425    -- Build_Final_List --
 426    ----------------------
 427
 428    procedure Build_Final_List (N : Node_Id; Typ : Entity_Id) is
 429       Loc  : constant Source_Ptr := Sloc (N);
 430       Decl : Node_Id;
 431
 432    begin
 433       Set_Associated_Final_Chain (Typ,
 434         Make_Defining_Identifier (Loc,
 435           New_External_Name (Chars (Typ), 'L')));
 436
 437       Decl :=
 438         Make_Object_Declaration (Loc,
 439           Defining_Identifier =>
 440              Associated_Final_Chain (Typ),
 441           Object_Definition   =>
 442             New_Reference_To
 443               (RTE (RE_List_Controller), Loc));
 444
 445       --  The type may have been frozen already, and this is a late freezing
 446       --  action, in which case the declaration must be elaborated at once.
 447       --  If the call is for an allocator, the chain must also be created now,
 448       --  because the freezing of the type does not build one. Otherwise, the
 449       --  declaration is one of the freezing actions for a user-defined type.
 450
 451       if Is_Frozen (Typ)
 452         or else (Nkind (N) = N_Allocator
 453                   and then Ekind (Etype (N)) = E_Anonymous_Access_Type)
 454       then
 455          Insert_Action (N, Decl);
 456       else
 457          Append_Freeze_Action (Typ, Decl);
 458       end if;
 459    end Build_Final_List;
 460
 461    ---------------------
 462    -- Build_Late_Proc --
 463    ---------------------
 464
 465    procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
 466    begin
 467       for Final_Prim in Name_Of'Range loop
 468          if Name_Of (Final_Prim) = Nam then
 469             Set_TSS (Typ,
 470               Make_Deep_Proc (
 471                 Prim  => Final_Prim,
 472                 Typ   => Typ,
 473                 Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
 474          end if;
 475       end loop;
 476    end Build_Late_Proc;
 477
 478    -----------------------------
 479    -- Build_Record_Deep_Procs --
 480    -----------------------------
 481
 482    procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
 483    begin
 484       Set_TSS (Typ,
 485         Make_Deep_Proc (
 486           Prim  => Initialize_Case,
 487           Typ   => Typ,
 488           Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
 489
 490       if not Is_Inherently_Limited_Type (Typ) then
 491          Set_TSS (Typ,
 492            Make_Deep_Proc (
 493              Prim  => Adjust_Case,
 494              Typ   => Typ,
 495              Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
 496       end if;
 497
 498       Set_TSS (Typ,
 499         Make_Deep_Proc (
 500           Prim  => Finalize_Case,
 501           Typ   => Typ,
 502           Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
 503    end Build_Record_Deep_Procs;
 504
 505    -------------------
 506    -- Cleanup_Array --
 507    -------------------
 508
 509    function Cleanup_Array
 510      (N    : Node_Id;
 511       Obj  : Node_Id;
 512       Typ  : Entity_Id) return List_Id
 513    is
 514       Loc        : constant Source_Ptr := Sloc (N);
 515       Index_List : constant List_Id := New_List;
 516
 517       function Free_Component return List_Id;
 518       --  Generate the code to finalize the task or protected  subcomponents
 519       --  of a single component of the array.
 520
 521       function Free_One_Dimension (Dim : Int) return List_Id;
 522       --  Generate a loop over one dimension of the array
 523
 524       --------------------
 525       -- Free_Component --
 526       --------------------
 527
 528       function Free_Component return List_Id is
 529          Stmts : List_Id := New_List;
 530          Tsk   : Node_Id;
 531          C_Typ : constant Entity_Id := Component_Type (Typ);
 532
 533       begin
 534          --  Component type is known to contain tasks or protected objects
 535
 536          Tsk :=
 537            Make_Indexed_Component (Loc,
 538              Prefix        => Duplicate_Subexpr_No_Checks (Obj),
 539              Expressions   => Index_List);
 540
 541          Set_Etype (Tsk, C_Typ);
 542
 543          if Is_Task_Type (C_Typ) then
 544             Append_To (Stmts, Cleanup_Task (N, Tsk));
 545
 546          elsif Is_Simple_Protected_Type (C_Typ) then
 547             Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
 548
 549          elsif Is_Record_Type (C_Typ) then
 550             Stmts := Cleanup_Record (N, Tsk, C_Typ);
 551
 552          elsif Is_Array_Type (C_Typ) then
 553             Stmts := Cleanup_Array (N, Tsk, C_Typ);
 554          end if;
 555
 556          return Stmts;
 557       end Free_Component;
 558
 559       ------------------------
 560       -- Free_One_Dimension --
 561       ------------------------
 562
 563       function Free_One_Dimension (Dim : Int) return List_Id is
 564          Index      : Entity_Id;
 565
 566       begin
 567          if Dim > Number_Dimensions (Typ) then
 568             return Free_Component;
 569
 570          --  Here we generate the required loop
 571
 572          else
 573             Index :=
 574               Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
 575
 576             Append (New_Reference_To (Index, Loc), Index_List);
 577
 578             return New_List (
 579               Make_Implicit_Loop_Statement (N,
 580                 Identifier => Empty,
 581                 Iteration_Scheme =>
 582                   Make_Iteration_Scheme (Loc,
 583                     Loop_Parameter_Specification =>
 584                       Make_Loop_Parameter_Specification (Loc,
 585                         Defining_Identifier => Index,
 586                         Discrete_Subtype_Definition =>
 587                           Make_Attribute_Reference (Loc,
 588                             Prefix => Duplicate_Subexpr (Obj),
 589                             Attribute_Name  => Name_Range,
 590                             Expressions => New_List (
 591                               Make_Integer_Literal (Loc, Dim))))),
 592                 Statements =>  Free_One_Dimension (Dim + 1)));
 593          end if;
 594       end Free_One_Dimension;
 595
 596    --  Start of processing for Cleanup_Array
 597
 598    begin
 599       return Free_One_Dimension (1);
 600    end Cleanup_Array;
 601
 602    --------------------
 603    -- Cleanup_Record --
 604    --------------------
 605
 606    function Cleanup_Record
 607      (N    : Node_Id;
 608       Obj  : Node_Id;
 609       Typ  : Entity_Id) return List_Id
 610    is
 611       Loc   : constant Source_Ptr := Sloc (N);
 612       Tsk   : Node_Id;
 613       Comp  : Entity_Id;
 614       Stmts : constant List_Id    := New_List;
 615       U_Typ : constant Entity_Id  := Underlying_Type (Typ);
 616
 617    begin
 618       if Has_Discriminants (U_Typ)
 619         and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
 620         and then
 621           Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
 622         and then
 623           Present
 624             (Variant_Part
 625               (Component_List (Type_Definition (Parent (U_Typ)))))
 626       then
 627          --  For now, do not attempt to free a component that may appear in
 628          --  a variant, and instead issue a warning. Doing this "properly"
 629          --  would require building a case statement and would be quite a
 630          --  mess. Note that the RM only requires that free "work" for the
 631          --  case of a task access value, so already we go way beyond this
 632          --  in that we deal with the array case and non-discriminated
 633          --  record cases.
 634
 635          Error_Msg_N
 636            ("task/protected object in variant record will not be freed?", N);
 637          return New_List (Make_Null_Statement (Loc));
 638       end if;
 639
 640       Comp := First_Component (Typ);
 641
 642       while Present (Comp) loop
 643          if Has_Task (Etype (Comp))
 644            or else Has_Simple_Protected_Object (Etype (Comp))
 645          then
 646             Tsk :=
 647               Make_Selected_Component (Loc,
 648                 Prefix        => Duplicate_Subexpr_No_Checks (Obj),
 649                 Selector_Name => New_Occurrence_Of (Comp, Loc));
 650             Set_Etype (Tsk, Etype (Comp));
 651
 652             if Is_Task_Type (Etype (Comp)) then
 653                Append_To (Stmts, Cleanup_Task (N, Tsk));
 654
 655             elsif Is_Simple_Protected_Type (Etype (Comp)) then
 656                Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
 657
 658             elsif Is_Record_Type (Etype (Comp)) then
 659
 660                --  Recurse, by generating the prefix of the argument to
 661                --  the eventual cleanup call.
 662
 663                Append_List_To
 664                  (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
 665
 666             elsif Is_Array_Type (Etype (Comp)) then
 667                Append_List_To
 668                  (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
 669             end if;
 670          end if;
 671
 672          Next_Component (Comp);
 673       end loop;
 674
 675       return Stmts;
 676    end Cleanup_Record;
 677
 678    ------------------------------
 679    -- Cleanup_Protected_Object --
 680    ------------------------------
 681
 682    function Cleanup_Protected_Object
 683      (N   : Node_Id;
 684       Ref : Node_Id) return Node_Id
 685    is
 686       Loc : constant Source_Ptr := Sloc (N);
 687
 688    begin
 689       return
 690         Make_Procedure_Call_Statement (Loc,
 691           Name => New_Reference_To (RTE (RE_Finalize_Protection), Loc),
 692           Parameter_Associations => New_List (
 693             Concurrent_Ref (Ref)));
 694    end Cleanup_Protected_Object;
 695
 696    ------------------------------------
 697    -- Clean_Simple_Protected_Objects --
 698    ------------------------------------
 699
 700    procedure Clean_Simple_Protected_Objects (N : Node_Id) is
 701       Stmts : constant List_Id := Statements (Handled_Statement_Sequence (N));
 702       Stmt  : Node_Id          := Last (Stmts);
 703       E     : Entity_Id;
 704
 705    begin
 706       E := First_Entity (Current_Scope);
 707       while Present (E) loop
 708          if (Ekind (E) = E_Variable
 709               or else Ekind (E) = E_Constant)
 710            and then Has_Simple_Protected_Object (Etype (E))
 711            and then not Has_Task (Etype (E))
 712            and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration
 713          then
 714             declare
 715                Typ : constant Entity_Id := Etype (E);
 716                Ref : constant Node_Id := New_Occurrence_Of (E, Sloc (Stmt));
 717
 718             begin
 719                if Is_Simple_Protected_Type (Typ) then
 720                   Append_To (Stmts, Cleanup_Protected_Object (N, Ref));
 721
 722                elsif Has_Simple_Protected_Object (Typ) then
 723                   if Is_Record_Type (Typ) then
 724                      Append_List_To (Stmts, Cleanup_Record (N, Ref, Typ));
 725
 726                   elsif Is_Array_Type (Typ) then
 727                      Append_List_To (Stmts, Cleanup_Array (N, Ref, Typ));
 728                   end if;
 729                end if;
 730             end;
 731          end if;
 732
 733          Next_Entity (E);
 734       end loop;
 735
 736       --   Analyze inserted cleanup statements
 737
 738       if Present (Stmt) then
 739          Stmt := Next (Stmt);
 740
 741          while Present (Stmt) loop
 742             Analyze (Stmt);
 743             Next (Stmt);
 744          end loop;
 745       end if;
 746    end Clean_Simple_Protected_Objects;
 747
 748    ------------------
 749    -- Cleanup_Task --
 750    ------------------
 751
 752    function Cleanup_Task
 753      (N   : Node_Id;
 754       Ref : Node_Id) return Node_Id
 755    is
 756       Loc  : constant Source_Ptr := Sloc (N);
 757    begin
 758       return
 759         Make_Procedure_Call_Statement (Loc,
 760           Name => New_Reference_To (RTE (RE_Free_Task), Loc),
 761           Parameter_Associations =>
 762             New_List (Concurrent_Ref (Ref)));
 763    end Cleanup_Task;
 764
 765    ---------------------------------
 766    -- Has_Simple_Protected_Object --
 767    ---------------------------------
 768
 769    function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
 770       Comp : Entity_Id;
 771
 772    begin
 773       if Is_Simple_Protected_Type (T) then
 774          return True;
 775
 776       elsif Is_Array_Type (T) then
 777          return Has_Simple_Protected_Object (Component_Type (T));
 778
 779       elsif Is_Record_Type (T) then
 780          Comp := First_Component (T);
 781
 782          while Present (Comp) loop
 783             if Has_Simple_Protected_Object (Etype (Comp)) then
 784                return True;
 785             end if;
 786
 787             Next_Component (Comp);
 788          end loop;
 789
 790          return False;
 791
 792       else
 793          return False;
 794       end if;
 795    end Has_Simple_Protected_Object;
 796
 797    ------------------------------
 798    -- Is_Simple_Protected_Type --
 799    ------------------------------
 800
 801    function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
 802    begin
 803       return Is_Protected_Type (T) and then not Has_Entries (T);
 804    end Is_Simple_Protected_Type;
 805
 806    ------------------------------
 807    -- Check_Visibly_Controlled --
 808    ------------------------------
 809
 810    procedure Check_Visibly_Controlled
 811      (Prim : Final_Primitives;
 812       Typ  : Entity_Id;
 813       E    : in out Entity_Id;
 814       Cref : in out Node_Id)
 815    is
 816       Parent_Type : Entity_Id;
 817       Op          : Entity_Id;
 818
 819    begin
 820       if Is_Derived_Type (Typ)
 821         and then Comes_From_Source (E)
 822         and then not Is_Overriding_Operation (E)
 823       then
 824          --  We know that the explicit operation on the type does not override
 825          --  the inherited operation of the parent, and that the derivation
 826          --  is from a private type that is not visibly controlled.
 827
 828          Parent_Type := Etype (Typ);
 829          Op := Find_Prim_Op (Parent_Type, Name_Of (Prim));
 830
 831          if Present (Op) then
 832             E := Op;
 833
 834             --  Wrap the object to be initialized into the proper
 835             --  unchecked conversion, to be compatible with the operation
 836             --  to be called.
 837
 838             if Nkind (Cref) = N_Unchecked_Type_Conversion then
 839                Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
 840             else
 841                Cref := Unchecked_Convert_To (Parent_Type, Cref);
 842             end if;
 843          end if;
 844       end if;
 845    end Check_Visibly_Controlled;
 846
 847    ---------------------
 848    -- Controlled_Type --
 849    ---------------------
 850
 851    function Controlled_Type (T : Entity_Id) return Boolean is
 852
 853       function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
 854       --  If type is not frozen yet, check explicitly among its components,
 855       --  because flag is not necessarily set.
 856
 857       -----------------------------------
 858       -- Has_Some_Controlled_Component --
 859       -----------------------------------
 860
 861       function Has_Some_Controlled_Component
 862         (Rec : Entity_Id) return Boolean
 863       is
 864          Comp : Entity_Id;
 865
 866       begin
 867          if Has_Controlled_Component (Rec) then
 868             return True;
 869
 870          elsif not Is_Frozen (Rec) then
 871             if Is_Record_Type (Rec) then
 872                Comp := First_Entity (Rec);
 873
 874                while Present (Comp) loop
 875                   if not Is_Type (Comp)
 876                     and then Controlled_Type (Etype (Comp))
 877                   then
 878                      return True;
 879                   end if;
 880
 881                   Next_Entity (Comp);
 882                end loop;
 883
 884                return False;
 885
 886             elsif Is_Array_Type (Rec) then
 887                return Is_Controlled (Component_Type (Rec));
 888
 889             else
 890                return Has_Controlled_Component (Rec);
 891             end if;
 892          else
 893             return False;
 894          end if;
 895       end Has_Some_Controlled_Component;
 896
 897    --  Start of processing for Controlled_Type
 898
 899    begin
 900       --  Class-wide types must be treated as controlled because they may
 901       --  contain an extension that has controlled components
 902
 903       --  We can skip this if finalization is not available
 904
 905       return (Is_Class_Wide_Type (T)
 906                 and then not In_Finalization_Root (T)
 907                 and then not Restriction_Active (No_Finalization))
 908         or else Is_Controlled (T)
 909         or else Has_Some_Controlled_Component (T)
 910         or else (Is_Concurrent_Type (T)
 911                    and then Present (Corresponding_Record_Type (T))
 912                    and then Controlled_Type (Corresponding_Record_Type (T)));
 913    end Controlled_Type;
 914
 915    ---------------------------
 916    -- CW_Or_Controlled_Type --
 917    ---------------------------
 918
 919    function CW_Or_Controlled_Type (T : Entity_Id) return Boolean is
 920    begin
 921       return Is_Class_Wide_Type (T) or else Controlled_Type (T);
 922    end CW_Or_Controlled_Type;
 923
 924    --------------------------
 925    -- Controller_Component --
 926    --------------------------
 927
 928    function Controller_Component (Typ : Entity_Id) return Entity_Id is
 929       T         : Entity_Id := Base_Type (Typ);
 930       Comp      : Entity_Id;
 931       Comp_Scop : Entity_Id;
 932       Res       : Entity_Id := Empty;
 933       Res_Scop  : Entity_Id := Empty;
 934
 935    begin
 936       if Is_Class_Wide_Type (T) then
 937          T := Root_Type (T);
 938       end if;
 939
 940       if Is_Private_Type (T) then
 941          T := Underlying_Type (T);
 942       end if;
 943
 944       --  Fetch the outermost controller
 945
 946       Comp := First_Entity (T);
 947       while Present (Comp) loop
 948          if Chars (Comp) = Name_uController then
 949             Comp_Scop := Scope (Original_Record_Component (Comp));
 950
 951             --  If this controller is at the outermost level, no need to
 952             --  look for another one
 953
 954             if Comp_Scop = T then
 955                return Comp;
 956
 957             --  Otherwise record the outermost one and continue looking
 958
 959             elsif Res = Empty or else Is_Ancestor (Res_Scop, Comp_Scop) then
 960                Res      := Comp;
 961                Res_Scop := Comp_Scop;
 962             end if;
 963          end if;
 964
 965          Next_Entity (Comp);
 966       end loop;
 967
 968       --  If we fall through the loop, there is no controller component
 969
 970       return Res;
 971    end Controller_Component;
 972
 973    ------------------
 974    -- Convert_View --
 975    ------------------
 976
 977    function Convert_View
 978      (Proc : Entity_Id;
 979       Arg  : Node_Id;
 980       Ind  : Pos := 1) return Node_Id
 981    is
 982       Fent : Entity_Id := First_Entity (Proc);
 983       Ftyp : Entity_Id;
 984       Atyp : Entity_Id;
 985
 986    begin
 987       for J in 2 .. Ind loop
 988          Next_Entity (Fent);
 989       end loop;
 990
 991       Ftyp := Etype (Fent);
 992
 993       if Nkind_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 ot 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             if Abort_Allowed
2305               or else Restriction_Active (No_Entry_Queue) = False
2306               or else Number_Entries (Pid) > 1
2307             then
2308                Name := New_Reference_To (RTE (RE_Service_Entries), Loc);
2309             else
2310                Name := New_Reference_To (RTE (RE_Service_Entry), Loc);
2311             end if;
2312
2313             Append_To (Stmt,
2314               Make_Procedure_Call_Statement (Loc,
2315                 Name => Name,
2316                 Parameter_Associations => New_List (
2317                   Make_Attribute_Reference (Loc,
2318                     Prefix =>
2319                       Make_Selected_Component (Loc,
2320                         Prefix => New_Reference_To (
2321                           Defining_Identifier (Param), Loc),
2322                         Selector_Name =>
2323                           Make_Identifier (Loc, Name_uObject)),
2324                     Attribute_Name => Name_Unchecked_Access))));
2325
2326          else
2327             --  Unlock (_object._object'Access);
2328
2329             --  object is the record used to implement the protected object.
2330             --  It is a parameter to the protected subprogram.
2331
2332             --  If the protected object is controlled (i.e it has entries or
2333             --  needs finalization for interrupt handling), call
2334             --  Unlock_Entries, except if the protected object follows the
2335             --  ravenscar profile, in which case call Unlock_Entry, otherwise
2336             --  call the simplified version, Unlock.
2337
2338             if Has_Entries (Pid)
2339               or else Has_Interrupt_Handler (Pid)
2340               or else (Has_Attach_Handler (Pid)
2341                          and then not Restricted_Profile)
2342               or else (Ada_Version >= Ada_05
2343                          and then Present (Interface_List (Parent (Pid))))
2344             then
2345                if Abort_Allowed
2346                  or else Restriction_Active (No_Entry_Queue) = False
2347                  or else Number_Entries (Pid) > 1
2348                then
2349                   Name := New_Reference_To (RTE (RE_Unlock_Entries), Loc);
2350                else
2351                   Name := New_Reference_To (RTE (RE_Unlock_Entry), Loc);
2352                end if;
2353
2354             else
2355                Name := New_Reference_To (RTE (RE_Unlock), Loc);
2356             end if;
2357
2358             Append_To (Stmt,
2359               Make_Procedure_Call_Statement (Loc,
2360                 Name => Name,
2361                 Parameter_Associations => New_List (
2362                   Make_Attribute_Reference (Loc,
2363                     Prefix =>
2364                       Make_Selected_Component (Loc,
2365                         Prefix =>
2366                           New_Reference_To (Defining_Identifier (Param), Loc),
2367                         Selector_Name =>
2368                           Make_Identifier (Loc, Name_uObject)),
2369                     Attribute_Name => Name_Unchecked_Access))));
2370          end if;
2371
2372          if Abort_Allowed then
2373
2374             --  Abort_Undefer;
2375
2376             Append_To (Stmt,
2377               Make_Procedure_Call_Statement (Loc,
2378                 Name =>
2379                   New_Reference_To (
2380                     RTE (RE_Abort_Undefer), Loc),
2381                 Parameter_Associations => Empty_List));
2382          end if;
2383
2384       elsif Is_Task_Allocation_Block then
2385
2386          --  Add a call to Expunge_Unactivated_Tasks to the cleanup
2387          --  handler of a block created for the dynamic allocation of
2388          --  tasks:
2389
2390          --  Expunge_Unactivated_Tasks (_chain);
2391
2392          --  where _chain is the list of tasks created by the allocator
2393          --  but not yet activated. This list will be empty unless
2394          --  the block completes abnormally.
2395
2396          --  This only applies to dynamically allocated tasks;
2397          --  other unactivated tasks are completed by Complete_Task or
2398          --  Complete_Master.
2399
2400          --  NOTE: This cleanup handler references _chain, a local
2401          --        object.
2402
2403          Append_To (Stmt,
2404            Make_Procedure_Call_Statement (Loc,
2405              Name =>
2406                New_Reference_To (
2407                  RTE (RE_Expunge_Unactivated_Tasks), Loc),
2408              Parameter_Associations => New_List (
2409                New_Reference_To (Activation_Chain_Entity (N), Loc))));
2410
2411       elsif Is_Asynchronous_Call_Block then
2412
2413          --  Add a call to attempt to cancel the asynchronous entry call
2414          --  whenever the block containing the abortable part is exited.
2415
2416          --  NOTE: This cleanup handler references C, a local object
2417
2418          --  Get the argument to the Cancel procedure
2419          Cancel_Param := Entry_Cancel_Parameter (Entity (Identifier (N)));
2420
2421          --  If it is of type Communication_Block, this must be a
2422          --  protected entry call.
2423
2424          if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
2425
2426             Append_To (Stmt,
2427
2428             --  if Enqueued (Cancel_Parameter) then
2429
2430               Make_Implicit_If_Statement (Clean,
2431                 Condition => Make_Function_Call (Loc,
2432                   Name => New_Reference_To (
2433                     RTE (RE_Enqueued), Loc),
2434                   Parameter_Associations => New_List (
2435                     New_Reference_To (Cancel_Param, Loc))),
2436                 Then_Statements => New_List (
2437
2438             --  Cancel_Protected_Entry_Call (Cancel_Param);
2439
2440                   Make_Procedure_Call_Statement (Loc,
2441                     Name => New_Reference_To (
2442                       RTE (RE_Cancel_Protected_Entry_Call), Loc),
2443                     Parameter_Associations => New_List (
2444                       New_Reference_To (Cancel_Param, Loc))))));
2445
2446          --  Asynchronous delay
2447
2448          elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
2449             Append_To (Stmt,
2450               Make_Procedure_Call_Statement (Loc,
2451                 Name => New_Reference_To (RTE (RE_Cancel_Async_Delay), Loc),
2452                 Parameter_Associations => New_List (
2453                   Make_Attribute_Reference (Loc,
2454                     Prefix => New_Reference_To (Cancel_Param, Loc),
2455                     Attribute_Name => Name_Unchecked_Access))));
2456
2457          --  Task entry call
2458
2459          else
2460             --  Append call to Cancel_Task_Entry_Call (C);
2461
2462             Append_To (Stmt,
2463               Make_Procedure_Call_Statement (Loc,
2464                 Name => New_Reference_To (
2465                   RTE (RE_Cancel_Task_Entry_Call),
2466                   Loc),
2467                 Parameter_Associations => New_List (
2468                   New_Reference_To (Cancel_Param, Loc))));
2469
2470          end if;
2471       end if;
2472
2473       if Present (Flist) then
2474          Append_To (Stmt,
2475            Make_Procedure_Call_Statement (Loc,
2476              Name => New_Reference_To (RTE (RE_Finalize_List), Loc),
2477              Parameter_Associations => New_List (
2478                     New_Reference_To (Flist, Loc))));
2479       end if;
2480
2481       if Present (Mark) then
2482          Append_To (Stmt,
2483            Make_Procedure_Call_Statement (Loc,
2484              Name => New_Reference_To (RTE (RE_SS_Release), Loc),
2485              Parameter_Associations => New_List (
2486                     New_Reference_To (Mark, Loc))));
2487       end if;
2488
2489       Sbody :=
2490         Make_Subprogram_Body (Loc,
2491           Specification =>
2492             Make_Procedure_Specification (Loc,
2493               Defining_Unit_Name => Clean),
2494
2495           Declarations  => New_List,
2496
2497           Handled_Statement_Sequence =>
2498             Make_Handled_Sequence_Of_Statements (Loc,
2499               Statements => Stmt));
2500
2501       if Present (Flist) or else Is_Task or else Is_Master then
2502          Wrap_Cleanup_Procedure (Sbody);
2503       end if;
2504
2505       --  We do not want debug information for _Clean routines,
2506       --  since it just confuses the debugging operation unless
2507       --  we are debugging generated code.
2508
2509       if not Debug_Generated_Code then
2510          Set_Debug_Info_Off (Clean, True);
2511       end if;
2512
2513       return Sbody;
2514    end Make_Clean;
2515
2516    --------------------------
2517    -- Make_Deep_Array_Body --
2518    --------------------------
2519
2520    --  Array components are initialized and adjusted in the normal order
2521    --  and finalized in the reverse order. Exceptions are handled and
2522    --  Program_Error is re-raise in the Adjust and Finalize case
2523    --  (RM 7.6.1(12)). Generate the following code :
2524    --
2525    --  procedure Deep_<P>   --  with <P> being Initialize or Adjust or Finalize
2526    --   (L : in out Finalizable_Ptr;
2527    --    V : in out Typ)
2528    --  is
2529    --  begin
2530    --     for J1 in             Typ'First (1) .. Typ'Last (1) loop
2531    --               ^ reverse ^  --  in the finalization case
2532    --        ...
2533    --           for J2 in Typ'First (n) .. Typ'Last (n) loop
2534    --                 Make_<P>_Call (Typ, V (J1, .. , Jn), L, V);
2535    --           end loop;
2536    --        ...
2537    --     end loop;
2538    --  exception                                --  not in the
2539    --     when others => raise Program_Error;   --     Initialize case
2540    --  end Deep_<P>;
2541
2542    function Make_Deep_Array_Body
2543      (Prim : Final_Primitives;
2544       Typ  : Entity_Id) return List_Id
2545    is
2546       Loc : constant Source_Ptr := Sloc (Typ);
2547
2548       Index_List : constant List_Id := New_List;
2549       --  Stores the list of references to the indexes (one per dimension)
2550
2551       function One_Component return List_Id;
2552       --  Create one statement to initialize/adjust/finalize one array
2553       --  component, designated by a full set of indices.
2554
2555       function One_Dimension (N : Int) return List_Id;
2556       --  Create loop to deal with one dimension of the array. The single
2557       --  statement in the body of the loop initializes the inner dimensions if
2558       --  any, or else a single component.
2559
2560       -------------------
2561       -- One_Component --
2562       -------------------
2563
2564       function One_Component return List_Id is
2565          Comp_Typ : constant Entity_Id := Component_Type (Typ);
2566          Comp_Ref : constant Node_Id :=
2567                       Make_Indexed_Component (Loc,
2568                         Prefix      => Make_Identifier (Loc, Name_V),
2569                         Expressions => Index_List);
2570
2571       begin
2572          --  Set the etype of the component Reference, which is used to
2573          --  determine whether a conversion to a parent type is needed.
2574
2575          Set_Etype (Comp_Ref, Comp_Typ);
2576
2577          case Prim is
2578             when Initialize_Case =>
2579                return Make_Init_Call (Comp_Ref, Comp_Typ,
2580                         Make_Identifier (Loc, Name_L),
2581                         Make_Identifier (Loc, Name_B));
2582
2583             when Adjust_Case =>
2584                return Make_Adjust_Call (Comp_Ref, Comp_Typ,
2585                         Make_Identifier (Loc, Name_L),
2586                         Make_Identifier (Loc, Name_B));
2587
2588             when Finalize_Case =>
2589                return Make_Final_Call (Comp_Ref, Comp_Typ,
2590                         Make_Identifier (Loc, Name_B));
2591          end case;
2592       end One_Component;
2593
2594       -------------------
2595       -- One_Dimension --
2596       -------------------
2597
2598       function One_Dimension (N : Int) return List_Id is
2599          Index : Entity_Id;
2600
2601       begin
2602          if N > Number_Dimensions (Typ) then
2603             return One_Component;
2604
2605          else
2606             Index :=
2607               Make_Defining_Identifier (Loc, New_External_Name ('J', N));
2608
2609             Append_To (Index_List, New_Reference_To (Index, Loc));
2610
2611             return New_List (
2612               Make_Implicit_Loop_Statement (Typ,
2613                 Identifier => Empty,
2614                 Iteration_Scheme =>
2615                   Make_Iteration_Scheme (Loc,
2616                     Loop_Parameter_Specification =>
2617                       Make_Loop_Parameter_Specification (Loc,
2618                         Defining_Identifier => Index,
2619                         Discrete_Subtype_Definition =>
2620                           Make_Attribute_Reference (Loc,
2621                             Prefix => Make_Identifier (Loc, Name_V),
2622                             Attribute_Name  => Name_Range,
2623                             Expressions => New_List (
2624                               Make_Integer_Literal (Loc, N))),
2625                         Reverse_Present => Prim = Finalize_Case)),
2626                 Statements => One_Dimension (N + 1)));
2627          end if;
2628       end One_Dimension;
2629
2630    --  Start of processing for Make_Deep_Array_Body
2631
2632    begin
2633       return One_Dimension (1);
2634    end Make_Deep_Array_Body;
2635
2636    --------------------
2637    -- Make_Deep_Proc --
2638    --------------------
2639
2640    --  Generate:
2641    --    procedure DEEP_<prim>
2642    --      (L : IN OUT Finalizable_Ptr;    -- not for Finalize
2643    --       V : IN OUT <typ>;
2644    --       B : IN Short_Short_Integer) is
2645    --    begin
2646    --       <stmts>;
2647    --    exception                   --  Finalize and Adjust Cases only
2648    --       raise Program_Error;     --  idem
2649    --    end DEEP_<prim>;
2650
2651    function Make_Deep_Proc
2652      (Prim  : Final_Primitives;
2653       Typ   : Entity_Id;
2654       Stmts : List_Id) return Entity_Id
2655    is
2656       Loc       : constant Source_Ptr := Sloc (Typ);
2657       Formals   : List_Id;
2658       Proc_Name : Entity_Id;
2659       Handler   : List_Id := No_List;
2660       Type_B    : Entity_Id;
2661
2662    begin
2663       if Prim = Finalize_Case then
2664          Formals := New_List;
2665          Type_B := Standard_Boolean;
2666
2667       else
2668          Formals := New_List (
2669            Make_Parameter_Specification (Loc,
2670              Defining_Identifier => Make_Defining_Identifier (Loc, Name_L),
2671              In_Present          => True,
2672              Out_Present         => True,
2673              Parameter_Type      =>
2674                New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
2675          Type_B := Standard_Short_Short_Integer;
2676       end if;
2677
2678       Append_To (Formals,
2679         Make_Parameter_Specification (Loc,
2680           Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
2681           In_Present          => True,
2682           Out_Present         => True,
2683           Parameter_Type      => New_Reference_To (Typ, Loc)));
2684
2685       Append_To (Formals,
2686         Make_Parameter_Specification (Loc,
2687           Defining_Identifier => Make_Defining_Identifier (Loc, Name_B),
2688           Parameter_Type      => New_Reference_To (Type_B, Loc)));
2689
2690       if Prim = Finalize_Case or else Prim = Adjust_Case then
2691          Handler := New_List (Make_Handler_For_Ctrl_Operation (Loc));
2692       end if;
2693
2694       Proc_Name :=
2695         Make_Defining_Identifier (Loc,
2696           Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
2697
2698       Discard_Node (
2699         Make_Subprogram_Body (Loc,
2700           Specification =>
2701             Make_Procedure_Specification (Loc,
2702               Defining_Unit_Name       => Proc_Name,
2703               Parameter_Specifications => Formals),
2704
2705           Declarations =>  Empty_List,
2706           Handled_Statement_Sequence =>
2707             Make_Handled_Sequence_Of_Statements (Loc,
2708               Statements         => Stmts,
2709               Exception_Handlers => Handler)));
2710
2711       return Proc_Name;
2712    end Make_Deep_Proc;
2713
2714    ---------------------------
2715    -- Make_Deep_Record_Body --
2716    ---------------------------
2717
2718    --  The Deep procedures call the appropriate Controlling proc on the
2719    --  the controller component. In the init case, it also attach the
2720    --  controller to the current finalization list.
2721
2722    function Make_Deep_Record_Body
2723      (Prim : Final_Primitives;
2724       Typ  : Entity_Id) return List_Id
2725    is
2726       Loc            : constant Source_Ptr := Sloc (Typ);
2727       Controller_Typ : Entity_Id;
2728       Obj_Ref        : constant Node_Id := Make_Identifier (Loc, Name_V);
2729       Controller_Ref : constant Node_Id :=
2730                          Make_Selected_Component (Loc,
2731                            Prefix        => Obj_Ref,
2732                            Selector_Name =>
2733                              Make_Identifier (Loc, Name_uController));
2734       Res            : constant List_Id := New_List;
2735
2736    begin
2737       if Is_Inherently_Limited_Type (Typ) then
2738          Controller_Typ := RTE (RE_Limited_Record_Controller);
2739       else
2740          Controller_Typ := RTE (RE_Record_Controller);
2741       end if;
2742
2743       case Prim is
2744          when Initialize_Case =>
2745             Append_List_To (Res,
2746               Make_Init_Call (
2747                 Ref          => Controller_Ref,
2748                 Typ          => Controller_Typ,
2749                 Flist_Ref    => Make_Identifier (Loc, Name_L),
2750                 With_Attach  => Make_Identifier (Loc, Name_B)));
2751
2752             --  When the type is also a controlled type by itself,
2753             --  Initialize it and attach it to the finalization chain
2754
2755             if Is_Controlled (Typ) then
2756                Append_To (Res,
2757                  Make_Procedure_Call_Statement (Loc,
2758                    Name => New_Reference_To (
2759                      Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
2760                    Parameter_Associations =>
2761                      New_List (New_Copy_Tree (Obj_Ref))));
2762
2763                Append_To (Res, Make_Attach_Call (
2764                  Obj_Ref      => New_Copy_Tree (Obj_Ref),
2765                  Flist_Ref    => Make_Identifier (Loc, Name_L),
2766                  With_Attach => Make_Identifier (Loc, Name_B)));
2767             end if;
2768
2769          when Adjust_Case =>
2770             Append_List_To (Res,
2771               Make_Adjust_Call (Controller_Ref, Controller_Typ,
2772                 Make_Identifier (Loc, Name_L),
2773                 Make_Identifier (Loc, Name_B)));
2774
2775             --  When the type is also a controlled type by itself,
2776             --  Adjust it it and attach it to the finalization chain
2777
2778             if Is_Controlled (Typ) then
2779                Append_To (Res,
2780                  Make_Procedure_Call_Statement (Loc,
2781                    Name => New_Reference_To (
2782                      Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
2783                    Parameter_Associations =>
2784                      New_List (New_Copy_Tree (Obj_Ref))));
2785
2786                Append_To (Res, Make_Attach_Call (
2787                  Obj_Ref      => New_Copy_Tree (Obj_Ref),
2788                  Flist_Ref    => Make_Identifier (Loc, Name_L),
2789                  With_Attach => Make_Identifier (Loc, Name_B)));
2790             end if;
2791
2792          when Finalize_Case =>
2793             if Is_Controlled (Typ) then
2794                Append_To (Res,
2795                  Make_Implicit_If_Statement (Obj_Ref,
2796                    Condition => Make_Identifier (Loc, Name_B),
2797                    Then_Statements => New_List (
2798                      Make_Procedure_Call_Statement (Loc,
2799                        Name => New_Reference_To (RTE (RE_Finalize_One), Loc),
2800                        Parameter_Associations => New_List (
2801                          OK_Convert_To (RTE (RE_Finalizable),
2802                            New_Copy_Tree (Obj_Ref))))),
2803
2804                    Else_Statements => New_List (
2805                      Make_Procedure_Call_Statement (Loc,
2806                        Name => New_Reference_To (
2807                          Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
2808                        Parameter_Associations =>
2809                         New_List (New_Copy_Tree (Obj_Ref))))));
2810             end if;
2811
2812             Append_List_To (Res,
2813               Make_Final_Call (Controller_Ref, Controller_Typ,
2814                 Make_Identifier (Loc, Name_B)));
2815       end case;
2816       return Res;
2817    end Make_Deep_Record_Body;
2818
2819    ----------------------
2820    -- Make_Final_Call --
2821    ----------------------
2822
2823    function Make_Final_Call
2824      (Ref         : Node_Id;
2825       Typ         : Entity_Id;
2826       With_Detach : Node_Id) return List_Id
2827    is
2828       Loc   : constant Source_Ptr := Sloc (Ref);
2829       Res   : constant List_Id    := New_List;
2830       Cref  : Node_Id;
2831       Cref2 : Node_Id;
2832       Proc  : Entity_Id;
2833       Utyp  : Entity_Id;
2834
2835    begin
2836       if Is_Class_Wide_Type (Typ) then
2837          Utyp := Root_Type (Typ);
2838          Cref := Ref;
2839
2840       elsif Is_Concurrent_Type (Typ) then
2841          Utyp := Corresponding_Record_Type (Typ);
2842          Cref := Convert_Concurrent (Ref, Typ);
2843
2844       elsif Is_Private_Type (Typ)
2845         and then Present (Full_View (Typ))
2846         and then Is_Concurrent_Type (Full_View (Typ))
2847       then
2848          Utyp := Corresponding_Record_Type (Full_View (Typ));
2849          Cref := Convert_Concurrent (Ref, Full_View (Typ));
2850       else
2851          Utyp := Typ;
2852          Cref := Ref;
2853       end if;
2854
2855       Utyp := Underlying_Type (Base_Type (Utyp));
2856       Set_Assignment_OK (Cref);
2857
2858       --  Deal with non-tagged derivation of private views. If the parent is
2859       --  now known to be protected, the finalization routine is the one
2860       --  defined on the corresponding record of the ancestor (corresponding
2861       --  records do not automatically inherit operations, but maybe they
2862       --  should???)
2863
2864       if Is_Untagged_Derivation (Typ) then
2865          if Is_Protected_Type (Typ) then
2866             Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
2867          else
2868             Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
2869          end if;
2870
2871          Cref := Unchecked_Convert_To (Utyp, Cref);
2872
2873          --  We need to set Assignment_OK to prevent problems with unchecked
2874          --  conversions, where we do not want them to be converted back in the
2875          --  case of untagged record derivation (see code in Make_*_Call
2876          --  procedures for similar situations).
2877
2878          Set_Assignment_OK (Cref);
2879       end if;
2880
2881       --  If the underlying_type is a subtype, we are dealing with
2882       --  the completion of a private type. We need to access
2883       --  the base type and generate a conversion to it.
2884
2885       if Utyp /= Base_Type (Utyp) then
2886          pragma Assert (Is_Private_Type (Typ));
2887          Utyp := Base_Type (Utyp);
2888          Cref := Unchecked_Convert_To (Utyp, Cref);
2889       end if;
2890
2891       --  Generate:
2892       --    Deep_Finalize (Ref, With_Detach);
2893
2894       if Has_Controlled_Component (Utyp)
2895         or else Is_Class_Wide_Type (Typ)
2896       then
2897          if Is_Tagged_Type (Utyp) then
2898             Proc := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
2899          else
2900             Proc := TSS (Utyp, TSS_Deep_Finalize);
2901          end if;
2902
2903          Cref := Convert_View (Proc, Cref);
2904
2905          Append_To (Res,
2906            Make_Procedure_Call_Statement (Loc,
2907              Name => New_Reference_To (Proc, Loc),
2908              Parameter_Associations =>
2909                New_List (Cref, With_Detach)));
2910
2911       --  Generate:
2912       --    if With_Detach then
2913       --       Finalize_One (Ref);
2914       --    else
2915       --       Finalize (Ref);
2916       --    end if;
2917
2918       else
2919          Proc := Find_Prim_Op (Utyp, Name_Of (Finalize_Case));
2920
2921          if Chars (With_Detach) = Chars (Standard_True) then
2922             Append_To (Res,
2923               Make_Procedure_Call_Statement (Loc,
2924                 Name => New_Reference_To (RTE (RE_Finalize_One), Loc),
2925                 Parameter_Associations => New_List (
2926                   OK_Convert_To (RTE (RE_Finalizable), Cref))));
2927
2928          elsif Chars (With_Detach) = Chars (Standard_False) then
2929             Append_To (Res,
2930               Make_Procedure_Call_Statement (Loc,
2931                 Name => New_Reference_To (Proc, Loc),
2932                 Parameter_Associations =>
2933                   New_List (Convert_View (Proc, Cref))));
2934
2935          else
2936             Cref2 := New_Copy_Tree (Cref);
2937             Append_To (Res,
2938               Make_Implicit_If_Statement (Ref,
2939                 Condition => With_Detach,
2940                 Then_Statements => New_List (
2941                   Make_Procedure_Call_Statement (Loc,
2942                     Name => New_Reference_To (RTE (RE_Finalize_One), Loc),
2943                     Parameter_Associations => New_List (
2944                       OK_Convert_To (RTE (RE_Finalizable), Cref)))),
2945
2946                 Else_Statements => New_List (
2947                   Make_Procedure_Call_Statement (Loc,
2948                     Name => New_Reference_To (Proc, Loc),
2949                     Parameter_Associations =>
2950                       New_List (Convert_View (Proc, Cref2))))));
2951          end if;
2952       end if;
2953
2954       return Res;
2955    end Make_Final_Call;
2956
2957    -------------------------------------
2958    -- Make_Handler_For_Ctrl_Operation --
2959    -------------------------------------
2960
2961    --  Generate:
2962
2963    --    when E : others =>
2964    --      Raise_From_Controlled_Operation (X => E);
2965
2966    --  or:
2967
2968    --    when others =>
2969    --      raise Program_Error [finalize raised exception];
2970
2971    --  depending on whether Raise_From_Controlled_Operation is available
2972
2973    function Make_Handler_For_Ctrl_Operation
2974      (Loc : Source_Ptr) return Node_Id
2975    is
2976       E_Occ : Entity_Id;
2977       --  Choice parameter (for the first case above)
2978
2979       Raise_Node : Node_Id;
2980       --  Procedure call or raise statement
2981
2982    begin
2983       if RTE_Available (RE_Raise_From_Controlled_Operation) then
2984
2985          --  Standard runtime: add choice parameter E, and pass it to
2986          --  Raise_From_Controlled_Operation so that the original exception
2987          --  name and message can be recorded in the exception message for
2988          --  Program_Error.
2989
2990          E_Occ := Make_Defining_Identifier (Loc, Name_E);
2991          Raise_Node := Make_Procedure_Call_Statement (Loc,
2992                          Name =>
2993                            New_Occurrence_Of (
2994                              RTE (RE_Raise_From_Controlled_Operation), Loc),
2995                          Parameter_Associations => New_List (
2996                            New_Occurrence_Of (E_Occ, Loc)));
2997
2998       else
2999          --  Restricted runtime: exception messages are not supported
3000
3001          E_Occ := Empty;
3002          Raise_Node := Make_Raise_Program_Error (Loc,
3003                          Reason => PE_Finalize_Raised_Exception);
3004       end if;
3005
3006       return Make_Implicit_Exception_Handler (Loc,
3007                Exception_Choices => New_List (Make_Others_Choice (Loc)),
3008                Choice_Parameter  => E_Occ,
3009                Statements        => New_List (Raise_Node));
3010    end Make_Handler_For_Ctrl_Operation;
3011
3012    --------------------
3013    -- Make_Init_Call --
3014    --------------------
3015
3016    function Make_Init_Call
3017      (Ref          : Node_Id;
3018       Typ          : Entity_Id;
3019       Flist_Ref    : Node_Id;
3020       With_Attach  : Node_Id) return List_Id
3021    is
3022       Loc     : constant Source_Ptr := Sloc (Ref);
3023       Is_Conc : Boolean;
3024       Res     : constant List_Id := New_List;
3025       Proc    : Entity_Id;
3026       Utyp    : Entity_Id;
3027       Cref    : Node_Id;
3028       Cref2   : Node_Id;
3029       Attach  : Node_Id := With_Attach;
3030
3031    begin
3032       if Is_Concurrent_Type (Typ) then
3033          Is_Conc := True;
3034          Utyp    := Corresponding_Record_Type (Typ);
3035          Cref    := Convert_Concurrent (Ref, Typ);
3036
3037       elsif Is_Private_Type (Typ)
3038         and then Present (Full_View (Typ))
3039         and then Is_Concurrent_Type (Underlying_Type (Typ))
3040       then
3041          Is_Conc := True;
3042          Utyp    := Corresponding_Record_Type (Underlying_Type (Typ));
3043          Cref    := Convert_Concurrent (Ref, Underlying_Type (Typ));
3044
3045       else
3046          Is_Conc := False;
3047          Utyp    := Typ;
3048          Cref    := Ref;
3049       end if;
3050
3051       Utyp := Underlying_Type (Base_Type (Utyp));
3052
3053       Set_Assignment_OK (Cref);
3054
3055       --  Deal with non-tagged derivation of private views
3056
3057       if Is_Untagged_Derivation (Typ)
3058         and then not Is_Conc
3059       then
3060          Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
3061          Cref := Unchecked_Convert_To (Utyp, Cref);
3062          Set_Assignment_OK (Cref);
3063          --  To prevent problems with UC see 1.156 RH ???
3064       end if;
3065
3066       --  If the underlying_type is a subtype, we are dealing with
3067       --  the completion of a private type. We need to access
3068       --  the base type and generate a conversion to it.
3069
3070       if Utyp /= Base_Type (Utyp) then
3071          pragma Assert (Is_Private_Type (Typ));
3072          Utyp := Base_Type (Utyp);
3073          Cref := Unchecked_Convert_To (Utyp, Cref);
3074       end if;
3075
3076       --  We do not need to attach to one of the Global Final Lists
3077       --  the objects whose type is Finalize_Storage_Only
3078
3079       if Finalize_Storage_Only (Typ)
3080         and then (Global_Flist_Ref (Flist_Ref)
3081           or else Entity (Constant_Value (RTE (RE_Garbage_Collected)))
3082                   = Standard_True)
3083       then
3084          Attach := Make_Integer_Literal (Loc, 0);
3085       end if;
3086
3087       --  Generate:
3088       --    Deep_Initialize (Ref, Flist_Ref);
3089
3090       if Has_Controlled_Component (Utyp) then
3091          Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
3092
3093          Cref := Convert_View (Proc, Cref, 2);
3094
3095          Append_To (Res,
3096            Make_Procedure_Call_Statement (Loc,
3097              Name => New_Reference_To (Proc, Loc),
3098              Parameter_Associations => New_List (
3099                Node1 => Flist_Ref,
3100                Node2 => Cref,
3101                Node3 => Attach)));
3102
3103       --  Generate:
3104       --    Attach_To_Final_List (Ref, Flist_Ref);
3105       --    Initialize (Ref);
3106
3107       else -- Is_Controlled (Utyp)
3108          Proc  := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
3109          Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Cref);
3110
3111          Cref  := Convert_View (Proc, Cref);
3112          Cref2 := New_Copy_Tree (Cref);
3113
3114          Append_To (Res,
3115            Make_Procedure_Call_Statement (Loc,
3116            Name => New_Reference_To (Proc, Loc),
3117            Parameter_Associations => New_List (Cref2)));
3118
3119          Append_To (Res,
3120            Make_Attach_Call (Cref, Flist_Ref, Attach));
3121       end if;
3122
3123       return Res;
3124    end Make_Init_Call;
3125
3126    --------------------------
3127    -- Make_Transient_Block --
3128    --------------------------
3129
3130    --  If finalization is involved, this function just wraps the instruction
3131    --  into a block whose name is the transient block entity, and then
3132    --  Expand_Cleanup_Actions (called on the expansion of the handled
3133    --  sequence of statements will do the necessary expansions for
3134    --  cleanups).
3135
3136    function Make_Transient_Block
3137      (Loc    : Source_Ptr;
3138       Action : Node_Id) return Node_Id
3139    is
3140       Flist  : constant Entity_Id := Finalization_Chain_Entity (Current_Scope);
3141       Decls  : constant List_Id   := New_List;
3142       Par    : constant Node_Id   := Parent (Action);
3143       Instrs : constant List_Id   := New_List (Action);
3144       Blk    : Node_Id;
3145
3146    begin
3147       --  Case where only secondary stack use is involved
3148
3149       if VM_Target = No_VM
3150         and then Uses_Sec_Stack (Current_Scope)
3151         and then No (Flist)
3152         and then Nkind (Action) /= N_Simple_Return_Statement
3153         and then Nkind (Par) /= N_Exception_Handler
3154       then
3155
3156          declare
3157             S  : Entity_Id;
3158             K  : Entity_Kind;
3159          begin
3160             S := Scope (Current_Scope);
3161             loop
3162                K := Ekind (S);
3163
3164                --  At the outer level, no need to release the sec stack
3165
3166                if S = Standard_Standard then
3167                   Set_Uses_Sec_Stack (Current_Scope, False);
3168                   exit;
3169
3170                --  In a function, only release the sec stack if the
3171                --  function does not return on the sec stack otherwise
3172                --  the result may be lost. The caller is responsible for
3173                --  releasing.
3174
3175                elsif K = E_Function then
3176                   Set_Uses_Sec_Stack (Current_Scope, False);
3177
3178                   if not Requires_Transient_Scope (Etype (S)) then
3179                      Set_Uses_Sec_Stack (S, True);
3180                      Check_Restriction (No_Secondary_Stack, Action);
3181                   end if;
3182
3183                   exit;
3184
3185                --  In a loop or entry we should install a block encompassing
3186                --  all the construct. For now just release right away.
3187
3188                elsif K = E_Loop or else K = E_Entry then
3189                   exit;
3190
3191                --  In a procedure or a block, we release on exit of the
3192                --  procedure or block. ??? memory leak can be created by
3193                --  recursive calls.
3194
3195                elsif K = E_Procedure
3196                  or else K = E_Block
3197                then
3198                   Set_Uses_Sec_Stack (S, True);
3199                   Check_Restriction (No_Secondary_Stack, Action);
3200                   Set_Uses_Sec_Stack (Current_Scope, False);
3201                   exit;
3202
3203                else
3204                   S := Scope (S);
3205                end if;
3206             end loop;
3207          end;
3208       end if;
3209
3210       --  Insert actions stuck in the transient scopes as well as all
3211       --  freezing nodes needed by those actions
3212
3213       Insert_Actions_In_Scope_Around (Action);
3214
3215       declare
3216          Last_Inserted : Node_Id := Prev (Action);
3217       begin
3218          if Present (Last_Inserted) then
3219             Freeze_All (First_Entity (Current_Scope), Last_Inserted);
3220          end if;
3221       end;
3222
3223       Blk :=
3224         Make_Block_Statement (Loc,
3225           Identifier => New_Reference_To (Current_Scope, Loc),
3226           Declarations => Decls,
3227           Handled_Statement_Sequence =>
3228             Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
3229           Has_Created_Identifier => True);
3230
3231       --  When the transient scope was established, we pushed the entry for
3232       --  the transient scope onto the scope stack, so that the scope was
3233       --  active for the installation of finalizable entities etc. Now we
3234       --  must remove this entry, since we have constructed a proper block.
3235
3236       Pop_Scope;
3237
3238       return Blk;
3239    end Make_Transient_Block;
3240
3241    ------------------------
3242    -- Node_To_Be_Wrapped --
3243    ------------------------
3244
3245    function Node_To_Be_Wrapped return Node_Id is
3246    begin
3247       return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
3248    end Node_To_Be_Wrapped;
3249
3250    ----------------------------
3251    -- Set_Node_To_Be_Wrapped --
3252    ----------------------------
3253
3254    procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
3255    begin
3256       Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
3257    end Set_Node_To_Be_Wrapped;
3258
3259    ----------------------------------
3260    -- Store_After_Actions_In_Scope --
3261    ----------------------------------
3262
3263    procedure Store_After_Actions_In_Scope (L : List_Id) is
3264       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
3265
3266    begin
3267       if Present (SE.Actions_To_Be_Wrapped_After) then
3268          Insert_List_Before_And_Analyze (
3269           First (SE.Actions_To_Be_Wrapped_After), L);
3270
3271       else
3272          SE.Actions_To_Be_Wrapped_After := L;
3273
3274          if Is_List_Member (SE.Node_To_Be_Wrapped) then
3275             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
3276          else
3277             Set_Parent (L, SE.Node_To_Be_Wrapped);
3278          end if;
3279
3280          Analyze_List (L);
3281       end if;
3282    end Store_After_Actions_In_Scope;
3283
3284    -----------------------------------
3285    -- Store_Before_Actions_In_Scope --
3286    -----------------------------------
3287
3288    procedure Store_Before_Actions_In_Scope (L : List_Id) is
3289       SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
3290
3291    begin
3292       if Present (SE.Actions_To_Be_Wrapped_Before) then
3293          Insert_List_After_And_Analyze (
3294            Last (SE.Actions_To_Be_Wrapped_Before), L);
3295
3296       else
3297          SE.Actions_To_Be_Wrapped_Before := L;
3298
3299          if Is_List_Member (SE.Node_To_Be_Wrapped) then
3300             Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
3301          else
3302             Set_Parent (L, SE.Node_To_Be_Wrapped);
3303          end if;
3304
3305          Analyze_List (L);
3306       end if;
3307    end Store_Before_Actions_In_Scope;
3308
3309    --------------------------------
3310    -- Wrap_Transient_Declaration --
3311    --------------------------------
3312
3313    --  If a transient scope has been established during the processing of the
3314    --  Expression of an Object_Declaration, it is not possible to wrap the
3315    --  declaration into a transient block as usual case, otherwise the object
3316    --  would be itself declared in the wrong scope. Therefore, all entities (if
3317    --  any) defined in the transient block are moved to the proper enclosing
3318    --  scope, furthermore, if they are controlled variables they are finalized
3319    --  right after the declaration. The finalization list of the transient
3320    --  scope is defined as a renaming of the enclosing one so during their
3321    --  initialization they will be attached to the proper finalization
3322    --  list. For instance, the following declaration :
3323
3324    --        X : Typ := F (G (A), G (B));
3325
3326    --  (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
3327    --  is expanded into :
3328
3329    --    _local_final_list_1 : Finalizable_Ptr;
3330    --    X : Typ := [ complex Expression-Action ];
3331    --    Finalize_One(_v1);
3332    --    Finalize_One (_v2);
3333
3334    procedure Wrap_Transient_Declaration (N : Node_Id) is
3335       S           : Entity_Id;
3336       LC          : Entity_Id := Empty;
3337       Nodes       : List_Id;
3338       Loc         : constant Source_Ptr := Sloc (N);
3339       Enclosing_S : Entity_Id;
3340       Uses_SS     : Boolean;
3341       Next_N      : constant Node_Id := Next (N);
3342
3343    begin
3344       S := Current_Scope;
3345       Enclosing_S := Scope (S);
3346
3347       --  Insert Actions kept in the Scope stack
3348
3349       Insert_Actions_In_Scope_Around (N);
3350
3351       --  If the declaration is consuming some secondary stack, mark the
3352       --  Enclosing scope appropriately.
3353
3354       Uses_SS := Uses_Sec_Stack (S);
3355       Pop_Scope;
3356
3357       --  Create a List controller and rename the final list to be its
3358       --  internal final pointer:
3359       --       Lxxx : Simple_List_Controller;
3360       --       Fxxx : Finalizable_Ptr renames Lxxx.F;
3361
3362       if Present (Finalization_Chain_Entity (S)) then
3363          LC := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
3364
3365          Nodes := New_List (
3366            Make_Object_Declaration (Loc,
3367              Defining_Identifier => LC,
3368              Object_Definition   =>
3369                New_Reference_To (RTE (RE_Simple_List_Controller), Loc)),
3370
3371            Make_Object_Renaming_Declaration (Loc,
3372              Defining_Identifier => Finalization_Chain_Entity (S),
3373              Subtype_Mark => New_Reference_To (RTE (RE_Finalizable_Ptr), Loc),
3374              Name =>
3375                Make_Selected_Component (Loc,
3376                  Prefix        => New_Reference_To (LC, Loc),
3377                  Selector_Name => Make_Identifier (Loc, Name_F))));
3378
3379          --  Put the declaration at the beginning of the declaration part
3380          --  to make sure it will be before all other actions that have been
3381          --  inserted before N.
3382
3383          Insert_List_Before_And_Analyze (First (List_Containing (N)), Nodes);
3384
3385          --  Generate the Finalization calls by finalizing the list
3386          --  controller right away. It will be re-finalized on scope
3387          --  exit but it doesn't matter. It cannot be done when the
3388          --  call initializes a renaming object though because in this
3389          --  case, the object becomes a pointer to the temporary and thus
3390          --  increases its life span. Ditto if this is a renaming of a
3391          --  component of an expression (such as a function call). .
3392          --  Note that there is a problem if an actual in the call needs
3393          --  finalization, because in that case the call itself is the master,
3394          --  and the actual should be finalized on return from the call ???
3395
3396          if Nkind (N) = N_Object_Renaming_Declaration
3397            and then Controlled_Type (Etype (Defining_Identifier (N)))
3398          then
3399             null;
3400
3401          elsif Nkind (N) = N_Object_Renaming_Declaration
3402            and then
3403              Nkind_In (Renamed_Object (Defining_Identifier (N)),
3404                        N_Selected_Component,
3405                        N_Indexed_Component)
3406            and then
3407              Controlled_Type
3408                (Etype (Prefix (Renamed_Object (Defining_Identifier (N)))))
3409          then
3410             null;
3411
3412          else
3413             Nodes :=
3414               Make_Final_Call
3415                 (Ref         => New_Reference_To (LC, Loc),
3416                  Typ         => Etype (LC),
3417                  With_Detach => New_Reference_To (Standard_False, Loc));
3418
3419             if Present (Next_N) then
3420                Insert_List_Before_And_Analyze (Next_N, Nodes);
3421             else
3422                Append_List_To (List_Containing (N), Nodes);
3423             end if;
3424          end if;
3425       end if;
3426
3427       --  Put the local entities back in the enclosing scope, and set the
3428       --  Is_Public flag appropriately.
3429
3430       Transfer_Entities (S, Enclosing_S);
3431
3432       --  Mark the enclosing dynamic scope so that the sec stack will be
3433       --  released upon its exit unless this is a function that returns on
3434       --  the sec stack in which case this will be done by the caller.
3435
3436       if VM_Target = No_VM and then Uses_SS then
3437          S := Enclosing_Dynamic_Scope (S);
3438
3439          if Ekind (S) = E_Function
3440            and then Requires_Transient_Scope (Etype (S))
3441          then
3442             null;
3443          else
3444             Set_Uses_Sec_Stack (S);
3445             Check_Restriction (No_Secondary_Stack, N);
3446          end if;
3447       end if;
3448    end Wrap_Transient_Declaration;
3449
3450    -------------------------------
3451    -- Wrap_Transient_Expression --
3452    -------------------------------
3453
3454    --  Insert actions before <Expression>:
3455
3456    --  (lines marked with <CTRL> are expanded only in presence of Controlled
3457    --   objects needing finalization)
3458
3459    --     _E : Etyp;
3460    --     declare
3461    --        _M : constant Mark_Id := SS_Mark;
3462    --        Local_Final_List : System.FI.Finalizable_Ptr;    <CTRL>
3463
3464    --        procedure _Clean is
3465    --        begin
3466    --           Abort_Defer;
3467    --           System.FI.Finalize_List (Local_Final_List);   <CTRL>
3468    --           SS_Release (M);
3469    --           Abort_Undefer;
3470    --        end _Clean;
3471
3472    --     begin
3473    --        _E := <Expression>;
3474    --     at end
3475    --        _Clean;
3476    --     end;
3477
3478    --    then expression is replaced by _E
3479
3480    procedure Wrap_Transient_Expression (N : Node_Id) is
3481       Loc  : constant Source_Ptr := Sloc (N);
3482       E    : constant Entity_Id :=
3483                Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
3484       Etyp : constant Entity_Id := Etype (N);
3485
3486    begin
3487       Insert_Actions (N, New_List (
3488         Make_Object_Declaration (Loc,
3489           Defining_Identifier => E,
3490           Object_Definition   => New_Reference_To (Etyp, Loc)),
3491
3492         Make_Transient_Block (Loc,
3493           Action =>
3494             Make_Assignment_Statement (Loc,
3495               Name       => New_Reference_To (E, Loc),
3496               Expression => Relocate_Node (N)))));
3497
3498       Rewrite (N, New_Reference_To (E, Loc));
3499       Analyze_And_Resolve (N, Etyp);
3500    end Wrap_Transient_Expression;
3501
3502    ------------------------------
3503    -- Wrap_Transient_Statement --
3504    ------------------------------
3505
3506    --  Transform <Instruction> into
3507
3508    --  (lines marked with <CTRL> are expanded only in presence of Controlled
3509    --   objects needing finalization)
3510
3511    --    declare
3512    --       _M : Mark_Id := SS_Mark;
3513    --       Local_Final_List : System.FI.Finalizable_Ptr ;    <CTRL>
3514
3515    --       procedure _Clean is
3516    --       begin
3517    --          Abort_Defer;
3518    --          System.FI.Finalize_List (Local_Final_List);    <CTRL>
3519    --          SS_Release (_M);
3520    --          Abort_Undefer;
3521    --       end _Clean;
3522
3523    --    begin
3524    --       <Instruction>;
3525    --    at end
3526    --       _Clean;
3527    --    end;
3528
3529    procedure Wrap_Transient_Statement (N : Node_Id) is
3530       Loc           : constant Source_Ptr := Sloc (N);
3531       New_Statement : constant Node_Id := Relocate_Node (N);
3532
3533    begin
3534       Rewrite (N, Make_Transient_Block (Loc, New_Statement));
3535
3536       --  With the scope stack back to normal, we can call analyze on the
3537       --  resulting block. At this point, the transient scope is being
3538       --  treated like a perfectly normal scope, so there is nothing
3539       --  special about it.
3540
3541       --  Note: Wrap_Transient_Statement is called with the node already
3542       --  analyzed (i.e. Analyzed (N) is True). This is important, since
3543       --  otherwise we would get a recursive processing of the node when
3544       --  we do this Analyze call.
3545
3546       Analyze (N);
3547    end Wrap_Transient_Statement;
3548
3549 end Exp_Ch7;