1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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 Elists; use Elists;
34 with Errout; use Errout;
35 with Exp_Ch6; use Exp_Ch6;
36 with Exp_Ch9; use Exp_Ch9;
37 with Exp_Ch11; use Exp_Ch11;
38 with Exp_Dbug; use Exp_Dbug;
39 with Exp_Dist; use Exp_Dist;
40 with Exp_Disp; use Exp_Disp;
41 with Exp_Prag; use Exp_Prag;
42 with Exp_Tss; use Exp_Tss;
43 with Exp_Util; use Exp_Util;
44 with Freeze; use Freeze;
46 with Nlists; use Nlists;
47 with Nmake; use Nmake;
49 with Output; use Output;
50 with Restrict; use Restrict;
51 with Rident; use Rident;
52 with Rtsfind; use Rtsfind;
53 with Sinfo; use Sinfo;
55 with Sem_Aux; use Sem_Aux;
56 with Sem_Ch3; use Sem_Ch3;
57 with Sem_Ch7; use Sem_Ch7;
58 with Sem_Ch8; use Sem_Ch8;
59 with Sem_Res; use Sem_Res;
60 with Sem_Util; use Sem_Util;
61 with Snames; use Snames;
62 with Stand; use Stand;
63 with Tbuild; use Tbuild;
64 with Ttypes; use Ttypes;
65 with Uintp; use Uintp;
67 package body Exp_Ch7 is
69 --------------------------------
70 -- Transient Scope Management --
71 --------------------------------
73 -- A transient scope is created when temporary objects are created by the
74 -- compiler. These temporary objects are allocated on the secondary stack
75 -- and the transient scope is responsible for finalizing the object when
76 -- appropriate and reclaiming the memory at the right time. The temporary
77 -- objects are generally the objects allocated to store the result of a
78 -- function returning an unconstrained or a tagged value. Expressions
79 -- needing to be wrapped in a transient scope (functions calls returning
80 -- unconstrained or tagged values) may appear in 3 different contexts which
81 -- lead to 3 different kinds of transient scope expansion:
83 -- 1. In a simple statement (procedure call, assignment, ...). In this
84 -- case the instruction is wrapped into a transient block. See
85 -- Wrap_Transient_Statement for details.
87 -- 2. In an expression of a control structure (test in a IF statement,
88 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
91 -- 3. In a expression of an object_declaration. No wrapping is possible
92 -- here, so the finalization actions, if any, are done right after the
93 -- declaration and the secondary stack deallocation is done in the
94 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
96 -- Note about functions returning tagged types: it has been decided to
97 -- always allocate their result in the secondary stack, even though is not
98 -- absolutely mandatory when the tagged type is constrained because the
99 -- caller knows the size of the returned object and thus could allocate the
100 -- result in the primary stack. An exception to this is when the function
101 -- builds its result in place, as is done for functions with inherently
102 -- limited result types for Ada 2005. In that case, certain callers may
103 -- pass the address of a constrained object as the target object for the
106 -- By allocating tagged results in the secondary stack a number of
107 -- implementation difficulties are avoided:
109 -- - If it is a dispatching function call, the computation of the size of
110 -- the result is possible but complex from the outside.
112 -- - If the returned type is controlled, the assignment of the returned
113 -- value to the anonymous object involves an Adjust, and we have no
114 -- easy way to access the anonymous object created by the back end.
116 -- - If the returned type is class-wide, this is an unconstrained type
119 -- Furthermore, the small loss in efficiency which is the result of this
120 -- decision is not such a big deal because functions returning tagged types
121 -- are not as common in practice compared to functions returning access to
124 --------------------------------------------------
125 -- Transient Blocks and Finalization Management --
126 --------------------------------------------------
128 function Find_Transient_Context (N : Node_Id) return Node_Id;
129 -- Locate a suitable context for arbitrary node N which may need to be
130 -- serviced by a transient scope. Return Empty if no suitable context is
133 procedure Insert_Actions_In_Scope_Around
136 Manage_SS : Boolean);
137 -- Insert the before-actions kept in the scope stack before N, and the
138 -- after-actions after N, which must be a member of a list. If flag Clean
139 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
140 -- calls to mark and release the secondary stack.
142 function Make_Transient_Block
145 Par : Node_Id) return Node_Id;
146 -- Action is a single statement or object declaration. Par is the proper
147 -- parent of the generated block. Create a transient block whose name is
148 -- the current scope and the only handled statement is Action. If Action
149 -- involves controlled objects or secondary stack usage, the corresponding
150 -- cleanup actions are performed at the end of the block.
152 procedure Set_Node_To_Be_Wrapped (N : Node_Id);
153 -- Set the field Node_To_Be_Wrapped of the current scope
155 -- ??? The entire comment needs to be rewritten
156 -- ??? which entire comment?
158 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id);
159 -- Shared processing for Store_xxx_Actions_In_Scope
161 -----------------------------
162 -- Finalization Management --
163 -----------------------------
165 -- This part describe how Initialization/Adjustment/Finalization procedures
166 -- are generated and called. Two cases must be considered, types that are
167 -- Controlled (Is_Controlled flag set) and composite types that contain
168 -- controlled components (Has_Controlled_Component flag set). In the first
169 -- case the procedures to call are the user-defined primitive operations
170 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
171 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
172 -- of calling the former procedures on the controlled components.
174 -- For records with Has_Controlled_Component set, a hidden "controller"
175 -- component is inserted. This controller component contains its own
176 -- finalization list on which all controlled components are attached
177 -- creating an indirection on the upper-level Finalization list. This
178 -- technique facilitates the management of objects whose number of
179 -- controlled components changes during execution. This controller
180 -- component is itself controlled and is attached to the upper-level
181 -- finalization chain. Its adjust primitive is in charge of calling adjust
182 -- on the components and adjusting the finalization pointer to match their
183 -- new location (see a-finali.adb).
185 -- It is not possible to use a similar technique for arrays that have
186 -- Has_Controlled_Component set. In this case, deep procedures are
187 -- generated that call initialize/adjust/finalize + attachment or
188 -- detachment on the finalization list for all component.
190 -- Initialize calls: they are generated for declarations or dynamic
191 -- allocations of Controlled objects with no initial value. They are always
192 -- followed by an attachment to the current Finalization Chain. For the
193 -- dynamic allocation case this the chain attached to the scope of the
194 -- access type definition otherwise, this is the chain of the current
197 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
198 -- or dynamic allocations of Controlled objects with an initial value.
199 -- (2) after an assignment. In the first case they are followed by an
200 -- attachment to the final chain, in the second case they are not.
202 -- Finalization Calls: They are generated on (1) scope exit, (2)
203 -- assignments, (3) unchecked deallocations. In case (3) they have to
204 -- be detached from the final chain, in case (2) they must not and in
205 -- case (1) this is not important since we are exiting the scope anyway.
209 -- Type extensions will have a new record controller at each derivation
210 -- level containing controlled components. The record controller for
211 -- the parent/ancestor is attached to the finalization list of the
212 -- extension's record controller (i.e. the parent is like a component
213 -- of the extension).
215 -- For types that are both Is_Controlled and Has_Controlled_Components,
216 -- the record controller and the object itself are handled separately.
217 -- It could seem simpler to attach the object at the end of its record
218 -- controller but this would not tackle view conversions properly.
220 -- A classwide type can always potentially have controlled components
221 -- but the record controller of the corresponding actual type may not
222 -- be known at compile time so the dispatch table contains a special
223 -- field that allows computation of the offset of the record controller
224 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
226 -- Here is a simple example of the expansion of a controlled block :
230 -- Y : Controlled := Init;
236 -- Z : R := (C => X);
246 -- _L : System.FI.Finalizable_Ptr;
248 -- procedure _Clean is
251 -- System.FI.Finalize_List (_L);
259 -- Attach_To_Final_List (_L, Finalizable (X), 1);
260 -- at end: Abort_Undefer;
261 -- Y : Controlled := Init;
263 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
271 -- Deep_Initialize (W, _L, 1);
272 -- at end: Abort_Under;
273 -- Z : R := (C => X);
274 -- Deep_Adjust (Z, _L, 1);
278 -- Deep_Finalize (W, False);
279 -- <save W's final pointers>
281 -- <restore W's final pointers>
282 -- Deep_Adjust (W, _L, 0);
287 type Final_Primitives is
288 (Initialize_Case, Adjust_Case, Finalize_Case, Address_Case);
289 -- This enumeration type is defined in order to ease sharing code for
290 -- building finalization procedures for composite types.
292 Name_Of : constant array (Final_Primitives) of Name_Id :=
293 (Initialize_Case => Name_Initialize,
294 Adjust_Case => Name_Adjust,
295 Finalize_Case => Name_Finalize,
296 Address_Case => Name_Finalize_Address);
297 Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
298 (Initialize_Case => TSS_Deep_Initialize,
299 Adjust_Case => TSS_Deep_Adjust,
300 Finalize_Case => TSS_Deep_Finalize,
301 Address_Case => TSS_Finalize_Address);
303 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean;
304 -- Determine whether access type Typ may have a finalization master
306 procedure Build_Array_Deep_Procs (Typ : Entity_Id);
307 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
308 -- Has_Controlled_Component set and store them using the TSS mechanism.
310 function Build_Cleanup_Statements
312 Additional_Cleanup : List_Id) return List_Id;
313 -- Create the cleanup calls for an asynchronous call block, task master,
314 -- protected subprogram body, task allocation block or task body, or
315 -- additional cleanup actions parked on a transient block. If the context
316 -- does not contain the above constructs, the routine returns an empty
319 procedure Build_Finalizer
321 Clean_Stmts : List_Id;
324 Defer_Abort : Boolean;
325 Fin_Id : out Entity_Id);
326 -- N may denote an accept statement, block, entry body, package body,
327 -- package spec, protected body, subprogram body, or a task body. Create
328 -- a procedure which contains finalization calls for all controlled objects
329 -- declared in the declarative or statement region of N. The calls are
330 -- built in reverse order relative to the original declarations. In the
331 -- case of a task body, the routine delays the creation of the finalizer
332 -- until all statements have been moved to the task body procedure.
333 -- Clean_Stmts may contain additional context-dependent code used to abort
334 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
335 -- Mark_Id is the secondary stack used in the current context or Empty if
336 -- missing. Top_Decls is the list on which the declaration of the finalizer
337 -- is attached in the non-package case. Defer_Abort indicates that the
338 -- statements passed in perform actions that require abort to be deferred,
339 -- such as for task termination. Fin_Id is the finalizer declaration
342 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id);
343 -- N is a construct which contains a handled sequence of statements, Fin_Id
344 -- is the entity of a finalizer. Create an At_End handler which covers the
345 -- statements of N and calls Fin_Id. If the handled statement sequence has
346 -- an exception handler, the statements will be wrapped in a block to avoid
347 -- unwanted interaction with the new At_End handler.
349 procedure Build_Record_Deep_Procs (Typ : Entity_Id);
350 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
351 -- Has_Component_Component set and store them using the TSS mechanism.
353 -------------------------------------------
354 -- Unnesting procedures for CCG and LLVM --
355 -------------------------------------------
357 -- Expansion generates subprograms for controlled types management that
358 -- may appear in declarative lists in package declarations and bodies.
359 -- These subprograms appear within generated blocks that contain local
360 -- declarations and a call to finalization procedures. To ensure that
361 -- such subprograms get activation records when needed, we transform the
362 -- block into a procedure body, followed by a call to it in the same
365 procedure Check_Unnesting_Elaboration_Code (N : Node_Id);
366 -- The statement part of a package body that is a compilation unit may
367 -- contain blocks that declare local subprograms. In Subprogram_Unnesting_
368 -- Mode such subprograms must be handled as nested inside the (implicit)
369 -- elaboration procedure that executes that statement part. To handle
370 -- properly uplevel references we construct that subprogram explicitly,
371 -- to contain blocks and inner subprograms, The statement part becomes
372 -- a call to this subprogram. This is only done if blocks are present
373 -- in the statement list of the body. (It would be nice to unify this
374 -- procedure with Check_Unnesting_In_Decls_Or_Stmts, if possible, since
375 -- they're doing very similar work, but are structured differently. ???)
377 procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id);
378 -- Similarly, the declarations or statements in library-level packages may
379 -- have created blocks with nested subprograms. Such a block must be
380 -- transformed into a procedure followed by a call to it, so that unnesting
381 -- can handle uplevel references within these nested subprograms (typically
382 -- subprograms that handle finalization actions). This also applies to
383 -- nested packages, including instantiations, in which case it must
384 -- recursively process inner bodies.
386 procedure Check_Unnesting_In_Handlers (N : Node_Id);
387 -- Similarly, check for blocks with nested subprograms occurring within
388 -- a set of exception handlers associated with a package body N.
390 procedure Unnest_Block (Decl : Node_Id);
391 -- Blocks that contain nested subprograms with up-level references need to
392 -- create activation records for them. We do this by rewriting the block as
393 -- a procedure, followed by a call to it in the same declarative list, to
394 -- replicate the semantics of the original block.
396 -- A common source for such block is a transient block created for a
397 -- construct (declaration, assignment, etc.) that involves controlled
398 -- actions or secondary-stack management, in which case the nested
399 -- subprogram is a finalizer.
401 procedure Unnest_Loop (Loop_Stmt : Node_Id);
402 -- Top-level Loops that contain nested subprograms with up-level references
403 -- need to have activation records. We do this by rewriting the loop as a
404 -- procedure containing the loop, followed by a call to the procedure in
405 -- the same library-level declarative list, to replicate the semantics of
406 -- the original loop. Such loops can occur due to aggregate expansions and
409 procedure Check_Visibly_Controlled
410 (Prim : Final_Primitives;
412 E : in out Entity_Id;
413 Cref : in out Node_Id);
414 -- The controlled operation declared for a derived type may not be
415 -- overriding, if the controlled operations of the parent type are hidden,
416 -- for example when the parent is a private type whose full view is
417 -- controlled. For other primitive operations we modify the name of the
418 -- operation to indicate that it is not overriding, but this is not
419 -- possible for Initialize, etc. because they have to be retrievable by
420 -- name. Before generating the proper call to one of these operations we
421 -- check whether Typ is known to be controlled at the point of definition.
422 -- If it is not then we must retrieve the hidden operation of the parent
423 -- and use it instead. This is one case that might be solved more cleanly
424 -- once Overriding pragmas or declarations are in place.
426 function Contains_Subprogram (Blk : Entity_Id) return Boolean;
427 -- Check recursively whether a loop or block contains a subprogram that
428 -- may need an activation record.
430 function Convert_View
433 Ind : Pos := 1) return Node_Id;
434 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
435 -- argument being passed to it. Ind indicates which formal of procedure
436 -- Proc we are trying to match. This function will, if necessary, generate
437 -- a conversion between the partial and full view of Arg to match the type
438 -- of the formal of Proc, or force a conversion to the class-wide type in
439 -- the case where the operation is abstract.
441 function Enclosing_Function (E : Entity_Id) return Entity_Id;
442 -- Given an arbitrary entity, traverse the scope chain looking for the
443 -- first enclosing function. Return Empty if no function was found.
449 Skip_Self : Boolean := False) return Node_Id;
450 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
451 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
452 -- an adjust or finalization call. Wnen flag Skip_Self is set, the related
453 -- action has an effect on the components only (if any).
455 function Make_Deep_Proc
456 (Prim : Final_Primitives;
458 Stmts : List_Id) return Node_Id;
459 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
460 -- Deep_Finalize procedures according to the first parameter, these
461 -- procedures operate on the type Typ. The Stmts parameter gives the body
464 function Make_Deep_Array_Body
465 (Prim : Final_Primitives;
466 Typ : Entity_Id) return List_Id;
467 -- This function generates the list of statements for implementing
468 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
469 -- the first parameter, these procedures operate on the array type Typ.
471 function Make_Deep_Record_Body
472 (Prim : Final_Primitives;
474 Is_Local : Boolean := False) return List_Id;
475 -- This function generates the list of statements for implementing
476 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
477 -- the first parameter, these procedures operate on the record type Typ.
478 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
479 -- whether the inner logic should be dictated by state counters.
481 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id;
482 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
483 -- Make_Deep_Record_Body. Generate the following statements:
486 -- type Acc_Typ is access all Typ;
487 -- for Acc_Typ'Storage_Size use 0;
489 -- [Deep_]Finalize (Acc_Typ (V).all);
492 --------------------------------
493 -- Allows_Finalization_Master --
494 --------------------------------
496 function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is
497 function In_Deallocation_Instance (E : Entity_Id) return Boolean;
498 -- Determine whether entity E is inside a wrapper package created for
499 -- an instance of Ada.Unchecked_Deallocation.
501 ------------------------------
502 -- In_Deallocation_Instance --
503 ------------------------------
505 function In_Deallocation_Instance (E : Entity_Id) return Boolean is
506 Pkg : constant Entity_Id := Scope (E);
507 Par : Node_Id := Empty;
510 if Ekind (Pkg) = E_Package
511 and then Present (Related_Instance (Pkg))
512 and then Ekind (Related_Instance (Pkg)) = E_Procedure
514 Par := Generic_Parent (Parent (Related_Instance (Pkg)));
518 and then Chars (Par) = Name_Unchecked_Deallocation
519 and then Chars (Scope (Par)) = Name_Ada
520 and then Scope (Scope (Par)) = Standard_Standard;
524 end In_Deallocation_Instance;
528 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
529 Ptr_Typ : constant Entity_Id :=
530 Root_Type_Of_Full_View (Base_Type (Typ));
532 -- Start of processing for Allows_Finalization_Master
535 -- Certain run-time configurations and targets do not provide support
536 -- for controlled types and therefore do not need masters.
538 if Restriction_Active (No_Finalization) then
541 -- Do not consider C and C++ types since it is assumed that the non-Ada
542 -- side will handle their cleanup.
544 elsif Convention (Desig_Typ) = Convention_C
545 or else Convention (Desig_Typ) = Convention_CPP
549 -- Do not consider an access type that returns on the secondary stack
551 elsif Present (Associated_Storage_Pool (Ptr_Typ))
552 and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
556 -- Do not consider an access type that can never allocate an object
558 elsif No_Pool_Assigned (Ptr_Typ) then
561 -- Do not consider an access type coming from an Unchecked_Deallocation
562 -- instance. Even though the designated type may be controlled, the
563 -- access type will never participate in any allocations.
565 elsif In_Deallocation_Instance (Ptr_Typ) then
568 -- Do not consider a non-library access type when No_Nested_Finalization
569 -- is in effect since finalization masters are controlled objects and if
570 -- created will violate the restriction.
572 elsif Restriction_Active (No_Nested_Finalization)
573 and then not Is_Library_Level_Entity (Ptr_Typ)
577 -- Do not consider an access type subject to pragma No_Heap_Finalization
578 -- because objects allocated through such a type are not to be finalized
579 -- when the access type goes out of scope.
581 elsif No_Heap_Finalization (Ptr_Typ) then
584 -- Do not create finalization masters in GNATprove mode because this
585 -- causes unwanted extra expansion. A compilation in this mode must
586 -- keep the tree as close as possible to the original sources.
588 elsif GNATprove_Mode then
591 -- Otherwise the access type may use a finalization master
596 end Allows_Finalization_Master;
598 ----------------------------
599 -- Build_Anonymous_Master --
600 ----------------------------
602 procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is
603 function Create_Anonymous_Master
604 (Desig_Typ : Entity_Id;
606 Unit_Decl : Node_Id) return Entity_Id;
607 -- Create a new anonymous master for access type Ptr_Typ with designated
608 -- type Desig_Typ. The declaration of the master and its initialization
609 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
610 -- the entity of Unit_Decl.
612 function Current_Anonymous_Master
613 (Desig_Typ : Entity_Id;
614 Unit_Id : Entity_Id) return Entity_Id;
615 -- Find an anonymous master declared within unit Unit_Id which services
616 -- designated type Desig_Typ. If there is no such master, return Empty.
618 -----------------------------
619 -- Create_Anonymous_Master --
620 -----------------------------
622 function Create_Anonymous_Master
623 (Desig_Typ : Entity_Id;
625 Unit_Decl : Node_Id) return Entity_Id
627 Loc : constant Source_Ptr := Sloc (Unit_Id);
638 -- <FM_Id> : Finalization_Master;
640 FM_Id := Make_Temporary (Loc, 'A');
643 Make_Object_Declaration (Loc,
644 Defining_Identifier => FM_Id,
646 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
650 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
653 Make_Procedure_Call_Statement (Loc,
655 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
656 Parameter_Associations => New_List (
657 New_Occurrence_Of (FM_Id, Loc),
658 Make_Attribute_Reference (Loc,
660 New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
661 Attribute_Name => Name_Unrestricted_Access)));
663 -- Find the declarative list of the unit
665 if Nkind (Unit_Decl) = N_Package_Declaration then
666 Unit_Spec := Specification (Unit_Decl);
667 Decls := Visible_Declarations (Unit_Spec);
671 Set_Visible_Declarations (Unit_Spec, Decls);
674 -- Package body or subprogram case
676 -- ??? A subprogram spec or body that acts as a compilation unit may
677 -- contain a formal parameter of an anonymous access-to-controlled
678 -- type initialized by an allocator.
680 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
682 -- There is no suitable place to create the master as the subprogram
683 -- is not in a declarative list.
686 Decls := Declarations (Unit_Decl);
690 Set_Declarations (Unit_Decl, Decls);
694 Prepend_To (Decls, FM_Init);
695 Prepend_To (Decls, FM_Decl);
697 -- Use the scope of the unit when analyzing the declaration of the
698 -- master and its initialization actions.
700 Push_Scope (Unit_Id);
705 -- Mark the master as servicing this specific designated type
707 Set_Anonymous_Designated_Type (FM_Id, Desig_Typ);
709 -- Include the anonymous master in the list of existing masters which
710 -- appear in this unit. This effectively creates a mapping between a
711 -- master and a designated type which in turn allows for the reuse of
712 -- masters on a per-unit basis.
714 All_FMs := Anonymous_Masters (Unit_Id);
717 All_FMs := New_Elmt_List;
718 Set_Anonymous_Masters (Unit_Id, All_FMs);
721 Prepend_Elmt (FM_Id, All_FMs);
724 end Create_Anonymous_Master;
726 ------------------------------
727 -- Current_Anonymous_Master --
728 ------------------------------
730 function Current_Anonymous_Master
731 (Desig_Typ : Entity_Id;
732 Unit_Id : Entity_Id) return Entity_Id
734 All_FMs : constant Elist_Id := Anonymous_Masters (Unit_Id);
739 -- Inspect the list of anonymous masters declared within the unit
740 -- looking for an existing master which services the same designated
743 if Present (All_FMs) then
744 FM_Elmt := First_Elmt (All_FMs);
745 while Present (FM_Elmt) loop
746 FM_Id := Node (FM_Elmt);
748 -- The currect master services the same designated type. As a
749 -- result the master can be reused and associated with another
750 -- anonymous access-to-controlled type.
752 if Anonymous_Designated_Type (FM_Id) = Desig_Typ then
761 end Current_Anonymous_Master;
765 Desig_Typ : Entity_Id;
767 Priv_View : Entity_Id;
771 -- Start of processing for Build_Anonymous_Master
774 -- Nothing to do if the circumstances do not allow for a finalization
777 if not Allows_Finalization_Master (Ptr_Typ) then
781 Unit_Decl := Unit (Cunit (Current_Sem_Unit));
782 Unit_Id := Unique_Defining_Entity (Unit_Decl);
784 -- The compilation unit is a package instantiation. In this case the
785 -- anonymous master is associated with the package spec as both the
786 -- spec and body appear at the same level.
788 if Nkind (Unit_Decl) = N_Package_Body
789 and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
791 Unit_Id := Corresponding_Spec (Unit_Decl);
792 Unit_Decl := Unit_Declaration_Node (Unit_Id);
795 -- Use the initial declaration of the designated type when it denotes
796 -- the full view of an incomplete or private type. This ensures that
797 -- types with one and two views are treated the same.
799 Desig_Typ := Directly_Designated_Type (Ptr_Typ);
800 Priv_View := Incomplete_Or_Partial_View (Desig_Typ);
802 if Present (Priv_View) then
803 Desig_Typ := Priv_View;
806 -- Determine whether the current semantic unit already has an anonymous
807 -- master which services the designated type.
809 FM_Id := Current_Anonymous_Master (Desig_Typ, Unit_Id);
811 -- If this is not the case, create a new master
814 FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl);
817 Set_Finalization_Master (Ptr_Typ, FM_Id);
818 end Build_Anonymous_Master;
820 ----------------------------
821 -- Build_Array_Deep_Procs --
822 ----------------------------
824 procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
828 (Prim => Initialize_Case,
830 Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
832 if not Is_Limited_View (Typ) then
835 (Prim => Adjust_Case,
837 Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
840 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
841 -- suppressed since these routine will not be used.
843 if not Restriction_Active (No_Finalization) then
846 (Prim => Finalize_Case,
848 Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
850 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
852 if not CodePeer_Mode then
855 (Prim => Address_Case,
857 Stmts => Make_Deep_Array_Body (Address_Case, Typ)));
860 end Build_Array_Deep_Procs;
862 ------------------------------
863 -- Build_Cleanup_Statements --
864 ------------------------------
866 function Build_Cleanup_Statements
868 Additional_Cleanup : List_Id) return List_Id
870 Is_Asynchronous_Call : constant Boolean :=
871 Nkind (N) = N_Block_Statement
872 and then Is_Asynchronous_Call_Block (N);
873 Is_Master : constant Boolean :=
874 Nkind (N) /= N_Entry_Body
875 and then Is_Task_Master (N);
876 Is_Protected_Body : constant Boolean :=
877 Nkind (N) = N_Subprogram_Body
878 and then Is_Protected_Subprogram_Body (N);
879 Is_Task_Allocation : constant Boolean :=
880 Nkind (N) = N_Block_Statement
881 and then Is_Task_Allocation_Block (N);
882 Is_Task_Body : constant Boolean :=
883 Nkind (Original_Node (N)) = N_Task_Body;
885 Loc : constant Source_Ptr := Sloc (N);
886 Stmts : constant List_Id := New_List;
890 if Restricted_Profile then
892 Build_Runtime_Call (Loc, RE_Complete_Restricted_Task));
894 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Task));
898 if Restriction_Active (No_Task_Hierarchy) = False then
899 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Complete_Master));
902 -- Add statements to unlock the protected object parameter and to
903 -- undefer abort. If the context is a protected procedure and the object
904 -- has entries, call the entry service routine.
906 -- NOTE: The generated code references _object, a parameter to the
909 elsif Is_Protected_Body then
911 Spec : constant Node_Id := Parent (Corresponding_Spec (N));
912 Conc_Typ : Entity_Id := Empty;
914 Param_Typ : Entity_Id;
917 -- Find the _object parameter representing the protected object
919 Param := First (Parameter_Specifications (Spec));
921 Param_Typ := Etype (Parameter_Type (Param));
923 if Ekind (Param_Typ) = E_Record_Type then
924 Conc_Typ := Corresponding_Concurrent_Type (Param_Typ);
927 exit when No (Param) or else Present (Conc_Typ);
931 pragma Assert (Present (Param));
932 pragma Assert (Present (Conc_Typ));
934 -- Historical note: In earlier versions of GNAT, there was code
935 -- at this point to generate stuff to service entry queues. It is
936 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
938 Build_Protected_Subprogram_Call_Cleanup
939 (Specification (N), Conc_Typ, Loc, Stmts);
942 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
943 -- tasks. Other unactivated tasks are completed by Complete_Task or
946 -- NOTE: The generated code references _chain, a local object
948 elsif Is_Task_Allocation then
951 -- Expunge_Unactivated_Tasks (_chain);
953 -- where _chain is the list of tasks created by the allocator but not
954 -- yet activated. This list will be empty unless the block completes
958 Make_Procedure_Call_Statement (Loc,
961 (RTE (RE_Expunge_Unactivated_Tasks), Loc),
962 Parameter_Associations => New_List (
963 New_Occurrence_Of (Activation_Chain_Entity (N), Loc))));
965 -- Attempt to cancel an asynchronous entry call whenever the block which
966 -- contains the abortable part is exited.
968 -- NOTE: The generated code references Cnn, a local object
970 elsif Is_Asynchronous_Call then
972 Cancel_Param : constant Entity_Id :=
973 Entry_Cancel_Parameter (Entity (Identifier (N)));
976 -- If it is of type Communication_Block, this must be a protected
977 -- entry call. Generate:
979 -- if Enqueued (Cancel_Param) then
980 -- Cancel_Protected_Entry_Call (Cancel_Param);
983 if Is_RTE (Etype (Cancel_Param), RE_Communication_Block) then
985 Make_If_Statement (Loc,
987 Make_Function_Call (Loc,
989 New_Occurrence_Of (RTE (RE_Enqueued), Loc),
990 Parameter_Associations => New_List (
991 New_Occurrence_Of (Cancel_Param, Loc))),
993 Then_Statements => New_List (
994 Make_Procedure_Call_Statement (Loc,
997 (RTE (RE_Cancel_Protected_Entry_Call), Loc),
998 Parameter_Associations => New_List (
999 New_Occurrence_Of (Cancel_Param, Loc))))));
1001 -- Asynchronous delay, generate:
1002 -- Cancel_Async_Delay (Cancel_Param);
1004 elsif Is_RTE (Etype (Cancel_Param), RE_Delay_Block) then
1006 Make_Procedure_Call_Statement (Loc,
1008 New_Occurrence_Of (RTE (RE_Cancel_Async_Delay), Loc),
1009 Parameter_Associations => New_List (
1010 Make_Attribute_Reference (Loc,
1012 New_Occurrence_Of (Cancel_Param, Loc),
1013 Attribute_Name => Name_Unchecked_Access))));
1015 -- Task entry call, generate:
1016 -- Cancel_Task_Entry_Call (Cancel_Param);
1020 Make_Procedure_Call_Statement (Loc,
1022 New_Occurrence_Of (RTE (RE_Cancel_Task_Entry_Call), Loc),
1023 Parameter_Associations => New_List (
1024 New_Occurrence_Of (Cancel_Param, Loc))));
1029 Append_List_To (Stmts, Additional_Cleanup);
1031 end Build_Cleanup_Statements;
1033 -----------------------------
1034 -- Build_Controlling_Procs --
1035 -----------------------------
1037 procedure Build_Controlling_Procs (Typ : Entity_Id) is
1039 if Is_Array_Type (Typ) then
1040 Build_Array_Deep_Procs (Typ);
1041 else pragma Assert (Is_Record_Type (Typ));
1042 Build_Record_Deep_Procs (Typ);
1044 end Build_Controlling_Procs;
1046 -----------------------------
1047 -- Build_Exception_Handler --
1048 -----------------------------
1050 function Build_Exception_Handler
1051 (Data : Finalization_Exception_Data;
1052 For_Library : Boolean := False) return Node_Id
1055 Proc_To_Call : Entity_Id;
1060 pragma Assert (Present (Data.Raised_Id));
1062 if Exception_Extra_Info
1063 or else (For_Library and not Restricted_Profile)
1065 if Exception_Extra_Info then
1069 -- Get_Current_Excep.all
1072 Make_Function_Call (Data.Loc,
1074 Make_Explicit_Dereference (Data.Loc,
1077 (RTE (RE_Get_Current_Excep), Data.Loc)));
1084 Except := Make_Null (Data.Loc);
1087 if For_Library and then not Restricted_Profile then
1088 Proc_To_Call := RTE (RE_Save_Library_Occurrence);
1089 Actuals := New_List (Except);
1092 Proc_To_Call := RTE (RE_Save_Occurrence);
1094 -- The dereference occurs only when Exception_Extra_Info is true,
1095 -- and therefore Except is not null.
1099 New_Occurrence_Of (Data.E_Id, Data.Loc),
1100 Make_Explicit_Dereference (Data.Loc, Except));
1106 -- if not Raised_Id then
1107 -- Raised_Id := True;
1109 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1111 -- Save_Library_Occurrence (Get_Current_Excep.all);
1116 Make_If_Statement (Data.Loc,
1118 Make_Op_Not (Data.Loc,
1119 Right_Opnd => New_Occurrence_Of (Data.Raised_Id, Data.Loc)),
1121 Then_Statements => New_List (
1122 Make_Assignment_Statement (Data.Loc,
1123 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
1124 Expression => New_Occurrence_Of (Standard_True, Data.Loc)),
1126 Make_Procedure_Call_Statement (Data.Loc,
1128 New_Occurrence_Of (Proc_To_Call, Data.Loc),
1129 Parameter_Associations => Actuals))));
1134 -- Raised_Id := True;
1137 Make_Assignment_Statement (Data.Loc,
1138 Name => New_Occurrence_Of (Data.Raised_Id, Data.Loc),
1139 Expression => New_Occurrence_Of (Standard_True, Data.Loc)));
1147 Make_Exception_Handler (Data.Loc,
1148 Exception_Choices => New_List (Make_Others_Choice (Data.Loc)),
1149 Statements => Stmts);
1150 end Build_Exception_Handler;
1152 -------------------------------
1153 -- Build_Finalization_Master --
1154 -------------------------------
1156 procedure Build_Finalization_Master
1158 For_Lib_Level : Boolean := False;
1159 For_Private : Boolean := False;
1160 Context_Scope : Entity_Id := Empty;
1161 Insertion_Node : Node_Id := Empty)
1163 procedure Add_Pending_Access_Type
1165 Ptr_Typ : Entity_Id);
1166 -- Add access type Ptr_Typ to the pending access type list for type Typ
1168 -----------------------------
1169 -- Add_Pending_Access_Type --
1170 -----------------------------
1172 procedure Add_Pending_Access_Type
1174 Ptr_Typ : Entity_Id)
1179 if Present (Pending_Access_Types (Typ)) then
1180 List := Pending_Access_Types (Typ);
1182 List := New_Elmt_List;
1183 Set_Pending_Access_Types (Typ, List);
1186 Prepend_Elmt (Ptr_Typ, List);
1187 end Add_Pending_Access_Type;
1191 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
1193 Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ));
1194 -- A finalization master created for a named access type is associated
1195 -- with the full view (if applicable) as a consequence of freezing. The
1196 -- full view criteria does not apply to anonymous access types because
1197 -- those cannot have a private and a full view.
1199 -- Start of processing for Build_Finalization_Master
1202 -- Nothing to do if the circumstances do not allow for a finalization
1205 if not Allows_Finalization_Master (Typ) then
1208 -- Various machinery such as freezing may have already created a
1209 -- finalization master.
1211 elsif Present (Finalization_Master (Ptr_Typ)) then
1216 Actions : constant List_Id := New_List;
1217 Loc : constant Source_Ptr := Sloc (Ptr_Typ);
1218 Fin_Mas_Id : Entity_Id;
1219 Pool_Id : Entity_Id;
1222 -- Source access types use fixed master names since the master is
1223 -- inserted in the same source unit only once. The only exception to
1224 -- this are instances using the same access type as generic actual.
1226 if Comes_From_Source (Ptr_Typ) and then not Inside_A_Generic then
1228 Make_Defining_Identifier (Loc,
1229 Chars => New_External_Name (Chars (Ptr_Typ), "FM"));
1231 -- Internally generated access types use temporaries as their names
1232 -- due to possible collision with identical names coming from other
1236 Fin_Mas_Id := Make_Temporary (Loc, 'F');
1239 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
1242 -- <Ptr_Typ>FM : aliased Finalization_Master;
1245 Make_Object_Declaration (Loc,
1246 Defining_Identifier => Fin_Mas_Id,
1247 Aliased_Present => True,
1248 Object_Definition =>
1249 New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
1251 -- Set the associated pool and primitive Finalize_Address of the new
1252 -- finalization master.
1254 -- The access type has a user-defined storage pool, use it
1256 if Present (Associated_Storage_Pool (Ptr_Typ)) then
1257 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
1259 -- Otherwise the default choice is the global storage pool
1262 Pool_Id := RTE (RE_Global_Pool_Object);
1263 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
1267 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1270 Make_Procedure_Call_Statement (Loc,
1272 New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
1273 Parameter_Associations => New_List (
1274 New_Occurrence_Of (Fin_Mas_Id, Loc),
1275 Make_Attribute_Reference (Loc,
1276 Prefix => New_Occurrence_Of (Pool_Id, Loc),
1277 Attribute_Name => Name_Unrestricted_Access))));
1279 -- Finalize_Address is not generated in CodePeer mode because the
1280 -- body contains address arithmetic. Skip this step.
1282 if CodePeer_Mode then
1285 -- Associate the Finalize_Address primitive of the designated type
1286 -- with the finalization master of the access type. The designated
1287 -- type must be forzen as Finalize_Address is generated when the
1288 -- freeze node is expanded.
1290 elsif Is_Frozen (Desig_Typ)
1291 and then Present (Finalize_Address (Desig_Typ))
1293 -- The finalization master of an anonymous access type may need
1294 -- to be inserted in a specific place in the tree. For instance:
1298 -- <finalization master of "access Comp_Typ">
1300 -- type Rec_Typ is record
1301 -- Comp : access Comp_Typ;
1304 -- <freeze node for Comp_Typ>
1305 -- <freeze node for Rec_Typ>
1307 -- Due to this oddity, the anonymous access type is stored for
1308 -- later processing (see below).
1310 and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type
1313 -- Set_Finalize_Address
1314 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1317 Make_Set_Finalize_Address_Call
1319 Ptr_Typ => Ptr_Typ));
1321 -- Otherwise the designated type is either anonymous access or a
1322 -- Taft-amendment type and has not been frozen. Store the access
1323 -- type for later processing (see Freeze_Type).
1326 Add_Pending_Access_Type (Desig_Typ, Ptr_Typ);
1329 -- A finalization master created for an access designating a type
1330 -- with private components is inserted before a context-dependent
1335 -- At this point both the scope of the context and the insertion
1336 -- mode must be known.
1338 pragma Assert (Present (Context_Scope));
1339 pragma Assert (Present (Insertion_Node));
1341 Push_Scope (Context_Scope);
1343 -- Treat use clauses as declarations and insert directly in front
1346 if Nkind_In (Insertion_Node, N_Use_Package_Clause,
1349 Insert_List_Before_And_Analyze (Insertion_Node, Actions);
1351 Insert_Actions (Insertion_Node, Actions);
1356 -- The finalization master belongs to an access result type related
1357 -- to a build-in-place function call used to initialize a library
1358 -- level object. The master must be inserted in front of the access
1359 -- result type declaration denoted by Insertion_Node.
1361 elsif For_Lib_Level then
1362 pragma Assert (Present (Insertion_Node));
1363 Insert_Actions (Insertion_Node, Actions);
1365 -- Otherwise the finalization master and its initialization become a
1366 -- part of the freeze node.
1369 Append_Freeze_Actions (Ptr_Typ, Actions);
1372 end Build_Finalization_Master;
1374 ---------------------
1375 -- Build_Finalizer --
1376 ---------------------
1378 procedure Build_Finalizer
1380 Clean_Stmts : List_Id;
1381 Mark_Id : Entity_Id;
1382 Top_Decls : List_Id;
1383 Defer_Abort : Boolean;
1384 Fin_Id : out Entity_Id)
1386 Acts_As_Clean : constant Boolean :=
1389 (Present (Clean_Stmts)
1390 and then Is_Non_Empty_List (Clean_Stmts));
1392 For_Package_Body : constant Boolean := Nkind (N) = N_Package_Body;
1393 For_Package_Spec : constant Boolean := Nkind (N) = N_Package_Declaration;
1394 For_Package : constant Boolean :=
1395 For_Package_Body or else For_Package_Spec;
1396 Loc : constant Source_Ptr := Sloc (N);
1398 -- NOTE: Local variable declarations are conservative and do not create
1399 -- structures right from the start. Entities and lists are created once
1400 -- it has been established that N has at least one controlled object.
1402 Components_Built : Boolean := False;
1403 -- A flag used to avoid double initialization of entities and lists. If
1404 -- the flag is set then the following variables have been initialized:
1410 Counter_Id : Entity_Id := Empty;
1411 Counter_Val : Nat := 0;
1412 -- Name and value of the state counter
1414 Decls : List_Id := No_List;
1415 -- Declarative region of N (if available). If N is a package declaration
1416 -- Decls denotes the visible declarations.
1418 Finalizer_Data : Finalization_Exception_Data;
1419 -- Data for the exception
1421 Finalizer_Decls : List_Id := No_List;
1422 -- Local variable declarations. This list holds the label declarations
1423 -- of all jump block alternatives as well as the declaration of the
1424 -- local exception occurrence and the raised flag:
1425 -- E : Exception_Occurrence;
1426 -- Raised : Boolean := False;
1427 -- L<counter value> : label;
1429 Finalizer_Insert_Nod : Node_Id := Empty;
1430 -- Insertion point for the finalizer body. Depending on the context
1431 -- (Nkind of N) and the individual grouping of controlled objects, this
1432 -- node may denote a package declaration or body, package instantiation,
1433 -- block statement or a counter update statement.
1435 Finalizer_Stmts : List_Id := No_List;
1436 -- The statement list of the finalizer body. It contains the following:
1438 -- Abort_Defer; -- Added if abort is allowed
1439 -- <call to Prev_At_End> -- Added if exists
1440 -- <cleanup statements> -- Added if Acts_As_Clean
1441 -- <jump block> -- Added if Has_Ctrl_Objs
1442 -- <finalization statements> -- Added if Has_Ctrl_Objs
1443 -- <stack release> -- Added if Mark_Id exists
1444 -- Abort_Undefer; -- Added if abort is allowed
1446 Has_Ctrl_Objs : Boolean := False;
1447 -- A general flag which denotes whether N has at least one controlled
1450 Has_Tagged_Types : Boolean := False;
1451 -- A general flag which indicates whether N has at least one library-
1452 -- level tagged type declaration.
1454 HSS : Node_Id := Empty;
1455 -- The sequence of statements of N (if available)
1457 Jump_Alts : List_Id := No_List;
1458 -- Jump block alternatives. Depending on the value of the state counter,
1459 -- the control flow jumps to a sequence of finalization statements. This
1460 -- list contains the following:
1462 -- when <counter value> =>
1463 -- goto L<counter value>;
1465 Jump_Block_Insert_Nod : Node_Id := Empty;
1466 -- Specific point in the finalizer statements where the jump block is
1469 Last_Top_Level_Ctrl_Construct : Node_Id := Empty;
1470 -- The last controlled construct encountered when processing the top
1471 -- level lists of N. This can be a nested package, an instantiation or
1472 -- an object declaration.
1474 Prev_At_End : Entity_Id := Empty;
1475 -- The previous at end procedure of the handled statements block of N
1477 Priv_Decls : List_Id := No_List;
1478 -- The private declarations of N if N is a package declaration
1480 Spec_Id : Entity_Id := Empty;
1481 Spec_Decls : List_Id := Top_Decls;
1482 Stmts : List_Id := No_List;
1484 Tagged_Type_Stmts : List_Id := No_List;
1485 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1486 -- tagged types found in N.
1488 -----------------------
1489 -- Local subprograms --
1490 -----------------------
1492 procedure Build_Components;
1493 -- Create all entites and initialize all lists used in the creation of
1496 procedure Create_Finalizer;
1497 -- Create the spec and body of the finalizer and insert them in the
1498 -- proper place in the tree depending on the context.
1500 procedure Process_Declarations
1502 Preprocess : Boolean := False;
1503 Top_Level : Boolean := False);
1504 -- Inspect a list of declarations or statements which may contain
1505 -- objects that need finalization. When flag Preprocess is set, the
1506 -- routine will simply count the total number of controlled objects in
1507 -- Decls. Flag Top_Level denotes whether the processing is done for
1508 -- objects in nested package declarations or instances.
1510 procedure Process_Object_Declaration
1512 Has_No_Init : Boolean := False;
1513 Is_Protected : Boolean := False);
1514 -- Generate all the machinery associated with the finalization of a
1515 -- single object. Flag Has_No_Init is used to denote certain contexts
1516 -- where Decl does not have initialization call(s). Flag Is_Protected
1517 -- is set when Decl denotes a simple protected object.
1519 procedure Process_Tagged_Type_Declaration (Decl : Node_Id);
1520 -- Generate all the code necessary to unregister the external tag of a
1523 ----------------------
1524 -- Build_Components --
1525 ----------------------
1527 procedure Build_Components is
1528 Counter_Decl : Node_Id;
1529 Counter_Typ : Entity_Id;
1530 Counter_Typ_Decl : Node_Id;
1533 pragma Assert (Present (Decls));
1535 -- This routine might be invoked several times when dealing with
1536 -- constructs that have two lists (either two declarative regions
1537 -- or declarations and statements). Avoid double initialization.
1539 if Components_Built then
1543 Components_Built := True;
1545 if Has_Ctrl_Objs then
1547 -- Create entities for the counter, its type, the local exception
1548 -- and the raised flag.
1550 Counter_Id := Make_Temporary (Loc, 'C');
1551 Counter_Typ := Make_Temporary (Loc, 'T');
1553 Finalizer_Decls := New_List;
1555 Build_Object_Declarations
1556 (Finalizer_Data, Finalizer_Decls, Loc, For_Package);
1558 -- Since the total number of controlled objects is always known,
1559 -- build a subtype of Natural with precise bounds. This allows
1560 -- the backend to optimize the case statement. Generate:
1562 -- subtype Tnn is Natural range 0 .. Counter_Val;
1565 Make_Subtype_Declaration (Loc,
1566 Defining_Identifier => Counter_Typ,
1567 Subtype_Indication =>
1568 Make_Subtype_Indication (Loc,
1569 Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
1571 Make_Range_Constraint (Loc,
1575 Make_Integer_Literal (Loc, Uint_0),
1577 Make_Integer_Literal (Loc, Counter_Val)))));
1579 -- Generate the declaration of the counter itself:
1581 -- Counter : Integer := 0;
1584 Make_Object_Declaration (Loc,
1585 Defining_Identifier => Counter_Id,
1586 Object_Definition => New_Occurrence_Of (Counter_Typ, Loc),
1587 Expression => Make_Integer_Literal (Loc, 0));
1589 -- Set the type of the counter explicitly to prevent errors when
1590 -- examining object declarations later on.
1592 Set_Etype (Counter_Id, Counter_Typ);
1594 -- The counter and its type are inserted before the source
1595 -- declarations of N.
1597 Prepend_To (Decls, Counter_Decl);
1598 Prepend_To (Decls, Counter_Typ_Decl);
1600 -- The counter and its associated type must be manually analyzed
1601 -- since N has already been analyzed. Use the scope of the spec
1602 -- when inserting in a package.
1605 Push_Scope (Spec_Id);
1606 Analyze (Counter_Typ_Decl);
1607 Analyze (Counter_Decl);
1611 Analyze (Counter_Typ_Decl);
1612 Analyze (Counter_Decl);
1615 Jump_Alts := New_List;
1618 -- If the context requires additional cleanup, the finalization
1619 -- machinery is added after the cleanup code.
1621 if Acts_As_Clean then
1622 Finalizer_Stmts := Clean_Stmts;
1623 Jump_Block_Insert_Nod := Last (Finalizer_Stmts);
1625 Finalizer_Stmts := New_List;
1628 if Has_Tagged_Types then
1629 Tagged_Type_Stmts := New_List;
1631 end Build_Components;
1633 ----------------------
1634 -- Create_Finalizer --
1635 ----------------------
1637 procedure Create_Finalizer is
1638 function New_Finalizer_Name return Name_Id;
1639 -- Create a fully qualified name of a package spec or body finalizer.
1640 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1642 ------------------------
1643 -- New_Finalizer_Name --
1644 ------------------------
1646 function New_Finalizer_Name return Name_Id is
1647 procedure New_Finalizer_Name (Id : Entity_Id);
1648 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1649 -- has a non-standard scope, process the scope first.
1651 ------------------------
1652 -- New_Finalizer_Name --
1653 ------------------------
1655 procedure New_Finalizer_Name (Id : Entity_Id) is
1657 if Scope (Id) = Standard_Standard then
1658 Get_Name_String (Chars (Id));
1661 New_Finalizer_Name (Scope (Id));
1662 Add_Str_To_Name_Buffer ("__");
1663 Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id)));
1665 end New_Finalizer_Name;
1667 -- Start of processing for New_Finalizer_Name
1670 -- Create the fully qualified name of the enclosing scope
1672 New_Finalizer_Name (Spec_Id);
1675 -- __finalize_[spec|body]
1677 Add_Str_To_Name_Buffer ("__finalize_");
1679 if For_Package_Spec then
1680 Add_Str_To_Name_Buffer ("spec");
1682 Add_Str_To_Name_Buffer ("body");
1686 end New_Finalizer_Name;
1690 Body_Id : Entity_Id;
1693 Jump_Block : Node_Id;
1695 Label_Id : Entity_Id;
1697 -- Start of processing for Create_Finalizer
1700 -- Step 1: Creation of the finalizer name
1702 -- Packages must use a distinct name for their finalizers since the
1703 -- binder will have to generate calls to them by name. The name is
1704 -- of the following form:
1706 -- xx__yy__finalize_[spec|body]
1709 Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name);
1710 Set_Has_Qualified_Name (Fin_Id);
1711 Set_Has_Fully_Qualified_Name (Fin_Id);
1713 -- The default name is _finalizer
1717 Make_Defining_Identifier (Loc,
1718 Chars => New_External_Name (Name_uFinalizer));
1720 -- The visibility semantics of AT_END handlers force a strange
1721 -- separation of spec and body for stack-related finalizers:
1723 -- declare : Enclosing_Scope
1724 -- procedure _finalizer;
1726 -- <controlled objects>
1727 -- procedure _finalizer is
1733 -- Both spec and body are within the same construct and scope, but
1734 -- the body is part of the handled sequence of statements. This
1735 -- placement confuses the elaboration mechanism on targets where
1736 -- AT_END handlers are expanded into "when all others" handlers:
1739 -- when all others =>
1740 -- _finalizer; -- appears to require elab checks
1745 -- Since the compiler guarantees that the body of a _finalizer is
1746 -- always inserted in the same construct where the AT_END handler
1747 -- resides, there is no need for elaboration checks.
1749 Set_Kill_Elaboration_Checks (Fin_Id);
1751 -- Inlining the finalizer produces a substantial speedup at -O2.
1752 -- It is inlined by default at -O3. Either way, it is called
1753 -- exactly twice (once on the normal path, and once for
1754 -- exceptions/abort), so this won't bloat the code too much.
1756 Set_Is_Inlined (Fin_Id);
1759 -- Step 2: Creation of the finalizer specification
1762 -- procedure Fin_Id;
1765 Make_Subprogram_Declaration (Loc,
1767 Make_Procedure_Specification (Loc,
1768 Defining_Unit_Name => Fin_Id));
1770 -- Step 3: Creation of the finalizer body
1772 if Has_Ctrl_Objs then
1774 -- Add L0, the default destination to the jump block
1776 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
1777 Set_Entity (Label_Id,
1778 Make_Defining_Identifier (Loc, Chars (Label_Id)));
1779 Label := Make_Label (Loc, Label_Id);
1784 Prepend_To (Finalizer_Decls,
1785 Make_Implicit_Label_Declaration (Loc,
1786 Defining_Identifier => Entity (Label_Id),
1787 Label_Construct => Label));
1793 Append_To (Jump_Alts,
1794 Make_Case_Statement_Alternative (Loc,
1795 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1796 Statements => New_List (
1797 Make_Goto_Statement (Loc,
1798 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
1803 Append_To (Finalizer_Stmts, Label);
1805 -- Create the jump block which controls the finalization flow
1806 -- depending on the value of the state counter.
1809 Make_Case_Statement (Loc,
1810 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
1811 Alternatives => Jump_Alts);
1813 if Acts_As_Clean and then Present (Jump_Block_Insert_Nod) then
1814 Insert_After (Jump_Block_Insert_Nod, Jump_Block);
1816 Prepend_To (Finalizer_Stmts, Jump_Block);
1820 -- Add the library-level tagged type unregistration machinery before
1821 -- the jump block circuitry. This ensures that external tags will be
1822 -- removed even if a finalization exception occurs at some point.
1824 if Has_Tagged_Types then
1825 Prepend_List_To (Finalizer_Stmts, Tagged_Type_Stmts);
1828 -- Add a call to the previous At_End handler if it exists. The call
1829 -- must always precede the jump block.
1831 if Present (Prev_At_End) then
1832 Prepend_To (Finalizer_Stmts,
1833 Make_Procedure_Call_Statement (Loc, Prev_At_End));
1835 -- Clear the At_End handler since we have already generated the
1836 -- proper replacement call for it.
1838 Set_At_End_Proc (HSS, Empty);
1841 -- Release the secondary stack
1843 if Present (Mark_Id) then
1845 Release : Node_Id := Build_SS_Release_Call (Loc, Mark_Id);
1848 -- If the context is a build-in-place function, the secondary
1849 -- stack must be released, unless the build-in-place function
1850 -- itself is returning on the secondary stack. Generate:
1852 -- if BIP_Alloc_Form /= Secondary_Stack then
1853 -- SS_Release (Mark_Id);
1856 -- Note that if the function returns on the secondary stack,
1857 -- then the responsibility of reclaiming the space is always
1858 -- left to the caller (recursively if needed).
1860 if Nkind (N) = N_Subprogram_Body then
1862 Spec_Id : constant Entity_Id :=
1863 Unique_Defining_Entity (N);
1864 BIP_SS : constant Boolean :=
1865 Is_Build_In_Place_Function (Spec_Id)
1866 and then Needs_BIP_Alloc_Form (Spec_Id);
1870 Make_If_Statement (Loc,
1875 (Build_In_Place_Formal
1876 (Spec_Id, BIP_Alloc_Form), Loc),
1878 Make_Integer_Literal (Loc,
1880 (BIP_Allocation_Form'Pos
1881 (Secondary_Stack)))),
1883 Then_Statements => New_List (Release));
1888 Append_To (Finalizer_Stmts, Release);
1892 -- Protect the statements with abort defer/undefer. This is only when
1893 -- aborts are allowed and the cleanup statements require deferral or
1894 -- there are controlled objects to be finalized. Note that the abort
1895 -- defer/undefer pair does not require an extra block because each
1896 -- finalization exception is caught in its corresponding finalization
1897 -- block. As a result, the call to Abort_Defer always takes place.
1899 if Abort_Allowed and then (Defer_Abort or Has_Ctrl_Objs) then
1900 Prepend_To (Finalizer_Stmts,
1901 Build_Runtime_Call (Loc, RE_Abort_Defer));
1903 Append_To (Finalizer_Stmts,
1904 Build_Runtime_Call (Loc, RE_Abort_Undefer));
1907 -- The local exception does not need to be reraised for library-level
1908 -- finalizers. Note that this action must be carried out after object
1909 -- cleanup, secondary stack release, and abort undeferral. Generate:
1911 -- if Raised and then not Abort then
1912 -- Raise_From_Controlled_Operation (E);
1915 if Has_Ctrl_Objs and Exceptions_OK and not For_Package then
1916 Append_To (Finalizer_Stmts,
1917 Build_Raise_Statement (Finalizer_Data));
1921 -- procedure Fin_Id is
1922 -- Abort : constant Boolean := Triggered_By_Abort;
1924 -- Abort : constant Boolean := False; -- no abort
1926 -- E : Exception_Occurrence; -- All added if flag
1927 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1933 -- Abort_Defer; -- Added if abort is allowed
1934 -- <call to Prev_At_End> -- Added if exists
1935 -- <cleanup statements> -- Added if Acts_As_Clean
1936 -- <jump block> -- Added if Has_Ctrl_Objs
1937 -- <finalization statements> -- Added if Has_Ctrl_Objs
1938 -- <stack release> -- Added if Mark_Id exists
1939 -- Abort_Undefer; -- Added if abort is allowed
1940 -- <exception propagation> -- Added if Has_Ctrl_Objs
1943 -- Create the body of the finalizer
1945 Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
1948 Set_Has_Qualified_Name (Body_Id);
1949 Set_Has_Fully_Qualified_Name (Body_Id);
1953 Make_Subprogram_Body (Loc,
1955 Make_Procedure_Specification (Loc,
1956 Defining_Unit_Name => Body_Id),
1957 Declarations => Finalizer_Decls,
1958 Handled_Statement_Sequence =>
1959 Make_Handled_Sequence_Of_Statements (Loc,
1960 Statements => Finalizer_Stmts));
1962 -- Step 4: Spec and body insertion, analysis
1966 -- If the package spec has private declarations, the finalizer
1967 -- body must be added to the end of the list in order to have
1968 -- visibility of all private controlled objects.
1970 if For_Package_Spec then
1971 if Present (Priv_Decls) then
1972 Append_To (Priv_Decls, Fin_Spec);
1973 Append_To (Priv_Decls, Fin_Body);
1975 Append_To (Decls, Fin_Spec);
1976 Append_To (Decls, Fin_Body);
1979 -- For package bodies, both the finalizer spec and body are
1980 -- inserted at the end of the package declarations.
1983 Append_To (Decls, Fin_Spec);
1984 Append_To (Decls, Fin_Body);
1987 -- Push the name of the package
1989 Push_Scope (Spec_Id);
1997 -- Create the spec for the finalizer. The At_End handler must be
1998 -- able to call the body which resides in a nested structure.
2002 -- procedure Fin_Id; -- Spec
2004 -- <objects and possibly statements>
2005 -- procedure Fin_Id is ... -- Body
2008 -- Fin_Id; -- At_End handler
2011 pragma Assert (Present (Spec_Decls));
2013 Append_To (Spec_Decls, Fin_Spec);
2016 -- When the finalizer acts solely as a cleanup routine, the body
2017 -- is inserted right after the spec.
2019 if Acts_As_Clean and not Has_Ctrl_Objs then
2020 Insert_After (Fin_Spec, Fin_Body);
2022 -- In all other cases the body is inserted after either:
2024 -- 1) The counter update statement of the last controlled object
2025 -- 2) The last top level nested controlled package
2026 -- 3) The last top level controlled instantiation
2029 -- Manually freeze the spec. This is somewhat of a hack because
2030 -- a subprogram is frozen when its body is seen and the freeze
2031 -- node appears right before the body. However, in this case,
2032 -- the spec must be frozen earlier since the At_End handler
2033 -- must be able to call it.
2036 -- procedure Fin_Id; -- Spec
2037 -- [Fin_Id] -- Freeze node
2041 -- Fin_Id; -- At_End handler
2044 Ensure_Freeze_Node (Fin_Id);
2045 Insert_After (Fin_Spec, Freeze_Node (Fin_Id));
2046 Set_Is_Frozen (Fin_Id);
2048 -- In the case where the last construct to contain a controlled
2049 -- object is either a nested package, an instantiation or a
2050 -- freeze node, the body must be inserted directly after the
2053 if Nkind_In (Last_Top_Level_Ctrl_Construct,
2055 N_Package_Declaration,
2058 Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct;
2061 Insert_After (Finalizer_Insert_Nod, Fin_Body);
2064 Analyze (Fin_Body, Suppress => All_Checks);
2067 -- Never consider that the finalizer procedure is enabled Ghost, even
2068 -- when the corresponding unit is Ghost, as this would lead to an
2069 -- an external name with a ___ghost_ prefix that the binder cannot
2070 -- generate, as it has no knowledge of the Ghost status of units.
2072 Set_Is_Checked_Ghost_Entity (Fin_Id, False);
2073 end Create_Finalizer;
2075 --------------------------
2076 -- Process_Declarations --
2077 --------------------------
2079 procedure Process_Declarations
2081 Preprocess : Boolean := False;
2082 Top_Level : Boolean := False)
2087 Obj_Typ : Entity_Id;
2088 Pack_Id : Entity_Id;
2092 Old_Counter_Val : Nat;
2093 -- This variable is used to determine whether a nested package or
2094 -- instance contains at least one controlled object.
2096 procedure Processing_Actions
2097 (Has_No_Init : Boolean := False;
2098 Is_Protected : Boolean := False);
2099 -- Depending on the mode of operation of Process_Declarations, either
2100 -- increment the controlled object counter, set the controlled object
2101 -- flag and store the last top level construct or process the current
2102 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2103 -- the current declaration may not have initialization proc(s). Flag
2104 -- Is_Protected should be set when the current declaration denotes a
2105 -- simple protected object.
2107 ------------------------
2108 -- Processing_Actions --
2109 ------------------------
2111 procedure Processing_Actions
2112 (Has_No_Init : Boolean := False;
2113 Is_Protected : Boolean := False)
2116 -- Library-level tagged type
2118 if Nkind (Decl) = N_Full_Type_Declaration then
2120 Has_Tagged_Types := True;
2122 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
2123 Last_Top_Level_Ctrl_Construct := Decl;
2127 Process_Tagged_Type_Declaration (Decl);
2130 -- Controlled object declaration
2134 Counter_Val := Counter_Val + 1;
2135 Has_Ctrl_Objs := True;
2137 if Top_Level and then No (Last_Top_Level_Ctrl_Construct) then
2138 Last_Top_Level_Ctrl_Construct := Decl;
2142 Process_Object_Declaration (Decl, Has_No_Init, Is_Protected);
2145 end Processing_Actions;
2147 -- Start of processing for Process_Declarations
2150 if No (Decls) or else Is_Empty_List (Decls) then
2154 -- Process all declarations in reverse order
2156 Decl := Last_Non_Pragma (Decls);
2157 while Present (Decl) loop
2159 -- Library-level tagged types
2161 if Nkind (Decl) = N_Full_Type_Declaration then
2162 Typ := Defining_Identifier (Decl);
2164 -- Ignored Ghost types do not need any cleanup actions because
2165 -- they will not appear in the final tree.
2167 if Is_Ignored_Ghost_Entity (Typ) then
2170 elsif Is_Tagged_Type (Typ)
2171 and then Is_Library_Level_Entity (Typ)
2172 and then Convention (Typ) = Convention_Ada
2173 and then Present (Access_Disp_Table (Typ))
2174 and then RTE_Available (RE_Register_Tag)
2175 and then not Is_Abstract_Type (Typ)
2176 and then not No_Run_Time_Mode
2181 -- Regular object declarations
2183 elsif Nkind (Decl) = N_Object_Declaration then
2184 Obj_Id := Defining_Identifier (Decl);
2185 Obj_Typ := Base_Type (Etype (Obj_Id));
2186 Expr := Expression (Decl);
2188 -- Bypass any form of processing for objects which have their
2189 -- finalization disabled. This applies only to objects at the
2192 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2195 -- Finalization of transient objects are treated separately in
2196 -- order to handle sensitive cases. These include:
2198 -- * Aggregate expansion
2199 -- * If, case, and expression with actions expansion
2200 -- * Transient scopes
2202 -- If one of those contexts has marked the transient object as
2203 -- ignored, do not generate finalization actions for it.
2205 elsif Is_Finalized_Transient (Obj_Id)
2206 or else Is_Ignored_Transient (Obj_Id)
2210 -- Ignored Ghost objects do not need any cleanup actions
2211 -- because they will not appear in the final tree.
2213 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2216 -- The object is of the form:
2217 -- Obj : [constant] Typ [:= Expr];
2219 -- Do not process tag-to-class-wide conversions because they do
2220 -- not yield an object. Do not process the incomplete view of a
2221 -- deferred constant. Note that an object initialized by means
2222 -- of a build-in-place function call may appear as a deferred
2223 -- constant after expansion activities. These kinds of objects
2224 -- must be finalized.
2226 elsif not Is_Imported (Obj_Id)
2227 and then Needs_Finalization (Obj_Typ)
2228 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
2229 and then not (Ekind (Obj_Id) = E_Constant
2230 and then not Has_Completion (Obj_Id)
2231 and then No (BIP_Initialization_Call (Obj_Id)))
2235 -- The object is of the form:
2236 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2238 -- Obj : Access_Typ :=
2239 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2241 elsif Is_Access_Type (Obj_Typ)
2242 and then Needs_Finalization
2243 (Available_View (Designated_Type (Obj_Typ)))
2244 and then Present (Expr)
2246 (Is_Secondary_Stack_BIP_Func_Call (Expr)
2248 (Is_Non_BIP_Func_Call (Expr)
2249 and then not Is_Related_To_Func_Return (Obj_Id)))
2251 Processing_Actions (Has_No_Init => True);
2253 -- Processing for "hook" objects generated for transient
2254 -- objects declared inside an Expression_With_Actions.
2256 elsif Is_Access_Type (Obj_Typ)
2257 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2258 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2259 N_Object_Declaration
2261 Processing_Actions (Has_No_Init => True);
2263 -- Process intermediate results of an if expression with one
2264 -- of the alternatives using a controlled function call.
2266 elsif Is_Access_Type (Obj_Typ)
2267 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2268 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
2269 N_Defining_Identifier
2270 and then Present (Expr)
2271 and then Nkind (Expr) = N_Null
2273 Processing_Actions (Has_No_Init => True);
2275 -- Simple protected objects which use type System.Tasking.
2276 -- Protected_Objects.Protection to manage their locks should
2277 -- be treated as controlled since they require manual cleanup.
2278 -- The only exception is illustrated in the following example:
2281 -- type Ctrl is new Controlled ...
2282 -- procedure Finalize (Obj : in out Ctrl);
2286 -- package body Pkg is
2287 -- protected Prot is
2288 -- procedure Do_Something (Obj : in out Ctrl);
2291 -- protected body Prot is
2292 -- procedure Do_Something (Obj : in out Ctrl) is ...
2295 -- procedure Finalize (Obj : in out Ctrl) is
2297 -- Prot.Do_Something (Obj);
2301 -- Since for the most part entities in package bodies depend on
2302 -- those in package specs, Prot's lock should be cleaned up
2303 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2304 -- This act however attempts to invoke Do_Something and fails
2305 -- because the lock has disappeared.
2307 elsif Ekind (Obj_Id) = E_Variable
2308 and then not In_Library_Level_Package_Body (Obj_Id)
2309 and then (Is_Simple_Protected_Type (Obj_Typ)
2310 or else Has_Simple_Protected_Object (Obj_Typ))
2312 Processing_Actions (Is_Protected => True);
2315 -- Specific cases of object renamings
2317 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
2318 Obj_Id := Defining_Identifier (Decl);
2319 Obj_Typ := Base_Type (Etype (Obj_Id));
2321 -- Bypass any form of processing for objects which have their
2322 -- finalization disabled. This applies only to objects at the
2325 if For_Package and then Finalize_Storage_Only (Obj_Typ) then
2328 -- Ignored Ghost object renamings do not need any cleanup
2329 -- actions because they will not appear in the final tree.
2331 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
2334 -- Return object of a build-in-place function. This case is
2335 -- recognized and marked by the expansion of an extended return
2336 -- statement (see Expand_N_Extended_Return_Statement).
2338 elsif Needs_Finalization (Obj_Typ)
2339 and then Is_Return_Object (Obj_Id)
2340 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
2342 Processing_Actions (Has_No_Init => True);
2344 -- Detect a case where a source object has been initialized by
2345 -- a controlled function call or another object which was later
2346 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
2348 -- Obj1 : CW_Type := Src_Obj;
2349 -- Obj2 : CW_Type := Function_Call (...);
2351 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
2352 -- Tmp : ... := Function_Call (...)'reference;
2353 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
2355 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
2356 Processing_Actions (Has_No_Init => True);
2359 -- Inspect the freeze node of an access-to-controlled type and
2360 -- look for a delayed finalization master. This case arises when
2361 -- the freeze actions are inserted at a later time than the
2362 -- expansion of the context. Since Build_Finalizer is never called
2363 -- on a single construct twice, the master will be ultimately
2364 -- left out and never finalized. This is also needed for freeze
2365 -- actions of designated types themselves, since in some cases the
2366 -- finalization master is associated with a designated type's
2367 -- freeze node rather than that of the access type (see handling
2368 -- for freeze actions in Build_Finalization_Master).
2370 elsif Nkind (Decl) = N_Freeze_Entity
2371 and then Present (Actions (Decl))
2373 Typ := Entity (Decl);
2375 -- Freeze nodes for ignored Ghost types do not need cleanup
2376 -- actions because they will never appear in the final tree.
2378 if Is_Ignored_Ghost_Entity (Typ) then
2381 elsif (Is_Access_Type (Typ)
2382 and then not Is_Access_Subprogram_Type (Typ)
2383 and then Needs_Finalization
2384 (Available_View (Designated_Type (Typ))))
2385 or else (Is_Type (Typ) and then Needs_Finalization (Typ))
2387 Old_Counter_Val := Counter_Val;
2389 -- Freeze nodes are considered to be identical to packages
2390 -- and blocks in terms of nesting. The difference is that
2391 -- a finalization master created inside the freeze node is
2392 -- at the same nesting level as the node itself.
2394 Process_Declarations (Actions (Decl), Preprocess);
2396 -- The freeze node contains a finalization master
2400 and then No (Last_Top_Level_Ctrl_Construct)
2401 and then Counter_Val > Old_Counter_Val
2403 Last_Top_Level_Ctrl_Construct := Decl;
2407 -- Nested package declarations, avoid generics
2409 elsif Nkind (Decl) = N_Package_Declaration then
2410 Pack_Id := Defining_Entity (Decl);
2411 Spec := Specification (Decl);
2413 -- Do not inspect an ignored Ghost package because all code
2414 -- found within will not appear in the final tree.
2416 if Is_Ignored_Ghost_Entity (Pack_Id) then
2419 elsif Ekind (Pack_Id) /= E_Generic_Package then
2420 Old_Counter_Val := Counter_Val;
2421 Process_Declarations
2422 (Private_Declarations (Spec), Preprocess);
2423 Process_Declarations
2424 (Visible_Declarations (Spec), Preprocess);
2426 -- Either the visible or the private declarations contain a
2427 -- controlled object. The nested package declaration is the
2428 -- last such construct.
2432 and then No (Last_Top_Level_Ctrl_Construct)
2433 and then Counter_Val > Old_Counter_Val
2435 Last_Top_Level_Ctrl_Construct := Decl;
2439 -- Nested package bodies, avoid generics
2441 elsif Nkind (Decl) = N_Package_Body then
2443 -- Do not inspect an ignored Ghost package body because all
2444 -- code found within will not appear in the final tree.
2446 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
2449 elsif Ekind (Corresponding_Spec (Decl)) /=
2452 Old_Counter_Val := Counter_Val;
2453 Process_Declarations (Declarations (Decl), Preprocess);
2455 -- The nested package body is the last construct to contain
2456 -- a controlled object.
2460 and then No (Last_Top_Level_Ctrl_Construct)
2461 and then Counter_Val > Old_Counter_Val
2463 Last_Top_Level_Ctrl_Construct := Decl;
2467 -- Handle a rare case caused by a controlled transient object
2468 -- created as part of a record init proc. The variable is wrapped
2469 -- in a block, but the block is not associated with a transient
2472 elsif Nkind (Decl) = N_Block_Statement
2473 and then Inside_Init_Proc
2475 Old_Counter_Val := Counter_Val;
2477 if Present (Handled_Statement_Sequence (Decl)) then
2478 Process_Declarations
2479 (Statements (Handled_Statement_Sequence (Decl)),
2483 Process_Declarations (Declarations (Decl), Preprocess);
2485 -- Either the declaration or statement list of the block has a
2486 -- controlled object.
2490 and then No (Last_Top_Level_Ctrl_Construct)
2491 and then Counter_Val > Old_Counter_Val
2493 Last_Top_Level_Ctrl_Construct := Decl;
2496 -- Handle the case where the original context has been wrapped in
2497 -- a block to avoid interference between exception handlers and
2498 -- At_End handlers. Treat the block as transparent and process its
2501 elsif Nkind (Decl) = N_Block_Statement
2502 and then Is_Finalization_Wrapper (Decl)
2504 if Present (Handled_Statement_Sequence (Decl)) then
2505 Process_Declarations
2506 (Statements (Handled_Statement_Sequence (Decl)),
2510 Process_Declarations (Declarations (Decl), Preprocess);
2513 Prev_Non_Pragma (Decl);
2515 end Process_Declarations;
2517 --------------------------------
2518 -- Process_Object_Declaration --
2519 --------------------------------
2521 procedure Process_Object_Declaration
2523 Has_No_Init : Boolean := False;
2524 Is_Protected : Boolean := False)
2526 Loc : constant Source_Ptr := Sloc (Decl);
2527 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
2529 Init_Typ : Entity_Id;
2530 -- The initialization type of the related object declaration. Note
2531 -- that this is not necessarily the same type as Obj_Typ because of
2532 -- possible type derivations.
2534 Obj_Typ : Entity_Id;
2535 -- The type of the related object declaration
2537 function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
2538 -- Func_Id denotes a build-in-place function. Generate the following
2541 -- if BIPallocfrom > Secondary_Stack'Pos
2542 -- and then BIPfinalizationmaster /= null
2545 -- type Ptr_Typ is access Obj_Typ;
2546 -- for Ptr_Typ'Storage_Pool
2547 -- use Base_Pool (BIPfinalizationmaster);
2549 -- Free (Ptr_Typ (Temp));
2553 -- Obj_Typ is the type of the current object, Temp is the original
2554 -- allocation which Obj_Id renames.
2556 procedure Find_Last_Init
2557 (Last_Init : out Node_Id;
2558 Body_Insert : out Node_Id);
2559 -- Find the last initialization call related to object declaration
2560 -- Decl. Last_Init denotes the last initialization call which follows
2561 -- Decl. Body_Insert denotes a node where the finalizer body could be
2562 -- potentially inserted after (if blocks are involved).
2564 -----------------------------
2565 -- Build_BIP_Cleanup_Stmts --
2566 -----------------------------
2568 function Build_BIP_Cleanup_Stmts
2569 (Func_Id : Entity_Id) return Node_Id
2571 Decls : constant List_Id := New_List;
2572 Fin_Mas_Id : constant Entity_Id :=
2573 Build_In_Place_Formal
2574 (Func_Id, BIP_Finalization_Master);
2575 Func_Typ : constant Entity_Id := Etype (Func_Id);
2576 Temp_Id : constant Entity_Id :=
2577 Entity (Prefix (Name (Parent (Obj_Id))));
2581 Free_Stmt : Node_Id;
2582 Pool_Id : Entity_Id;
2583 Ptr_Typ : Entity_Id;
2587 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2589 Pool_Id := Make_Temporary (Loc, 'P');
2592 Make_Object_Renaming_Declaration (Loc,
2593 Defining_Identifier => Pool_Id,
2595 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc),
2597 Make_Explicit_Dereference (Loc,
2599 Make_Function_Call (Loc,
2601 New_Occurrence_Of (RTE (RE_Base_Pool), Loc),
2602 Parameter_Associations => New_List (
2603 Make_Explicit_Dereference (Loc,
2605 New_Occurrence_Of (Fin_Mas_Id, Loc)))))));
2607 -- Create an access type which uses the storage pool of the
2608 -- caller's finalization master.
2611 -- type Ptr_Typ is access Func_Typ;
2613 Ptr_Typ := Make_Temporary (Loc, 'P');
2616 Make_Full_Type_Declaration (Loc,
2617 Defining_Identifier => Ptr_Typ,
2619 Make_Access_To_Object_Definition (Loc,
2620 Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc))));
2622 -- Perform minor decoration in order to set the master and the
2623 -- storage pool attributes.
2625 Set_Ekind (Ptr_Typ, E_Access_Type);
2626 Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id);
2627 Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
2629 -- Create an explicit free statement. Note that the free uses the
2630 -- caller's pool expressed as a renaming.
2633 Make_Free_Statement (Loc,
2635 Unchecked_Convert_To (Ptr_Typ,
2636 New_Occurrence_Of (Temp_Id, Loc)));
2638 Set_Storage_Pool (Free_Stmt, Pool_Id);
2640 -- Create a block to house the dummy type and the instantiation as
2641 -- well as to perform the cleanup the temporary.
2647 -- Free (Ptr_Typ (Temp_Id));
2651 Make_Block_Statement (Loc,
2652 Declarations => Decls,
2653 Handled_Statement_Sequence =>
2654 Make_Handled_Sequence_Of_Statements (Loc,
2655 Statements => New_List (Free_Stmt)));
2658 -- if BIPfinalizationmaster /= null then
2662 Left_Opnd => New_Occurrence_Of (Fin_Mas_Id, Loc),
2663 Right_Opnd => Make_Null (Loc));
2665 -- For constrained or tagged results escalate the condition to
2666 -- include the allocation format. Generate:
2668 -- if BIPallocform > Secondary_Stack'Pos
2669 -- and then BIPfinalizationmaster /= null
2672 if not Is_Constrained (Func_Typ)
2673 or else Is_Tagged_Type (Func_Typ)
2676 Alloc : constant Entity_Id :=
2677 Build_In_Place_Formal (Func_Id, BIP_Alloc_Form);
2683 Left_Opnd => New_Occurrence_Of (Alloc, Loc),
2685 Make_Integer_Literal (Loc,
2687 (BIP_Allocation_Form'Pos (Secondary_Stack)))),
2689 Right_Opnd => Cond);
2699 Make_If_Statement (Loc,
2701 Then_Statements => New_List (Free_Blk));
2702 end Build_BIP_Cleanup_Stmts;
2704 --------------------
2705 -- Find_Last_Init --
2706 --------------------
2708 procedure Find_Last_Init
2709 (Last_Init : out Node_Id;
2710 Body_Insert : out Node_Id)
2712 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id;
2713 -- Find the last initialization call within the statements of
2716 function Is_Init_Call (N : Node_Id) return Boolean;
2717 -- Determine whether node N denotes one of the initialization
2718 -- procedures of types Init_Typ or Obj_Typ.
2720 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
2721 -- Obtain the next statement which follows list member Stmt while
2722 -- ignoring artifacts related to access-before-elaboration checks.
2724 -----------------------------
2725 -- Find_Last_Init_In_Block --
2726 -----------------------------
2728 function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is
2729 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2733 -- Examine the individual statements of the block in reverse to
2734 -- locate the last initialization call.
2736 if Present (HSS) and then Present (Statements (HSS)) then
2737 Stmt := Last (Statements (HSS));
2738 while Present (Stmt) loop
2740 -- Peek inside nested blocks in case aborts are allowed
2742 if Nkind (Stmt) = N_Block_Statement then
2743 return Find_Last_Init_In_Block (Stmt);
2745 elsif Is_Init_Call (Stmt) then
2754 end Find_Last_Init_In_Block;
2760 function Is_Init_Call (N : Node_Id) return Boolean is
2761 function Is_Init_Proc_Of
2762 (Subp_Id : Entity_Id;
2763 Typ : Entity_Id) return Boolean;
2764 -- Determine whether subprogram Subp_Id is a valid init proc of
2767 ---------------------
2768 -- Is_Init_Proc_Of --
2769 ---------------------
2771 function Is_Init_Proc_Of
2772 (Subp_Id : Entity_Id;
2773 Typ : Entity_Id) return Boolean
2775 Deep_Init : Entity_Id := Empty;
2776 Prim_Init : Entity_Id := Empty;
2777 Type_Init : Entity_Id := Empty;
2780 -- Obtain all possible initialization routines of the
2781 -- related type and try to match the subprogram entity
2782 -- against one of them.
2786 Deep_Init := TSS (Typ, TSS_Deep_Initialize);
2788 -- Primitive Initialize
2790 if Is_Controlled (Typ) then
2791 Prim_Init := Find_Optional_Prim_Op (Typ, Name_Initialize);
2793 if Present (Prim_Init) then
2794 Prim_Init := Ultimate_Alias (Prim_Init);
2798 -- Type initialization routine
2800 if Has_Non_Null_Base_Init_Proc (Typ) then
2801 Type_Init := Base_Init_Proc (Typ);
2805 (Present (Deep_Init) and then Subp_Id = Deep_Init)
2807 (Present (Prim_Init) and then Subp_Id = Prim_Init)
2809 (Present (Type_Init) and then Subp_Id = Type_Init);
2810 end Is_Init_Proc_Of;
2814 Call_Id : Entity_Id;
2816 -- Start of processing for Is_Init_Call
2819 if Nkind (N) = N_Procedure_Call_Statement
2820 and then Nkind (Name (N)) = N_Identifier
2822 Call_Id := Entity (Name (N));
2824 -- Consider both the type of the object declaration and its
2825 -- related initialization type.
2828 Is_Init_Proc_Of (Call_Id, Init_Typ)
2830 Is_Init_Proc_Of (Call_Id, Obj_Typ);
2836 -----------------------------
2837 -- Next_Suitable_Statement --
2838 -----------------------------
2840 function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id is
2844 -- Skip call markers and Program_Error raises installed by the
2847 Result := Next (Stmt);
2848 while Present (Result) loop
2849 if not Nkind_In (Result, N_Call_Marker,
2850 N_Raise_Program_Error)
2855 Result := Next (Result);
2859 end Next_Suitable_Statement;
2867 Deep_Init_Found : Boolean := False;
2868 -- A flag set when a call to [Deep_]Initialize has been found
2870 -- Start of processing for Find_Last_Init
2874 Body_Insert := Empty;
2876 -- Object renamings and objects associated with controlled
2877 -- function results do not require initialization.
2883 Stmt := Next_Suitable_Statement (Decl);
2885 -- For an object with suppressed initialization, we check whether
2886 -- there is in fact no initialization expression. If there is not,
2887 -- then this is an object declaration that has been turned into a
2888 -- different object declaration that calls the build-in-place
2889 -- function in a 'Reference attribute, as in "F(...)'Reference".
2890 -- We search for that later object declaration, so that the
2891 -- Inc_Decl will be inserted after the call. Otherwise, if the
2892 -- call raises an exception, we will finalize the (uninitialized)
2893 -- object, which is wrong.
2895 if No_Initialization (Decl) then
2896 if No (Expression (Last_Init)) then
2898 Last_Init := Next (Last_Init);
2899 exit when No (Last_Init);
2900 exit when Nkind (Last_Init) = N_Object_Declaration
2901 and then Nkind (Expression (Last_Init)) = N_Reference
2902 and then Nkind (Prefix (Expression (Last_Init))) =
2904 and then Is_Expanded_Build_In_Place_Call
2905 (Prefix (Expression (Last_Init)));
2911 -- In all other cases the initialization calls follow the related
2912 -- object. The general structure of object initialization built by
2913 -- routine Default_Initialize_Object is as follows:
2915 -- [begin -- aborts allowed
2917 -- Type_Init_Proc (Obj);
2918 -- [begin] -- exceptions allowed
2919 -- Deep_Initialize (Obj);
2920 -- [exception -- exceptions allowed
2922 -- Deep_Finalize (Obj, Self => False);
2925 -- [at end -- aborts allowed
2929 -- When aborts are allowed, the initialization calls are housed
2932 elsif Nkind (Stmt) = N_Block_Statement then
2933 Last_Init := Find_Last_Init_In_Block (Stmt);
2934 Body_Insert := Stmt;
2936 -- Otherwise the initialization calls follow the related object
2939 Stmt_2 := Next_Suitable_Statement (Stmt);
2941 -- Check for an optional call to Deep_Initialize which may
2942 -- appear within a block depending on whether the object has
2943 -- controlled components.
2945 if Present (Stmt_2) then
2946 if Nkind (Stmt_2) = N_Block_Statement then
2947 Call := Find_Last_Init_In_Block (Stmt_2);
2949 if Present (Call) then
2950 Deep_Init_Found := True;
2952 Body_Insert := Stmt_2;
2955 elsif Is_Init_Call (Stmt_2) then
2956 Deep_Init_Found := True;
2957 Last_Init := Stmt_2;
2958 Body_Insert := Last_Init;
2962 -- If the object lacks a call to Deep_Initialize, then it must
2963 -- have a call to its related type init proc.
2965 if not Deep_Init_Found and then Is_Init_Call (Stmt) then
2967 Body_Insert := Last_Init;
2975 Count_Ins : Node_Id;
2977 Fin_Stmts : List_Id := No_List;
2980 Label_Id : Entity_Id;
2983 -- Start of processing for Process_Object_Declaration
2986 -- Handle the object type and the reference to the object
2988 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
2989 Obj_Typ := Base_Type (Etype (Obj_Id));
2992 if Is_Access_Type (Obj_Typ) then
2993 Obj_Typ := Directly_Designated_Type (Obj_Typ);
2994 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
2996 elsif Is_Concurrent_Type (Obj_Typ)
2997 and then Present (Corresponding_Record_Type (Obj_Typ))
2999 Obj_Typ := Corresponding_Record_Type (Obj_Typ);
3000 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
3002 elsif Is_Private_Type (Obj_Typ)
3003 and then Present (Full_View (Obj_Typ))
3005 Obj_Typ := Full_View (Obj_Typ);
3006 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
3008 elsif Obj_Typ /= Base_Type (Obj_Typ) then
3009 Obj_Typ := Base_Type (Obj_Typ);
3010 Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref);
3017 Set_Etype (Obj_Ref, Obj_Typ);
3019 -- Handle the initialization type of the object declaration
3021 Init_Typ := Obj_Typ;
3023 if Is_Private_Type (Init_Typ)
3024 and then Present (Full_View (Init_Typ))
3026 Init_Typ := Full_View (Init_Typ);
3028 elsif Is_Untagged_Derivation (Init_Typ) then
3029 Init_Typ := Root_Type (Init_Typ);
3036 -- Set a new value for the state counter and insert the statement
3037 -- after the object declaration. Generate:
3039 -- Counter := <value>;
3042 Make_Assignment_Statement (Loc,
3043 Name => New_Occurrence_Of (Counter_Id, Loc),
3044 Expression => Make_Integer_Literal (Loc, Counter_Val));
3046 -- Insert the counter after all initialization has been done. The
3047 -- place of insertion depends on the context.
3049 if Ekind_In (Obj_Id, E_Constant, E_Variable) then
3051 -- The object is initialized by a build-in-place function call.
3052 -- The counter insertion point is after the function call.
3054 if Present (BIP_Initialization_Call (Obj_Id)) then
3055 Count_Ins := BIP_Initialization_Call (Obj_Id);
3058 -- The object is initialized by an aggregate. Insert the counter
3059 -- after the last aggregate assignment.
3061 elsif Present (Last_Aggregate_Assignment (Obj_Id)) then
3062 Count_Ins := Last_Aggregate_Assignment (Obj_Id);
3065 -- In all other cases the counter is inserted after the last call
3066 -- to either [Deep_]Initialize or the type-specific init proc.
3069 Find_Last_Init (Count_Ins, Body_Ins);
3072 -- In all other cases the counter is inserted after the last call to
3073 -- either [Deep_]Initialize or the type-specific init proc.
3076 Find_Last_Init (Count_Ins, Body_Ins);
3079 -- If the Initialize function is null or trivial, the call will have
3080 -- been replaced with a null statement, in which case place counter
3081 -- declaration after object declaration itself.
3083 if No (Count_Ins) then
3087 Insert_After (Count_Ins, Inc_Decl);
3090 -- If the current declaration is the last in the list, the finalizer
3091 -- body needs to be inserted after the set counter statement for the
3092 -- current object declaration. This is complicated by the fact that
3093 -- the set counter statement may appear in abort deferred block. In
3094 -- that case, the proper insertion place is after the block.
3096 if No (Finalizer_Insert_Nod) then
3098 -- Insertion after an abort deferred block
3100 if Present (Body_Ins) then
3101 Finalizer_Insert_Nod := Body_Ins;
3103 Finalizer_Insert_Nod := Inc_Decl;
3107 -- Create the associated label with this object, generate:
3109 -- L<counter> : label;
3112 Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
3114 (Label_Id, Make_Defining_Identifier (Loc, Chars (Label_Id)));
3115 Label := Make_Label (Loc, Label_Id);
3117 Prepend_To (Finalizer_Decls,
3118 Make_Implicit_Label_Declaration (Loc,
3119 Defining_Identifier => Entity (Label_Id),
3120 Label_Construct => Label));
3122 -- Create the associated jump with this object, generate:
3124 -- when <counter> =>
3127 Prepend_To (Jump_Alts,
3128 Make_Case_Statement_Alternative (Loc,
3129 Discrete_Choices => New_List (
3130 Make_Integer_Literal (Loc, Counter_Val)),
3131 Statements => New_List (
3132 Make_Goto_Statement (Loc,
3133 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
3135 -- Insert the jump destination, generate:
3139 Append_To (Finalizer_Stmts, Label);
3141 -- Processing for simple protected objects. Such objects require
3142 -- manual finalization of their lock managers.
3144 if Is_Protected then
3145 if Is_Simple_Protected_Type (Obj_Typ) then
3146 Fin_Call := Cleanup_Protected_Object (Decl, Obj_Ref);
3148 if Present (Fin_Call) then
3149 Fin_Stmts := New_List (Fin_Call);
3152 elsif Has_Simple_Protected_Object (Obj_Typ) then
3153 if Is_Record_Type (Obj_Typ) then
3154 Fin_Stmts := Cleanup_Record (Decl, Obj_Ref, Obj_Typ);
3155 elsif Is_Array_Type (Obj_Typ) then
3156 Fin_Stmts := Cleanup_Array (Decl, Obj_Ref, Obj_Typ);
3162 -- System.Tasking.Protected_Objects.Finalize_Protection
3170 if Present (Fin_Stmts) and then Exceptions_OK then
3171 Fin_Stmts := New_List (
3172 Make_Block_Statement (Loc,
3173 Handled_Statement_Sequence =>
3174 Make_Handled_Sequence_Of_Statements (Loc,
3175 Statements => Fin_Stmts,
3177 Exception_Handlers => New_List (
3178 Make_Exception_Handler (Loc,
3179 Exception_Choices => New_List (
3180 Make_Others_Choice (Loc)),
3182 Statements => New_List (
3183 Make_Null_Statement (Loc)))))));
3186 -- Processing for regular controlled objects
3191 -- [Deep_]Finalize (Obj);
3194 -- when Id : others =>
3195 -- if not Raised then
3197 -- Save_Occurrence (E, Id);
3206 -- Guard against a missing [Deep_]Finalize when the object type
3207 -- was not properly frozen.
3209 if No (Fin_Call) then
3210 Fin_Call := Make_Null_Statement (Loc);
3213 -- For CodePeer, the exception handlers normally generated here
3214 -- generate complex flowgraphs which result in capacity problems.
3215 -- Omitting these handlers for CodePeer is justified as follows:
3217 -- If a handler is dead, then omitting it is surely ok
3219 -- If a handler is live, then CodePeer should flag the
3220 -- potentially-exception-raising construct that causes it
3221 -- to be live. That is what we are interested in, not what
3222 -- happens after the exception is raised.
3224 if Exceptions_OK and not CodePeer_Mode then
3225 Fin_Stmts := New_List (
3226 Make_Block_Statement (Loc,
3227 Handled_Statement_Sequence =>
3228 Make_Handled_Sequence_Of_Statements (Loc,
3229 Statements => New_List (Fin_Call),
3231 Exception_Handlers => New_List (
3232 Build_Exception_Handler
3233 (Finalizer_Data, For_Package)))));
3235 -- When exception handlers are prohibited, the finalization call
3236 -- appears unprotected. Any exception raised during finalization
3237 -- will bypass the circuitry which ensures the cleanup of all
3238 -- remaining objects.
3241 Fin_Stmts := New_List (Fin_Call);
3244 -- If we are dealing with a return object of a build-in-place
3245 -- function, generate the following cleanup statements:
3247 -- if BIPallocfrom > Secondary_Stack'Pos
3248 -- and then BIPfinalizationmaster /= null
3251 -- type Ptr_Typ is access Obj_Typ;
3252 -- for Ptr_Typ'Storage_Pool use
3253 -- Base_Pool (BIPfinalizationmaster.all).all;
3255 -- Free (Ptr_Typ (Temp));
3259 -- The generated code effectively detaches the temporary from the
3260 -- caller finalization master and deallocates the object.
3262 if Is_Return_Object (Obj_Id) then
3264 Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
3266 if Is_Build_In_Place_Function (Func_Id)
3267 and then Needs_BIP_Finalization_Master (Func_Id)
3269 Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
3274 if Ekind_In (Obj_Id, E_Constant, E_Variable)
3275 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
3277 -- Temporaries created for the purpose of "exporting" a
3278 -- transient object out of an Expression_With_Actions (EWA)
3279 -- need guards. The following illustrates the usage of such
3282 -- Access_Typ : access [all] Obj_Typ;
3283 -- Temp : Access_Typ := null;
3284 -- <Counter> := ...;
3287 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3288 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3290 -- Temp := Ctrl_Trans'Unchecked_Access;
3293 -- The finalization machinery does not process EWA nodes as
3294 -- this may lead to premature finalization of expressions. Note
3295 -- that Temp is marked as being properly initialized regardless
3296 -- of whether the initialization of Ctrl_Trans succeeded. Since
3297 -- a failed initialization may leave Temp with a value of null,
3298 -- add a guard to handle this case:
3300 -- if Obj /= null then
3301 -- <object finalization statements>
3304 if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
3305 N_Object_Declaration
3307 Fin_Stmts := New_List (
3308 Make_If_Statement (Loc,
3311 Left_Opnd => New_Occurrence_Of (Obj_Id, Loc),
3312 Right_Opnd => Make_Null (Loc)),
3313 Then_Statements => Fin_Stmts));
3315 -- Return objects use a flag to aid in processing their
3316 -- potential finalization when the enclosing function fails
3317 -- to return properly. Generate:
3320 -- <object finalization statements>
3324 Fin_Stmts := New_List (
3325 Make_If_Statement (Loc,
3330 (Status_Flag_Or_Transient_Decl (Obj_Id), Loc)),
3332 Then_Statements => Fin_Stmts));
3337 Append_List_To (Finalizer_Stmts, Fin_Stmts);
3339 -- Since the declarations are examined in reverse, the state counter
3340 -- must be decremented in order to keep with the true position of
3343 Counter_Val := Counter_Val - 1;
3344 end Process_Object_Declaration;
3346 -------------------------------------
3347 -- Process_Tagged_Type_Declaration --
3348 -------------------------------------
3350 procedure Process_Tagged_Type_Declaration (Decl : Node_Id) is
3351 Typ : constant Entity_Id := Defining_Identifier (Decl);
3352 DT_Ptr : constant Entity_Id :=
3353 Node (First_Elmt (Access_Disp_Table (Typ)));
3356 -- Ada.Tags.Unregister_Tag (<Typ>P);
3358 Append_To (Tagged_Type_Stmts,
3359 Make_Procedure_Call_Statement (Loc,
3361 New_Occurrence_Of (RTE (RE_Unregister_Tag), Loc),
3362 Parameter_Associations => New_List (
3363 New_Occurrence_Of (DT_Ptr, Loc))));
3364 end Process_Tagged_Type_Declaration;
3366 -- Start of processing for Build_Finalizer
3371 -- Do not perform this expansion in SPARK mode because it is not
3374 if GNATprove_Mode then
3378 -- Step 1: Extract all lists which may contain controlled objects or
3379 -- library-level tagged types.
3381 if For_Package_Spec then
3382 Decls := Visible_Declarations (Specification (N));
3383 Priv_Decls := Private_Declarations (Specification (N));
3385 -- Retrieve the package spec id
3387 Spec_Id := Defining_Unit_Name (Specification (N));
3389 if Nkind (Spec_Id) = N_Defining_Program_Unit_Name then
3390 Spec_Id := Defining_Identifier (Spec_Id);
3393 -- Accept statement, block, entry body, package body, protected body,
3394 -- subprogram body or task body.
3397 Decls := Declarations (N);
3398 HSS := Handled_Statement_Sequence (N);
3400 if Present (HSS) then
3401 if Present (Statements (HSS)) then
3402 Stmts := Statements (HSS);
3405 if Present (At_End_Proc (HSS)) then
3406 Prev_At_End := At_End_Proc (HSS);
3410 -- Retrieve the package spec id for package bodies
3412 if For_Package_Body then
3413 Spec_Id := Corresponding_Spec (N);
3417 -- Do not process nested packages since those are handled by the
3418 -- enclosing scope's finalizer. Do not process non-expanded package
3419 -- instantiations since those will be re-analyzed and re-expanded.
3423 (not Is_Library_Level_Entity (Spec_Id)
3425 -- Nested packages are considered to be library level entities,
3426 -- but do not need to be processed separately. True library level
3427 -- packages have a scope value of 1.
3429 or else Scope_Depth_Value (Spec_Id) /= Uint_1
3430 or else (Is_Generic_Instance (Spec_Id)
3431 and then Package_Instantiation (Spec_Id) /= N))
3436 -- Step 2: Object [pre]processing
3440 -- Preprocess the visible declarations now in order to obtain the
3441 -- correct number of controlled object by the time the private
3442 -- declarations are processed.
3444 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
3446 -- From all the possible contexts, only package specifications may
3447 -- have private declarations.
3449 if For_Package_Spec then
3450 Process_Declarations
3451 (Priv_Decls, Preprocess => True, Top_Level => True);
3454 -- The current context may lack controlled objects, but require some
3455 -- other form of completion (task termination for instance). In such
3456 -- cases, the finalizer must be created and carry the additional
3459 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3463 -- The preprocessing has determined that the context has controlled
3464 -- objects or library-level tagged types.
3466 if Has_Ctrl_Objs or Has_Tagged_Types then
3468 -- Private declarations are processed first in order to preserve
3469 -- possible dependencies between public and private objects.
3471 if For_Package_Spec then
3472 Process_Declarations (Priv_Decls);
3475 Process_Declarations (Decls);
3481 -- Preprocess both declarations and statements
3483 Process_Declarations (Decls, Preprocess => True, Top_Level => True);
3484 Process_Declarations (Stmts, Preprocess => True, Top_Level => True);
3486 -- At this point it is known that N has controlled objects. Ensure
3487 -- that N has a declarative list since the finalizer spec will be
3490 if Has_Ctrl_Objs and then No (Decls) then
3491 Set_Declarations (N, New_List);
3492 Decls := Declarations (N);
3493 Spec_Decls := Decls;
3496 -- The current context may lack controlled objects, but require some
3497 -- other form of completion (task termination for instance). In such
3498 -- cases, the finalizer must be created and carry the additional
3501 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3505 if Has_Ctrl_Objs or Has_Tagged_Types then
3506 Process_Declarations (Stmts);
3507 Process_Declarations (Decls);
3511 -- Step 3: Finalizer creation
3513 if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then
3516 end Build_Finalizer;
3518 --------------------------
3519 -- Build_Finalizer_Call --
3520 --------------------------
3522 procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is
3523 Is_Prot_Body : constant Boolean :=
3524 Nkind (N) = N_Subprogram_Body
3525 and then Is_Protected_Subprogram_Body (N);
3526 -- Determine whether N denotes the protected version of a subprogram
3527 -- which belongs to a protected type.
3529 Loc : constant Source_Ptr := Sloc (N);
3533 -- Do not perform this expansion in SPARK mode because we do not create
3534 -- finalizers in the first place.
3536 if GNATprove_Mode then
3540 -- The At_End handler should have been assimilated by the finalizer
3542 HSS := Handled_Statement_Sequence (N);
3543 pragma Assert (No (At_End_Proc (HSS)));
3545 -- If the construct to be cleaned up is a protected subprogram body, the
3546 -- finalizer call needs to be associated with the block which wraps the
3547 -- unprotected version of the subprogram. The following illustrates this
3550 -- procedure Prot_SubpP is
3551 -- procedure finalizer is
3553 -- Service_Entries (Prot_Obj);
3560 -- Prot_SubpN (Prot_Obj);
3566 if Is_Prot_Body then
3567 HSS := Handled_Statement_Sequence (Last (Statements (HSS)));
3569 -- An At_End handler and regular exception handlers cannot coexist in
3570 -- the same statement sequence. Wrap the original statements in a block.
3572 elsif Present (Exception_Handlers (HSS)) then
3574 End_Lab : constant Node_Id := End_Label (HSS);
3579 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
3581 Set_Handled_Statement_Sequence (N,
3582 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
3584 HSS := Handled_Statement_Sequence (N);
3585 Set_End_Label (HSS, End_Lab);
3589 Set_At_End_Proc (HSS, New_Occurrence_Of (Fin_Id, Loc));
3591 -- Attach reference to finalizer to tree, for LLVM use
3593 Set_Parent (At_End_Proc (HSS), HSS);
3595 Analyze (At_End_Proc (HSS));
3596 Expand_At_End_Handler (HSS, Empty);
3597 end Build_Finalizer_Call;
3599 ---------------------
3600 -- Build_Late_Proc --
3601 ---------------------
3603 procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id) is
3605 for Final_Prim in Name_Of'Range loop
3606 if Name_Of (Final_Prim) = Nam then
3609 (Prim => Final_Prim,
3611 Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
3614 end Build_Late_Proc;
3616 -------------------------------
3617 -- Build_Object_Declarations --
3618 -------------------------------
3620 procedure Build_Object_Declarations
3621 (Data : out Finalization_Exception_Data;
3624 For_Package : Boolean := False)
3629 -- This variable captures an unused dummy internal entity, see the
3630 -- comment associated with its use.
3633 pragma Assert (Decls /= No_List);
3635 -- Always set the proper location as it may be needed even when
3636 -- exception propagation is forbidden.
3640 if Restriction_Active (No_Exception_Propagation) then
3641 Data.Abort_Id := Empty;
3643 Data.Raised_Id := Empty;
3647 Data.Raised_Id := Make_Temporary (Loc, 'R');
3649 -- In certain scenarios, finalization can be triggered by an abort. If
3650 -- the finalization itself fails and raises an exception, the resulting
3651 -- Program_Error must be supressed and replaced by an abort signal. In
3652 -- order to detect this scenario, save the state of entry into the
3653 -- finalization code.
3655 -- This is not needed for library-level finalizers as they are called by
3656 -- the environment task and cannot be aborted.
3658 if not For_Package then
3659 if Abort_Allowed then
3660 Data.Abort_Id := Make_Temporary (Loc, 'A');
3663 -- Abort_Id : constant Boolean := <A_Expr>;
3666 Make_Object_Declaration (Loc,
3667 Defining_Identifier => Data.Abort_Id,
3668 Constant_Present => True,
3669 Object_Definition =>
3670 New_Occurrence_Of (Standard_Boolean, Loc),
3672 New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc)));
3674 -- Abort is not required
3677 -- Generate a dummy entity to ensure that the internal symbols are
3678 -- in sync when a unit is compiled with and without aborts.
3680 Dummy := Make_Temporary (Loc, 'A');
3681 Data.Abort_Id := Empty;
3684 -- Library-level finalizers
3687 Data.Abort_Id := Empty;
3690 if Exception_Extra_Info then
3691 Data.E_Id := Make_Temporary (Loc, 'E');
3694 -- E_Id : Exception_Occurrence;
3697 Make_Object_Declaration (Loc,
3698 Defining_Identifier => Data.E_Id,
3699 Object_Definition =>
3700 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc));
3701 Set_No_Initialization (Decl);
3703 Append_To (Decls, Decl);
3710 -- Raised_Id : Boolean := False;
3713 Make_Object_Declaration (Loc,
3714 Defining_Identifier => Data.Raised_Id,
3715 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
3716 Expression => New_Occurrence_Of (Standard_False, Loc)));
3717 end Build_Object_Declarations;
3719 ---------------------------
3720 -- Build_Raise_Statement --
3721 ---------------------------
3723 function Build_Raise_Statement
3724 (Data : Finalization_Exception_Data) return Node_Id
3730 -- Standard run-time use the specialized routine
3731 -- Raise_From_Controlled_Operation.
3733 if Exception_Extra_Info
3734 and then RTE_Available (RE_Raise_From_Controlled_Operation)
3737 Make_Procedure_Call_Statement (Data.Loc,
3740 (RTE (RE_Raise_From_Controlled_Operation), Data.Loc),
3741 Parameter_Associations =>
3742 New_List (New_Occurrence_Of (Data.E_Id, Data.Loc)));
3744 -- Restricted run-time: exception messages are not supported and hence
3745 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3750 Make_Raise_Program_Error (Data.Loc,
3751 Reason => PE_Finalize_Raised_Exception);
3756 -- Raised_Id and then not Abort_Id
3760 Expr := New_Occurrence_Of (Data.Raised_Id, Data.Loc);
3762 if Present (Data.Abort_Id) then
3763 Expr := Make_And_Then (Data.Loc,
3766 Make_Op_Not (Data.Loc,
3767 Right_Opnd => New_Occurrence_Of (Data.Abort_Id, Data.Loc)));
3772 -- if Raised_Id and then not Abort_Id then
3773 -- Raise_From_Controlled_Operation (E_Id);
3775 -- raise Program_Error; -- restricted runtime
3779 Make_If_Statement (Data.Loc,
3781 Then_Statements => New_List (Stmt));
3782 end Build_Raise_Statement;
3784 -----------------------------
3785 -- Build_Record_Deep_Procs --
3786 -----------------------------
3788 procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
3792 (Prim => Initialize_Case,
3794 Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
3796 if not Is_Limited_View (Typ) then
3799 (Prim => Adjust_Case,
3801 Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
3804 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3805 -- suppressed since these routine will not be used.
3807 if not Restriction_Active (No_Finalization) then
3810 (Prim => Finalize_Case,
3812 Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
3814 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3816 if not CodePeer_Mode then
3819 (Prim => Address_Case,
3821 Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
3824 end Build_Record_Deep_Procs;
3830 function Cleanup_Array
3833 Typ : Entity_Id) return List_Id
3835 Loc : constant Source_Ptr := Sloc (N);
3836 Index_List : constant List_Id := New_List;
3838 function Free_Component return List_Id;
3839 -- Generate the code to finalize the task or protected subcomponents
3840 -- of a single component of the array.
3842 function Free_One_Dimension (Dim : Int) return List_Id;
3843 -- Generate a loop over one dimension of the array
3845 --------------------
3846 -- Free_Component --
3847 --------------------
3849 function Free_Component return List_Id is
3850 Stmts : List_Id := New_List;
3852 C_Typ : constant Entity_Id := Component_Type (Typ);
3855 -- Component type is known to contain tasks or protected objects
3858 Make_Indexed_Component (Loc,
3859 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3860 Expressions => Index_List);
3862 Set_Etype (Tsk, C_Typ);
3864 if Is_Task_Type (C_Typ) then
3865 Append_To (Stmts, Cleanup_Task (N, Tsk));
3867 elsif Is_Simple_Protected_Type (C_Typ) then
3868 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3870 elsif Is_Record_Type (C_Typ) then
3871 Stmts := Cleanup_Record (N, Tsk, C_Typ);
3873 elsif Is_Array_Type (C_Typ) then
3874 Stmts := Cleanup_Array (N, Tsk, C_Typ);
3880 ------------------------
3881 -- Free_One_Dimension --
3882 ------------------------
3884 function Free_One_Dimension (Dim : Int) return List_Id is
3888 if Dim > Number_Dimensions (Typ) then
3889 return Free_Component;
3891 -- Here we generate the required loop
3894 Index := Make_Temporary (Loc, 'J');
3895 Append (New_Occurrence_Of (Index, Loc), Index_List);
3898 Make_Implicit_Loop_Statement (N,
3899 Identifier => Empty,
3901 Make_Iteration_Scheme (Loc,
3902 Loop_Parameter_Specification =>
3903 Make_Loop_Parameter_Specification (Loc,
3904 Defining_Identifier => Index,
3905 Discrete_Subtype_Definition =>
3906 Make_Attribute_Reference (Loc,
3907 Prefix => Duplicate_Subexpr (Obj),
3908 Attribute_Name => Name_Range,
3909 Expressions => New_List (
3910 Make_Integer_Literal (Loc, Dim))))),
3911 Statements => Free_One_Dimension (Dim + 1)));
3913 end Free_One_Dimension;
3915 -- Start of processing for Cleanup_Array
3918 return Free_One_Dimension (1);
3921 --------------------
3922 -- Cleanup_Record --
3923 --------------------
3925 function Cleanup_Record
3928 Typ : Entity_Id) return List_Id
3930 Loc : constant Source_Ptr := Sloc (N);
3931 Stmts : constant List_Id := New_List;
3932 U_Typ : constant Entity_Id := Underlying_Type (Typ);
3938 if Has_Discriminants (U_Typ)
3939 and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
3940 and then Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
3943 (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
3945 -- For now, do not attempt to free a component that may appear in a
3946 -- variant, and instead issue a warning. Doing this "properly" would
3947 -- require building a case statement and would be quite a mess. Note
3948 -- that the RM only requires that free "work" for the case of a task
3949 -- access value, so already we go way beyond this in that we deal
3950 -- with the array case and non-discriminated record cases.
3953 ("task/protected object in variant record will not be freed??", N);
3954 return New_List (Make_Null_Statement (Loc));
3957 Comp := First_Component (U_Typ);
3958 while Present (Comp) loop
3959 if Has_Task (Etype (Comp))
3960 or else Has_Simple_Protected_Object (Etype (Comp))
3963 Make_Selected_Component (Loc,
3964 Prefix => Duplicate_Subexpr_No_Checks (Obj),
3965 Selector_Name => New_Occurrence_Of (Comp, Loc));
3966 Set_Etype (Tsk, Etype (Comp));
3968 if Is_Task_Type (Etype (Comp)) then
3969 Append_To (Stmts, Cleanup_Task (N, Tsk));
3971 elsif Is_Simple_Protected_Type (Etype (Comp)) then
3972 Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
3974 elsif Is_Record_Type (Etype (Comp)) then
3976 -- Recurse, by generating the prefix of the argument to the
3977 -- eventual cleanup call.
3979 Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
3981 elsif Is_Array_Type (Etype (Comp)) then
3982 Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
3986 Next_Component (Comp);
3992 ------------------------------
3993 -- Cleanup_Protected_Object --
3994 ------------------------------
3996 function Cleanup_Protected_Object
3998 Ref : Node_Id) return Node_Id
4000 Loc : constant Source_Ptr := Sloc (N);
4003 -- For restricted run-time libraries (Ravenscar), tasks are
4004 -- non-terminating, and protected objects can only appear at library
4005 -- level, so we do not want finalization of protected objects.
4007 if Restricted_Profile then
4012 Make_Procedure_Call_Statement (Loc,
4014 New_Occurrence_Of (RTE (RE_Finalize_Protection), Loc),
4015 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
4017 end Cleanup_Protected_Object;
4023 function Cleanup_Task
4025 Ref : Node_Id) return Node_Id
4027 Loc : constant Source_Ptr := Sloc (N);
4030 -- For restricted run-time libraries (Ravenscar), tasks are
4031 -- non-terminating and they can only appear at library level,
4032 -- so we do not want finalization of task objects.
4034 if Restricted_Profile then
4039 Make_Procedure_Call_Statement (Loc,
4041 New_Occurrence_Of (RTE (RE_Free_Task), Loc),
4042 Parameter_Associations => New_List (Concurrent_Ref (Ref)));
4046 --------------------------------------
4047 -- Check_Unnesting_Elaboration_Code --
4048 --------------------------------------
4050 procedure Check_Unnesting_Elaboration_Code (N : Node_Id) is
4051 Loc : constant Source_Ptr := Sloc (N);
4052 Block_Elab_Proc : Entity_Id := Empty;
4054 procedure Set_Block_Elab_Proc;
4055 -- Create a defining identifier for a procedure that will replace
4056 -- a block with nested subprograms (unless it has already been created,
4057 -- in which case this is a no-op).
4059 procedure Set_Block_Elab_Proc is
4061 if No (Block_Elab_Proc) then
4063 Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('I'));
4065 end Set_Block_Elab_Proc;
4067 procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id);
4068 -- Find entities in the elaboration code of a library package body that
4069 -- contain or represent a subprogram body. A body can appear within a
4070 -- block or a loop or can appear by itself if generated for an object
4071 -- declaration that involves controlled actions. The first such entity
4072 -- forces creation of a new procedure entity (via Set_Block_Elab_Proc)
4073 -- that will be used to reset the scopes of all entities that become
4074 -- local to the new elaboration procedure. This is needed for subsequent
4075 -- unnesting actions, which depend on proper setting of the Scope links
4076 -- to determine the nesting level of each subprogram.
4078 -----------------------
4079 -- Find_Local_Scope --
4080 -----------------------
4082 procedure Reset_Scopes_To_Block_Elab_Proc (L : List_Id) is
4088 while Present (Stat) loop
4089 case Nkind (Stat) is
4090 when N_Block_Statement =>
4091 Id := Entity (Identifier (Stat));
4093 -- The Scope of this block needs to be reset to the new
4094 -- procedure if the block contains nested subprograms.
4096 if Present (Id) and then Contains_Subprogram (Id) then
4097 Set_Block_Elab_Proc;
4098 Set_Scope (Id, Block_Elab_Proc);
4101 when N_Loop_Statement =>
4102 Id := Entity (Identifier (Stat));
4104 if Present (Id) and then Contains_Subprogram (Id) then
4105 if Scope (Id) = Current_Scope then
4106 Set_Block_Elab_Proc;
4107 Set_Scope (Id, Block_Elab_Proc);
4111 -- We traverse the loop's statements as well, which may
4112 -- include other block (etc.) statements that need to have
4113 -- their Scope set to Block_Elab_Proc. (Is this really the
4114 -- case, or do such nested blocks refer to the loop scope
4115 -- rather than the loop's enclosing scope???.)
4117 Reset_Scopes_To_Block_Elab_Proc (Statements (Stat));
4119 when N_If_Statement =>
4120 Reset_Scopes_To_Block_Elab_Proc (Then_Statements (Stat));
4122 Reset_Scopes_To_Block_Elab_Proc (Else_Statements (Stat));
4128 Elif := First (Elsif_Parts (Stat));
4129 while Present (Elif) loop
4130 Reset_Scopes_To_Block_Elab_Proc
4131 (Then_Statements (Elif));
4137 when N_Case_Statement =>
4142 Alt := First (Alternatives (Stat));
4143 while Present (Alt) loop
4144 Reset_Scopes_To_Block_Elab_Proc (Statements (Alt));
4150 -- Reset the Scope of a subprogram occurring at the top level
4152 when N_Subprogram_Body =>
4153 Id := Defining_Entity (Stat);
4155 Set_Block_Elab_Proc;
4156 Set_Scope (Id, Block_Elab_Proc);
4164 end Reset_Scopes_To_Block_Elab_Proc;
4168 H_Seq : constant Node_Id := Handled_Statement_Sequence (N);
4169 Elab_Body : Node_Id;
4170 Elab_Call : Node_Id;
4172 -- Start of processing for Check_Unnesting_Elaboration_Code
4175 if Present (H_Seq) then
4176 Reset_Scopes_To_Block_Elab_Proc (Statements (H_Seq));
4178 -- There may be subprograms declared in the exception handlers
4179 -- of the current body.
4181 if Present (Exception_Handlers (H_Seq)) then
4183 Handler : Node_Id := First (Exception_Handlers (H_Seq));
4185 while Present (Handler) loop
4186 Reset_Scopes_To_Block_Elab_Proc (Statements (Handler));
4193 if Present (Block_Elab_Proc) then
4195 Make_Subprogram_Body (Loc,
4197 Make_Procedure_Specification (Loc,
4198 Defining_Unit_Name => Block_Elab_Proc),
4199 Declarations => New_List,
4200 Handled_Statement_Sequence =>
4201 Relocate_Node (Handled_Statement_Sequence (N)));
4204 Make_Procedure_Call_Statement (Loc,
4205 Name => New_Occurrence_Of (Block_Elab_Proc, Loc));
4207 Append_To (Declarations (N), Elab_Body);
4208 Analyze (Elab_Body);
4209 Set_Has_Nested_Subprogram (Block_Elab_Proc);
4211 Set_Handled_Statement_Sequence (N,
4212 Make_Handled_Sequence_Of_Statements (Loc,
4213 Statements => New_List (Elab_Call)));
4215 Analyze (Elab_Call);
4217 -- Could we reset the scopes of entities associated with the new
4218 -- procedure here via a loop over entities rather than doing it in
4219 -- the recursive Reset_Scopes_To_Elab_Proc procedure???
4222 end Check_Unnesting_Elaboration_Code;
4224 ---------------------------------------
4225 -- Check_Unnesting_In_Decls_Or_Stmts --
4226 ---------------------------------------
4228 procedure Check_Unnesting_In_Decls_Or_Stmts (Decls_Or_Stmts : List_Id) is
4229 Decl_Or_Stmt : Node_Id;
4232 if Unnest_Subprogram_Mode
4233 and then Present (Decls_Or_Stmts)
4235 Decl_Or_Stmt := First (Decls_Or_Stmts);
4236 while Present (Decl_Or_Stmt) loop
4237 if Nkind (Decl_Or_Stmt) = N_Block_Statement
4238 and then Contains_Subprogram (Entity (Identifier (Decl_Or_Stmt)))
4240 Unnest_Block (Decl_Or_Stmt);
4242 elsif Nkind (Decl_Or_Stmt) = N_Loop_Statement then
4244 Id : constant Entity_Id :=
4245 Entity (Identifier (Decl_Or_Stmt));
4248 -- When a top-level loop within declarations of a library
4249 -- package spec or body contains nested subprograms, we wrap
4250 -- it in a procedure to handle possible up-level references
4251 -- to entities associated with the loop (such as loop
4254 if Present (Id) and then Contains_Subprogram (Id) then
4255 Unnest_Loop (Decl_Or_Stmt);
4259 elsif Nkind (Decl_Or_Stmt) = N_Package_Declaration
4260 and then not Modify_Tree_For_C
4262 Check_Unnesting_In_Decls_Or_Stmts
4263 (Visible_Declarations (Specification (Decl_Or_Stmt)));
4264 Check_Unnesting_In_Decls_Or_Stmts
4265 (Private_Declarations (Specification (Decl_Or_Stmt)));
4267 elsif Nkind (Decl_Or_Stmt) = N_Package_Body
4268 and then not Modify_Tree_For_C
4270 Check_Unnesting_In_Decls_Or_Stmts (Declarations (Decl_Or_Stmt));
4271 if Present (Statements
4272 (Handled_Statement_Sequence (Decl_Or_Stmt)))
4274 Check_Unnesting_In_Decls_Or_Stmts (Statements
4275 (Handled_Statement_Sequence (Decl_Or_Stmt)));
4276 Check_Unnesting_In_Handlers (Decl_Or_Stmt);
4280 Next (Decl_Or_Stmt);
4283 end Check_Unnesting_In_Decls_Or_Stmts;
4285 ---------------------------------
4286 -- Check_Unnesting_In_Handlers --
4287 ---------------------------------
4289 procedure Check_Unnesting_In_Handlers (N : Node_Id) is
4290 Stmt_Seq : constant Node_Id := Handled_Statement_Sequence (N);
4293 if Present (Stmt_Seq)
4294 and then Present (Exception_Handlers (Stmt_Seq))
4297 Handler : Node_Id := First (Exception_Handlers (Stmt_Seq));
4299 while Present (Handler) loop
4300 if Present (Statements (Handler)) then
4301 Check_Unnesting_In_Decls_Or_Stmts (Statements (Handler));
4308 end Check_Unnesting_In_Handlers;
4310 ------------------------------
4311 -- Check_Visibly_Controlled --
4312 ------------------------------
4314 procedure Check_Visibly_Controlled
4315 (Prim : Final_Primitives;
4317 E : in out Entity_Id;
4318 Cref : in out Node_Id)
4320 Parent_Type : Entity_Id;
4324 if Is_Derived_Type (Typ)
4325 and then Comes_From_Source (E)
4326 and then not Present (Overridden_Operation (E))
4328 -- We know that the explicit operation on the type does not override
4329 -- the inherited operation of the parent, and that the derivation
4330 -- is from a private type that is not visibly controlled.
4332 Parent_Type := Etype (Typ);
4333 Op := Find_Optional_Prim_Op (Parent_Type, Name_Of (Prim));
4335 if Present (Op) then
4338 -- Wrap the object to be initialized into the proper
4339 -- unchecked conversion, to be compatible with the operation
4342 if Nkind (Cref) = N_Unchecked_Type_Conversion then
4343 Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
4345 Cref := Unchecked_Convert_To (Parent_Type, Cref);
4349 end Check_Visibly_Controlled;
4351 --------------------------
4352 -- Contains_Subprogram --
4353 --------------------------
4355 function Contains_Subprogram (Blk : Entity_Id) return Boolean is
4359 E := First_Entity (Blk);
4361 while Present (E) loop
4362 if Is_Subprogram (E) then
4365 elsif Ekind_In (E, E_Block, E_Loop)
4366 and then Contains_Subprogram (E)
4375 end Contains_Subprogram;
4381 function Convert_View
4384 Ind : Pos := 1) return Node_Id
4386 Fent : Entity_Id := First_Entity (Proc);
4391 for J in 2 .. Ind loop
4395 Ftyp := Etype (Fent);
4397 if Nkind_In (Arg, N_Type_Conversion, N_Unchecked_Type_Conversion) then
4398 Atyp := Entity (Subtype_Mark (Arg));
4400 Atyp := Etype (Arg);
4403 if Is_Abstract_Subprogram (Proc) and then Is_Tagged_Type (Ftyp) then
4404 return Unchecked_Convert_To (Class_Wide_Type (Ftyp), Arg);
4407 and then Present (Atyp)
4408 and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
4409 and then Base_Type (Underlying_Type (Atyp)) =
4410 Base_Type (Underlying_Type (Ftyp))
4412 return Unchecked_Convert_To (Ftyp, Arg);
4414 -- If the argument is already a conversion, as generated by
4415 -- Make_Init_Call, set the target type to the type of the formal
4416 -- directly, to avoid spurious typing problems.
4418 elsif Nkind_In (Arg, N_Unchecked_Type_Conversion, N_Type_Conversion)
4419 and then not Is_Class_Wide_Type (Atyp)
4421 Set_Subtype_Mark (Arg, New_Occurrence_Of (Ftyp, Sloc (Arg)));
4422 Set_Etype (Arg, Ftyp);
4425 -- Otherwise, introduce a conversion when the designated object
4426 -- has a type derived from the formal of the controlled routine.
4428 elsif Is_Private_Type (Ftyp)
4429 and then Present (Atyp)
4430 and then Is_Derived_Type (Underlying_Type (Base_Type (Atyp)))
4432 return Unchecked_Convert_To (Ftyp, Arg);
4439 -------------------------------
4440 -- CW_Or_Has_Controlled_Part --
4441 -------------------------------
4443 function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
4445 return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
4446 end CW_Or_Has_Controlled_Part;
4448 ------------------------
4449 -- Enclosing_Function --
4450 ------------------------
4452 function Enclosing_Function (E : Entity_Id) return Entity_Id is
4453 Func_Id : Entity_Id;
4457 while Present (Func_Id) and then Func_Id /= Standard_Standard loop
4458 if Ekind (Func_Id) = E_Function then
4462 Func_Id := Scope (Func_Id);
4466 end Enclosing_Function;
4468 -------------------------------
4469 -- Establish_Transient_Scope --
4470 -------------------------------
4472 -- This procedure is called each time a transient block has to be inserted
4473 -- that is to say for each call to a function with unconstrained or tagged
4474 -- result. It creates a new scope on the scope stack in order to enclose
4475 -- all transient variables generated.
4477 procedure Establish_Transient_Scope
4479 Manage_Sec_Stack : Boolean)
4481 procedure Create_Transient_Scope (Constr : Node_Id);
4482 -- Place a new scope on the scope stack in order to service construct
4483 -- Constr. The new scope may also manage the secondary stack.
4485 procedure Delegate_Sec_Stack_Management;
4486 -- Move the management of the secondary stack to the nearest enclosing
4489 function Find_Enclosing_Transient_Scope return Entity_Id;
4490 -- Examine the scope stack looking for the nearest enclosing transient
4491 -- scope. Return Empty if no such scope exists.
4493 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean;
4494 -- Determine whether arbitrary Id denotes a package or subprogram [body]
4496 ----------------------------
4497 -- Create_Transient_Scope --
4498 ----------------------------
4500 procedure Create_Transient_Scope (Constr : Node_Id) is
4501 Loc : constant Source_Ptr := Sloc (N);
4503 Iter_Loop : Entity_Id;
4504 Trans_Scop : Entity_Id;
4507 Trans_Scop := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
4508 Set_Etype (Trans_Scop, Standard_Void_Type);
4510 Push_Scope (Trans_Scop);
4511 Set_Node_To_Be_Wrapped (Constr);
4512 Set_Scope_Is_Transient;
4514 -- The transient scope must also manage the secondary stack
4516 if Manage_Sec_Stack then
4517 Set_Uses_Sec_Stack (Trans_Scop);
4518 Check_Restriction (No_Secondary_Stack, N);
4520 -- The expansion of iterator loops generates references to objects
4521 -- in order to extract elements from a container:
4523 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4524 -- Obj : <object type> renames Ref.all.Element.all;
4526 -- These references are controlled and returned on the secondary
4527 -- stack. A new reference is created at each iteration of the loop
4528 -- and as a result it must be finalized and the space occupied by
4529 -- it on the secondary stack reclaimed at the end of the current
4532 -- When the context that requires a transient scope is a call to
4533 -- routine Reference, the node to be wrapped is the source object:
4535 -- for Obj of Container loop
4537 -- Routine Wrap_Transient_Declaration however does not generate
4538 -- a physical block as wrapping a declaration will kill it too
4539 -- early. To handle this peculiar case, mark the related iterator
4540 -- loop as requiring the secondary stack. This signals the
4541 -- finalization machinery to manage the secondary stack (see
4542 -- routine Process_Statements_For_Controlled_Objects).
4544 Iter_Loop := Find_Enclosing_Iterator_Loop (Trans_Scop);
4546 if Present (Iter_Loop) then
4547 Set_Uses_Sec_Stack (Iter_Loop);
4551 if Debug_Flag_W then
4552 Write_Str (" <Transient>");
4555 end Create_Transient_Scope;
4557 -----------------------------------
4558 -- Delegate_Sec_Stack_Management --
4559 -----------------------------------
4561 procedure Delegate_Sec_Stack_Management is
4562 Scop_Id : Entity_Id;
4563 Scop_Rec : Scope_Stack_Entry;
4566 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
4567 Scop_Rec := Scope_Stack.Table (Index);
4568 Scop_Id := Scop_Rec.Entity;
4570 -- Prevent the search from going too far or within the scope space
4573 if Scop_Id = Standard_Standard then
4576 -- No transient scope should be encountered during the traversal
4577 -- because Establish_Transient_Scope should have already handled
4580 elsif Scop_Rec.Is_Transient then
4581 pragma Assert (False);
4584 -- The construct which requires secondary stack management is
4585 -- always enclosed by a package or subprogram scope.
4587 elsif Is_Package_Or_Subprogram (Scop_Id) then
4588 Set_Uses_Sec_Stack (Scop_Id);
4589 Check_Restriction (No_Secondary_Stack, N);
4595 -- At this point no suitable scope was found. This should never occur
4596 -- because a construct is always enclosed by a compilation unit which
4599 pragma Assert (False);
4600 end Delegate_Sec_Stack_Management;
4602 ------------------------------------
4603 -- Find_Enclosing_Transient_Scope --
4604 ------------------------------------
4606 function Find_Enclosing_Transient_Scope return Entity_Id is
4607 Scop_Id : Entity_Id;
4608 Scop_Rec : Scope_Stack_Entry;
4611 for Index in reverse Scope_Stack.First .. Scope_Stack.Last loop
4612 Scop_Rec := Scope_Stack.Table (Index);
4613 Scop_Id := Scop_Rec.Entity;
4615 -- Prevent the search from going too far or within the scope space
4618 if Scop_Id = Standard_Standard
4619 or else Is_Package_Or_Subprogram (Scop_Id)
4623 elsif Scop_Rec.Is_Transient then
4629 end Find_Enclosing_Transient_Scope;
4631 ------------------------------
4632 -- Is_Package_Or_Subprogram --
4633 ------------------------------
4635 function Is_Package_Or_Subprogram (Id : Entity_Id) return Boolean is
4637 return Ekind_In (Id, E_Entry,
4643 end Is_Package_Or_Subprogram;
4647 Trans_Id : constant Entity_Id := Find_Enclosing_Transient_Scope;
4650 -- Start of processing for Establish_Transient_Scope
4653 -- Do not create a new transient scope if there is an existing transient
4654 -- scope on the stack.
4656 if Present (Trans_Id) then
4658 -- If the transient scope was requested for purposes of managing the
4659 -- secondary stack, then the existing scope must perform this task.
4661 if Manage_Sec_Stack then
4662 Set_Uses_Sec_Stack (Trans_Id);
4668 -- At this point it is known that the scope stack is free of transient
4669 -- scopes. Locate the proper construct which must be serviced by a new
4672 Context := Find_Transient_Context (N);
4674 if Present (Context) then
4675 if Nkind (Context) = N_Assignment_Statement then
4677 -- An assignment statement with suppressed controlled semantics
4678 -- does not need a transient scope because finalization is not
4679 -- desirable at this point. Note that No_Ctrl_Actions is also
4680 -- set for non-controlled assignments to suppress dispatching
4683 if No_Ctrl_Actions (Context)
4684 and then Needs_Finalization (Etype (Name (Context)))
4686 -- When a controlled component is initialized by a function
4687 -- call, the result on the secondary stack is always assigned
4688 -- to the component. Signal the nearest suitable scope that it
4689 -- is safe to manage the secondary stack.
4691 if Manage_Sec_Stack and then Within_Init_Proc then
4692 Delegate_Sec_Stack_Management;
4695 -- Otherwise the assignment is a normal transient context and thus
4696 -- requires a transient scope.
4699 Create_Transient_Scope (Context);
4705 Create_Transient_Scope (Context);
4708 end Establish_Transient_Scope;
4710 ----------------------------
4711 -- Expand_Cleanup_Actions --
4712 ----------------------------
4714 procedure Expand_Cleanup_Actions (N : Node_Id) is
4715 pragma Assert (Nkind_In (N, N_Block_Statement,
4717 N_Extended_Return_Statement,
4721 Scop : constant Entity_Id := Current_Scope;
4723 Is_Asynchronous_Call : constant Boolean :=
4724 Nkind (N) = N_Block_Statement
4725 and then Is_Asynchronous_Call_Block (N);
4726 Is_Master : constant Boolean :=
4727 Nkind (N) /= N_Extended_Return_Statement
4728 and then Nkind (N) /= N_Entry_Body
4729 and then Is_Task_Master (N);
4730 Is_Protected_Subp_Body : constant Boolean :=
4731 Nkind (N) = N_Subprogram_Body
4732 and then Is_Protected_Subprogram_Body (N);
4733 Is_Task_Allocation : constant Boolean :=
4734 Nkind (N) = N_Block_Statement
4735 and then Is_Task_Allocation_Block (N);
4736 Is_Task_Body : constant Boolean :=
4737 Nkind (Original_Node (N)) = N_Task_Body;
4739 -- We mark the secondary stack if it is used in this construct, and
4740 -- we're not returning a function result on the secondary stack, except
4741 -- that a build-in-place function that might or might not return on the
4742 -- secondary stack always needs a mark. A run-time test is required in
4743 -- the case where the build-in-place function has a BIP_Alloc extra
4744 -- parameter (see Create_Finalizer).
4746 Needs_Sec_Stack_Mark : constant Boolean :=
4747 (Uses_Sec_Stack (Scop)
4749 not Sec_Stack_Needed_For_Return (Scop))
4751 (Is_Build_In_Place_Function (Scop)
4752 and then Needs_BIP_Alloc_Form (Scop));
4754 Needs_Custom_Cleanup : constant Boolean :=
4755 Nkind (N) = N_Block_Statement
4756 and then Present (Cleanup_Actions (N));
4758 Actions_Required : constant Boolean :=
4759 Requires_Cleanup_Actions (N, True)
4760 or else Is_Asynchronous_Call
4762 or else Is_Protected_Subp_Body
4763 or else Is_Task_Allocation
4764 or else Is_Task_Body
4765 or else Needs_Sec_Stack_Mark
4766 or else Needs_Custom_Cleanup;
4768 HSS : Node_Id := Handled_Statement_Sequence (N);
4772 procedure Wrap_HSS_In_Block;
4773 -- Move HSS inside a new block along with the original exception
4774 -- handlers. Make the newly generated block the sole statement of HSS.
4776 -----------------------
4777 -- Wrap_HSS_In_Block --
4778 -----------------------
4780 procedure Wrap_HSS_In_Block is
4782 Block_Id : Entity_Id;
4786 -- Preserve end label to provide proper cross-reference information
4788 End_Lab := End_Label (HSS);
4790 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
4792 Block_Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
4793 Set_Identifier (Block, New_Occurrence_Of (Block_Id, Loc));
4794 Set_Etype (Block_Id, Standard_Void_Type);
4795 Set_Block_Node (Block_Id, Identifier (Block));
4797 -- Signal the finalization machinery that this particular block
4798 -- contains the original context.
4800 Set_Is_Finalization_Wrapper (Block);
4802 Set_Handled_Statement_Sequence (N,
4803 Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
4804 HSS := Handled_Statement_Sequence (N);
4806 Set_First_Real_Statement (HSS, Block);
4807 Set_End_Label (HSS, End_Lab);
4809 -- Comment needed here, see RH for 1.306 ???
4811 if Nkind (N) = N_Subprogram_Body then
4812 Set_Has_Nested_Block_With_Handler (Scop);
4814 end Wrap_HSS_In_Block;
4816 -- Start of processing for Expand_Cleanup_Actions
4819 -- The current construct does not need any form of servicing
4821 if not Actions_Required then
4824 -- If the current node is a rewritten task body and the descriptors have
4825 -- not been delayed (due to some nested instantiations), do not generate
4826 -- redundant cleanup actions.
4829 and then Nkind (N) = N_Subprogram_Body
4830 and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
4835 -- If an extended return statement contains something like
4839 -- where F is a build-in-place function call returning a controlled
4840 -- type, then a temporary object will be implicitly declared as part
4841 -- of the statement list, and this will need cleanup. In such cases,
4844 -- return Result : T := ... do
4845 -- <statements> -- possibly with handlers
4850 -- return Result : T := ... do
4851 -- declare -- no declarations
4853 -- <statements> -- possibly with handlers
4854 -- end; -- no handlers
4857 -- So Expand_Cleanup_Actions will end up being called recursively on the
4860 if Nkind (N) = N_Extended_Return_Statement then
4862 Block : constant Node_Id :=
4863 Make_Block_Statement (Sloc (N),
4864 Declarations => Empty_List,
4865 Handled_Statement_Sequence =>
4866 Handled_Statement_Sequence (N));
4868 Set_Handled_Statement_Sequence (N,
4869 Make_Handled_Sequence_Of_Statements (Sloc (N),
4870 Statements => New_List (Block)));
4875 -- Analysis of the block did all the work
4880 if Needs_Custom_Cleanup then
4881 Cln := Cleanup_Actions (N);
4887 Decls : List_Id := Declarations (N);
4889 Mark : Entity_Id := Empty;
4890 New_Decls : List_Id;
4894 -- If we are generating expanded code for debugging purposes, use the
4895 -- Sloc of the point of insertion for the cleanup code. The Sloc will
4896 -- be updated subsequently to reference the proper line in .dg files.
4897 -- If we are not debugging generated code, use No_Location instead,
4898 -- so that no debug information is generated for the cleanup code.
4899 -- This makes the behavior of the NEXT command in GDB monotonic, and
4900 -- makes the placement of breakpoints more accurate.
4902 if Debug_Generated_Code then
4908 -- Set polling off. The finalization and cleanup code is executed
4909 -- with aborts deferred.
4911 Old_Poll := Polling_Required;
4912 Polling_Required := False;
4914 -- A task activation call has already been built for a task
4915 -- allocation block.
4917 if not Is_Task_Allocation then
4918 Build_Task_Activation_Call (N);
4922 Establish_Task_Master (N);
4925 New_Decls := New_List;
4927 -- If secondary stack is in use, generate:
4929 -- Mnn : constant Mark_Id := SS_Mark;
4931 if Needs_Sec_Stack_Mark then
4932 Mark := Make_Temporary (Loc, 'M');
4934 Append_To (New_Decls, Build_SS_Mark_Call (Loc, Mark));
4935 Set_Uses_Sec_Stack (Scop, False);
4938 -- If exception handlers are present, wrap the sequence of statements
4939 -- in a block since it is not possible to have exception handlers and
4940 -- an At_End handler in the same construct.
4942 if Present (Exception_Handlers (HSS)) then
4945 -- Ensure that the First_Real_Statement field is set
4947 elsif No (First_Real_Statement (HSS)) then
4948 Set_First_Real_Statement (HSS, First (Statements (HSS)));
4951 -- Do not move the Activation_Chain declaration in the context of
4952 -- task allocation blocks. Task allocation blocks use _chain in their
4953 -- cleanup handlers and gigi complains if it is declared in the
4954 -- sequence of statements of the scope that declares the handler.
4956 if Is_Task_Allocation then
4958 Chain : constant Entity_Id := Activation_Chain_Entity (N);
4962 Decl := First (Decls);
4963 while Nkind (Decl) /= N_Object_Declaration
4964 or else Defining_Identifier (Decl) /= Chain
4968 -- A task allocation block should always include a _chain
4971 pragma Assert (Present (Decl));
4975 Prepend_To (New_Decls, Decl);
4979 -- Ensure the presence of a declaration list in order to successfully
4980 -- append all original statements to it.
4983 Set_Declarations (N, New_List);
4984 Decls := Declarations (N);
4987 -- Move the declarations into the sequence of statements in order to
4988 -- have them protected by the At_End handler. It may seem weird to
4989 -- put declarations in the sequence of statement but in fact nothing
4990 -- forbids that at the tree level.
4992 Append_List_To (Decls, Statements (HSS));
4993 Set_Statements (HSS, Decls);
4995 -- Reset the Sloc of the handled statement sequence to properly
4996 -- reflect the new initial "statement" in the sequence.
4998 Set_Sloc (HSS, Sloc (First (Decls)));
5000 -- The declarations of finalizer spec and auxiliary variables replace
5001 -- the old declarations that have been moved inward.
5003 Set_Declarations (N, New_Decls);
5004 Analyze_Declarations (New_Decls);
5006 -- Generate finalization calls for all controlled objects appearing
5007 -- in the statements of N. Add context specific cleanup for various
5012 Clean_Stmts => Build_Cleanup_Statements (N, Cln),
5014 Top_Decls => New_Decls,
5015 Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body
5019 if Present (Fin_Id) then
5020 Build_Finalizer_Call (N, Fin_Id);
5023 -- Restore saved polling mode
5025 Polling_Required := Old_Poll;
5027 end Expand_Cleanup_Actions;
5029 ---------------------------
5030 -- Expand_N_Package_Body --
5031 ---------------------------
5033 -- Add call to Activate_Tasks if body is an activator (actual processing
5034 -- is in chapter 9).
5036 -- Generate subprogram descriptor for elaboration routine
5038 -- Encode entity names in package body
5040 procedure Expand_N_Package_Body (N : Node_Id) is
5041 Spec_Id : constant Entity_Id := Corresponding_Spec (N);
5045 -- This is done only for non-generic packages
5047 if Ekind (Spec_Id) = E_Package then
5048 Push_Scope (Spec_Id);
5050 -- Build dispatch tables of library level tagged types
5052 if Tagged_Type_Expansion
5053 and then Is_Library_Level_Entity (Spec_Id)
5055 Build_Static_Dispatch_Tables (N);
5058 Build_Task_Activation_Call (N);
5060 -- Verify the run-time semantics of pragma Initial_Condition at the
5061 -- end of the body statements.
5063 Expand_Pragma_Initial_Condition (Spec_Id, N);
5065 -- If this is a library-level package and unnesting is enabled,
5066 -- check for the presence of blocks with nested subprograms occurring
5067 -- in elaboration code, and generate procedures to encapsulate the
5068 -- blocks in case the nested subprograms make up-level references.
5070 if Unnest_Subprogram_Mode
5072 Is_Library_Level_Entity (Current_Scope)
5074 Check_Unnesting_Elaboration_Code (N);
5075 Check_Unnesting_In_Decls_Or_Stmts (Declarations (N));
5076 Check_Unnesting_In_Handlers (N);
5082 Set_Elaboration_Flag (N, Spec_Id);
5083 Set_In_Package_Body (Spec_Id, False);
5085 -- Set to encode entity names in package body before gigi is called
5087 Qualify_Entity_Names (N);
5089 if Ekind (Spec_Id) /= E_Generic_Package then
5092 Clean_Stmts => No_List,
5094 Top_Decls => No_List,
5095 Defer_Abort => False,
5098 if Present (Fin_Id) then
5100 Body_Ent : Node_Id := Defining_Unit_Name (N);
5103 if Nkind (Body_Ent) = N_Defining_Program_Unit_Name then
5104 Body_Ent := Defining_Identifier (Body_Ent);
5107 Set_Finalizer (Body_Ent, Fin_Id);
5111 end Expand_N_Package_Body;
5113 ----------------------------------
5114 -- Expand_N_Package_Declaration --
5115 ----------------------------------
5117 -- Add call to Activate_Tasks if there are tasks declared and the package
5118 -- has no body. Note that in Ada 83 this may result in premature activation
5119 -- of some tasks, given that we cannot tell whether a body will eventually
5122 procedure Expand_N_Package_Declaration (N : Node_Id) is
5123 Id : constant Entity_Id := Defining_Entity (N);
5124 Spec : constant Node_Id := Specification (N);
5128 No_Body : Boolean := False;
5129 -- True in the case of a package declaration that is a compilation
5130 -- unit and for which no associated body will be compiled in this
5134 -- Case of a package declaration other than a compilation unit
5136 if Nkind (Parent (N)) /= N_Compilation_Unit then
5139 -- Case of a compilation unit that does not require a body
5141 elsif not Body_Required (Parent (N))
5142 and then not Unit_Requires_Body (Id)
5146 -- Special case of generating calling stubs for a remote call interface
5147 -- package: even though the package declaration requires one, the body
5148 -- won't be processed in this compilation (so any stubs for RACWs
5149 -- declared in the package must be generated here, along with the spec).
5151 elsif Parent (N) = Cunit (Main_Unit)
5152 and then Is_Remote_Call_Interface (Id)
5153 and then Distribution_Stub_Mode = Generate_Caller_Stub_Body
5158 -- For a nested instance, delay processing until freeze point
5160 if Has_Delayed_Freeze (Id)
5161 and then Nkind (Parent (N)) /= N_Compilation_Unit
5166 -- For a package declaration that implies no associated body, generate
5167 -- task activation call and RACW supporting bodies now (since we won't
5168 -- have a specific separate compilation unit for that).
5173 -- Generate RACW subprogram bodies
5175 if Has_RACW (Id) then
5176 Decls := Private_Declarations (Spec);
5179 Decls := Visible_Declarations (Spec);
5184 Set_Visible_Declarations (Spec, Decls);
5187 Append_RACW_Bodies (Decls, Id);
5188 Analyze_List (Decls);
5191 -- Generate task activation call as last step of elaboration
5193 if Present (Activation_Chain_Entity (N)) then
5194 Build_Task_Activation_Call (N);
5197 -- Verify the run-time semantics of pragma Initial_Condition at the
5198 -- end of the private declarations when the package lacks a body.
5200 Expand_Pragma_Initial_Condition (Id, N);
5205 -- Build dispatch tables of library level tagged types
5207 if Tagged_Type_Expansion
5208 and then (Is_Compilation_Unit (Id)
5209 or else (Is_Generic_Instance (Id)
5210 and then Is_Library_Level_Entity (Id)))
5212 Build_Static_Dispatch_Tables (N);
5215 -- Note: it is not necessary to worry about generating a subprogram
5216 -- descriptor, since the only way to get exception handlers into a
5217 -- package spec is to include instantiations, and that would cause
5218 -- generation of subprogram descriptors to be delayed in any case.
5220 -- Set to encode entity names in package spec before gigi is called
5222 Qualify_Entity_Names (N);
5224 if Ekind (Id) /= E_Generic_Package then
5227 Clean_Stmts => No_List,
5229 Top_Decls => No_List,
5230 Defer_Abort => False,
5233 Set_Finalizer (Id, Fin_Id);
5236 -- If this is a library-level package and unnesting is enabled,
5237 -- check for the presence of blocks with nested subprograms occurring
5238 -- in elaboration code, and generate procedures to encapsulate the
5239 -- blocks in case the nested subprograms make up-level references.
5241 if Unnest_Subprogram_Mode
5242 and then Is_Library_Level_Entity (Current_Scope)
5244 Check_Unnesting_In_Decls_Or_Stmts (Visible_Declarations (Spec));
5245 Check_Unnesting_In_Decls_Or_Stmts (Private_Declarations (Spec));
5247 end Expand_N_Package_Declaration;
5249 ----------------------------
5250 -- Find_Transient_Context --
5251 ----------------------------
5253 function Find_Transient_Context (N : Node_Id) return Node_Id is
5260 while Present (Curr) loop
5261 case Nkind (Curr) is
5265 -- Declarations act as a boundary for a transient scope even if
5266 -- they are not wrapped, see Wrap_Transient_Declaration.
5268 when N_Object_Declaration
5269 | N_Object_Renaming_Declaration
5270 | N_Subtype_Declaration
5276 -- Statements and statement-like constructs act as a boundary for
5277 -- a transient scope.
5279 when N_Accept_Alternative
5280 | N_Attribute_Definition_Clause
5282 | N_Case_Statement_Alternative
5284 | N_Delay_Alternative
5285 | N_Delay_Until_Statement
5286 | N_Delay_Relative_Statement
5287 | N_Discriminant_Association
5289 | N_Entry_Body_Formal_Part
5292 | N_Iteration_Scheme
5293 | N_Terminate_Alternative
5295 pragma Assert (Present (Prev));
5298 when N_Assignment_Statement =>
5301 when N_Entry_Call_Statement
5302 | N_Procedure_Call_Statement
5304 -- When an entry or procedure call acts as the alternative of a
5305 -- conditional or timed entry call, the proper context is that
5306 -- of the alternative.
5308 if Nkind (Parent (Curr)) = N_Entry_Call_Alternative
5309 and then Nkind_In (Parent (Parent (Curr)),
5310 N_Conditional_Entry_Call,
5313 return Parent (Parent (Curr));
5315 -- General case for entry or procedure calls
5323 -- Pragma Check is not a valid transient context in GNATprove
5324 -- mode because the pragma must remain unchanged.
5327 and then Get_Pragma_Id (Curr) = Pragma_Check
5331 -- General case for pragmas
5337 when N_Raise_Statement =>
5340 when N_Simple_Return_Statement =>
5342 -- A return statement is not a valid transient context when the
5343 -- function itself requires transient scope management because
5344 -- the result will be reclaimed too early.
5346 if Requires_Transient_Scope (Etype
5347 (Return_Applies_To (Return_Statement_Entity (Curr))))
5351 -- General case for return statements
5359 when N_Attribute_Reference =>
5360 if Is_Procedure_Attribute_Name (Attribute_Name (Curr)) then
5364 -- An Ada 2012 iterator specification is not a valid context
5365 -- because Analyze_Iterator_Specification already employs special
5366 -- processing for it.
5368 when N_Iterator_Specification =>
5371 when N_Loop_Parameter_Specification =>
5373 -- An iteration scheme is not a valid context because routine
5374 -- Analyze_Iteration_Scheme already employs special processing.
5376 if Nkind (Parent (Curr)) = N_Iteration_Scheme then
5379 return Parent (Curr);
5384 -- The following nodes represent "dummy contexts" which do not
5385 -- need to be wrapped.
5387 when N_Component_Declaration
5388 | N_Discriminant_Specification
5389 | N_Parameter_Specification
5393 -- If the traversal leaves a scope without having been able to
5394 -- find a construct to wrap, something is going wrong, but this
5395 -- can happen in error situations that are not detected yet (such
5396 -- as a dynamic string in a pragma Export).
5398 when N_Block_Statement
5401 | N_Package_Declaration
5415 Curr := Parent (Curr);
5419 end Find_Transient_Context;
5421 ----------------------------------
5422 -- Has_New_Controlled_Component --
5423 ----------------------------------
5425 function Has_New_Controlled_Component (E : Entity_Id) return Boolean is
5429 if not Is_Tagged_Type (E) then
5430 return Has_Controlled_Component (E);
5431 elsif not Is_Derived_Type (E) then
5432 return Has_Controlled_Component (E);
5435 Comp := First_Component (E);
5436 while Present (Comp) loop
5437 if Chars (Comp) = Name_uParent then
5440 elsif Scope (Original_Record_Component (Comp)) = E
5441 and then Needs_Finalization (Etype (Comp))
5446 Next_Component (Comp);
5450 end Has_New_Controlled_Component;
5452 ---------------------------------
5453 -- Has_Simple_Protected_Object --
5454 ---------------------------------
5456 function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
5458 if Has_Task (T) then
5461 elsif Is_Simple_Protected_Type (T) then
5464 elsif Is_Array_Type (T) then
5465 return Has_Simple_Protected_Object (Component_Type (T));
5467 elsif Is_Record_Type (T) then
5472 Comp := First_Component (T);
5473 while Present (Comp) loop
5474 if Has_Simple_Protected_Object (Etype (Comp)) then
5478 Next_Component (Comp);
5487 end Has_Simple_Protected_Object;
5489 ------------------------------------
5490 -- Insert_Actions_In_Scope_Around --
5491 ------------------------------------
5493 procedure Insert_Actions_In_Scope_Around
5496 Manage_SS : Boolean)
5498 Act_Before : constant List_Id :=
5499 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before);
5500 Act_After : constant List_Id :=
5501 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After);
5502 Act_Cleanup : constant List_Id :=
5503 Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup);
5504 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
5505 -- Last), but this was incorrect as Process_Transients_In_Scope may
5506 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
5508 procedure Process_Transients_In_Scope
5509 (First_Object : Node_Id;
5510 Last_Object : Node_Id;
5511 Related_Node : Node_Id);
5512 -- Find all transient objects in the list First_Object .. Last_Object
5513 -- and generate finalization actions for them. Related_Node denotes the
5514 -- node which created all transient objects.
5516 ---------------------------------
5517 -- Process_Transients_In_Scope --
5518 ---------------------------------
5520 procedure Process_Transients_In_Scope
5521 (First_Object : Node_Id;
5522 Last_Object : Node_Id;
5523 Related_Node : Node_Id)
5525 Must_Hook : Boolean := False;
5526 -- Flag denoting whether the context requires transient object
5527 -- export to the outer finalizer.
5529 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
5530 -- Determine whether an arbitrary node denotes a subprogram call
5532 procedure Detect_Subprogram_Call is
5533 new Traverse_Proc (Is_Subprogram_Call);
5535 procedure Process_Transient_In_Scope
5536 (Obj_Decl : Node_Id;
5537 Blk_Data : Finalization_Exception_Data;
5538 Blk_Stmts : List_Id);
5539 -- Generate finalization actions for a single transient object
5540 -- denoted by object declaration Obj_Decl. Blk_Data is the
5541 -- exception data of the enclosing block. Blk_Stmts denotes the
5542 -- statements of the enclosing block.
5544 ------------------------
5545 -- Is_Subprogram_Call --
5546 ------------------------
5548 function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
5550 -- A regular procedure or function call
5552 if Nkind (N) in N_Subprogram_Call then
5558 -- Heavy expansion may relocate function calls outside the related
5559 -- node. Inspect the original node to detect the initial placement
5562 elsif Is_Rewrite_Substitution (N) then
5563 Detect_Subprogram_Call (Original_Node (N));
5571 -- Generalized indexing always involves a function call
5573 elsif Nkind (N) = N_Indexed_Component
5574 and then Present (Generalized_Indexing (N))
5584 end Is_Subprogram_Call;
5586 --------------------------------
5587 -- Process_Transient_In_Scope --
5588 --------------------------------
5590 procedure Process_Transient_In_Scope
5591 (Obj_Decl : Node_Id;
5592 Blk_Data : Finalization_Exception_Data;
5593 Blk_Stmts : List_Id)
5595 Loc : constant Source_Ptr := Sloc (Obj_Decl);
5596 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
5598 Fin_Stmts : List_Id;
5599 Hook_Assign : Node_Id;
5600 Hook_Clear : Node_Id;
5601 Hook_Decl : Node_Id;
5602 Hook_Insert : Node_Id;
5606 -- Mark the transient object as successfully processed to avoid
5607 -- double finalization.
5609 Set_Is_Finalized_Transient (Obj_Id);
5611 -- Construct all the pieces necessary to hook and finalize the
5612 -- transient object.
5614 Build_Transient_Object_Statements
5615 (Obj_Decl => Obj_Decl,
5616 Fin_Call => Fin_Call,
5617 Hook_Assign => Hook_Assign,
5618 Hook_Clear => Hook_Clear,
5619 Hook_Decl => Hook_Decl,
5620 Ptr_Decl => Ptr_Decl);
5622 -- The context contains at least one subprogram call which may
5623 -- raise an exception. This scenario employs "hooking" to pass
5624 -- transient objects to the enclosing finalizer in case of an
5629 -- Add the access type which provides a reference to the
5630 -- transient object. Generate:
5632 -- type Ptr_Typ is access all Desig_Typ;
5634 Insert_Action (Obj_Decl, Ptr_Decl);
5636 -- Add the temporary which acts as a hook to the transient
5637 -- object. Generate:
5639 -- Hook : Ptr_Typ := null;
5641 Insert_Action (Obj_Decl, Hook_Decl);
5643 -- When the transient object is initialized by an aggregate,
5644 -- the hook must capture the object after the last aggregate
5645 -- assignment takes place. Only then is the object considered
5646 -- fully initialized. Generate:
5648 -- Hook := Ptr_Typ (Obj_Id);
5650 -- Hook := Obj_Id'Unrestricted_Access;
5652 if Ekind_In (Obj_Id, E_Constant, E_Variable)
5653 and then Present (Last_Aggregate_Assignment (Obj_Id))
5655 Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
5657 -- Otherwise the hook seizes the related object immediately
5660 Hook_Insert := Obj_Decl;
5663 Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
5666 -- When exception propagation is enabled wrap the hook clear
5667 -- statement and the finalization call into a block to catch
5668 -- potential exceptions raised during finalization. Generate:
5672 -- [Deep_]Finalize (Obj_Ref);
5676 -- if not Raised then
5679 -- (Enn, Get_Current_Excep.all.all);
5683 if Exceptions_OK then
5684 Fin_Stmts := New_List;
5687 Append_To (Fin_Stmts, Hook_Clear);
5690 Append_To (Fin_Stmts, Fin_Call);
5692 Prepend_To (Blk_Stmts,
5693 Make_Block_Statement (Loc,
5694 Handled_Statement_Sequence =>
5695 Make_Handled_Sequence_Of_Statements (Loc,
5696 Statements => Fin_Stmts,
5697 Exception_Handlers => New_List (
5698 Build_Exception_Handler (Blk_Data)))));
5700 -- Otherwise generate:
5703 -- [Deep_]Finalize (Obj_Ref);
5705 -- Note that the statements are inserted in reverse order to
5706 -- achieve the desired final order outlined above.
5709 Prepend_To (Blk_Stmts, Fin_Call);
5712 Prepend_To (Blk_Stmts, Hook_Clear);
5715 end Process_Transient_In_Scope;
5719 Built : Boolean := False;
5720 Blk_Data : Finalization_Exception_Data;
5721 Blk_Decl : Node_Id := Empty;
5722 Blk_Decls : List_Id := No_List;
5724 Blk_Stmts : List_Id := No_List;
5725 Loc : Source_Ptr := No_Location;
5728 -- Start of processing for Process_Transients_In_Scope
5731 -- The expansion performed by this routine is as follows:
5733 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5734 -- Hook_1 : Ptr_Typ_1 := null;
5735 -- Ctrl_Trans_Obj_1 : ...;
5736 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5738 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5739 -- Hook_N : Ptr_Typ_N := null;
5740 -- Ctrl_Trans_Obj_N : ...;
5741 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5744 -- Abrt : constant Boolean := ...;
5745 -- Ex : Exception_Occurrence;
5746 -- Raised : Boolean := False;
5753 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5757 -- if not Raised then
5759 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5764 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5768 -- if not Raised then
5770 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5775 -- if Raised and not Abrt then
5776 -- Raise_From_Controlled_Operation (Ex);
5780 -- Recognize a scenario where the transient context is an object
5781 -- declaration initialized by a build-in-place function call:
5783 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5785 -- The rough expansion of the above is:
5787 -- Temp : ... := Ctrl_Func_Call;
5789 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5791 -- The finalization of any transient object must happen after the
5792 -- build-in-place function call is executed.
5794 if Nkind (N) = N_Object_Declaration
5795 and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
5798 Blk_Ins := BIP_Initialization_Call (Defining_Identifier (N));
5800 -- Search the context for at least one subprogram call. If found, the
5801 -- machinery exports all transient objects to the enclosing finalizer
5802 -- due to the possibility of abnormal call termination.
5805 Detect_Subprogram_Call (N);
5806 Blk_Ins := Last_Object;
5810 Insert_List_After_And_Analyze (Blk_Ins, Act_Cleanup);
5813 -- Examine all objects in the list First_Object .. Last_Object
5815 Obj_Decl := First_Object;
5816 while Present (Obj_Decl) loop
5817 if Nkind (Obj_Decl) = N_Object_Declaration
5818 and then Analyzed (Obj_Decl)
5819 and then Is_Finalizable_Transient (Obj_Decl, N)
5821 -- Do not process the node to be wrapped since it will be
5822 -- handled by the enclosing finalizer.
5824 and then Obj_Decl /= Related_Node
5826 Loc := Sloc (Obj_Decl);
5828 -- Before generating the cleanup code for the first transient
5829 -- object, create a wrapper block which houses all hook clear
5830 -- statements and finalization calls. This wrapper is needed by
5835 Blk_Stmts := New_List;
5838 -- Abrt : constant Boolean := ...;
5839 -- Ex : Exception_Occurrence;
5840 -- Raised : Boolean := False;
5842 if Exceptions_OK then
5843 Blk_Decls := New_List;
5844 Build_Object_Declarations (Blk_Data, Blk_Decls, Loc);
5848 Make_Block_Statement (Loc,
5849 Declarations => Blk_Decls,
5850 Handled_Statement_Sequence =>
5851 Make_Handled_Sequence_Of_Statements (Loc,
5852 Statements => Blk_Stmts));
5855 -- Construct all necessary circuitry to hook and finalize a
5856 -- single transient object.
5858 pragma Assert (Present (Blk_Stmts));
5859 Process_Transient_In_Scope
5860 (Obj_Decl => Obj_Decl,
5861 Blk_Data => Blk_Data,
5862 Blk_Stmts => Blk_Stmts);
5865 -- Terminate the scan after the last object has been processed to
5866 -- avoid touching unrelated code.
5868 if Obj_Decl = Last_Object then
5875 -- Complete the decoration of the enclosing finalization block and
5876 -- insert it into the tree.
5878 if Present (Blk_Decl) then
5880 pragma Assert (Present (Blk_Stmts));
5881 pragma Assert (Loc /= No_Location);
5883 -- Note that this Abort_Undefer does not require a extra block or
5884 -- an AT_END handler because each finalization exception is caught
5885 -- in its own corresponding finalization block. As a result, the
5886 -- call to Abort_Defer always takes place.
5888 if Abort_Allowed then
5889 Prepend_To (Blk_Stmts,
5890 Build_Runtime_Call (Loc, RE_Abort_Defer));
5892 Append_To (Blk_Stmts,
5893 Build_Runtime_Call (Loc, RE_Abort_Undefer));
5897 -- if Raised and then not Abrt then
5898 -- Raise_From_Controlled_Operation (Ex);
5901 if Exceptions_OK then
5902 Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data));
5905 Insert_After_And_Analyze (Blk_Ins, Blk_Decl);
5907 end Process_Transients_In_Scope;
5911 Loc : constant Source_Ptr := Sloc (N);
5912 Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped;
5913 First_Obj : Node_Id;
5915 Mark_Id : Entity_Id;
5918 -- Start of processing for Insert_Actions_In_Scope_Around
5921 -- Nothing to do if the scope does not manage the secondary stack or
5922 -- does not contain meaninful actions for insertion.
5925 and then No (Act_Before)
5926 and then No (Act_After)
5927 and then No (Act_Cleanup)
5932 -- If the node to be wrapped is the trigger of an asynchronous select,
5933 -- it is not part of a statement list. The actions must be inserted
5934 -- before the select itself, which is part of some list of statements.
5935 -- Note that the triggering alternative includes the triggering
5936 -- statement and an optional statement list. If the node to be
5937 -- wrapped is part of that list, the normal insertion applies.
5939 if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative
5940 and then not Is_List_Member (Node_To_Wrap)
5942 Target := Parent (Parent (Node_To_Wrap));
5947 First_Obj := Target;
5950 -- Add all actions associated with a transient scope into the main tree.
5951 -- There are several scenarios here:
5953 -- +--- Before ----+ +----- After ---+
5954 -- 1) First_Obj ....... Target ........ Last_Obj
5956 -- 2) First_Obj ....... Target
5958 -- 3) Target ........ Last_Obj
5960 -- Flag declarations are inserted before the first object
5962 if Present (Act_Before) then
5963 First_Obj := First (Act_Before);
5964 Insert_List_Before (Target, Act_Before);
5967 -- Finalization calls are inserted after the last object
5969 if Present (Act_After) then
5970 Last_Obj := Last (Act_After);
5971 Insert_List_After (Target, Act_After);
5974 -- Mark and release the secondary stack when the context warrants it
5977 Mark_Id := Make_Temporary (Loc, 'M');
5980 -- Mnn : constant Mark_Id := SS_Mark;
5982 Insert_Before_And_Analyze
5983 (First_Obj, Build_SS_Mark_Call (Loc, Mark_Id));
5986 -- SS_Release (Mnn);
5988 Insert_After_And_Analyze
5989 (Last_Obj, Build_SS_Release_Call (Loc, Mark_Id));
5992 -- Check for transient objects associated with Target and generate the
5993 -- appropriate finalization actions for them.
5995 Process_Transients_In_Scope
5996 (First_Object => First_Obj,
5997 Last_Object => Last_Obj,
5998 Related_Node => Target);
6000 -- Reset the action lists
6003 (Scope_Stack.Last).Actions_To_Be_Wrapped (Before) := No_List;
6005 (Scope_Stack.Last).Actions_To_Be_Wrapped (After) := No_List;
6009 (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup) := No_List;
6011 end Insert_Actions_In_Scope_Around;
6013 ------------------------------
6014 -- Is_Simple_Protected_Type --
6015 ------------------------------
6017 function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
6020 Is_Protected_Type (T)
6021 and then not Uses_Lock_Free (T)
6022 and then not Has_Entries (T)
6023 and then Is_RTE (Find_Protection_Type (T), RE_Protection);
6024 end Is_Simple_Protected_Type;
6026 -----------------------
6027 -- Make_Adjust_Call --
6028 -----------------------
6030 function Make_Adjust_Call
6033 Skip_Self : Boolean := False) return Node_Id
6035 Loc : constant Source_Ptr := Sloc (Obj_Ref);
6036 Adj_Id : Entity_Id := Empty;
6043 -- Recover the proper type which contains Deep_Adjust
6045 if Is_Class_Wide_Type (Typ) then
6046 Utyp := Root_Type (Typ);
6051 Utyp := Underlying_Type (Base_Type (Utyp));
6052 Set_Assignment_OK (Ref);
6054 -- Deal with untagged derivation of private views
6056 if Present (Utyp) and then Is_Untagged_Derivation (Typ) then
6057 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
6058 Ref := Unchecked_Convert_To (Utyp, Ref);
6059 Set_Assignment_OK (Ref);
6062 -- When dealing with the completion of a private type, use the base
6065 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
6066 pragma Assert (Is_Private_Type (Typ));
6068 Utyp := Base_Type (Utyp);
6069 Ref := Unchecked_Convert_To (Utyp, Ref);
6072 -- The underlying type may not be present due to a missing full view. In
6073 -- this case freezing did not take place and there is no [Deep_]Adjust
6074 -- primitive to call.
6079 elsif Skip_Self then
6080 if Has_Controlled_Component (Utyp) then
6081 if Is_Tagged_Type (Utyp) then
6082 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6084 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
6088 -- Class-wide types, interfaces and types with controlled components
6090 elsif Is_Class_Wide_Type (Typ)
6091 or else Is_Interface (Typ)
6092 or else Has_Controlled_Component (Utyp)
6094 if Is_Tagged_Type (Utyp) then
6095 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6097 Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
6100 -- Derivations from [Limited_]Controlled
6102 elsif Is_Controlled (Utyp) then
6103 if Has_Controlled_Component (Utyp) then
6104 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6106 Adj_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Adjust_Case));
6111 elsif Is_Tagged_Type (Utyp) then
6112 Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
6115 raise Program_Error;
6118 if Present (Adj_Id) then
6120 -- If the object is unanalyzed, set its expected type for use in
6121 -- Convert_View in case an additional conversion is needed.
6124 and then Nkind (Ref) /= N_Unchecked_Type_Conversion
6126 Set_Etype (Ref, Typ);
6129 -- The object reference may need another conversion depending on the
6130 -- type of the formal and that of the actual.
6132 if not Is_Class_Wide_Type (Typ) then
6133 Ref := Convert_View (Adj_Id, Ref);
6140 Skip_Self => Skip_Self);
6144 end Make_Adjust_Call;
6146 ----------------------
6147 -- Make_Detach_Call --
6148 ----------------------
6150 function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is
6151 Loc : constant Source_Ptr := Sloc (Obj_Ref);
6155 Make_Procedure_Call_Statement (Loc,
6157 New_Occurrence_Of (RTE (RE_Detach), Loc),
6158 Parameter_Associations => New_List (
6159 Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
6160 end Make_Detach_Call;
6168 Proc_Id : Entity_Id;
6170 Skip_Self : Boolean := False) return Node_Id
6172 Params : constant List_Id := New_List (Param);
6175 -- Do not apply the controlled action to the object itself by signaling
6176 -- the related routine to avoid self.
6179 Append_To (Params, New_Occurrence_Of (Standard_False, Loc));
6183 Make_Procedure_Call_Statement (Loc,
6184 Name => New_Occurrence_Of (Proc_Id, Loc),
6185 Parameter_Associations => Params);
6188 --------------------------
6189 -- Make_Deep_Array_Body --
6190 --------------------------
6192 function Make_Deep_Array_Body
6193 (Prim : Final_Primitives;
6194 Typ : Entity_Id) return List_Id
6196 function Build_Adjust_Or_Finalize_Statements
6197 (Typ : Entity_Id) return List_Id;
6198 -- Create the statements necessary to adjust or finalize an array of
6199 -- controlled elements. Generate:
6202 -- Abort : constant Boolean := Triggered_By_Abort;
6204 -- Abort : constant Boolean := False; -- no abort
6206 -- E : Exception_Occurrence;
6207 -- Raised : Boolean := False;
6210 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
6211 -- ^-- in the finalization case
6213 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
6215 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
6219 -- if not Raised then
6221 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6228 -- if Raised and then not Abort then
6229 -- Raise_From_Controlled_Operation (E);
6233 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id;
6234 -- Create the statements necessary to initialize an array of controlled
6235 -- elements. Include a mechanism to carry out partial finalization if an
6236 -- exception occurs. Generate:
6239 -- Counter : Integer := 0;
6242 -- for J1 in V'Range (1) loop
6244 -- for JN in V'Range (N) loop
6246 -- [Deep_]Initialize (V (J1, ..., JN));
6248 -- Counter := Counter + 1;
6253 -- Abort : constant Boolean := Triggered_By_Abort;
6255 -- Abort : constant Boolean := False; -- no abort
6256 -- E : Exception_Occurrence;
6257 -- Raised : Boolean := False;
6264 -- V'Length (N) - Counter;
6266 -- for F1 in reverse V'Range (1) loop
6268 -- for FN in reverse V'Range (N) loop
6269 -- if Counter > 0 then
6270 -- Counter := Counter - 1;
6273 -- [Deep_]Finalize (V (F1, ..., FN));
6277 -- if not Raised then
6279 -- Save_Occurrence (E,
6280 -- Get_Current_Excep.all.all);
6289 -- if Raised and then not Abort then
6290 -- Raise_From_Controlled_Operation (E);
6299 function New_References_To
6301 Loc : Source_Ptr) return List_Id;
6302 -- Given a list of defining identifiers, return a list of references to
6303 -- the original identifiers, in the same order as they appear.
6305 -----------------------------------------
6306 -- Build_Adjust_Or_Finalize_Statements --
6307 -----------------------------------------
6309 function Build_Adjust_Or_Finalize_Statements
6310 (Typ : Entity_Id) return List_Id
6312 Comp_Typ : constant Entity_Id := Component_Type (Typ);
6313 Index_List : constant List_Id := New_List;
6314 Loc : constant Source_Ptr := Sloc (Typ);
6315 Num_Dims : constant Int := Number_Dimensions (Typ);
6317 procedure Build_Indexes;
6318 -- Generate the indexes used in the dimension loops
6324 procedure Build_Indexes is
6326 -- Generate the following identifiers:
6327 -- Jnn - for initialization
6329 for Dim in 1 .. Num_Dims loop
6330 Append_To (Index_List,
6331 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
6337 Final_Decls : List_Id := No_List;
6338 Final_Data : Finalization_Exception_Data;
6342 Core_Loop : Node_Id;
6345 Loop_Id : Entity_Id;
6348 -- Start of processing for Build_Adjust_Or_Finalize_Statements
6351 Final_Decls := New_List;
6354 Build_Object_Declarations (Final_Data, Final_Decls, Loc);
6357 Make_Indexed_Component (Loc,
6358 Prefix => Make_Identifier (Loc, Name_V),
6359 Expressions => New_References_To (Index_List, Loc));
6360 Set_Etype (Comp_Ref, Comp_Typ);
6363 -- [Deep_]Adjust (V (J1, ..., JN))
6365 if Prim = Adjust_Case then
6366 Call := Make_Adjust_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6369 -- [Deep_]Finalize (V (J1, ..., JN))
6371 else pragma Assert (Prim = Finalize_Case);
6372 Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6375 if Present (Call) then
6377 -- Generate the block which houses the adjust or finalize call:
6380 -- <adjust or finalize call>
6384 -- if not Raised then
6386 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6390 if Exceptions_OK then
6392 Make_Block_Statement (Loc,
6393 Handled_Statement_Sequence =>
6394 Make_Handled_Sequence_Of_Statements (Loc,
6395 Statements => New_List (Call),
6396 Exception_Handlers => New_List (
6397 Build_Exception_Handler (Final_Data))));
6402 -- Generate the dimension loops starting from the innermost one
6404 -- for Jnn in [reverse] V'Range (Dim) loop
6408 J := Last (Index_List);
6410 while Present (J) and then Dim > 0 loop
6416 Make_Loop_Statement (Loc,
6418 Make_Iteration_Scheme (Loc,
6419 Loop_Parameter_Specification =>
6420 Make_Loop_Parameter_Specification (Loc,
6421 Defining_Identifier => Loop_Id,
6422 Discrete_Subtype_Definition =>
6423 Make_Attribute_Reference (Loc,
6424 Prefix => Make_Identifier (Loc, Name_V),
6425 Attribute_Name => Name_Range,
6426 Expressions => New_List (
6427 Make_Integer_Literal (Loc, Dim))),
6430 Prim = Finalize_Case)),
6432 Statements => New_List (Core_Loop),
6433 End_Label => Empty);
6438 -- Generate the block which contains the core loop, declarations
6439 -- of the abort flag, the exception occurrence, the raised flag
6440 -- and the conditional raise:
6443 -- Abort : constant Boolean := Triggered_By_Abort;
6445 -- Abort : constant Boolean := False; -- no abort
6447 -- E : Exception_Occurrence;
6448 -- Raised : Boolean := False;
6453 -- if Raised and then not Abort then
6454 -- Raise_From_Controlled_Operation (E);
6458 Stmts := New_List (Core_Loop);
6460 if Exceptions_OK then
6461 Append_To (Stmts, Build_Raise_Statement (Final_Data));
6465 Make_Block_Statement (Loc,
6466 Declarations => Final_Decls,
6467 Handled_Statement_Sequence =>
6468 Make_Handled_Sequence_Of_Statements (Loc,
6469 Statements => Stmts));
6471 -- Otherwise previous errors or a missing full view may prevent the
6472 -- proper freezing of the component type. If this is the case, there
6473 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
6476 Block := Make_Null_Statement (Loc);
6479 return New_List (Block);
6480 end Build_Adjust_Or_Finalize_Statements;
6482 ---------------------------------
6483 -- Build_Initialize_Statements --
6484 ---------------------------------
6486 function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
6487 Comp_Typ : constant Entity_Id := Component_Type (Typ);
6488 Final_List : constant List_Id := New_List;
6489 Index_List : constant List_Id := New_List;
6490 Loc : constant Source_Ptr := Sloc (Typ);
6491 Num_Dims : constant Int := Number_Dimensions (Typ);
6493 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id;
6494 -- Generate the following assignment:
6495 -- Counter := V'Length (1) *
6497 -- V'Length (N) - Counter;
6499 -- Counter_Id denotes the entity of the counter.
6501 function Build_Finalization_Call return Node_Id;
6502 -- Generate a deep finalization call for an array element
6504 procedure Build_Indexes;
6505 -- Generate the initialization and finalization indexes used in the
6508 function Build_Initialization_Call return Node_Id;
6509 -- Generate a deep initialization call for an array element
6511 ----------------------
6512 -- Build_Assignment --
6513 ----------------------
6515 function Build_Assignment (Counter_Id : Entity_Id) return Node_Id is
6520 -- Start from the first dimension and generate:
6525 Make_Attribute_Reference (Loc,
6526 Prefix => Make_Identifier (Loc, Name_V),
6527 Attribute_Name => Name_Length,
6528 Expressions => New_List (Make_Integer_Literal (Loc, Dim)));
6530 -- Process the rest of the dimensions, generate:
6531 -- Expr * V'Length (N)
6534 while Dim <= Num_Dims loop
6536 Make_Op_Multiply (Loc,
6539 Make_Attribute_Reference (Loc,
6540 Prefix => Make_Identifier (Loc, Name_V),
6541 Attribute_Name => Name_Length,
6542 Expressions => New_List (
6543 Make_Integer_Literal (Loc, Dim))));
6549 -- Counter := Expr - Counter;
6552 Make_Assignment_Statement (Loc,
6553 Name => New_Occurrence_Of (Counter_Id, Loc),
6555 Make_Op_Subtract (Loc,
6557 Right_Opnd => New_Occurrence_Of (Counter_Id, Loc)));
6558 end Build_Assignment;
6560 -----------------------------
6561 -- Build_Finalization_Call --
6562 -----------------------------
6564 function Build_Finalization_Call return Node_Id is
6565 Comp_Ref : constant Node_Id :=
6566 Make_Indexed_Component (Loc,
6567 Prefix => Make_Identifier (Loc, Name_V),
6568 Expressions => New_References_To (Final_List, Loc));
6571 Set_Etype (Comp_Ref, Comp_Typ);
6574 -- [Deep_]Finalize (V);
6576 return Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6577 end Build_Finalization_Call;
6583 procedure Build_Indexes is
6585 -- Generate the following identifiers:
6586 -- Jnn - for initialization
6587 -- Fnn - for finalization
6589 for Dim in 1 .. Num_Dims loop
6590 Append_To (Index_List,
6591 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim)));
6593 Append_To (Final_List,
6594 Make_Defining_Identifier (Loc, New_External_Name ('F', Dim)));
6598 -------------------------------
6599 -- Build_Initialization_Call --
6600 -------------------------------
6602 function Build_Initialization_Call return Node_Id is
6603 Comp_Ref : constant Node_Id :=
6604 Make_Indexed_Component (Loc,
6605 Prefix => Make_Identifier (Loc, Name_V),
6606 Expressions => New_References_To (Index_List, Loc));
6609 Set_Etype (Comp_Ref, Comp_Typ);
6612 -- [Deep_]Initialize (V (J1, ..., JN));
6614 return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
6615 end Build_Initialization_Call;
6619 Counter_Id : Entity_Id;
6623 Final_Block : Node_Id;
6624 Final_Data : Finalization_Exception_Data;
6625 Final_Decls : List_Id := No_List;
6626 Final_Loop : Node_Id;
6627 Init_Block : Node_Id;
6628 Init_Call : Node_Id;
6629 Init_Loop : Node_Id;
6634 -- Start of processing for Build_Initialize_Statements
6637 Counter_Id := Make_Temporary (Loc, 'C');
6638 Final_Decls := New_List;
6641 Build_Object_Declarations (Final_Data, Final_Decls, Loc);
6643 -- Generate the block which houses the finalization call, the index
6644 -- guard and the handler which triggers Program_Error later on.
6646 -- if Counter > 0 then
6647 -- Counter := Counter - 1;
6650 -- [Deep_]Finalize (V (F1, ..., FN));
6653 -- if not Raised then
6655 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6660 Fin_Stmt := Build_Finalization_Call;
6662 if Present (Fin_Stmt) then
6663 if Exceptions_OK then
6665 Make_Block_Statement (Loc,
6666 Handled_Statement_Sequence =>
6667 Make_Handled_Sequence_Of_Statements (Loc,
6668 Statements => New_List (Fin_Stmt),
6669 Exception_Handlers => New_List (
6670 Build_Exception_Handler (Final_Data))));
6673 -- This is the core of the loop, the dimension iterators are added
6674 -- one by one in reverse.
6677 Make_If_Statement (Loc,
6680 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6681 Right_Opnd => Make_Integer_Literal (Loc, 0)),
6683 Then_Statements => New_List (
6684 Make_Assignment_Statement (Loc,
6685 Name => New_Occurrence_Of (Counter_Id, Loc),
6687 Make_Op_Subtract (Loc,
6688 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6689 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
6691 Else_Statements => New_List (Fin_Stmt));
6693 -- Generate all finalization loops starting from the innermost
6696 -- for Fnn in reverse V'Range (Dim) loop
6700 F := Last (Final_List);
6702 while Present (F) and then Dim > 0 loop
6708 Make_Loop_Statement (Loc,
6710 Make_Iteration_Scheme (Loc,
6711 Loop_Parameter_Specification =>
6712 Make_Loop_Parameter_Specification (Loc,
6713 Defining_Identifier => Loop_Id,
6714 Discrete_Subtype_Definition =>
6715 Make_Attribute_Reference (Loc,
6716 Prefix => Make_Identifier (Loc, Name_V),
6717 Attribute_Name => Name_Range,
6718 Expressions => New_List (
6719 Make_Integer_Literal (Loc, Dim))),
6721 Reverse_Present => True)),
6723 Statements => New_List (Final_Loop),
6724 End_Label => Empty);
6729 -- Generate the block which contains the finalization loops, the
6730 -- declarations of the abort flag, the exception occurrence, the
6731 -- raised flag and the conditional raise.
6734 -- Abort : constant Boolean := Triggered_By_Abort;
6736 -- Abort : constant Boolean := False; -- no abort
6738 -- E : Exception_Occurrence;
6739 -- Raised : Boolean := False;
6745 -- V'Length (N) - Counter;
6749 -- if Raised and then not Abort then
6750 -- Raise_From_Controlled_Operation (E);
6756 Stmts := New_List (Build_Assignment (Counter_Id), Final_Loop);
6758 if Exceptions_OK then
6759 Append_To (Stmts, Build_Raise_Statement (Final_Data));
6760 Append_To (Stmts, Make_Raise_Statement (Loc));
6764 Make_Block_Statement (Loc,
6765 Declarations => Final_Decls,
6766 Handled_Statement_Sequence =>
6767 Make_Handled_Sequence_Of_Statements (Loc,
6768 Statements => Stmts));
6770 -- Otherwise previous errors or a missing full view may prevent the
6771 -- proper freezing of the component type. If this is the case, there
6772 -- is no [Deep_]Finalize primitive to call.
6775 Final_Block := Make_Null_Statement (Loc);
6778 -- Generate the block which contains the initialization call and
6779 -- the partial finalization code.
6782 -- [Deep_]Initialize (V (J1, ..., JN));
6784 -- Counter := Counter + 1;
6788 -- <finalization code>
6791 Init_Call := Build_Initialization_Call;
6793 -- Only create finalization block if there is a non-trivial
6794 -- call to initialization.
6796 if Present (Init_Call)
6797 and then Nkind (Init_Call) /= N_Null_Statement
6800 Make_Block_Statement (Loc,
6801 Handled_Statement_Sequence =>
6802 Make_Handled_Sequence_Of_Statements (Loc,
6803 Statements => New_List (Init_Call),
6804 Exception_Handlers => New_List (
6805 Make_Exception_Handler (Loc,
6806 Exception_Choices => New_List (
6807 Make_Others_Choice (Loc)),
6808 Statements => New_List (Final_Block)))));
6810 Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
6811 Make_Assignment_Statement (Loc,
6812 Name => New_Occurrence_Of (Counter_Id, Loc),
6815 Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
6816 Right_Opnd => Make_Integer_Literal (Loc, 1))));
6818 -- Generate all initialization loops starting from the innermost
6821 -- for Jnn in V'Range (Dim) loop
6825 J := Last (Index_List);
6827 while Present (J) and then Dim > 0 loop
6833 Make_Loop_Statement (Loc,
6835 Make_Iteration_Scheme (Loc,
6836 Loop_Parameter_Specification =>
6837 Make_Loop_Parameter_Specification (Loc,
6838 Defining_Identifier => Loop_Id,
6839 Discrete_Subtype_Definition =>
6840 Make_Attribute_Reference (Loc,
6841 Prefix => Make_Identifier (Loc, Name_V),
6842 Attribute_Name => Name_Range,
6843 Expressions => New_List (
6844 Make_Integer_Literal (Loc, Dim))))),
6846 Statements => New_List (Init_Loop),
6847 End_Label => Empty);
6852 -- Generate the block which contains the counter variable and the
6853 -- initialization loops.
6856 -- Counter : Integer := 0;
6862 Make_Block_Statement (Loc,
6863 Declarations => New_List (
6864 Make_Object_Declaration (Loc,
6865 Defining_Identifier => Counter_Id,
6866 Object_Definition =>
6867 New_Occurrence_Of (Standard_Integer, Loc),
6868 Expression => Make_Integer_Literal (Loc, 0))),
6870 Handled_Statement_Sequence =>
6871 Make_Handled_Sequence_Of_Statements (Loc,
6872 Statements => New_List (Init_Loop)));
6874 -- Otherwise previous errors or a missing full view may prevent the
6875 -- proper freezing of the component type. If this is the case, there
6876 -- is no [Deep_]Initialize primitive to call.
6879 Init_Block := Make_Null_Statement (Loc);
6882 return New_List (Init_Block);
6883 end Build_Initialize_Statements;
6885 -----------------------
6886 -- New_References_To --
6887 -----------------------
6889 function New_References_To
6891 Loc : Source_Ptr) return List_Id
6893 Refs : constant List_Id := New_List;
6898 while Present (Id) loop
6899 Append_To (Refs, New_Occurrence_Of (Id, Loc));
6904 end New_References_To;
6906 -- Start of processing for Make_Deep_Array_Body
6910 when Address_Case =>
6911 return Make_Finalize_Address_Stmts (Typ);
6916 return Build_Adjust_Or_Finalize_Statements (Typ);
6918 when Initialize_Case =>
6919 return Build_Initialize_Statements (Typ);
6921 end Make_Deep_Array_Body;
6923 --------------------
6924 -- Make_Deep_Proc --
6925 --------------------
6927 function Make_Deep_Proc
6928 (Prim : Final_Primitives;
6930 Stmts : List_Id) return Entity_Id
6932 Loc : constant Source_Ptr := Sloc (Typ);
6934 Proc_Id : Entity_Id;
6937 -- Create the object formal, generate:
6938 -- V : System.Address
6940 if Prim = Address_Case then
6941 Formals := New_List (
6942 Make_Parameter_Specification (Loc,
6943 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
6945 New_Occurrence_Of (RTE (RE_Address), Loc)));
6952 Formals := New_List (
6953 Make_Parameter_Specification (Loc,
6954 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
6956 Out_Present => True,
6957 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
6959 -- F : Boolean := True
6961 if Prim = Adjust_Case
6962 or else Prim = Finalize_Case
6965 Make_Parameter_Specification (Loc,
6966 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
6968 New_Occurrence_Of (Standard_Boolean, Loc),
6970 New_Occurrence_Of (Standard_True, Loc)));
6975 Make_Defining_Identifier (Loc,
6976 Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
6979 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6982 -- exception -- Finalize and Adjust cases only
6983 -- raise Program_Error;
6984 -- end Deep_Initialize / Adjust / Finalize;
6988 -- procedure Finalize_Address (V : System.Address) is
6991 -- end Finalize_Address;
6994 Make_Subprogram_Body (Loc,
6996 Make_Procedure_Specification (Loc,
6997 Defining_Unit_Name => Proc_Id,
6998 Parameter_Specifications => Formals),
7000 Declarations => Empty_List,
7002 Handled_Statement_Sequence =>
7003 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
7005 -- If there are no calls to component initialization, indicate that
7006 -- the procedure is trivial, so prevent calls to it.
7008 if Is_Empty_List (Stmts)
7009 or else Nkind (First (Stmts)) = N_Null_Statement
7011 Set_Is_Trivial_Subprogram (Proc_Id);
7017 ---------------------------
7018 -- Make_Deep_Record_Body --
7019 ---------------------------
7021 function Make_Deep_Record_Body
7022 (Prim : Final_Primitives;
7024 Is_Local : Boolean := False) return List_Id
7026 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
7027 -- Build the statements necessary to adjust a record type. The type may
7028 -- have discriminants and contain variant parts. Generate:
7032 -- [Deep_]Adjust (V.Comp_1);
7034 -- when Id : others =>
7035 -- if not Raised then
7037 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7042 -- [Deep_]Adjust (V.Comp_N);
7044 -- when Id : others =>
7045 -- if not Raised then
7047 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7052 -- Deep_Adjust (V._parent, False); -- If applicable
7054 -- when Id : others =>
7055 -- if not Raised then
7057 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7063 -- Adjust (V); -- If applicable
7066 -- if not Raised then
7068 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7073 -- if Raised and then not Abort then
7074 -- Raise_From_Controlled_Operation (E);
7078 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
7079 -- Build the statements necessary to finalize a record type. The type
7080 -- may have discriminants and contain variant parts. Generate:
7083 -- Abort : constant Boolean := Triggered_By_Abort;
7085 -- Abort : constant Boolean := False; -- no abort
7086 -- E : Exception_Occurrence;
7087 -- Raised : Boolean := False;
7092 -- Finalize (V); -- If applicable
7095 -- if not Raised then
7097 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7102 -- case Variant_1 is
7104 -- case State_Counter_N => -- If Is_Local is enabled
7114 -- <<LN>> -- If Is_Local is enabled
7116 -- [Deep_]Finalize (V.Comp_N);
7119 -- if not Raised then
7121 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7127 -- [Deep_]Finalize (V.Comp_1);
7130 -- if not Raised then
7132 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7138 -- case State_Counter_1 => -- If Is_Local is enabled
7144 -- Deep_Finalize (V._parent, False); -- If applicable
7146 -- when Id : others =>
7147 -- if not Raised then
7149 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7153 -- if Raised and then not Abort then
7154 -- Raise_From_Controlled_Operation (E);
7158 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id;
7159 -- Given a derived tagged type Typ, traverse all components, find field
7160 -- _parent and return its type.
7162 procedure Preprocess_Components
7164 Num_Comps : out Nat;
7165 Has_POC : out Boolean);
7166 -- Examine all components in component list Comps, count all controlled
7167 -- components and determine whether at least one of them is per-object
7168 -- constrained. Component _parent is always skipped.
7170 -----------------------------
7171 -- Build_Adjust_Statements --
7172 -----------------------------
7174 function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is
7175 Loc : constant Source_Ptr := Sloc (Typ);
7176 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
7178 Finalizer_Data : Finalization_Exception_Data;
7180 function Process_Component_List_For_Adjust
7181 (Comps : Node_Id) return List_Id;
7182 -- Build all necessary adjust statements for a single component list
7184 ---------------------------------------
7185 -- Process_Component_List_For_Adjust --
7186 ---------------------------------------
7188 function Process_Component_List_For_Adjust
7189 (Comps : Node_Id) return List_Id
7191 Stmts : constant List_Id := New_List;
7193 procedure Process_Component_For_Adjust (Decl : Node_Id);
7194 -- Process the declaration of a single controlled component
7196 ----------------------------------
7197 -- Process_Component_For_Adjust --
7198 ----------------------------------
7200 procedure Process_Component_For_Adjust (Decl : Node_Id) is
7201 Id : constant Entity_Id := Defining_Identifier (Decl);
7202 Typ : constant Entity_Id := Etype (Id);
7208 -- [Deep_]Adjust (V.Id);
7212 -- if not Raised then
7214 -- Save_Occurrence (E, Get_Current_Excep.all.all);
7221 Make_Selected_Component (Loc,
7222 Prefix => Make_Identifier (Loc, Name_V),
7223 Selector_Name => Make_Identifier (Loc, Chars (Id))),
7226 -- Guard against a missing [Deep_]Adjust when the component
7227 -- type was not properly frozen.
7229 if Present (Adj_Call) then
7230 if Exceptions_OK then
7232 Make_Block_Statement (Loc,
7233 Handled_Statement_Sequence =>
7234 Make_Handled_Sequence_Of_Statements (Loc,
7235 Statements => New_List (Adj_Call),
7236 Exception_Handlers => New_List (
7237 Build_Exception_Handler (Finalizer_Data))));
7240 Append_To (Stmts, Adj_Call);
7242 end Process_Component_For_Adjust;
7247 Decl_Id : Entity_Id;
7248 Decl_Typ : Entity_Id;
7253 -- Start of processing for Process_Component_List_For_Adjust
7256 -- Perform an initial check, determine the number of controlled
7257 -- components in the current list and whether at least one of them
7258 -- is per-object constrained.
7260 Preprocess_Components (Comps, Num_Comps, Has_POC);
7262 -- The processing in this routine is done in the following order:
7263 -- 1) Regular components
7264 -- 2) Per-object constrained components
7267 if Num_Comps > 0 then
7269 -- Process all regular components in order of declarations
7271 Decl := First_Non_Pragma (Component_Items (Comps));
7272 while Present (Decl) loop
7273 Decl_Id := Defining_Identifier (Decl);
7274 Decl_Typ := Etype (Decl_Id);
7276 -- Skip _parent as well as per-object constrained components
7278 if Chars (Decl_Id) /= Name_uParent
7279 and then Needs_Finalization (Decl_Typ)
7281 if Has_Access_Constraint (Decl_Id)
7282 and then No (Expression (Decl))
7286 Process_Component_For_Adjust (Decl);
7290 Next_Non_Pragma (Decl);
7293 -- Process all per-object constrained components in order of
7297 Decl := First_Non_Pragma (Component_Items (Comps));
7298 while Present (Decl) loop
7299 Decl_Id := Defining_Identifier (Decl);
7300 Decl_Typ := Etype (Decl_Id);
7304 if Chars (Decl_Id) /= Name_uParent
7305 and then Needs_Finalization (Decl_Typ)
7306 and then Has_Access_Constraint (Decl_Id)
7307 and then No (Expression (Decl))
7309 Process_Component_For_Adjust (Decl);
7312 Next_Non_Pragma (Decl);
7317 -- Process all variants, if any
7320 if Present (Variant_Part (Comps)) then
7322 Var_Alts : constant List_Id := New_List;
7326 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
7327 while Present (Var) loop
7330 -- when <discrete choices> =>
7331 -- <adjust statements>
7333 Append_To (Var_Alts,
7334 Make_Case_Statement_Alternative (Loc,
7336 New_Copy_List (Discrete_Choices (Var)),
7338 Process_Component_List_For_Adjust (
7339 Component_List (Var))));
7341 Next_Non_Pragma (Var);
7345 -- case V.<discriminant> is
7346 -- when <discrete choices 1> =>
7347 -- <adjust statements 1>
7349 -- when <discrete choices N> =>
7350 -- <adjust statements N>
7354 Make_Case_Statement (Loc,
7356 Make_Selected_Component (Loc,
7357 Prefix => Make_Identifier (Loc, Name_V),
7359 Make_Identifier (Loc,
7360 Chars => Chars (Name (Variant_Part (Comps))))),
7361 Alternatives => Var_Alts);
7365 -- Add the variant case statement to the list of statements
7367 if Present (Var_Case) then
7368 Append_To (Stmts, Var_Case);
7371 -- If the component list did not have any controlled components
7372 -- nor variants, return null.
7374 if Is_Empty_List (Stmts) then
7375 Append_To (Stmts, Make_Null_Statement (Loc));
7379 end Process_Component_List_For_Adjust;
7383 Bod_Stmts : List_Id := No_List;
7384 Finalizer_Decls : List_Id := No_List;
7387 -- Start of processing for Build_Adjust_Statements
7390 Finalizer_Decls := New_List;
7391 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
7393 if Nkind (Typ_Def) = N_Derived_Type_Definition then
7394 Rec_Def := Record_Extension_Part (Typ_Def);
7399 -- Create an adjust sequence for all record components
7401 if Present (Component_List (Rec_Def)) then
7403 Process_Component_List_For_Adjust (Component_List (Rec_Def));
7406 -- A derived record type must adjust all inherited components. This
7407 -- action poses the following problem:
7409 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
7414 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
7416 -- Deep_Adjust (Obj._parent);
7421 -- Adjusting the derived type will invoke Adjust of the parent and
7422 -- then that of the derived type. This is undesirable because both
7423 -- routines may modify shared components. Only the Adjust of the
7424 -- derived type should be invoked.
7426 -- To prevent this double adjustment of shared components,
7427 -- Deep_Adjust uses a flag to control the invocation of Adjust:
7429 -- procedure Deep_Adjust
7430 -- (Obj : in out Some_Type;
7431 -- Flag : Boolean := True)
7439 -- When Deep_Adjust is invokes for field _parent, a value of False is
7440 -- provided for the flag:
7442 -- Deep_Adjust (Obj._parent, False);
7444 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
7446 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
7451 if Needs_Finalization (Par_Typ) then
7455 Make_Selected_Component (Loc,
7456 Prefix => Make_Identifier (Loc, Name_V),
7458 Make_Identifier (Loc, Name_uParent)),
7464 -- Deep_Adjust (V._parent, False);
7467 -- when Id : others =>
7468 -- if not Raised then
7470 -- Save_Occurrence (E,
7471 -- Get_Current_Excep.all.all);
7475 if Present (Call) then
7478 if Exceptions_OK then
7480 Make_Block_Statement (Loc,
7481 Handled_Statement_Sequence =>
7482 Make_Handled_Sequence_Of_Statements (Loc,
7483 Statements => New_List (Adj_Stmt),
7484 Exception_Handlers => New_List (
7485 Build_Exception_Handler (Finalizer_Data))));
7488 Prepend_To (Bod_Stmts, Adj_Stmt);
7494 -- Adjust the object. This action must be performed last after all
7495 -- components have been adjusted.
7497 if Is_Controlled (Typ) then
7503 Proc := Find_Optional_Prim_Op (Typ, Name_Adjust);
7512 -- if not Raised then
7514 -- Save_Occurrence (E,
7515 -- Get_Current_Excep.all.all);
7520 if Present (Proc) then
7522 Make_Procedure_Call_Statement (Loc,
7523 Name => New_Occurrence_Of (Proc, Loc),
7524 Parameter_Associations => New_List (
7525 Make_Identifier (Loc, Name_V)));
7527 if Exceptions_OK then
7529 Make_Block_Statement (Loc,
7530 Handled_Statement_Sequence =>
7531 Make_Handled_Sequence_Of_Statements (Loc,
7532 Statements => New_List (Adj_Stmt),
7533 Exception_Handlers => New_List (
7534 Build_Exception_Handler
7535 (Finalizer_Data))));
7538 Append_To (Bod_Stmts,
7539 Make_If_Statement (Loc,
7540 Condition => Make_Identifier (Loc, Name_F),
7541 Then_Statements => New_List (Adj_Stmt)));
7546 -- At this point either all adjustment statements have been generated
7547 -- or the type is not controlled.
7549 if Is_Empty_List (Bod_Stmts) then
7550 Append_To (Bod_Stmts, Make_Null_Statement (Loc));
7556 -- Abort : constant Boolean := Triggered_By_Abort;
7558 -- Abort : constant Boolean := False; -- no abort
7560 -- E : Exception_Occurrence;
7561 -- Raised : Boolean := False;
7564 -- <adjust statements>
7566 -- if Raised and then not Abort then
7567 -- Raise_From_Controlled_Operation (E);
7572 if Exceptions_OK then
7573 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
7578 Make_Block_Statement (Loc,
7581 Handled_Statement_Sequence =>
7582 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
7584 end Build_Adjust_Statements;
7586 -------------------------------
7587 -- Build_Finalize_Statements --
7588 -------------------------------
7590 function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is
7591 Loc : constant Source_Ptr := Sloc (Typ);
7592 Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
7595 Finalizer_Data : Finalization_Exception_Data;
7597 function Process_Component_List_For_Finalize
7598 (Comps : Node_Id) return List_Id;
7599 -- Build all necessary finalization statements for a single component
7600 -- list. The statements may include a jump circuitry if flag Is_Local
7603 -----------------------------------------
7604 -- Process_Component_List_For_Finalize --
7605 -----------------------------------------
7607 function Process_Component_List_For_Finalize
7608 (Comps : Node_Id) return List_Id
7610 procedure Process_Component_For_Finalize
7615 Num_Comps : in out Nat);
7616 -- Process the declaration of a single controlled component. If
7617 -- flag Is_Local is enabled, create the corresponding label and
7618 -- jump circuitry. Alts is the list of case alternatives, Decls
7619 -- is the top level declaration list where labels are declared
7620 -- and Stmts is the list of finalization actions. Num_Comps
7621 -- denotes the current number of components needing finalization.
7623 ------------------------------------
7624 -- Process_Component_For_Finalize --
7625 ------------------------------------
7627 procedure Process_Component_For_Finalize
7632 Num_Comps : in out Nat)
7634 Id : constant Entity_Id := Defining_Identifier (Decl);
7635 Typ : constant Entity_Id := Etype (Id);
7642 Label_Id : Entity_Id;
7649 Make_Identifier (Loc,
7650 Chars => New_External_Name ('L', Num_Comps));
7651 Set_Entity (Label_Id,
7652 Make_Defining_Identifier (Loc, Chars (Label_Id)));
7653 Label := Make_Label (Loc, Label_Id);
7656 Make_Implicit_Label_Declaration (Loc,
7657 Defining_Identifier => Entity (Label_Id),
7658 Label_Construct => Label));
7665 Make_Case_Statement_Alternative (Loc,
7666 Discrete_Choices => New_List (
7667 Make_Integer_Literal (Loc, Num_Comps)),
7669 Statements => New_List (
7670 Make_Goto_Statement (Loc,
7672 New_Occurrence_Of (Entity (Label_Id), Loc)))));
7677 Append_To (Stmts, Label);
7679 -- Decrease the number of components to be processed.
7680 -- This action yields a new Label_Id in future calls.
7682 Num_Comps := Num_Comps - 1;
7687 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7689 -- begin -- Exception handlers allowed
7690 -- [Deep_]Finalize (V.Id);
7693 -- if not Raised then
7695 -- Save_Occurrence (E,
7696 -- Get_Current_Excep.all.all);
7703 Make_Selected_Component (Loc,
7704 Prefix => Make_Identifier (Loc, Name_V),
7705 Selector_Name => Make_Identifier (Loc, Chars (Id))),
7708 -- Guard against a missing [Deep_]Finalize when the component
7709 -- type was not properly frozen.
7711 if Present (Fin_Call) then
7712 if Exceptions_OK then
7714 Make_Block_Statement (Loc,
7715 Handled_Statement_Sequence =>
7716 Make_Handled_Sequence_Of_Statements (Loc,
7717 Statements => New_List (Fin_Call),
7718 Exception_Handlers => New_List (
7719 Build_Exception_Handler (Finalizer_Data))));
7722 Append_To (Stmts, Fin_Call);
7724 end Process_Component_For_Finalize;
7729 Counter_Id : Entity_Id := Empty;
7731 Decl_Id : Entity_Id;
7732 Decl_Typ : Entity_Id;
7735 Jump_Block : Node_Id;
7737 Label_Id : Entity_Id;
7742 -- Start of processing for Process_Component_List_For_Finalize
7745 -- Perform an initial check, look for controlled and per-object
7746 -- constrained components.
7748 Preprocess_Components (Comps, Num_Comps, Has_POC);
7750 -- Create a state counter to service the current component list.
7751 -- This step is performed before the variants are inspected in
7752 -- order to generate the same state counter names as those from
7753 -- Build_Initialize_Statements.
7755 if Num_Comps > 0 and then Is_Local then
7756 Counter := Counter + 1;
7759 Make_Defining_Identifier (Loc,
7760 Chars => New_External_Name ('C', Counter));
7763 -- Process the component in the following order:
7765 -- 2) Per-object constrained components
7766 -- 3) Regular components
7768 -- Start with the variant parts
7771 if Present (Variant_Part (Comps)) then
7773 Var_Alts : constant List_Id := New_List;
7777 Var := First_Non_Pragma (Variants (Variant_Part (Comps)));
7778 while Present (Var) loop
7781 -- when <discrete choices> =>
7782 -- <finalize statements>
7784 Append_To (Var_Alts,
7785 Make_Case_Statement_Alternative (Loc,
7787 New_Copy_List (Discrete_Choices (Var)),
7789 Process_Component_List_For_Finalize (
7790 Component_List (Var))));
7792 Next_Non_Pragma (Var);
7796 -- case V.<discriminant> is
7797 -- when <discrete choices 1> =>
7798 -- <finalize statements 1>
7800 -- when <discrete choices N> =>
7801 -- <finalize statements N>
7805 Make_Case_Statement (Loc,
7807 Make_Selected_Component (Loc,
7808 Prefix => Make_Identifier (Loc, Name_V),
7810 Make_Identifier (Loc,
7811 Chars => Chars (Name (Variant_Part (Comps))))),
7812 Alternatives => Var_Alts);
7816 -- The current component list does not have a single controlled
7817 -- component, however it may contain variants. Return the case
7818 -- statement for the variants or nothing.
7820 if Num_Comps = 0 then
7821 if Present (Var_Case) then
7822 return New_List (Var_Case);
7824 return New_List (Make_Null_Statement (Loc));
7828 -- Prepare all lists
7834 -- Process all per-object constrained components in reverse order
7837 Decl := Last_Non_Pragma (Component_Items (Comps));
7838 while Present (Decl) loop
7839 Decl_Id := Defining_Identifier (Decl);
7840 Decl_Typ := Etype (Decl_Id);
7844 if Chars (Decl_Id) /= Name_uParent
7845 and then Needs_Finalization (Decl_Typ)
7846 and then Has_Access_Constraint (Decl_Id)
7847 and then No (Expression (Decl))
7849 Process_Component_For_Finalize
7850 (Decl, Alts, Decls, Stmts, Num_Comps);
7853 Prev_Non_Pragma (Decl);
7857 -- Process the rest of the components in reverse order
7859 Decl := Last_Non_Pragma (Component_Items (Comps));
7860 while Present (Decl) loop
7861 Decl_Id := Defining_Identifier (Decl);
7862 Decl_Typ := Etype (Decl_Id);
7866 if Chars (Decl_Id) /= Name_uParent
7867 and then Needs_Finalization (Decl_Typ)
7869 -- Skip per-object constrained components since they were
7870 -- handled in the above step.
7872 if Has_Access_Constraint (Decl_Id)
7873 and then No (Expression (Decl))
7877 Process_Component_For_Finalize
7878 (Decl, Alts, Decls, Stmts, Num_Comps);
7882 Prev_Non_Pragma (Decl);
7887 -- LN : label; -- If Is_Local is enabled
7892 -- case CounterX is .
7902 -- <<LN>> -- If Is_Local is enabled
7904 -- [Deep_]Finalize (V.CompY);
7906 -- when Id : others =>
7907 -- if not Raised then
7909 -- Save_Occurrence (E,
7910 -- Get_Current_Excep.all.all);
7914 -- <<L0>> -- If Is_Local is enabled
7919 -- Add the declaration of default jump location L0, its
7920 -- corresponding alternative and its place in the statements.
7922 Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
7923 Set_Entity (Label_Id,
7924 Make_Defining_Identifier (Loc, Chars (Label_Id)));
7925 Label := Make_Label (Loc, Label_Id);
7927 Append_To (Decls, -- declaration
7928 Make_Implicit_Label_Declaration (Loc,
7929 Defining_Identifier => Entity (Label_Id),
7930 Label_Construct => Label));
7932 Append_To (Alts, -- alternative
7933 Make_Case_Statement_Alternative (Loc,
7934 Discrete_Choices => New_List (
7935 Make_Others_Choice (Loc)),
7937 Statements => New_List (
7938 Make_Goto_Statement (Loc,
7939 Name => New_Occurrence_Of (Entity (Label_Id), Loc)))));
7941 Append_To (Stmts, Label); -- statement
7943 -- Create the jump block
7946 Make_Case_Statement (Loc,
7947 Expression => Make_Identifier (Loc, Chars (Counter_Id)),
7948 Alternatives => Alts));
7952 Make_Block_Statement (Loc,
7953 Declarations => Decls,
7954 Handled_Statement_Sequence =>
7955 Make_Handled_Sequence_Of_Statements (Loc, Stmts));
7957 if Present (Var_Case) then
7958 return New_List (Var_Case, Jump_Block);
7960 return New_List (Jump_Block);
7962 end Process_Component_List_For_Finalize;
7966 Bod_Stmts : List_Id := No_List;
7967 Finalizer_Decls : List_Id := No_List;
7970 -- Start of processing for Build_Finalize_Statements
7973 Finalizer_Decls := New_List;
7974 Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
7976 if Nkind (Typ_Def) = N_Derived_Type_Definition then
7977 Rec_Def := Record_Extension_Part (Typ_Def);
7982 -- Create a finalization sequence for all record components
7984 if Present (Component_List (Rec_Def)) then
7986 Process_Component_List_For_Finalize (Component_List (Rec_Def));
7989 -- A derived record type must finalize all inherited components. This
7990 -- action poses the following problem:
7992 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7997 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7999 -- Deep_Finalize (Obj._parent);
8004 -- Finalizing the derived type will invoke Finalize of the parent and
8005 -- then that of the derived type. This is undesirable because both
8006 -- routines may modify shared components. Only the Finalize of the
8007 -- derived type should be invoked.
8009 -- To prevent this double adjustment of shared components,
8010 -- Deep_Finalize uses a flag to control the invocation of Finalize:
8012 -- procedure Deep_Finalize
8013 -- (Obj : in out Some_Type;
8014 -- Flag : Boolean := True)
8022 -- When Deep_Finalize is invoked for field _parent, a value of False
8023 -- is provided for the flag:
8025 -- Deep_Finalize (Obj._parent, False);
8027 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
8029 Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
8034 if Needs_Finalization (Par_Typ) then
8038 Make_Selected_Component (Loc,
8039 Prefix => Make_Identifier (Loc, Name_V),
8041 Make_Identifier (Loc, Name_uParent)),
8047 -- Deep_Finalize (V._parent, False);
8050 -- when Id : others =>
8051 -- if not Raised then
8053 -- Save_Occurrence (E,
8054 -- Get_Current_Excep.all.all);
8058 if Present (Call) then
8061 if Exceptions_OK then
8063 Make_Block_Statement (Loc,
8064 Handled_Statement_Sequence =>
8065 Make_Handled_Sequence_Of_Statements (Loc,
8066 Statements => New_List (Fin_Stmt),
8067 Exception_Handlers => New_List (
8068 Build_Exception_Handler
8069 (Finalizer_Data))));
8072 Append_To (Bod_Stmts, Fin_Stmt);
8078 -- Finalize the object. This action must be performed first before
8079 -- all components have been finalized.
8081 if Is_Controlled (Typ) and then not Is_Local then
8087 Proc := Find_Optional_Prim_Op (Typ, Name_Finalize);
8096 -- if not Raised then
8098 -- Save_Occurrence (E,
8099 -- Get_Current_Excep.all.all);
8104 if Present (Proc) then
8106 Make_Procedure_Call_Statement (Loc,
8107 Name => New_Occurrence_Of (Proc, Loc),
8108 Parameter_Associations => New_List (
8109 Make_Identifier (Loc, Name_V)));
8111 if Exceptions_OK then
8113 Make_Block_Statement (Loc,
8114 Handled_Statement_Sequence =>
8115 Make_Handled_Sequence_Of_Statements (Loc,
8116 Statements => New_List (Fin_Stmt),
8117 Exception_Handlers => New_List (
8118 Build_Exception_Handler
8119 (Finalizer_Data))));
8122 Prepend_To (Bod_Stmts,
8123 Make_If_Statement (Loc,
8124 Condition => Make_Identifier (Loc, Name_F),
8125 Then_Statements => New_List (Fin_Stmt)));
8130 -- At this point either all finalization statements have been
8131 -- generated or the type is not controlled.
8133 if No (Bod_Stmts) then
8134 return New_List (Make_Null_Statement (Loc));
8138 -- Abort : constant Boolean := Triggered_By_Abort;
8140 -- Abort : constant Boolean := False; -- no abort
8142 -- E : Exception_Occurrence;
8143 -- Raised : Boolean := False;
8146 -- <finalize statements>
8148 -- if Raised and then not Abort then
8149 -- Raise_From_Controlled_Operation (E);
8154 if Exceptions_OK then
8155 Append_To (Bod_Stmts, Build_Raise_Statement (Finalizer_Data));
8160 Make_Block_Statement (Loc,
8163 Handled_Statement_Sequence =>
8164 Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts)));
8166 end Build_Finalize_Statements;
8168 -----------------------
8169 -- Parent_Field_Type --
8170 -----------------------
8172 function Parent_Field_Type (Typ : Entity_Id) return Entity_Id is
8176 Field := First_Entity (Typ);
8177 while Present (Field) loop
8178 if Chars (Field) = Name_uParent then
8179 return Etype (Field);
8182 Next_Entity (Field);
8185 -- A derived tagged type should always have a parent field
8187 raise Program_Error;
8188 end Parent_Field_Type;
8190 ---------------------------
8191 -- Preprocess_Components --
8192 ---------------------------
8194 procedure Preprocess_Components
8196 Num_Comps : out Nat;
8197 Has_POC : out Boolean)
8207 Decl := First_Non_Pragma (Component_Items (Comps));
8208 while Present (Decl) loop
8209 Id := Defining_Identifier (Decl);
8212 -- Skip field _parent
8214 if Chars (Id) /= Name_uParent
8215 and then Needs_Finalization (Typ)
8217 Num_Comps := Num_Comps + 1;
8219 if Has_Access_Constraint (Id)
8220 and then No (Expression (Decl))
8226 Next_Non_Pragma (Decl);
8228 end Preprocess_Components;
8230 -- Start of processing for Make_Deep_Record_Body
8234 when Address_Case =>
8235 return Make_Finalize_Address_Stmts (Typ);
8238 return Build_Adjust_Statements (Typ);
8240 when Finalize_Case =>
8241 return Build_Finalize_Statements (Typ);
8243 when Initialize_Case =>
8245 Loc : constant Source_Ptr := Sloc (Typ);
8248 if Is_Controlled (Typ) then
8250 Make_Procedure_Call_Statement (Loc,
8253 (Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
8254 Parameter_Associations => New_List (
8255 Make_Identifier (Loc, Name_V))));
8261 end Make_Deep_Record_Body;
8263 ----------------------
8264 -- Make_Final_Call --
8265 ----------------------
8267 function Make_Final_Call
8270 Skip_Self : Boolean := False) return Node_Id
8272 Loc : constant Source_Ptr := Sloc (Obj_Ref);
8274 Fin_Id : Entity_Id := Empty;
8281 -- Recover the proper type which contains [Deep_]Finalize
8283 if Is_Class_Wide_Type (Typ) then
8284 Utyp := Root_Type (Typ);
8287 elsif Is_Concurrent_Type (Typ) then
8288 Utyp := Corresponding_Record_Type (Typ);
8290 Ref := Convert_Concurrent (Ref, Typ);
8292 elsif Is_Private_Type (Typ)
8293 and then Present (Full_View (Typ))
8294 and then Is_Concurrent_Type (Full_View (Typ))
8296 Utyp := Corresponding_Record_Type (Full_View (Typ));
8298 Ref := Convert_Concurrent (Ref, Full_View (Typ));
8305 Utyp := Underlying_Type (Base_Type (Utyp));
8306 Set_Assignment_OK (Ref);
8308 -- Deal with untagged derivation of private views. If the parent type
8309 -- is a protected type, Deep_Finalize is found on the corresponding
8310 -- record of the ancestor.
8312 if Is_Untagged_Derivation (Typ) then
8313 if Is_Protected_Type (Typ) then
8314 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
8316 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
8318 if Is_Protected_Type (Utyp) then
8319 Utyp := Corresponding_Record_Type (Utyp);
8323 Ref := Unchecked_Convert_To (Utyp, Ref);
8324 Set_Assignment_OK (Ref);
8327 -- Deal with derived private types which do not inherit primitives from
8328 -- their parents. In this case, [Deep_]Finalize can be found in the full
8329 -- view of the parent type.
8332 and then Is_Tagged_Type (Utyp)
8333 and then Is_Derived_Type (Utyp)
8334 and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
8335 and then Is_Private_Type (Etype (Utyp))
8336 and then Present (Full_View (Etype (Utyp)))
8338 Utyp := Full_View (Etype (Utyp));
8339 Ref := Unchecked_Convert_To (Utyp, Ref);
8340 Set_Assignment_OK (Ref);
8343 -- When dealing with the completion of a private type, use the base type
8346 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
8347 pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
8349 Utyp := Base_Type (Utyp);
8350 Ref := Unchecked_Convert_To (Utyp, Ref);
8351 Set_Assignment_OK (Ref);
8354 -- The underlying type may not be present due to a missing full view. In
8355 -- this case freezing did not take place and there is no [Deep_]Finalize
8356 -- primitive to call.
8361 elsif Skip_Self then
8362 if Has_Controlled_Component (Utyp) then
8363 if Is_Tagged_Type (Utyp) then
8364 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8366 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
8370 -- Class-wide types, interfaces and types with controlled components
8372 elsif Is_Class_Wide_Type (Typ)
8373 or else Is_Interface (Typ)
8374 or else Has_Controlled_Component (Utyp)
8376 if Is_Tagged_Type (Utyp) then
8377 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8379 Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
8382 -- Derivations from [Limited_]Controlled
8384 elsif Is_Controlled (Utyp) then
8385 if Has_Controlled_Component (Utyp) then
8386 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8388 Fin_Id := Find_Optional_Prim_Op (Utyp, Name_Of (Finalize_Case));
8393 elsif Is_Tagged_Type (Utyp) then
8394 Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
8397 raise Program_Error;
8400 if Present (Fin_Id) then
8402 -- When finalizing a class-wide object, do not convert to the root
8403 -- type in order to produce a dispatching call.
8405 if Is_Class_Wide_Type (Typ) then
8408 -- Ensure that a finalization routine is at least decorated in order
8409 -- to inspect the object parameter.
8411 elsif Analyzed (Fin_Id)
8412 or else Ekind (Fin_Id) = E_Procedure
8414 -- In certain cases, such as the creation of Stream_Read, the
8415 -- visible entity of the type is its full view. Since Stream_Read
8416 -- will have to create an object of type Typ, the local object
8417 -- will be finalzed by the scope finalizer generated later on. The
8418 -- object parameter of Deep_Finalize will always use the private
8419 -- view of the type. To avoid such a clash between a private and a
8420 -- full view, perform an unchecked conversion of the object
8421 -- reference to the private view.
8424 Formal_Typ : constant Entity_Id :=
8425 Etype (First_Formal (Fin_Id));
8427 if Is_Private_Type (Formal_Typ)
8428 and then Present (Full_View (Formal_Typ))
8429 and then Full_View (Formal_Typ) = Utyp
8431 Ref := Unchecked_Convert_To (Formal_Typ, Ref);
8435 Ref := Convert_View (Fin_Id, Ref);
8442 Skip_Self => Skip_Self);
8446 end Make_Final_Call;
8448 --------------------------------
8449 -- Make_Finalize_Address_Body --
8450 --------------------------------
8452 procedure Make_Finalize_Address_Body (Typ : Entity_Id) is
8453 Is_Task : constant Boolean :=
8454 Ekind (Typ) = E_Record_Type
8455 and then Is_Concurrent_Record_Type (Typ)
8456 and then Ekind (Corresponding_Concurrent_Type (Typ)) =
8458 Loc : constant Source_Ptr := Sloc (Typ);
8459 Proc_Id : Entity_Id;
8463 -- The corresponding records of task types are not controlled by design.
8464 -- For the sake of completeness, create an empty Finalize_Address to be
8465 -- used in task class-wide allocations.
8470 -- Nothing to do if the type is not controlled or it already has a
8471 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
8472 -- come from source. These are usually generated for completeness and
8473 -- do not need the Finalize_Address primitive.
8475 elsif not Needs_Finalization (Typ)
8476 or else Present (TSS (Typ, TSS_Finalize_Address))
8478 (Is_Class_Wide_Type (Typ)
8479 and then Ekind (Root_Type (Typ)) = E_Record_Subtype
8480 and then not Comes_From_Source (Root_Type (Typ)))
8485 -- Do not generate Finalize_Address routine for CodePeer
8487 if CodePeer_Mode then
8492 Make_Defining_Identifier (Loc,
8493 Make_TSS_Name (Typ, TSS_Finalize_Address));
8497 -- procedure <Typ>FD (V : System.Address) is
8499 -- null; -- for tasks
8501 -- declare -- for all other types
8502 -- type Pnn is access all Typ;
8503 -- for Pnn'Storage_Size use 0;
8505 -- [Deep_]Finalize (Pnn (V).all);
8510 Stmts := New_List (Make_Null_Statement (Loc));
8512 Stmts := Make_Finalize_Address_Stmts (Typ);
8516 Make_Subprogram_Body (Loc,
8518 Make_Procedure_Specification (Loc,
8519 Defining_Unit_Name => Proc_Id,
8521 Parameter_Specifications => New_List (
8522 Make_Parameter_Specification (Loc,
8523 Defining_Identifier =>
8524 Make_Defining_Identifier (Loc, Name_V),
8526 New_Occurrence_Of (RTE (RE_Address), Loc)))),
8528 Declarations => No_List,
8530 Handled_Statement_Sequence =>
8531 Make_Handled_Sequence_Of_Statements (Loc,
8532 Statements => Stmts)));
8534 Set_TSS (Typ, Proc_Id);
8535 end Make_Finalize_Address_Body;
8537 ---------------------------------
8538 -- Make_Finalize_Address_Stmts --
8539 ---------------------------------
8541 function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
8542 Loc : constant Source_Ptr := Sloc (Typ);
8545 Desig_Typ : Entity_Id;
8546 Fin_Block : Node_Id;
8549 Ptr_Typ : Entity_Id;
8552 if Is_Array_Type (Typ) then
8553 if Is_Constrained (First_Subtype (Typ)) then
8554 Desig_Typ := First_Subtype (Typ);
8556 Desig_Typ := Base_Type (Typ);
8559 -- Class-wide types of constrained root types
8561 elsif Is_Class_Wide_Type (Typ)
8562 and then Has_Discriminants (Root_Type (Typ))
8564 Is_Empty_Elmt_List (Discriminant_Constraint (Root_Type (Typ)))
8567 Parent_Typ : Entity_Id;
8570 -- Climb the parent type chain looking for a non-constrained type
8572 Parent_Typ := Root_Type (Typ);
8573 while Parent_Typ /= Etype (Parent_Typ)
8574 and then Has_Discriminants (Parent_Typ)
8576 Is_Empty_Elmt_List (Discriminant_Constraint (Parent_Typ))
8578 Parent_Typ := Etype (Parent_Typ);
8581 -- Handle views created for tagged types with unknown
8584 if Is_Underlying_Record_View (Parent_Typ) then
8585 Parent_Typ := Underlying_Record_View (Parent_Typ);
8588 Desig_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
8598 -- type Ptr_Typ is access all Typ;
8599 -- for Ptr_Typ'Storage_Size use 0;
8601 Ptr_Typ := Make_Temporary (Loc, 'P');
8604 Make_Full_Type_Declaration (Loc,
8605 Defining_Identifier => Ptr_Typ,
8607 Make_Access_To_Object_Definition (Loc,
8608 All_Present => True,
8609 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))),
8611 Make_Attribute_Definition_Clause (Loc,
8612 Name => New_Occurrence_Of (Ptr_Typ, Loc),
8613 Chars => Name_Storage_Size,
8614 Expression => Make_Integer_Literal (Loc, 0)));
8616 Obj_Expr := Make_Identifier (Loc, Name_V);
8618 -- Unconstrained arrays require special processing in order to retrieve
8619 -- the elements. To achieve this, we have to skip the dope vector which
8620 -- lays in front of the elements and then use a thin pointer to perform
8621 -- the address-to-access conversion.
8623 if Is_Array_Type (Typ)
8624 and then not Is_Constrained (First_Subtype (Typ))
8627 Dope_Id : Entity_Id;
8630 -- Ensure that Ptr_Typ a thin pointer, generate:
8631 -- for Ptr_Typ'Size use System.Address'Size;
8634 Make_Attribute_Definition_Clause (Loc,
8635 Name => New_Occurrence_Of (Ptr_Typ, Loc),
8638 Make_Integer_Literal (Loc, System_Address_Size)));
8641 -- Dnn : constant Storage_Offset :=
8642 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8644 Dope_Id := Make_Temporary (Loc, 'D');
8647 Make_Object_Declaration (Loc,
8648 Defining_Identifier => Dope_Id,
8649 Constant_Present => True,
8650 Object_Definition =>
8651 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
8653 Make_Op_Divide (Loc,
8655 Make_Attribute_Reference (Loc,
8656 Prefix => New_Occurrence_Of (Desig_Typ, Loc),
8657 Attribute_Name => Name_Descriptor_Size),
8659 Make_Integer_Literal (Loc, System_Storage_Unit))));
8661 -- Shift the address from the start of the dope vector to the
8662 -- start of the elements:
8666 -- Note that this is done through a wrapper routine since RTSfind
8667 -- cannot retrieve operations with string names of the form "+".
8670 Make_Function_Call (Loc,
8672 New_Occurrence_Of (RTE (RE_Add_Offset_To_Address), Loc),
8673 Parameter_Associations => New_List (
8675 New_Occurrence_Of (Dope_Id, Loc)));
8682 Make_Explicit_Dereference (Loc,
8683 Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
8686 if Present (Fin_Call) then
8688 Make_Block_Statement (Loc,
8689 Declarations => Decls,
8690 Handled_Statement_Sequence =>
8691 Make_Handled_Sequence_Of_Statements (Loc,
8692 Statements => New_List (Fin_Call)));
8694 -- Otherwise previous errors or a missing full view may prevent the
8695 -- proper freezing of the designated type. If this is the case, there
8696 -- is no [Deep_]Finalize primitive to call.
8699 Fin_Block := Make_Null_Statement (Loc);
8702 return New_List (Fin_Block);
8703 end Make_Finalize_Address_Stmts;
8705 -------------------------------------
8706 -- Make_Handler_For_Ctrl_Operation --
8707 -------------------------------------
8711 -- when E : others =>
8712 -- Raise_From_Controlled_Operation (E);
8717 -- raise Program_Error [finalize raised exception];
8719 -- depending on whether Raise_From_Controlled_Operation is available
8721 function Make_Handler_For_Ctrl_Operation
8722 (Loc : Source_Ptr) return Node_Id
8725 -- Choice parameter (for the first case above)
8727 Raise_Node : Node_Id;
8728 -- Procedure call or raise statement
8731 -- Standard run-time: add choice parameter E and pass it to
8732 -- Raise_From_Controlled_Operation so that the original exception
8733 -- name and message can be recorded in the exception message for
8736 if RTE_Available (RE_Raise_From_Controlled_Operation) then
8737 E_Occ := Make_Defining_Identifier (Loc, Name_E);
8739 Make_Procedure_Call_Statement (Loc,
8742 (RTE (RE_Raise_From_Controlled_Operation), Loc),
8743 Parameter_Associations => New_List (
8744 New_Occurrence_Of (E_Occ, Loc)));
8746 -- Restricted run-time: exception messages are not supported
8751 Make_Raise_Program_Error (Loc,
8752 Reason => PE_Finalize_Raised_Exception);
8756 Make_Implicit_Exception_Handler (Loc,
8757 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8758 Choice_Parameter => E_Occ,
8759 Statements => New_List (Raise_Node));
8760 end Make_Handler_For_Ctrl_Operation;
8762 --------------------
8763 -- Make_Init_Call --
8764 --------------------
8766 function Make_Init_Call
8768 Typ : Entity_Id) return Node_Id
8770 Loc : constant Source_Ptr := Sloc (Obj_Ref);
8779 -- Deal with the type and object reference. Depending on the context, an
8780 -- object reference may need several conversions.
8782 if Is_Concurrent_Type (Typ) then
8784 Utyp := Corresponding_Record_Type (Typ);
8785 Ref := Convert_Concurrent (Ref, Typ);
8787 elsif Is_Private_Type (Typ)
8788 and then Present (Full_View (Typ))
8789 and then Is_Concurrent_Type (Underlying_Type (Typ))
8792 Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
8793 Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
8800 Utyp := Underlying_Type (Base_Type (Utyp));
8801 Set_Assignment_OK (Ref);
8803 -- Deal with untagged derivation of private views
8805 if Is_Untagged_Derivation (Typ) and then not Is_Conc then
8806 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
8807 Ref := Unchecked_Convert_To (Utyp, Ref);
8809 -- The following is to prevent problems with UC see 1.156 RH ???
8811 Set_Assignment_OK (Ref);
8814 -- If the underlying_type is a subtype, then we are dealing with the
8815 -- completion of a private type. We need to access the base type and
8816 -- generate a conversion to it.
8818 if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
8819 pragma Assert (Is_Private_Type (Typ));
8820 Utyp := Base_Type (Utyp);
8821 Ref := Unchecked_Convert_To (Utyp, Ref);
8824 -- The underlying type may not be present due to a missing full view.
8825 -- In this case freezing did not take place and there is no suitable
8826 -- [Deep_]Initialize primitive to call.
8832 -- Select the appropriate version of initialize
8834 if Has_Controlled_Component (Utyp) then
8835 Proc := TSS (Utyp, Deep_Name_Of (Initialize_Case));
8837 Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
8838 Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Ref);
8841 -- If initialization procedure for an array of controlled objects is
8842 -- trivial, do not generate a useless call to it.
8844 if (Is_Array_Type (Utyp) and then Is_Trivial_Subprogram (Proc))
8846 (not Comes_From_Source (Proc)
8847 and then Present (Alias (Proc))
8848 and then Is_Trivial_Subprogram (Alias (Proc)))
8850 return Make_Null_Statement (Loc);
8853 -- The object reference may need another conversion depending on the
8854 -- type of the formal and that of the actual.
8856 Ref := Convert_View (Proc, Ref);
8859 -- [Deep_]Initialize (Ref);
8862 Make_Procedure_Call_Statement (Loc,
8863 Name => New_Occurrence_Of (Proc, Loc),
8864 Parameter_Associations => New_List (Ref));
8867 ------------------------------
8868 -- Make_Local_Deep_Finalize --
8869 ------------------------------
8871 function Make_Local_Deep_Finalize
8873 Nam : Entity_Id) return Node_Id
8875 Loc : constant Source_Ptr := Sloc (Typ);
8879 Formals := New_List (
8883 Make_Parameter_Specification (Loc,
8884 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
8886 Out_Present => True,
8887 Parameter_Type => New_Occurrence_Of (Typ, Loc)),
8889 -- F : Boolean := True
8891 Make_Parameter_Specification (Loc,
8892 Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
8893 Parameter_Type => New_Occurrence_Of (Standard_Boolean, Loc),
8894 Expression => New_Occurrence_Of (Standard_True, Loc)));
8896 -- Add the necessary number of counters to represent the initialization
8897 -- state of an object.
8900 Make_Subprogram_Body (Loc,
8902 Make_Procedure_Specification (Loc,
8903 Defining_Unit_Name => Nam,
8904 Parameter_Specifications => Formals),
8906 Declarations => No_List,
8908 Handled_Statement_Sequence =>
8909 Make_Handled_Sequence_Of_Statements (Loc,
8910 Statements => Make_Deep_Record_Body (Finalize_Case, Typ, True)));
8911 end Make_Local_Deep_Finalize;
8913 ------------------------------------
8914 -- Make_Set_Finalize_Address_Call --
8915 ------------------------------------
8917 function Make_Set_Finalize_Address_Call
8919 Ptr_Typ : Entity_Id) return Node_Id
8921 -- It is possible for Ptr_Typ to be a partial view, if the access type
8922 -- is a full view declared in the private part of a nested package, and
8923 -- the finalization actions take place when completing analysis of the
8924 -- enclosing unit. For this reason use Underlying_Type twice below.
8926 Desig_Typ : constant Entity_Id :=
8928 (Designated_Type (Underlying_Type (Ptr_Typ)));
8929 Fin_Addr : constant Entity_Id := Finalize_Address (Desig_Typ);
8930 Fin_Mas : constant Entity_Id :=
8931 Finalization_Master (Underlying_Type (Ptr_Typ));
8934 -- Both the finalization master and primitive Finalize_Address must be
8937 pragma Assert (Present (Fin_Addr) and Present (Fin_Mas));
8940 -- Set_Finalize_Address
8941 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8944 Make_Procedure_Call_Statement (Loc,
8946 New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc),
8947 Parameter_Associations => New_List (
8948 New_Occurrence_Of (Fin_Mas, Loc),
8950 Make_Attribute_Reference (Loc,
8951 Prefix => New_Occurrence_Of (Fin_Addr, Loc),
8952 Attribute_Name => Name_Unrestricted_Access)));
8953 end Make_Set_Finalize_Address_Call;
8955 --------------------------
8956 -- Make_Transient_Block --
8957 --------------------------
8959 function Make_Transient_Block
8962 Par : Node_Id) return Node_Id
8964 function Manages_Sec_Stack (Id : Entity_Id) return Boolean;
8965 -- Determine whether scoping entity Id manages the secondary stack
8967 function Within_Loop_Statement (N : Node_Id) return Boolean;
8968 -- Return True when N appears within a loop and no block is containing N
8970 -----------------------
8971 -- Manages_Sec_Stack --
8972 -----------------------
8974 function Manages_Sec_Stack (Id : Entity_Id) return Boolean is
8978 -- An exception handler with a choice parameter utilizes a dummy
8979 -- block to provide a declarative region. Such a block should not
8980 -- be considered because it never manifests in the tree and can
8981 -- never release the secondary stack.
8985 Uses_Sec_Stack (Id) and then not Is_Exception_Handler (Id);
8992 return Uses_Sec_Stack (Id);
8997 end Manages_Sec_Stack;
8999 ---------------------------
9000 -- Within_Loop_Statement --
9001 ---------------------------
9003 function Within_Loop_Statement (N : Node_Id) return Boolean is
9004 Par : Node_Id := Parent (N);
9007 while not (Nkind_In (Par, N_Handled_Sequence_Of_Statements,
9009 N_Package_Specification)
9010 or else Nkind (Par) in N_Proper_Body)
9012 pragma Assert (Present (Par));
9013 Par := Parent (Par);
9016 return Nkind (Par) = N_Loop_Statement;
9017 end Within_Loop_Statement;
9021 Decls : constant List_Id := New_List;
9022 Instrs : constant List_Id := New_List (Action);
9023 Trans_Id : constant Entity_Id := Current_Scope;
9029 -- Start of processing for Make_Transient_Block
9032 -- Even though the transient block is tasked with managing the secondary
9033 -- stack, the block may forgo this functionality depending on how the
9034 -- secondary stack is managed by enclosing scopes.
9036 if Manages_Sec_Stack (Trans_Id) then
9038 -- Determine whether an enclosing scope already manages the secondary
9041 Scop := Scope (Trans_Id);
9042 while Present (Scop) loop
9044 -- It should not be possible to reach Standard without hitting one
9045 -- of the other cases first unless Standard was manually pushed.
9047 if Scop = Standard_Standard then
9050 -- The transient block is within a function which returns on the
9051 -- secondary stack. Take a conservative approach and assume that
9052 -- the value on the secondary stack is part of the result. Note
9053 -- that it is not possible to detect this dependency without flow
9054 -- analysis which the compiler does not have. Letting the object
9055 -- live longer than the transient block will not leak any memory
9056 -- because the caller will reclaim the total storage used by the
9059 elsif Ekind (Scop) = E_Function
9060 and then Sec_Stack_Needed_For_Return (Scop)
9062 Set_Uses_Sec_Stack (Trans_Id, False);
9065 -- The transient block must manage the secondary stack when the
9066 -- block appears within a loop in order to reclaim the memory at
9069 elsif Ekind (Scop) = E_Loop then
9072 -- Ditto when the block appears without a block that does not
9073 -- manage the secondary stack and is located within a loop.
9075 elsif Ekind (Scop) = E_Block
9076 and then not Manages_Sec_Stack (Scop)
9077 and then Present (Block_Node (Scop))
9078 and then Within_Loop_Statement (Block_Node (Scop))
9082 -- The transient block does not need to manage the secondary stack
9083 -- when there is an enclosing construct which already does that.
9084 -- This optimization saves on SS_Mark and SS_Release calls but may
9085 -- allow objects to live a little longer than required.
9087 -- The transient block must manage the secondary stack when switch
9088 -- -gnatd.s (strict management) is in effect.
9090 elsif Manages_Sec_Stack (Scop) and then not Debug_Flag_Dot_S then
9091 Set_Uses_Sec_Stack (Trans_Id, False);
9094 -- Prevent the search from going too far because transient blocks
9095 -- are bounded by packages and subprogram scopes.
9097 elsif Ekind_In (Scop, E_Entry,
9107 Scop := Scope (Scop);
9111 -- Create the transient block. Set the parent now since the block itself
9112 -- is not part of the tree. The current scope is the E_Block entity that
9113 -- has been pushed by Establish_Transient_Scope.
9115 pragma Assert (Ekind (Trans_Id) = E_Block);
9118 Make_Block_Statement (Loc,
9119 Identifier => New_Occurrence_Of (Trans_Id, Loc),
9120 Declarations => Decls,
9121 Handled_Statement_Sequence =>
9122 Make_Handled_Sequence_Of_Statements (Loc, Statements => Instrs),
9123 Has_Created_Identifier => True);
9124 Set_Parent (Block, Par);
9126 -- Insert actions stuck in the transient scopes as well as all freezing
9127 -- nodes needed by those actions. Do not insert cleanup actions here,
9128 -- they will be transferred to the newly created block.
9130 Insert_Actions_In_Scope_Around
9131 (Action, Clean => False, Manage_SS => False);
9133 Insert := Prev (Action);
9135 if Present (Insert) then
9136 Freeze_All (First_Entity (Trans_Id), Insert);
9139 -- Transfer cleanup actions to the newly created block
9142 Cleanup_Actions : List_Id
9143 renames Scope_Stack.Table (Scope_Stack.Last).
9144 Actions_To_Be_Wrapped (Cleanup);
9146 Set_Cleanup_Actions (Block, Cleanup_Actions);
9147 Cleanup_Actions := No_List;
9150 -- When the transient scope was established, we pushed the entry for the
9151 -- transient scope onto the scope stack, so that the scope was active
9152 -- for the installation of finalizable entities etc. Now we must remove
9153 -- this entry, since we have constructed a proper block.
9158 end Make_Transient_Block;
9160 ------------------------
9161 -- Node_To_Be_Wrapped --
9162 ------------------------
9164 function Node_To_Be_Wrapped return Node_Id is
9166 return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
9167 end Node_To_Be_Wrapped;
9169 ----------------------------
9170 -- Set_Node_To_Be_Wrapped --
9171 ----------------------------
9173 procedure Set_Node_To_Be_Wrapped (N : Node_Id) is
9175 Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := N;
9176 end Set_Node_To_Be_Wrapped;
9178 ----------------------------
9179 -- Store_Actions_In_Scope --
9180 ----------------------------
9182 procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id) is
9183 SE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
9184 Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK);
9187 if No (Actions) then
9190 if Is_List_Member (SE.Node_To_Be_Wrapped) then
9191 Set_Parent (L, Parent (SE.Node_To_Be_Wrapped));
9193 Set_Parent (L, SE.Node_To_Be_Wrapped);
9198 elsif AK = Before then
9199 Insert_List_After_And_Analyze (Last (Actions), L);
9202 Insert_List_Before_And_Analyze (First (Actions), L);
9204 end Store_Actions_In_Scope;
9206 ----------------------------------
9207 -- Store_After_Actions_In_Scope --
9208 ----------------------------------
9210 procedure Store_After_Actions_In_Scope (L : List_Id) is
9212 Store_Actions_In_Scope (After, L);
9213 end Store_After_Actions_In_Scope;
9215 -----------------------------------
9216 -- Store_Before_Actions_In_Scope --
9217 -----------------------------------
9219 procedure Store_Before_Actions_In_Scope (L : List_Id) is
9221 Store_Actions_In_Scope (Before, L);
9222 end Store_Before_Actions_In_Scope;
9224 -----------------------------------
9225 -- Store_Cleanup_Actions_In_Scope --
9226 -----------------------------------
9228 procedure Store_Cleanup_Actions_In_Scope (L : List_Id) is
9230 Store_Actions_In_Scope (Cleanup, L);
9231 end Store_Cleanup_Actions_In_Scope;
9237 procedure Unnest_Block (Decl : Node_Id) is
9238 Loc : constant Source_Ptr := Sloc (Decl);
9240 Local_Body : Node_Id;
9241 Local_Call : Node_Id;
9242 Local_Proc : Entity_Id;
9243 Local_Scop : Entity_Id;
9246 Local_Scop := Entity (Identifier (Decl));
9247 Ent := First_Entity (Local_Scop);
9250 Make_Defining_Identifier (Loc,
9251 Chars => New_Internal_Name ('P'));
9254 Make_Subprogram_Body (Loc,
9256 Make_Procedure_Specification (Loc,
9257 Defining_Unit_Name => Local_Proc),
9258 Declarations => Declarations (Decl),
9259 Handled_Statement_Sequence =>
9260 Handled_Statement_Sequence (Decl));
9262 Rewrite (Decl, Local_Body);
9264 Set_Has_Nested_Subprogram (Local_Proc);
9267 Make_Procedure_Call_Statement (Loc,
9268 Name => New_Occurrence_Of (Local_Proc, Loc));
9270 Insert_After (Decl, Local_Call);
9271 Analyze (Local_Call);
9273 -- The new subprogram has the same scope as the original block
9275 Set_Scope (Local_Proc, Scope (Local_Scop));
9277 -- And the entity list of the new procedure is that of the block
9279 Set_First_Entity (Local_Proc, Ent);
9281 -- Reset the scopes of all the entities to the new procedure
9283 while Present (Ent) loop
9284 Set_Scope (Ent, Local_Proc);
9293 procedure Unnest_Loop (Loop_Stmt : Node_Id) is
9294 Loc : constant Source_Ptr := Sloc (Loop_Stmt);
9296 Local_Body : Node_Id;
9297 Local_Call : Node_Id;
9298 Local_Proc : Entity_Id;
9299 Local_Scop : Entity_Id;
9300 Loop_Copy : constant Node_Id :=
9301 Relocate_Node (Loop_Stmt);
9303 Local_Scop := Entity (Identifier (Loop_Stmt));
9304 Ent := First_Entity (Local_Scop);
9307 Make_Defining_Identifier (Loc,
9308 Chars => New_Internal_Name ('P'));
9311 Make_Subprogram_Body (Loc,
9313 Make_Procedure_Specification (Loc,
9314 Defining_Unit_Name => Local_Proc),
9315 Declarations => Empty_List,
9316 Handled_Statement_Sequence =>
9317 Make_Handled_Sequence_Of_Statements (Loc,
9318 Statements => New_List (Loop_Copy)));
9320 Set_First_Real_Statement
9321 (Handled_Statement_Sequence (Local_Body), Loop_Copy);
9323 Rewrite (Loop_Stmt, Local_Body);
9324 Analyze (Loop_Stmt);
9326 Set_Has_Nested_Subprogram (Local_Proc);
9329 Make_Procedure_Call_Statement (Loc,
9330 Name => New_Occurrence_Of (Local_Proc, Loc));
9332 Insert_After (Loop_Stmt, Local_Call);
9333 Analyze (Local_Call);
9335 -- New procedure has the same scope as the original loop, and the scope
9336 -- of the loop is the new procedure.
9338 Set_Scope (Local_Proc, Scope (Local_Scop));
9339 Set_Scope (Local_Scop, Local_Proc);
9341 -- The entity list of the new procedure is that of the loop
9343 Set_First_Entity (Local_Proc, Ent);
9345 -- Note that the entities associated with the loop don't need to have
9346 -- their Scope fields reset, since they're still associated with the
9347 -- same loop entity that now belongs to the copied loop statement.
9350 --------------------------------
9351 -- Wrap_Transient_Declaration --
9352 --------------------------------
9354 -- If a transient scope has been established during the processing of the
9355 -- Expression of an Object_Declaration, it is not possible to wrap the
9356 -- declaration into a transient block as usual case, otherwise the object
9357 -- would be itself declared in the wrong scope. Therefore, all entities (if
9358 -- any) defined in the transient block are moved to the proper enclosing
9359 -- scope. Furthermore, if they are controlled variables they are finalized
9360 -- right after the declaration. The finalization list of the transient
9361 -- scope is defined as a renaming of the enclosing one so during their
9362 -- initialization they will be attached to the proper finalization list.
9363 -- For instance, the following declaration :
9365 -- X : Typ := F (G (A), G (B));
9367 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
9368 -- is expanded into :
9370 -- X : Typ := [ complex Expression-Action ];
9371 -- [Deep_]Finalize (_v1);
9372 -- [Deep_]Finalize (_v2);
9374 procedure Wrap_Transient_Declaration (N : Node_Id) is
9379 Curr_S := Current_Scope;
9380 Encl_S := Scope (Curr_S);
9382 -- Insert all actions including cleanup generated while analyzing or
9383 -- expanding the transient context back into the tree. Manage the
9384 -- secondary stack when the object declaration appears in a library
9385 -- level package [body].
9387 Insert_Actions_In_Scope_Around
9391 Uses_Sec_Stack (Curr_S)
9392 and then Nkind (N) = N_Object_Declaration
9393 and then Ekind_In (Encl_S, E_Package, E_Package_Body)
9394 and then Is_Library_Level_Entity (Encl_S));
9397 -- Relocate local entities declared within the transient scope to the
9398 -- enclosing scope. This action sets their Is_Public flag accordingly.
9400 Transfer_Entities (Curr_S, Encl_S);
9402 -- Mark the enclosing dynamic scope to ensure that the secondary stack
9403 -- is properly released upon exiting the said scope.
9405 if Uses_Sec_Stack (Curr_S) then
9406 Curr_S := Enclosing_Dynamic_Scope (Curr_S);
9408 -- Do not mark a function that returns on the secondary stack as the
9409 -- reclamation is done by the caller.
9411 if Ekind (Curr_S) = E_Function
9412 and then Requires_Transient_Scope (Etype (Curr_S))
9416 -- Otherwise mark the enclosing dynamic scope
9419 Set_Uses_Sec_Stack (Curr_S);
9420 Check_Restriction (No_Secondary_Stack, N);
9423 end Wrap_Transient_Declaration;
9425 -------------------------------
9426 -- Wrap_Transient_Expression --
9427 -------------------------------
9429 procedure Wrap_Transient_Expression (N : Node_Id) is
9430 Loc : constant Source_Ptr := Sloc (N);
9431 Expr : Node_Id := Relocate_Node (N);
9432 Temp : constant Entity_Id := Make_Temporary (Loc, 'E', N);
9433 Typ : constant Entity_Id := Etype (N);
9440 -- M : constant Mark_Id := SS_Mark;
9441 -- procedure Finalizer is ... (See Build_Finalizer)
9444 -- Temp := <Expr>; -- general case
9445 -- Temp := (if <Expr> then True else False); -- boolean case
9451 -- A special case is made for Boolean expressions so that the back end
9452 -- knows to generate a conditional branch instruction, if running with
9453 -- -fpreserve-control-flow. This ensures that a control-flow change
9454 -- signaling the decision outcome occurs before the cleanup actions.
9456 if Opt.Suppress_Control_Flow_Optimizations
9457 and then Is_Boolean_Type (Typ)
9460 Make_If_Expression (Loc,
9461 Expressions => New_List (
9463 New_Occurrence_Of (Standard_True, Loc),
9464 New_Occurrence_Of (Standard_False, Loc)));
9467 Insert_Actions (N, New_List (
9468 Make_Object_Declaration (Loc,
9469 Defining_Identifier => Temp,
9470 Object_Definition => New_Occurrence_Of (Typ, Loc)),
9472 Make_Transient_Block (Loc,
9474 Make_Assignment_Statement (Loc,
9475 Name => New_Occurrence_Of (Temp, Loc),
9476 Expression => Expr),
9477 Par => Parent (N))));
9479 Rewrite (N, New_Occurrence_Of (Temp, Loc));
9480 Analyze_And_Resolve (N, Typ);
9481 end Wrap_Transient_Expression;
9483 ------------------------------
9484 -- Wrap_Transient_Statement --
9485 ------------------------------
9487 procedure Wrap_Transient_Statement (N : Node_Id) is
9488 Loc : constant Source_Ptr := Sloc (N);
9489 New_Stmt : constant Node_Id := Relocate_Node (N);
9494 -- M : constant Mark_Id := SS_Mark;
9495 -- procedure Finalizer is ... (See Build_Finalizer)
9505 Make_Transient_Block (Loc,
9507 Par => Parent (N)));
9509 -- With the scope stack back to normal, we can call analyze on the
9510 -- resulting block. At this point, the transient scope is being
9511 -- treated like a perfectly normal scope, so there is nothing
9512 -- special about it.
9514 -- Note: Wrap_Transient_Statement is called with the node already
9515 -- analyzed (i.e. Analyzed (N) is True). This is important, since
9516 -- otherwise we would get a recursive processing of the node when
9517 -- we do this Analyze call.
9520 end Wrap_Transient_Statement;