1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This package contains virtually all expansion mechanisms related to
30 with Atree; use Atree;
31 with Debug; use Debug;
32 with Einfo; use Einfo;
33 with Einfo.Entities; use Einfo.Entities;
34 with Einfo.Utils; use Einfo.Utils;
35 with Elists; use Elists;
36 with Errout; use Errout;
37 with Exp_Ch6; use Exp_Ch6;
38 with Exp_Ch9; use Exp_Ch9;
39 with Exp_Ch11; use Exp_Ch11;
40 with Exp_Dbug; use Exp_Dbug;
41 with Exp_Dist; use Exp_Dist;
42 with Exp_Disp; use Exp_Disp;
43 with Exp_Prag; use Exp_Prag;
44 with Exp_Tss; use Exp_Tss;
45 with Exp_Util; use Exp_Util;
46 with Freeze; use Freeze;
47 with GNAT_CUDA; use GNAT_CUDA;
49 with Nlists; use Nlists;
50 with Nmake; use Nmake;
52 with Output; use Output;
53 with Restrict; use Restrict;
54 with Rident; use Rident;
55 with Rtsfind; use Rtsfind;
56 with Sinfo; use Sinfo;
57 with Sinfo.Nodes; use Sinfo.Nodes;
58 with Sinfo.Utils; use Sinfo.Utils;
60 with Sem_Aux; use Sem_Aux;
61 with Sem_Ch7; use Sem_Ch7;
62 with Sem_Ch8; use Sem_Ch8;
63 with Sem_Res; use Sem_Res;
64 with Sem_Util; use Sem_Util;
65 with Snames; use Snames;
66 with Stand; use Stand;
67 with Tbuild; use Tbuild;
68 with Ttypes; use Ttypes;
69 with Uintp; use Uintp;
71 package body Exp_Ch7 is
73 --------------------------------
74 -- Transient Scope Management --
75 --------------------------------
77 -- A transient scope is needed when certain temporary objects are created
78 -- by the compiler. These temporary objects are allocated on the secondary
79 -- stack and/or need finalization, and the transient scope is responsible
80 -- for finalizing the objects and reclaiming the memory of the secondary
81 -- stack at the appropriate time. They are generally objects allocated to
82 -- store the result of a function returning an unconstrained or controlled
83 -- value. Expressions needing to be wrapped in a transient scope may appear
84 -- in three different contexts which lead to different kinds of transient
87 -- 1. In a simple statement (procedure call, assignment, ...). In this
88 -- case the instruction is wrapped into a transient block. See
89 -- Wrap_Transient_Statement for details.
91 -- 2. In an expression of a control structure (test in a IF statement,
92 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
95 -- 3. In a expression of an object_declaration. No wrapping is possible
96 -- here, so the finalization actions, if any, are done right after the
97 -- declaration and the secondary stack deallocation is done in the
98 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
100 --------------------------------------------------
101 -- Transient Blocks and Finalization Management --
102 --------------------------------------------------
104 procedure Insert_Actions_In_Scope_Around
107 Manage_SS : Boolean);
108 -- Insert the before-actions kept in the scope stack before N, and the
109 -- after-actions after N, which must be a member of a list. If flag Clean
110 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
111 -- calls to mark and release the secondary stack.
113 function Make_Transient_Block
116 Par : Node_Id) return Node_Id;
117 -- Action is a single statement or object declaration. Par is the proper
118 -- parent of the generated block. Create a transient block whose name is
119 -- the current scope and the only handled statement is Action. If Action
120 -- involves controlled objects or secondary stack usage, the corresponding
121 -- cleanup actions are performed at the end of the block.
123 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id);
124 -- Shared processing for Store_xxx_Actions_In_Scope
126 -----------------------------
127 -- Finalization Management --
128 -----------------------------
130 -- This part describes how Initialization/Adjustment/Finalization
131 -- procedures are generated and called. Two cases must be considered: types
132 -- that are Controlled (Is_Controlled flag set) and composite types that
133 -- contain controlled components (Has_Controlled_Component flag set). In
134 -- the first case the procedures to call are the user-defined primitive
135 -- operations Initialize/Adjust/Finalize. In the second case, GNAT
136 -- generates Deep_Initialize, Deep_Adjust and Deep_Finalize that are in
137 -- charge of calling the former procedures on the controlled components.
139 -- For records with Has_Controlled_Component set, a hidden "controller"
140 -- component is inserted. This controller component contains its own
141 -- finalization list on which all controlled components are attached
142 -- creating an indirection on the upper-level Finalization list. This
143 -- technique facilitates the management of objects whose number of
144 -- controlled components changes during execution. This controller
145 -- component is itself controlled and is attached to the upper-level
146 -- finalization chain. Its adjust primitive is in charge of calling adjust
147 -- on the components and adjusting the finalization pointer to match their
148 -- new location (see a-finali.adb).
150 -- It is not possible to use a similar technique for arrays that have
151 -- Has_Controlled_Component set. In this case, deep procedures are
152 -- generated that call initialize/adjust/finalize + attachment or
153 -- detachment on the finalization list for all component.
155 -- Initialize calls: they are generated for declarations or dynamic
156 -- allocations of Controlled objects with no initial value. They are always
157 -- followed by an attachment to the current Finalization Chain. For the
158 -- dynamic allocation case this the chain attached to the scope of the
159 -- access type definition otherwise, this is the chain of the current
162 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
163 -- or dynamic allocations of Controlled objects with an initial value.
164 -- (2) after an assignment. In the first case they are followed by an
165 -- attachment to the final chain, in the second case they are not.
167 -- Finalization Calls: They are generated on (1) scope exit, (2)
168 -- assignments, (3) unchecked deallocations. In case (3) they have to
169 -- be detached from the final chain, in case (2) they must not and in
170 -- case (1) this is not important since we are exiting the scope anyway.
174 -- Type extensions will have a new record controller at each derivation
175 -- level containing controlled components. The record controller for
176 -- the parent/ancestor is attached to the finalization list of the
177 -- extension's record controller (i.e. the parent is like a component
178 -- of the extension).
180 -- For types that are both Is_Controlled and Has_Controlled_Components,
181 -- the record controller and the object itself are handled separately.
182 -- It could seem simpler to attach the object at the end of its record
183 -- controller but this would not tackle view conversions properly.
185 -- A classwide type can always potentially have controlled components
186 -- but the record controller of the corresponding actual type may not
187 -- be known at compile time so the dispatch table contains a special
188 -- field that allows computation of the offset of the record controller
189 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
191 -- Here is a simple example of the expansion of a controlled block :
195 -- Y : Controlled := Init;
201 -- Z : R := (C => X);
211 -- _L : System.FI.Finalizable_Ptr;
213 -- procedure _Clean is
216 -- System.FI.Finalize_List (_L);
224 -- Attach_To_Final_List (_L, Finalizable (X), 1);
225 -- at end: Abort_Undefer;
226 -- Y : Controlled := Init;
228 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
236 -- Deep_Initialize (W, _L, 1);
237 -- at end: Abort_Under;
238 -- Z : R := (C => X);
239 -- Deep_Adjust (Z, _L, 1);
243 -- Deep_Finalize (W, False);
244 -- <save W's final pointers>
246 -- <restore W's final pointers>
247 -- Deep_Adjust (W, _L, 0);
252 type Final_Primitives is
253 (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
254 -- This enumeration type is defined in order to ease sharing code for
255 -- building finalization procedures for composite types.
257 Name_Of : constant array (Final_Primitives) of Name_Id :=
258 (Initialize_Case => Name_Initialize,
259 Adjust_Case => Name_Adjust,
260 Finalize_Case => Name_Finalize,
261 Address_Case => Name_Finalize_Address);
262 Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
263 (Initialize_Case => TSS_Deep_Initialize,
264 Adjust_Case => TSS_Deep_Adjust,
265 Finalize_Case => TSS_Deep_Finalize,
266 Address_Case => TSS_Finalize_Address);
268 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean;
269 -- Determine whether access type Typ may have a finalization master
271 procedure Build_Array_Deep_Procs (Typ : Entity_Id);
272 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
273 -- Has_Controlled_Component set and store them using the TSS mechanism.
275 function Build_Cleanup_Statements
277 Additional_Cleanup : List_Id) return List_Id;
278 -- Create the cleanup calls for an asynchronous call block, task master,
279 -- protected subprogram body, task allocation block or task body, or
280 -- additional cleanup actions parked on a transient block. If the context
281 -- does not contain the above constructs, the routine returns an empty
284 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
285 -- N is a construct that contains a handled sequence of statements, Fin_Id
286 -- is the entity of a finalizer. Create an At_End handler that covers the
287 -- statements of N and calls Fin_Id. If the handled statement sequence has
288 -- an exception handler, the statements will be wrapped in a block to avoid
289 -- unwanted interaction with the new At_End handler.
291 procedure Build_Record_Deep_Procs (Typ : Entity_Id);
292 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
293 -- Has_Component_Component set and store them using the TSS mechanism.
295 -------------------------------------------
296 -- Unnesting procedures for CCG and LLVM --
297 -------------------------------------------
299 -- Expansion generates subprograms for controlled types management that
300 -- may appear in declarative lists in package declarations and bodies.
301 -- These subprograms appear within generated blocks that contain local
302 -- declarations and a call to finalization procedures. To ensure that
303 -- such subprograms get activation records when needed, we transform the
304 -- block into a procedure body, followed by a call to it in the same
307 procedure Check_Unnesting_Elaboration_Code (N : Node_Id);
308 -- The statement part of a package body that is a compilation unit may
309 -- contain blocks that declare local subprograms. In Subprogram_Unnesting_
310 -- Mode such subprograms must be handled as nested inside the (implicit)
311 -- elaboration procedure that executes that statement part. To handle
312 -- properly uplevel references we construct that subprogram explicitly,
313 -- to contain blocks and inner subprograms, the statement part becomes
314 -- a call to this subprogram. This is only done if blocks are present
315 -- in the statement list of the body. (It would be nice to unify this
316 -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
317 -- they're doing very similar work, but are structured differently. ???)
319 procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id);
320 -- Similarly, the declarations or statements in library-level packages may
321 -- have created blocks with nested subprograms. Such a block must be
322 -- transformed into a procedure followed by a call to it, so that unnesting
323 -- can handle uplevel references within these nested subprograms (typically
324 -- subprograms that handle finalization actions). This also applies to
325 -- nested packages, including instantiations, in which case it must
326 -- recursively process inner bodies.
328 procedure Check_Unnesting_In_Handlers (N : Node_Id);
329 -- Similarly, check for blocks with nested subprograms occurring within
330 -- a set of exception handlers associated with a package body N.
332 procedure Unnest_Block (Decl : Node_Id);
333 -- Blocks that contain nested subprograms with up-level references need to
334 -- create activation records for them. We do this by rewriting the block as
335 -- a procedure, followed by a call to it in the same declarative list, to
336 -- replicate the semantics of the original block.
338 -- A common source for such block is a transient block created for a
339 -- construct (declaration, assignment, etc.) that involves controlled
340 -- actions or secondary-stack management, in which case the nested
341 -- subprogram is a finalizer.
343 procedure Unnest_If_Statement (If_Stmt : Node_Id);
344 -- The separate statement lists associated with an if-statement (then part,
345 -- elsif parts, else part) may require unnesting if they directly contain
346 -- a subprogram body that references up-level objects. Each statement list
347 -- is traversed to locate such subprogram bodies, and if a part's statement
348 -- list contains a body, then the list is replaced with a new procedure
349 -- containing the part's statements followed by a call to the procedure.
350 -- Furthermore, any nested blocks, loops, or if statements will also be
351 -- traversed to determine the need for further unnesting transformations.
353 procedure Unnest_Statement_List (Stmts : in out List_Id);
354 -- A list of statements that directly contains a subprogram at its outer
355 -- level, that may reference objects declared in that same statement list,
356 -- is rewritten as a procedure containing the statement list Stmts (which
357 -- includes any such objects as well as the nested subprogram), followed by
358 -- a call to the new procedure, and Stmts becomes the list containing the
359 -- procedure and the call. This ensures that Unnest_Subprogram will later
360 -- properly handle up-level references from the nested subprogram to
361 -- objects declared earlier in statement list, by creating an activation
362 -- record and passing it to the nested subprogram. This procedure also
363 -- resets the Scope of objects declared in the statement list, as well as
364 -- the Scope of the nested subprogram, to refer to the new procedure.
365 -- Also, the new procedure is marked Has_Nested_Subprogram, so this should
366 -- only be called when known that the statement list contains a subprogram.
368 procedure Unnest_Loop (Loop_Stmt : Node_Id);
369 -- Top-level Loops that contain nested subprograms with up-level references
370 -- need to have activation records. We do this by rewriting the loop as a
371 -- procedure containing the loop, followed by a call to the procedure in
372 -- the same library-level declarative list, to replicate the semantics of
373 -- the original loop. Such loops can occur due to aggregate expansions and
376 procedure Check_Visibly_Controlled
377 (Prim : Final_Primitives;
379 E : in out Entity_Id;
380 Cref : in out Node_Id);
381 -- The controlled operation declared for a derived type may not be
382 -- overriding, if the controlled operations of the parent type are hidden,
383 -- for example when the parent is a private type whose full view is
384 -- controlled. For other primitive operations we modify the name of the
385 -- operation to indicate that it is not overriding, but this is not
386 -- possible for Initialize, etc. because they have to be retrievable by
387 -- name. Before generating the proper call to one of these operations we
388 -- check whether Typ is known to be controlled at the point of definition.
389 -- If it is not then we must retrieve the hidden operation of the parent
390 -- and use it instead. This is one case that might be solved more cleanly
391 -- once Overriding pragmas or declarations are in place.
393 function Contains_Subprogram (Blk : Entity_Id) return Boolean;
394 -- Check recursively whether a loop or block contains a subprogram that
395 -- may need an activation record.
397 function Convert_View (Proc : Entity_Id; Arg : Node_Id) return Node_Id;
398 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
399 -- argument being passed to it. This function will, if necessary, generate
400 -- a conversion between the partial and full view of Arg to match the type
401 -- of the formal of Proc, or force a conversion to the class-wide type in
402 -- the case where the operation is abstract.
408 Skip_Self : Boolean := False) return Node_Id;
409 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
410 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
411 -- an adjust or finalization call. When flag Skip_Self is set, the related
412 -- action has an effect on the components only (if any).
414 function Make_Deep_Proc
415 (Prim : Final_Primitives;
417 Stmts : List_Id) return Entity_Id;
418 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
419 -- Deep_Finalize procedures according to the first parameter. These
420 -- procedures operate on the type Typ. The Stmts parameter gives the
421 -- body of the procedure.
423 function Make_Deep_Array_Body
424 (Prim : Final_Primitives;
425 Typ : Entity_Id) return List_Id;
426 -- This function generates the list of statements for implementing
427 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
428 -- the first parameter, these procedures operate on the array type Typ.
430 function Make_Deep_Record_Body
431 (Prim : Final_Primitives;
433 Is_Local : Boolean := False) return List_Id;
434 -- This function generates the list of statements for implementing
435 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
436 -- the first parameter, these procedures operate on the record type Typ.
437 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
438 -- whether the inner logic should be dictated by state counters.
440 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
441 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
442 -- Make_Deep_Record_Body. Generate the following statements:
445 -- type Acc_Typ is access all Typ;
446 -- for Acc_Typ'Storage_Size use 0;
448 -- [Deep_]Finalize (Acc_Typ (V).all);
451 --------------------------------
452 -- Allows_Finalization_Master --
453 --------------------------------
455 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is
456 function In_Deallocation_Instance (E : Entity_Id) return Boolean;
457 -- Determine whether entity E is inside a wrapper package created for
458 -- an instance of Ada.Unchecked_Deallocation.
460 ------------------------------
461 -- In_Deallocation_Instance --
462 ------------------------------
464 function In_Deallocation_Instance (E : Entity_Id) return Boolean is
465 Pkg : constant Entity_Id := Scope (E);
466 Par : Node_Id := Empty;
469 if Ekind (Pkg) = E_Package
470 and then Present (Related_Instance (Pkg))
471 and then Ekind (Related_Instance (Pkg)) = E_Procedure
473 Par := Generic_Parent (Parent (Related_Instance (Pkg)));
477 and then Chars (Par) = Name_Unchecked_Deallocation
478 and then Chars (Scope (Par)) = Name_Ada
479 and then Scope (Scope (Par)) = Standard_Standard;
483 end In_Deallocation_Instance;
487 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
488 Ptr_Typ : constant Entity_Id :=
489 Root_Type_Of_Full_View (Base_Type (Typ));
491 -- Start of processing for Allows_Finalization_Master
494 -- Certain run-time configurations and targets do not provide support
495 -- for controlled types and therefore do not need masters.
497 if Restriction_Active (No_Finalization) then
500 -- Do not consider C and C++ types since it is assumed that the non-Ada
501 -- side will handle their cleanup.
503 elsif Convention (Desig_Typ) = Convention_C
504 or else Convention (Desig_Typ) = Convention_CPP
508 -- Do not consider an access type that returns on the secondary stack
510 elsif Present (Associated_Storage_Pool (Ptr_Typ))
511 and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
515 -- Do not consider an access type that can never allocate an object
517 elsif No_Pool_Assigned (Ptr_Typ) then
520 -- Do not consider an access type coming from an Unchecked_Deallocation
521 -- instance. Even though the designated type may be controlled, the
522 -- access type will never participate in any allocations.
524 elsif In_Deallocation_Instance (Ptr_Typ) then
527 -- Do not consider a non-library access type when No_Nested_Finalization
528 -- is in effect since finalization masters are controlled objects and if
529 -- created will violate the restriction.
531 elsif Restriction_Active (No_Nested_Finalization)
532 and then not Is_Library_Level_Entity (Ptr_Typ)
536 -- Do not consider an access type subject to pragma No_Heap_Finalization
537 -- because objects allocated through such a type are not to be finalized
538 -- when the access type goes out of scope.
540 elsif No_Heap_Finalization (Ptr_Typ) then
543 -- Do not create finalization masters in GNATprove mode because this
544 -- causes unwanted extra expansion. A compilation in this mode must
545 -- keep the tree as close as possible to the original sources.
547 elsif GNATprove_Mode then
550 -- Otherwise the access type may use a finalization master
555 end Allows_Finalization_Master;
557 ----------------------------
558 -- Build_Anonymous_Master --
559 ----------------------------
561 procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is
562 function Create_Anonymous_Master
563 (Desig_Typ : Entity_Id;
565 Unit_Decl : Node_Id) return Entity_Id;
566 -- Create a new anonymous master for access type Ptr_Typ with designated
567 -- type Desig_Typ. The declaration of the master and its initialization
568 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
569 -- the entity of Unit_Decl.
571 function Current_Anonymous_Master
572 (Desig_Typ : Entity_Id;
573 Unit_Id : Entity_Id) return Entity_Id;
574 -- Find an anonymous master declared within unit Unit_Id which services
575 -- designated type Desig_Typ. If there is no such master, return Empty.
577 -----------------------------
578 -- Create_Anonymous_Master --
579 -----------------------------
581 function Create_Anonymous_Master
582 (Desig_Typ : Entity_Id;
584 Unit_Decl : Node_Id) return Entity_Id
586 Loc : constant Source_Ptr := Sloc (Unit_Id);
597 -- <FM_Id> : Finalization_Master;
599 FM_Id := Make_Temporary (Loc, 'A');
602 Make_Object_Declaration (Loc,
603 Defining_Identifier => FM_Id,
605 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
609 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
612 Make_Procedure_Call_Statement (Loc,
614 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
615 Parameter_Associations => New_List (
616 New_Occurrence_Of (FM_Id, Loc),
617 Make_Attribute_Reference (Loc,
619 New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
620 Attribute_Name => Name_Unrestricted_Access)));
622 -- Find the declarative list of the unit
624 if Nkind (Unit_Decl) = N_Package_Declaration then
625 Unit_Spec := Specification (Unit_Decl);
626 Decls := Visible_Declarations (Unit_Spec);
630 Set_Visible_Declarations (Unit_Spec, Decls);
633 -- Package body or subprogram case
635 -- ??? A subprogram spec or body that acts as a compilation unit may
636 -- contain a formal parameter of an anonymous access-to-controlled
637 -- type initialized by an allocator.
639 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
641 -- There is no suitable place to create the master as the subprogram
642 -- is not in a declarative list.
645 Decls := Declarations (Unit_Decl);
649 Set_Declarations (Unit_Decl, Decls);
653 Prepend_To (Decls, FM_Init);
654 Prepend_To (Decls, FM_Decl);
656 -- Use the scope of the unit when analyzing the declaration of the
657 -- master and its initialization actions.
659 Push_Scope (Unit_Id);
664 -- Mark the master as servicing this specific designated type
666 Set_Anonymous_Designated_Type (FM_Id, Desig_Typ);
668 -- Include the anonymous master in the list of existing masters which
669 -- appear in this unit. This effectively creates a mapping between a
670 -- master and a designated type which in turn allows for the reuse of
671 -- masters on a per-unit basis.
673 All_FMs := Anonymous_Masters (Unit_Id);
676 All_FMs := New_Elmt_List;
677 Set_Anonymous_Masters (Unit_Id, All_FMs);
680 Prepend_Elmt (FM_Id, All_FMs);
683 end Create_Anonymous_Master;
685 ------------------------------
686 -- Current_Anonymous_Master --
687 ------------------------------
689 function Current_Anonymous_Master
690 (Desig_Typ : Entity_Id;
691 Unit_Id : Entity_Id) return Entity_Id
693 All_FMs : constant Elist_Id := Anonymous_Masters (Unit_Id);
698 -- Inspect the list of anonymous masters declared within the unit
699 -- looking for an existing master which services the same designated
702 if Present (All_FMs) then
703 FM_Elmt := First_Elmt (All_FMs);
704 while Present (FM_Elmt) loop
705 FM_Id := Node (FM_Elmt);
707 -- The currect master services the same designated type. As a
708 -- result the master can be reused and associated with another
709 -- anonymous access-to-controlled type.
711 if Anonymous_Designated_Type (FM_Id) = Desig_Typ then
720 end Current_Anonymous_Master;
724 Desig_Typ : Entity_Id;
726 Priv_View : Entity_Id;
730 -- Start of processing for Build_Anonymous_Master
733 -- Nothing to do if the circumstances do not allow for a finalization
736 if not Allows_Finalization_Master (Ptr_Typ) then
740 Unit_Decl := Unit (Cunit (Current_Sem_Unit));
741 Unit_Id := Unique_Defining_Entity (Unit_Decl);
743 -- The compilation unit is a package instantiation. In this case the
744 -- anonymous master is associated with the package spec as both the
745 -- spec and body appear at the same level.
747 if Nkind (Unit_Decl) = N_Package_Body
748 and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
750 Unit_Id := Corresponding_Spec (Unit_Decl);
751 Unit_Decl := Unit_Declaration_Node (Unit_Id);
754 -- Use the initial declaration of the designated type when it denotes
755 -- the full view of an incomplete or private type. This ensures that
756 -- types with one and two views are treated the same.
758 Desig_Typ := Directly_Designated_Type (Ptr_Typ);
759 Priv_View := Incomplete_Or_Partial_View (Desig_Typ);
761 if Present (Priv_View) then
762 Desig_Typ := Priv_View;
765 -- Determine whether the current semantic unit already has an anonymous
766 -- master which services the designated type.
768 FM_Id := Current_Anonymous_Master (Desig_Typ, Unit_Id);
770 -- If this is not the case, create a new master
773 FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl);
776 Set_Finalization_Master (Ptr_Typ, FM_Id);
777 end Build_Anonymous_Master;
779 ----------------------------
780 -- Build_Array_Deep_Procs --
781 ----------------------------
783 procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
787 (Prim => Initialize_Case,
789 Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
791 if not Is_Inherently_Limited_Type (Typ) then
794 (Prim => Adjust_Case,
796 Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
799 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
800 -- suppressed since these routine will not be used.
802 if not Restriction_Active (No_Finalization) then
805 (Prim => Finalize_Case,
807 Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
809 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
811 if not CodePeer_Mode then
814 (Prim => Address_Case,
816 Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
819 end Build_Array_Deep_Procs;
821 ------------------------------
822 -- Build_Cleanup_Statements --
823 ------------------------------
825 function Build_Cleanup_Statements
827 Additional_Cleanup : List_Id) return List_Id
829 Is_Asynchronous_Call : constant Boolean :=
830 Nkind (N) = N_Block_Statement and then Is_Asynchronous_Call_Block (N);
831 Is_Master : constant Boolean :=
832 Nkind (N) /= N_Entry_Body and then Is_Task_Master (N);
833 Is_Protected_Subp_Body : constant Boolean :=
834 Nkind (N) = N_Subprogram_Body
835 and then Is_Protected_Subprogram_Body (N);
836 Is_Task_Allocation : constant Boolean :=
837 Nkind (N) = N_Block_Statement and then Is_Task_Allocation_Block (N);
838 Is_Task_Body : constant Boolean :=
839 Nkind (Original_Node (N)) = N_Task_Body;
841 Loc : constant Source_Ptr := Sloc (N);
842 Stmts : constant List_Id := New_List;
846 if Restricted_Profile then
848 Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
850 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task));
854 if Restriction_Active (No_Task_Hierarchy) = False then
855 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
858 -- Add statements to unlock the protected object parameter and to
859 -- undefer abort. If the context is a protected procedure and the object
860 -- has entries, call the entry service routine.
862 -- NOTE: The generated code references _object, a parameter to the
865 elsif Is_Protected_Subp_Body then
867 Spec : constant Node_Id := Parent (Corresponding_Spec (N));
868 Conc_Typ : Entity_Id := Empty;
870 Param_Typ : Entity_Id;
873 -- Find the _object parameter representing the protected object
875 Param := First (Parameter_Specifications (Spec));
877 Param_Typ := Etype (Parameter_Type (Param));
879 if Ekind (Param_Typ) = E_Record_Type then
880 Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
883 exit when No (Param) or else Present (Conc_Typ);
887 pragma Assert (Present (Param));
888 pragma Assert (Present (Conc_Typ));
890 Build_Protected_Subprogram_Call_Cleanup
891 (Specification (N), Conc_Typ, Loc, Stmts);
894 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
895 -- tasks. Other unactivated tasks are completed by Complete_Task or
898 -- NOTE: The generated code references _chain, a local object
900 elsif Is_Task_Allocation then
903 -- Expunge_Unactivated_Tasks (_chain);
905 -- where _chain is the list of tasks created by the allocator but not
906 -- yet activated. This list will be empty unless the block completes
910 Make_Procedure_Call_Statement (Loc,
913 (RTE (RE_Expunge_Unactivated_Tasks), Loc),
914 Parameter_Associations => New_List (
915 New_Occurrence_Of (Activation_Chain_Entity (N), Loc))));
917 -- Attempt to cancel an asynchronous entry call whenever the block which
918 -- contains the abortable part is exited.
920 -- NOTE: The generated code references Cnn, a local object
922 elsif Is_Asynchronous_Call then
924 Cancel_Param : constant Entity_Id :=
925 Entry_Cancel_Parameter (Entity (Identifier (N)));
928 -- If it is of type Communication_Block, this must be a protected
929 -- entry call. Generate:
931 -- if Enqueued (Cancel_Param) then
932 -- Cancel_Protected_Entry_Call (Cancel_Param);
935 if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
937 Make_If_Statement (Loc,
939 Make_Function_Call (Loc,
941 New_Occurrence_Of (RTE (RE_Enqueued), Loc),
942 Parameter_Associations => New_List (
943 New_Occurrence_Of (Cancel_Param, Loc))),
945 Then_Statements => New_List (
946 Make_Procedure_Call_Statement (Loc,
949 (RTE (RE_Cancel_Protected_Entry_Call), Loc),
950 Parameter_Associations => New_List (
951 New_Occurrence_Of (Cancel_Param, Loc))))));
953 -- Asynchronous delay, generate:
954 -- Cancel_Async_Delay (Cancel_Param);
956 elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
958 Make_Procedure_Call_Statement (Loc,
960 New_Occurrence_Of (RTE (RE_Cancel_Async_Delay), Loc),
961 Parameter_Associations => New_List (
962 Make_Attribute_Reference (Loc,
964 New_Occurrence_Of (Cancel_Param, Loc),
965 Attribute_Name => Name_Unchecked_Access))));
967 -- Task entry call, generate:
968 -- Cancel_Task_Entry_Call (Cancel_Param);
972 Make_Procedure_Call_Statement (Loc,
974 New_Occurrence_Of (RTE (RE_Cancel_Task_Entry_Call), Loc),
975 Parameter_Associations => New_List (
976 New_Occurrence_Of (Cancel_Param, Loc))));
981 Append_List_To (Stmts, Additional_Cleanup);
983 end Build_Cleanup_Statements;
985 -----------------------------
986 -- Build_Controlling_Procs --
987 -----------------------------
989 procedure Build_Controlling_Procs (Typ : Entity_Id) is
991 if Is_Array_Type (Typ) then
992 Build_Array_Deep_Procs (Typ);
993 else pragma Assert (Is_Record_Type (Typ));
994 Build_Record_Deep_Procs (Typ);
996 end Build_Controlling_Procs;
998 -----------------------------
999 -- Build_Exception_Handler --
1000 -----------------------------
1002 function Build_Exception_Handler
1003 (Data : Finalization_Exception_Data;
1004 For_Library : Boolean := False) return Node_Id
1007 Proc_To_Call : Entity_Id;
1012 pragma Assert (Present (Data.Raised_Id));
1014 if Exception_Extra_Info
1015 or else (For_Library and not Restricted_Profile)
1017 if Exception_Extra_Info then
1021 -- Get_Current_Excep.all
1024 Make_Function_Call (Data.Loc,
1026 Make_Explicit_Dereference (Data.Loc,
1029 (RTE (RE_Get_Current_Excep), Data.Loc)));
1036 Except := Make_Null (Data.Loc);
1039 if For_Library and then not Restricted_Profile then
1040 Proc_To_Call := RTE (RE_Save_Library_Occurrence);
1041 Actuals := New_List (Except);
1044 Proc_To_Call := RTE (RE_Save_Occurrence);
1046 -- The dereference occurs only when Exception_Extra_Info is true,
1047 -- and therefore Except is not null.
1051 New_Occurrence_Of (Data.E_Id, Data.Loc),
1052 Make_Explicit_Dereference (Data.Loc, Except));
1058 -- if not Raised_Id then
1059 -- Raised_Id := True;
1061 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1063 -- Save_Library_Occurrence (Get_Current_Excep.all);
1068 Make_If_Statement (Data.Loc,
1070 Make_Op_Not (Data.Loc,
1071 Right_Opnd => New_Occurrence_Of (Data.Raised_Id, Data.Loc)),
1073 Then_Statements => New_List (
1074 Make_Assignment_Statement (Data.Loc,
1075 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
1076 Expression => New_Occurrence_Of (Standard_True, Data.Loc)),
1078 Make_Procedure_Call_Statement (Data.Loc,
1080 New_Occurrence_Of (Proc_To_Call, Data.Loc),
1081 Parameter_Associations => Actuals))));
1086 -- Raised_Id := True;
1089 Make_Assignment_Statement (Data.Loc,
1090 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
1091 Expression => New_Occurrence_Of (Standard_True, Data.Loc)));
1099 Make_Exception_Handler (Data.Loc,
1100 Exception_Choices => New_List (Make_Others_Choice (Data.Loc)),
1101 Statements => Stmts);
1102 end Build_Exception_Handler;
1104 -------------------------------
1105 -- Build_Finalization_Master --
1106 -------------------------------
1108 procedure Build_Finalization_Master
1110 For_Lib_Level : Boolean := False;
1111 For_Private : Boolean := False;
1112 Context_Scope : Entity_Id := Empty;
1113 Insertion_Node : Node_Id := Empty)
1115 procedure Add_Pending_Access_Type
1117 Ptr_Typ : Entity_Id);
1118 -- Add access type Ptr_Typ to the pending access type list for type Typ
1120 -----------------------------
1121 -- Add_Pending_Access_Type --
1122 -----------------------------
1124 procedure Add_Pending_Access_Type
1126 Ptr_Typ : Entity_Id)
1131 if Present (Pending_Access_Types (Typ)) then
1132 List := Pending_Access_Types (Typ);
1134 List := New_Elmt_List;
1135 Set_Pending_Access_Types (Typ, List);
1138 Prepend_Elmt (Ptr_Typ, List);
1139 end Add_Pending_Access_Type;
1143 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
1145 Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ));
1146 -- A finalization master created for a named access type is associated
1147 -- with the full view (if applicable) as a consequence of freezing. The
1148 -- full view criteria does not apply to anonymous access types because
1149 -- those cannot have a private and a full view.
1151 -- Start of processing for Build_Finalization_Master
1154 -- Nothing to do if the circumstances do not allow for a finalization
1157 if not Allows_Finalization_Master (Typ) then
1160 -- Various machinery such as freezing may have already created a
1161 -- finalization master.
1163 elsif Present (Finalization_Master (Ptr_Typ)) then
1168 Actions : constant List_Id := New_List;
1169 Loc : constant Source_Ptr := Sloc (Ptr_Typ);
1170 Fin_Mas_Id : Entity_Id;
1171 Pool_Id : Entity_Id;
1174 -- Source access types use fixed master names since the master is
1175 -- inserted in the same source unit only once. The only exception to
1176 -- this are instances using the same access type as generic actual.
1178 if Comes_From_Source (Ptr_Typ) and then not Inside_A_Generic then
1180 Make_Defining_Identifier (Loc,
1181 Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
1183 -- Internally generated access types use temporaries as their names
1184 -- due to possible collision with identical names coming from other
1188 Fin_Mas_Id := Make_Temporary (Loc, 'F');
1191 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
1194 -- <Ptr_Typ>FM : aliased Finalization_Master;
1197 Make_Object_Declaration (Loc,
1198 Defining_Identifier => Fin_Mas_Id,
1199 Aliased_Present => True,
1200 Object_Definition =>
1201 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
1203 if Debug_Generated_Code then
1204 Set_Debug_Info_Needed (Fin_Mas_Id);
1207 -- Set the associated pool and primitive Finalize_Address of the new
1208 -- finalization master.
1210 -- The access type has a user-defined storage pool, use it
1212 if Present (Associated_Storage_Pool (Ptr_Typ)) then
1213 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
1215 -- Otherwise the default choice is the global storage pool
1218 Pool_Id := RTE (RE_Global_Pool_Object);
1219 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
1223 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1226 Make_Procedure_Call_Statement (Loc,
1228 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
1229 Parameter_Associations => New_List (
1230 New_Occurrence_Of (Fin_Mas_Id, Loc),
1231 Make_Attribute_Reference (Loc,
1232 Prefix => New_Occurrence_Of (Pool_Id, Loc),
1233 Attribute_Name => Name_Unrestricted_Access))));
1235 -- Finalize_Address is not generated in CodePeer mode because the
1236 -- body contains address arithmetic. Skip this step.
1238 if CodePeer_Mode then
1241 -- Associate the Finalize_Address primitive of the designated type
1242 -- with the finalization master of the access type. The designated
1243 -- type must be forzen as Finalize_Address is generated when the
1244 -- freeze node is expanded.
1246 elsif Is_Frozen (Desig_Typ)
1247 and then Present (Finalize_Address (Desig_Typ))
1249 -- The finalization master of an anonymous access type may need
1250 -- to be inserted in a specific place in the tree. For instance:
1254 -- <finalization master of "access Comp_Typ">
1256 -- type Rec_Typ is record
1257 -- Comp : access Comp_Typ;
1260 -- <freeze node for Comp_Typ>
1261 -- <freeze node for Rec_Typ>
1263 -- Due to this oddity, the anonymous access type is stored for
1264 -- later processing (see below).
1266 and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type
1269 -- Set_Finalize_Address
1270 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1273 Make_Set_Finalize_Address_Call
1275 Ptr_Typ => Ptr_Typ));
1277 -- Otherwise the designated type is either anonymous access or a
1278 -- Taft-amendment type and has not been frozen. Store the access
1279 -- type for later processing (see Freeze_Type).
1282 Add_Pending_Access_Type (Desig_Typ, Ptr_Typ);
1285 -- A finalization master created for an access designating a type
1286 -- with private components is inserted before a context-dependent
1291 -- At this point both the scope of the context and the insertion
1292 -- mode must be known.
1294 pragma Assert (Present (Context_Scope));
1295 pragma Assert (Present (Insertion_Node));
1297 Push_Scope (Context_Scope);
1299 -- Treat use clauses as declarations and insert directly in front
1302 if Nkind (Insertion_Node) in
1303 N_Use_Package_Clause | N_Use_Type_Clause
1305 Insert_List_Before_And_Analyze (Insertion_Node, Actions);
1307 Insert_Actions (Insertion_Node, Actions);
1312 -- The finalization master belongs to an access result type related
1313 -- to a build-in-place function call used to initialize a library
1314 -- level object. The master must be inserted in front of the access
1315 -- result type declaration denoted by Insertion_Node.
1317 elsif For_Lib_Level then
1318 pragma Assert (Present (Insertion_Node));
1319 Insert_Actions (Insertion_Node, Actions);
1321 -- Otherwise the finalization master and its initialization become a
1322 -- part of the freeze node.
1325 Append_Freeze_Actions (Ptr_Typ, Actions);
1328 Analyze_List (Actions);
1330 -- When the type the finalization master is being generated for was
1331 -- created to store a 'Old object, then mark it as such so its
1332 -- finalization can be delayed until after postconditions have been
1335 if Stores_Attribute_Old_Prefix (Ptr_Typ) then
1336 Set_Stores_Attribute_Old_Prefix (Fin_Mas_Id);
1339 end Build_Finalization_Master;
1341 ---------------------
1342 -- Build_Finalizer --
1343 ---------------------
1345 procedure Build_Finalizer
1347 Clean_Stmts : List_Id;
1348 Mark_Id : Entity_Id;
1349 Top_Decls : List_Id;
1350 Defer_Abort : Boolean;
1351 Fin_Id : out Entity_Id)
1353 Acts_As_Clean : constant Boolean :=
1356 (Present (Clean_Stmts)
1357 and then Is_Non_Empty_List (Clean_Stmts));
1359 For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
1360 For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
1361 For_Package : constant Boolean :=
1362 For_Package_Body or else For_Package_Spec;
1363 Loc : constant Source_Ptr := Sloc (N);
1365 -- NOTE: Local variable declarations are conservative and do not create
1366 -- structures right from the start. Entities and lists are created once
1367 -- it has been established that N has at least one controlled object.
1369 Components_Built : Boolean := False;
1370 -- A flag used to avoid double initialization of entities and lists. If
1371 -- the flag is set then the following variables have been initialized:
1377 Counter_Id : Entity_Id := Empty;
1378 Counter_Val : Nat := 0;
1379 -- Name and value of the state counter
1381 Decls : List_Id := No_List;
1382 -- Declarative region of N (if available). If N is a package declaration
1383 -- Decls denotes the visible declarations.
1385 Finalizer_Data : Finalization_Exception_Data;
1386 -- Data for the exception
1388 Finalizer_Decls : List_Id := No_List;
1389 -- Local variable declarations. This list holds the label declarations
1390 -- of all jump block alternatives as well as the declaration of the
1391 -- local exception occurrence and the raised flag:
1392 -- E : Exception_Occurrence;
1393 -- Raised : Boolean := False;
1394 -- L<counter value> : label;
1396 Finalizer_Insert_Nod : Node_Id := Empty;
1397 -- Insertion point for the finalizer body. Depending on the context
1398 -- (Nkind of N) and the individual grouping of controlled objects, this
1399 -- node may denote a package declaration or body, package instantiation,
1400 -- block statement or a counter update statement.
1402 Finalizer_Stmts : List_Id := No_List;
1403 -- The statement list of the finalizer body. It contains the following:
1405 -- Abort_Defer; -- Added if abort is allowed
1406 -- <call to Prev_At_End> -- Added if exists
1407 -- <cleanup statements> -- Added if Acts_As_Clean
1408 -- <jump block> -- Added if Has_Ctrl_Objs
1409 -- <finalization statements> -- Added if Has_Ctrl_Objs
1410 -- <stack release> -- Added if Mark_Id exists
1411 -- Abort_Undefer; -- Added if abort is allowed
1413 Has_Ctrl_Objs : Boolean := False;
1414 -- A general flag which denotes whether N has at least one controlled
1417 Has_Tagged_Types : Boolean := False;
1418 -- A general flag which indicates whether N has at least one library-
1419 -- level tagged type declaration.
1421 HSS : Node_Id := Empty;
1422 -- The sequence of statements of N (if available)
1424 Jump_Alts : List_Id := No_List;
1425 -- Jump block alternatives. Depending on the value of the state counter,
1426 -- the control flow jumps to a sequence of finalization statements. This
1427 -- list contains the following:
1429 -- when <counter value> =>
1430 -- goto L<counter value>;
1432 Jump_Block_Insert_Nod : Node_Id := Empty;
1433 -- Specific point in the finalizer statements where the jump block is
1436 Last_Top_Level_Ctrl_Construct : Node_Id := Empty;
1437 -- The last controlled construct encountered when processing the top
1438 -- level lists of N. This can be a nested package, an instantiation or
1439 -- an object declaration.
1441 Prev_At_End : Entity_Id := Empty;
1442 -- The previous at end procedure of the handled statements block of N
1444 Priv_Decls : List_Id := No_List;
1445 -- The private declarations of N if N is a package declaration
1447 Spec_Id : Entity_Id := Empty;
1448 Spec_Decls : List_Id := Top_Decls;
1449 Stmts : List_Id := No_List;
1451 Tagged_Type_Stmts : List_Id := No_List;
1452 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1453 -- tagged types found in N.
1455 -----------------------
1456 -- Local subprograms --
1457 -----------------------
1459 procedure Build_Components;
1460 -- Create all entites and initialize all lists used in the creation of
1463 procedure Create_Finalizer;
1464 -- Create the spec and body of the finalizer and insert them in the
1465 -- proper place in the tree depending on the context.
1467 function New_Finalizer_Name
1468 (Spec_Id : Node_Id; For_Spec : Boolean) return Name_Id;
1469 -- Create a fully qualified name of a package spec or body finalizer.
1470 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1472 procedure Process_Declarations
1474 Preprocess : Boolean := False;
1475 Top_Level : Boolean := False);
1476 -- Inspect a list of declarations or statements which may contain
1477 -- objects that need finalization. When flag Preprocess is set, the
1478 -- routine will simply count the total number of controlled objects in
1479 -- Decls and set Counter_Val accordingly. Top_Level is only relevant
1480 -- when Preprocess is set and if True, the processing is performed for
1481 -- objects in nested package declarations or instances.
1483 procedure Process_Object_Declaration
1485 Has_No_Init : Boolean := False;
1486 Is_Protected : Boolean := False);
1487 -- Generate all the machinery associated with the finalization of a
1488 -- single object. Flag Has_No_Init is used to denote certain contexts
1489 -- where Decl does not have initialization call(s). Flag Is_Protected
1490 -- is set when Decl denotes a simple protected object.
1492 procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
1493 -- Generate all the code necessary to unregister the external tag of a
1496 ----------------------
1497 -- Build_Components --
1498 ----------------------
1500 procedure Build_Components is
1501 Counter_Decl : Node_Id;
1502 Counter_Typ : Entity_Id;
1503 Counter_Typ_Decl : Node_Id;
1506 pragma Assert (Present (Decls));
1508 -- This routine might be invoked several times when dealing with
1509 -- constructs that have two lists (either two declarative regions
1510 -- or declarations and statements). Avoid double initialization.
1512 if Components_Built then
1516 Components_Built := True;
1518 if Has_Ctrl_Objs then
1520 -- Create entities for the counter, its type, the local exception
1521 -- and the raised flag.
1523 Counter_Id := Make_Temporary (Loc, 'C');
1524 Counter_Typ := Make_Temporary (Loc, 'T');
1526 Finalizer_Decls := New_List;
1528 Build_Object_Declarations
1529 (Finalizer_Data, Finalizer_Decls, Loc, For_Package);
1531 -- Since the total number of controlled objects is always known,
1532 -- build a subtype of Natural with precise bounds. This allows
1533 -- the backend to optimize the case statement. Generate:
1535 -- subtype Tnn is Natural range 0 .. Counter_Val;
1538 Make_Subtype_Declaration (Loc,
1539 Defining_Identifier => Counter_Typ,
1540 Subtype_Indication =>
1541 Make_Subtype_Indication (Loc,
1542 Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
1544 Make_Range_Constraint (Loc,
1548 Make_Integer_Literal (Loc, Uint_0),
1550 Make_Integer_Literal (Loc, Counter_Val)))));
1552 -- Generate the declaration of the counter itself:
1554 -- Counter : Integer := 0;
1557 Make_Object_Declaration (Loc,
1558 Defining_Identifier => Counter_Id,
1559 Object_Definition => New_Occurrence_Of (Counter_Typ, Loc),
1560 Expression => Make_Integer_Literal (Loc, 0));
1562 -- Set the type of the counter explicitly to prevent errors when
1563 -- examining object declarations later on.
1565 Set_Etype (Counter_Id, Counter_Typ);
1567 if Debug_Generated_Code then
1568 Set_Debug_Info_Needed (Counter_Id);
1571 -- The counter and its type are inserted before the source
1572 -- declarations of N.
1574 Prepend_To (Decls, Counter_Decl);
1575 Prepend_To (Decls, Counter_Typ_Decl);
1577 -- The counter and its associated type must be manually analyzed
1578 -- since N has already been analyzed.
1580 Analyze (Counter_Typ_Decl);
1581 Analyze (Counter_Decl);
1583 Jump_Alts := New_List;
1586 -- If the context requires additional cleanup, the finalization
1587 -- machinery is added after the cleanup code.
1589 if Acts_As_Clean then
1590 Finalizer_Stmts := Clean_Stmts;
1591 Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
1593 Finalizer_Stmts := New_List;
1596 if Has_Tagged_Types then
1597 Tagged_Type_Stmts := New_List;
1599 end Build_Components;
1601 ----------------------
1602 -- Create_Finalizer --
1603 ----------------------
1605 procedure Create_Finalizer is
1606 Body_Id : Entity_Id;
1609 Jump_Block : Node_Id;
1611 Label_Id : Entity_Id;
1614 -- Step 1: Creation of the finalizer name
1616 -- Packages must use a distinct name for their finalizers since the
1617 -- binder will have to generate calls to them by name. The name is
1618 -- of the following form:
1620 -- xx__yy__finalize_[spec|body]
1623 Fin_Id := Make_Defining_Identifier
1624 (Loc, New_Finalizer_Name (Spec_Id, For_Package_Spec));
1625 Set_Has_Qualified_Name (Fin_Id);
1626 Set_Has_Fully_Qualified_Name (Fin_Id);
1628 -- The default name is _finalizer
1631 -- Generation of a finalization procedure exclusively for 'Old
1632 -- interally generated constants requires different name since
1633 -- there will need to be multiple finalization routines in the
1634 -- same scope. See Build_Finalizer for details.
1637 Make_Defining_Identifier (Loc,
1638 Chars => New_External_Name (Name_uFinalizer));
1640 -- The visibility semantics of AT_END handlers force a strange
1641 -- separation of spec and body for stack-related finalizers:
1643 -- declare : Enclosing_Scope
1644 -- procedure _finalizer;
1646 -- <controlled objects>
1647 -- procedure _finalizer is
1653 -- Both spec and body are within the same construct and scope, but
1654 -- the body is part of the handled sequence of statements. This
1655 -- placement confuses the elaboration mechanism on targets where
1656 -- AT_END handlers are expanded into "when all others" handlers:
1659 -- when all others =>
1660 -- _finalizer; -- appears to require elab checks
1665 -- Since the compiler guarantees that the body of a _finalizer is
1666 -- always inserted in the same construct where the AT_END handler
1667 -- resides, there is no need for elaboration checks.
1669 Set_Kill_Elaboration_Checks (Fin_Id);
1671 -- Inlining the finalizer produces a substantial speedup at -O2.
1672 -- It is inlined by default at -O3. Either way, it is called
1673 -- exactly twice (once on the normal path, and once for
1674 -- exceptions/abort), so this won't bloat the code too much.
1676 Set_Is_Inlined (Fin_Id);
1679 if Debug_Generated_Code then
1680 Set_Debug_Info_Needed (Fin_Id);
1683 -- Step 2: Creation of the finalizer specification
1686 -- procedure Fin_Id;
1689 Make_Subprogram_Declaration (Loc,
1691 Make_Procedure_Specification (Loc,
1692 Defining_Unit_Name => Fin_Id));
1695 Set_Is_Exported (Fin_Id);
1696 Set_Interface_Name (Fin_Id,
1697 Make_String_Literal (Loc,
1698 Strval => Get_Name_String (Chars (Fin_Id))));
1701 -- Step 3: Creation of the finalizer body
1703 -- Has_Ctrl_Objs might be set because of a generic package body having
1704 -- controlled objects. In this case, Jump_Alts may be empty and no
1705 -- case nor goto statements are needed.
1708 and then not Is_Empty_List (Jump_Alts)
1710 -- Add L0, the default destination to the jump block
1712 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
1713 Set_Entity (Label_Id,
1714 Make_Defining_Identifier (Loc, Chars (Label_Id)));
1715 Label := Make_Label (Loc, Label_Id);
1720 Prepend_To (Finalizer_Decls,
1721 Make_Implicit_Label_Declaration (Loc,
1722 Defining_Identifier => Entity (Label_Id),
1723 Label_Construct => Label));
1729 Append_To (Jump_Alts,
1730 Make_Case_Statement_Alternative (Loc,
1731 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1732 Statements => New_List (
1733 Make_Goto_Statement (Loc,
1734 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
1739 Append_To (Finalizer_Stmts, Label);
1741 -- Create the jump block which controls the finalization flow
1742 -- depending on the value of the state counter.
1745 Make_Case_Statement (Loc,
1746 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
1747 Alternatives => Jump_Alts);
1749 if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then
1750 Insert_After (Jump_Block_Insert_Nod, Jump_Block);
1752 Prepend_To (Finalizer_Stmts, Jump_Block);
1756 -- Add the library-level tagged type unregistration machinery before
1757 -- the jump block circuitry. This ensures that external tags will be
1758 -- removed even if a finalization exception occurs at some point.
1760 if Has_Tagged_Types then
1761 Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
1764 -- Add a call to the previous At_End handler if it exists. The call
1765 -- must always precede the jump block.
1767 if Present (Prev_At_End) then
1768 Prepend_To (Finalizer_Stmts,
1769 Make_Procedure_Call_Statement (Loc, Prev_At_End));
1771 -- Clear the At_End handler since we have already generated the
1772 -- proper replacement call for it.
1774 Set_At_End_Proc (HSS, Empty);
1777 -- Release the secondary stack
1779 if Present (Mark_Id) then
1781 Release : Node_Id := Build_SS_Release_Call (Loc, Mark_Id);
1784 -- If the context is a build-in-place function, the secondary
1785 -- stack must be released, unless the build-in-place function
1786 -- itself is returning on the secondary stack. Generate:
1788 -- if BIP_Alloc_Form /= Secondary_Stack then
1789 -- SS_Release (Mark_Id);
1792 -- Note that if the function returns on the secondary stack,
1793 -- then the responsibility of reclaiming the space is always
1794 -- left to the caller (recursively if needed).
1796 if Nkind (N) = N_Subprogram_Body then
1798 Spec_Id : constant Entity_Id :=
1799 Unique_Defining_Entity (N);
1800 BIP_SS : constant Boolean :=
1801 Is_Build_In_Place_Function (Spec_Id)
1802 and then Needs_BIP_Alloc_Form (Spec_Id);
1806 Make_If_Statement (Loc,
1811 (Build_In_Place_Formal
1812 (Spec_Id, BIP_Alloc_Form), Loc),
1814 Make_Integer_Literal (Loc,
1816 (BIP_Allocation_Form'Pos
1817 (Secondary_Stack)))),
1819 Then_Statements => New_List (Release));
1824 Append_To (Finalizer_Stmts, Release);
1828 -- Protect the statements with abort defer/undefer. This is only when
1829 -- aborts are allowed and the cleanup statements require deferral or
1830 -- there are controlled objects to be finalized. Note that the abort
1831 -- defer/undefer pair does not require an extra block because each
1832 -- finalization exception is caught in its corresponding finalization
1833 -- block. As a result, the call to Abort_Defer always takes place.
1835 if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then
1836 Prepend_To (Finalizer_Stmts,
1837 Build_Runtime_Call (Loc, RE_Abort_Defer));
1839 Append_To (Finalizer_Stmts,
1840 Build_Runtime_Call (Loc, RE_Abort_Undefer));
1843 -- The local exception does not need to be reraised for library-level
1844 -- finalizers. Note that this action must be carried out after object
1845 -- cleanup, secondary stack release, and abort undeferral. Generate:
1847 -- if Raised and then not Abort then
1848 -- Raise_From_Controlled_Operation (E);
1851 if Has_Ctrl_Objs and Exceptions_OK and not For_Package then
1852 Append_To (Finalizer_Stmts,
1853 Build_Raise_Statement (Finalizer_Data));
1857 -- procedure Fin_Id is
1858 -- Abort : constant Boolean := Triggered_By_Abort;
1860 -- Abort : constant Boolean := False; -- no abort
1862 -- E : Exception_Occurrence; -- All added if flag
1863 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1869 -- Abort_Defer; -- Added if abort is allowed
1870 -- <call to Prev_At_End> -- Added if exists
1871 -- <cleanup statements> -- Added if Acts_As_Clean
1872 -- <jump block> -- Added if Has_Ctrl_Objs
1873 -- <finalization statements> -- Added if Has_Ctrl_Objs
1874 -- <stack release> -- Added if Mark_Id exists
1875 -- Abort_Undefer; -- Added if abort is allowed
1876 -- <exception propagation> -- Added if Has_Ctrl_Objs
1879 -- Create the body of the finalizer
1881 Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
1883 if Debug_Generated_Code then
1884 Set_Debug_Info_Needed (Body_Id);
1888 Set_Has_Qualified_Name (Body_Id);
1889 Set_Has_Fully_Qualified_Name (Body_Id);
1893 Make_Subprogram_Body (Loc,
1895 Make_Procedure_Specification (Loc,
1896 Defining_Unit_Name => Body_Id),
1897 Declarations => Finalizer_Decls,
1898 Handled_Statement_Sequence =>
1899 Make_Handled_Sequence_Of_Statements (Loc,
1900 Statements => Finalizer_Stmts));
1902 -- Step 4: Spec and body insertion, analysis
1906 -- If the package spec has private declarations, the finalizer
1907 -- body must be added to the end of the list in order to have
1908 -- visibility of all private controlled objects.
1910 if For_Package_Spec then
1911 if Present (Priv_Decls) then
1912 Append_To (Priv_Decls, Fin_Spec);
1913 Append_To (Priv_Decls, Fin_Body);
1915 Append_To (Decls, Fin_Spec);
1916 Append_To (Decls, Fin_Body);
1919 -- For package bodies, both the finalizer spec and body are
1920 -- inserted at the end of the package declarations.
1923 Append_To (Decls, Fin_Spec);
1924 Append_To (Decls, Fin_Body);
1933 -- Create the spec for the finalizer. The At_End handler must be
1934 -- able to call the body which resides in a nested structure.
1938 -- procedure Fin_Id; -- Spec
1940 -- <objects and possibly statements>
1941 -- procedure Fin_Id is ... -- Body
1944 -- Fin_Id; -- At_End handler
1947 pragma Assert (Present (Spec_Decls));
1949 -- It maybe possible that we are finalizing 'Old objects which
1950 -- exist in the spec declarations. When this is the case the
1951 -- Finalizer_Insert_Node will come before the end of the
1952 -- Spec_Decls. So, to mitigate this, we insert the finalizer spec
1953 -- earlier at the Finalizer_Insert_Nod instead of appending to the
1954 -- end of Spec_Decls to prevent its body appearing before its
1955 -- corresponding spec.
1957 if Present (Finalizer_Insert_Nod)
1958 and then List_Containing (Finalizer_Insert_Nod) = Spec_Decls
1960 Insert_After_And_Analyze (Finalizer_Insert_Nod, Fin_Spec);
1961 Finalizer_Insert_Nod := Fin_Spec;
1963 -- Otherwise, Finalizer_Insert_Nod is not in Spec_Decls
1966 Append_To (Spec_Decls, Fin_Spec);
1970 -- When the finalizer acts solely as a cleanup routine, the body
1971 -- is inserted right after the spec.
1973 if Acts_As_Clean and not Has_Ctrl_Objs then
1974 Insert_After (Fin_Spec, Fin_Body);
1976 -- In all other cases the body is inserted after either:
1978 -- 1) The counter update statement of the last controlled object
1979 -- 2) The last top level nested controlled package
1980 -- 3) The last top level controlled instantiation
1983 -- Manually freeze the spec. This is somewhat of a hack because
1984 -- a subprogram is frozen when its body is seen and the freeze
1985 -- node appears right before the body. However, in this case,
1986 -- the spec must be frozen earlier since the At_End handler
1987 -- must be able to call it.
1990 -- procedure Fin_Id; -- Spec
1991 -- [Fin_Id] -- Freeze node
1995 -- Fin_Id; -- At_End handler
1998 Ensure_Freeze_Node (Fin_Id);
1999 Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
2000 Set_Is_Frozen (Fin_Id);
2002 -- In the case where the last construct to contain a controlled
2003 -- object is either a nested package, an instantiation or a
2004 -- freeze node, the body must be inserted directly after the
2005 -- construct, except if the insertion point is already placed
2006 -- after the construct, typically in the statement list.
2008 if Nkind (Last_Top_Level_Ctrl_Construct) in
2009 N_Freeze_Entity | N_Package_Declaration | N_Package_Body
2011 (List_Containing (Last_Top_Level_Ctrl_Construct) = Spec_Decls
2012 and then Present (Stmts)
2013 and then List_Containing (Finalizer_Insert_Nod) = Stmts)
2015 Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
2018 Insert_After (Finalizer_Insert_Nod, Fin_Body);
2021 Analyze (Fin_Body, Suppress => All_Checks);
2024 -- Never consider that the finalizer procedure is enabled Ghost, even
2025 -- when the corresponding unit is Ghost, as this would lead to an
2026 -- an external name with a ___ghost_ prefix that the binder cannot
2027 -- generate, as it has no knowledge of the Ghost status of units.
2029 Set_Is_Checked_Ghost_Entity (Fin_Id, False);
2030 end Create_Finalizer;
2032 ------------------------
2033 -- New_Finalizer_Name --
2034 ------------------------
2036 function New_Finalizer_Name
2037 (Spec_Id : Node_Id; For_Spec : Boolean) return Name_Id
2039 procedure New_Finalizer_Name (Id : Entity_Id);
2040 -- Place "__<name-of-Id>" in the name buffer. If the identifier
2041 -- has a non-standard scope, process the scope first.
2043 ------------------------
2044 -- New_Finalizer_Name --
2045 ------------------------
2047 procedure New_Finalizer_Name (Id : Entity_Id) is
2049 if Scope (Id) = Standard_Standard then
2050 Get_Name_String (Chars (Id));
2053 New_Finalizer_Name (Scope (Id));
2054 Add_Str_To_Name_Buffer ("__");
2055 Get_Name_String_And_Append (Chars (Id));
2057 end New_Finalizer_Name;
2059 -- Start of processing for New_Finalizer_Name
2062 -- Create the fully qualified name of the enclosing scope
2064 New_Finalizer_Name (Spec_Id);
2067 -- __finalize_[spec|body]
2069 Add_Str_To_Name_Buffer ("__finalize_");
2072 Add_Str_To_Name_Buffer ("spec");
2074 Add_Str_To_Name_Buffer ("body");
2078 end New_Finalizer_Name;
2080 --------------------------
2081 -- Process_Declarations --
2082 --------------------------
2084 procedure Process_Declarations
2086 Preprocess : Boolean := False;
2087 Top_Level : Boolean := False)
2092 Obj_Typ : Entity_Id;
2093 Pack_Id : Entity_Id;
2097 Old_Counter_Val : Nat;
2098 -- This variable is used to determine whether a nested package or
2099 -- instance contains at least one controlled object.
2101 procedure Process_Package_Body (Decl : Node_Id);
2102 -- Process an N_Package_Body node
2104 procedure Processing_Actions
2105 (Has_No_Init : Boolean := False;
2106 Is_Protected : Boolean := False);
2107 -- Depending on the mode of operation of Process_Declarations, either
2108 -- increment the controlled object counter, set the controlled object
2109 -- flag and store the last top level construct or process the current
2110 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2111 -- the current declaration may not have initialization proc(s). Flag
2112 -- Is_Protected should be set when the current declaration denotes a
2113 -- simple protected object.
2115 --------------------------
2116 -- Process_Package_Body --
2117 --------------------------
2119 procedure Process_Package_Body (Decl : Node_Id) is
2121 -- Do not inspect an ignored Ghost package body because all
2122 -- code found within will not appear in the final tree.
2124 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
2127 elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package then
2128 Old_Counter_Val := Counter_Val;
2129 Process_Declarations (Declarations (Decl), Preprocess);
2131 -- The nested package body is the last construct to contain
2132 -- a controlled object.
2136 and then No (Last_Top_Level_Ctrl_Construct)
2137 and then Counter_Val > Old_Counter_Val
2139 Last_Top_Level_Ctrl_Construct := Decl;
2142 end Process_Package_Body;
2144 ------------------------
2145 -- Processing_Actions --
2146 ------------------------
2148 procedure Processing_Actions
2149 (Has_No_Init : Boolean := False;
2150 Is_Protected : Boolean := False)
2153 -- Library-level tagged type
2155 if Nkind (Decl) = N_Full_Type_Declaration then
2157 Has_Tagged_Types := True;
2159 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
2160 Last_Top_Level_Ctrl_Construct := Decl;
2163 -- Unregister tagged type, unless No_Tagged_Type_Registration
2166 elsif not Restriction_Active (No_Tagged_Type_Registration) then
2167 Process_Tagged_Type_Declaration (Decl);
2170 -- Controlled object declaration
2174 Counter_Val := Counter_Val + 1;
2175 Has_Ctrl_Objs := True;
2177 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
2178 Last_Top_Level_Ctrl_Construct := Decl;
2182 Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
2185 end Processing_Actions;
2187 -- Start of processing for Process_Declarations
2190 if Is_Empty_List (Decls) then
2194 -- Process all declarations in reverse order
2196 Decl := Last_Non_Pragma (Decls);
2197 while Present (Decl) loop
2198 -- Library-level tagged types
2200 if Nkind (Decl) = N_Full_Type_Declaration then
2201 Typ := Defining_Identifier (Decl);
2203 -- Ignored Ghost types do not need any cleanup actions because
2204 -- they will not appear in the final tree.
2206 if Is_Ignored_Ghost_Entity (Typ) then
2209 elsif Is_Tagged_Type (Typ)
2210 and then Is_Library_Level_Entity (Typ)
2211 and then Convention (Typ) = Convention_Ada
2212 and then Present (Access_Disp_Table (Typ))
2213 and then not Is_Abstract_Type (Typ)
2214 and then not No_Run_Time_Mode
2215 and then not Restriction_Active (No_Tagged_Type_Registration)
2216 and then RTE_Available (RE_Register_Tag)
2221 -- Regular object declarations
2223 elsif Nkind (Decl) = N_Object_Declaration then
2224 Obj_Id := Defining_Identifier (Decl);
2225 Obj_Typ := Base_Type (Etype (Obj_Id));
2226 Expr := Expression (Decl);
2228 -- Bypass any form of processing for objects which have their
2229 -- finalization disabled. This applies only to objects at the
2232 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2235 -- Finalization of transient objects are treated separately in
2236 -- order to handle sensitive cases. These include:
2238 -- * Conditional expressions
2239 -- * Expressions with actions
2240 -- * Transient scopes
2242 -- If one of those contexts has marked the transient object as
2243 -- ignored, do not generate finalization actions for it.
2245 elsif Is_Finalized_Transient (Obj_Id)
2246 or else Is_Ignored_Transient (Obj_Id)
2250 -- Ignored Ghost objects do not need any cleanup actions
2251 -- because they will not appear in the final tree.
2253 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2256 -- The object is of the form:
2257 -- Obj : [constant] Typ [:= Expr];
2259 -- Do not process the incomplete view of a deferred constant.
2260 -- Note that an object initialized by means of a BIP function
2261 -- call may appear as a deferred constant after expansion
2262 -- activities. These kinds of objects must be finalized.
2264 elsif not Is_Imported (Obj_Id)
2265 and then Needs_Finalization (Obj_Typ)
2266 and then not (Ekind (Obj_Id) = E_Constant
2267 and then not Has_Completion (Obj_Id)
2268 and then No (BIP_Initialization_Call (Obj_Id)))
2272 -- The object is of the form:
2273 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2275 -- Obj : Access_Typ :=
2276 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2278 elsif Is_Access_Type (Obj_Typ)
2279 and then Needs_Finalization
2280 (Available_View (Designated_Type (Obj_Typ)))
2281 and then Present (Expr)
2283 (Is_Secondary_Stack_BIP_Func_Call (Expr)
2285 (Is_Non_BIP_Func_Call (Expr)
2286 and then not Is_Related_To_Func_Return (Obj_Id)))
2288 Processing_Actions (Has_No_Init => True);
2290 -- Processing for "hook" objects generated for transient
2291 -- objects declared inside an Expression_With_Actions.
2293 elsif Is_Access_Type (Obj_Typ)
2294 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2295 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2296 N_Object_Declaration
2298 Processing_Actions (Has_No_Init => True);
2300 -- Process intermediate results of an if expression with one
2301 -- of the alternatives using a controlled function call.
2303 elsif Is_Access_Type (Obj_Typ)
2304 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2305 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2306 N_Defining_Identifier
2307 and then Present (Expr)
2308 and then Nkind (Expr) = N_Null
2310 Processing_Actions (Has_No_Init => True);
2312 -- Simple protected objects which use type System.Tasking.
2313 -- Protected_Objects.Protection to manage their locks should
2314 -- be treated as controlled since they require manual cleanup.
2315 -- The only exception is illustrated in the following example:
2318 -- type Ctrl is new Controlled ...
2319 -- procedure Finalize (Obj : in out Ctrl);
2323 -- package body Pkg is
2324 -- protected Prot is
2325 -- procedure Do_Something (Obj : in out Ctrl);
2328 -- protected body Prot is
2329 -- procedure Do_Something (Obj : in out Ctrl) is ...
2332 -- procedure Finalize (Obj : in out Ctrl) is
2334 -- Prot.Do_Something (Obj);
2338 -- Since for the most part entities in package bodies depend on
2339 -- those in package specs, Prot's lock should be cleaned up
2340 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2341 -- This act however attempts to invoke Do_Something and fails
2342 -- because the lock has disappeared.
2344 elsif Ekind (Obj_Id) = E_Variable
2345 and then not In_Library_Level_Package_Body (Obj_Id)
2346 and then Has_Simple_Protected_Object (Obj_Typ)
2348 Processing_Actions (Is_Protected => True);
2351 -- Specific cases of object renamings
2353 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
2354 Obj_Id := Defining_Identifier (Decl);
2355 Obj_Typ := Base_Type (Etype (Obj_Id));
2357 -- Bypass any form of processing for objects which have their
2358 -- finalization disabled. This applies only to objects at the
2361 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2364 -- Ignored Ghost object renamings do not need any cleanup
2365 -- actions because they will not appear in the final tree.
2367 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2370 -- Return object of extended return statements. This case is
2371 -- recognized and marked by the expansion of extended return
2372 -- statements (see Expand_N_Extended_Return_Statement).
2374 elsif Needs_Finalization (Obj_Typ)
2375 and then Is_Return_Object (Obj_Id)
2376 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2378 Processing_Actions (Has_No_Init => True);
2381 -- Inspect the freeze node of an access-to-controlled type and
2382 -- look for a delayed finalization master. This case arises when
2383 -- the freeze actions are inserted at a later time than the
2384 -- expansion of the context. Since Build_Finalizer is never called
2385 -- on a single construct twice, the master will be ultimately
2386 -- left out and never finalized. This is also needed for freeze
2387 -- actions of designated types themselves, since in some cases the
2388 -- finalization master is associated with a designated type's
2389 -- freeze node rather than that of the access type (see handling
2390 -- for freeze actions in Build_Finalization_Master).
2392 elsif Nkind (Decl) = N_Freeze_Entity
2393 and then Present (Actions (Decl))
2395 Typ := Entity (Decl);
2397 -- Freeze nodes for ignored Ghost types do not need cleanup
2398 -- actions because they will never appear in the final tree.
2400 if Is_Ignored_Ghost_Entity (Typ) then
2403 elsif (Is_Access_Object_Type (Typ)
2404 and then Needs_Finalization
2405 (Available_View (Designated_Type (Typ))))
2406 or else (Is_Type (Typ) and then Needs_Finalization (Typ))
2408 Old_Counter_Val := Counter_Val;
2410 -- Freeze nodes are considered to be identical to packages
2411 -- and blocks in terms of nesting. The difference is that
2412 -- a finalization master created inside the freeze node is
2413 -- at the same nesting level as the node itself.
2415 Process_Declarations (Actions (Decl), Preprocess);
2417 -- The freeze node contains a finalization master
2421 and then No (Last_Top_Level_Ctrl_Construct)
2422 and then Counter_Val > Old_Counter_Val
2424 Last_Top_Level_Ctrl_Construct := Decl;
2428 -- Nested package declarations, avoid generics
2430 elsif Nkind (Decl) = N_Package_Declaration then
2431 Pack_Id := Defining_Entity (Decl);
2432 Spec := Specification (Decl);
2434 -- Do not inspect an ignored Ghost package because all code
2435 -- found within will not appear in the final tree.
2437 if Is_Ignored_Ghost_Entity (Pack_Id) then
2440 elsif Ekind (Pack_Id) /= E_Generic_Package then
2441 Old_Counter_Val := Counter_Val;
2442 Process_Declarations
2443 (Private_Declarations (Spec), Preprocess);
2444 Process_Declarations
2445 (Visible_Declarations (Spec), Preprocess);
2447 -- Either the visible or the private declarations contain a
2448 -- controlled object. The nested package declaration is the
2449 -- last such construct.
2453 and then No (Last_Top_Level_Ctrl_Construct)
2454 and then Counter_Val > Old_Counter_Val
2456 Last_Top_Level_Ctrl_Construct := Decl;
2460 -- Nested package bodies, avoid generics
2462 elsif Nkind (Decl) = N_Package_Body then
2463 Process_Package_Body (Decl);
2465 elsif Nkind (Decl) = N_Package_Body_Stub
2466 and then Present (Library_Unit (Decl))
2468 Process_Package_Body (Proper_Body (Unit (Library_Unit (Decl))));
2471 Prev_Non_Pragma (Decl);
2473 end Process_Declarations;
2475 --------------------------------
2476 -- Process_Object_Declaration --
2477 --------------------------------
2479 procedure Process_Object_Declaration
2481 Has_No_Init : Boolean := False;
2482 Is_Protected : Boolean := False)
2484 Loc : constant Source_Ptr := Sloc (Decl);
2485 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
2487 Init_Typ : Entity_Id;
2488 -- The initialization type of the related object declaration. Note
2489 -- that this is not necessarily the same type as Obj_Typ because of
2490 -- possible type derivations.
2492 Obj_Typ : Entity_Id;
2493 -- The type of the related object declaration
2495 function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
2496 -- Func_Id denotes a build-in-place function. Generate the following
2499 -- if BIPallocfrom > Secondary_Stack'Pos
2500 -- and then BIPfinalizationmaster /= null
2503 -- type Ptr_Typ is access Obj_Typ;
2504 -- for Ptr_Typ'Storage_Pool
2505 -- use Base_Pool (BIPfinalizationmaster);
2507 -- Free (Ptr_Typ (Temp));
2511 -- Obj_Typ is the type of the current object, Temp is the original
2512 -- allocation which Obj_Id renames.
2514 procedure Find_Last_Init
2515 (Last_Init : out Node_Id;
2516 Body_Insert : out Node_Id);
2517 -- Find the last initialization call related to object declaration
2518 -- Decl. Last_Init denotes the last initialization call which follows
2519 -- Decl. Body_Insert denotes a node where the finalizer body could be
2520 -- potentially inserted after (if blocks are involved).
2522 -----------------------------
2523 -- Build_BIP_Cleanup_Stmts --
2524 -----------------------------
2526 function Build_BIP_Cleanup_Stmts
2527 (Func_Id : Entity_Id) return Node_Id
2529 Decls : constant List_Id := New_List;
2530 Fin_Mas_Id : constant Entity_Id :=
2531 Build_In_Place_Formal
2532 (Func_Id, BIP_Finalization_Master);
2533 Func_Typ : constant Entity_Id := Etype (Func_Id);
2534 Temp_Id : constant Entity_Id :=
2535 Entity (Prefix (Name (Parent (Obj_Id))));
2539 Free_Stmt : Node_Id;
2540 Pool_Id : Entity_Id;
2541 Ptr_Typ : Entity_Id;
2545 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2547 Pool_Id := Make_Temporary (Loc, 'P');
2550 Make_Object_Renaming_Declaration (Loc,
2551 Defining_Identifier => Pool_Id,
2553 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
2555 Make_Explicit_Dereference (Loc,
2557 Make_Function_Call (Loc,
2559 New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
2560 Parameter_Associations => New_List (
2561 Make_Explicit_Dereference (Loc,
2563 New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
2565 -- Create an access type which uses the storage pool of the
2566 -- caller's finalization master.
2569 -- type Ptr_Typ is access Func_Typ;
2571 Ptr_Typ := Make_Temporary (Loc, 'P');
2574 Make_Full_Type_Declaration (Loc,
2575 Defining_Identifier => Ptr_Typ,
2577 Make_Access_To_Object_Definition (Loc,
2578 Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc))));
2580 -- Perform minor decoration in order to set the master and the
2581 -- storage pool attributes.
2583 Mutate_Ekind (Ptr_Typ, E_Access_Type);
2584 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
2585 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
2587 if Debug_Generated_Code then
2588 Set_Debug_Info_Needed (Pool_Id);
2591 -- Create an explicit free statement. Note that the free uses the
2592 -- caller's pool expressed as a renaming.
2595 Make_Free_Statement (Loc,
2597 Unchecked_Convert_To (Ptr_Typ,
2598 New_Occurrence_Of (Temp_Id, Loc)));
2600 Set_Storage_Pool (Free_Stmt, Pool_Id);
2602 -- Create a block to house the dummy type and the instantiation as
2603 -- well as to perform the cleanup the temporary.
2609 -- Free (Ptr_Typ (Temp_Id));
2613 Make_Block_Statement (Loc,
2614 Declarations => Decls,
2615 Handled_Statement_Sequence =>
2616 Make_Handled_Sequence_Of_Statements (Loc,
2617 Statements => New_List (Free_Stmt)));
2620 -- if BIPfinalizationmaster /= null then
2624 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
2625 Right_Opnd => Make_Null (Loc));
2627 -- For unconstrained or tagged results, escalate the condition to
2628 -- include the allocation format. Generate:
2630 -- if BIPallocform > Secondary_Stack'Pos
2631 -- and then BIPfinalizationmaster /= null
2634 if Needs_BIP_Alloc_Form (Func_Id) then
2636 Alloc : constant Entity_Id :=
2637 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
2643 Left_Opnd => New_Occurrence_Of (Alloc, Loc),
2645 Make_Integer_Literal (Loc,
2647 (BIP_Allocation_Form'Pos (Secondary_Stack)))),
2649 Right_Opnd => Cond);
2659 Make_If_Statement (Loc,
2661 Then_Statements => New_List (Free_Blk));
2662 end Build_BIP_Cleanup_Stmts;
2664 --------------------
2665 -- Find_Last_Init --
2666 --------------------
2668 procedure Find_Last_Init
2669 (Last_Init : out Node_Id;
2670 Body_Insert : out Node_Id)
2672 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id;
2673 -- Find the last initialization call within the statements of
2676 function Is_Init_Call (N : Node_Id) return Boolean;
2677 -- Determine whether node N denotes one of the initialization
2678 -- procedures of types Init_Typ or Obj_Typ.
2680 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
2681 -- Obtain the next statement which follows list member Stmt while
2682 -- ignoring artifacts related to access-before-elaboration checks.
2684 -----------------------------
2685 -- Find_Last_Init_In_Block --
2686 -----------------------------
2688 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is
2689 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2693 -- Examine the individual statements of the block in reverse to
2694 -- locate the last initialization call.
2696 if Present (HSS) and then Present (Statements (HSS)) then
2697 Stmt := Last (Statements (HSS));
2698 while Present (Stmt) loop
2700 -- Peek inside nested blocks in case aborts are allowed
2702 if Nkind (Stmt) = N_Block_Statement then
2703 return Find_Last_Init_In_Block (Stmt);
2705 elsif Is_Init_Call (Stmt) then
2714 end Find_Last_Init_In_Block;
2720 function Is_Init_Call (N : Node_Id) return Boolean is
2721 function Is_Init_Proc_Of
2722 (Subp_Id : Entity_Id;
2723 Typ : Entity_Id) return Boolean;
2724 -- Determine whether subprogram Subp_Id is a valid init proc of
2727 ---------------------
2728 -- Is_Init_Proc_Of --
2729 ---------------------
2731 function Is_Init_Proc_Of
2732 (Subp_Id : Entity_Id;
2733 Typ : Entity_Id) return Boolean
2735 Deep_Init : Entity_Id := Empty;
2736 Prim_Init : Entity_Id := Empty;
2737 Type_Init : Entity_Id := Empty;
2740 -- Obtain all possible initialization routines of the
2741 -- related type and try to match the subprogram entity
2742 -- against one of them.
2746 Deep_Init := TSS (Typ, TSS_Deep_Initialize);
2748 -- Primitive Initialize
2750 if Is_Controlled (Typ) then
2751 Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize);
2753 if Present (Prim_Init) then
2754 Prim_Init := Ultimate_Alias (Prim_Init);
2758 -- Type initialization routine
2760 if Has_Non_Null_Base_Init_Proc (Typ) then
2761 Type_Init := Base_Init_Proc (Typ);
2765 (Present (Deep_Init) and then Subp_Id = Deep_Init)
2767 (Present (Prim_Init) and then Subp_Id = Prim_Init)
2769 (Present (Type_Init) and then Subp_Id = Type_Init);
2770 end Is_Init_Proc_Of;
2774 Call_Id : Entity_Id;
2776 -- Start of processing for Is_Init_Call
2779 if Nkind (N) = N_Procedure_Call_Statement
2780 and then Nkind (Name (N)) = N_Identifier
2782 Call_Id := Entity (Name (N));
2784 -- Consider both the type of the object declaration and its
2785 -- related initialization type.
2788 Is_Init_Proc_Of (Call_Id, Init_Typ)
2790 Is_Init_Proc_Of (Call_Id, Obj_Typ);
2796 -----------------------------
2797 -- Next_Suitable_Statement --
2798 -----------------------------
2800 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
2804 -- Skip call markers and Program_Error raises installed by the
2807 Result := Next (Stmt);
2808 while Present (Result) loop
2809 exit when Nkind (Result) not in
2810 N_Call_Marker | N_Raise_Program_Error;
2816 end Next_Suitable_Statement;
2824 Deep_Init_Found : Boolean := False;
2825 -- A flag set when a call to [Deep_]Initialize has been found
2827 -- Start of processing for Find_Last_Init
2831 Body_Insert := Empty;
2833 -- Object renamings and objects associated with controlled
2834 -- function results do not require initialization.
2840 Stmt := Next_Suitable_Statement (Decl);
2842 -- For an object with suppressed initialization, we check whether
2843 -- there is in fact no initialization expression. If there is not,
2844 -- then this is an object declaration that has been turned into a
2845 -- different object declaration that calls the build-in-place
2846 -- function in a 'Reference attribute, as in "F(...)'Reference".
2847 -- We search for that later object declaration, so that the
2848 -- Inc_Decl will be inserted after the call. Otherwise, if the
2849 -- call raises an exception, we will finalize the (uninitialized)
2850 -- object, which is wrong.
2852 if No_Initialization (Decl) then
2853 if No (Expression (Last_Init)) then
2856 exit when No (Last_Init);
2857 exit when Nkind (Last_Init) = N_Object_Declaration
2858 and then Nkind (Expression (Last_Init)) = N_Reference
2859 and then Nkind (Prefix (Expression (Last_Init))) =
2861 and then Is_Expanded_Build_In_Place_Call
2862 (Prefix (Expression (Last_Init)));
2868 -- If the initialization is in the declaration, we're done, so
2869 -- early return if we have no more statements or they have been
2870 -- rewritten, which means that they were in the source code.
2872 elsif No (Stmt) or else Original_Node (Stmt) /= Stmt then
2875 -- In all other cases the initialization calls follow the related
2876 -- object. The general structure of object initialization built by
2877 -- routine Default_Initialize_Object is as follows:
2879 -- [begin -- aborts allowed
2881 -- Type_Init_Proc (Obj);
2882 -- [begin] -- exceptions allowed
2883 -- Deep_Initialize (Obj);
2884 -- [exception -- exceptions allowed
2886 -- Deep_Finalize (Obj, Self => False);
2889 -- [at end -- aborts allowed
2893 -- When aborts are allowed, the initialization calls are housed
2896 elsif Nkind (Stmt) = N_Block_Statement then
2897 Last_Init := Find_Last_Init_In_Block (Stmt);
2898 Body_Insert := Stmt;
2900 -- Otherwise the initialization calls follow the related object
2903 Stmt_2 := Next_Suitable_Statement (Stmt);
2905 -- Check for an optional call to Deep_Initialize which may
2906 -- appear within a block depending on whether the object has
2907 -- controlled components.
2909 if Present (Stmt_2) then
2910 if Nkind (Stmt_2) = N_Block_Statement then
2911 Call := Find_Last_Init_In_Block (Stmt_2);
2913 if Present (Call) then
2914 Deep_Init_Found := True;
2916 Body_Insert := Stmt_2;
2919 elsif Is_Init_Call (Stmt_2) then
2920 Deep_Init_Found := True;
2921 Last_Init := Stmt_2;
2922 Body_Insert := Last_Init;
2926 -- If the object lacks a call to Deep_Initialize, then it must
2927 -- have a call to its related type init proc.
2929 if not Deep_Init_Found and then Is_Init_Call (Stmt) then
2931 Body_Insert := Last_Init;
2939 Count_Ins : Node_Id;
2941 Fin_Stmts : List_Id := No_List;
2944 Label_Id : Entity_Id;
2947 -- Start of processing for Process_Object_Declaration
2950 -- Handle the object type and the reference to the object. Note
2951 -- that objects having simple protected components must retain
2952 -- their original form for the processing below to work.
2954 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
2955 Obj_Typ := Base_Type (Etype (Obj_Id));
2958 if Is_Access_Type (Obj_Typ) then
2959 Obj_Typ := Directly_Designated_Type (Obj_Typ);
2960 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
2962 elsif Is_Concurrent_Type (Obj_Typ)
2963 and then Present (Corresponding_Record_Type (Obj_Typ))
2964 and then not Is_Protected
2966 Obj_Typ := Corresponding_Record_Type (Obj_Typ);
2967 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2969 elsif Is_Private_Type (Obj_Typ)
2970 and then Present (Full_View (Obj_Typ))
2972 Obj_Typ := Full_View (Obj_Typ);
2973 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2975 elsif Obj_Typ /= Base_Type (Obj_Typ) then
2976 Obj_Typ := Base_Type (Obj_Typ);
2977 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
2984 Set_Etype (Obj_Ref, Obj_Typ);
2986 -- Handle the initialization type of the object declaration
2988 Init_Typ := Obj_Typ;
2990 if Is_Private_Type (Init_Typ)
2991 and then Present (Full_View (Init_Typ))
2993 Init_Typ := Full_View (Init_Typ);
2995 elsif Is_Untagged_Derivation (Init_Typ) then
2996 Init_Typ := Root_Type (Init_Typ);
3003 -- Set a new value for the state counter and insert the statement
3004 -- after the object declaration. Generate:
3006 -- Counter := <value>;
3009 Make_Assignment_Statement (Loc,
3010 Name => New_Occurrence_Of (Counter_Id, Loc),
3011 Expression => Make_Integer_Literal (Loc, Counter_Val));
3013 -- Insert the counter after all initialization has been done. The
3014 -- place of insertion depends on the context.
3016 if Ekind (Obj_Id) in E_Constant | E_Variable then
3018 -- The object is initialized by a build-in-place function call.
3019 -- The counter insertion point is after the function call.
3021 if Present (BIP_Initialization_Call (Obj_Id)) then
3022 Count_Ins := BIP_Initialization_Call (Obj_Id);
3025 -- The object is initialized by an aggregate. Insert the counter
3026 -- after the last aggregate assignment.
3028 elsif Present (Last_Aggregate_Assignment (Obj_Id)) then
3029 Count_Ins := Last_Aggregate_Assignment (Obj_Id);
3032 -- In all other cases the counter is inserted after the last call
3033 -- to either [Deep_]Initialize or the type-specific init proc.
3036 Find_Last_Init (Count_Ins, Body_Ins);
3039 -- In all other cases the counter is inserted after the last call to
3040 -- either [Deep_]Initialize or the type-specific init proc.
3043 Find_Last_Init (Count_Ins, Body_Ins);
3046 -- If the Initialize function is null or trivial, the call will have
3047 -- been replaced with a null statement, in which case place counter
3048 -- declaration after object declaration itself.
3050 if No (Count_Ins) then
3054 Insert_After (Count_Ins, Inc_Decl);
3057 -- If the current declaration is the last in the list, the finalizer
3058 -- body needs to be inserted after the set counter statement for the
3059 -- current object declaration. This is complicated by the fact that
3060 -- the set counter statement may appear in abort deferred block. In
3061 -- that case, the proper insertion place is after the block.
3063 if No (Finalizer_Insert_Nod) then
3065 -- Insertion after an abort deferred block
3067 if Present (Body_Ins) then
3068 Finalizer_Insert_Nod := Body_Ins;
3070 Finalizer_Insert_Nod := Inc_Decl;
3074 -- Create the associated label with this object, generate:
3076 -- L<counter> : label;
3079 Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
3081 (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
3082 Label := Make_Label (Loc, Label_Id);
3084 Prepend_To (Finalizer_Decls,
3085 Make_Implicit_Label_Declaration (Loc,
3086 Defining_Identifier => Entity (Label_Id),
3087 Label_Construct => Label));
3089 -- Create the associated jump with this object, generate:
3091 -- when <counter> =>
3094 Prepend_To (Jump_Alts,
3095 Make_Case_Statement_Alternative (Loc,
3096 Discrete_Choices => New_List (
3097 Make_Integer_Literal (Loc, Counter_Val)),
3098 Statements => New_List (
3099 Make_Goto_Statement (Loc,
3100 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
3102 -- Insert the jump destination, generate:
3106 Append_To (Finalizer_Stmts, Label);
3108 -- Disable warnings on Obj_Id. This works around an issue where GCC
3109 -- is not able to detect that Obj_Id is protected by a counter and
3110 -- emits spurious warnings.
3112 if not Comes_From_Source (Obj_Id) then
3113 Set_Warnings_Off (Obj_Id);
3116 -- Processing for simple protected objects. Such objects require
3117 -- manual finalization of their lock managers.
3119 if Is_Protected then
3120 if Is_Simple_Protected_Type (Obj_Typ) then
3121 Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
3123 if Present (Fin_Call) then
3124 Fin_Stmts := New_List (Fin_Call);
3127 elsif Is_Array_Type (Obj_Typ) then
3128 Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
3131 Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
3136 -- System.Tasking.Protected_Objects.Finalize_Protection
3144 if Present (Fin_Stmts) and then Exceptions_OK then
3145 Fin_Stmts := New_List (
3146 Make_Block_Statement (Loc,
3147 Handled_Statement_Sequence =>
3148 Make_Handled_Sequence_Of_Statements (Loc,
3149 Statements => Fin_Stmts,
3151 Exception_Handlers => New_List (
3152 Make_Exception_Handler (Loc,
3153 Exception_Choices => New_List (
3154 Make_Others_Choice (Loc)),
3156 Statements => New_List (
3157 Make_Null_Statement (Loc)))))));
3160 -- Processing for regular controlled objects
3165 -- [Deep_]Finalize (Obj);
3168 -- when Id : others =>
3169 -- if not Raised then
3171 -- Save_Occurrence (E, Id);
3180 -- Guard against a missing [Deep_]Finalize when the object type
3181 -- was not properly frozen.
3183 if No (Fin_Call) then
3184 Fin_Call := Make_Null_Statement (Loc);
3187 -- For CodePeer, the exception handlers normally generated here
3188 -- generate complex flowgraphs which result in capacity problems.
3189 -- Omitting these handlers for CodePeer is justified as follows:
3191 -- If a handler is dead, then omitting it is surely ok
3193 -- If a handler is live, then CodePeer should flag the
3194 -- potentially-exception-raising construct that causes it
3195 -- to be live. That is what we are interested in, not what
3196 -- happens after the exception is raised.
3198 if Exceptions_OK and not CodePeer_Mode then
3199 Fin_Stmts := New_List (
3200 Make_Block_Statement (Loc,
3201 Handled_Statement_Sequence =>
3202 Make_Handled_Sequence_Of_Statements (Loc,
3203 Statements => New_List (Fin_Call),
3205 Exception_Handlers => New_List (
3206 Build_Exception_Handler
3207 (Finalizer_Data, For_Package)))));
3209 -- When exception handlers are prohibited, the finalization call
3210 -- appears unprotected. Any exception raised during finalization
3211 -- will bypass the circuitry which ensures the cleanup of all
3212 -- remaining objects.
3215 Fin_Stmts := New_List (Fin_Call);
3218 -- If we are dealing with a return object of a build-in-place
3219 -- function, generate the following cleanup statements:
3221 -- if BIPallocfrom > Secondary_Stack'Pos
3222 -- and then BIPfinalizationmaster /= null
3225 -- type Ptr_Typ is access Obj_Typ;
3226 -- for Ptr_Typ'Storage_Pool use
3227 -- Base_Pool (BIPfinalizationmaster.all).all;
3229 -- Free (Ptr_Typ (Temp));
3233 -- The generated code effectively detaches the temporary from the
3234 -- caller finalization master and deallocates the object.
3236 if Is_Return_Object (Obj_Id) then
3238 Func_Id : constant Entity_Id :=
3239 Return_Applies_To (Scope (Obj_Id));
3242 if Is_Build_In_Place_Function (Func_Id)
3243 and then Needs_BIP_Finalization_Master (Func_Id)
3245 Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
3250 if Ekind (Obj_Id) in E_Constant | E_Variable
3251 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
3253 -- Temporaries created for the purpose of "exporting" a
3254 -- transient object out of an Expression_With_Actions (EWA)
3255 -- need guards. The following illustrates the usage of such
3258 -- Access_Typ : access [all] Obj_Typ;
3259 -- Temp : Access_Typ := null;
3260 -- <Counter> := ...;
3263 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3264 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3266 -- Temp := Ctrl_Trans'Unchecked_Access;
3269 -- The finalization machinery does not process EWA nodes as
3270 -- this may lead to premature finalization of expressions. Note
3271 -- that Temp is marked as being properly initialized regardless
3272 -- of whether the initialization of Ctrl_Trans succeeded. Since
3273 -- a failed initialization may leave Temp with a value of null,
3274 -- add a guard to handle this case:
3276 -- if Obj /= null then
3277 -- <object finalization statements>
3280 if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
3281 N_Object_Declaration
3283 Fin_Stmts := New_List (
3284 Make_If_Statement (Loc,
3287 Left_Opnd => New_Occurrence_Of (Obj_Id, Loc),
3288 Right_Opnd => Make_Null (Loc)),
3289 Then_Statements => Fin_Stmts));
3291 -- Return objects use a flag to aid in processing their
3292 -- potential finalization when the enclosing function fails
3293 -- to return properly. Generate:
3296 -- <object finalization statements>
3300 Fin_Stmts := New_List (
3301 Make_If_Statement (Loc,
3306 (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)),
3308 Then_Statements => Fin_Stmts));
3313 Append_List_To (Finalizer_Stmts, Fin_Stmts);
3315 -- Since the declarations are examined in reverse, the state counter
3316 -- must be decremented in order to keep with the true position of
3319 Counter_Val := Counter_Val - 1;
3320 end Process_Object_Declaration;
3322 -------------------------------------
3323 -- Process_Tagged_Type_Declaration --
3324 -------------------------------------
3326 procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
3327 Typ : constant Entity_Id := Defining_Identifier (Decl);
3328 DT_Ptr : constant Entity_Id :=
3329 Node (First_Elmt (Access_Disp_Table (Typ)));
3332 -- Ada.Tags.Unregister_Tag (<Typ>P);
3334 Append_To (Tagged_Type_Stmts,
3335 Make_Procedure_Call_Statement (Loc,
3337 New_Occurrence_Of (RTE (RE_Unregister_Tag), Loc),
3338 Parameter_Associations => New_List (
3339 New_Occurrence_Of (DT_Ptr, Loc))));
3340 end Process_Tagged_Type_Declaration;
3342 -- Start of processing for Build_Finalizer
3347 -- Do not perform this expansion in SPARK mode because it is not
3350 if GNATprove_Mode then
3354 -- Step 1: Extract all lists which may contain controlled objects or
3355 -- library-level tagged types.
3357 if For_Package_Spec then
3358 Decls := Visible_Declarations (Specification (N));
3359 Priv_Decls := Private_Declarations (Specification (N));
3361 -- Retrieve the package spec id
3363 Spec_Id := Defining_Unit_Name (Specification (N));
3365 if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
3366 Spec_Id := Defining_Identifier (Spec_Id);
3369 -- Accept statement, block, entry body, package body, protected body,
3370 -- subprogram body or task body.
3373 Decls := Declarations (N);
3374 HSS := Handled_Statement_Sequence (N);
3376 if Present (HSS) then
3377 if Present (Statements (HSS)) then
3378 Stmts := Statements (HSS);
3381 if Present (At_End_Proc (HSS)) then
3382 Prev_At_End := At_End_Proc (HSS);
3386 -- Retrieve the package spec id for package bodies
3388 if For_Package_Body then
3389 Spec_Id := Corresponding_Spec (N);
3393 -- We do not need to process nested packages since they are handled by
3394 -- the finalizer of the enclosing scope, including at library level.
3395 -- And we do not build two finalizers for an instance without body that
3396 -- is a library unit (see Analyze_Package_Instantiation).
3399 and then (not Is_Compilation_Unit (Spec_Id)
3400 or else (Is_Generic_Instance (Spec_Id)
3401 and then Package_Instantiation (Spec_Id) = N))
3406 -- Step 2: Object [pre]processing
3409 -- For package specs and bodies, we are invoked from the Standard
3410 -- scope, so we need to push the specs onto the scope stack first.
3412 Push_Scope (Spec_Id);
3414 -- Preprocess the visible declarations now in order to obtain the
3415 -- correct number of controlled object by the time the private
3416 -- declarations are processed.
3418 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
3420 -- From all the possible contexts, only package specifications may
3421 -- have private declarations.
3423 if For_Package_Spec then
3424 Process_Declarations
3425 (Priv_Decls, Preprocess => True, Top_Level => True);
3428 -- The current context may lack controlled objects, but require some
3429 -- other form of completion (task termination for instance). In such
3430 -- cases, the finalizer must be created and carry the additional
3433 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3437 -- The preprocessing has determined that the context has controlled
3438 -- objects or library-level tagged types.
3440 if Has_Ctrl_Objs or Has_Tagged_Types then
3442 -- Private declarations are processed first in order to preserve
3443 -- possible dependencies between public and private objects.
3445 if For_Package_Spec then
3446 Process_Declarations (Priv_Decls);
3449 Process_Declarations (Decls);
3455 -- Preprocess both declarations and statements
3457 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
3458 Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
3460 -- At this point it is known that N has controlled objects. Ensure
3461 -- that N has a declarative list since the finalizer spec will be
3464 if Has_Ctrl_Objs and then No (Decls) then
3465 Set_Declarations (N, New_List);
3466 Decls := Declarations (N);
3467 Spec_Decls := Decls;
3470 -- The current context may lack controlled objects, but require some
3471 -- other form of completion (task termination for instance). In such
3472 -- cases, the finalizer must be created and carry the additional
3475 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3479 if Has_Ctrl_Objs or Has_Tagged_Types then
3480 Process_Declarations (Stmts);
3481 Process_Declarations (Decls);
3485 -- Step 3: Finalizer creation
3487 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3491 -- Pop the scope that was pushed above for package specs and bodies
3496 end Build_Finalizer;
3498 --------------------------
3499 -- Build_Finalizer_Call --
3500 --------------------------
3502 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
3504 -- Do not perform this expansion in SPARK mode because we do not create
3505 -- finalizers in the first place.
3507 if GNATprove_Mode then
3511 -- If the construct to be cleaned up is a protected subprogram body, the
3512 -- finalizer call needs to be associated with the block that wraps the
3513 -- unprotected version of the subprogram. The following illustrates this
3516 -- procedure Prot_SubpP is
3517 -- procedure finalizer is
3519 -- Service_Entries (Prot_Obj);
3526 -- Prot_SubpN (Prot_Obj);
3533 Loc : constant Source_Ptr := Sloc (N);
3535 Is_Protected_Subp_Body : constant Boolean :=
3536 Nkind (N) = N_Subprogram_Body
3537 and then Is_Protected_Subprogram_Body (N);
3538 -- True if N is the protected version of a subprogram that belongs to
3539 -- a protected type.
3541 HSS : constant Node_Id :=
3542 (if Is_Protected_Subp_Body
3543 then Handled_Statement_Sequence
3544 (Last (Statements (Handled_Statement_Sequence (N))))
3545 else Handled_Statement_Sequence (N));
3547 -- We attach the At_End_Proc to the HSS if this is an accept
3548 -- statement or extended return statement. Also in the case of
3549 -- a protected subprogram, because if Service_Entries raises an
3550 -- exception, we do not lock the PO, so we also do not want to
3553 Use_HSS : constant Boolean :=
3554 Nkind (N) in N_Accept_Statement | N_Extended_Return_Statement
3555 or else Is_Protected_Subp_Body;
3557 At_End_Proc_Bearer : constant Node_Id := (if Use_HSS then HSS else N);
3559 pragma Assert (No (At_End_Proc (At_End_Proc_Bearer)));
3560 Set_At_End_Proc (At_End_Proc_Bearer, New_Occurrence_Of (Fin_Id, Loc));
3561 -- Attach reference to finalizer to tree, for LLVM use
3562 Set_Parent (At_End_Proc (At_End_Proc_Bearer), At_End_Proc_Bearer);
3563 Analyze (At_End_Proc (At_End_Proc_Bearer));
3564 Expand_At_End_Handler (At_End_Proc_Bearer, Empty);
3566 end Build_Finalizer_Call;
3568 ---------------------
3569 -- Build_Late_Proc --
3570 ---------------------
3572 procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
3574 for Final_Prim in Name_Of'Range loop
3575 if Name_Of (Final_Prim) = Nam then
3578 (Prim => Final_Prim,
3580 Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
3583 end Build_Late_Proc;
3585 -------------------------------
3586 -- Build_Object_Declarations --
3587 -------------------------------
3589 procedure Build_Object_Declarations
3590 (Data : out Finalization_Exception_Data;
3593 For_Package : Boolean := False)
3598 -- This variable captures an unused dummy internal entity, see the
3599 -- comment associated with its use.
3602 pragma Assert (Decls /= No_List);
3604 -- Always set the proper location as it may be needed even when
3605 -- exception propagation is forbidden.
3609 if Restriction_Active (No_Exception_Propagation) then
3610 Data.Abort_Id := Empty;
3612 Data.Raised_Id := Empty;
3616 Data.Raised_Id := Make_Temporary (Loc, 'R');
3618 -- In certain scenarios, finalization can be triggered by an abort. If
3619 -- the finalization itself fails and raises an exception, the resulting
3620 -- Program_Error must be supressed and replaced by an abort signal. In
3621 -- order to detect this scenario, save the state of entry into the
3622 -- finalization code.
3624 -- This is not needed for library-level finalizers as they are called by
3625 -- the environment task and cannot be aborted.
3627 if not For_Package then
3628 if Abort_Allowed then
3629 Data.Abort_Id := Make_Temporary (Loc, 'A');
3632 -- Abort_Id : constant Boolean := <A_Expr>;
3635 Make_Object_Declaration (Loc,
3636 Defining_Identifier => Data.Abort_Id,
3637 Constant_Present => True,
3638 Object_Definition =>
3639 New_Occurrence_Of (Standard_Boolean, Loc),
3641 New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc)));
3643 -- Abort is not required
3646 -- Generate a dummy entity to ensure that the internal symbols are
3647 -- in sync when a unit is compiled with and without aborts.
3649 Dummy := Make_Temporary (Loc, 'A');
3650 Data.Abort_Id := Empty;
3653 -- Library-level finalizers
3656 Data.Abort_Id := Empty;
3659 if Exception_Extra_Info then
3660 Data.E_Id := Make_Temporary (Loc, 'E');
3663 -- E_Id : Exception_Occurrence;
3666 Make_Object_Declaration (Loc,
3667 Defining_Identifier => Data.E_Id,
3668 Object_Definition =>
3669 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc));
3670 Set_No_Initialization (Decl);
3672 Append_To (Decls, Decl);
3679 -- Raised_Id : Boolean := False;
3682 Make_Object_Declaration (Loc,
3683 Defining_Identifier => Data.Raised_Id,
3684 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
3685 Expression => New_Occurrence_Of (Standard_False, Loc)));
3687 if Debug_Generated_Code then
3688 Set_Debug_Info_Needed (Data.Raised_Id);
3690 end Build_Object_Declarations;
3692 ---------------------------
3693 -- Build_Raise_Statement --
3694 ---------------------------
3696 function Build_Raise_Statement
3697 (Data : Finalization_Exception_Data) return Node_Id
3703 -- Standard run-time use the specialized routine
3704 -- Raise_From_Controlled_Operation.
3706 if Exception_Extra_Info
3707 and then RTE_Available (RE_Raise_From_Controlled_Operation)
3710 Make_Procedure_Call_Statement (Data.Loc,
3713 (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
3714 Parameter_Associations =>
3715 New_List (New_Occurrence_Of (Data.E_Id, Data.Loc)));
3717 -- Restricted run-time: exception messages are not supported and hence
3718 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3723 Make_Raise_Program_Error (Data.Loc,
3724 Reason => PE_Finalize_Raised_Exception);
3729 -- Raised_Id and then not Abort_Id
3733 Expr := New_Occurrence_Of (Data.Raised_Id, Data.Loc);
3735 if Present (Data.Abort_Id) then
3736 Expr := Make_And_Then (Data.Loc,
3739 Make_Op_Not (Data.Loc,
3740 Right_Opnd => New_Occurrence_Of (Data.Abort_Id, Data.Loc)));
3745 -- if Raised_Id and then not Abort_Id then
3746 -- Raise_From_Controlled_Operation (E_Id);
3748 -- raise Program_Error; -- restricted runtime
3752 Make_If_Statement (Data.Loc,
3754 Then_Statements => New_List (Stmt));
3755 end Build_Raise_Statement;
3757 -----------------------------
3758 -- Build_Record_Deep_Procs --
3759 -----------------------------
3761 procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
3765 (Prim => Initialize_Case,
3767 Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
3769 if not Is_Inherently_Limited_Type (Typ) then
3772 (Prim => Adjust_Case,
3774 Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
3777 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3778 -- suppressed since these routine will not be used.
3780 if not Restriction_Active (No_Finalization) then
3783 (Prim => Finalize_Case,
3785 Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
3787 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3789 if not CodePeer_Mode then
3792 (Prim => Address_Case,
3794 Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
3797 end Build_Record_Deep_Procs;
3803 function Cleanup_Array
3806 Typ : Entity_Id) return List_Id
3808 Loc : constant Source_Ptr := Sloc (N);
3809 Index_List : constant List_Id := New_List;
3811 function Free_Component return List_Id;
3812 -- Generate the code to finalize the task or protected subcomponents
3813 -- of a single component of the array.
3815 function Free_One_Dimension (Dim : Int) return List_Id;
3816 -- Generate a loop over one dimension of the array
3818 --------------------
3819 -- Free_Component --
3820 --------------------
3822 function Free_Component return List_Id is
3823 Stmts : List_Id := New_List;
3825 C_Typ : constant Entity_Id := Component_Type (Typ);
3828 -- Component type is known to contain tasks or protected objects
3831 Make_Indexed_Component (Loc,
3832 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3833 Expressions => Index_List);
3835 Set_Etype (Tsk, C_Typ);
3837 if Is_Task_Type (C_Typ) then
3838 Append_To (Stmts, Cleanup_Task (N, Tsk));
3840 elsif Is_Simple_Protected_Type (C_Typ) then
3841 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3843 elsif Is_Record_Type (C_Typ) then
3844 Stmts := Cleanup_Record (N, Tsk, C_Typ);
3846 elsif Is_Array_Type (C_Typ) then
3847 Stmts := Cleanup_Array (N, Tsk, C_Typ);
3853 ------------------------
3854 -- Free_One_Dimension --
3855 ------------------------
3857 function Free_One_Dimension (Dim : Int) return List_Id is
3861 if Dim > Number_Dimensions (Typ) then
3862 return Free_Component;
3864 -- Here we generate the required loop
3867 Index := Make_Temporary (Loc, 'J');
3868 Append (New_Occurrence_Of (Index, Loc), Index_List);
3871 Make_Implicit_Loop_Statement (N,
3872 Identifier => Empty,
3874 Make_Iteration_Scheme (Loc,
3875 Loop_Parameter_Specification =>
3876 Make_Loop_Parameter_Specification (Loc,
3877 Defining_Identifier => Index,
3878 Discrete_Subtype_Definition =>
3879 Make_Attribute_Reference (Loc,
3880 Prefix => Duplicate_Subexpr (Obj),
3881 Attribute_Name => Name_Range,
3882 Expressions => New_List (
3883 Make_Integer_Literal (Loc, Dim))))),
3884 Statements => Free_One_Dimension (Dim + 1)));
3886 end Free_One_Dimension;
3888 -- Start of processing for Cleanup_Array
3891 return Free_One_Dimension (1);
3894 --------------------
3895 -- Cleanup_Record --
3896 --------------------
3898 function Cleanup_Record
3901 Typ : Entity_Id) return List_Id
3903 Loc : constant Source_Ptr := Sloc (N);
3904 Stmts : constant List_Id := New_List;
3905 U_Typ : constant Entity_Id := Underlying_Type (Typ);
3911 if Has_Discriminants (U_Typ)
3912 and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
3913 and then Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
3916 (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
3918 -- For now, do not attempt to free a component that may appear in a
3919 -- variant, and instead issue a warning. Doing this "properly" would
3920 -- require building a case statement and would be quite a mess. Note
3921 -- that the RM only requires that free "work" for the case of a task
3922 -- access value, so already we go way beyond this in that we deal
3923 -- with the array case and non-discriminated record cases.
3926 ("task/protected object in variant record will not be freed??", N);
3927 return New_List (Make_Null_Statement (Loc));
3930 Comp := First_Component (U_Typ);
3931 while Present (Comp) loop
3932 if Chars (Comp) /= Name_uParent
3933 and then (Has_Task (Etype (Comp))
3934 or else Has_Simple_Protected_Object (Etype (Comp)))
3937 Make_Selected_Component (Loc,
3938 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3939 Selector_Name => New_Occurrence_Of (Comp, Loc));
3940 Set_Etype (Tsk, Etype (Comp));
3942 if Is_Task_Type (Etype (Comp)) then
3943 Append_To (Stmts, Cleanup_Task (N, Tsk));
3945 elsif Is_Simple_Protected_Type (Etype (Comp)) then
3946 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3948 elsif Is_Record_Type (Etype (Comp)) then
3950 -- Recurse, by generating the prefix of the argument to the
3951 -- eventual cleanup call.
3953 Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
3955 elsif Is_Array_Type (Etype (Comp)) then
3956 Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
3960 Next_Component (Comp);
3966 ------------------------------
3967 -- Cleanup_Protected_Object --
3968 ------------------------------
3970 function Cleanup_Protected_Object
3972 Ref : Node_Id) return Node_Id
3974 Loc : constant Source_Ptr := Sloc (N);
3977 -- For restricted run-time libraries (Ravenscar), tasks are
3978 -- non-terminating, and protected objects can only appear at library
3979 -- level, so we do not want finalization of protected objects.
3981 if Restricted_Profile then
3986 Make_Procedure_Call_Statement (Loc,
3988 New_Occurrence_Of (RTE (RE_Finalize_Protection), Loc),
3989 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
3991 end Cleanup_Protected_Object;
3997 function Cleanup_Task
3999 Ref : Node_Id) return Node_Id
4001 Loc : constant Source_Ptr := Sloc (N);
4004 -- For restricted run-time libraries (Ravenscar), tasks are
4005 -- non-terminating and they can only appear at library level,
4006 -- so we do not want finalization of task objects.
4008 if Restricted_Profile then
4013 Make_Procedure_Call_Statement (Loc,
4015 New_Occurrence_Of (RTE (RE_Free_Task), Loc),
4016 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
4020 --------------------------------------
4021 -- Check_Unnesting_Elaboration_Code --
4022 --------------------------------------
4024 procedure Check_Unnesting_Elaboration_Code (N : Node_Id) is
4025 Loc : constant Source_Ptr := Sloc (N);
4026 Block_Elab_Proc : Entity_Id := Empty;
4028 procedure Set_Block_Elab_Proc;
4029 -- Create a defining identifier for a procedure that will replace
4030 -- a block with nested subprograms (unless it has already been created,
4031 -- in which case this is a no-op).
4033 procedure Set_Block_Elab_Proc is
4035 if No (Block_Elab_Proc) then
4036 Block_Elab_Proc := Make_Temporary (Loc, 'I');
4038 end Set_Block_Elab_Proc;
4040 procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id);
4041 -- Find entities in the elaboration code of a library package body that
4042 -- contain or represent a subprogram body. A body can appear within a
4043 -- block or a loop or can appear by itself if generated for an object
4044 -- declaration that involves controlled actions. The first such entity
4045 -- forces creation of a new procedure entity (via Set_Block_Elab_Proc)
4046 -- that will be used to reset the scopes of all entities that become
4047 -- local to the new elaboration procedure. This is needed for subsequent
4048 -- unnesting actions, which depend on proper setting of the Scope links
4049 -- to determine the nesting level of each subprogram.
4051 -----------------------
4052 -- Find_Local_Scope --
4053 -----------------------
4055 procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id) is
4062 while Present (Stat) loop
4063 case Nkind (Stat) is
4064 when N_Block_Statement =>
4065 if Present (Identifier (Stat)) then
4066 Id := Entity (Identifier (Stat));
4068 -- The Scope of this block needs to be reset to the new
4069 -- procedure if the block contains nested subprograms.
4071 if Present (Id) and then Contains_Subprogram (Id) then
4072 Set_Block_Elab_Proc;
4073 Set_Scope (Id, Block_Elab_Proc);
4077 when N_Loop_Statement =>
4078 Id := Entity (Identifier (Stat));
4080 if Present (Id) and then Contains_Subprogram (Id) then
4081 if Scope (Id) = Current_Scope then
4082 Set_Block_Elab_Proc;
4083 Set_Scope (Id, Block_Elab_Proc);
4087 -- We traverse the loop's statements as well, which may
4088 -- include other block (etc.) statements that need to have
4089 -- their Scope set to Block_Elab_Proc. (Is this really the
4090 -- case, or do such nested blocks refer to the loop scope
4091 -- rather than the loop's enclosing scope???.)
4093 Reset_Scopes_To_Block_Elab_Proc (Statements (Stat));
4095 when N_If_Statement =>
4096 Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Stat));
4097 Reset_Scopes_To_Block_Elab_Proc (Else_Statements (Stat));
4099 Node := First (Elsif_Parts (Stat));
4100 while Present (Node) loop
4101 Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Node));
4105 when N_Case_Statement =>
4106 Node := First (Alternatives (Stat));
4107 while Present (Node) loop
4108 Reset_Scopes_To_Block_Elab_Proc (Statements (Node));
4112 -- Reset the Scope of a subprogram occurring at the top level
4114 when N_Subprogram_Body =>
4115 Id := Defining_Entity (Stat);
4117 Set_Block_Elab_Proc;
4118 Set_Scope (Id, Block_Elab_Proc);
4126 end Reset_Scopes_To_Block_Elab_Proc;
4130 H_Seq : constant Node_Id := Handled_Statement_Sequence (N);
4131 Elab_Body : Node_Id;
4132 Elab_Call : Node_Id;
4134 -- Start of processing for Check_Unnesting_Elaboration_Code
4137 if Present (H_Seq) then
4138 Reset_Scopes_To_Block_Elab_Proc (Statements (H_Seq));
4140 -- There may be subprograms declared in the exception handlers
4141 -- of the current body.
4143 if Present (Exception_Handlers (H_Seq)) then
4145 Handler : Node_Id := First (Exception_Handlers (H_Seq));
4147 while Present (Handler) loop
4148 Reset_Scopes_To_Block_Elab_Proc (Statements (Handler));
4155 if Present (Block_Elab_Proc) then
4157 Make_Subprogram_Body (Loc,
4159 Make_Procedure_Specification (Loc,
4160 Defining_Unit_Name => Block_Elab_Proc),
4161 Declarations => New_List,
4162 Handled_Statement_Sequence =>
4163 Relocate_Node (Handled_Statement_Sequence (N)));
4166 Make_Procedure_Call_Statement (Loc,
4167 Name => New_Occurrence_Of (Block_Elab_Proc, Loc));
4169 Append_To (Declarations (N), Elab_Body);
4170 Analyze (Elab_Body);
4171 Set_Has_Nested_Subprogram (Block_Elab_Proc);
4173 Set_Handled_Statement_Sequence (N,
4174 Make_Handled_Sequence_Of_Statements (Loc,
4175 Statements => New_List (Elab_Call)));
4177 Analyze (Elab_Call);
4179 -- Could we reset the scopes of entities associated with the new
4180 -- procedure here via a loop over entities rather than doing it in
4181 -- the recursive Reset_Scopes_To_Elab_Proc procedure???
4184 end Check_Unnesting_Elaboration_Code;
4186 ---------------------------------------
4187 -- Check_Unnesting_In_Decls_Or_Stmts --
4188 ---------------------------------------
4190 procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id) is
4191 Decl_Or_Stmt : Node_Id;
4194 if Unnest_Subprogram_Mode
4195 and then Present (Decls_Or_Stmts)
4197 Decl_Or_Stmt := First (Decls_Or_Stmts);
4198 while Present (Decl_Or_Stmt) loop
4199 if Nkind (Decl_Or_Stmt) = N_Block_Statement
4200 and then Contains_Subprogram (Entity (Identifier (Decl_Or_Stmt)))
4202 Unnest_Block (Decl_Or_Stmt);
4204 -- If-statements may contain subprogram bodies at the outer level
4205 -- of their statement lists, and the subprograms may make up-level
4206 -- references (such as to objects declared in the same statement
4207 -- list). Unlike block and loop cases, however, we don't have an
4208 -- entity on which to test the Contains_Subprogram flag, so
4209 -- Unnest_If_Statement must traverse the statement lists to
4210 -- determine whether there are nested subprograms present.
4212 elsif Nkind (Decl_Or_Stmt) = N_If_Statement then
4213 Unnest_If_Statement (Decl_Or_Stmt);
4215 elsif Nkind (Decl_Or_Stmt) = N_Loop_Statement then
4217 Id : constant Entity_Id :=
4218 Entity (Identifier (Decl_Or_Stmt));
4221 -- When a top-level loop within declarations of a library
4222 -- package spec or body contains nested subprograms, we wrap
4223 -- it in a procedure to handle possible up-level references
4224 -- to entities associated with the loop (such as loop
4227 if Present (Id) and then Contains_Subprogram (Id) then
4228 Unnest_Loop (Decl_Or_Stmt);
4232 elsif Nkind (Decl_Or_Stmt) = N_Package_Declaration
4233 and then not Modify_Tree_For_C
4235 Check_Unnesting_In_Decls_Or_Stmts
4236 (Visible_Declarations (Specification (Decl_Or_Stmt)));
4237 Check_Unnesting_In_Decls_Or_Stmts
4238 (Private_Declarations (Specification (Decl_Or_Stmt)));
4240 elsif Nkind (Decl_Or_Stmt) = N_Package_Body
4241 and then not Modify_Tree_For_C
4243 Check_Unnesting_In_Decls_Or_Stmts (Declarations (Decl_Or_Stmt));
4244 if Present (Statements
4245 (Handled_Statement_Sequence (Decl_Or_Stmt)))
4247 Check_Unnesting_In_Decls_Or_Stmts (Statements
4248 (Handled_Statement_Sequence (Decl_Or_Stmt)));
4249 Check_Unnesting_In_Handlers (Decl_Or_Stmt);
4253 Next (Decl_Or_Stmt);
4256 end Check_Unnesting_In_Decls_Or_Stmts;
4258 ---------------------------------
4259 -- Check_Unnesting_In_Handlers --
4260 ---------------------------------
4262 procedure Check_Unnesting_In_Handlers (N : Node_Id) is
4263 Stmt_Seq : constant Node_Id := Handled_Statement_Sequence (N);
4266 if Present (Stmt_Seq)
4267 and then Present (Exception_Handlers (Stmt_Seq))
4270 Handler : Node_Id := First (Exception_Handlers (Stmt_Seq));
4272 while Present (Handler) loop
4273 if Present (Statements (Handler)) then
4274 Check_Unnesting_In_Decls_Or_Stmts (Statements (Handler));
4281 end Check_Unnesting_In_Handlers;
4283 ------------------------------
4284 -- Check_Visibly_Controlled --
4285 ------------------------------
4287 procedure Check_Visibly_Controlled
4288 (Prim : Final_Primitives;
4290 E : in out Entity_Id;
4291 Cref : in out Node_Id)
4293 Parent_Type : Entity_Id;
4297 if Is_Derived_Type (Typ)
4298 and then Comes_From_Source (E)
4299 and then No (Overridden_Operation (E))
4301 -- We know that the explicit operation on the type does not override
4302 -- the inherited operation of the parent, and that the derivation
4303 -- is from a private type that is not visibly controlled.
4305 Parent_Type := Etype (Typ);
4306 Op := Find_Optional_Prim_Op (Parent_Type, Name_Of (Prim));
4308 if Present (Op) then
4311 -- Wrap the object to be initialized into the proper
4312 -- unchecked conversion, to be compatible with the operation
4315 if Nkind (Cref) = N_Unchecked_Type_Conversion then
4316 Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
4318 Cref := Unchecked_Convert_To (Parent_Type, Cref);
4322 end Check_Visibly_Controlled;
4324 --------------------------
4325 -- Contains_Subprogram --
4326 --------------------------
4328 function Contains_Subprogram (Blk : Entity_Id) return Boolean is
4332 E := First_Entity (Blk);
4334 -- The compiler may generate loops with a declare block containing
4335 -- nested procedures used for finalization. Recursively search for
4336 -- subprograms in such constructs.
4338 if Ekind (Blk) = E_Loop
4339 and then Parent_Kind (Blk) = N_Loop_Statement
4342 Stmt : Node_Id := First (Statements (Parent (Blk)));
4344 while Present (Stmt) loop
4345 if Nkind (Stmt) = N_Block_Statement then
4347 Id : constant Entity_Id :=
4348 Entity (Identifier (Stmt));
4350 if Contains_Subprogram (Id) then
4360 while Present (E) loop
4361 if Is_Subprogram (E) then
4364 elsif Ekind (E) in E_Block | E_Loop
4365 and then Contains_Subprogram (E)
4374 end Contains_Subprogram;
4380 function Convert_View (Proc : Entity_Id; Arg : Node_Id) return Node_Id is
4381 Ftyp : constant Entity_Id := Etype (First_Formal (Proc));
4386 if Nkind (Arg) in N_Type_Conversion | N_Unchecked_Type_Conversion then
4387 Atyp := Entity (Subtype_Mark (Arg));
4389 Atyp := Etype (Arg);
4392 if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
4393 return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
4395 elsif Present (Atyp)
4396 and then Atyp /= Ftyp
4397 and then (Is_Private_Type (Ftyp)
4398 or else Is_Private_Type (Atyp)
4399 or else Is_Private_Type (Base_Type (Atyp)))
4400 and then Implementation_Base_Type (Atyp) =
4401 Implementation_Base_Type (Ftyp)
4403 return Unchecked_Convert_To (Ftyp, Arg);
4405 -- If the argument is already a conversion, as generated by
4406 -- Make_Init_Call, set the target type to the type of the formal
4407 -- directly, to avoid spurious typing problems.
4409 elsif Nkind (Arg) in N_Unchecked_Type_Conversion | N_Type_Conversion
4410 and then not Is_Class_Wide_Type (Atyp)
4412 Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
4413 Set_Etype (Arg, Ftyp);
4416 -- Otherwise, introduce a conversion when the designated object
4417 -- has a type derived from the formal of the controlled routine.
4419 elsif Is_Private_Type (Ftyp)
4420 and then Present (Atyp)
4421 and then Is_Derived_Type (Underlying_Type (Base_Type (Atyp)))
4423 return Unchecked_Convert_To (Ftyp, Arg);
4430 -------------------------------
4431 -- Establish_Transient_Scope --
4432 -------------------------------
4434 -- This procedure is called each time a transient block has to be inserted
4435 -- that is to say for each call to a function with unconstrained or tagged
4436 -- result. It creates a new scope on the scope stack in order to enclose
4437 -- all transient variables generated.
4439 procedure Establish_Transient_Scope
4441 Manage_Sec_Stack : Boolean)
4443 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean;
4444 -- Determine whether arbitrary Id denotes a package or subprogram [body]
4446 function Find_Enclosing_Transient_Scope return Int;
4447 -- Examine the scope stack looking for the nearest enclosing transient
4448 -- scope within the innermost enclosing package or subprogram. Return
4449 -- its index in the table or else -1 if no such scope exists.
4451 function Find_Transient_Context (N : Node_Id) return Node_Id;
4452 -- Locate a suitable context for arbitrary node N which may need to be
4453 -- serviced by a transient scope. Return Empty if no suitable context
4456 procedure Delegate_Sec_Stack_Management;
4457 -- Move the management of the secondary stack to the nearest enclosing
4460 procedure Create_Transient_Scope (Context : Node_Id);
4461 -- Place a new scope on the scope stack in order to service construct
4462 -- Context. Context is the node found by Find_Transient_Context. The
4463 -- new scope may also manage the secondary stack.
4465 ----------------------------
4466 -- Create_Transient_Scope --
4467 ----------------------------
4469 procedure Create_Transient_Scope (Context : Node_Id) is
4470 Loc : constant Source_Ptr := Sloc (N);
4472 Iter_Loop : Entity_Id;
4473 Trans_Scop : constant Entity_Id :=
4474 New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
4477 Set_Etype (Trans_Scop, Standard_Void_Type);
4479 -- Push a new scope, and set its Node_To_Be_Wrapped and Is_Transient
4482 Push_Scope (Trans_Scop);
4483 Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := Context;
4484 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := True;
4486 -- The transient scope must also manage the secondary stack
4488 if Manage_Sec_Stack then
4489 Set_Uses_Sec_Stack (Trans_Scop);
4490 Check_Restriction (No_Secondary_Stack, N);
4492 -- The expansion of iterator loops generates references to objects
4493 -- in order to extract elements from a container:
4495 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4496 -- Obj : <object type> renames Ref.all.Element.all;
4498 -- These references are controlled and returned on the secondary
4499 -- stack. A new reference is created at each iteration of the loop
4500 -- and as a result it must be finalized and the space occupied by
4501 -- it on the secondary stack reclaimed at the end of the current
4504 -- When the context that requires a transient scope is a call to
4505 -- routine Reference, the node to be wrapped is the source object:
4507 -- for Obj of Container loop
4509 -- Routine Wrap_Transient_Declaration however does not generate
4510 -- a physical block as wrapping a declaration will kill it too
4511 -- early. To handle this peculiar case, mark the related iterator
4512 -- loop as requiring the secondary stack. This signals the
4513 -- finalization machinery to manage the secondary stack (see
4514 -- routine Process_Statements_For_Controlled_Objects).
4516 Iter_Loop := Find_Enclosing_Iterator_Loop (Trans_Scop);
4518 if Present (Iter_Loop) then
4519 Set_Uses_Sec_Stack (Iter_Loop);
4523 if Debug_Flag_W then
4524 Write_Str (" <Transient>");
4527 end Create_Transient_Scope;
4529 -----------------------------------
4530 -- Delegate_Sec_Stack_Management --
4531 -----------------------------------
4533 procedure Delegate_Sec_Stack_Management is
4535 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
4537 Scope : Scope_Stack_Entry renames Scope_Stack.Table (Index);
4539 -- Prevent the search from going too far or within the scope
4540 -- space of another unit.
4542 if Scope.Entity = Standard_Standard then
4545 -- No transient scope should be encountered during the
4546 -- traversal because Establish_Transient_Scope should have
4547 -- already handled this case.
4549 elsif Scope.Is_Transient then
4550 raise Program_Error;
4552 -- The construct that requires secondary stack management is
4553 -- always enclosed by a package or subprogram scope.
4555 elsif Is_Package_Or_Subprogram (Scope.Entity) then
4556 Set_Uses_Sec_Stack (Scope.Entity);
4557 Check_Restriction (No_Secondary_Stack, N);
4564 -- At this point no suitable scope was found. This should never occur
4565 -- because a construct is always enclosed by a compilation unit which
4568 pragma Assert (False);
4569 end Delegate_Sec_Stack_Management;
4571 ------------------------------------
4572 -- Find_Enclosing_Transient_Scope --
4573 ------------------------------------
4575 function Find_Enclosing_Transient_Scope return Int is
4577 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
4579 Scope : Scope_Stack_Entry renames Scope_Stack.Table (Index);
4581 -- Prevent the search from going too far or within the scope
4582 -- space of another unit.
4584 if Scope.Entity = Standard_Standard
4585 or else Is_Package_Or_Subprogram (Scope.Entity)
4589 elsif Scope.Is_Transient then
4596 end Find_Enclosing_Transient_Scope;
4598 ----------------------------
4599 -- Find_Transient_Context --
4600 ----------------------------
4602 function Find_Transient_Context (N : Node_Id) return Node_Id is
4603 Curr : Node_Id := N;
4604 Prev : Node_Id := Empty;
4607 while Present (Curr) loop
4608 case Nkind (Curr) is
4612 -- Declarations act as a boundary for a transient scope even if
4613 -- they are not wrapped, see Wrap_Transient_Declaration.
4615 when N_Object_Declaration
4616 | N_Object_Renaming_Declaration
4617 | N_Subtype_Declaration
4623 -- Statements and statement-like constructs act as a boundary
4624 -- for a transient scope.
4626 when N_Accept_Alternative
4627 | N_Attribute_Definition_Clause
4629 | N_Case_Statement_Alternative
4631 | N_Delay_Alternative
4632 | N_Delay_Until_Statement
4633 | N_Delay_Relative_Statement
4634 | N_Discriminant_Association
4636 | N_Entry_Body_Formal_Part
4639 | N_Iteration_Scheme
4640 | N_Terminate_Alternative
4642 pragma Assert (Present (Prev));
4645 when N_Assignment_Statement =>
4648 when N_Entry_Call_Statement
4649 | N_Procedure_Call_Statement
4651 -- When an entry or procedure call acts as the alternative
4652 -- of a conditional or timed entry call, the proper context
4653 -- is that of the alternative.
4655 if Nkind (Parent (Curr)) = N_Entry_Call_Alternative
4656 and then Nkind (Parent (Parent (Curr))) in
4657 N_Conditional_Entry_Call | N_Timed_Entry_Call
4659 return Parent (Parent (Curr));
4661 -- General case for entry or procedure calls
4669 -- Pragma Check is not a valid transient context in
4670 -- GNATprove mode because the pragma must remain unchanged.
4673 and then Get_Pragma_Id (Curr) = Pragma_Check
4677 -- General case for pragmas
4683 when N_Raise_Statement =>
4686 when N_Simple_Return_Statement =>
4688 Fun_Id : constant Entity_Id :=
4689 Return_Applies_To (Return_Statement_Entity (Curr));
4692 -- A transient context that must manage the secondary
4693 -- stack cannot be a return statement of a function that
4694 -- itself requires secondary stack management, because
4695 -- the function's result would be reclaimed too early.
4696 -- And returns of thunks never require transient scopes.
4698 if (Manage_Sec_Stack
4699 and then Needs_Secondary_Stack (Etype (Fun_Id)))
4700 or else Is_Thunk (Fun_Id)
4704 -- General case for return statements
4713 when N_Attribute_Reference =>
4714 if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then
4718 -- An Ada 2012 iterator specification is not a valid context
4719 -- because Analyze_Iterator_Specification already employs
4720 -- special processing for it.
4722 when N_Iterator_Specification =>
4725 when N_Loop_Parameter_Specification =>
4727 -- An iteration scheme is not a valid context because
4728 -- routine Analyze_Iteration_Scheme already employs
4729 -- special processing.
4731 if Nkind (Parent (Curr)) = N_Iteration_Scheme then
4734 return Parent (Curr);
4739 -- The following nodes represent "dummy contexts" which do not
4740 -- need to be wrapped.
4742 when N_Component_Declaration
4743 | N_Discriminant_Specification
4744 | N_Parameter_Specification
4748 -- If the traversal leaves a scope without having been able to
4749 -- find a construct to wrap, something is going wrong, but this
4750 -- can happen in error situations that are not detected yet
4751 -- (such as a dynamic string in a pragma Export).
4753 when N_Block_Statement
4756 | N_Package_Declaration
4770 Curr := Parent (Curr);
4774 end Find_Transient_Context;
4776 ------------------------------
4777 -- Is_Package_Or_Subprogram --
4778 ------------------------------
4780 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean is
4782 return Ekind (Id) in E_Entry
4787 | E_Subprogram_Body;
4788 end Is_Package_Or_Subprogram;
4792 Trans_Idx : constant Int := Find_Enclosing_Transient_Scope;
4795 -- Start of processing for Establish_Transient_Scope
4798 -- Do not create a new transient scope if there is already an enclosing
4799 -- transient scope within the innermost enclosing package or subprogram.
4801 if Trans_Idx >= 0 then
4803 -- If the transient scope was requested for purposes of managing the
4804 -- secondary stack, then the existing scope must perform this task,
4805 -- unless the node to be wrapped is a return statement of a function
4806 -- that requires secondary stack management, because the function's
4807 -- result would be reclaimed too early (see Find_Transient_Context).
4809 if Manage_Sec_Stack then
4811 SE : Scope_Stack_Entry renames Scope_Stack.Table (Trans_Idx);
4814 if Nkind (SE.Node_To_Be_Wrapped) /= N_Simple_Return_Statement
4816 Needs_Secondary_Stack
4819 (Return_Statement_Entity (SE.Node_To_Be_Wrapped))))
4821 Set_Uses_Sec_Stack (SE.Entity);
4829 -- Find the construct that must be serviced by a new transient scope, if
4832 Context := Find_Transient_Context (N);
4834 if Present (Context) then
4835 if Nkind (Context) = N_Assignment_Statement then
4837 -- An assignment statement with suppressed controlled semantics
4838 -- does not need a transient scope because finalization is not
4839 -- desirable at this point. Note that No_Ctrl_Actions is also
4840 -- set for non-controlled assignments to suppress dispatching
4843 if No_Ctrl_Actions (Context)
4844 and then Needs_Finalization (Etype (Name (Context)))
4846 -- When a controlled component is initialized by a function
4847 -- call, the result on the secondary stack is always assigned
4848 -- to the component. Signal the nearest suitable scope that it
4849 -- is safe to manage the secondary stack.
4851 if Manage_Sec_Stack and then Within_Init_Proc then
4852 Delegate_Sec_Stack_Management;
4855 -- Otherwise the assignment is a normal transient context and thus
4856 -- requires a transient scope.
4859 Create_Transient_Scope (Context);
4865 Create_Transient_Scope (Context);
4868 end Establish_Transient_Scope;
4870 ----------------------------
4871 -- Expand_Cleanup_Actions --
4872 ----------------------------
4874 procedure Expand_Cleanup_Actions (N : Node_Id) is
4876 (Nkind (N) in N_Block_Statement
4880 | N_Extended_Return_Statement);
4882 Scop : constant Entity_Id := Current_Scope;
4884 Is_Asynchronous_Call : constant Boolean :=
4885 Nkind (N) = N_Block_Statement
4886 and then Is_Asynchronous_Call_Block (N);
4887 Is_Master : constant Boolean :=
4888 Nkind (N) /= N_Extended_Return_Statement
4889 and then Nkind (N) /= N_Entry_Body
4890 and then Is_Task_Master (N);
4891 Is_Protected_Subp_Body : constant Boolean :=
4892 Nkind (N) = N_Subprogram_Body
4893 and then Is_Protected_Subprogram_Body (N);
4894 Is_Task_Allocation : constant Boolean :=
4895 Nkind (N) = N_Block_Statement
4896 and then Is_Task_Allocation_Block (N);
4897 Is_Task_Body : constant Boolean :=
4898 Nkind (Original_Node (N)) = N_Task_Body;
4900 -- We mark the secondary stack if it is used in this construct, and
4901 -- we're not returning a function result on the secondary stack, except
4902 -- that a build-in-place function that might or might not return on the
4903 -- secondary stack always needs a mark. A run-time test is required in
4904 -- the case where the build-in-place function has a BIP_Alloc extra
4905 -- parameter (see Create_Finalizer).
4907 Needs_Sec_Stack_Mark : constant Boolean :=
4908 (Uses_Sec_Stack (Scop)
4910 not Sec_Stack_Needed_For_Return (Scop))
4912 (Is_Build_In_Place_Function (Scop)
4913 and then Needs_BIP_Alloc_Form (Scop));
4915 Needs_Custom_Cleanup : constant Boolean :=
4916 Nkind (N) = N_Block_Statement
4917 and then Present (Cleanup_Actions (N));
4919 Actions_Required : constant Boolean :=
4920 Requires_Cleanup_Actions (N, True)
4921 or else Is_Asynchronous_Call
4923 or else Is_Protected_Subp_Body
4924 or else Is_Task_Allocation
4925 or else Is_Task_Body
4926 or else Needs_Sec_Stack_Mark
4927 or else Needs_Custom_Cleanup;
4932 -- Start of processing for Expand_Cleanup_Actions
4935 -- The current construct does not need any form of servicing
4937 if not Actions_Required then
4941 -- If an extended return statement contains something like
4945 -- where F is a build-in-place function call returning a controlled
4946 -- type, then a temporary object will be implicitly declared as part
4947 -- of the statement list, and this will need cleanup. In such cases,
4950 -- return Result : T := ... do
4951 -- <statements> -- possibly with handlers
4956 -- return Result : T := ... do
4957 -- declare -- no declarations
4959 -- <statements> -- possibly with handlers
4960 -- end; -- no handlers
4963 -- So Expand_Cleanup_Actions will end up being called recursively on the
4966 if Nkind (N) = N_Extended_Return_Statement then
4968 Block : constant Node_Id :=
4969 Make_Block_Statement (Sloc (N),
4970 Declarations => Empty_List,
4971 Handled_Statement_Sequence =>
4972 Handled_Statement_Sequence (N));
4974 Set_Handled_Statement_Sequence (N,
4975 Make_Handled_Sequence_Of_Statements (Sloc (N),
4976 Statements => New_List (Block)));
4981 -- Analysis of the block did all the work
4986 if Needs_Custom_Cleanup then
4987 Cln := Cleanup_Actions (N);
4992 if No (Declarations (N)) then
4993 Set_Declarations (N, New_List);
4997 Decls : constant List_Id := Declarations (N);
4999 Mark : Entity_Id := Empty;
5001 -- If we are generating expanded code for debugging purposes, use the
5002 -- Sloc of the point of insertion for the cleanup code. The Sloc will
5003 -- be updated subsequently to reference the proper line in .dg files.
5004 -- If we are not debugging generated code, use No_Location instead,
5005 -- so that no debug information is generated for the cleanup code.
5006 -- This makes the behavior of the NEXT command in GDB monotonic, and
5007 -- makes the placement of breakpoints more accurate.
5009 if Debug_Generated_Code then
5015 -- A task activation call has already been built for a task
5016 -- allocation block.
5018 if not Is_Task_Allocation then
5019 Build_Task_Activation_Call (N);
5023 Establish_Task_Master (N);
5026 -- If secondary stack is in use, generate:
5028 -- Mnn : constant Mark_Id := SS_Mark;
5030 if Needs_Sec_Stack_Mark then
5031 Set_Uses_Sec_Stack (Scop, False); -- avoid duplicate SS marks
5032 Mark := Make_Temporary (Loc, 'M');
5035 Mark_Call : constant Node_Id := Build_SS_Mark_Call (Loc, Mark);
5037 Prepend_To (Decls, Mark_Call);
5038 Analyze (Mark_Call);
5042 -- Generate finalization calls for all controlled objects appearing
5043 -- in the statements of N. Add context specific cleanup for various
5048 Clean_Stmts => Build_Cleanup_Statements (N, Cln),
5051 Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
5055 if Present (Fin_Id) then
5056 Build_Finalizer_Call (N, Fin_Id);
5059 end Expand_Cleanup_Actions;
5061 ---------------------------
5062 -- Expand_N_Package_Body --
5063 ---------------------------
5065 -- Add call to Activate_Tasks if body is an activator (actual processing
5066 -- is in chapter 9).
5068 -- Generate subprogram descriptor for elaboration routine
5070 -- Encode entity names in package body
5072 procedure Expand_N_Package_Body (N : Node_Id) is
5073 Id : constant Entity_Id := Defining_Entity (N);
5074 Spec_Id : constant Entity_Id := Corresponding_Spec (N);
5079 -- This is done only for non-generic packages
5081 if Ekind (Spec_Id) = E_Package then
5082 -- Build dispatch tables of library-level tagged types for bodies
5083 -- that are not compilation units (see Analyze_Compilation_Unit),
5084 -- except for instances because they have no N_Compilation_Unit.
5086 if Tagged_Type_Expansion
5087 and then Is_Library_Level_Entity (Spec_Id)
5088 and then (not Is_Compilation_Unit (Spec_Id)
5089 or else Is_Generic_Instance (Spec_Id))
5091 Build_Static_Dispatch_Tables (N);
5094 Push_Scope (Spec_Id);
5096 Expand_CUDA_Package (N);
5098 Build_Task_Activation_Call (N);
5100 -- Verify the run-time semantics of pragma Initial_Condition at the
5101 -- end of the body statements.
5103 Expand_Pragma_Initial_Condition (Spec_Id, N);
5105 -- If this is a library-level package and unnesting is enabled,
5106 -- check for the presence of blocks with nested subprograms occurring
5107 -- in elaboration code, and generate procedures to encapsulate the
5108 -- blocks in case the nested subprograms make up-level references.
5110 if Unnest_Subprogram_Mode
5112 Is_Library_Level_Entity (Current_Scope)
5114 Check_Unnesting_Elaboration_Code (N);
5115 Check_Unnesting_In_Decls_Or_Stmts (Declarations (N));
5116 Check_Unnesting_In_Handlers (N);
5122 Set_Elaboration_Flag (N, Spec_Id);
5123 Set_In_Package_Body (Spec_Id, False);
5125 -- Set to encode entity names in package body before gigi is called
5127 Qualify_Entity_Names (N);
5129 if Ekind (Spec_Id) /= E_Generic_Package
5130 and then not Delay_Cleanups (Id)
5134 Clean_Stmts => No_List,
5136 Top_Decls => No_List,
5137 Defer_Abort => False,
5140 if Present (Fin_Id) then
5141 Set_Finalizer (Defining_Entity (N), Fin_Id);
5144 end Expand_N_Package_Body;
5146 ----------------------------------
5147 -- Expand_N_Package_Declaration --
5148 ----------------------------------
5150 -- Add call to Activate_Tasks if there are tasks declared and the package
5151 -- has no body. Note that in Ada 83 this may result in premature activation
5152 -- of some tasks, given that we cannot tell whether a body will eventually
5155 procedure Expand_N_Package_Declaration (N : Node_Id) is
5156 Id : constant Entity_Id := Defining_Entity (N);
5157 Spec : constant Node_Id := Specification (N);
5161 No_Body : Boolean := False;
5162 -- True in the case of a package declaration that is a compilation
5163 -- unit and for which no associated body will be compiled in this
5167 -- Case of a package declaration other than a compilation unit
5169 if Nkind (Parent (N)) /= N_Compilation_Unit then
5172 -- Case of a compilation unit that does not require a body
5174 elsif not Body_Required (Parent (N))
5175 and then not Unit_Requires_Body (Id)
5179 -- Special case of generating calling stubs for a remote call interface
5180 -- package: even though the package declaration requires one, the body
5181 -- won't be processed in this compilation (so any stubs for RACWs
5182 -- declared in the package must be generated here, along with the spec).
5184 elsif Parent (N) = Cunit (Main_Unit)
5185 and then Is_Remote_Call_Interface (Id)
5186 and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
5191 -- For a nested instance, delay processing until freeze point
5193 if Has_Delayed_Freeze (Id)
5194 and then Nkind (Parent (N)) /= N_Compilation_Unit
5199 -- For a package declaration that implies no associated body, generate
5200 -- task activation call and RACW supporting bodies now (since we won't
5201 -- have a specific separate compilation unit for that).
5206 -- Generate RACW subprogram bodies
5208 if Has_RACW (Id) then
5209 Decls := Private_Declarations (Spec);
5212 Decls := Visible_Declarations (Spec);
5217 Set_Visible_Declarations (Spec, Decls);
5220 Append_RACW_Bodies (Decls, Id);
5221 Analyze_List (Decls);
5224 -- Generate task activation call as last step of elaboration
5226 if Present (Activation_Chain_Entity (N)) then
5227 Build_Task_Activation_Call (N);
5230 -- Verify the run-time semantics of pragma Initial_Condition at the
5231 -- end of the private declarations when the package lacks a body.
5233 Expand_Pragma_Initial_Condition (Id, N);
5238 -- Build dispatch tables of library-level tagged types for instances
5239 -- that are not compilation units (see Analyze_Compilation_Unit).
5241 if Tagged_Type_Expansion
5242 and then Is_Library_Level_Entity (Id)
5243 and then Is_Generic_Instance (Id)
5244 and then not Is_Compilation_Unit (Id)
5246 Build_Static_Dispatch_Tables (N);
5249 -- Note: it is not necessary to worry about generating a subprogram
5250 -- descriptor, since the only way to get exception handlers into a
5251 -- package spec is to include instantiations, and that would cause
5252 -- generation of subprogram descriptors to be delayed in any case.
5254 -- Set to encode entity names in package spec before gigi is called
5256 Qualify_Entity_Names (N);
5258 if Ekind (Id) /= E_Generic_Package
5259 and then not Delay_Cleanups (Id)
5263 Clean_Stmts => No_List,
5265 Top_Decls => No_List,
5266 Defer_Abort => False,
5269 if Present (Fin_Id) then
5270 Set_Finalizer (Id, Fin_Id);
5274 -- If this is a library-level package and unnesting is enabled,
5275 -- check for the presence of blocks with nested subprograms occurring
5276 -- in elaboration code, and generate procedures to encapsulate the
5277 -- blocks in case the nested subprograms make up-level references.
5279 if Unnest_Subprogram_Mode
5280 and then Is_Library_Level_Entity (Current_Scope)
5282 Check_Unnesting_In_Decls_Or_Stmts (Visible_Declarations (Spec));
5283 Check_Unnesting_In_Decls_Or_Stmts (Private_Declarations (Spec));
5285 end Expand_N_Package_Declaration;
5287 ---------------------------------
5288 -- Has_Simple_Protected_Object --
5289 ---------------------------------
5291 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
5293 if Has_Task (T) then
5296 elsif Is_Simple_Protected_Type (T) then
5299 elsif Is_Array_Type (T) then
5300 return Has_Simple_Protected_Object (Component_Type (T));
5302 elsif Is_Record_Type (T) then
5307 Comp := First_Component (T);
5308 while Present (Comp) loop
5309 if Has_Simple_Protected_Object (Etype (Comp)) then
5313 Next_Component (Comp);
5322 end Has_Simple_Protected_Object;
5324 ------------------------------------
5325 -- Insert_Actions_In_Scope_Around --
5326 ------------------------------------
5328 procedure Insert_Actions_In_Scope_Around
5331 Manage_SS : Boolean)
5333 Act_Before : constant List_Id :=
5334 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before);
5335 Act_After : constant List_Id :=
5336 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After);
5337 Act_Cleanup : constant List_Id :=
5338 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup);
5339 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
5340 -- Last), but this was incorrect as Process_Transients_In_Scope may
5341 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
5343 procedure Process_Transients_In_Scope
5344 (First_Object : Node_Id;
5345 Last_Object : Node_Id;
5346 Related_Node : Node_Id);
5347 -- Find all transient objects in the list First_Object .. Last_Object
5348 -- and generate finalization actions for them. Related_Node denotes the
5349 -- node which created all transient objects.
5351 ---------------------------------
5352 -- Process_Transients_In_Scope --
5353 ---------------------------------
5355 procedure Process_Transients_In_Scope
5356 (First_Object : Node_Id;
5357 Last_Object : Node_Id;
5358 Related_Node : Node_Id)
5360 Must_Hook : Boolean;
5361 -- Flag denoting whether the context requires transient object
5362 -- export to the outer finalizer.
5364 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
5365 -- Return Abandon if arbitrary node denotes a subprogram call
5367 function Has_Subprogram_Call is
5368 new Traverse_Func (Is_Subprogram_Call);
5370 procedure Process_Transient_In_Scope
5371 (Obj_Decl : Node_Id;
5372 Blk_Data : Finalization_Exception_Data;
5373 Blk_Stmts : List_Id);
5374 -- Generate finalization actions for a single transient object
5375 -- denoted by object declaration Obj_Decl. Blk_Data is the
5376 -- exception data of the enclosing block. Blk_Stmts denotes the
5377 -- statements of the enclosing block.
5379 ------------------------
5380 -- Is_Subprogram_Call --
5381 ------------------------
5383 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
5385 -- A regular procedure or function call
5387 if Nkind (N) in N_Subprogram_Call then
5392 -- Heavy expansion may relocate function calls outside the related
5393 -- node. Inspect the original node to detect the initial placement
5396 elsif Is_Rewrite_Substitution (N) then
5397 return Has_Subprogram_Call (Original_Node (N));
5399 -- Generalized indexing always involves a function call
5401 elsif Nkind (N) = N_Indexed_Component
5402 and then Present (Generalized_Indexing (N))
5411 end Is_Subprogram_Call;
5413 --------------------------------
5414 -- Process_Transient_In_Scope --
5415 --------------------------------
5417 procedure Process_Transient_In_Scope
5418 (Obj_Decl : Node_Id;
5419 Blk_Data : Finalization_Exception_Data;
5420 Blk_Stmts : List_Id)
5422 Loc : constant Source_Ptr := Sloc (Obj_Decl);
5423 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
5425 Fin_Stmts : List_Id;
5426 Hook_Assign : Node_Id;
5427 Hook_Clear : Node_Id;
5428 Hook_Decl : Node_Id;
5429 Hook_Insert : Node_Id;
5433 -- Mark the transient object as successfully processed to avoid
5434 -- double finalization.
5436 Set_Is_Finalized_Transient (Obj_Id);
5438 -- Construct all the pieces necessary to hook and finalize the
5439 -- transient object.
5441 Build_Transient_Object_Statements
5442 (Obj_Decl => Obj_Decl,
5443 Fin_Call => Fin_Call,
5444 Hook_Assign => Hook_Assign,
5445 Hook_Clear => Hook_Clear,
5446 Hook_Decl => Hook_Decl,
5447 Ptr_Decl => Ptr_Decl);
5449 -- The context contains at least one subprogram call which may
5450 -- raise an exception. This scenario employs "hooking" to pass
5451 -- transient objects to the enclosing finalizer in case of an
5456 -- Add the access type which provides a reference to the
5457 -- transient object. Generate:
5459 -- type Ptr_Typ is access all Desig_Typ;
5461 Insert_Action (Obj_Decl, Ptr_Decl);
5463 -- Add the temporary which acts as a hook to the transient
5464 -- object. Generate:
5466 -- Hook : Ptr_Typ := null;
5468 Insert_Action (Obj_Decl, Hook_Decl);
5470 -- When the transient object is initialized by an aggregate,
5471 -- the hook must capture the object after the last aggregate
5472 -- assignment takes place. Only then is the object considered
5473 -- fully initialized. Generate:
5475 -- Hook := Ptr_Typ (Obj_Id);
5477 -- Hook := Obj_Id'Unrestricted_Access;
5479 -- Similarly if we have a build in place call: we must
5480 -- initialize Hook only after the call has happened, otherwise
5481 -- Obj_Id will not be initialized yet.
5483 if Ekind (Obj_Id) in E_Constant | E_Variable then
5484 if Present (Last_Aggregate_Assignment (Obj_Id)) then
5485 Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
5486 elsif Present (BIP_Initialization_Call (Obj_Id)) then
5487 Hook_Insert := BIP_Initialization_Call (Obj_Id);
5489 Hook_Insert := Obj_Decl;
5492 -- Otherwise the hook seizes the related object immediately
5495 Hook_Insert := Obj_Decl;
5498 Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
5501 -- When exception propagation is enabled wrap the hook clear
5502 -- statement and the finalization call into a block to catch
5503 -- potential exceptions raised during finalization. Generate:
5507 -- [Deep_]Finalize (Obj_Ref);
5511 -- if not Raised then
5514 -- (Enn, Get_Current_Excep.all.all);
5518 if Exceptions_OK then
5519 Fin_Stmts := New_List;
5522 Append_To (Fin_Stmts, Hook_Clear);
5525 Append_To (Fin_Stmts, Fin_Call);
5527 Prepend_To (Blk_Stmts,
5528 Make_Block_Statement (Loc,
5529 Handled_Statement_Sequence =>
5530 Make_Handled_Sequence_Of_Statements (Loc,
5531 Statements => Fin_Stmts,
5532 Exception_Handlers => New_List (
5533 Build_Exception_Handler (Blk_Data)))));
5535 -- Otherwise generate:
5538 -- [Deep_]Finalize (Obj_Ref);
5540 -- Note that the statements are inserted in reverse order to
5541 -- achieve the desired final order outlined above.
5544 Prepend_To (Blk_Stmts, Fin_Call);
5547 Prepend_To (Blk_Stmts, Hook_Clear);
5550 end Process_Transient_In_Scope;
5554 Built : Boolean := False;
5555 Blk_Data : Finalization_Exception_Data;
5556 Blk_Decl : Node_Id := Empty;
5557 Blk_Decls : List_Id := No_List;
5559 Blk_Stmts : List_Id := No_List;
5560 Loc : Source_Ptr := No_Location;
5563 -- Start of processing for Process_Transients_In_Scope
5566 -- The expansion performed by this routine is as follows:
5568 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5569 -- Hook_1 : Ptr_Typ_1 := null;
5570 -- Ctrl_Trans_Obj_1 : ...;
5571 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5573 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5574 -- Hook_N : Ptr_Typ_N := null;
5575 -- Ctrl_Trans_Obj_N : ...;
5576 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5579 -- Abrt : constant Boolean := ...;
5580 -- Ex : Exception_Occurrence;
5581 -- Raised : Boolean := False;
5588 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5592 -- if not Raised then
5594 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5599 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5603 -- if not Raised then
5605 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5610 -- if Raised and not Abrt then
5611 -- Raise_From_Controlled_Operation (Ex);
5615 -- Recognize a scenario where the transient context is an object
5616 -- declaration initialized by a build-in-place function call:
5618 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5620 -- The rough expansion of the above is:
5622 -- Temp : ... := Ctrl_Func_Call;
5624 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5626 -- The finalization of any transient object must happen after the
5627 -- build-in-place function call is executed.
5629 if Nkind (N) = N_Object_Declaration
5630 and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
5633 Blk_Ins := BIP_Initialization_Call (Defining_Identifier (N));
5635 -- Search the context for at least one subprogram call. If found, the
5636 -- machinery exports all transient objects to the enclosing finalizer
5637 -- due to the possibility of abnormal call termination.
5640 Must_Hook := Has_Subprogram_Call (N) = Abandon;
5641 Blk_Ins := Last_Object;
5645 Insert_List_After_And_Analyze (Blk_Ins, Act_Cleanup);
5648 -- Examine all objects in the list First_Object .. Last_Object
5650 Obj_Decl := First_Object;
5651 while Present (Obj_Decl) loop
5652 if Nkind (Obj_Decl) = N_Object_Declaration
5653 and then Analyzed (Obj_Decl)
5654 and then Is_Finalizable_Transient (Obj_Decl, N)
5656 -- Do not process the node to be wrapped since it will be
5657 -- handled by the enclosing finalizer.
5659 and then Obj_Decl /= Related_Node
5661 Loc := Sloc (Obj_Decl);
5663 -- Before generating the cleanup code for the first transient
5664 -- object, create a wrapper block which houses all hook clear
5665 -- statements and finalization calls. This wrapper is needed by
5670 Blk_Stmts := New_List;
5673 -- Abrt : constant Boolean := ...;
5674 -- Ex : Exception_Occurrence;
5675 -- Raised : Boolean := False;
5677 if Exceptions_OK then
5678 Blk_Decls := New_List;
5679 Build_Object_Declarations (Blk_Data, Blk_Decls, Loc);
5683 Make_Block_Statement (Loc,
5684 Declarations => Blk_Decls,
5685 Handled_Statement_Sequence =>
5686 Make_Handled_Sequence_Of_Statements (Loc,
5687 Statements => Blk_Stmts));
5690 -- Construct all necessary circuitry to hook and finalize a
5691 -- single transient object.
5693 pragma Assert (Present (Blk_Stmts));
5694 Process_Transient_In_Scope
5695 (Obj_Decl => Obj_Decl,
5696 Blk_Data => Blk_Data,
5697 Blk_Stmts => Blk_Stmts);
5700 -- Terminate the scan after the last object has been processed to
5701 -- avoid touching unrelated code.
5703 if Obj_Decl = Last_Object then
5710 -- Complete the decoration of the enclosing finalization block and
5711 -- insert it into the tree.
5713 if Present (Blk_Decl) then
5715 pragma Assert (Present (Blk_Stmts));
5716 pragma Assert (Loc /= No_Location);
5718 -- Note that this Abort_Undefer does not require a extra block or
5719 -- an AT_END handler because each finalization exception is caught
5720 -- in its own corresponding finalization block. As a result, the
5721 -- call to Abort_Defer always takes place.
5723 if Abort_Allowed then
5724 Prepend_To (Blk_Stmts,
5725 Build_Runtime_Call (Loc, RE_Abort_Defer));
5727 Append_To (Blk_Stmts,
5728 Build_Runtime_Call (Loc, RE_Abort_Undefer));
5732 -- if Raised and then not Abrt then
5733 -- Raise_From_Controlled_Operation (Ex);
5736 if Exceptions_OK then
5737 Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data));
5740 Insert_After_And_Analyze (Blk_Ins, Blk_Decl);
5742 end Process_Transients_In_Scope;
5746 Loc : constant Source_Ptr := Sloc (N);
5747 Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
5748 First_Obj : Node_Id;
5750 Mark_Id : Entity_Id;
5753 -- Start of processing for Insert_Actions_In_Scope_Around
5756 -- Nothing to do if the scope does not manage the secondary stack or
5757 -- does not contain meaningful actions for insertion.
5760 and then No (Act_Before)
5761 and then No (Act_After)
5762 and then No (Act_Cleanup)
5767 -- If the node to be wrapped is the trigger of an asynchronous select,
5768 -- it is not part of a statement list. The actions must be inserted
5769 -- before the select itself, which is part of some list of statements.
5770 -- Note that the triggering alternative includes the triggering
5771 -- statement and an optional statement list. If the node to be
5772 -- wrapped is part of that list, the normal insertion applies.
5774 if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative
5775 and then not Is_List_Member (Node_To_Wrap)
5777 Target := Parent (Parent (Node_To_Wrap));
5782 First_Obj := Target;
5785 -- Add all actions associated with a transient scope into the main tree.
5786 -- There are several scenarios here:
5788 -- +--- Before ----+ +----- After ---+
5789 -- 1) First_Obj ....... Target ........ Last_Obj
5791 -- 2) First_Obj ....... Target
5793 -- 3) Target ........ Last_Obj
5795 -- Flag declarations are inserted before the first object
5797 if Present (Act_Before) then
5798 First_Obj := First (Act_Before);
5799 Insert_List_Before (Target, Act_Before);
5802 -- Finalization calls are inserted after the last object
5804 if Present (Act_After) then
5805 Last_Obj := Last (Act_After);
5806 Insert_List_After (Target, Act_After);
5809 -- Mark and release the secondary stack when the context warrants it
5812 Mark_Id := Make_Temporary (Loc, 'M');
5815 -- Mnn : constant Mark_Id := SS_Mark;
5817 Insert_Before_And_Analyze
5818 (First_Obj, Build_SS_Mark_Call (Loc, Mark_Id));
5821 -- SS_Release (Mnn);
5823 Insert_After_And_Analyze
5824 (Last_Obj, Build_SS_Release_Call (Loc, Mark_Id));
5827 -- Check for transient objects associated with Target and generate the
5828 -- appropriate finalization actions for them.
5830 Process_Transients_In_Scope
5831 (First_Object => First_Obj,
5832 Last_Object => Last_Obj,
5833 Related_Node => Target);
5835 -- Reset the action lists
5838 (Scope_Stack.Last).Actions_To_Be_Wrapped (Before) := No_List;
5840 (Scope_Stack.Last).Actions_To_Be_Wrapped (After) := No_List;
5844 (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup) := No_List;
5846 end Insert_Actions_In_Scope_Around;
5848 ------------------------------
5849 -- Is_Simple_Protected_Type --
5850 ------------------------------
5852 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
5855 Is_Protected_Type (T)
5856 and then not Uses_Lock_Free (T)
5857 and then not Has_Entries (T)
5858 and then Is_RTE (Find_Protection_Type (T), RE_Protection);
5859 end Is_Simple_Protected_Type;
5861 -----------------------
5862 -- Make_Adjust_Call --
5863 -----------------------
5865 function Make_Adjust_Call
5868 Skip_Self : Boolean := False) return Node_Id
5870 Loc : constant Source_Ptr := Sloc (Obj_Ref);
5871 Adj_Id : Entity_Id := Empty;
5878 -- Recover the proper type which contains Deep_Adjust
5880 if Is_Class_Wide_Type (Typ) then
5881 Utyp := Root_Type (Typ);
5886 Utyp := Underlying_Type (Base_Type (Utyp));
5887 Set_Assignment_OK (Ref);
5889 -- Deal with untagged derivation of private views
5891 if Present (Utyp) and then Is_Untagged_Derivation (Typ) then
5892 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
5893 Ref := Unchecked_Convert_To (Utyp, Ref);
5894 Set_Assignment_OK (Ref);
5897 -- When dealing with the completion of a private type, use the base
5900 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
5901 pragma Assert (Is_Private_Type (Typ));
5903 Utyp := Base_Type (Utyp);
5904 Ref := Unchecked_Convert_To (Utyp, Ref);
5907 -- The underlying type may not be present due to a missing full view. In
5908 -- this case freezing did not take place and there is no [Deep_]Adjust
5909 -- primitive to call.
5914 elsif Skip_Self then
5915 if Has_Controlled_Component (Utyp) then
5916 if Is_Tagged_Type (Utyp) then
5917 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
5919 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
5923 -- Class-wide types, interfaces and types with controlled components
5925 elsif Is_Class_Wide_Type (Typ)
5926 or else Is_Interface (Typ)
5927 or else Has_Controlled_Component (Utyp)
5929 if Is_Tagged_Type (Utyp) then
5930 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
5932 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
5935 -- Derivations from [Limited_]Controlled
5937 elsif Is_Controlled (Utyp) then
5938 Adj_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Adjust_Case));
5942 elsif Is_Tagged_Type (Utyp) then
5943 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
5946 raise Program_Error;
5949 if Present (Adj_Id) then
5951 -- If the object is unanalyzed, set its expected type for use in
5952 -- Convert_View in case an additional conversion is needed.
5955 and then Nkind (Ref) /= N_Unchecked_Type_Conversion
5957 Set_Etype (Ref, Typ);
5960 -- The object reference may need another conversion depending on the
5961 -- type of the formal and that of the actual.
5963 if not Is_Class_Wide_Type (Typ) then
5964 Ref := Convert_View (Adj_Id, Ref);
5971 Skip_Self => Skip_Self);
5975 end Make_Adjust_Call;
5983 Proc_Id : Entity_Id;
5985 Skip_Self : Boolean := False) return Node_Id
5987 Params : constant List_Id := New_List (Param);
5990 -- Do not apply the controlled action to the object itself by signaling
5991 -- the related routine to avoid self.
5994 Append_To (Params, New_Occurrence_Of (Standard_False, Loc));
5998 Make_Procedure_Call_Statement (Loc,
5999 Name => New_Occurrence_Of (Proc_Id, Loc),
6000 Parameter_Associations => Params);
6003 --------------------------
6004 -- Make_Deep_Array_Body --
6005 --------------------------
6007 function Make_Deep_Array_Body
6008 (Prim : Final_Primitives;
6009 Typ : Entity_Id) return List_Id
6011 function Build_Adjust_Or_Finalize_Statements
6012 (Typ : Entity_Id) return List_Id;
6013 -- Create the statements necessary to adjust or finalize an array of
6014 -- controlled elements. Generate:
6017 -- Abort : constant Boolean := Triggered_By_Abort;
6019 -- Abort : constant Boolean := False; -- no abort
6021 -- E : Exception_Occurrence;
6022 -- Raised : Boolean := False;
6025 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
6026 -- ^-- in the finalization case
6028 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
6030 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
6034 -- if not Raised then
6036 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6043 -- if Raised and then not Abort then
6044 -- Raise_From_Controlled_Operation (E);
6048 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id;
6049 -- Create the statements necessary to initialize an array of controlled
6050 -- elements. Include a mechanism to carry out partial finalization if an
6051 -- exception occurs. Generate:
6054 -- Counter : Integer := 0;
6057 -- for J1 in V'Range (1) loop
6059 -- for JN in V'Range (N) loop
6061 -- [Deep_]Initialize (V (J1, ..., JN));
6063 -- Counter := Counter + 1;
6068 -- Abort : constant Boolean := Triggered_By_Abort;
6070 -- Abort : constant Boolean := False; -- no abort
6071 -- E : Exception_Occurrence;
6072 -- Raised : Boolean := False;
6079 -- V'Length (N) - Counter;
6081 -- for F1 in reverse V'Range (1) loop
6083 -- for FN in reverse V'Range (N) loop
6084 -- if Counter > 0 then
6085 -- Counter := Counter - 1;
6088 -- [Deep_]Finalize (V (F1, ..., FN));
6092 -- if not Raised then
6094 -- Save_Occurrence (E,
6095 -- Get_Current_Excep.all.all);
6104 -- if Raised and then not Abort then
6105 -- Raise_From_Controlled_Operation (E);
6114 function New_References_To
6116 Loc : Source_Ptr) return List_Id;
6117 -- Given a list of defining identifiers, return a list of references to
6118 -- the original identifiers, in the same order as they appear.
6120 -----------------------------------------
6121 -- Build_Adjust_Or_Finalize_Statements --
6122 -----------------------------------------
6124 function Build_Adjust_Or_Finalize_Statements
6125 (Typ : Entity_Id) return List_Id
6127 Comp_Typ : constant Entity_Id := Component_Type (Typ);
6128 Index_List : constant List_Id := New_List;
6129 Loc : constant Source_Ptr := Sloc (Typ);
6130 Num_Dims : constant Int := Number_Dimensions (Typ);
6132 procedure Build_Indexes;
6133 -- Generate the indexes used in the dimension loops
6139 procedure Build_Indexes is
6141 -- Generate the following identifiers:
6142 -- Jnn - for initialization
6144 for Dim in 1 .. Num_Dims loop
6145 Append_To (Index_List,
6146 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
6152 Final_Decls : List_Id := No_List;
6153 Final_Data : Finalization_Exception_Data;
6157 Core_Loop : Node_Id;
6160 Loop_Id : Entity_Id;
6163 -- Start of processing for Build_Adjust_Or_Finalize_Statements
6166 Final_Decls := New_List;
6169 Build_Object_Declarations (Final_Data, Final_Decls, Loc);
6172 Make_Indexed_Component (Loc,
6173 Prefix => Make_Identifier (Loc, Name_V),
6174 Expressions => New_References_To (Index_List, Loc));
6175 Set_Etype (Comp_Ref, Comp_Typ);
6178 -- [Deep_]Adjust (V (J1, ..., JN))
6180 if Prim = Adjust_Case then
6181 Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6184 -- [Deep_]Finalize (V (J1, ..., JN))
6186 else pragma Assert (Prim = Finalize_Case);
6187 Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6190 if Present (Call) then
6192 -- Generate the block which houses the adjust or finalize call:
6195 -- <adjust or finalize call>
6199 -- if not Raised then
6201 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6205 if Exceptions_OK then
6207 Make_Block_Statement (Loc,
6208 Handled_Statement_Sequence =>
6209 Make_Handled_Sequence_Of_Statements (Loc,
6210 Statements => New_List (Call),
6211 Exception_Handlers => New_List (
6212 Build_Exception_Handler (Final_Data))));
6217 -- Generate the dimension loops starting from the innermost one
6219 -- for Jnn in [reverse] V'Range (Dim) loop
6223 J := Last (Index_List);
6225 while Present (J) and then Dim > 0 loop
6231 Make_Loop_Statement (Loc,
6233 Make_Iteration_Scheme (Loc,
6234 Loop_Parameter_Specification =>
6235 Make_Loop_Parameter_Specification (Loc,
6236 Defining_Identifier => Loop_Id,
6237 Discrete_Subtype_Definition =>
6238 Make_Attribute_Reference (Loc,
6239 Prefix => Make_Identifier (Loc, Name_V),
6240 Attribute_Name => Name_Range,
6241 Expressions => New_List (
6242 Make_Integer_Literal (Loc, Dim))),
6245 Prim = Finalize_Case)),
6247 Statements => New_List (Core_Loop),
6248 End_Label => Empty);
6253 -- Generate the block which contains the core loop, declarations
6254 -- of the abort flag, the exception occurrence, the raised flag
6255 -- and the conditional raise:
6258 -- Abort : constant Boolean := Triggered_By_Abort;
6260 -- Abort : constant Boolean := False; -- no abort
6262 -- E : Exception_Occurrence;
6263 -- Raised : Boolean := False;
6268 -- if Raised and then not Abort then
6269 -- Raise_From_Controlled_Operation (E);
6273 Stmts := New_List (Core_Loop);
6275 if Exceptions_OK then
6276 Append_To (Stmts, Build_Raise_Statement (Final_Data));
6280 Make_Block_Statement (Loc,
6281 Declarations => Final_Decls,
6282 Handled_Statement_Sequence =>
6283 Make_Handled_Sequence_Of_Statements (Loc,
6284 Statements => Stmts));
6286 -- Otherwise previous errors or a missing full view may prevent the
6287 -- proper freezing of the component type. If this is the case, there
6288 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
6291 Block := Make_Null_Statement (Loc);
6294 return New_List (Block);
6295 end Build_Adjust_Or_Finalize_Statements;
6297 ---------------------------------
6298 -- Build_Initialize_Statements --
6299 ---------------------------------
6301 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
6302 Comp_Typ : constant Entity_Id := Component_Type (Typ);
6303 Final_List : constant List_Id := New_List;
6304 Index_List : constant List_Id := New_List;
6305 Loc : constant Source_Ptr := Sloc (Typ);
6306 Num_Dims : constant Int := Number_Dimensions (Typ);
6308 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id;
6309 -- Generate the following assignment:
6310 -- Counter := V'Length (1) *
6312 -- V'Length (N) - Counter;
6314 -- Counter_Id denotes the entity of the counter.
6316 function Build_Finalization_Call return Node_Id;
6317 -- Generate a deep finalization call for an array element
6319 procedure Build_Indexes;
6320 -- Generate the initialization and finalization indexes used in the
6323 function Build_Initialization_Call return Node_Id;
6324 -- Generate a deep initialization call for an array element
6326 ----------------------
6327 -- Build_Assignment --
6328 ----------------------
6330 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id is
6335 -- Start from the first dimension and generate:
6340 Make_Attribute_Reference (Loc,
6341 Prefix => Make_Identifier (Loc, Name_V),
6342 Attribute_Name => Name_Length,
6343 Expressions => New_List (Make_Integer_Literal (Loc, Dim)));
6345 -- Process the rest of the dimensions, generate:
6346 -- Expr * V'Length (N)
6349 while Dim <= Num_Dims loop
6351 Make_Op_Multiply (Loc,
6354 Make_Attribute_Reference (Loc,
6355 Prefix => Make_Identifier (Loc, Name_V),
6356 Attribute_Name => Name_Length,
6357 Expressions => New_List (
6358 Make_Integer_Literal (Loc, Dim))));
6364 -- Counter := Expr - Counter;
6367 Make_Assignment_Statement (Loc,
6368 Name => New_Occurrence_Of (Counter_Id, Loc),
6370 Make_Op_Subtract (Loc,
6372 Right_Opnd => New_Occurrence_Of (Counter_Id, Loc)));
6373 end Build_Assignment;
6375 -----------------------------
6376 -- Build_Finalization_Call --
6377 -----------------------------
6379 function Build_Finalization_Call return Node_Id is
6380 Comp_Ref : constant Node_Id :=
6381 Make_Indexed_Component (Loc,
6382 Prefix => Make_Identifier (Loc, Name_V),
6383 Expressions => New_References_To (Final_List, Loc));
6386 Set_Etype (Comp_Ref, Comp_Typ);
6389 -- [Deep_]Finalize (V);
6391 return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6392 end Build_Finalization_Call;
6398 procedure Build_Indexes is
6400 -- Generate the following identifiers:
6401 -- Jnn - for initialization
6402 -- Fnn - for finalization
6404 for Dim in 1 .. Num_Dims loop
6405 Append_To (Index_List,
6406 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
6408 Append_To (Final_List,
6409 Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
6413 -------------------------------
6414 -- Build_Initialization_Call --
6415 -------------------------------
6417 function Build_Initialization_Call return Node_Id is
6418 Comp_Ref : constant Node_Id :=
6419 Make_Indexed_Component (Loc,
6420 Prefix => Make_Identifier (Loc, Name_V),
6421 Expressions => New_References_To (Index_List, Loc));
6424 Set_Etype (Comp_Ref, Comp_Typ);
6427 -- [Deep_]Initialize (V (J1, ..., JN));
6429 return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6430 end Build_Initialization_Call;
6434 Counter_Id : Entity_Id;
6438 Final_Block : Node_Id;
6439 Final_Data : Finalization_Exception_Data;
6440 Final_Decls : List_Id := No_List;
6441 Final_Loop : Node_Id;
6442 Init_Block : Node_Id;
6443 Init_Call : Node_Id;
6444 Init_Loop : Node_Id;
6449 -- Start of processing for Build_Initialize_Statements
6452 Counter_Id := Make_Temporary (Loc, 'C');
6453 Final_Decls := New_List;
6456 Build_Object_Declarations (Final_Data, Final_Decls, Loc);
6458 -- Generate the block which houses the finalization call, the index
6459 -- guard and the handler which triggers Program_Error later on.
6461 -- if Counter > 0 then
6462 -- Counter := Counter - 1;
6465 -- [Deep_]Finalize (V (F1, ..., FN));
6468 -- if not Raised then
6470 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6475 Fin_Stmt := Build_Finalization_Call;
6477 if Present (Fin_Stmt) then
6478 if Exceptions_OK then
6480 Make_Block_Statement (Loc,
6481 Handled_Statement_Sequence =>
6482 Make_Handled_Sequence_Of_Statements (Loc,
6483 Statements => New_List (Fin_Stmt),
6484 Exception_Handlers => New_List (
6485 Build_Exception_Handler (Final_Data))));
6488 -- This is the core of the loop, the dimension iterators are added
6489 -- one by one in reverse.
6492 Make_If_Statement (Loc,
6495 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6496 Right_Opnd => Make_Integer_Literal (Loc, 0)),
6498 Then_Statements => New_List (
6499 Make_Assignment_Statement (Loc,
6500 Name => New_Occurrence_Of (Counter_Id, Loc),
6502 Make_Op_Subtract (Loc,
6503 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6504 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
6506 Else_Statements => New_List (Fin_Stmt));
6508 -- Generate all finalization loops starting from the innermost
6511 -- for Fnn in reverse V'Range (Dim) loop
6515 F := Last (Final_List);
6517 while Present (F) and then Dim > 0 loop
6523 Make_Loop_Statement (Loc,
6525 Make_Iteration_Scheme (Loc,
6526 Loop_Parameter_Specification =>
6527 Make_Loop_Parameter_Specification (Loc,
6528 Defining_Identifier => Loop_Id,
6529 Discrete_Subtype_Definition =>
6530 Make_Attribute_Reference (Loc,
6531 Prefix => Make_Identifier (Loc, Name_V),
6532 Attribute_Name => Name_Range,
6533 Expressions => New_List (
6534 Make_Integer_Literal (Loc, Dim))),
6536 Reverse_Present => True)),
6538 Statements => New_List (Final_Loop),
6539 End_Label => Empty);
6544 -- Generate the block which contains the finalization loops, the
6545 -- declarations of the abort flag, the exception occurrence, the
6546 -- raised flag and the conditional raise.
6549 -- Abort : constant Boolean := Triggered_By_Abort;
6551 -- Abort : constant Boolean := False; -- no abort
6553 -- E : Exception_Occurrence;
6554 -- Raised : Boolean := False;
6560 -- V'Length (N) - Counter;
6564 -- if Raised and then not Abort then
6565 -- Raise_From_Controlled_Operation (E);
6571 Stmts := New_List (Build_Assignment (Counter_Id), Final_Loop);
6573 if Exceptions_OK then
6574 Append_To (Stmts, Build_Raise_Statement (Final_Data));
6575 Append_To (Stmts, Make_Raise_Statement (Loc));
6579 Make_Block_Statement (Loc,
6580 Declarations => Final_Decls,
6581 Handled_Statement_Sequence =>
6582 Make_Handled_Sequence_Of_Statements (Loc,
6583 Statements => Stmts));
6585 -- Otherwise previous errors or a missing full view may prevent the
6586 -- proper freezing of the component type. If this is the case, there
6587 -- is no [Deep_]Finalize primitive to call.
6590 Final_Block := Make_Null_Statement (Loc);
6593 -- Generate the block which contains the initialization call and
6594 -- the partial finalization code.
6597 -- [Deep_]Initialize (V (J1, ..., JN));
6599 -- Counter := Counter + 1;
6603 -- <finalization code>
6606 Init_Call := Build_Initialization_Call;
6608 -- Only create finalization block if there is a nontrivial call
6609 -- to initialization or a Default_Initial_Condition check to be
6612 if (Present (Init_Call)
6613 and then Nkind (Init_Call) /= N_Null_Statement)
6616 and then not GNATprove_Mode
6617 and then Present (DIC_Procedure (Comp_Typ))
6618 and then not Has_Null_Body (DIC_Procedure (Comp_Typ)))
6621 Init_Stmts : constant List_Id := New_List;
6624 if Present (Init_Call) then
6625 Append_To (Init_Stmts, Init_Call);
6628 if Has_DIC (Comp_Typ)
6629 and then Present (DIC_Procedure (Comp_Typ))
6633 Build_DIC_Call (Loc,
6634 Make_Indexed_Component (Loc,
6635 Prefix => Make_Identifier (Loc, Name_V),
6636 Expressions => New_References_To (Index_List, Loc)),
6641 Make_Block_Statement (Loc,
6642 Handled_Statement_Sequence =>
6643 Make_Handled_Sequence_Of_Statements (Loc,
6644 Statements => Init_Stmts,
6645 Exception_Handlers => New_List (
6646 Make_Exception_Handler (Loc,
6647 Exception_Choices => New_List (
6648 Make_Others_Choice (Loc)),
6649 Statements => New_List (Final_Block)))));
6652 Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
6653 Make_Assignment_Statement (Loc,
6654 Name => New_Occurrence_Of (Counter_Id, Loc),
6657 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6658 Right_Opnd => Make_Integer_Literal (Loc, 1))));
6660 -- Generate all initialization loops starting from the innermost
6663 -- for Jnn in V'Range (Dim) loop
6667 J := Last (Index_List);
6669 while Present (J) and then Dim > 0 loop
6675 Make_Loop_Statement (Loc,
6677 Make_Iteration_Scheme (Loc,
6678 Loop_Parameter_Specification =>
6679 Make_Loop_Parameter_Specification (Loc,
6680 Defining_Identifier => Loop_Id,
6681 Discrete_Subtype_Definition =>
6682 Make_Attribute_Reference (Loc,
6683 Prefix => Make_Identifier (Loc, Name_V),
6684 Attribute_Name => Name_Range,
6685 Expressions => New_List (
6686 Make_Integer_Literal (Loc, Dim))))),
6688 Statements => New_List (Init_Loop),
6689 End_Label => Empty);
6694 -- Generate the block which contains the counter variable and the
6695 -- initialization loops.
6698 -- Counter : Integer := 0;
6704 Make_Block_Statement (Loc,
6705 Declarations => New_List (
6706 Make_Object_Declaration (Loc,
6707 Defining_Identifier => Counter_Id,
6708 Object_Definition =>
6709 New_Occurrence_Of (Standard_Integer, Loc),
6710 Expression => Make_Integer_Literal (Loc, 0))),
6712 Handled_Statement_Sequence =>
6713 Make_Handled_Sequence_Of_Statements (Loc,
6714 Statements => New_List (Init_Loop)));
6716 if Debug_Generated_Code then
6717 Set_Debug_Info_Needed (Counter_Id);
6720 -- Otherwise previous errors or a missing full view may prevent the
6721 -- proper freezing of the component type. If this is the case, there
6722 -- is no [Deep_]Initialize primitive to call.
6725 Init_Block := Make_Null_Statement (Loc);
6728 return New_List (Init_Block);
6729 end Build_Initialize_Statements;
6731 -----------------------
6732 -- New_References_To --
6733 -----------------------
6735 function New_References_To
6737 Loc : Source_Ptr) return List_Id
6739 Refs : constant List_Id := New_List;
6744 while Present (Id) loop
6745 Append_To (Refs, New_Occurrence_Of (Id, Loc));
6750 end New_References_To;
6752 -- Start of processing for Make_Deep_Array_Body
6756 when Address_Case =>
6757 return Make_Finalize_Address_Stmts (Typ);
6762 return Build_Adjust_Or_Finalize_Statements (Typ);
6764 when Initialize_Case =>
6765 return Build_Initialize_Statements (Typ);
6767 end Make_Deep_Array_Body;
6769 --------------------
6770 -- Make_Deep_Proc --
6771 --------------------
6773 function Make_Deep_Proc
6774 (Prim : Final_Primitives;
6776 Stmts : List_Id) return Entity_Id
6778 Loc : constant Source_Ptr := Sloc (Typ);
6780 Proc_Id : Entity_Id;
6783 -- Create the object formal, generate:
6784 -- V : System.Address
6786 if Prim = Address_Case then
6787 Formals := New_List (
6788 Make_Parameter_Specification (Loc,
6789 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
6791 New_Occurrence_Of (RTE (RE_Address), Loc)));
6798 Formals := New_List (
6799 Make_Parameter_Specification (Loc,
6800 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
6802 Out_Present => True,
6803 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
6805 -- F : Boolean := True
6807 if Prim = Adjust_Case
6808 or else Prim = Finalize_Case
6811 Make_Parameter_Specification (Loc,
6812 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
6814 New_Occurrence_Of (Standard_Boolean, Loc),
6816 New_Occurrence_Of (Standard_True, Loc)));
6821 Make_Defining_Identifier (Loc,
6822 Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
6825 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6828 -- exception -- Finalize and Adjust cases only
6829 -- raise Program_Error;
6830 -- end Deep_Initialize / Adjust / Finalize;
6834 -- procedure Finalize_Address (V : System.Address) is
6837 -- end Finalize_Address;
6840 Make_Subprogram_Body (Loc,
6842 Make_Procedure_Specification (Loc,
6843 Defining_Unit_Name => Proc_Id,
6844 Parameter_Specifications => Formals),
6846 Declarations => Empty_List,
6848 Handled_Statement_Sequence =>
6849 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
6851 -- If there are no calls to component initialization, indicate that
6852 -- the procedure is trivial, so prevent calls to it.
6854 if Is_Empty_List (Stmts)
6855 or else Nkind (First (Stmts)) = N_Null_Statement
6857 Set_Is_Trivial_Subprogram (Proc_Id);
6863 ---------------------------
6864 -- Make_Deep_Record_Body --
6865 ---------------------------
6867 function Make_Deep_Record_Body
6868 (Prim : Final_Primitives;
6870 Is_Local : Boolean := False) return List_Id
6872 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
6873 -- Build the statements necessary to adjust a record type. The type may
6874 -- have discriminants and contain variant parts. Generate:
6878 -- [Deep_]Adjust (V.Comp_1);
6880 -- when Id : others =>
6881 -- if not Raised then
6883 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6888 -- [Deep_]Adjust (V.Comp_N);
6890 -- when Id : others =>
6891 -- if not Raised then
6893 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6898 -- Deep_Adjust (V._parent, False); -- If applicable
6900 -- when Id : others =>
6901 -- if not Raised then
6903 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6909 -- Adjust (V); -- If applicable
6912 -- if not Raised then
6914 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6919 -- if Raised and then not Abort then
6920 -- Raise_From_Controlled_Operation (E);
6924 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
6925 -- Build the statements necessary to finalize a record type. The type
6926 -- may have discriminants and contain variant parts. Generate:
6929 -- Abort : constant Boolean := Triggered_By_Abort;
6931 -- Abort : constant Boolean := False; -- no abort
6932 -- E : Exception_Occurrence;
6933 -- Raised : Boolean := False;
6938 -- Finalize (V); -- If applicable
6941 -- if not Raised then
6943 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6948 -- case Variant_1 is
6950 -- case State_Counter_N => -- If Is_Local is enabled
6960 -- <<LN>> -- If Is_Local is enabled
6962 -- [Deep_]Finalize (V.Comp_N);
6965 -- if not Raised then
6967 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6973 -- [Deep_]Finalize (V.Comp_1);
6976 -- if not Raised then
6978 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6984 -- case State_Counter_1 => -- If Is_Local is enabled
6990 -- Deep_Finalize (V._parent, False); -- If applicable
6992 -- when Id : others =>
6993 -- if not Raised then
6995 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6999 -- if Raised and then not Abort then
7000 -- Raise_From_Controlled_Operation (E);
7004 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id;
7005 -- Given a derived tagged type Typ, traverse all components, find field
7006 -- _parent and return its type.
7008 procedure Preprocess_Components
7010 Num_Comps : out Nat;
7011 Has_POC : out Boolean);
7012 -- Examine all components in component list Comps, count all controlled
7013 -- components and determine whether at least one of them is per-object
7014 -- constrained. Component _parent is always skipped.
7016 -----------------------------
7017 -- Build_Adjust_Statements --
7018 -----------------------------
7020 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
7021 Loc : constant Source_Ptr := Sloc (Typ);
7022 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
7024 Finalizer_Data : Finalization_Exception_Data;
7026 function Process_Component_List_For_Adjust
7027 (Comps : Node_Id) return List_Id;
7028 -- Build all necessary adjust statements for a single component list
7030 ---------------------------------------
7031 -- Process_Component_List_For_Adjust --
7032 ---------------------------------------
7034 function Process_Component_List_For_Adjust
7035 (Comps : Node_Id) return List_Id
7037 Stmts : constant List_Id := New_List;
7039 procedure Process_Component_For_Adjust (Decl : Node_Id);
7040 -- Process the declaration of a single controlled component
7042 ----------------------------------
7043 -- Process_Component_For_Adjust --
7044 ----------------------------------
7046 procedure Process_Component_For_Adjust (Decl : Node_Id) is
7047 Id : constant Entity_Id := Defining_Identifier (Decl);
7048 Typ : constant Entity_Id := Etype (Id);
7054 -- [Deep_]Adjust (V.Id);
7058 -- if not Raised then
7060 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7067 Make_Selected_Component (Loc,
7068 Prefix => Make_Identifier (Loc, Name_V),
7069 Selector_Name => Make_Identifier (Loc, Chars (Id))),
7072 -- Guard against a missing [Deep_]Adjust when the component
7073 -- type was not properly frozen.
7075 if Present (Adj_Call) then
7076 if Exceptions_OK then
7078 Make_Block_Statement (Loc,
7079 Handled_Statement_Sequence =>
7080 Make_Handled_Sequence_Of_Statements (Loc,
7081 Statements => New_List (Adj_Call),
7082 Exception_Handlers => New_List (
7083 Build_Exception_Handler (Finalizer_Data))));
7086 Append_To (Stmts, Adj_Call);
7088 end Process_Component_For_Adjust;
7093 Decl_Id : Entity_Id;
7094 Decl_Typ : Entity_Id;
7099 -- Start of processing for Process_Component_List_For_Adjust
7102 -- Perform an initial check, determine the number of controlled
7103 -- components in the current list and whether at least one of them
7104 -- is per-object constrained.
7106 Preprocess_Components (Comps, Num_Comps, Has_POC);
7108 -- The processing in this routine is done in the following order:
7109 -- 1) Regular components
7110 -- 2) Per-object constrained components
7113 if Num_Comps > 0 then
7115 -- Process all regular components in order of declarations
7117 Decl := First_Non_Pragma (Component_Items (Comps));
7118 while Present (Decl) loop
7119 Decl_Id := Defining_Identifier (Decl);
7120 Decl_Typ := Etype (Decl_Id);
7122 -- Skip _parent as well as per-object constrained components
7124 if Chars (Decl_Id) /= Name_uParent
7125 and then Needs_Finalization (Decl_Typ)
7127 if Has_Access_Constraint (Decl_Id)
7128 and then No (Expression (Decl))
7132 Process_Component_For_Adjust (Decl);
7136 Next_Non_Pragma (Decl);
7139 -- Process all per-object constrained components in order of
7143 Decl := First_Non_Pragma (Component_Items (Comps));
7144 while Present (Decl) loop
7145 Decl_Id := Defining_Identifier (Decl);
7146 Decl_Typ := Etype (Decl_Id);
7150 if Chars (Decl_Id) /= Name_uParent
7151 and then Needs_Finalization (Decl_Typ)
7152 and then Has_Access_Constraint (Decl_Id)
7153 and then No (Expression (Decl))
7155 Process_Component_For_Adjust (Decl);
7158 Next_Non_Pragma (Decl);
7163 -- Process all variants, if any
7166 if Present (Variant_Part (Comps)) then
7168 Var_Alts : constant List_Id := New_List;
7172 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
7173 while Present (Var) loop
7176 -- when <discrete choices> =>
7177 -- <adjust statements>
7179 Append_To (Var_Alts,
7180 Make_Case_Statement_Alternative (Loc,
7182 New_Copy_List (Discrete_Choices (Var)),
7184 Process_Component_List_For_Adjust (
7185 Component_List (Var))));
7187 Next_Non_Pragma (Var);
7191 -- case V.<discriminant> is
7192 -- when <discrete choices 1> =>
7193 -- <adjust statements 1>
7195 -- when <discrete choices N> =>
7196 -- <adjust statements N>
7200 Make_Case_Statement (Loc,
7202 Make_Selected_Component (Loc,
7203 Prefix => Make_Identifier (Loc, Name_V),
7205 Make_Identifier (Loc,
7206 Chars => Chars (Name (Variant_Part (Comps))))),
7207 Alternatives => Var_Alts);
7211 -- Add the variant case statement to the list of statements
7213 if Present (Var_Case) then
7214 Append_To (Stmts, Var_Case);
7217 -- If the component list did not have any controlled components
7218 -- nor variants, return null.
7220 if Is_Empty_List (Stmts) then
7221 Append_To (Stmts, Make_Null_Statement (Loc));
7225 end Process_Component_List_For_Adjust;
7229 Bod_Stmts : List_Id := No_List;
7230 Finalizer_Decls : List_Id := No_List;
7233 -- Start of processing for Build_Adjust_Statements
7236 Finalizer_Decls := New_List;
7237 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
7239 if Nkind (Typ_Def) = N_Derived_Type_Definition then
7240 Rec_Def := Record_Extension_Part (Typ_Def);
7245 -- Create an adjust sequence for all record components
7247 if Present (Component_List (Rec_Def)) then
7249 Process_Component_List_For_Adjust (Component_List (Rec_Def));
7252 -- A derived record type must adjust all inherited components. This
7253 -- action poses the following problem:
7255 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
7260 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
7262 -- Deep_Adjust (Obj._parent);
7267 -- Adjusting the derived type will invoke Adjust of the parent and
7268 -- then that of the derived type. This is undesirable because both
7269 -- routines may modify shared components. Only the Adjust of the
7270 -- derived type should be invoked.
7272 -- To prevent this double adjustment of shared components,
7273 -- Deep_Adjust uses a flag to control the invocation of Adjust:
7275 -- procedure Deep_Adjust
7276 -- (Obj : in out Some_Type;
7277 -- Flag : Boolean := True)
7285 -- When Deep_Adjust is invoked for field _parent, a value of False is
7286 -- provided for the flag:
7288 -- Deep_Adjust (Obj._parent, False);
7290 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
7292 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
7297 if Needs_Finalization (Par_Typ) then
7301 Make_Selected_Component (Loc,
7302 Prefix => Make_Identifier (Loc, Name_V),
7304 Make_Identifier (Loc, Name_uParent)),
7310 -- Deep_Adjust (V._parent, False);
7313 -- when Id : others =>
7314 -- if not Raised then
7316 -- Save_Occurrence (E,
7317 -- Get_Current_Excep.all.all);
7321 if Present (Call) then
7324 if Exceptions_OK then
7326 Make_Block_Statement (Loc,
7327 Handled_Statement_Sequence =>
7328 Make_Handled_Sequence_Of_Statements (Loc,
7329 Statements => New_List (Adj_Stmt),
7330 Exception_Handlers => New_List (
7331 Build_Exception_Handler (Finalizer_Data))));
7334 Prepend_To (Bod_Stmts, Adj_Stmt);
7340 -- Adjust the object. This action must be performed last after all
7341 -- components have been adjusted.
7343 if Is_Controlled (Typ) then
7349 Proc := Find_Optional_Prim_Op (Typ, Name_Adjust);
7358 -- if not Raised then
7360 -- Save_Occurrence (E,
7361 -- Get_Current_Excep.all.all);
7366 if Present (Proc) then
7368 Make_Procedure_Call_Statement (Loc,
7369 Name => New_Occurrence_Of (Proc, Loc),
7370 Parameter_Associations => New_List (
7371 Make_Identifier (Loc, Name_V)));
7373 if Exceptions_OK then
7375 Make_Block_Statement (Loc,
7376 Handled_Statement_Sequence =>
7377 Make_Handled_Sequence_Of_Statements (Loc,
7378 Statements => New_List (Adj_Stmt),
7379 Exception_Handlers => New_List (
7380 Build_Exception_Handler
7381 (Finalizer_Data))));
7384 Append_To (Bod_Stmts,
7385 Make_If_Statement (Loc,
7386 Condition => Make_Identifier (Loc, Name_F),
7387 Then_Statements => New_List (Adj_Stmt)));
7392 -- At this point either all adjustment statements have been generated
7393 -- or the type is not controlled.
7395 if Is_Empty_List (Bod_Stmts) then
7396 Append_To (Bod_Stmts, Make_Null_Statement (Loc));
7402 -- Abort : constant Boolean := Triggered_By_Abort;
7404 -- Abort : constant Boolean := False; -- no abort
7406 -- E : Exception_Occurrence;
7407 -- Raised : Boolean := False;
7410 -- <adjust statements>
7412 -- if Raised and then not Abort then
7413 -- Raise_From_Controlled_Operation (E);
7418 if Exceptions_OK then
7419 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
7424 Make_Block_Statement (Loc,
7427 Handled_Statement_Sequence =>
7428 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
7430 end Build_Adjust_Statements;
7432 -------------------------------
7433 -- Build_Finalize_Statements --
7434 -------------------------------
7436 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
7437 Loc : constant Source_Ptr := Sloc (Typ);
7438 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
7441 Finalizer_Data : Finalization_Exception_Data;
7442 Last_POC_Call : Node_Id := Empty;
7444 function Process_Component_List_For_Finalize
7446 In_Variant_Part : Boolean := False) return List_Id;
7447 -- Build all necessary finalization statements for a single component
7448 -- list. The statements may include a jump circuitry if flag Is_Local
7449 -- is enabled. In_Variant_Part indicates whether this is a recursive
7452 -----------------------------------------
7453 -- Process_Component_List_For_Finalize --
7454 -----------------------------------------
7456 function Process_Component_List_For_Finalize
7458 In_Variant_Part : Boolean := False) return List_Id
7460 procedure Process_Component_For_Finalize
7465 Num_Comps : in out Nat);
7466 -- Process the declaration of a single controlled component. If
7467 -- flag Is_Local is enabled, create the corresponding label and
7468 -- jump circuitry. Alts is the list of case alternatives, Decls
7469 -- is the top level declaration list where labels are declared
7470 -- and Stmts is the list of finalization actions. Num_Comps
7471 -- denotes the current number of components needing finalization.
7473 ------------------------------------
7474 -- Process_Component_For_Finalize --
7475 ------------------------------------
7477 procedure Process_Component_For_Finalize
7482 Num_Comps : in out Nat)
7484 Id : constant Entity_Id := Defining_Identifier (Decl);
7485 Typ : constant Entity_Id := Etype (Id);
7492 Label_Id : Entity_Id;
7499 Make_Identifier (Loc,
7500 Chars => New_External_Name ('L', Num_Comps));
7501 Set_Entity (Label_Id,
7502 Make_Defining_Identifier (Loc, Chars (Label_Id)));
7503 Label := Make_Label (Loc, Label_Id);
7506 Make_Implicit_Label_Declaration (Loc,
7507 Defining_Identifier => Entity (Label_Id),
7508 Label_Construct => Label));
7515 Make_Case_Statement_Alternative (Loc,
7516 Discrete_Choices => New_List (
7517 Make_Integer_Literal (Loc, Num_Comps)),
7519 Statements => New_List (
7520 Make_Goto_Statement (Loc,
7522 New_Occurrence_Of (Entity (Label_Id), Loc)))));
7527 Append_To (Stmts, Label);
7529 -- Decrease the number of components to be processed.
7530 -- This action yields a new Label_Id in future calls.
7532 Num_Comps := Num_Comps - 1;
7537 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7539 -- begin -- Exception handlers allowed
7540 -- [Deep_]Finalize (V.Id);
7543 -- if not Raised then
7545 -- Save_Occurrence (E,
7546 -- Get_Current_Excep.all.all);
7553 Make_Selected_Component (Loc,
7554 Prefix => Make_Identifier (Loc, Name_V),
7555 Selector_Name => Make_Identifier (Loc, Chars (Id))),
7558 -- Guard against a missing [Deep_]Finalize when the component
7559 -- type was not properly frozen.
7561 if Present (Fin_Call) then
7562 if Exceptions_OK then
7564 Make_Block_Statement (Loc,
7565 Handled_Statement_Sequence =>
7566 Make_Handled_Sequence_Of_Statements (Loc,
7567 Statements => New_List (Fin_Call),
7568 Exception_Handlers => New_List (
7569 Build_Exception_Handler (Finalizer_Data))));
7572 Append_To (Stmts, Fin_Call);
7574 end Process_Component_For_Finalize;
7579 Counter_Id : Entity_Id := Empty;
7581 Decl_Id : Entity_Id;
7582 Decl_Typ : Entity_Id;
7585 Jump_Block : Node_Id;
7587 Label_Id : Entity_Id;
7592 -- Start of processing for Process_Component_List_For_Finalize
7595 -- Perform an initial check, look for controlled and per-object
7596 -- constrained components.
7598 Preprocess_Components (Comps, Num_Comps, Has_POC);
7600 -- Create a state counter to service the current component list.
7601 -- This step is performed before the variants are inspected in
7602 -- order to generate the same state counter names as those from
7603 -- Build_Initialize_Statements.
7605 if Num_Comps > 0 and then Is_Local then
7606 Counter := Counter + 1;
7609 Make_Defining_Identifier (Loc,
7610 Chars => New_External_Name ('C', Counter));
7613 -- Process the component in the following order:
7615 -- 2) Per-object constrained components
7616 -- 3) Regular components
7618 -- Start with the variant parts
7621 if Present (Variant_Part (Comps)) then
7623 Var_Alts : constant List_Id := New_List;
7627 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
7628 while Present (Var) loop
7631 -- when <discrete choices> =>
7632 -- <finalize statements>
7634 Append_To (Var_Alts,
7635 Make_Case_Statement_Alternative (Loc,
7637 New_Copy_List (Discrete_Choices (Var)),
7639 Process_Component_List_For_Finalize (
7640 Component_List (Var),
7641 In_Variant_Part => True)));
7643 Next_Non_Pragma (Var);
7647 -- case V.<discriminant> is
7648 -- when <discrete choices 1> =>
7649 -- <finalize statements 1>
7651 -- when <discrete choices N> =>
7652 -- <finalize statements N>
7656 Make_Case_Statement (Loc,
7658 Make_Selected_Component (Loc,
7659 Prefix => Make_Identifier (Loc, Name_V),
7661 Make_Identifier (Loc,
7662 Chars => Chars (Name (Variant_Part (Comps))))),
7663 Alternatives => Var_Alts);
7667 -- The current component list does not have a single controlled
7668 -- component, however it may contain variants. Return the case
7669 -- statement for the variants or nothing.
7671 if Num_Comps = 0 then
7672 if Present (Var_Case) then
7673 return New_List (Var_Case);
7675 return New_List (Make_Null_Statement (Loc));
7679 -- Prepare all lists
7685 -- Process all per-object constrained components in reverse order
7688 Decl := Last_Non_Pragma (Component_Items (Comps));
7689 while Present (Decl) loop
7690 Decl_Id := Defining_Identifier (Decl);
7691 Decl_Typ := Etype (Decl_Id);
7695 if Chars (Decl_Id) /= Name_uParent
7696 and then Needs_Finalization (Decl_Typ)
7697 and then Has_Access_Constraint (Decl_Id)
7698 and then No (Expression (Decl))
7700 Process_Component_For_Finalize
7701 (Decl, Alts, Decls, Stmts, Num_Comps);
7704 Prev_Non_Pragma (Decl);
7708 if not In_Variant_Part then
7709 Last_POC_Call := Last (Stmts);
7710 -- In the case of a type extension, the deep-finalize call
7711 -- for the _Parent component will be inserted here.
7714 -- Process the rest of the components in reverse order
7716 Decl := Last_Non_Pragma (Component_Items (Comps));
7717 while Present (Decl) loop
7718 Decl_Id := Defining_Identifier (Decl);
7719 Decl_Typ := Etype (Decl_Id);
7723 if Chars (Decl_Id) /= Name_uParent
7724 and then Needs_Finalization (Decl_Typ)
7726 -- Skip per-object constrained components since they were
7727 -- handled in the above step.
7729 if Has_Access_Constraint (Decl_Id)
7730 and then No (Expression (Decl))
7734 Process_Component_For_Finalize
7735 (Decl, Alts, Decls, Stmts, Num_Comps);
7739 Prev_Non_Pragma (Decl);
7744 -- LN : label; -- If Is_Local is enabled
7749 -- case CounterX is .
7759 -- <<LN>> -- If Is_Local is enabled
7761 -- [Deep_]Finalize (V.CompY);
7763 -- when Id : others =>
7764 -- if not Raised then
7766 -- Save_Occurrence (E,
7767 -- Get_Current_Excep.all.all);
7771 -- <<L0>> -- If Is_Local is enabled
7776 -- Add the declaration of default jump location L0, its
7777 -- corresponding alternative and its place in the statements.
7779 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
7780 Set_Entity (Label_Id,
7781 Make_Defining_Identifier (Loc, Chars (Label_Id)));
7782 Label := Make_Label (Loc, Label_Id);
7784 Append_To (Decls, -- declaration
7785 Make_Implicit_Label_Declaration (Loc,
7786 Defining_Identifier => Entity (Label_Id),
7787 Label_Construct => Label));
7789 Append_To (Alts, -- alternative
7790 Make_Case_Statement_Alternative (Loc,
7791 Discrete_Choices => New_List (
7792 Make_Others_Choice (Loc)),
7794 Statements => New_List (
7795 Make_Goto_Statement (Loc,
7796 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
7798 Append_To (Stmts, Label); -- statement
7800 -- Create the jump block
7803 Make_Case_Statement (Loc,
7804 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
7805 Alternatives => Alts));
7809 Make_Block_Statement (Loc,
7810 Declarations => Decls,
7811 Handled_Statement_Sequence =>
7812 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
7814 if Present (Var_Case) then
7815 return New_List (Var_Case, Jump_Block);
7817 return New_List (Jump_Block);
7819 end Process_Component_List_For_Finalize;
7823 Bod_Stmts : List_Id := No_List;
7824 Finalizer_Decls : List_Id := No_List;
7827 -- Start of processing for Build_Finalize_Statements
7830 Finalizer_Decls := New_List;
7831 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
7833 if Nkind (Typ_Def) = N_Derived_Type_Definition then
7834 Rec_Def := Record_Extension_Part (Typ_Def);
7839 -- Create a finalization sequence for all record components
7841 if Present (Component_List (Rec_Def)) then
7843 Process_Component_List_For_Finalize (Component_List (Rec_Def));
7846 -- A derived record type must finalize all inherited components. This
7847 -- action poses the following problem:
7849 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7854 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7856 -- Deep_Finalize (Obj._parent);
7861 -- Finalizing the derived type will invoke Finalize of the parent and
7862 -- then that of the derived type. This is undesirable because both
7863 -- routines may modify shared components. Only the Finalize of the
7864 -- derived type should be invoked.
7866 -- To prevent this double adjustment of shared components,
7867 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7869 -- procedure Deep_Finalize
7870 -- (Obj : in out Some_Type;
7871 -- Flag : Boolean := True)
7879 -- When Deep_Finalize is invoked for field _parent, a value of False
7880 -- is provided for the flag:
7882 -- Deep_Finalize (Obj._parent, False);
7884 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
7886 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
7891 if Needs_Finalization (Par_Typ) then
7895 Make_Selected_Component (Loc,
7896 Prefix => Make_Identifier (Loc, Name_V),
7898 Make_Identifier (Loc, Name_uParent)),
7904 -- Deep_Finalize (V._parent, False);
7907 -- when Id : others =>
7908 -- if not Raised then
7910 -- Save_Occurrence (E,
7911 -- Get_Current_Excep.all.all);
7915 if Present (Call) then
7918 if Exceptions_OK then
7920 Make_Block_Statement (Loc,
7921 Handled_Statement_Sequence =>
7922 Make_Handled_Sequence_Of_Statements (Loc,
7923 Statements => New_List (Fin_Stmt),
7924 Exception_Handlers => New_List (
7925 Build_Exception_Handler
7926 (Finalizer_Data))));
7929 -- The intended component finalization order is
7930 -- 1) POC components of extension
7931 -- 2) _Parent component
7932 -- 3) non-POC components of extension.
7934 -- With this "finalize the parent part in the middle"
7935 -- ordering, we can avoid the need for making two
7936 -- calls to the parent's subprogram in the way that
7937 -- is necessary for Init_Procs. This does have the
7938 -- peculiar (but legal) consequence that the parent's
7939 -- non-POC components are finalized before the
7940 -- non-POC extension components. This violates the
7941 -- usual "finalize in reverse declaration order"
7942 -- principle, but that's ok (see Ada RM 7.6.1(9)).
7944 -- Last_POC_Call should be non-empty if the extension
7945 -- has at least one POC. Interactions with variant
7946 -- parts are incorrectly ignored.
7948 if Present (Last_POC_Call) then
7949 Insert_After (Last_POC_Call, Fin_Stmt);
7951 -- At this point, we could look for the common case
7952 -- where there are no POC components anywhere in
7953 -- sight (inherited or not) and, in that common case,
7954 -- call Append_To instead of Prepend_To. That would
7955 -- result in finalizing the parent part after, rather
7956 -- than before, the extension components. That might
7957 -- be more intuitive (as discussed in preceding
7958 -- comment), but it is not required.
7959 Prepend_To (Bod_Stmts, Fin_Stmt);
7966 -- Finalize the object. This action must be performed first before
7967 -- all components have been finalized.
7969 if Is_Controlled (Typ) and then not Is_Local then
7975 Proc := Find_Optional_Prim_Op (Typ, Name_Finalize);
7984 -- if not Raised then
7986 -- Save_Occurrence (E,
7987 -- Get_Current_Excep.all.all);
7992 if Present (Proc) then
7994 Make_Procedure_Call_Statement (Loc,
7995 Name => New_Occurrence_Of (Proc, Loc),
7996 Parameter_Associations => New_List (
7997 Make_Identifier (Loc, Name_V)));
7999 if Exceptions_OK then
8001 Make_Block_Statement (Loc,
8002 Handled_Statement_Sequence =>
8003 Make_Handled_Sequence_Of_Statements (Loc,
8004 Statements => New_List (Fin_Stmt),
8005 Exception_Handlers => New_List (
8006 Build_Exception_Handler
8007 (Finalizer_Data))));
8010 Prepend_To (Bod_Stmts,
8011 Make_If_Statement (Loc,
8012 Condition => Make_Identifier (Loc, Name_F),
8013 Then_Statements => New_List (Fin_Stmt)));
8018 -- At this point either all finalization statements have been
8019 -- generated or the type is not controlled.
8021 if No (Bod_Stmts) then
8022 return New_List (Make_Null_Statement (Loc));
8026 -- Abort : constant Boolean := Triggered_By_Abort;
8028 -- Abort : constant Boolean := False; -- no abort
8030 -- E : Exception_Occurrence;
8031 -- Raised : Boolean := False;
8034 -- <finalize statements>
8036 -- if Raised and then not Abort then
8037 -- Raise_From_Controlled_Operation (E);
8042 if Exceptions_OK then
8043 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
8048 Make_Block_Statement (Loc,
8051 Handled_Statement_Sequence =>
8052 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
8054 end Build_Finalize_Statements;
8056 -----------------------
8057 -- Parent_Field_Type --
8058 -----------------------
8060 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
8064 Field := First_Entity (Typ);
8065 while Present (Field) loop
8066 if Chars (Field) = Name_uParent then
8067 return Etype (Field);
8070 Next_Entity (Field);
8073 -- A derived tagged type should always have a parent field
8075 raise Program_Error;
8076 end Parent_Field_Type;
8078 ---------------------------
8079 -- Preprocess_Components --
8080 ---------------------------
8082 procedure Preprocess_Components
8084 Num_Comps : out Nat;
8085 Has_POC : out Boolean)
8095 Decl := First_Non_Pragma (Component_Items (Comps));
8096 while Present (Decl) loop
8097 Id := Defining_Identifier (Decl);
8100 -- Skip field _parent
8102 if Chars (Id) /= Name_uParent
8103 and then Needs_Finalization (Typ)
8105 Num_Comps := Num_Comps + 1;
8107 if Has_Access_Constraint (Id)
8108 and then No (Expression (Decl))
8114 Next_Non_Pragma (Decl);
8116 end Preprocess_Components;
8118 -- Start of processing for Make_Deep_Record_Body
8122 when Address_Case =>
8123 return Make_Finalize_Address_Stmts (Typ);
8126 return Build_Adjust_Statements (Typ);
8128 when Finalize_Case =>
8129 return Build_Finalize_Statements (Typ);
8131 when Initialize_Case =>
8133 Loc : constant Source_Ptr := Sloc (Typ);
8136 if Is_Controlled (Typ) then
8138 Make_Procedure_Call_Statement (Loc,
8141 (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
8142 Parameter_Associations => New_List (
8143 Make_Identifier (Loc, Name_V))));
8149 end Make_Deep_Record_Body;
8151 ----------------------
8152 -- Make_Final_Call --
8153 ----------------------
8155 function Make_Final_Call
8158 Skip_Self : Boolean := False) return Node_Id
8160 Loc : constant Source_Ptr := Sloc (Obj_Ref);
8162 Prot_Typ : Entity_Id := Empty;
8163 Fin_Id : Entity_Id := Empty;
8170 -- Recover the proper type which contains [Deep_]Finalize
8172 if Is_Class_Wide_Type (Typ) then
8173 Utyp := Root_Type (Typ);
8176 elsif Is_Concurrent_Type (Typ) then
8177 Utyp := Corresponding_Record_Type (Typ);
8179 Ref := Convert_Concurrent (Ref, Typ);
8181 elsif Is_Private_Type (Typ)
8182 and then Present (Underlying_Type (Typ))
8183 and then Is_Concurrent_Type (Underlying_Type (Typ))
8185 Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
8187 Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
8194 Utyp := Underlying_Type (Base_Type (Utyp));
8195 Set_Assignment_OK (Ref);
8197 -- Deal with untagged derivation of private views. If the parent type
8198 -- is a protected type, Deep_Finalize is found on the corresponding
8199 -- record of the ancestor.
8201 if Is_Untagged_Derivation (Typ) then
8202 if Is_Protected_Type (Typ) then
8203 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
8205 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
8207 if Is_Protected_Type (Utyp) then
8208 Utyp := Corresponding_Record_Type (Utyp);
8212 Ref := Unchecked_Convert_To (Utyp, Ref);
8213 Set_Assignment_OK (Ref);
8216 -- Deal with derived private types which do not inherit primitives from
8217 -- their parents. In this case, [Deep_]Finalize can be found in the full
8218 -- view of the parent type.
8221 and then Is_Tagged_Type (Utyp)
8222 and then Is_Derived_Type (Utyp)
8223 and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
8224 and then Is_Private_Type (Etype (Utyp))
8225 and then Present (Full_View (Etype (Utyp)))
8227 Utyp := Full_View (Etype (Utyp));
8228 Ref := Unchecked_Convert_To (Utyp, Ref);
8229 Set_Assignment_OK (Ref);
8232 -- When dealing with the completion of a private type, use the base type
8235 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
8236 pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
8238 Utyp := Base_Type (Utyp);
8239 Ref := Unchecked_Convert_To (Utyp, Ref);
8240 Set_Assignment_OK (Ref);
8243 -- Detect if Typ is a protected type or an expanded protected type and
8244 -- store the relevant type within Prot_Typ for later processing.
8246 if Is_Protected_Type (Typ) then
8249 elsif Ekind (Typ) = E_Record_Type
8250 and then Present (Corresponding_Concurrent_Type (Typ))
8251 and then Is_Protected_Type (Corresponding_Concurrent_Type (Typ))
8253 Prot_Typ := Corresponding_Concurrent_Type (Typ);
8256 -- The underlying type may not be present due to a missing full view. In
8257 -- this case freezing did not take place and there is no [Deep_]Finalize
8258 -- primitive to call.
8263 elsif Skip_Self then
8264 if Has_Controlled_Component (Utyp) then
8265 if Is_Tagged_Type (Utyp) then
8266 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8268 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
8272 -- Class-wide types, interfaces and types with controlled components
8274 elsif Is_Class_Wide_Type (Typ)
8275 or else Is_Interface (Typ)
8276 or else Has_Controlled_Component (Utyp)
8278 if Is_Tagged_Type (Utyp) then
8279 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8281 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
8284 -- Derivations from [Limited_]Controlled
8286 elsif Is_Controlled (Utyp) then
8287 Fin_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Finalize_Case));
8291 elsif Is_Tagged_Type (Utyp) then
8292 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8294 -- Protected types: these also require finalization even though they
8295 -- are not marked controlled explicitly.
8297 elsif Present (Prot_Typ) then
8298 -- Protected objects do not need to be finalized on restricted
8301 if Restricted_Profile then
8304 -- ??? Only handle the simple case for now. Will not support a record
8305 -- or array containing protected objects.
8307 elsif Is_Simple_Protected_Type (Prot_Typ) then
8308 Fin_Id := RTE (RE_Finalize_Protection);
8310 raise Program_Error;
8313 raise Program_Error;
8316 if Present (Fin_Id) then
8318 -- When finalizing a class-wide object, do not convert to the root
8319 -- type in order to produce a dispatching call.
8321 if Is_Class_Wide_Type (Typ) then
8324 -- Ensure that a finalization routine is at least decorated in order
8325 -- to inspect the object parameter.
8327 elsif Analyzed (Fin_Id)
8328 or else Ekind (Fin_Id) = E_Procedure
8330 -- In certain cases, such as the creation of Stream_Read, the
8331 -- visible entity of the type is its full view. Since Stream_Read
8332 -- will have to create an object of type Typ, the local object
8333 -- will be finalzed by the scope finalizer generated later on. The
8334 -- object parameter of Deep_Finalize will always use the private
8335 -- view of the type. To avoid such a clash between a private and a
8336 -- full view, perform an unchecked conversion of the object
8337 -- reference to the private view.
8340 Formal_Typ : constant Entity_Id :=
8341 Etype (First_Formal (Fin_Id));
8343 if Is_Private_Type (Formal_Typ)
8344 and then Present (Full_View (Formal_Typ))
8345 and then Full_View (Formal_Typ) = Utyp
8347 Ref := Unchecked_Convert_To (Formal_Typ, Ref);
8351 -- If the object is unanalyzed, set its expected type for use in
8352 -- Convert_View in case an additional conversion is needed.
8355 and then Nkind (Ref) /= N_Unchecked_Type_Conversion
8357 Set_Etype (Ref, Typ);
8360 Ref := Convert_View (Fin_Id, Ref);
8367 Skip_Self => Skip_Self);
8369 pragma Assert (Serious_Errors_Detected > 0
8370 or else not Has_Controlled_Component (Utyp));
8373 end Make_Final_Call;
8375 --------------------------------
8376 -- Make_Finalize_Address_Body --
8377 --------------------------------
8379 procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
8380 Is_Task : constant Boolean :=
8381 Ekind (Typ) = E_Record_Type
8382 and then Is_Concurrent_Record_Type (Typ)
8383 and then Ekind (Corresponding_Concurrent_Type (Typ)) =
8385 Loc : constant Source_Ptr := Sloc (Typ);
8386 Proc_Id : Entity_Id;
8390 -- The corresponding records of task types are not controlled by design.
8391 -- For the sake of completeness, create an empty Finalize_Address to be
8392 -- used in task class-wide allocations.
8397 -- Nothing to do if the type is not controlled or it already has a
8398 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
8399 -- come from source. These are usually generated for completeness and
8400 -- do not need the Finalize_Address primitive.
8402 elsif not Needs_Finalization (Typ)
8403 or else Present (TSS (Typ, TSS_Finalize_Address))
8405 (Is_Class_Wide_Type (Typ)
8406 and then Ekind (Root_Type (Typ)) = E_Record_Subtype
8407 and then not Comes_From_Source (Root_Type (Typ)))
8412 -- Do not generate Finalize_Address routine for CodePeer
8414 if CodePeer_Mode then
8419 Make_Defining_Identifier (Loc,
8420 Make_TSS_Name (Typ, TSS_Finalize_Address));
8424 -- procedure <Typ>FD (V : System.Address) is
8426 -- null; -- for tasks
8428 -- declare -- for all other types
8429 -- type Pnn is access all Typ;
8430 -- for Pnn'Storage_Size use 0;
8432 -- [Deep_]Finalize (Pnn (V).all);
8437 Stmts := New_List (Make_Null_Statement (Loc));
8439 Stmts := Make_Finalize_Address_Stmts (Typ);
8443 Make_Subprogram_Body (Loc,
8445 Make_Procedure_Specification (Loc,
8446 Defining_Unit_Name => Proc_Id,
8448 Parameter_Specifications => New_List (
8449 Make_Parameter_Specification (Loc,
8450 Defining_Identifier =>
8451 Make_Defining_Identifier (Loc, Name_V),
8453 New_Occurrence_Of (RTE (RE_Address), Loc)))),
8455 Declarations => No_List,
8457 Handled_Statement_Sequence =>
8458 Make_Handled_Sequence_Of_Statements (Loc,
8459 Statements => Stmts)));
8461 Set_TSS (Typ, Proc_Id);
8462 end Make_Finalize_Address_Body;
8464 ---------------------------------
8465 -- Make_Finalize_Address_Stmts --
8466 ---------------------------------
8468 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
8469 Loc : constant Source_Ptr := Sloc (Typ);
8472 Desig_Typ : Entity_Id;
8473 Fin_Block : Node_Id;
8476 Ptr_Typ : Entity_Id;
8479 if Is_Array_Type (Typ) then
8480 if Is_Constrained (First_Subtype (Typ)) then
8481 Desig_Typ := First_Subtype (Typ);
8483 Desig_Typ := Base_Type (Typ);
8486 -- Class-wide types of constrained root types
8488 elsif Is_Class_Wide_Type (Typ)
8489 and then Has_Discriminants (Root_Type (Typ))
8491 Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
8494 Parent_Typ : Entity_Id;
8495 Parent_Utyp : Entity_Id;
8498 -- Climb the parent type chain looking for a non-constrained type
8500 Parent_Typ := Root_Type (Typ);
8501 while Parent_Typ /= Etype (Parent_Typ)
8502 and then Has_Discriminants (Parent_Typ)
8504 Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
8506 Parent_Typ := Etype (Parent_Typ);
8509 -- Handle views created for tagged types with unknown
8512 if Is_Underlying_Record_View (Parent_Typ) then
8513 Parent_Typ := Underlying_Record_View (Parent_Typ);
8516 Parent_Utyp := Underlying_Type (Parent_Typ);
8518 -- Handle views created for a synchronized private extension with
8519 -- known, non-defaulted discriminants. In that case, parent_typ
8520 -- will be the private extension, as it is the first "non
8521 -- -constrained" type in the parent chain. Unfortunately, the
8522 -- underlying type, being a protected or task type, is not the
8523 -- "real" type needing finalization. Rather, the "corresponding
8524 -- record type" should be the designated type here. In fact, TSS
8525 -- finalizer generation is specifically skipped for the nominal
8526 -- class-wide type of (the full view of) a concurrent type (see
8527 -- exp_ch7.Expand_Freeze_Class_Wide_Type). If we don't designate
8528 -- the underlying record (Tprot_typeVC), we will end up trying to
8529 -- dispatch to prot_typeVDF from an incorrectly designated
8530 -- Tprot_typeC, which is, of course, not actually a member of
8531 -- prot_typeV'Class, and thus incompatible.
8533 if Ekind (Parent_Utyp) in Concurrent_Kind
8534 and then Present (Corresponding_Record_Type (Parent_Utyp))
8536 Parent_Utyp := Corresponding_Record_Type (Parent_Utyp);
8539 Desig_Typ := Class_Wide_Type (Parent_Utyp);
8549 -- type Ptr_Typ is access all Typ;
8550 -- for Ptr_Typ'Storage_Size use 0;
8552 Ptr_Typ := Make_Temporary (Loc, 'P');
8555 Make_Full_Type_Declaration (Loc,
8556 Defining_Identifier => Ptr_Typ,
8558 Make_Access_To_Object_Definition (Loc,
8559 All_Present => True,
8560 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))),
8562 Make_Attribute_Definition_Clause (Loc,
8563 Name => New_Occurrence_Of (Ptr_Typ, Loc),
8564 Chars => Name_Storage_Size,
8565 Expression => Make_Integer_Literal (Loc, 0)));
8567 Obj_Expr := Make_Identifier (Loc, Name_V);
8569 -- Unconstrained arrays require special processing in order to retrieve
8570 -- the elements. To achieve this, we have to skip the dope vector which
8571 -- lays in front of the elements and then use a thin pointer to perform
8572 -- the address-to-access conversion.
8574 if Is_Array_Type (Typ)
8575 and then not Is_Constrained (First_Subtype (Typ))
8578 Dope_Id : Entity_Id;
8581 -- Ensure that Ptr_Typ is a thin pointer; generate:
8582 -- for Ptr_Typ'Size use System.Address'Size;
8585 Make_Attribute_Definition_Clause (Loc,
8586 Name => New_Occurrence_Of (Ptr_Typ, Loc),
8589 Make_Integer_Literal (Loc, System_Address_Size)));
8592 -- Dnn : constant Storage_Offset :=
8593 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8595 Dope_Id := Make_Temporary (Loc, 'D');
8598 Make_Object_Declaration (Loc,
8599 Defining_Identifier => Dope_Id,
8600 Constant_Present => True,
8601 Object_Definition =>
8602 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
8604 Make_Op_Divide (Loc,
8606 Make_Attribute_Reference (Loc,
8607 Prefix => New_Occurrence_Of (Desig_Typ, Loc),
8608 Attribute_Name => Name_Descriptor_Size),
8610 Make_Integer_Literal (Loc, System_Storage_Unit))));
8612 -- Shift the address from the start of the dope vector to the
8613 -- start of the elements:
8617 -- Note that this is done through a wrapper routine since RTSfind
8618 -- cannot retrieve operations with string names of the form "+".
8621 Make_Function_Call (Loc,
8623 New_Occurrence_Of (RTE (RE_Add_Offset_To_Address), Loc),
8624 Parameter_Associations => New_List (
8626 New_Occurrence_Of (Dope_Id, Loc)));
8633 Make_Explicit_Dereference (Loc,
8634 Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
8637 if Present (Fin_Call) then
8639 Make_Block_Statement (Loc,
8640 Declarations => Decls,
8641 Handled_Statement_Sequence =>
8642 Make_Handled_Sequence_Of_Statements (Loc,
8643 Statements => New_List (Fin_Call)));
8645 -- Otherwise previous errors or a missing full view may prevent the
8646 -- proper freezing of the designated type. If this is the case, there
8647 -- is no [Deep_]Finalize primitive to call.
8650 Fin_Block := Make_Null_Statement (Loc);
8653 return New_List (Fin_Block);
8654 end Make_Finalize_Address_Stmts;
8656 -------------------------------------
8657 -- Make_Handler_For_Ctrl_Operation --
8658 -------------------------------------
8662 -- when E : others =>
8663 -- Raise_From_Controlled_Operation (E);
8668 -- raise Program_Error [finalize raised exception];
8670 -- depending on whether Raise_From_Controlled_Operation is available
8672 function Make_Handler_For_Ctrl_Operation
8673 (Loc : Source_Ptr) return Node_Id
8676 -- Choice parameter (for the first case above)
8678 Raise_Node : Node_Id;
8679 -- Procedure call or raise statement
8682 -- Standard run-time: add choice parameter E and pass it to
8683 -- Raise_From_Controlled_Operation so that the original exception
8684 -- name and message can be recorded in the exception message for
8687 if RTE_Available (RE_Raise_From_Controlled_Operation) then
8688 E_Occ := Make_Defining_Identifier (Loc, Name_E);
8690 Make_Procedure_Call_Statement (Loc,
8693 (RTE (RE_Raise_From_Controlled_Operation), Loc),
8694 Parameter_Associations => New_List (
8695 New_Occurrence_Of (E_Occ, Loc)));
8697 -- Restricted run-time: exception messages are not supported
8702 Make_Raise_Program_Error (Loc,
8703 Reason => PE_Finalize_Raised_Exception);
8707 Make_Implicit_Exception_Handler (Loc,
8708 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8709 Choice_Parameter => E_Occ,
8710 Statements => New_List (Raise_Node));
8711 end Make_Handler_For_Ctrl_Operation;
8713 --------------------
8714 -- Make_Init_Call --
8715 --------------------
8717 function Make_Init_Call
8719 Typ : Entity_Id) return Node_Id
8721 Loc : constant Source_Ptr := Sloc (Obj_Ref);
8730 -- Deal with the type and object reference. Depending on the context, an
8731 -- object reference may need several conversions.
8733 if Is_Concurrent_Type (Typ) then
8735 Utyp := Corresponding_Record_Type (Typ);
8736 Ref := Convert_Concurrent (Ref, Typ);
8738 elsif Is_Private_Type (Typ)
8739 and then Present (Full_View (Typ))
8740 and then Is_Concurrent_Type (Underlying_Type (Typ))
8743 Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
8744 Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
8751 Utyp := Underlying_Type (Base_Type (Utyp));
8752 Set_Assignment_OK (Ref);
8754 -- Deal with untagged derivation of private views
8756 if Is_Untagged_Derivation (Typ) and then not Is_Conc then
8757 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
8758 Ref := Unchecked_Convert_To (Utyp, Ref);
8760 -- The following is to prevent problems with UC see 1.156 RH ???
8762 Set_Assignment_OK (Ref);
8765 -- If the underlying_type is a subtype, then we are dealing with the
8766 -- completion of a private type. We need to access the base type and
8767 -- generate a conversion to it.
8769 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
8770 pragma Assert (Is_Private_Type (Typ));
8771 Utyp := Base_Type (Utyp);
8772 Ref := Unchecked_Convert_To (Utyp, Ref);
8775 -- The underlying type may not be present due to a missing full view.
8776 -- In this case freezing did not take place and there is no suitable
8777 -- [Deep_]Initialize primitive to call.
8778 -- If Typ is protected then no additional processing is needed either.
8781 or else Is_Protected_Type (Typ)
8786 -- Select the appropriate version of initialize
8788 if Has_Controlled_Component (Utyp) then
8789 Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
8791 Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
8792 Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
8795 -- If initialization procedure for an array of controlled objects is
8796 -- trivial, do not generate a useless call to it.
8797 -- The initialization procedure may be missing altogether in the case
8798 -- of a derived container whose components have trivial initialization.
8801 or else (Is_Array_Type (Utyp) and then Is_Trivial_Subprogram (Proc))
8803 (not Comes_From_Source (Proc)
8804 and then Present (Alias (Proc))
8805 and then Is_Trivial_Subprogram (Alias (Proc)))
8810 -- The object reference may need another conversion depending on the
8811 -- type of the formal and that of the actual.
8813 Ref := Convert_View (Proc, Ref);
8816 -- [Deep_]Initialize (Ref);
8819 Make_Procedure_Call_Statement (Loc,
8820 Name => New_Occurrence_Of (Proc, Loc),
8821 Parameter_Associations => New_List (Ref));
8824 ------------------------------
8825 -- Make_Local_Deep_Finalize --
8826 ------------------------------
8828 function Make_Local_Deep_Finalize
8830 Nam : Entity_Id) return Node_Id
8832 Loc : constant Source_Ptr := Sloc (Typ);
8836 Formals := New_List (
8840 Make_Parameter_Specification (Loc,
8841 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
8843 Out_Present => True,
8844 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
8846 -- F : Boolean := True
8848 Make_Parameter_Specification (Loc,
8849 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
8850 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
8851 Expression => New_Occurrence_Of (Standard_True, Loc)));
8853 -- Add the necessary number of counters to represent the initialization
8854 -- state of an object.
8857 Make_Subprogram_Body (Loc,
8859 Make_Procedure_Specification (Loc,
8860 Defining_Unit_Name => Nam,
8861 Parameter_Specifications => Formals),
8863 Declarations => No_List,
8865 Handled_Statement_Sequence =>
8866 Make_Handled_Sequence_Of_Statements (Loc,
8867 Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
8868 end Make_Local_Deep_Finalize;
8870 ------------------------------------
8871 -- Make_Set_Finalize_Address_Call --
8872 ------------------------------------
8874 function Make_Set_Finalize_Address_Call
8876 Ptr_Typ : Entity_Id) return Node_Id
8878 -- It is possible for Ptr_Typ to be a partial view, if the access type
8879 -- is a full view declared in the private part of a nested package, and
8880 -- the finalization actions take place when completing analysis of the
8881 -- enclosing unit. For this reason use Underlying_Type twice below.
8883 Desig_Typ : constant Entity_Id :=
8885 (Designated_Type (Underlying_Type (Ptr_Typ)));
8886 Fin_Addr : constant Entity_Id := Finalize_Address (Desig_Typ);
8887 Fin_Mas : constant Entity_Id :=
8888 Finalization_Master (Underlying_Type (Ptr_Typ));
8891 -- Both the finalization master and primitive Finalize_Address must be
8894 pragma Assert (Present (Fin_Addr) and Present (Fin_Mas));
8897 -- Set_Finalize_Address
8898 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8901 Make_Procedure_Call_Statement (Loc,
8903 New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc),
8904 Parameter_Associations => New_List (
8905 New_Occurrence_Of (Fin_Mas, Loc),
8907 Make_Attribute_Reference (Loc,
8908 Prefix => New_Occurrence_Of (Fin_Addr, Loc),
8909 Attribute_Name => Name_Unrestricted_Access)));
8910 end Make_Set_Finalize_Address_Call;
8912 --------------------------
8913 -- Make_Transient_Block --
8914 --------------------------
8916 function Make_Transient_Block
8919 Par : Node_Id) return Node_Id
8921 function Manages_Sec_Stack (Id : Entity_Id) return Boolean;
8922 -- Determine whether scoping entity Id manages the secondary stack
8924 function Within_Loop_Statement (N : Node_Id) return Boolean;
8925 -- Return True when N appears within a loop and no block is containing N
8927 -----------------------
8928 -- Manages_Sec_Stack --
8929 -----------------------
8931 function Manages_Sec_Stack (Id : Entity_Id) return Boolean is
8935 -- An exception handler with a choice parameter utilizes a dummy
8936 -- block to provide a declarative region. Such a block should not
8937 -- be considered because it never manifests in the tree and can
8938 -- never release the secondary stack.
8942 Uses_Sec_Stack (Id) and then not Is_Exception_Handler (Id);
8949 return Uses_Sec_Stack (Id);
8954 end Manages_Sec_Stack;
8956 ---------------------------
8957 -- Within_Loop_Statement --
8958 ---------------------------
8960 function Within_Loop_Statement (N : Node_Id) return Boolean is
8961 Par : Node_Id := Parent (N);
8964 while Nkind (Par) not in
8965 N_Handled_Sequence_Of_Statements | N_Loop_Statement |
8966 N_Package_Specification | N_Proper_Body
8968 pragma Assert (Present (Par));
8969 Par := Parent (Par);
8972 return Nkind (Par) = N_Loop_Statement;
8973 end Within_Loop_Statement;
8977 Decls : constant List_Id := New_List;
8978 Instrs : constant List_Id := New_List (Action);
8979 Trans_Id : constant Entity_Id := Current_Scope;
8985 -- Start of processing for Make_Transient_Block
8988 -- Even though the transient block is tasked with managing the secondary
8989 -- stack, the block may forgo this functionality depending on how the
8990 -- secondary stack is managed by enclosing scopes.
8992 if Manages_Sec_Stack (Trans_Id) then
8994 -- Determine whether an enclosing scope already manages the secondary
8997 Scop := Scope (Trans_Id);
8998 while Present (Scop) loop
9000 -- It should not be possible to reach Standard without hitting one
9001 -- of the other cases first unless Standard was manually pushed.
9003 if Scop = Standard_Standard then
9006 -- The transient block is within a function which returns on the
9007 -- secondary stack. Take a conservative approach and assume that
9008 -- the value on the secondary stack is part of the result. Note
9009 -- that it is not possible to detect this dependency without flow
9010 -- analysis which the compiler does not have. Letting the object
9011 -- live longer than the transient block will not leak any memory
9012 -- because the caller will reclaim the total storage used by the
9015 elsif Ekind (Scop) = E_Function
9016 and then Sec_Stack_Needed_For_Return (Scop)
9018 Set_Uses_Sec_Stack (Trans_Id, False);
9021 -- The transient block must manage the secondary stack when the
9022 -- block appears within a loop in order to reclaim the memory at
9025 elsif Ekind (Scop) = E_Loop then
9028 -- Ditto when the block appears without a block that does not
9029 -- manage the secondary stack and is located within a loop.
9031 elsif Ekind (Scop) = E_Block
9032 and then not Manages_Sec_Stack (Scop)
9033 and then Present (Block_Node (Scop))
9034 and then Within_Loop_Statement (Block_Node (Scop))
9038 -- The transient block does not need to manage the secondary stack
9039 -- when there is an enclosing construct which already does that.
9040 -- This optimization saves on SS_Mark and SS_Release calls but may
9041 -- allow objects to live a little longer than required.
9043 -- The transient block must manage the secondary stack when switch
9044 -- -gnatd.s (strict management) is in effect.
9046 elsif Manages_Sec_Stack (Scop) and then not Debug_Flag_Dot_S then
9047 Set_Uses_Sec_Stack (Trans_Id, False);
9050 -- Prevent the search from going too far because transient blocks
9051 -- are bounded by packages and subprogram scopes.
9053 elsif Ekind (Scop) in E_Entry
9063 Scop := Scope (Scop);
9067 -- Create the transient block. Set the parent now since the block itself
9068 -- is not part of the tree. The current scope is the E_Block entity that
9069 -- has been pushed by Establish_Transient_Scope.
9071 pragma Assert (Ekind (Trans_Id) = E_Block);
9074 Make_Block_Statement (Loc,
9075 Identifier => New_Occurrence_Of (Trans_Id, Loc),
9076 Declarations => Decls,
9077 Handled_Statement_Sequence =>
9078 Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
9079 Has_Created_Identifier => True);
9080 Set_Parent (Block, Par);
9082 -- Insert actions stuck in the transient scopes as well as all freezing
9083 -- nodes needed by those actions. Do not insert cleanup actions here,
9084 -- they will be transferred to the newly created block.
9086 Insert_Actions_In_Scope_Around
9087 (Action, Clean => False, Manage_SS => False);
9089 Insert := Prev (Action);
9091 if Present (Insert) then
9092 Freeze_All (First_Entity (Trans_Id), Insert);
9095 -- Transfer cleanup actions to the newly created block
9098 Cleanup_Actions : List_Id
9099 renames Scope_Stack.Table (Scope_Stack.Last).
9100 Actions_To_Be_Wrapped (Cleanup);
9102 Set_Cleanup_Actions (Block, Cleanup_Actions);
9103 Cleanup_Actions := No_List;
9106 -- When the transient scope was established, we pushed the entry for the
9107 -- transient scope onto the scope stack, so that the scope was active
9108 -- for the installation of finalizable entities etc. Now we must remove
9109 -- this entry, since we have constructed a proper block.
9114 end Make_Transient_Block;
9116 ------------------------
9117 -- Node_To_Be_Wrapped --
9118 ------------------------
9120 function Node_To_Be_Wrapped return Node_Id is
9122 return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
9123 end Node_To_Be_Wrapped;
9125 ----------------------------
9126 -- Store_Actions_In_Scope --
9127 ----------------------------
9129 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is
9130 SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
9131 Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK);
9134 if Is_Empty_List (Actions) then
9137 if Is_List_Member (SE.Node_To_Be_Wrapped) then
9138 Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
9140 Set_Parent (L, SE.Node_To_Be_Wrapped);
9145 elsif AK = Before then
9146 Insert_List_After_And_Analyze (Last (Actions), L);
9149 Insert_List_Before_And_Analyze (First (Actions), L);
9151 end Store_Actions_In_Scope;
9153 ----------------------------------
9154 -- Store_After_Actions_In_Scope --
9155 ----------------------------------
9157 procedure Store_After_Actions_In_Scope (L : List_Id) is
9159 Store_Actions_In_Scope (After, L);
9160 end Store_After_Actions_In_Scope;
9162 -----------------------------------
9163 -- Store_Before_Actions_In_Scope --
9164 -----------------------------------
9166 procedure Store_Before_Actions_In_Scope (L : List_Id) is
9168 Store_Actions_In_Scope (Before, L);
9169 end Store_Before_Actions_In_Scope;
9171 -----------------------------------
9172 -- Store_Cleanup_Actions_In_Scope --
9173 -----------------------------------
9175 procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is
9177 Store_Actions_In_Scope (Cleanup, L);
9178 end Store_Cleanup_Actions_In_Scope;
9184 procedure Unnest_Block (Decl : Node_Id) is
9185 Loc : constant Source_Ptr := Sloc (Decl);
9187 Local_Body : Node_Id;
9188 Local_Call : Node_Id;
9189 Local_Proc : Entity_Id;
9190 Local_Scop : Entity_Id;
9193 Local_Scop := Entity (Identifier (Decl));
9194 Ent := First_Entity (Local_Scop);
9196 Local_Proc := Make_Temporary (Loc, 'P');
9199 Make_Subprogram_Body (Loc,
9201 Make_Procedure_Specification (Loc,
9202 Defining_Unit_Name => Local_Proc),
9203 Declarations => Declarations (Decl),
9204 Handled_Statement_Sequence =>
9205 Handled_Statement_Sequence (Decl));
9207 -- Handlers in the block may contain nested subprograms that require
9210 Check_Unnesting_In_Handlers (Local_Body);
9212 Rewrite (Decl, Local_Body);
9214 Set_Has_Nested_Subprogram (Local_Proc);
9217 Make_Procedure_Call_Statement (Loc,
9218 Name => New_Occurrence_Of (Local_Proc, Loc));
9220 Insert_After (Decl, Local_Call);
9221 Analyze (Local_Call);
9223 -- The new subprogram has the same scope as the original block
9225 Set_Scope (Local_Proc, Scope (Local_Scop));
9227 -- And the entity list of the new procedure is that of the block
9229 Set_First_Entity (Local_Proc, Ent);
9231 -- Reset the scopes of all the entities to the new procedure
9233 while Present (Ent) loop
9234 Set_Scope (Ent, Local_Proc);
9239 -------------------------
9240 -- Unnest_If_Statement --
9241 -------------------------
9243 procedure Unnest_If_Statement (If_Stmt : Node_Id) is
9245 procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id);
9246 -- A list of statements (that may be a list associated with a then,
9247 -- elsif, or else part of an if-statement) is traversed at the top
9248 -- level to determine whether it contains a subprogram body, and if so,
9249 -- the statements will be replaced with a new procedure body containing
9250 -- the statements followed by a call to the procedure. The individual
9251 -- statements may also be blocks, loops, or other if statements that
9252 -- themselves may require contain nested subprograms needing unnesting.
9254 procedure Check_Stmts_For_Subp_Unnesting (Stmts : in out List_Id) is
9255 Subp_Found : Boolean := False;
9258 if Is_Empty_List (Stmts) then
9263 Stmt : Node_Id := First (Stmts);
9265 while Present (Stmt) loop
9266 if Nkind (Stmt) = N_Subprogram_Body then
9275 -- The statements themselves may be blocks, loops, etc. that in turn
9276 -- contain nested subprograms requiring an unnesting transformation.
9277 -- We perform this traversal after looking for subprogram bodies, to
9278 -- avoid considering procedures created for one of those statements
9279 -- (such as a block rewritten as a procedure) as a nested subprogram
9280 -- of the statement list (which could result in an unneeded wrapper
9283 Check_Unnesting_In_Decls_Or_Stmts (Stmts);
9285 -- If there was a top-level subprogram body in the statement list,
9286 -- then perform an unnesting transformation on the list by replacing
9287 -- the statements with a wrapper procedure body containing the
9288 -- original statements followed by a call to that procedure.
9291 Unnest_Statement_List (Stmts);
9293 end Check_Stmts_For_Subp_Unnesting;
9297 Then_Stmts : List_Id := Then_Statements (If_Stmt);
9298 Else_Stmts : List_Id := Else_Statements (If_Stmt);
9300 -- Start of processing for Unnest_If_Statement
9303 Check_Stmts_For_Subp_Unnesting (Then_Stmts);
9304 Set_Then_Statements (If_Stmt, Then_Stmts);
9306 if not Is_Empty_List (Elsif_Parts (If_Stmt)) then
9308 Elsif_Part : Node_Id :=
9309 First (Elsif_Parts (If_Stmt));
9310 Elsif_Stmts : List_Id;
9312 while Present (Elsif_Part) loop
9313 Elsif_Stmts := Then_Statements (Elsif_Part);
9315 Check_Stmts_For_Subp_Unnesting (Elsif_Stmts);
9316 Set_Then_Statements (Elsif_Part, Elsif_Stmts);
9323 Check_Stmts_For_Subp_Unnesting (Else_Stmts);
9324 Set_Else_Statements (If_Stmt, Else_Stmts);
9325 end Unnest_If_Statement;
9331 procedure Unnest_Loop (Loop_Stmt : Node_Id) is
9333 procedure Fixup_Inner_Scopes (Loop_Stmt : Node_Id);
9334 -- The loops created by the compiler for array aggregates can have
9335 -- nested finalization procedure when the type of the array components
9336 -- needs finalization. It has the following form:
9338 -- for J4b in 10 .. 12 loop
9340 -- procedure __finalizer;
9342 -- procedure __finalizer is
9346 -- obj (J4b) := ...;
9348 -- When the compiler creates the N_Block_Statement, it sets its scope to
9349 -- the upper scope (the one containing the loop).
9351 -- The Unnest_Loop procedure moves the N_Loop_Statement inside a new
9352 -- procedure and correctly sets the scopes for both the new procedure
9353 -- and the loop entity. The inner block scope is not modified and this
9354 -- leaves the Tree in an incoherent state (i.e. the inner procedure must
9355 -- have its enclosing procedure in its scope ancestries).
9357 -- This procedure fixes the scope links.
9359 -- Another (better) fix would be to have the block scope set to be the
9360 -- loop entity earlier (when the block is created or when the loop gets
9361 -- an actual entity set). But unfortunately this proved harder to
9364 procedure Fixup_Inner_Scopes (Loop_Stmt : Node_Id) is
9365 Stmt : Node_Id := First (Statements (Loop_Stmt));
9366 Loop_Stmt_Ent : constant Entity_Id := Entity (Identifier (Loop_Stmt));
9367 Ent_To_Fix : Entity_Id;
9369 while Present (Stmt) loop
9370 if Nkind (Stmt) = N_Block_Statement
9371 and then Is_Abort_Block (Stmt)
9373 Ent_To_Fix := Entity (Identifier (Stmt));
9374 Set_Scope (Ent_To_Fix, Loop_Stmt_Ent);
9375 elsif Nkind (Stmt) = N_Loop_Statement then
9376 Fixup_Inner_Scopes (Stmt);
9380 end Fixup_Inner_Scopes;
9382 Loc : constant Source_Ptr := Sloc (Loop_Stmt);
9384 Local_Body : Node_Id;
9385 Local_Call : Node_Id;
9386 Loop_Ent : Entity_Id;
9387 Local_Proc : Entity_Id;
9388 Loop_Copy : constant Node_Id :=
9389 Relocate_Node (Loop_Stmt);
9391 Loop_Ent := Entity (Identifier (Loop_Stmt));
9392 Ent := First_Entity (Loop_Ent);
9394 Local_Proc := Make_Temporary (Loc, 'P');
9397 Make_Subprogram_Body (Loc,
9399 Make_Procedure_Specification (Loc,
9400 Defining_Unit_Name => Local_Proc),
9401 Declarations => Empty_List,
9402 Handled_Statement_Sequence =>
9403 Make_Handled_Sequence_Of_Statements (Loc,
9404 Statements => New_List (Loop_Copy)));
9406 Rewrite (Loop_Stmt, Local_Body);
9407 Analyze (Loop_Stmt);
9409 Set_Has_Nested_Subprogram (Local_Proc);
9412 Make_Procedure_Call_Statement (Loc,
9413 Name => New_Occurrence_Of (Local_Proc, Loc));
9415 Insert_After (Loop_Stmt, Local_Call);
9416 Analyze (Local_Call);
9418 -- New procedure has the same scope as the original loop, and the scope
9419 -- of the loop is the new procedure.
9421 Set_Scope (Local_Proc, Scope (Loop_Ent));
9422 Set_Scope (Loop_Ent, Local_Proc);
9424 Fixup_Inner_Scopes (Loop_Copy);
9426 -- The entity list of the new procedure is that of the loop
9428 Set_First_Entity (Local_Proc, Ent);
9430 -- Note that the entities associated with the loop don't need to have
9431 -- their Scope fields reset, since they're still associated with the
9432 -- same loop entity that now belongs to the copied loop statement.
9435 ---------------------------
9436 -- Unnest_Statement_List --
9437 ---------------------------
9439 procedure Unnest_Statement_List (Stmts : in out List_Id) is
9440 Loc : constant Source_Ptr := Sloc (First (Stmts));
9441 Local_Body : Node_Id;
9442 Local_Call : Node_Id;
9443 Local_Proc : Entity_Id;
9444 New_Stmts : constant List_Id := Empty_List;
9447 Local_Proc := Make_Temporary (Loc, 'P');
9450 Make_Subprogram_Body (Loc,
9452 Make_Procedure_Specification (Loc,
9453 Defining_Unit_Name => Local_Proc),
9454 Declarations => Empty_List,
9455 Handled_Statement_Sequence =>
9456 Make_Handled_Sequence_Of_Statements (Loc,
9457 Statements => Stmts));
9459 Append_To (New_Stmts, Local_Body);
9461 Analyze (Local_Body);
9463 Set_Has_Nested_Subprogram (Local_Proc);
9466 Make_Procedure_Call_Statement (Loc,
9467 Name => New_Occurrence_Of (Local_Proc, Loc));
9469 Append_To (New_Stmts, Local_Call);
9470 Analyze (Local_Call);
9472 -- Traverse the statements, and for any that are declarations or
9473 -- subprogram bodies that have entities, set the Scope of those
9474 -- entities to the new procedure's Entity_Id.
9477 Stmt : Node_Id := First (Stmts);
9480 while Present (Stmt) loop
9481 case Nkind (Stmt) is
9483 | N_Renaming_Declaration
9485 Set_Scope (Defining_Identifier (Stmt), Local_Proc);
9487 when N_Subprogram_Body =>
9489 (Defining_Unit_Name (Specification (Stmt)), Local_Proc);
9500 end Unnest_Statement_List;
9502 --------------------------------
9503 -- Wrap_Transient_Declaration --
9504 --------------------------------
9506 -- If a transient scope has been established during the processing of the
9507 -- Expression of an Object_Declaration, it is not possible to wrap the
9508 -- declaration into a transient block as usual case, otherwise the object
9509 -- would be itself declared in the wrong scope. Therefore, all entities (if
9510 -- any) defined in the transient block are moved to the proper enclosing
9511 -- scope. Furthermore, if they are controlled variables they are finalized
9512 -- right after the declaration. The finalization list of the transient
9513 -- scope is defined as a renaming of the enclosing one so during their
9514 -- initialization they will be attached to the proper finalization list.
9515 -- For instance, the following declaration :
9517 -- X : Typ := F (G (A), G (B));
9519 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
9520 -- is expanded into :
9522 -- X : Typ := [ complex Expression-Action ];
9523 -- [Deep_]Finalize (_v1);
9524 -- [Deep_]Finalize (_v2);
9526 procedure Wrap_Transient_Declaration (N : Node_Id) is
9531 Curr_S := Current_Scope;
9532 Encl_S := Scope (Curr_S);
9534 -- Insert all actions including cleanup generated while analyzing or
9535 -- expanding the transient context back into the tree. Manage the
9536 -- secondary stack when the object declaration appears in a library
9537 -- level package [body].
9539 Insert_Actions_In_Scope_Around
9543 Uses_Sec_Stack (Curr_S)
9544 and then Nkind (N) = N_Object_Declaration
9545 and then Ekind (Encl_S) in E_Package | E_Package_Body
9546 and then Is_Library_Level_Entity (Encl_S));
9549 -- Relocate local entities declared within the transient scope to the
9550 -- enclosing scope. This action sets their Is_Public flag accordingly.
9552 Transfer_Entities (Curr_S, Encl_S);
9554 -- Mark the enclosing dynamic scope to ensure that the secondary stack
9555 -- is properly released upon exiting the said scope.
9557 if Uses_Sec_Stack (Curr_S) then
9558 Curr_S := Enclosing_Dynamic_Scope (Curr_S);
9560 -- Do not mark a function that returns on the secondary stack as the
9561 -- reclamation is done by the caller.
9563 if Ekind (Curr_S) = E_Function
9564 and then Needs_Secondary_Stack (Etype (Curr_S))
9568 -- Otherwise mark the enclosing dynamic scope
9571 Set_Uses_Sec_Stack (Curr_S);
9572 Check_Restriction (No_Secondary_Stack, N);
9575 end Wrap_Transient_Declaration;
9577 -------------------------------
9578 -- Wrap_Transient_Expression --
9579 -------------------------------
9581 procedure Wrap_Transient_Expression (N : Node_Id) is
9582 Loc : constant Source_Ptr := Sloc (N);
9583 Expr : Node_Id := Relocate_Node (N);
9584 Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N);
9585 Typ : constant Entity_Id := Etype (N);
9592 -- M : constant Mark_Id := SS_Mark;
9593 -- procedure Finalizer is ... (See Build_Finalizer)
9596 -- Temp := <Expr>; -- general case
9597 -- Temp := (if <Expr> then True else False); -- boolean case
9603 -- A special case is made for Boolean expressions so that the back end
9604 -- knows to generate a conditional branch instruction, if running with
9605 -- -fpreserve-control-flow. This ensures that a control-flow change
9606 -- signaling the decision outcome occurs before the cleanup actions.
9608 if Opt.Suppress_Control_Flow_Optimizations
9609 and then Is_Boolean_Type (Typ)
9612 Make_If_Expression (Loc,
9613 Expressions => New_List (
9615 New_Occurrence_Of (Standard_True, Loc),
9616 New_Occurrence_Of (Standard_False, Loc)));
9619 Insert_Actions (N, New_List (
9620 Make_Object_Declaration (Loc,
9621 Defining_Identifier => Temp,
9622 Object_Definition => New_Occurrence_Of (Typ, Loc)),
9624 Make_Transient_Block (Loc,
9626 Make_Assignment_Statement (Loc,
9627 Name => New_Occurrence_Of (Temp, Loc),
9628 Expression => Expr),
9629 Par => Parent (N))));
9631 if Debug_Generated_Code then
9632 Set_Debug_Info_Needed (Temp);
9635 Rewrite (N, New_Occurrence_Of (Temp, Loc));
9636 Analyze_And_Resolve (N, Typ);
9637 end Wrap_Transient_Expression;
9639 ------------------------------
9640 -- Wrap_Transient_Statement --
9641 ------------------------------
9643 procedure Wrap_Transient_Statement (N : Node_Id) is
9644 Loc : constant Source_Ptr := Sloc (N);
9645 New_Stmt : constant Node_Id := Relocate_Node (N);
9650 -- M : constant Mark_Id := SS_Mark;
9651 -- procedure Finalizer is ... (See Build_Finalizer)
9661 Make_Transient_Block (Loc,
9663 Par => Parent (N)));
9665 -- With the scope stack back to normal, we can call analyze on the
9666 -- resulting block. At this point, the transient scope is being
9667 -- treated like a perfectly normal scope, so there is nothing
9668 -- special about it.
9670 -- Note: Wrap_Transient_Statement is called with the node already
9671 -- analyzed (i.e. Analyzed (N) is True). This is important, since
9672 -- otherwise we would get a recursive processing of the node when
9673 -- we do this Analyze call.
9676 end Wrap_Transient_Statement;