1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
;
129 -- N is a node which may generate a transient scope. Loop over the parent
130 -- pointers of N until we find the appropriate node to wrap. If it returns
131 -- Empty, it means that no transient scope is needed in this context.
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 clean up 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 procedure Check_Visibly_Controlled
354 (Prim
: Final_Primitives
;
356 E
: in out Entity_Id
;
357 Cref
: in out Node_Id
);
358 -- The controlled operation declared for a derived type may not be
359 -- overriding, if the controlled operations of the parent type are hidden,
360 -- for example when the parent is a private type whose full view is
361 -- controlled. For other primitive operations we modify the name of the
362 -- operation to indicate that it is not overriding, but this is not
363 -- possible for Initialize, etc. because they have to be retrievable by
364 -- name. Before generating the proper call to one of these operations we
365 -- check whether Typ is known to be controlled at the point of definition.
366 -- If it is not then we must retrieve the hidden operation of the parent
367 -- and use it instead. This is one case that might be solved more cleanly
368 -- once Overriding pragmas or declarations are in place.
370 function Convert_View
373 Ind
: Pos
:= 1) return Node_Id
;
374 -- Proc is one of the Initialize/Adjust/Finalize operations, and Arg is the
375 -- argument being passed to it. Ind indicates which formal of procedure
376 -- Proc we are trying to match. This function will, if necessary, generate
377 -- a conversion between the partial and full view of Arg to match the type
378 -- of the formal of Proc, or force a conversion to the class-wide type in
379 -- the case where the operation is abstract.
381 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
;
382 -- Given an arbitrary entity, traverse the scope chain looking for the
383 -- first enclosing function. Return Empty if no function was found.
389 Skip_Self
: Boolean := False) return Node_Id
;
390 -- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
391 -- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
392 -- an adjust or finalization call. Wnen flag Skip_Self is set, the related
393 -- action has an effect on the components only (if any).
395 function Make_Deep_Proc
396 (Prim
: Final_Primitives
;
398 Stmts
: List_Id
) return Node_Id
;
399 -- This function generates the tree for Deep_Initialize, Deep_Adjust or
400 -- Deep_Finalize procedures according to the first parameter, these
401 -- procedures operate on the type Typ. The Stmts parameter gives the body
404 function Make_Deep_Array_Body
405 (Prim
: Final_Primitives
;
406 Typ
: Entity_Id
) return List_Id
;
407 -- This function generates the list of statements for implementing
408 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
409 -- the first parameter, these procedures operate on the array type Typ.
411 function Make_Deep_Record_Body
412 (Prim
: Final_Primitives
;
414 Is_Local
: Boolean := False) return List_Id
;
415 -- This function generates the list of statements for implementing
416 -- Deep_Initialize, Deep_Adjust or Deep_Finalize procedures according to
417 -- the first parameter, these procedures operate on the record type Typ.
418 -- Flag Is_Local is used in conjunction with Deep_Finalize to designate
419 -- whether the inner logic should be dictated by state counters.
421 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
;
422 -- Subsidiary to Make_Finalize_Address_Body, Make_Deep_Array_Body and
423 -- Make_Deep_Record_Body. Generate the following statements:
426 -- type Acc_Typ is access all Typ;
427 -- for Acc_Typ'Storage_Size use 0;
429 -- [Deep_]Finalize (Acc_Typ (V).all);
432 --------------------------------
433 -- Allows_Finalization_Master --
434 --------------------------------
436 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean is
437 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean;
438 -- Determine whether entity E is inside a wrapper package created for
439 -- an instance of Ada.Unchecked_Deallocation.
441 ------------------------------
442 -- In_Deallocation_Instance --
443 ------------------------------
445 function In_Deallocation_Instance
(E
: Entity_Id
) return Boolean is
446 Pkg
: constant Entity_Id
:= Scope
(E
);
447 Par
: Node_Id
:= Empty
;
450 if Ekind
(Pkg
) = E_Package
451 and then Present
(Related_Instance
(Pkg
))
452 and then Ekind
(Related_Instance
(Pkg
)) = E_Procedure
454 Par
:= Generic_Parent
(Parent
(Related_Instance
(Pkg
)));
458 and then Chars
(Par
) = Name_Unchecked_Deallocation
459 and then Chars
(Scope
(Par
)) = Name_Ada
460 and then Scope
(Scope
(Par
)) = Standard_Standard
;
464 end In_Deallocation_Instance
;
468 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
469 Ptr_Typ
: constant Entity_Id
:=
470 Root_Type_Of_Full_View
(Base_Type
(Typ
));
472 -- Start of processing for Allows_Finalization_Master
475 -- Certain run-time configurations and targets do not provide support
476 -- for controlled types and therefore do not need masters.
478 if Restriction_Active
(No_Finalization
) then
481 -- Do not consider C and C++ types since it is assumed that the non-Ada
482 -- side will handle their clean up.
484 elsif Convention
(Desig_Typ
) = Convention_C
485 or else Convention
(Desig_Typ
) = Convention_CPP
489 -- Do not consider an access type that returns on the secondary stack
491 elsif Present
(Associated_Storage_Pool
(Ptr_Typ
))
492 and then Is_RTE
(Associated_Storage_Pool
(Ptr_Typ
), RE_SS_Pool
)
496 -- Do not consider an access type that can never allocate an object
498 elsif No_Pool_Assigned
(Ptr_Typ
) then
501 -- Do not consider an access type coming from an Unchecked_Deallocation
502 -- instance. Even though the designated type may be controlled, the
503 -- access type will never participate in any allocations.
505 elsif In_Deallocation_Instance
(Ptr_Typ
) then
508 -- Do not consider a non-library access type when No_Nested_Finalization
509 -- is in effect since finalization masters are controlled objects and if
510 -- created will violate the restriction.
512 elsif Restriction_Active
(No_Nested_Finalization
)
513 and then not Is_Library_Level_Entity
(Ptr_Typ
)
517 -- Do not consider an access type subject to pragma No_Heap_Finalization
518 -- because objects allocated through such a type are not to be finalized
519 -- when the access type goes out of scope.
521 elsif No_Heap_Finalization
(Ptr_Typ
) then
524 -- Do not create finalization masters in GNATprove mode because this
525 -- causes unwanted extra expansion. A compilation in this mode must
526 -- keep the tree as close as possible to the original sources.
528 elsif GNATprove_Mode
then
531 -- Otherwise the access type may use a finalization master
536 end Allows_Finalization_Master
;
538 ----------------------------
539 -- Build_Anonymous_Master --
540 ----------------------------
542 procedure Build_Anonymous_Master
(Ptr_Typ
: Entity_Id
) is
543 function Create_Anonymous_Master
544 (Desig_Typ
: Entity_Id
;
546 Unit_Decl
: Node_Id
) return Entity_Id
;
547 -- Create a new anonymous master for access type Ptr_Typ with designated
548 -- type Desig_Typ. The declaration of the master and its initialization
549 -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
550 -- the entity of Unit_Decl.
552 function Current_Anonymous_Master
553 (Desig_Typ
: Entity_Id
;
554 Unit_Id
: Entity_Id
) return Entity_Id
;
555 -- Find an anonymous master declared within unit Unit_Id which services
556 -- designated type Desig_Typ. If there is no such master, return Empty.
558 -----------------------------
559 -- Create_Anonymous_Master --
560 -----------------------------
562 function Create_Anonymous_Master
563 (Desig_Typ
: Entity_Id
;
565 Unit_Decl
: Node_Id
) return Entity_Id
567 Loc
: constant Source_Ptr
:= Sloc
(Unit_Id
);
578 -- <FM_Id> : Finalization_Master;
580 FM_Id
:= Make_Temporary
(Loc
, 'A');
583 Make_Object_Declaration
(Loc
,
584 Defining_Identifier
=> FM_Id
,
586 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
));
590 -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
593 Make_Procedure_Call_Statement
(Loc
,
595 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
596 Parameter_Associations
=> New_List
(
597 New_Occurrence_Of
(FM_Id
, Loc
),
598 Make_Attribute_Reference
(Loc
,
600 New_Occurrence_Of
(RTE
(RE_Global_Pool_Object
), Loc
),
601 Attribute_Name
=> Name_Unrestricted_Access
)));
603 -- Find the declarative list of the unit
605 if Nkind
(Unit_Decl
) = N_Package_Declaration
then
606 Unit_Spec
:= Specification
(Unit_Decl
);
607 Decls
:= Visible_Declarations
(Unit_Spec
);
611 Set_Visible_Declarations
(Unit_Spec
, Decls
);
614 -- Package body or subprogram case
616 -- ??? A subprogram spec or body that acts as a compilation unit may
617 -- contain a formal parameter of an anonymous access-to-controlled
618 -- type initialized by an allocator.
620 -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
622 -- There is no suitable place to create the master as the subprogram
623 -- is not in a declarative list.
626 Decls
:= Declarations
(Unit_Decl
);
630 Set_Declarations
(Unit_Decl
, Decls
);
634 Prepend_To
(Decls
, FM_Init
);
635 Prepend_To
(Decls
, FM_Decl
);
637 -- Use the scope of the unit when analyzing the declaration of the
638 -- master and its initialization actions.
640 Push_Scope
(Unit_Id
);
645 -- Mark the master as servicing this specific designated type
647 Set_Anonymous_Designated_Type
(FM_Id
, Desig_Typ
);
649 -- Include the anonymous master in the list of existing masters which
650 -- appear in this unit. This effectively creates a mapping between a
651 -- master and a designated type which in turn allows for the reuse of
652 -- masters on a per-unit basis.
654 All_FMs
:= Anonymous_Masters
(Unit_Id
);
657 All_FMs
:= New_Elmt_List
;
658 Set_Anonymous_Masters
(Unit_Id
, All_FMs
);
661 Prepend_Elmt
(FM_Id
, All_FMs
);
664 end Create_Anonymous_Master
;
666 ------------------------------
667 -- Current_Anonymous_Master --
668 ------------------------------
670 function Current_Anonymous_Master
671 (Desig_Typ
: Entity_Id
;
672 Unit_Id
: Entity_Id
) return Entity_Id
674 All_FMs
: constant Elist_Id
:= Anonymous_Masters
(Unit_Id
);
679 -- Inspect the list of anonymous masters declared within the unit
680 -- looking for an existing master which services the same designated
683 if Present
(All_FMs
) then
684 FM_Elmt
:= First_Elmt
(All_FMs
);
685 while Present
(FM_Elmt
) loop
686 FM_Id
:= Node
(FM_Elmt
);
688 -- The currect master services the same designated type. As a
689 -- result the master can be reused and associated with another
690 -- anonymous access-to-controlled type.
692 if Anonymous_Designated_Type
(FM_Id
) = Desig_Typ
then
701 end Current_Anonymous_Master
;
705 Desig_Typ
: Entity_Id
;
707 Priv_View
: Entity_Id
;
711 -- Start of processing for Build_Anonymous_Master
714 -- Nothing to do if the circumstances do not allow for a finalization
717 if not Allows_Finalization_Master
(Ptr_Typ
) then
721 Unit_Decl
:= Unit
(Cunit
(Current_Sem_Unit
));
722 Unit_Id
:= Unique_Defining_Entity
(Unit_Decl
);
724 -- The compilation unit is a package instantiation. In this case the
725 -- anonymous master is associated with the package spec as both the
726 -- spec and body appear at the same level.
728 if Nkind
(Unit_Decl
) = N_Package_Body
729 and then Nkind
(Original_Node
(Unit_Decl
)) = N_Package_Instantiation
731 Unit_Id
:= Corresponding_Spec
(Unit_Decl
);
732 Unit_Decl
:= Unit_Declaration_Node
(Unit_Id
);
735 -- Use the initial declaration of the designated type when it denotes
736 -- the full view of an incomplete or private type. This ensures that
737 -- types with one and two views are treated the same.
739 Desig_Typ
:= Directly_Designated_Type
(Ptr_Typ
);
740 Priv_View
:= Incomplete_Or_Partial_View
(Desig_Typ
);
742 if Present
(Priv_View
) then
743 Desig_Typ
:= Priv_View
;
746 -- Determine whether the current semantic unit already has an anonymous
747 -- master which services the designated type.
749 FM_Id
:= Current_Anonymous_Master
(Desig_Typ
, Unit_Id
);
751 -- If this is not the case, create a new master
754 FM_Id
:= Create_Anonymous_Master
(Desig_Typ
, Unit_Id
, Unit_Decl
);
757 Set_Finalization_Master
(Ptr_Typ
, FM_Id
);
758 end Build_Anonymous_Master
;
760 ----------------------------
761 -- Build_Array_Deep_Procs --
762 ----------------------------
764 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
) is
768 (Prim
=> Initialize_Case
,
770 Stmts
=> Make_Deep_Array_Body
(Initialize_Case
, Typ
)));
772 if not Is_Limited_View
(Typ
) then
775 (Prim
=> Adjust_Case
,
777 Stmts
=> Make_Deep_Array_Body
(Adjust_Case
, Typ
)));
780 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
781 -- suppressed since these routine will not be used.
783 if not Restriction_Active
(No_Finalization
) then
786 (Prim
=> Finalize_Case
,
788 Stmts
=> Make_Deep_Array_Body
(Finalize_Case
, Typ
)));
790 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
792 if not CodePeer_Mode
then
795 (Prim
=> Address_Case
,
797 Stmts
=> Make_Deep_Array_Body
(Address_Case
, Typ
)));
800 end Build_Array_Deep_Procs
;
802 ------------------------------
803 -- Build_Cleanup_Statements --
804 ------------------------------
806 function Build_Cleanup_Statements
808 Additional_Cleanup
: List_Id
) return List_Id
810 Is_Asynchronous_Call
: constant Boolean :=
811 Nkind
(N
) = N_Block_Statement
812 and then Is_Asynchronous_Call_Block
(N
);
813 Is_Master
: constant Boolean :=
814 Nkind
(N
) /= N_Entry_Body
815 and then Is_Task_Master
(N
);
816 Is_Protected_Body
: constant Boolean :=
817 Nkind
(N
) = N_Subprogram_Body
818 and then Is_Protected_Subprogram_Body
(N
);
819 Is_Task_Allocation
: constant Boolean :=
820 Nkind
(N
) = N_Block_Statement
821 and then Is_Task_Allocation_Block
(N
);
822 Is_Task_Body
: constant Boolean :=
823 Nkind
(Original_Node
(N
)) = N_Task_Body
;
825 Loc
: constant Source_Ptr
:= Sloc
(N
);
826 Stmts
: constant List_Id
:= New_List
;
830 if Restricted_Profile
then
832 Build_Runtime_Call
(Loc
, RE_Complete_Restricted_Task
));
834 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Task
));
838 if Restriction_Active
(No_Task_Hierarchy
) = False then
839 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Complete_Master
));
842 -- Add statements to unlock the protected object parameter and to
843 -- undefer abort. If the context is a protected procedure and the object
844 -- has entries, call the entry service routine.
846 -- NOTE: The generated code references _object, a parameter to the
849 elsif Is_Protected_Body
then
851 Spec
: constant Node_Id
:= Parent
(Corresponding_Spec
(N
));
852 Conc_Typ
: Entity_Id
;
854 Param_Typ
: Entity_Id
;
857 -- Find the _object parameter representing the protected object
859 Param
:= First
(Parameter_Specifications
(Spec
));
861 Param_Typ
:= Etype
(Parameter_Type
(Param
));
863 if Ekind
(Param_Typ
) = E_Record_Type
then
864 Conc_Typ
:= Corresponding_Concurrent_Type
(Param_Typ
);
867 exit when No
(Param
) or else Present
(Conc_Typ
);
871 pragma Assert
(Present
(Param
));
873 -- Historical note: In earlier versions of GNAT, there was code
874 -- at this point to generate stuff to service entry queues. It is
875 -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
877 Build_Protected_Subprogram_Call_Cleanup
878 (Specification
(N
), Conc_Typ
, Loc
, Stmts
);
881 -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated
882 -- tasks. Other unactivated tasks are completed by Complete_Task or
885 -- NOTE: The generated code references _chain, a local object
887 elsif Is_Task_Allocation
then
890 -- Expunge_Unactivated_Tasks (_chain);
892 -- where _chain is the list of tasks created by the allocator but not
893 -- yet activated. This list will be empty unless the block completes
897 Make_Procedure_Call_Statement
(Loc
,
900 (RTE
(RE_Expunge_Unactivated_Tasks
), Loc
),
901 Parameter_Associations
=> New_List
(
902 New_Occurrence_Of
(Activation_Chain_Entity
(N
), Loc
))));
904 -- Attempt to cancel an asynchronous entry call whenever the block which
905 -- contains the abortable part is exited.
907 -- NOTE: The generated code references Cnn, a local object
909 elsif Is_Asynchronous_Call
then
911 Cancel_Param
: constant Entity_Id
:=
912 Entry_Cancel_Parameter
(Entity
(Identifier
(N
)));
915 -- If it is of type Communication_Block, this must be a protected
916 -- entry call. Generate:
918 -- if Enqueued (Cancel_Param) then
919 -- Cancel_Protected_Entry_Call (Cancel_Param);
922 if Is_RTE
(Etype
(Cancel_Param
), RE_Communication_Block
) then
924 Make_If_Statement
(Loc
,
926 Make_Function_Call
(Loc
,
928 New_Occurrence_Of
(RTE
(RE_Enqueued
), Loc
),
929 Parameter_Associations
=> New_List
(
930 New_Occurrence_Of
(Cancel_Param
, Loc
))),
932 Then_Statements
=> New_List
(
933 Make_Procedure_Call_Statement
(Loc
,
936 (RTE
(RE_Cancel_Protected_Entry_Call
), Loc
),
937 Parameter_Associations
=> New_List
(
938 New_Occurrence_Of
(Cancel_Param
, Loc
))))));
940 -- Asynchronous delay, generate:
941 -- Cancel_Async_Delay (Cancel_Param);
943 elsif Is_RTE
(Etype
(Cancel_Param
), RE_Delay_Block
) then
945 Make_Procedure_Call_Statement
(Loc
,
947 New_Occurrence_Of
(RTE
(RE_Cancel_Async_Delay
), Loc
),
948 Parameter_Associations
=> New_List
(
949 Make_Attribute_Reference
(Loc
,
951 New_Occurrence_Of
(Cancel_Param
, Loc
),
952 Attribute_Name
=> Name_Unchecked_Access
))));
954 -- Task entry call, generate:
955 -- Cancel_Task_Entry_Call (Cancel_Param);
959 Make_Procedure_Call_Statement
(Loc
,
961 New_Occurrence_Of
(RTE
(RE_Cancel_Task_Entry_Call
), Loc
),
962 Parameter_Associations
=> New_List
(
963 New_Occurrence_Of
(Cancel_Param
, Loc
))));
968 Append_List_To
(Stmts
, Additional_Cleanup
);
970 end Build_Cleanup_Statements
;
972 -----------------------------
973 -- Build_Controlling_Procs --
974 -----------------------------
976 procedure Build_Controlling_Procs
(Typ
: Entity_Id
) is
978 if Is_Array_Type
(Typ
) then
979 Build_Array_Deep_Procs
(Typ
);
980 else pragma Assert
(Is_Record_Type
(Typ
));
981 Build_Record_Deep_Procs
(Typ
);
983 end Build_Controlling_Procs
;
985 -----------------------------
986 -- Build_Exception_Handler --
987 -----------------------------
989 function Build_Exception_Handler
990 (Data
: Finalization_Exception_Data
;
991 For_Library
: Boolean := False) return Node_Id
994 Proc_To_Call
: Entity_Id
;
999 pragma Assert
(Present
(Data
.Raised_Id
));
1001 if Exception_Extra_Info
1002 or else (For_Library
and not Restricted_Profile
)
1004 if Exception_Extra_Info
then
1008 -- Get_Current_Excep.all
1011 Make_Function_Call
(Data
.Loc
,
1013 Make_Explicit_Dereference
(Data
.Loc
,
1016 (RTE
(RE_Get_Current_Excep
), Data
.Loc
)));
1023 Except
:= Make_Null
(Data
.Loc
);
1026 if For_Library
and then not Restricted_Profile
then
1027 Proc_To_Call
:= RTE
(RE_Save_Library_Occurrence
);
1028 Actuals
:= New_List
(Except
);
1031 Proc_To_Call
:= RTE
(RE_Save_Occurrence
);
1033 -- The dereference occurs only when Exception_Extra_Info is true,
1034 -- and therefore Except is not null.
1038 New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
),
1039 Make_Explicit_Dereference
(Data
.Loc
, Except
));
1045 -- if not Raised_Id then
1046 -- Raised_Id := True;
1048 -- Save_Occurrence (E_Id, Get_Current_Excep.all.all);
1050 -- Save_Library_Occurrence (Get_Current_Excep.all);
1055 Make_If_Statement
(Data
.Loc
,
1057 Make_Op_Not
(Data
.Loc
,
1058 Right_Opnd
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
)),
1060 Then_Statements
=> New_List
(
1061 Make_Assignment_Statement
(Data
.Loc
,
1062 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1063 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)),
1065 Make_Procedure_Call_Statement
(Data
.Loc
,
1067 New_Occurrence_Of
(Proc_To_Call
, Data
.Loc
),
1068 Parameter_Associations
=> Actuals
))));
1073 -- Raised_Id := True;
1076 Make_Assignment_Statement
(Data
.Loc
,
1077 Name
=> New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
),
1078 Expression
=> New_Occurrence_Of
(Standard_True
, Data
.Loc
)));
1086 Make_Exception_Handler
(Data
.Loc
,
1087 Exception_Choices
=> New_List
(Make_Others_Choice
(Data
.Loc
)),
1088 Statements
=> Stmts
);
1089 end Build_Exception_Handler
;
1091 -------------------------------
1092 -- Build_Finalization_Master --
1093 -------------------------------
1095 procedure Build_Finalization_Master
1097 For_Lib_Level
: Boolean := False;
1098 For_Private
: Boolean := False;
1099 Context_Scope
: Entity_Id
:= Empty
;
1100 Insertion_Node
: Node_Id
:= Empty
)
1102 procedure Add_Pending_Access_Type
1104 Ptr_Typ
: Entity_Id
);
1105 -- Add access type Ptr_Typ to the pending access type list for type Typ
1107 -----------------------------
1108 -- Add_Pending_Access_Type --
1109 -----------------------------
1111 procedure Add_Pending_Access_Type
1113 Ptr_Typ
: Entity_Id
)
1118 if Present
(Pending_Access_Types
(Typ
)) then
1119 List
:= Pending_Access_Types
(Typ
);
1121 List
:= New_Elmt_List
;
1122 Set_Pending_Access_Types
(Typ
, List
);
1125 Prepend_Elmt
(Ptr_Typ
, List
);
1126 end Add_Pending_Access_Type
;
1130 Desig_Typ
: constant Entity_Id
:= Designated_Type
(Typ
);
1132 Ptr_Typ
: constant Entity_Id
:= Root_Type_Of_Full_View
(Base_Type
(Typ
));
1133 -- A finalization master created for a named access type is associated
1134 -- with the full view (if applicable) as a consequence of freezing. The
1135 -- full view criteria does not apply to anonymous access types because
1136 -- those cannot have a private and a full view.
1138 -- Start of processing for Build_Finalization_Master
1141 -- Nothing to do if the circumstances do not allow for a finalization
1144 if not Allows_Finalization_Master
(Typ
) then
1147 -- Various machinery such as freezing may have already created a
1148 -- finalization master.
1150 elsif Present
(Finalization_Master
(Ptr_Typ
)) then
1155 Actions
: constant List_Id
:= New_List
;
1156 Loc
: constant Source_Ptr
:= Sloc
(Ptr_Typ
);
1157 Fin_Mas_Id
: Entity_Id
;
1158 Pool_Id
: Entity_Id
;
1161 -- Source access types use fixed master names since the master is
1162 -- inserted in the same source unit only once. The only exception to
1163 -- this are instances using the same access type as generic actual.
1165 if Comes_From_Source
(Ptr_Typ
) and then not Inside_A_Generic
then
1167 Make_Defining_Identifier
(Loc
,
1168 Chars
=> New_External_Name
(Chars
(Ptr_Typ
), "FM"));
1170 -- Internally generated access types use temporaries as their names
1171 -- due to possible collision with identical names coming from other
1175 Fin_Mas_Id
:= Make_Temporary
(Loc
, 'F');
1178 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
1181 -- <Ptr_Typ>FM : aliased Finalization_Master;
1184 Make_Object_Declaration
(Loc
,
1185 Defining_Identifier
=> Fin_Mas_Id
,
1186 Aliased_Present
=> True,
1187 Object_Definition
=>
1188 New_Occurrence_Of
(RTE
(RE_Finalization_Master
), Loc
)));
1190 -- Set the associated pool and primitive Finalize_Address of the new
1191 -- finalization master.
1193 -- The access type has a user-defined storage pool, use it
1195 if Present
(Associated_Storage_Pool
(Ptr_Typ
)) then
1196 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
1198 -- Otherwise the default choice is the global storage pool
1201 Pool_Id
:= RTE
(RE_Global_Pool_Object
);
1202 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
1206 -- Set_Base_Pool (<Ptr_Typ>FM, Pool_Id'Unchecked_Access);
1209 Make_Procedure_Call_Statement
(Loc
,
1211 New_Occurrence_Of
(RTE
(RE_Set_Base_Pool
), Loc
),
1212 Parameter_Associations
=> New_List
(
1213 New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
1214 Make_Attribute_Reference
(Loc
,
1215 Prefix
=> New_Occurrence_Of
(Pool_Id
, Loc
),
1216 Attribute_Name
=> Name_Unrestricted_Access
))));
1218 -- Finalize_Address is not generated in CodePeer mode because the
1219 -- body contains address arithmetic. Skip this step.
1221 if CodePeer_Mode
then
1224 -- Associate the Finalize_Address primitive of the designated type
1225 -- with the finalization master of the access type. The designated
1226 -- type must be forzen as Finalize_Address is generated when the
1227 -- freeze node is expanded.
1229 elsif Is_Frozen
(Desig_Typ
)
1230 and then Present
(Finalize_Address
(Desig_Typ
))
1232 -- The finalization master of an anonymous access type may need
1233 -- to be inserted in a specific place in the tree. For instance:
1237 -- <finalization master of "access Comp_Typ">
1239 -- type Rec_Typ is record
1240 -- Comp : access Comp_Typ;
1243 -- <freeze node for Comp_Typ>
1244 -- <freeze node for Rec_Typ>
1246 -- Due to this oddity, the anonymous access type is stored for
1247 -- later processing (see below).
1249 and then Ekind
(Ptr_Typ
) /= E_Anonymous_Access_Type
1252 -- Set_Finalize_Address
1253 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
1256 Make_Set_Finalize_Address_Call
1258 Ptr_Typ
=> Ptr_Typ
));
1260 -- Otherwise the designated type is either anonymous access or a
1261 -- Taft-amendment type and has not been frozen. Store the access
1262 -- type for later processing (see Freeze_Type).
1265 Add_Pending_Access_Type
(Desig_Typ
, Ptr_Typ
);
1268 -- A finalization master created for an access designating a type
1269 -- with private components is inserted before a context-dependent
1274 -- At this point both the scope of the context and the insertion
1275 -- mode must be known.
1277 pragma Assert
(Present
(Context_Scope
));
1278 pragma Assert
(Present
(Insertion_Node
));
1280 Push_Scope
(Context_Scope
);
1282 -- Treat use clauses as declarations and insert directly in front
1285 if Nkind_In
(Insertion_Node
, N_Use_Package_Clause
,
1288 Insert_List_Before_And_Analyze
(Insertion_Node
, Actions
);
1290 Insert_Actions
(Insertion_Node
, Actions
);
1295 -- The finalization master belongs to an access result type related
1296 -- to a build-in-place function call used to initialize a library
1297 -- level object. The master must be inserted in front of the access
1298 -- result type declaration denoted by Insertion_Node.
1300 elsif For_Lib_Level
then
1301 pragma Assert
(Present
(Insertion_Node
));
1302 Insert_Actions
(Insertion_Node
, Actions
);
1304 -- Otherwise the finalization master and its initialization become a
1305 -- part of the freeze node.
1308 Append_Freeze_Actions
(Ptr_Typ
, Actions
);
1311 end Build_Finalization_Master
;
1313 ---------------------
1314 -- Build_Finalizer --
1315 ---------------------
1317 procedure Build_Finalizer
1319 Clean_Stmts
: List_Id
;
1320 Mark_Id
: Entity_Id
;
1321 Top_Decls
: List_Id
;
1322 Defer_Abort
: Boolean;
1323 Fin_Id
: out Entity_Id
)
1325 Acts_As_Clean
: constant Boolean :=
1328 (Present
(Clean_Stmts
)
1329 and then Is_Non_Empty_List
(Clean_Stmts
));
1330 Exceptions_OK
: constant Boolean := Exceptions_In_Finalization_OK
;
1331 For_Package_Body
: constant Boolean := Nkind
(N
) = N_Package_Body
;
1332 For_Package_Spec
: constant Boolean := Nkind
(N
) = N_Package_Declaration
;
1333 For_Package
: constant Boolean :=
1334 For_Package_Body
or else For_Package_Spec
;
1335 Loc
: constant Source_Ptr
:= Sloc
(N
);
1337 -- NOTE: Local variable declarations are conservative and do not create
1338 -- structures right from the start. Entities and lists are created once
1339 -- it has been established that N has at least one controlled object.
1341 Components_Built
: Boolean := False;
1342 -- A flag used to avoid double initialization of entities and lists. If
1343 -- the flag is set then the following variables have been initialized:
1349 Counter_Id
: Entity_Id
:= Empty
;
1350 Counter_Val
: Nat
:= 0;
1351 -- Name and value of the state counter
1353 Decls
: List_Id
:= No_List
;
1354 -- Declarative region of N (if available). If N is a package declaration
1355 -- Decls denotes the visible declarations.
1357 Finalizer_Data
: Finalization_Exception_Data
;
1358 -- Data for the exception
1360 Finalizer_Decls
: List_Id
:= No_List
;
1361 -- Local variable declarations. This list holds the label declarations
1362 -- of all jump block alternatives as well as the declaration of the
1363 -- local exception occurrence and the raised flag:
1364 -- E : Exception_Occurrence;
1365 -- Raised : Boolean := False;
1366 -- L<counter value> : label;
1368 Finalizer_Insert_Nod
: Node_Id
:= Empty
;
1369 -- Insertion point for the finalizer body. Depending on the context
1370 -- (Nkind of N) and the individual grouping of controlled objects, this
1371 -- node may denote a package declaration or body, package instantiation,
1372 -- block statement or a counter update statement.
1374 Finalizer_Stmts
: List_Id
:= No_List
;
1375 -- The statement list of the finalizer body. It contains the following:
1377 -- Abort_Defer; -- Added if abort is allowed
1378 -- <call to Prev_At_End> -- Added if exists
1379 -- <cleanup statements> -- Added if Acts_As_Clean
1380 -- <jump block> -- Added if Has_Ctrl_Objs
1381 -- <finalization statements> -- Added if Has_Ctrl_Objs
1382 -- <stack release> -- Added if Mark_Id exists
1383 -- Abort_Undefer; -- Added if abort is allowed
1385 Has_Ctrl_Objs
: Boolean := False;
1386 -- A general flag which denotes whether N has at least one controlled
1389 Has_Tagged_Types
: Boolean := False;
1390 -- A general flag which indicates whether N has at least one library-
1391 -- level tagged type declaration.
1393 HSS
: Node_Id
:= Empty
;
1394 -- The sequence of statements of N (if available)
1396 Jump_Alts
: List_Id
:= No_List
;
1397 -- Jump block alternatives. Depending on the value of the state counter,
1398 -- the control flow jumps to a sequence of finalization statements. This
1399 -- list contains the following:
1401 -- when <counter value> =>
1402 -- goto L<counter value>;
1404 Jump_Block_Insert_Nod
: Node_Id
:= Empty
;
1405 -- Specific point in the finalizer statements where the jump block is
1408 Last_Top_Level_Ctrl_Construct
: Node_Id
:= Empty
;
1409 -- The last controlled construct encountered when processing the top
1410 -- level lists of N. This can be a nested package, an instantiation or
1411 -- an object declaration.
1413 Prev_At_End
: Entity_Id
:= Empty
;
1414 -- The previous at end procedure of the handled statements block of N
1416 Priv_Decls
: List_Id
:= No_List
;
1417 -- The private declarations of N if N is a package declaration
1419 Spec_Id
: Entity_Id
:= Empty
;
1420 Spec_Decls
: List_Id
:= Top_Decls
;
1421 Stmts
: List_Id
:= No_List
;
1423 Tagged_Type_Stmts
: List_Id
:= No_List
;
1424 -- Contains calls to Ada.Tags.Unregister_Tag for all library-level
1425 -- tagged types found in N.
1427 -----------------------
1428 -- Local subprograms --
1429 -----------------------
1431 procedure Build_Components
;
1432 -- Create all entites and initialize all lists used in the creation of
1435 procedure Create_Finalizer
;
1436 -- Create the spec and body of the finalizer and insert them in the
1437 -- proper place in the tree depending on the context.
1439 procedure Process_Declarations
1441 Preprocess
: Boolean := False;
1442 Top_Level
: Boolean := False);
1443 -- Inspect a list of declarations or statements which may contain
1444 -- objects that need finalization. When flag Preprocess is set, the
1445 -- routine will simply count the total number of controlled objects in
1446 -- Decls. Flag Top_Level denotes whether the processing is done for
1447 -- objects in nested package declarations or instances.
1449 procedure Process_Object_Declaration
1451 Has_No_Init
: Boolean := False;
1452 Is_Protected
: Boolean := False);
1453 -- Generate all the machinery associated with the finalization of a
1454 -- single object. Flag Has_No_Init is used to denote certain contexts
1455 -- where Decl does not have initialization call(s). Flag Is_Protected
1456 -- is set when Decl denotes a simple protected object.
1458 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
);
1459 -- Generate all the code necessary to unregister the external tag of a
1462 ----------------------
1463 -- Build_Components --
1464 ----------------------
1466 procedure Build_Components
is
1467 Counter_Decl
: Node_Id
;
1468 Counter_Typ
: Entity_Id
;
1469 Counter_Typ_Decl
: Node_Id
;
1472 pragma Assert
(Present
(Decls
));
1474 -- This routine might be invoked several times when dealing with
1475 -- constructs that have two lists (either two declarative regions
1476 -- or declarations and statements). Avoid double initialization.
1478 if Components_Built
then
1482 Components_Built
:= True;
1484 if Has_Ctrl_Objs
then
1486 -- Create entities for the counter, its type, the local exception
1487 -- and the raised flag.
1489 Counter_Id
:= Make_Temporary
(Loc
, 'C');
1490 Counter_Typ
:= Make_Temporary
(Loc
, 'T');
1492 Finalizer_Decls
:= New_List
;
1494 Build_Object_Declarations
1495 (Finalizer_Data
, Finalizer_Decls
, Loc
, For_Package
);
1497 -- Since the total number of controlled objects is always known,
1498 -- build a subtype of Natural with precise bounds. This allows
1499 -- the backend to optimize the case statement. Generate:
1501 -- subtype Tnn is Natural range 0 .. Counter_Val;
1504 Make_Subtype_Declaration
(Loc
,
1505 Defining_Identifier
=> Counter_Typ
,
1506 Subtype_Indication
=>
1507 Make_Subtype_Indication
(Loc
,
1508 Subtype_Mark
=> New_Occurrence_Of
(Standard_Natural
, Loc
),
1510 Make_Range_Constraint
(Loc
,
1514 Make_Integer_Literal
(Loc
, Uint_0
),
1516 Make_Integer_Literal
(Loc
, Counter_Val
)))));
1518 -- Generate the declaration of the counter itself:
1520 -- Counter : Integer := 0;
1523 Make_Object_Declaration
(Loc
,
1524 Defining_Identifier
=> Counter_Id
,
1525 Object_Definition
=> New_Occurrence_Of
(Counter_Typ
, Loc
),
1526 Expression
=> Make_Integer_Literal
(Loc
, 0));
1528 -- Set the type of the counter explicitly to prevent errors when
1529 -- examining object declarations later on.
1531 Set_Etype
(Counter_Id
, Counter_Typ
);
1533 -- The counter and its type are inserted before the source
1534 -- declarations of N.
1536 Prepend_To
(Decls
, Counter_Decl
);
1537 Prepend_To
(Decls
, Counter_Typ_Decl
);
1539 -- The counter and its associated type must be manually analyzed
1540 -- since N has already been analyzed. Use the scope of the spec
1541 -- when inserting in a package.
1544 Push_Scope
(Spec_Id
);
1545 Analyze
(Counter_Typ_Decl
);
1546 Analyze
(Counter_Decl
);
1550 Analyze
(Counter_Typ_Decl
);
1551 Analyze
(Counter_Decl
);
1554 Jump_Alts
:= New_List
;
1557 -- If the context requires additional clean up, the finalization
1558 -- machinery is added after the clean up code.
1560 if Acts_As_Clean
then
1561 Finalizer_Stmts
:= Clean_Stmts
;
1562 Jump_Block_Insert_Nod
:= Last
(Finalizer_Stmts
);
1564 Finalizer_Stmts
:= New_List
;
1567 if Has_Tagged_Types
then
1568 Tagged_Type_Stmts
:= New_List
;
1570 end Build_Components
;
1572 ----------------------
1573 -- Create_Finalizer --
1574 ----------------------
1576 procedure Create_Finalizer
is
1577 function New_Finalizer_Name
return Name_Id
;
1578 -- Create a fully qualified name of a package spec or body finalizer.
1579 -- The generated name is of the form: xx__yy__finalize_[spec|body].
1581 ------------------------
1582 -- New_Finalizer_Name --
1583 ------------------------
1585 function New_Finalizer_Name
return Name_Id
is
1586 procedure New_Finalizer_Name
(Id
: Entity_Id
);
1587 -- Place "__<name-of-Id>" in the name buffer. If the identifier
1588 -- has a non-standard scope, process the scope first.
1590 ------------------------
1591 -- New_Finalizer_Name --
1592 ------------------------
1594 procedure New_Finalizer_Name
(Id
: Entity_Id
) is
1596 if Scope
(Id
) = Standard_Standard
then
1597 Get_Name_String
(Chars
(Id
));
1600 New_Finalizer_Name
(Scope
(Id
));
1601 Add_Str_To_Name_Buffer
("__");
1602 Add_Str_To_Name_Buffer
(Get_Name_String
(Chars
(Id
)));
1604 end New_Finalizer_Name
;
1606 -- Start of processing for New_Finalizer_Name
1609 -- Create the fully qualified name of the enclosing scope
1611 New_Finalizer_Name
(Spec_Id
);
1614 -- __finalize_[spec|body]
1616 Add_Str_To_Name_Buffer
("__finalize_");
1618 if For_Package_Spec
then
1619 Add_Str_To_Name_Buffer
("spec");
1621 Add_Str_To_Name_Buffer
("body");
1625 end New_Finalizer_Name
;
1629 Body_Id
: Entity_Id
;
1632 Jump_Block
: Node_Id
;
1634 Label_Id
: Entity_Id
;
1636 -- Start of processing for Create_Finalizer
1639 -- Step 1: Creation of the finalizer name
1641 -- Packages must use a distinct name for their finalizers since the
1642 -- binder will have to generate calls to them by name. The name is
1643 -- of the following form:
1645 -- xx__yy__finalize_[spec|body]
1648 Fin_Id
:= Make_Defining_Identifier
(Loc
, New_Finalizer_Name
);
1649 Set_Has_Qualified_Name
(Fin_Id
);
1650 Set_Has_Fully_Qualified_Name
(Fin_Id
);
1652 -- The default name is _finalizer
1656 Make_Defining_Identifier
(Loc
,
1657 Chars
=> New_External_Name
(Name_uFinalizer
));
1659 -- The visibility semantics of AT_END handlers force a strange
1660 -- separation of spec and body for stack-related finalizers:
1662 -- declare : Enclosing_Scope
1663 -- procedure _finalizer;
1665 -- <controlled objects>
1666 -- procedure _finalizer is
1672 -- Both spec and body are within the same construct and scope, but
1673 -- the body is part of the handled sequence of statements. This
1674 -- placement confuses the elaboration mechanism on targets where
1675 -- AT_END handlers are expanded into "when all others" handlers:
1678 -- when all others =>
1679 -- _finalizer; -- appears to require elab checks
1684 -- Since the compiler guarantees that the body of a _finalizer is
1685 -- always inserted in the same construct where the AT_END handler
1686 -- resides, there is no need for elaboration checks.
1688 Set_Kill_Elaboration_Checks
(Fin_Id
);
1690 -- Inlining the finalizer produces a substantial speedup at -O2.
1691 -- It is inlined by default at -O3. Either way, it is called
1692 -- exactly twice (once on the normal path, and once for
1693 -- exceptions/abort), so this won't bloat the code too much.
1695 Set_Is_Inlined
(Fin_Id
);
1698 -- Step 2: Creation of the finalizer specification
1701 -- procedure Fin_Id;
1704 Make_Subprogram_Declaration
(Loc
,
1706 Make_Procedure_Specification
(Loc
,
1707 Defining_Unit_Name
=> Fin_Id
));
1709 -- Step 3: Creation of the finalizer body
1711 if Has_Ctrl_Objs
then
1713 -- Add L0, the default destination to the jump block
1715 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
1716 Set_Entity
(Label_Id
,
1717 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
1718 Label
:= Make_Label
(Loc
, Label_Id
);
1723 Prepend_To
(Finalizer_Decls
,
1724 Make_Implicit_Label_Declaration
(Loc
,
1725 Defining_Identifier
=> Entity
(Label_Id
),
1726 Label_Construct
=> Label
));
1732 Append_To
(Jump_Alts
,
1733 Make_Case_Statement_Alternative
(Loc
,
1734 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1735 Statements
=> New_List
(
1736 Make_Goto_Statement
(Loc
,
1737 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
1742 Append_To
(Finalizer_Stmts
, Label
);
1744 -- Create the jump block which controls the finalization flow
1745 -- depending on the value of the state counter.
1748 Make_Case_Statement
(Loc
,
1749 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
1750 Alternatives
=> Jump_Alts
);
1752 if Acts_As_Clean
and then Present
(Jump_Block_Insert_Nod
) then
1753 Insert_After
(Jump_Block_Insert_Nod
, Jump_Block
);
1755 Prepend_To
(Finalizer_Stmts
, Jump_Block
);
1759 -- Add the library-level tagged type unregistration machinery before
1760 -- the jump block circuitry. This ensures that external tags will be
1761 -- removed even if a finalization exception occurs at some point.
1763 if Has_Tagged_Types
then
1764 Prepend_List_To
(Finalizer_Stmts
, Tagged_Type_Stmts
);
1767 -- Add a call to the previous At_End handler if it exists. The call
1768 -- must always precede the jump block.
1770 if Present
(Prev_At_End
) then
1771 Prepend_To
(Finalizer_Stmts
,
1772 Make_Procedure_Call_Statement
(Loc
, Prev_At_End
));
1774 -- Clear the At_End handler since we have already generated the
1775 -- proper replacement call for it.
1777 Set_At_End_Proc
(HSS
, Empty
);
1780 -- Release the secondary stack mark
1782 if Present
(Mark_Id
) then
1783 Append_To
(Finalizer_Stmts
, Build_SS_Release_Call
(Loc
, Mark_Id
));
1786 -- Protect the statements with abort defer/undefer. This is only when
1787 -- aborts are allowed and the clean up statements require deferral or
1788 -- there are controlled objects to be finalized. Note that the abort
1789 -- defer/undefer pair does not require an extra block because each
1790 -- finalization exception is caught in its corresponding finalization
1791 -- block. As a result, the call to Abort_Defer always takes place.
1793 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1794 Prepend_To
(Finalizer_Stmts
,
1795 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
1797 Append_To
(Finalizer_Stmts
,
1798 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
1801 -- The local exception does not need to be reraised for library-level
1802 -- finalizers. Note that this action must be carried out after object
1803 -- clean up, secondary stack release and abort undeferral. Generate:
1805 -- if Raised and then not Abort then
1806 -- Raise_From_Controlled_Operation (E);
1809 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1810 Append_To
(Finalizer_Stmts
,
1811 Build_Raise_Statement
(Finalizer_Data
));
1815 -- procedure Fin_Id is
1816 -- Abort : constant Boolean := Triggered_By_Abort;
1818 -- Abort : constant Boolean := False; -- no abort
1820 -- E : Exception_Occurrence; -- All added if flag
1821 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1827 -- Abort_Defer; -- Added if abort is allowed
1828 -- <call to Prev_At_End> -- Added if exists
1829 -- <cleanup statements> -- Added if Acts_As_Clean
1830 -- <jump block> -- Added if Has_Ctrl_Objs
1831 -- <finalization statements> -- Added if Has_Ctrl_Objs
1832 -- <stack release> -- Added if Mark_Id exists
1833 -- Abort_Undefer; -- Added if abort is allowed
1834 -- <exception propagation> -- Added if Has_Ctrl_Objs
1837 -- Create the body of the finalizer
1839 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1842 Set_Has_Qualified_Name
(Body_Id
);
1843 Set_Has_Fully_Qualified_Name
(Body_Id
);
1847 Make_Subprogram_Body
(Loc
,
1849 Make_Procedure_Specification
(Loc
,
1850 Defining_Unit_Name
=> Body_Id
),
1851 Declarations
=> Finalizer_Decls
,
1852 Handled_Statement_Sequence
=>
1853 Make_Handled_Sequence_Of_Statements
(Loc
,
1854 Statements
=> Finalizer_Stmts
));
1856 -- Step 4: Spec and body insertion, analysis
1860 -- If the package spec has private declarations, the finalizer
1861 -- body must be added to the end of the list in order to have
1862 -- visibility of all private controlled objects.
1864 if For_Package_Spec
then
1865 if Present
(Priv_Decls
) then
1866 Append_To
(Priv_Decls
, Fin_Spec
);
1867 Append_To
(Priv_Decls
, Fin_Body
);
1869 Append_To
(Decls
, Fin_Spec
);
1870 Append_To
(Decls
, Fin_Body
);
1873 -- For package bodies, both the finalizer spec and body are
1874 -- inserted at the end of the package declarations.
1877 Append_To
(Decls
, Fin_Spec
);
1878 Append_To
(Decls
, Fin_Body
);
1881 -- Push the name of the package
1883 Push_Scope
(Spec_Id
);
1891 -- Create the spec for the finalizer. The At_End handler must be
1892 -- able to call the body which resides in a nested structure.
1896 -- procedure Fin_Id; -- Spec
1898 -- <objects and possibly statements>
1899 -- procedure Fin_Id is ... -- Body
1902 -- Fin_Id; -- At_End handler
1905 pragma Assert
(Present
(Spec_Decls
));
1907 Append_To
(Spec_Decls
, Fin_Spec
);
1910 -- When the finalizer acts solely as a clean up routine, the body
1911 -- is inserted right after the spec.
1913 if Acts_As_Clean
and not Has_Ctrl_Objs
then
1914 Insert_After
(Fin_Spec
, Fin_Body
);
1916 -- In all other cases the body is inserted after either:
1918 -- 1) The counter update statement of the last controlled object
1919 -- 2) The last top level nested controlled package
1920 -- 3) The last top level controlled instantiation
1923 -- Manually freeze the spec. This is somewhat of a hack because
1924 -- a subprogram is frozen when its body is seen and the freeze
1925 -- node appears right before the body. However, in this case,
1926 -- the spec must be frozen earlier since the At_End handler
1927 -- must be able to call it.
1930 -- procedure Fin_Id; -- Spec
1931 -- [Fin_Id] -- Freeze node
1935 -- Fin_Id; -- At_End handler
1938 Ensure_Freeze_Node
(Fin_Id
);
1939 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
1940 Set_Is_Frozen
(Fin_Id
);
1942 -- In the case where the last construct to contain a controlled
1943 -- object is either a nested package, an instantiation or a
1944 -- freeze node, the body must be inserted directly after the
1947 if Nkind_In
(Last_Top_Level_Ctrl_Construct
,
1949 N_Package_Declaration
,
1952 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
1955 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
1958 Analyze
(Fin_Body
, Suppress
=> All_Checks
);
1960 end Create_Finalizer
;
1962 --------------------------
1963 -- Process_Declarations --
1964 --------------------------
1966 procedure Process_Declarations
1968 Preprocess
: Boolean := False;
1969 Top_Level
: Boolean := False)
1974 Obj_Typ
: Entity_Id
;
1975 Pack_Id
: Entity_Id
;
1979 Old_Counter_Val
: Nat
;
1980 -- This variable is used to determine whether a nested package or
1981 -- instance contains at least one controlled object.
1983 procedure Processing_Actions
1984 (Has_No_Init
: Boolean := False;
1985 Is_Protected
: Boolean := False);
1986 -- Depending on the mode of operation of Process_Declarations, either
1987 -- increment the controlled object counter, set the controlled object
1988 -- flag and store the last top level construct or process the current
1989 -- declaration. Flag Has_No_Init is used to propagate scenarios where
1990 -- the current declaration may not have initialization proc(s). Flag
1991 -- Is_Protected should be set when the current declaration denotes a
1992 -- simple protected object.
1994 ------------------------
1995 -- Processing_Actions --
1996 ------------------------
1998 procedure Processing_Actions
1999 (Has_No_Init
: Boolean := False;
2000 Is_Protected
: Boolean := False)
2003 -- Library-level tagged type
2005 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2007 Has_Tagged_Types
:= True;
2009 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2010 Last_Top_Level_Ctrl_Construct
:= Decl
;
2014 Process_Tagged_Type_Declaration
(Decl
);
2017 -- Controlled object declaration
2021 Counter_Val
:= Counter_Val
+ 1;
2022 Has_Ctrl_Objs
:= True;
2024 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2025 Last_Top_Level_Ctrl_Construct
:= Decl
;
2029 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
2032 end Processing_Actions
;
2034 -- Start of processing for Process_Declarations
2037 if No
(Decls
) or else Is_Empty_List
(Decls
) then
2041 -- Process all declarations in reverse order
2043 Decl
:= Last_Non_Pragma
(Decls
);
2044 while Present
(Decl
) loop
2046 -- Library-level tagged types
2048 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2049 Typ
:= Defining_Identifier
(Decl
);
2051 -- Ignored Ghost types do not need any cleanup actions because
2052 -- they will not appear in the final tree.
2054 if Is_Ignored_Ghost_Entity
(Typ
) then
2057 elsif Is_Tagged_Type
(Typ
)
2058 and then Is_Library_Level_Entity
(Typ
)
2059 and then Convention
(Typ
) = Convention_Ada
2060 and then Present
(Access_Disp_Table
(Typ
))
2061 and then RTE_Available
(RE_Register_Tag
)
2062 and then not Is_Abstract_Type
(Typ
)
2063 and then not No_Run_Time_Mode
2068 -- Regular object declarations
2070 elsif Nkind
(Decl
) = N_Object_Declaration
then
2071 Obj_Id
:= Defining_Identifier
(Decl
);
2072 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2073 Expr
:= Expression
(Decl
);
2075 -- Bypass any form of processing for objects which have their
2076 -- finalization disabled. This applies only to objects at the
2079 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2082 -- Finalization of transient objects are treated separately in
2083 -- order to handle sensitive cases. These include:
2085 -- * Aggregate expansion
2086 -- * If, case, and expression with actions expansion
2087 -- * Transient scopes
2089 -- If one of those contexts has marked the transient object as
2090 -- ignored, do not generate finalization actions for it.
2092 elsif Is_Finalized_Transient
(Obj_Id
)
2093 or else Is_Ignored_Transient
(Obj_Id
)
2097 -- Ignored Ghost objects do not need any cleanup actions
2098 -- because they will not appear in the final tree.
2100 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2103 -- The object is of the form:
2104 -- Obj : [constant] Typ [:= Expr];
2106 -- Do not process tag-to-class-wide conversions because they do
2107 -- not yield an object. Do not process the incomplete view of a
2108 -- deferred constant. Note that an object initialized by means
2109 -- of a build-in-place function call may appear as a deferred
2110 -- constant after expansion activities. These kinds of objects
2111 -- must be finalized.
2113 elsif not Is_Imported
(Obj_Id
)
2114 and then Needs_Finalization
(Obj_Typ
)
2115 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
2116 and then not (Ekind
(Obj_Id
) = E_Constant
2117 and then not Has_Completion
(Obj_Id
)
2118 and then No
(BIP_Initialization_Call
(Obj_Id
)))
2122 -- The object is of the form:
2123 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2125 -- Obj : Access_Typ :=
2126 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2128 elsif Is_Access_Type
(Obj_Typ
)
2129 and then Needs_Finalization
2130 (Available_View
(Designated_Type
(Obj_Typ
)))
2131 and then Present
(Expr
)
2133 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
2135 (Is_Non_BIP_Func_Call
(Expr
)
2136 and then not Is_Related_To_Func_Return
(Obj_Id
)))
2138 Processing_Actions
(Has_No_Init
=> True);
2140 -- Processing for "hook" objects generated for transient
2141 -- objects declared inside an Expression_With_Actions.
2143 elsif Is_Access_Type
(Obj_Typ
)
2144 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2145 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2146 N_Object_Declaration
2148 Processing_Actions
(Has_No_Init
=> True);
2150 -- Process intermediate results of an if expression with one
2151 -- of the alternatives using a controlled function call.
2153 elsif Is_Access_Type
(Obj_Typ
)
2154 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2155 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2156 N_Defining_Identifier
2157 and then Present
(Expr
)
2158 and then Nkind
(Expr
) = N_Null
2160 Processing_Actions
(Has_No_Init
=> True);
2162 -- Simple protected objects which use type System.Tasking.
2163 -- Protected_Objects.Protection to manage their locks should
2164 -- be treated as controlled since they require manual cleanup.
2165 -- The only exception is illustrated in the following example:
2168 -- type Ctrl is new Controlled ...
2169 -- procedure Finalize (Obj : in out Ctrl);
2173 -- package body Pkg is
2174 -- protected Prot is
2175 -- procedure Do_Something (Obj : in out Ctrl);
2178 -- protected body Prot is
2179 -- procedure Do_Something (Obj : in out Ctrl) is ...
2182 -- procedure Finalize (Obj : in out Ctrl) is
2184 -- Prot.Do_Something (Obj);
2188 -- Since for the most part entities in package bodies depend on
2189 -- those in package specs, Prot's lock should be cleaned up
2190 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2191 -- This act however attempts to invoke Do_Something and fails
2192 -- because the lock has disappeared.
2194 elsif Ekind
(Obj_Id
) = E_Variable
2195 and then not In_Library_Level_Package_Body
(Obj_Id
)
2196 and then (Is_Simple_Protected_Type
(Obj_Typ
)
2197 or else Has_Simple_Protected_Object
(Obj_Typ
))
2199 Processing_Actions
(Is_Protected
=> True);
2202 -- Specific cases of object renamings
2204 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2205 Obj_Id
:= Defining_Identifier
(Decl
);
2206 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2208 -- Bypass any form of processing for objects which have their
2209 -- finalization disabled. This applies only to objects at the
2212 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2215 -- Ignored Ghost object renamings do not need any cleanup
2216 -- actions because they will not appear in the final tree.
2218 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2221 -- Return object of a build-in-place function. This case is
2222 -- recognized and marked by the expansion of an extended return
2223 -- statement (see Expand_N_Extended_Return_Statement).
2225 elsif Needs_Finalization
(Obj_Typ
)
2226 and then Is_Return_Object
(Obj_Id
)
2227 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2229 Processing_Actions
(Has_No_Init
=> True);
2231 -- Detect a case where a source object has been initialized by
2232 -- a controlled function call or another object which was later
2233 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
2235 -- Obj1 : CW_Type := Src_Obj;
2236 -- Obj2 : CW_Type := Function_Call (...);
2238 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
2239 -- Tmp : ... := Function_Call (...)'reference;
2240 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
2242 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
2243 Processing_Actions
(Has_No_Init
=> True);
2246 -- Inspect the freeze node of an access-to-controlled type and
2247 -- look for a delayed finalization master. This case arises when
2248 -- the freeze actions are inserted at a later time than the
2249 -- expansion of the context. Since Build_Finalizer is never called
2250 -- on a single construct twice, the master will be ultimately
2251 -- left out and never finalized. This is also needed for freeze
2252 -- actions of designated types themselves, since in some cases the
2253 -- finalization master is associated with a designated type's
2254 -- freeze node rather than that of the access type (see handling
2255 -- for freeze actions in Build_Finalization_Master).
2257 elsif Nkind
(Decl
) = N_Freeze_Entity
2258 and then Present
(Actions
(Decl
))
2260 Typ
:= Entity
(Decl
);
2262 -- Freeze nodes for ignored Ghost types do not need cleanup
2263 -- actions because they will never appear in the final tree.
2265 if Is_Ignored_Ghost_Entity
(Typ
) then
2268 elsif (Is_Access_Type
(Typ
)
2269 and then not Is_Access_Subprogram_Type
(Typ
)
2270 and then Needs_Finalization
2271 (Available_View
(Designated_Type
(Typ
))))
2272 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2274 Old_Counter_Val
:= Counter_Val
;
2276 -- Freeze nodes are considered to be identical to packages
2277 -- and blocks in terms of nesting. The difference is that
2278 -- a finalization master created inside the freeze node is
2279 -- at the same nesting level as the node itself.
2281 Process_Declarations
(Actions
(Decl
), Preprocess
);
2283 -- The freeze node contains a finalization master
2287 and then No
(Last_Top_Level_Ctrl_Construct
)
2288 and then Counter_Val
> Old_Counter_Val
2290 Last_Top_Level_Ctrl_Construct
:= Decl
;
2294 -- Nested package declarations, avoid generics
2296 elsif Nkind
(Decl
) = N_Package_Declaration
then
2297 Pack_Id
:= Defining_Entity
(Decl
);
2298 Spec
:= Specification
(Decl
);
2300 -- Do not inspect an ignored Ghost package because all code
2301 -- found within will not appear in the final tree.
2303 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
2306 elsif Ekind
(Pack_Id
) /= E_Generic_Package
then
2307 Old_Counter_Val
:= Counter_Val
;
2308 Process_Declarations
2309 (Private_Declarations
(Spec
), Preprocess
);
2310 Process_Declarations
2311 (Visible_Declarations
(Spec
), Preprocess
);
2313 -- Either the visible or the private declarations contain a
2314 -- controlled object. The nested package declaration is the
2315 -- last such construct.
2319 and then No
(Last_Top_Level_Ctrl_Construct
)
2320 and then Counter_Val
> Old_Counter_Val
2322 Last_Top_Level_Ctrl_Construct
:= Decl
;
2326 -- Nested package bodies, avoid generics
2328 elsif Nkind
(Decl
) = N_Package_Body
then
2330 -- Do not inspect an ignored Ghost package body because all
2331 -- code found within will not appear in the final tree.
2333 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
2336 elsif Ekind
(Corresponding_Spec
(Decl
)) /=
2339 Old_Counter_Val
:= Counter_Val
;
2340 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2342 -- The nested package body is the last construct to contain
2343 -- a controlled object.
2347 and then No
(Last_Top_Level_Ctrl_Construct
)
2348 and then Counter_Val
> Old_Counter_Val
2350 Last_Top_Level_Ctrl_Construct
:= Decl
;
2354 -- Handle a rare case caused by a controlled transient object
2355 -- created as part of a record init proc. The variable is wrapped
2356 -- in a block, but the block is not associated with a transient
2359 elsif Nkind
(Decl
) = N_Block_Statement
2360 and then Inside_Init_Proc
2362 Old_Counter_Val
:= Counter_Val
;
2364 if Present
(Handled_Statement_Sequence
(Decl
)) then
2365 Process_Declarations
2366 (Statements
(Handled_Statement_Sequence
(Decl
)),
2370 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2372 -- Either the declaration or statement list of the block has a
2373 -- controlled object.
2377 and then No
(Last_Top_Level_Ctrl_Construct
)
2378 and then Counter_Val
> Old_Counter_Val
2380 Last_Top_Level_Ctrl_Construct
:= Decl
;
2383 -- Handle the case where the original context has been wrapped in
2384 -- a block to avoid interference between exception handlers and
2385 -- At_End handlers. Treat the block as transparent and process its
2388 elsif Nkind
(Decl
) = N_Block_Statement
2389 and then Is_Finalization_Wrapper
(Decl
)
2391 if Present
(Handled_Statement_Sequence
(Decl
)) then
2392 Process_Declarations
2393 (Statements
(Handled_Statement_Sequence
(Decl
)),
2397 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2400 Prev_Non_Pragma
(Decl
);
2402 end Process_Declarations
;
2404 --------------------------------
2405 -- Process_Object_Declaration --
2406 --------------------------------
2408 procedure Process_Object_Declaration
2410 Has_No_Init
: Boolean := False;
2411 Is_Protected
: Boolean := False)
2413 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2414 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2416 Init_Typ
: Entity_Id
;
2417 -- The initialization type of the related object declaration. Note
2418 -- that this is not necessarily the same type as Obj_Typ because of
2419 -- possible type derivations.
2421 Obj_Typ
: Entity_Id
;
2422 -- The type of the related object declaration
2424 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2425 -- Func_Id denotes a build-in-place function. Generate the following
2428 -- if BIPallocfrom > Secondary_Stack'Pos
2429 -- and then BIPfinalizationmaster /= null
2432 -- type Ptr_Typ is access Obj_Typ;
2433 -- for Ptr_Typ'Storage_Pool
2434 -- use Base_Pool (BIPfinalizationmaster);
2436 -- Free (Ptr_Typ (Temp));
2440 -- Obj_Typ is the type of the current object, Temp is the original
2441 -- allocation which Obj_Id renames.
2443 procedure Find_Last_Init
2444 (Last_Init
: out Node_Id
;
2445 Body_Insert
: out Node_Id
);
2446 -- Find the last initialization call related to object declaration
2447 -- Decl. Last_Init denotes the last initialization call which follows
2448 -- Decl. Body_Insert denotes a node where the finalizer body could be
2449 -- potentially inserted after (if blocks are involved).
2451 -----------------------------
2452 -- Build_BIP_Cleanup_Stmts --
2453 -----------------------------
2455 function Build_BIP_Cleanup_Stmts
2456 (Func_Id
: Entity_Id
) return Node_Id
2458 Decls
: constant List_Id
:= New_List
;
2459 Fin_Mas_Id
: constant Entity_Id
:=
2460 Build_In_Place_Formal
2461 (Func_Id
, BIP_Finalization_Master
);
2462 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2463 Temp_Id
: constant Entity_Id
:=
2464 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2468 Free_Stmt
: Node_Id
;
2469 Pool_Id
: Entity_Id
;
2470 Ptr_Typ
: Entity_Id
;
2474 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2476 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2479 Make_Object_Renaming_Declaration
(Loc
,
2480 Defining_Identifier
=> Pool_Id
,
2482 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2484 Make_Explicit_Dereference
(Loc
,
2486 Make_Function_Call
(Loc
,
2488 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2489 Parameter_Associations
=> New_List
(
2490 Make_Explicit_Dereference
(Loc
,
2492 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2494 -- Create an access type which uses the storage pool of the
2495 -- caller's finalization master.
2498 -- type Ptr_Typ is access Func_Typ;
2500 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2503 Make_Full_Type_Declaration
(Loc
,
2504 Defining_Identifier
=> Ptr_Typ
,
2506 Make_Access_To_Object_Definition
(Loc
,
2507 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2509 -- Perform minor decoration in order to set the master and the
2510 -- storage pool attributes.
2512 Set_Ekind
(Ptr_Typ
, E_Access_Type
);
2513 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2514 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2516 -- Create an explicit free statement. Note that the free uses the
2517 -- caller's pool expressed as a renaming.
2520 Make_Free_Statement
(Loc
,
2522 Unchecked_Convert_To
(Ptr_Typ
,
2523 New_Occurrence_Of
(Temp_Id
, Loc
)));
2525 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2527 -- Create a block to house the dummy type and the instantiation as
2528 -- well as to perform the cleanup the temporary.
2534 -- Free (Ptr_Typ (Temp_Id));
2538 Make_Block_Statement
(Loc
,
2539 Declarations
=> Decls
,
2540 Handled_Statement_Sequence
=>
2541 Make_Handled_Sequence_Of_Statements
(Loc
,
2542 Statements
=> New_List
(Free_Stmt
)));
2545 -- if BIPfinalizationmaster /= null then
2549 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2550 Right_Opnd
=> Make_Null
(Loc
));
2552 -- For constrained or tagged results escalate the condition to
2553 -- include the allocation format. Generate:
2555 -- if BIPallocform > Secondary_Stack'Pos
2556 -- and then BIPfinalizationmaster /= null
2559 if not Is_Constrained
(Func_Typ
)
2560 or else Is_Tagged_Type
(Func_Typ
)
2563 Alloc
: constant Entity_Id
:=
2564 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2570 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2572 Make_Integer_Literal
(Loc
,
2574 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2576 Right_Opnd
=> Cond
);
2586 Make_If_Statement
(Loc
,
2588 Then_Statements
=> New_List
(Free_Blk
));
2589 end Build_BIP_Cleanup_Stmts
;
2591 --------------------
2592 -- Find_Last_Init --
2593 --------------------
2595 procedure Find_Last_Init
2596 (Last_Init
: out Node_Id
;
2597 Body_Insert
: out Node_Id
)
2599 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2600 -- Find the last initialization call within the statements of
2603 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2604 -- Determine whether node N denotes one of the initialization
2605 -- procedures of types Init_Typ or Obj_Typ.
2607 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2608 -- Obtain the next statement which follows list member Stmt while
2609 -- ignoring artifacts related to access-before-elaboration checks.
2611 -----------------------------
2612 -- Find_Last_Init_In_Block --
2613 -----------------------------
2615 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2616 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2620 -- Examine the individual statements of the block in reverse to
2621 -- locate the last initialization call.
2623 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2624 Stmt
:= Last
(Statements
(HSS
));
2625 while Present
(Stmt
) loop
2627 -- Peek inside nested blocks in case aborts are allowed
2629 if Nkind
(Stmt
) = N_Block_Statement
then
2630 return Find_Last_Init_In_Block
(Stmt
);
2632 elsif Is_Init_Call
(Stmt
) then
2641 end Find_Last_Init_In_Block
;
2647 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2648 function Is_Init_Proc_Of
2649 (Subp_Id
: Entity_Id
;
2650 Typ
: Entity_Id
) return Boolean;
2651 -- Determine whether subprogram Subp_Id is a valid init proc of
2654 ---------------------
2655 -- Is_Init_Proc_Of --
2656 ---------------------
2658 function Is_Init_Proc_Of
2659 (Subp_Id
: Entity_Id
;
2660 Typ
: Entity_Id
) return Boolean
2662 Deep_Init
: Entity_Id
:= Empty
;
2663 Prim_Init
: Entity_Id
:= Empty
;
2664 Type_Init
: Entity_Id
:= Empty
;
2667 -- Obtain all possible initialization routines of the
2668 -- related type and try to match the subprogram entity
2669 -- against one of them.
2673 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2675 -- Primitive Initialize
2677 if Is_Controlled
(Typ
) then
2678 Prim_Init
:= Find_Optional_Prim_Op
(Typ
, Name_Initialize
);
2680 if Present
(Prim_Init
) then
2681 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2685 -- Type initialization routine
2687 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2688 Type_Init
:= Base_Init_Proc
(Typ
);
2692 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2694 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2696 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2697 end Is_Init_Proc_Of
;
2701 Call_Id
: Entity_Id
;
2703 -- Start of processing for Is_Init_Call
2706 if Nkind
(N
) = N_Procedure_Call_Statement
2707 and then Nkind
(Name
(N
)) = N_Identifier
2709 Call_Id
:= Entity
(Name
(N
));
2711 -- Consider both the type of the object declaration and its
2712 -- related initialization type.
2715 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2717 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2723 -----------------------------
2724 -- Next_Suitable_Statement --
2725 -----------------------------
2727 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2731 -- Skip call markers and Program_Error raises installed by the
2734 Result
:= Next
(Stmt
);
2735 while Present
(Result
) loop
2736 if not Nkind_In
(Result
, N_Call_Marker
,
2737 N_Raise_Program_Error
)
2742 Result
:= Next
(Result
);
2746 end Next_Suitable_Statement
;
2754 Deep_Init_Found
: Boolean := False;
2755 -- A flag set when a call to [Deep_]Initialize has been found
2757 -- Start of processing for Find_Last_Init
2761 Body_Insert
:= Empty
;
2763 -- Object renamings and objects associated with controlled
2764 -- function results do not require initialization.
2770 Stmt
:= Next_Suitable_Statement
(Decl
);
2772 -- For an object with suppressed initialization, we check whether
2773 -- there is in fact no initialization expression. If there is not,
2774 -- then this is an object declaration that has been turned into a
2775 -- different object declaration that calls the build-in-place
2776 -- function in a 'Reference attribute, as in "F(...)'Reference".
2777 -- We search for that later object declaration, so that the
2778 -- Inc_Decl will be inserted after the call. Otherwise, if the
2779 -- call raises an exception, we will finalize the (uninitialized)
2780 -- object, which is wrong.
2782 if No_Initialization
(Decl
) then
2783 if No
(Expression
(Last_Init
)) then
2785 Last_Init
:= Next
(Last_Init
);
2786 exit when No
(Last_Init
);
2787 exit when Nkind
(Last_Init
) = N_Object_Declaration
2788 and then Nkind
(Expression
(Last_Init
)) = N_Reference
2789 and then Nkind
(Prefix
(Expression
(Last_Init
))) =
2791 and then Is_Expanded_Build_In_Place_Call
2792 (Prefix
(Expression
(Last_Init
)));
2798 -- In all other cases the initialization calls follow the related
2799 -- object. The general structure of object initialization built by
2800 -- routine Default_Initialize_Object is as follows:
2802 -- [begin -- aborts allowed
2804 -- Type_Init_Proc (Obj);
2805 -- [begin] -- exceptions allowed
2806 -- Deep_Initialize (Obj);
2807 -- [exception -- exceptions allowed
2809 -- Deep_Finalize (Obj, Self => False);
2812 -- [at end -- aborts allowed
2816 -- When aborts are allowed, the initialization calls are housed
2819 elsif Nkind
(Stmt
) = N_Block_Statement
then
2820 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
2821 Body_Insert
:= Stmt
;
2823 -- Otherwise the initialization calls follow the related object
2826 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
2828 -- Check for an optional call to Deep_Initialize which may
2829 -- appear within a block depending on whether the object has
2830 -- controlled components.
2832 if Present
(Stmt_2
) then
2833 if Nkind
(Stmt_2
) = N_Block_Statement
then
2834 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
2836 if Present
(Call
) then
2837 Deep_Init_Found
:= True;
2839 Body_Insert
:= Stmt_2
;
2842 elsif Is_Init_Call
(Stmt_2
) then
2843 Deep_Init_Found
:= True;
2844 Last_Init
:= Stmt_2
;
2845 Body_Insert
:= Last_Init
;
2849 -- If the object lacks a call to Deep_Initialize, then it must
2850 -- have a call to its related type init proc.
2852 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
2854 Body_Insert
:= Last_Init
;
2862 Count_Ins
: Node_Id
;
2864 Fin_Stmts
: List_Id
:= No_List
;
2867 Label_Id
: Entity_Id
;
2870 -- Start of processing for Process_Object_Declaration
2873 -- Handle the object type and the reference to the object
2875 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
2876 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2879 if Is_Access_Type
(Obj_Typ
) then
2880 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2881 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2883 elsif Is_Concurrent_Type
(Obj_Typ
)
2884 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
2886 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
2887 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2889 elsif Is_Private_Type
(Obj_Typ
)
2890 and then Present
(Full_View
(Obj_Typ
))
2892 Obj_Typ
:= Full_View
(Obj_Typ
);
2893 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2895 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
2896 Obj_Typ
:= Base_Type
(Obj_Typ
);
2897 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2904 Set_Etype
(Obj_Ref
, Obj_Typ
);
2906 -- Handle the initialization type of the object declaration
2908 Init_Typ
:= Obj_Typ
;
2910 if Is_Private_Type
(Init_Typ
)
2911 and then Present
(Full_View
(Init_Typ
))
2913 Init_Typ
:= Full_View
(Init_Typ
);
2915 elsif Is_Untagged_Derivation
(Init_Typ
) then
2916 Init_Typ
:= Root_Type
(Init_Typ
);
2923 -- Set a new value for the state counter and insert the statement
2924 -- after the object declaration. Generate:
2926 -- Counter := <value>;
2929 Make_Assignment_Statement
(Loc
,
2930 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
2931 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
2933 -- Insert the counter after all initialization has been done. The
2934 -- place of insertion depends on the context.
2936 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
) then
2938 -- The object is initialized by a build-in-place function call.
2939 -- The counter insertion point is after the function call.
2941 if Present
(BIP_Initialization_Call
(Obj_Id
)) then
2942 Count_Ins
:= BIP_Initialization_Call
(Obj_Id
);
2945 -- The object is initialized by an aggregate. Insert the counter
2946 -- after the last aggregate assignment.
2948 elsif Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
2949 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
2952 -- In all other cases the counter is inserted after the last call
2953 -- to either [Deep_]Initialize or the type-specific init proc.
2956 Find_Last_Init
(Count_Ins
, Body_Ins
);
2959 -- In all other cases the counter is inserted after the last call to
2960 -- either [Deep_]Initialize or the type-specific init proc.
2963 Find_Last_Init
(Count_Ins
, Body_Ins
);
2966 -- If the Initialize function is null or trivial, the call will have
2967 -- been replaced with a null statement, in which case place counter
2968 -- declaration after object declaration itself.
2970 if No
(Count_Ins
) then
2974 Insert_After
(Count_Ins
, Inc_Decl
);
2977 -- If the current declaration is the last in the list, the finalizer
2978 -- body needs to be inserted after the set counter statement for the
2979 -- current object declaration. This is complicated by the fact that
2980 -- the set counter statement may appear in abort deferred block. In
2981 -- that case, the proper insertion place is after the block.
2983 if No
(Finalizer_Insert_Nod
) then
2985 -- Insertion after an abort deferred block
2987 if Present
(Body_Ins
) then
2988 Finalizer_Insert_Nod
:= Body_Ins
;
2990 Finalizer_Insert_Nod
:= Inc_Decl
;
2994 -- Create the associated label with this object, generate:
2996 -- L<counter> : label;
2999 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
3001 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3002 Label
:= Make_Label
(Loc
, Label_Id
);
3004 Prepend_To
(Finalizer_Decls
,
3005 Make_Implicit_Label_Declaration
(Loc
,
3006 Defining_Identifier
=> Entity
(Label_Id
),
3007 Label_Construct
=> Label
));
3009 -- Create the associated jump with this object, generate:
3011 -- when <counter> =>
3014 Prepend_To
(Jump_Alts
,
3015 Make_Case_Statement_Alternative
(Loc
,
3016 Discrete_Choices
=> New_List
(
3017 Make_Integer_Literal
(Loc
, Counter_Val
)),
3018 Statements
=> New_List
(
3019 Make_Goto_Statement
(Loc
,
3020 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3022 -- Insert the jump destination, generate:
3026 Append_To
(Finalizer_Stmts
, Label
);
3028 -- Processing for simple protected objects. Such objects require
3029 -- manual finalization of their lock managers.
3031 if Is_Protected
then
3032 if Is_Simple_Protected_Type
(Obj_Typ
) then
3033 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
3035 if Present
(Fin_Call
) then
3036 Fin_Stmts
:= New_List
(Fin_Call
);
3039 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
3040 if Is_Record_Type
(Obj_Typ
) then
3041 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
3042 elsif Is_Array_Type
(Obj_Typ
) then
3043 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
3049 -- System.Tasking.Protected_Objects.Finalize_Protection
3057 if Present
(Fin_Stmts
) and then Exceptions_OK
then
3058 Fin_Stmts
:= New_List
(
3059 Make_Block_Statement
(Loc
,
3060 Handled_Statement_Sequence
=>
3061 Make_Handled_Sequence_Of_Statements
(Loc
,
3062 Statements
=> Fin_Stmts
,
3064 Exception_Handlers
=> New_List
(
3065 Make_Exception_Handler
(Loc
,
3066 Exception_Choices
=> New_List
(
3067 Make_Others_Choice
(Loc
)),
3069 Statements
=> New_List
(
3070 Make_Null_Statement
(Loc
)))))));
3073 -- Processing for regular controlled objects
3078 -- [Deep_]Finalize (Obj);
3081 -- when Id : others =>
3082 -- if not Raised then
3084 -- Save_Occurrence (E, Id);
3093 -- Guard against a missing [Deep_]Finalize when the object type
3094 -- was not properly frozen.
3096 if No
(Fin_Call
) then
3097 Fin_Call
:= Make_Null_Statement
(Loc
);
3100 -- For CodePeer, the exception handlers normally generated here
3101 -- generate complex flowgraphs which result in capacity problems.
3102 -- Omitting these handlers for CodePeer is justified as follows:
3104 -- If a handler is dead, then omitting it is surely ok
3106 -- If a handler is live, then CodePeer should flag the
3107 -- potentially-exception-raising construct that causes it
3108 -- to be live. That is what we are interested in, not what
3109 -- happens after the exception is raised.
3111 if Exceptions_OK
and not CodePeer_Mode
then
3112 Fin_Stmts
:= New_List
(
3113 Make_Block_Statement
(Loc
,
3114 Handled_Statement_Sequence
=>
3115 Make_Handled_Sequence_Of_Statements
(Loc
,
3116 Statements
=> New_List
(Fin_Call
),
3118 Exception_Handlers
=> New_List
(
3119 Build_Exception_Handler
3120 (Finalizer_Data
, For_Package
)))));
3122 -- When exception handlers are prohibited, the finalization call
3123 -- appears unprotected. Any exception raised during finalization
3124 -- will bypass the circuitry which ensures the cleanup of all
3125 -- remaining objects.
3128 Fin_Stmts
:= New_List
(Fin_Call
);
3131 -- If we are dealing with a return object of a build-in-place
3132 -- function, generate the following cleanup statements:
3134 -- if BIPallocfrom > Secondary_Stack'Pos
3135 -- and then BIPfinalizationmaster /= null
3138 -- type Ptr_Typ is access Obj_Typ;
3139 -- for Ptr_Typ'Storage_Pool use
3140 -- Base_Pool (BIPfinalizationmaster.all).all;
3142 -- Free (Ptr_Typ (Temp));
3146 -- The generated code effectively detaches the temporary from the
3147 -- caller finalization master and deallocates the object.
3149 if Is_Return_Object
(Obj_Id
) then
3151 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
3153 if Is_Build_In_Place_Function
(Func_Id
)
3154 and then Needs_BIP_Finalization_Master
(Func_Id
)
3156 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
3161 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
3162 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
3164 -- Temporaries created for the purpose of "exporting" a
3165 -- transient object out of an Expression_With_Actions (EWA)
3166 -- need guards. The following illustrates the usage of such
3169 -- Access_Typ : access [all] Obj_Typ;
3170 -- Temp : Access_Typ := null;
3171 -- <Counter> := ...;
3174 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3175 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3177 -- Temp := Ctrl_Trans'Unchecked_Access;
3180 -- The finalization machinery does not process EWA nodes as
3181 -- this may lead to premature finalization of expressions. Note
3182 -- that Temp is marked as being properly initialized regardless
3183 -- of whether the initialization of Ctrl_Trans succeeded. Since
3184 -- a failed initialization may leave Temp with a value of null,
3185 -- add a guard to handle this case:
3187 -- if Obj /= null then
3188 -- <object finalization statements>
3191 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
3192 N_Object_Declaration
3194 Fin_Stmts
:= New_List
(
3195 Make_If_Statement
(Loc
,
3198 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
3199 Right_Opnd
=> Make_Null
(Loc
)),
3200 Then_Statements
=> Fin_Stmts
));
3202 -- Return objects use a flag to aid in processing their
3203 -- potential finalization when the enclosing function fails
3204 -- to return properly. Generate:
3207 -- <object finalization statements>
3211 Fin_Stmts
:= New_List
(
3212 Make_If_Statement
(Loc
,
3217 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
3219 Then_Statements
=> Fin_Stmts
));
3224 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
3226 -- Since the declarations are examined in reverse, the state counter
3227 -- must be decremented in order to keep with the true position of
3230 Counter_Val
:= Counter_Val
- 1;
3231 end Process_Object_Declaration
;
3233 -------------------------------------
3234 -- Process_Tagged_Type_Declaration --
3235 -------------------------------------
3237 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
3238 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3239 DT_Ptr
: constant Entity_Id
:=
3240 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
3243 -- Ada.Tags.Unregister_Tag (<Typ>P);
3245 Append_To
(Tagged_Type_Stmts
,
3246 Make_Procedure_Call_Statement
(Loc
,
3248 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
3249 Parameter_Associations
=> New_List
(
3250 New_Occurrence_Of
(DT_Ptr
, Loc
))));
3251 end Process_Tagged_Type_Declaration
;
3253 -- Start of processing for Build_Finalizer
3258 -- Do not perform this expansion in SPARK mode because it is not
3261 if GNATprove_Mode
then
3265 -- Step 1: Extract all lists which may contain controlled objects or
3266 -- library-level tagged types.
3268 if For_Package_Spec
then
3269 Decls
:= Visible_Declarations
(Specification
(N
));
3270 Priv_Decls
:= Private_Declarations
(Specification
(N
));
3272 -- Retrieve the package spec id
3274 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
3276 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
3277 Spec_Id
:= Defining_Identifier
(Spec_Id
);
3280 -- Accept statement, block, entry body, package body, protected body,
3281 -- subprogram body or task body.
3284 Decls
:= Declarations
(N
);
3285 HSS
:= Handled_Statement_Sequence
(N
);
3287 if Present
(HSS
) then
3288 if Present
(Statements
(HSS
)) then
3289 Stmts
:= Statements
(HSS
);
3292 if Present
(At_End_Proc
(HSS
)) then
3293 Prev_At_End
:= At_End_Proc
(HSS
);
3297 -- Retrieve the package spec id for package bodies
3299 if For_Package_Body
then
3300 Spec_Id
:= Corresponding_Spec
(N
);
3304 -- Do not process nested packages since those are handled by the
3305 -- enclosing scope's finalizer. Do not process non-expanded package
3306 -- instantiations since those will be re-analyzed and re-expanded.
3310 (not Is_Library_Level_Entity
(Spec_Id
)
3312 -- Nested packages are considered to be library level entities,
3313 -- but do not need to be processed separately. True library level
3314 -- packages have a scope value of 1.
3316 or else Scope_Depth_Value
(Spec_Id
) /= Uint_1
3317 or else (Is_Generic_Instance
(Spec_Id
)
3318 and then Package_Instantiation
(Spec_Id
) /= N
))
3323 -- Step 2: Object [pre]processing
3327 -- Preprocess the visible declarations now in order to obtain the
3328 -- correct number of controlled object by the time the private
3329 -- declarations are processed.
3331 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3333 -- From all the possible contexts, only package specifications may
3334 -- have private declarations.
3336 if For_Package_Spec
then
3337 Process_Declarations
3338 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
3341 -- The current context may lack controlled objects, but require some
3342 -- other form of completion (task termination for instance). In such
3343 -- cases, the finalizer must be created and carry the additional
3346 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3350 -- The preprocessing has determined that the context has controlled
3351 -- objects or library-level tagged types.
3353 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3355 -- Private declarations are processed first in order to preserve
3356 -- possible dependencies between public and private objects.
3358 if For_Package_Spec
then
3359 Process_Declarations
(Priv_Decls
);
3362 Process_Declarations
(Decls
);
3368 -- Preprocess both declarations and statements
3370 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3371 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3373 -- At this point it is known that N has controlled objects. Ensure
3374 -- that N has a declarative list since the finalizer spec will be
3377 if Has_Ctrl_Objs
and then No
(Decls
) then
3378 Set_Declarations
(N
, New_List
);
3379 Decls
:= Declarations
(N
);
3380 Spec_Decls
:= Decls
;
3383 -- The current context may lack controlled objects, but require some
3384 -- other form of completion (task termination for instance). In such
3385 -- cases, the finalizer must be created and carry the additional
3388 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3392 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3393 Process_Declarations
(Stmts
);
3394 Process_Declarations
(Decls
);
3398 -- Step 3: Finalizer creation
3400 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3403 end Build_Finalizer
;
3405 --------------------------
3406 -- Build_Finalizer_Call --
3407 --------------------------
3409 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3410 Is_Prot_Body
: constant Boolean :=
3411 Nkind
(N
) = N_Subprogram_Body
3412 and then Is_Protected_Subprogram_Body
(N
);
3413 -- Determine whether N denotes the protected version of a subprogram
3414 -- which belongs to a protected type.
3416 Loc
: constant Source_Ptr
:= Sloc
(N
);
3420 -- Do not perform this expansion in SPARK mode because we do not create
3421 -- finalizers in the first place.
3423 if GNATprove_Mode
then
3427 -- The At_End handler should have been assimilated by the finalizer
3429 HSS
:= Handled_Statement_Sequence
(N
);
3430 pragma Assert
(No
(At_End_Proc
(HSS
)));
3432 -- If the construct to be cleaned up is a protected subprogram body, the
3433 -- finalizer call needs to be associated with the block which wraps the
3434 -- unprotected version of the subprogram. The following illustrates this
3437 -- procedure Prot_SubpP is
3438 -- procedure finalizer is
3440 -- Service_Entries (Prot_Obj);
3447 -- Prot_SubpN (Prot_Obj);
3453 if Is_Prot_Body
then
3454 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
3456 -- An At_End handler and regular exception handlers cannot coexist in
3457 -- the same statement sequence. Wrap the original statements in a block.
3459 elsif Present
(Exception_Handlers
(HSS
)) then
3461 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
3466 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3468 Set_Handled_Statement_Sequence
(N
,
3469 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3471 HSS
:= Handled_Statement_Sequence
(N
);
3472 Set_End_Label
(HSS
, End_Lab
);
3476 Set_At_End_Proc
(HSS
, New_Occurrence_Of
(Fin_Id
, Loc
));
3478 Analyze
(At_End_Proc
(HSS
));
3479 Expand_At_End_Handler
(HSS
, Empty
);
3480 end Build_Finalizer_Call
;
3482 ---------------------
3483 -- Build_Late_Proc --
3484 ---------------------
3486 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3488 for Final_Prim
in Name_Of
'Range loop
3489 if Name_Of
(Final_Prim
) = Nam
then
3492 (Prim
=> Final_Prim
,
3494 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3497 end Build_Late_Proc
;
3499 -------------------------------
3500 -- Build_Object_Declarations --
3501 -------------------------------
3503 procedure Build_Object_Declarations
3504 (Data
: out Finalization_Exception_Data
;
3507 For_Package
: Boolean := False)
3512 -- This variable captures an unused dummy internal entity, see the
3513 -- comment associated with its use.
3516 pragma Assert
(Decls
/= No_List
);
3518 -- Always set the proper location as it may be needed even when
3519 -- exception propagation is forbidden.
3523 if Restriction_Active
(No_Exception_Propagation
) then
3524 Data
.Abort_Id
:= Empty
;
3526 Data
.Raised_Id
:= Empty
;
3530 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3532 -- In certain scenarios, finalization can be triggered by an abort. If
3533 -- the finalization itself fails and raises an exception, the resulting
3534 -- Program_Error must be supressed and replaced by an abort signal. In
3535 -- order to detect this scenario, save the state of entry into the
3536 -- finalization code.
3538 -- This is not needed for library-level finalizers as they are called by
3539 -- the environment task and cannot be aborted.
3541 if not For_Package
then
3542 if Abort_Allowed
then
3543 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3546 -- Abort_Id : constant Boolean := <A_Expr>;
3549 Make_Object_Declaration
(Loc
,
3550 Defining_Identifier
=> Data
.Abort_Id
,
3551 Constant_Present
=> True,
3552 Object_Definition
=>
3553 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3555 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
3557 -- Abort is not required
3560 -- Generate a dummy entity to ensure that the internal symbols are
3561 -- in sync when a unit is compiled with and without aborts.
3563 Dummy
:= Make_Temporary
(Loc
, 'A');
3564 Data
.Abort_Id
:= Empty
;
3567 -- Library-level finalizers
3570 Data
.Abort_Id
:= Empty
;
3573 if Exception_Extra_Info
then
3574 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3577 -- E_Id : Exception_Occurrence;
3580 Make_Object_Declaration
(Loc
,
3581 Defining_Identifier
=> Data
.E_Id
,
3582 Object_Definition
=>
3583 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3584 Set_No_Initialization
(Decl
);
3586 Append_To
(Decls
, Decl
);
3593 -- Raised_Id : Boolean := False;
3596 Make_Object_Declaration
(Loc
,
3597 Defining_Identifier
=> Data
.Raised_Id
,
3598 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3599 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3600 end Build_Object_Declarations
;
3602 ---------------------------
3603 -- Build_Raise_Statement --
3604 ---------------------------
3606 function Build_Raise_Statement
3607 (Data
: Finalization_Exception_Data
) return Node_Id
3613 -- Standard run-time use the specialized routine
3614 -- Raise_From_Controlled_Operation.
3616 if Exception_Extra_Info
3617 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3620 Make_Procedure_Call_Statement
(Data
.Loc
,
3623 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3624 Parameter_Associations
=>
3625 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3627 -- Restricted run-time: exception messages are not supported and hence
3628 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3633 Make_Raise_Program_Error
(Data
.Loc
,
3634 Reason
=> PE_Finalize_Raised_Exception
);
3639 -- Raised_Id and then not Abort_Id
3643 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3645 if Present
(Data
.Abort_Id
) then
3646 Expr
:= Make_And_Then
(Data
.Loc
,
3649 Make_Op_Not
(Data
.Loc
,
3650 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3655 -- if Raised_Id and then not Abort_Id then
3656 -- Raise_From_Controlled_Operation (E_Id);
3658 -- raise Program_Error; -- restricted runtime
3662 Make_If_Statement
(Data
.Loc
,
3664 Then_Statements
=> New_List
(Stmt
));
3665 end Build_Raise_Statement
;
3667 -----------------------------
3668 -- Build_Record_Deep_Procs --
3669 -----------------------------
3671 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3675 (Prim
=> Initialize_Case
,
3677 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3679 if not Is_Limited_View
(Typ
) then
3682 (Prim
=> Adjust_Case
,
3684 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3687 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3688 -- suppressed since these routine will not be used.
3690 if not Restriction_Active
(No_Finalization
) then
3693 (Prim
=> Finalize_Case
,
3695 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3697 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3699 if not CodePeer_Mode
then
3702 (Prim
=> Address_Case
,
3704 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3707 end Build_Record_Deep_Procs
;
3713 function Cleanup_Array
3716 Typ
: Entity_Id
) return List_Id
3718 Loc
: constant Source_Ptr
:= Sloc
(N
);
3719 Index_List
: constant List_Id
:= New_List
;
3721 function Free_Component
return List_Id
;
3722 -- Generate the code to finalize the task or protected subcomponents
3723 -- of a single component of the array.
3725 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3726 -- Generate a loop over one dimension of the array
3728 --------------------
3729 -- Free_Component --
3730 --------------------
3732 function Free_Component
return List_Id
is
3733 Stmts
: List_Id
:= New_List
;
3735 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3738 -- Component type is known to contain tasks or protected objects
3741 Make_Indexed_Component
(Loc
,
3742 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3743 Expressions
=> Index_List
);
3745 Set_Etype
(Tsk
, C_Typ
);
3747 if Is_Task_Type
(C_Typ
) then
3748 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3750 elsif Is_Simple_Protected_Type
(C_Typ
) then
3751 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3753 elsif Is_Record_Type
(C_Typ
) then
3754 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3756 elsif Is_Array_Type
(C_Typ
) then
3757 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3763 ------------------------
3764 -- Free_One_Dimension --
3765 ------------------------
3767 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3771 if Dim
> Number_Dimensions
(Typ
) then
3772 return Free_Component
;
3774 -- Here we generate the required loop
3777 Index
:= Make_Temporary
(Loc
, 'J');
3778 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
3781 Make_Implicit_Loop_Statement
(N
,
3782 Identifier
=> Empty
,
3784 Make_Iteration_Scheme
(Loc
,
3785 Loop_Parameter_Specification
=>
3786 Make_Loop_Parameter_Specification
(Loc
,
3787 Defining_Identifier
=> Index
,
3788 Discrete_Subtype_Definition
=>
3789 Make_Attribute_Reference
(Loc
,
3790 Prefix
=> Duplicate_Subexpr
(Obj
),
3791 Attribute_Name
=> Name_Range
,
3792 Expressions
=> New_List
(
3793 Make_Integer_Literal
(Loc
, Dim
))))),
3794 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3796 end Free_One_Dimension
;
3798 -- Start of processing for Cleanup_Array
3801 return Free_One_Dimension
(1);
3804 --------------------
3805 -- Cleanup_Record --
3806 --------------------
3808 function Cleanup_Record
3811 Typ
: Entity_Id
) return List_Id
3813 Loc
: constant Source_Ptr
:= Sloc
(N
);
3816 Stmts
: constant List_Id
:= New_List
;
3817 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3820 if Has_Discriminants
(U_Typ
)
3821 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3822 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3825 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3827 -- For now, do not attempt to free a component that may appear in a
3828 -- variant, and instead issue a warning. Doing this "properly" would
3829 -- require building a case statement and would be quite a mess. Note
3830 -- that the RM only requires that free "work" for the case of a task
3831 -- access value, so already we go way beyond this in that we deal
3832 -- with the array case and non-discriminated record cases.
3835 ("task/protected object in variant record will not be freed??", N
);
3836 return New_List
(Make_Null_Statement
(Loc
));
3839 Comp
:= First_Component
(Typ
);
3840 while Present
(Comp
) loop
3841 if Has_Task
(Etype
(Comp
))
3842 or else Has_Simple_Protected_Object
(Etype
(Comp
))
3845 Make_Selected_Component
(Loc
,
3846 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3847 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3848 Set_Etype
(Tsk
, Etype
(Comp
));
3850 if Is_Task_Type
(Etype
(Comp
)) then
3851 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3853 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3854 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3856 elsif Is_Record_Type
(Etype
(Comp
)) then
3858 -- Recurse, by generating the prefix of the argument to
3859 -- the eventual cleanup call.
3861 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3863 elsif Is_Array_Type
(Etype
(Comp
)) then
3864 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3868 Next_Component
(Comp
);
3874 ------------------------------
3875 -- Cleanup_Protected_Object --
3876 ------------------------------
3878 function Cleanup_Protected_Object
3880 Ref
: Node_Id
) return Node_Id
3882 Loc
: constant Source_Ptr
:= Sloc
(N
);
3885 -- For restricted run-time libraries (Ravenscar), tasks are
3886 -- non-terminating, and protected objects can only appear at library
3887 -- level, so we do not want finalization of protected objects.
3889 if Restricted_Profile
then
3894 Make_Procedure_Call_Statement
(Loc
,
3896 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
3897 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3899 end Cleanup_Protected_Object
;
3905 function Cleanup_Task
3907 Ref
: Node_Id
) return Node_Id
3909 Loc
: constant Source_Ptr
:= Sloc
(N
);
3912 -- For restricted run-time libraries (Ravenscar), tasks are
3913 -- non-terminating and they can only appear at library level, so we do
3914 -- not want finalization of task objects.
3916 if Restricted_Profile
then
3921 Make_Procedure_Call_Statement
(Loc
,
3923 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
3924 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3928 ------------------------------
3929 -- Check_Visibly_Controlled --
3930 ------------------------------
3932 procedure Check_Visibly_Controlled
3933 (Prim
: Final_Primitives
;
3935 E
: in out Entity_Id
;
3936 Cref
: in out Node_Id
)
3938 Parent_Type
: Entity_Id
;
3942 if Is_Derived_Type
(Typ
)
3943 and then Comes_From_Source
(E
)
3944 and then not Present
(Overridden_Operation
(E
))
3946 -- We know that the explicit operation on the type does not override
3947 -- the inherited operation of the parent, and that the derivation
3948 -- is from a private type that is not visibly controlled.
3950 Parent_Type
:= Etype
(Typ
);
3951 Op
:= Find_Optional_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
3953 if Present
(Op
) then
3956 -- Wrap the object to be initialized into the proper
3957 -- unchecked conversion, to be compatible with the operation
3960 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
3961 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
3963 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
3967 end Check_Visibly_Controlled
;
3973 function Convert_View
3976 Ind
: Pos
:= 1) return Node_Id
3978 Fent
: Entity_Id
:= First_Entity
(Proc
);
3983 for J
in 2 .. Ind
loop
3987 Ftyp
:= Etype
(Fent
);
3989 if Nkind_In
(Arg
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
3990 Atyp
:= Entity
(Subtype_Mark
(Arg
));
3992 Atyp
:= Etype
(Arg
);
3995 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
3996 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
3999 and then Present
(Atyp
)
4000 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
4001 and then Base_Type
(Underlying_Type
(Atyp
)) =
4002 Base_Type
(Underlying_Type
(Ftyp
))
4004 return Unchecked_Convert_To
(Ftyp
, Arg
);
4006 -- If the argument is already a conversion, as generated by
4007 -- Make_Init_Call, set the target type to the type of the formal
4008 -- directly, to avoid spurious typing problems.
4010 elsif Nkind_In
(Arg
, N_Unchecked_Type_Conversion
, N_Type_Conversion
)
4011 and then not Is_Class_Wide_Type
(Atyp
)
4013 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
4014 Set_Etype
(Arg
, Ftyp
);
4017 -- Otherwise, introduce a conversion when the designated object
4018 -- has a type derived from the formal of the controlled routine.
4020 elsif Is_Private_Type
(Ftyp
)
4021 and then Present
(Atyp
)
4022 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
4024 return Unchecked_Convert_To
(Ftyp
, Arg
);
4031 -------------------------------
4032 -- CW_Or_Has_Controlled_Part --
4033 -------------------------------
4035 function CW_Or_Has_Controlled_Part
(T
: Entity_Id
) return Boolean is
4037 return Is_Class_Wide_Type
(T
) or else Needs_Finalization
(T
);
4038 end CW_Or_Has_Controlled_Part
;
4040 ------------------------
4041 -- Enclosing_Function --
4042 ------------------------
4044 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
4045 Func_Id
: Entity_Id
;
4049 while Present
(Func_Id
) and then Func_Id
/= Standard_Standard
loop
4050 if Ekind
(Func_Id
) = E_Function
then
4054 Func_Id
:= Scope
(Func_Id
);
4058 end Enclosing_Function
;
4060 -------------------------------
4061 -- Establish_Transient_Scope --
4062 -------------------------------
4064 -- This procedure is called each time a transient block has to be inserted
4065 -- that is to say for each call to a function with unconstrained or tagged
4066 -- result. It creates a new scope on the scope stack in order to enclose
4067 -- all transient variables generated.
4069 procedure Establish_Transient_Scope
(N
: Node_Id
; Sec_Stack
: Boolean) is
4070 Loc
: constant Source_Ptr
:= Sloc
(N
);
4071 Iter_Loop
: Entity_Id
;
4072 Scop_Id
: Entity_Id
;
4073 Scop_Rec
: Scope_Stack_Entry
;
4074 Wrap_Node
: Node_Id
;
4077 -- Do not create a new transient scope if there is an existing transient
4078 -- scope on the stack.
4080 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4081 Scop_Rec
:= Scope_Stack
.Table
(Index
);
4082 Scop_Id
:= Scop_Rec
.Entity
;
4084 -- The current scope is transient. If the scope being established
4085 -- needs to manage the secondary stack, then the existing scope
4086 -- overtakes that function.
4088 if Scop_Rec
.Is_Transient
then
4090 Set_Uses_Sec_Stack
(Scop_Id
);
4095 -- Prevent the search from going too far because transient blocks
4096 -- are bounded by packages and subprogram scopes. Reaching Standard
4097 -- should be impossible without hitting one of the other cases first
4098 -- unless Standard was manually pushed.
4100 elsif Scop_Id
= Standard_Standard
4101 or else Ekind_In
(Scop_Id
, E_Entry
,
4112 Wrap_Node
:= Find_Node_To_Be_Wrapped
(N
);
4114 -- The context does not contain a node that requires a transient scope,
4117 if No
(Wrap_Node
) then
4120 -- If the node to wrap is an iteration_scheme, the expression is one of
4121 -- the bounds, and the expansion will make an explicit declaration for
4122 -- it (see Analyze_Iteration_Scheme, sem_ch5.adb), so do not apply any
4123 -- transformations here. Same for an Ada 2012 iterator specification,
4124 -- where a block is created for the expression that build the container.
4126 elsif Nkind_In
(Wrap_Node
, N_Iteration_Scheme
,
4127 N_Iterator_Specification
)
4131 -- In formal verification mode, if the node to wrap is a pragma check,
4132 -- this node and enclosed expression are not expanded, so do not apply
4133 -- any transformations here.
4135 elsif GNATprove_Mode
4136 and then Nkind
(Wrap_Node
) = N_Pragma
4137 and then Get_Pragma_Id
(Wrap_Node
) = Pragma_Check
4141 -- Create a block entity to act as a transient scope. Note that when the
4142 -- node to be wrapped is an expression or a statement, a real physical
4143 -- block is constructed (see routines Wrap_Transient_Expression and
4144 -- Wrap_Transient_Statement) and inserted into the tree.
4147 Push_Scope
(New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B'));
4148 Set_Scope_Is_Transient
;
4150 -- The transient scope must also take care of the secondary stack
4154 Set_Uses_Sec_Stack
(Current_Scope
);
4155 Check_Restriction
(No_Secondary_Stack
, N
);
4157 -- The expansion of iterator loops generates references to objects
4158 -- in order to extract elements from a container:
4160 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4161 -- Obj : <object type> renames Ref.all.Element.all;
4163 -- These references are controlled and returned on the secondary
4164 -- stack. A new reference is created at each iteration of the loop
4165 -- and as a result it must be finalized and the space occupied by
4166 -- it on the secondary stack reclaimed at the end of the current
4169 -- When the context that requires a transient scope is a call to
4170 -- routine Reference, the node to be wrapped is the source object:
4172 -- for Obj of Container loop
4174 -- Routine Wrap_Transient_Declaration however does not generate a
4175 -- physical block as wrapping a declaration will kill it too ealy.
4176 -- To handle this peculiar case, mark the related iterator loop as
4177 -- requiring the secondary stack. This signals the finalization
4178 -- machinery to manage the secondary stack (see routine
4179 -- Process_Statements_For_Controlled_Objects).
4181 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Current_Scope
);
4183 if Present
(Iter_Loop
) then
4184 Set_Uses_Sec_Stack
(Iter_Loop
);
4188 Set_Etype
(Current_Scope
, Standard_Void_Type
);
4189 Set_Node_To_Be_Wrapped
(Wrap_Node
);
4191 if Debug_Flag_W
then
4192 Write_Str
(" <Transient>");
4196 end Establish_Transient_Scope
;
4198 ----------------------------
4199 -- Expand_Cleanup_Actions --
4200 ----------------------------
4202 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
4203 Scop
: constant Entity_Id
:= Current_Scope
;
4205 Is_Asynchronous_Call
: constant Boolean :=
4206 Nkind
(N
) = N_Block_Statement
4207 and then Is_Asynchronous_Call_Block
(N
);
4208 Is_Master
: constant Boolean :=
4209 Nkind
(N
) /= N_Entry_Body
4210 and then Is_Task_Master
(N
);
4211 Is_Protected_Subp_Body
: constant Boolean :=
4212 Nkind
(N
) = N_Subprogram_Body
4213 and then Is_Protected_Subprogram_Body
(N
);
4214 Is_Task_Allocation
: constant Boolean :=
4215 Nkind
(N
) = N_Block_Statement
4216 and then Is_Task_Allocation_Block
(N
);
4217 Is_Task_Body
: constant Boolean :=
4218 Nkind
(Original_Node
(N
)) = N_Task_Body
;
4219 Needs_Sec_Stack_Mark
: constant Boolean :=
4220 Uses_Sec_Stack
(Scop
)
4222 not Sec_Stack_Needed_For_Return
(Scop
);
4223 Needs_Custom_Cleanup
: constant Boolean :=
4224 Nkind
(N
) = N_Block_Statement
4225 and then Present
(Cleanup_Actions
(N
));
4227 Actions_Required
: constant Boolean :=
4228 Requires_Cleanup_Actions
(N
, True)
4229 or else Is_Asynchronous_Call
4231 or else Is_Protected_Subp_Body
4232 or else Is_Task_Allocation
4233 or else Is_Task_Body
4234 or else Needs_Sec_Stack_Mark
4235 or else Needs_Custom_Cleanup
;
4237 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
4241 procedure Wrap_HSS_In_Block
;
4242 -- Move HSS inside a new block along with the original exception
4243 -- handlers. Make the newly generated block the sole statement of HSS.
4245 -----------------------
4246 -- Wrap_HSS_In_Block --
4247 -----------------------
4249 procedure Wrap_HSS_In_Block
is
4251 Block_Id
: Entity_Id
;
4255 -- Preserve end label to provide proper cross-reference information
4257 End_Lab
:= End_Label
(HSS
);
4259 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
4261 Block_Id
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
4262 Set_Identifier
(Block
, New_Occurrence_Of
(Block_Id
, Loc
));
4263 Set_Etype
(Block_Id
, Standard_Void_Type
);
4264 Set_Block_Node
(Block_Id
, Identifier
(Block
));
4266 -- Signal the finalization machinery that this particular block
4267 -- contains the original context.
4269 Set_Is_Finalization_Wrapper
(Block
);
4271 Set_Handled_Statement_Sequence
(N
,
4272 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
4273 HSS
:= Handled_Statement_Sequence
(N
);
4275 Set_First_Real_Statement
(HSS
, Block
);
4276 Set_End_Label
(HSS
, End_Lab
);
4278 -- Comment needed here, see RH for 1.306 ???
4280 if Nkind
(N
) = N_Subprogram_Body
then
4281 Set_Has_Nested_Block_With_Handler
(Scop
);
4283 end Wrap_HSS_In_Block
;
4285 -- Start of processing for Expand_Cleanup_Actions
4288 -- The current construct does not need any form of servicing
4290 if not Actions_Required
then
4293 -- If the current node is a rewritten task body and the descriptors have
4294 -- not been delayed (due to some nested instantiations), do not generate
4295 -- redundant cleanup actions.
4298 and then Nkind
(N
) = N_Subprogram_Body
4299 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
4304 if Needs_Custom_Cleanup
then
4305 Cln
:= Cleanup_Actions
(N
);
4311 Decls
: List_Id
:= Declarations
(N
);
4313 Mark
: Entity_Id
:= Empty
;
4314 New_Decls
: List_Id
;
4318 -- If we are generating expanded code for debugging purposes, use the
4319 -- Sloc of the point of insertion for the cleanup code. The Sloc will
4320 -- be updated subsequently to reference the proper line in .dg files.
4321 -- If we are not debugging generated code, use No_Location instead,
4322 -- so that no debug information is generated for the cleanup code.
4323 -- This makes the behavior of the NEXT command in GDB monotonic, and
4324 -- makes the placement of breakpoints more accurate.
4326 if Debug_Generated_Code
then
4332 -- Set polling off. The finalization and cleanup code is executed
4333 -- with aborts deferred.
4335 Old_Poll
:= Polling_Required
;
4336 Polling_Required
:= False;
4338 -- A task activation call has already been built for a task
4339 -- allocation block.
4341 if not Is_Task_Allocation
then
4342 Build_Task_Activation_Call
(N
);
4346 Establish_Task_Master
(N
);
4349 New_Decls
:= New_List
;
4351 -- If secondary stack is in use, generate:
4353 -- Mnn : constant Mark_Id := SS_Mark;
4355 if Needs_Sec_Stack_Mark
then
4356 Mark
:= Make_Temporary
(Loc
, 'M');
4358 Append_To
(New_Decls
, Build_SS_Mark_Call
(Loc
, Mark
));
4359 Set_Uses_Sec_Stack
(Scop
, False);
4362 -- If exception handlers are present, wrap the sequence of statements
4363 -- in a block since it is not possible to have exception handlers and
4364 -- an At_End handler in the same construct.
4366 if Present
(Exception_Handlers
(HSS
)) then
4369 -- Ensure that the First_Real_Statement field is set
4371 elsif No
(First_Real_Statement
(HSS
)) then
4372 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
4375 -- Do not move the Activation_Chain declaration in the context of
4376 -- task allocation blocks. Task allocation blocks use _chain in their
4377 -- cleanup handlers and gigi complains if it is declared in the
4378 -- sequence of statements of the scope that declares the handler.
4380 if Is_Task_Allocation
then
4382 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
4386 Decl
:= First
(Decls
);
4387 while Nkind
(Decl
) /= N_Object_Declaration
4388 or else Defining_Identifier
(Decl
) /= Chain
4392 -- A task allocation block should always include a _chain
4395 pragma Assert
(Present
(Decl
));
4399 Prepend_To
(New_Decls
, Decl
);
4403 -- Ensure the presence of a declaration list in order to successfully
4404 -- append all original statements to it.
4407 Set_Declarations
(N
, New_List
);
4408 Decls
:= Declarations
(N
);
4411 -- Move the declarations into the sequence of statements in order to
4412 -- have them protected by the At_End handler. It may seem weird to
4413 -- put declarations in the sequence of statement but in fact nothing
4414 -- forbids that at the tree level.
4416 Append_List_To
(Decls
, Statements
(HSS
));
4417 Set_Statements
(HSS
, Decls
);
4419 -- Reset the Sloc of the handled statement sequence to properly
4420 -- reflect the new initial "statement" in the sequence.
4422 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
4424 -- The declarations of finalizer spec and auxiliary variables replace
4425 -- the old declarations that have been moved inward.
4427 Set_Declarations
(N
, New_Decls
);
4428 Analyze_Declarations
(New_Decls
);
4430 -- Generate finalization calls for all controlled objects appearing
4431 -- in the statements of N. Add context specific cleanup for various
4436 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
4438 Top_Decls
=> New_Decls
,
4439 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
4443 if Present
(Fin_Id
) then
4444 Build_Finalizer_Call
(N
, Fin_Id
);
4447 -- Restore saved polling mode
4449 Polling_Required
:= Old_Poll
;
4451 end Expand_Cleanup_Actions
;
4453 ---------------------------
4454 -- Expand_N_Package_Body --
4455 ---------------------------
4457 -- Add call to Activate_Tasks if body is an activator (actual processing
4458 -- is in chapter 9).
4460 -- Generate subprogram descriptor for elaboration routine
4462 -- Encode entity names in package body
4464 procedure Expand_N_Package_Body
(N
: Node_Id
) is
4465 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
4469 -- This is done only for non-generic packages
4471 if Ekind
(Spec_Id
) = E_Package
then
4472 Push_Scope
(Spec_Id
);
4474 -- Build dispatch tables of library level tagged types
4476 if Tagged_Type_Expansion
4477 and then Is_Library_Level_Entity
(Spec_Id
)
4479 Build_Static_Dispatch_Tables
(N
);
4482 Build_Task_Activation_Call
(N
);
4484 -- Verify the run-time semantics of pragma Initial_Condition at the
4485 -- end of the body statements.
4487 Expand_Pragma_Initial_Condition
(Spec_Id
, N
);
4492 Set_Elaboration_Flag
(N
, Spec_Id
);
4493 Set_In_Package_Body
(Spec_Id
, False);
4495 -- Set to encode entity names in package body before gigi is called
4497 Qualify_Entity_Names
(N
);
4499 if Ekind
(Spec_Id
) /= E_Generic_Package
then
4502 Clean_Stmts
=> No_List
,
4504 Top_Decls
=> No_List
,
4505 Defer_Abort
=> False,
4508 if Present
(Fin_Id
) then
4510 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
4513 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
4514 Body_Ent
:= Defining_Identifier
(Body_Ent
);
4517 Set_Finalizer
(Body_Ent
, Fin_Id
);
4521 end Expand_N_Package_Body
;
4523 ----------------------------------
4524 -- Expand_N_Package_Declaration --
4525 ----------------------------------
4527 -- Add call to Activate_Tasks if there are tasks declared and the package
4528 -- has no body. Note that in Ada 83 this may result in premature activation
4529 -- of some tasks, given that we cannot tell whether a body will eventually
4532 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
4533 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4534 Spec
: constant Node_Id
:= Specification
(N
);
4538 No_Body
: Boolean := False;
4539 -- True in the case of a package declaration that is a compilation
4540 -- unit and for which no associated body will be compiled in this
4544 -- Case of a package declaration other than a compilation unit
4546 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4549 -- Case of a compilation unit that does not require a body
4551 elsif not Body_Required
(Parent
(N
))
4552 and then not Unit_Requires_Body
(Id
)
4556 -- Special case of generating calling stubs for a remote call interface
4557 -- package: even though the package declaration requires one, the body
4558 -- won't be processed in this compilation (so any stubs for RACWs
4559 -- declared in the package must be generated here, along with the spec).
4561 elsif Parent
(N
) = Cunit
(Main_Unit
)
4562 and then Is_Remote_Call_Interface
(Id
)
4563 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4568 -- For a nested instance, delay processing until freeze point
4570 if Has_Delayed_Freeze
(Id
)
4571 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4576 -- For a package declaration that implies no associated body, generate
4577 -- task activation call and RACW supporting bodies now (since we won't
4578 -- have a specific separate compilation unit for that).
4583 -- Generate RACW subprogram bodies
4585 if Has_RACW
(Id
) then
4586 Decls
:= Private_Declarations
(Spec
);
4589 Decls
:= Visible_Declarations
(Spec
);
4594 Set_Visible_Declarations
(Spec
, Decls
);
4597 Append_RACW_Bodies
(Decls
, Id
);
4598 Analyze_List
(Decls
);
4601 -- Generate task activation call as last step of elaboration
4603 if Present
(Activation_Chain_Entity
(N
)) then
4604 Build_Task_Activation_Call
(N
);
4607 -- Verify the run-time semantics of pragma Initial_Condition at the
4608 -- end of the private declarations when the package lacks a body.
4610 Expand_Pragma_Initial_Condition
(Id
, N
);
4615 -- Build dispatch tables of library level tagged types
4617 if Tagged_Type_Expansion
4618 and then (Is_Compilation_Unit
(Id
)
4619 or else (Is_Generic_Instance
(Id
)
4620 and then Is_Library_Level_Entity
(Id
)))
4622 Build_Static_Dispatch_Tables
(N
);
4625 -- Note: it is not necessary to worry about generating a subprogram
4626 -- descriptor, since the only way to get exception handlers into a
4627 -- package spec is to include instantiations, and that would cause
4628 -- generation of subprogram descriptors to be delayed in any case.
4630 -- Set to encode entity names in package spec before gigi is called
4632 Qualify_Entity_Names
(N
);
4634 if Ekind
(Id
) /= E_Generic_Package
then
4637 Clean_Stmts
=> No_List
,
4639 Top_Decls
=> No_List
,
4640 Defer_Abort
=> False,
4643 Set_Finalizer
(Id
, Fin_Id
);
4645 end Expand_N_Package_Declaration
;
4647 -----------------------------
4648 -- Find_Node_To_Be_Wrapped --
4649 -----------------------------
4651 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
is
4653 The_Parent
: Node_Id
;
4659 case Nkind
(The_Parent
) is
4661 -- Simple statement can be wrapped
4666 -- Usually assignments are good candidate for wrapping except
4667 -- when they have been generated as part of a controlled aggregate
4668 -- where the wrapping should take place more globally. Note that
4669 -- No_Ctrl_Actions may be set also for non-controlled assignements
4670 -- in order to disable the use of dispatching _assign, so we need
4671 -- to test explicitly for a controlled type here.
4673 when N_Assignment_Statement
=>
4674 if No_Ctrl_Actions
(The_Parent
)
4675 and then Needs_Finalization
(Etype
(Name
(The_Parent
)))
4682 -- An entry call statement is a special case if it occurs in the
4683 -- context of a Timed_Entry_Call. In this case we wrap the entire
4684 -- timed entry call.
4686 when N_Entry_Call_Statement
4687 | N_Procedure_Call_Statement
4689 if Nkind
(Parent
(The_Parent
)) = N_Entry_Call_Alternative
4690 and then Nkind_In
(Parent
(Parent
(The_Parent
)),
4692 N_Conditional_Entry_Call
)
4694 return Parent
(Parent
(The_Parent
));
4699 -- Object declarations are also a boundary for the transient scope
4700 -- even if they are not really wrapped. For further details, see
4701 -- Wrap_Transient_Declaration.
4703 when N_Object_Declaration
4704 | N_Object_Renaming_Declaration
4705 | N_Subtype_Declaration
4709 -- The expression itself is to be wrapped if its parent is a
4710 -- compound statement or any other statement where the expression
4711 -- is known to be scalar.
4713 when N_Accept_Alternative
4714 | N_Attribute_Definition_Clause
4717 | N_Delay_Alternative
4718 | N_Delay_Until_Statement
4719 | N_Delay_Relative_Statement
4720 | N_Discriminant_Association
4722 | N_Entry_Body_Formal_Part
4725 | N_Iteration_Scheme
4726 | N_Terminate_Alternative
4728 pragma Assert
(Present
(P
));
4731 when N_Attribute_Reference
=>
4732 if Is_Procedure_Attribute_Name
4733 (Attribute_Name
(The_Parent
))
4738 -- A raise statement can be wrapped. This will arise when the
4739 -- expression in a raise_with_expression uses the secondary
4740 -- stack, for example.
4742 when N_Raise_Statement
=>
4745 -- If the expression is within the iteration scheme of a loop,
4746 -- we must create a declaration for it, followed by an assignment
4747 -- in order to have a usable statement to wrap.
4749 when N_Loop_Parameter_Specification
=>
4750 return Parent
(The_Parent
);
4752 -- The following nodes contains "dummy calls" which don't need to
4755 when N_Component_Declaration
4756 | N_Discriminant_Specification
4757 | N_Parameter_Specification
4761 -- The return statement is not to be wrapped when the function
4762 -- itself needs wrapping at the outer-level
4764 when N_Simple_Return_Statement
=>
4766 Applies_To
: constant Entity_Id
:=
4768 (Return_Statement_Entity
(The_Parent
));
4769 Return_Type
: constant Entity_Id
:= Etype
(Applies_To
);
4771 if Requires_Transient_Scope
(Return_Type
) then
4778 -- If we leave a scope without having been able to find a node to
4779 -- wrap, something is going wrong but this can happen in error
4780 -- situation that are not detected yet (such as a dynamic string
4781 -- in a pragma export)
4783 when N_Block_Statement
4785 | N_Package_Declaration
4790 -- Otherwise continue the search
4797 The_Parent
:= Parent
(P
);
4799 end Find_Node_To_Be_Wrapped
;
4801 ----------------------------------
4802 -- Has_New_Controlled_Component --
4803 ----------------------------------
4805 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
4809 if not Is_Tagged_Type
(E
) then
4810 return Has_Controlled_Component
(E
);
4811 elsif not Is_Derived_Type
(E
) then
4812 return Has_Controlled_Component
(E
);
4815 Comp
:= First_Component
(E
);
4816 while Present
(Comp
) loop
4817 if Chars
(Comp
) = Name_uParent
then
4820 elsif Scope
(Original_Record_Component
(Comp
)) = E
4821 and then Needs_Finalization
(Etype
(Comp
))
4826 Next_Component
(Comp
);
4830 end Has_New_Controlled_Component
;
4832 ---------------------------------
4833 -- Has_Simple_Protected_Object --
4834 ---------------------------------
4836 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
4838 if Has_Task
(T
) then
4841 elsif Is_Simple_Protected_Type
(T
) then
4844 elsif Is_Array_Type
(T
) then
4845 return Has_Simple_Protected_Object
(Component_Type
(T
));
4847 elsif Is_Record_Type
(T
) then
4852 Comp
:= First_Component
(T
);
4853 while Present
(Comp
) loop
4854 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
4858 Next_Component
(Comp
);
4867 end Has_Simple_Protected_Object
;
4869 ------------------------------------
4870 -- Insert_Actions_In_Scope_Around --
4871 ------------------------------------
4873 procedure Insert_Actions_In_Scope_Around
4876 Manage_SS
: Boolean)
4878 Act_Before
: constant List_Id
:=
4879 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
4880 Act_After
: constant List_Id
:=
4881 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
4882 Act_Cleanup
: constant List_Id
:=
4883 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
4884 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
4885 -- Last), but this was incorrect as Process_Transients_In_Scope may
4886 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
4888 procedure Process_Transients_In_Scope
4889 (First_Object
: Node_Id
;
4890 Last_Object
: Node_Id
;
4891 Related_Node
: Node_Id
);
4892 -- Find all transient objects in the list First_Object .. Last_Object
4893 -- and generate finalization actions for them. Related_Node denotes the
4894 -- node which created all transient objects.
4896 ---------------------------------
4897 -- Process_Transients_In_Scope --
4898 ---------------------------------
4900 procedure Process_Transients_In_Scope
4901 (First_Object
: Node_Id
;
4902 Last_Object
: Node_Id
;
4903 Related_Node
: Node_Id
)
4905 Exceptions_OK
: constant Boolean := Exceptions_In_Finalization_OK
;
4907 Must_Hook
: Boolean := False;
4908 -- Flag denoting whether the context requires transient object
4909 -- export to the outer finalizer.
4911 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
4912 -- Determine whether an arbitrary node denotes a subprogram call
4914 procedure Detect_Subprogram_Call
is
4915 new Traverse_Proc
(Is_Subprogram_Call
);
4917 procedure Process_Transient_In_Scope
4918 (Obj_Decl
: Node_Id
;
4919 Blk_Data
: Finalization_Exception_Data
;
4920 Blk_Stmts
: List_Id
);
4921 -- Generate finalization actions for a single transient object
4922 -- denoted by object declaration Obj_Decl. Blk_Data is the
4923 -- exception data of the enclosing block. Blk_Stmts denotes the
4924 -- statements of the enclosing block.
4926 ------------------------
4927 -- Is_Subprogram_Call --
4928 ------------------------
4930 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
4932 -- A regular procedure or function call
4934 if Nkind
(N
) in N_Subprogram_Call
then
4940 -- Heavy expansion may relocate function calls outside the related
4941 -- node. Inspect the original node to detect the initial placement
4944 elsif Original_Node
(N
) /= N
then
4945 Detect_Subprogram_Call
(Original_Node
(N
));
4953 -- Generalized indexing always involves a function call
4955 elsif Nkind
(N
) = N_Indexed_Component
4956 and then Present
(Generalized_Indexing
(N
))
4966 end Is_Subprogram_Call
;
4968 --------------------------------
4969 -- Process_Transient_In_Scope --
4970 --------------------------------
4972 procedure Process_Transient_In_Scope
4973 (Obj_Decl
: Node_Id
;
4974 Blk_Data
: Finalization_Exception_Data
;
4975 Blk_Stmts
: List_Id
)
4977 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
4978 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
4980 Fin_Stmts
: List_Id
;
4981 Hook_Assign
: Node_Id
;
4982 Hook_Clear
: Node_Id
;
4983 Hook_Decl
: Node_Id
;
4984 Hook_Insert
: Node_Id
;
4988 -- Mark the transient object as successfully processed to avoid
4989 -- double finalization.
4991 Set_Is_Finalized_Transient
(Obj_Id
);
4993 -- Construct all the pieces necessary to hook and finalize the
4994 -- transient object.
4996 Build_Transient_Object_Statements
4997 (Obj_Decl
=> Obj_Decl
,
4998 Fin_Call
=> Fin_Call
,
4999 Hook_Assign
=> Hook_Assign
,
5000 Hook_Clear
=> Hook_Clear
,
5001 Hook_Decl
=> Hook_Decl
,
5002 Ptr_Decl
=> Ptr_Decl
);
5004 -- The context contains at least one subprogram call which may
5005 -- raise an exception. This scenario employs "hooking" to pass
5006 -- transient objects to the enclosing finalizer in case of an
5011 -- Add the access type which provides a reference to the
5012 -- transient object. Generate:
5014 -- type Ptr_Typ is access all Desig_Typ;
5016 Insert_Action
(Obj_Decl
, Ptr_Decl
);
5018 -- Add the temporary which acts as a hook to the transient
5019 -- object. Generate:
5021 -- Hook : Ptr_Typ := null;
5023 Insert_Action
(Obj_Decl
, Hook_Decl
);
5025 -- When the transient object is initialized by an aggregate,
5026 -- the hook must capture the object after the last aggregate
5027 -- assignment takes place. Only then is the object considered
5028 -- fully initialized. Generate:
5030 -- Hook := Ptr_Typ (Obj_Id);
5032 -- Hook := Obj_Id'Unrestricted_Access;
5034 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
5035 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
5037 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
5039 -- Otherwise the hook seizes the related object immediately
5042 Hook_Insert
:= Obj_Decl
;
5045 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
5048 -- When exception propagation is enabled wrap the hook clear
5049 -- statement and the finalization call into a block to catch
5050 -- potential exceptions raised during finalization. Generate:
5054 -- [Deep_]Finalize (Obj_Ref);
5058 -- if not Raised then
5061 -- (Enn, Get_Current_Excep.all.all);
5065 if Exceptions_OK
then
5066 Fin_Stmts
:= New_List
;
5069 Append_To
(Fin_Stmts
, Hook_Clear
);
5072 Append_To
(Fin_Stmts
, Fin_Call
);
5074 Prepend_To
(Blk_Stmts
,
5075 Make_Block_Statement
(Loc
,
5076 Handled_Statement_Sequence
=>
5077 Make_Handled_Sequence_Of_Statements
(Loc
,
5078 Statements
=> Fin_Stmts
,
5079 Exception_Handlers
=> New_List
(
5080 Build_Exception_Handler
(Blk_Data
)))));
5082 -- Otherwise generate:
5085 -- [Deep_]Finalize (Obj_Ref);
5087 -- Note that the statements are inserted in reverse order to
5088 -- achieve the desired final order outlined above.
5091 Prepend_To
(Blk_Stmts
, Fin_Call
);
5094 Prepend_To
(Blk_Stmts
, Hook_Clear
);
5097 end Process_Transient_In_Scope
;
5101 Built
: Boolean := False;
5102 Blk_Data
: Finalization_Exception_Data
;
5103 Blk_Decl
: Node_Id
:= Empty
;
5104 Blk_Decls
: List_Id
:= No_List
;
5106 Blk_Stmts
: List_Id
;
5110 -- Start of processing for Process_Transients_In_Scope
5113 -- The expansion performed by this routine is as follows:
5115 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5116 -- Hook_1 : Ptr_Typ_1 := null;
5117 -- Ctrl_Trans_Obj_1 : ...;
5118 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5120 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5121 -- Hook_N : Ptr_Typ_N := null;
5122 -- Ctrl_Trans_Obj_N : ...;
5123 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5126 -- Abrt : constant Boolean := ...;
5127 -- Ex : Exception_Occurrence;
5128 -- Raised : Boolean := False;
5135 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5139 -- if not Raised then
5141 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5146 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5150 -- if not Raised then
5152 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5157 -- if Raised and not Abrt then
5158 -- Raise_From_Controlled_Operation (Ex);
5162 -- Recognize a scenario where the transient context is an object
5163 -- declaration initialized by a build-in-place function call:
5165 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5167 -- The rough expansion of the above is:
5169 -- Temp : ... := Ctrl_Func_Call;
5171 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5173 -- The finalization of any transient object must happen after the
5174 -- build-in-place function call is executed.
5176 if Nkind
(N
) = N_Object_Declaration
5177 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
5180 Blk_Ins
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
5182 -- Search the context for at least one subprogram call. If found, the
5183 -- machinery exports all transient objects to the enclosing finalizer
5184 -- due to the possibility of abnormal call termination.
5187 Detect_Subprogram_Call
(N
);
5188 Blk_Ins
:= Last_Object
;
5192 Insert_List_After_And_Analyze
(Blk_Ins
, Act_Cleanup
);
5195 -- Examine all objects in the list First_Object .. Last_Object
5197 Obj_Decl
:= First_Object
;
5198 while Present
(Obj_Decl
) loop
5199 if Nkind
(Obj_Decl
) = N_Object_Declaration
5200 and then Analyzed
(Obj_Decl
)
5201 and then Is_Finalizable_Transient
(Obj_Decl
, N
)
5203 -- Do not process the node to be wrapped since it will be
5204 -- handled by the enclosing finalizer.
5206 and then Obj_Decl
/= Related_Node
5208 Loc
:= Sloc
(Obj_Decl
);
5210 -- Before generating the clean up code for the first transient
5211 -- object, create a wrapper block which houses all hook clear
5212 -- statements and finalization calls. This wrapper is needed by
5217 Blk_Stmts
:= New_List
;
5220 -- Abrt : constant Boolean := ...;
5221 -- Ex : Exception_Occurrence;
5222 -- Raised : Boolean := False;
5224 if Exceptions_OK
then
5225 Blk_Decls
:= New_List
;
5226 Build_Object_Declarations
(Blk_Data
, Blk_Decls
, Loc
);
5230 Make_Block_Statement
(Loc
,
5231 Declarations
=> Blk_Decls
,
5232 Handled_Statement_Sequence
=>
5233 Make_Handled_Sequence_Of_Statements
(Loc
,
5234 Statements
=> Blk_Stmts
));
5237 -- Construct all necessary circuitry to hook and finalize a
5238 -- single transient object.
5240 Process_Transient_In_Scope
5241 (Obj_Decl
=> Obj_Decl
,
5242 Blk_Data
=> Blk_Data
,
5243 Blk_Stmts
=> Blk_Stmts
);
5246 -- Terminate the scan after the last object has been processed to
5247 -- avoid touching unrelated code.
5249 if Obj_Decl
= Last_Object
then
5256 -- Complete the decoration of the enclosing finalization block and
5257 -- insert it into the tree.
5259 if Present
(Blk_Decl
) then
5261 -- Note that this Abort_Undefer does not require a extra block or
5262 -- an AT_END handler because each finalization exception is caught
5263 -- in its own corresponding finalization block. As a result, the
5264 -- call to Abort_Defer always takes place.
5266 if Abort_Allowed
then
5267 Prepend_To
(Blk_Stmts
,
5268 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5270 Append_To
(Blk_Stmts
,
5271 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5275 -- if Raised and then not Abrt then
5276 -- Raise_From_Controlled_Operation (Ex);
5279 if Exceptions_OK
then
5280 Append_To
(Blk_Stmts
, Build_Raise_Statement
(Blk_Data
));
5283 Insert_After_And_Analyze
(Blk_Ins
, Blk_Decl
);
5285 end Process_Transients_In_Scope
;
5289 Loc
: constant Source_Ptr
:= Sloc
(N
);
5290 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
5291 First_Obj
: Node_Id
;
5293 Mark_Id
: Entity_Id
;
5296 -- Start of processing for Insert_Actions_In_Scope_Around
5299 -- Nothing to do if the scope does not manage the secondary stack or
5300 -- does not contain meaninful actions for insertion.
5303 and then No
(Act_Before
)
5304 and then No
(Act_After
)
5305 and then No
(Act_Cleanup
)
5310 -- If the node to be wrapped is the trigger of an asynchronous select,
5311 -- it is not part of a statement list. The actions must be inserted
5312 -- before the select itself, which is part of some list of statements.
5313 -- Note that the triggering alternative includes the triggering
5314 -- statement and an optional statement list. If the node to be
5315 -- wrapped is part of that list, the normal insertion applies.
5317 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
5318 and then not Is_List_Member
(Node_To_Wrap
)
5320 Target
:= Parent
(Parent
(Node_To_Wrap
));
5325 First_Obj
:= Target
;
5328 -- Add all actions associated with a transient scope into the main tree.
5329 -- There are several scenarios here:
5331 -- +--- Before ----+ +----- After ---+
5332 -- 1) First_Obj ....... Target ........ Last_Obj
5334 -- 2) First_Obj ....... Target
5336 -- 3) Target ........ Last_Obj
5338 -- Flag declarations are inserted before the first object
5340 if Present
(Act_Before
) then
5341 First_Obj
:= First
(Act_Before
);
5342 Insert_List_Before
(Target
, Act_Before
);
5345 -- Finalization calls are inserted after the last object
5347 if Present
(Act_After
) then
5348 Last_Obj
:= Last
(Act_After
);
5349 Insert_List_After
(Target
, Act_After
);
5352 -- Mark and release the secondary stack when the context warrants it
5355 Mark_Id
:= Make_Temporary
(Loc
, 'M');
5358 -- Mnn : constant Mark_Id := SS_Mark;
5360 Insert_Before_And_Analyze
5361 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
5364 -- SS_Release (Mnn);
5366 Insert_After_And_Analyze
5367 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
5370 -- Check for transient objects associated with Target and generate the
5371 -- appropriate finalization actions for them.
5373 Process_Transients_In_Scope
5374 (First_Object
=> First_Obj
,
5375 Last_Object
=> Last_Obj
,
5376 Related_Node
=> Target
);
5378 -- Reset the action lists
5381 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
5383 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
5387 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
5389 end Insert_Actions_In_Scope_Around
;
5391 ------------------------------
5392 -- Is_Simple_Protected_Type --
5393 ------------------------------
5395 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
5398 Is_Protected_Type
(T
)
5399 and then not Uses_Lock_Free
(T
)
5400 and then not Has_Entries
(T
)
5401 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
5402 end Is_Simple_Protected_Type
;
5404 -----------------------
5405 -- Make_Adjust_Call --
5406 -----------------------
5408 function Make_Adjust_Call
5411 Skip_Self
: Boolean := False) return Node_Id
5413 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5414 Adj_Id
: Entity_Id
:= Empty
;
5421 -- Recover the proper type which contains Deep_Adjust
5423 if Is_Class_Wide_Type
(Typ
) then
5424 Utyp
:= Root_Type
(Typ
);
5429 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
5430 Set_Assignment_OK
(Ref
);
5432 -- Deal with untagged derivation of private views
5434 if Present
(Utyp
) and then Is_Untagged_Derivation
(Typ
) then
5435 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
5436 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5437 Set_Assignment_OK
(Ref
);
5440 -- When dealing with the completion of a private type, use the base
5443 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
5444 pragma Assert
(Is_Private_Type
(Typ
));
5446 Utyp
:= Base_Type
(Utyp
);
5447 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5450 -- The underlying type may not be present due to a missing full view. In
5451 -- this case freezing did not take place and there is no [Deep_]Adjust
5452 -- primitive to call.
5457 elsif Skip_Self
then
5458 if Has_Controlled_Component
(Utyp
) then
5459 if Is_Tagged_Type
(Utyp
) then
5460 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5462 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5466 -- Class-wide types, interfaces and types with controlled components
5468 elsif Is_Class_Wide_Type
(Typ
)
5469 or else Is_Interface
(Typ
)
5470 or else Has_Controlled_Component
(Utyp
)
5472 if Is_Tagged_Type
(Utyp
) then
5473 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5475 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5478 -- Derivations from [Limited_]Controlled
5480 elsif Is_Controlled
(Utyp
) then
5481 if Has_Controlled_Component
(Utyp
) then
5482 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5484 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
5489 elsif Is_Tagged_Type
(Utyp
) then
5490 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5493 raise Program_Error
;
5496 if Present
(Adj_Id
) then
5498 -- If the object is unanalyzed, set its expected type for use in
5499 -- Convert_View in case an additional conversion is needed.
5502 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
5504 Set_Etype
(Ref
, Typ
);
5507 -- The object reference may need another conversion depending on the
5508 -- type of the formal and that of the actual.
5510 if not Is_Class_Wide_Type
(Typ
) then
5511 Ref
:= Convert_View
(Adj_Id
, Ref
);
5518 Skip_Self
=> Skip_Self
);
5522 end Make_Adjust_Call
;
5524 ----------------------
5525 -- Make_Detach_Call --
5526 ----------------------
5528 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
5529 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5533 Make_Procedure_Call_Statement
(Loc
,
5535 New_Occurrence_Of
(RTE
(RE_Detach
), Loc
),
5536 Parameter_Associations
=> New_List
(
5537 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5538 end Make_Detach_Call
;
5546 Proc_Id
: Entity_Id
;
5548 Skip_Self
: Boolean := False) return Node_Id
5550 Params
: constant List_Id
:= New_List
(Param
);
5553 -- Do not apply the controlled action to the object itself by signaling
5554 -- the related routine to avoid self.
5557 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
5561 Make_Procedure_Call_Statement
(Loc
,
5562 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
5563 Parameter_Associations
=> Params
);
5566 --------------------------
5567 -- Make_Deep_Array_Body --
5568 --------------------------
5570 function Make_Deep_Array_Body
5571 (Prim
: Final_Primitives
;
5572 Typ
: Entity_Id
) return List_Id
5574 Exceptions_OK
: constant Boolean := Exceptions_In_Finalization_OK
;
5576 function Build_Adjust_Or_Finalize_Statements
5577 (Typ
: Entity_Id
) return List_Id
;
5578 -- Create the statements necessary to adjust or finalize an array of
5579 -- controlled elements. Generate:
5582 -- Abort : constant Boolean := Triggered_By_Abort;
5584 -- Abort : constant Boolean := False; -- no abort
5586 -- E : Exception_Occurrence;
5587 -- Raised : Boolean := False;
5590 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
5591 -- ^-- in the finalization case
5593 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
5595 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
5599 -- if not Raised then
5601 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5608 -- if Raised and then not Abort then
5609 -- Raise_From_Controlled_Operation (E);
5613 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
5614 -- Create the statements necessary to initialize an array of controlled
5615 -- elements. Include a mechanism to carry out partial finalization if an
5616 -- exception occurs. Generate:
5619 -- Counter : Integer := 0;
5622 -- for J1 in V'Range (1) loop
5624 -- for JN in V'Range (N) loop
5626 -- [Deep_]Initialize (V (J1, ..., JN));
5628 -- Counter := Counter + 1;
5633 -- Abort : constant Boolean := Triggered_By_Abort;
5635 -- Abort : constant Boolean := False; -- no abort
5636 -- E : Exception_Occurrence;
5637 -- Raised : Boolean := False;
5644 -- V'Length (N) - Counter;
5646 -- for F1 in reverse V'Range (1) loop
5648 -- for FN in reverse V'Range (N) loop
5649 -- if Counter > 0 then
5650 -- Counter := Counter - 1;
5653 -- [Deep_]Finalize (V (F1, ..., FN));
5657 -- if not Raised then
5659 -- Save_Occurrence (E,
5660 -- Get_Current_Excep.all.all);
5669 -- if Raised and then not Abort then
5670 -- Raise_From_Controlled_Operation (E);
5679 function New_References_To
5681 Loc
: Source_Ptr
) return List_Id
;
5682 -- Given a list of defining identifiers, return a list of references to
5683 -- the original identifiers, in the same order as they appear.
5685 -----------------------------------------
5686 -- Build_Adjust_Or_Finalize_Statements --
5687 -----------------------------------------
5689 function Build_Adjust_Or_Finalize_Statements
5690 (Typ
: Entity_Id
) return List_Id
5692 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5693 Index_List
: constant List_Id
:= New_List
;
5694 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5695 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5697 procedure Build_Indexes
;
5698 -- Generate the indexes used in the dimension loops
5704 procedure Build_Indexes
is
5706 -- Generate the following identifiers:
5707 -- Jnn - for initialization
5709 for Dim
in 1 .. Num_Dims
loop
5710 Append_To
(Index_List
,
5711 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5717 Final_Decls
: List_Id
:= No_List
;
5718 Final_Data
: Finalization_Exception_Data
;
5722 Core_Loop
: Node_Id
;
5725 Loop_Id
: Entity_Id
;
5728 -- Start of processing for Build_Adjust_Or_Finalize_Statements
5731 Final_Decls
:= New_List
;
5734 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
5737 Make_Indexed_Component
(Loc
,
5738 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5739 Expressions
=> New_References_To
(Index_List
, Loc
));
5740 Set_Etype
(Comp_Ref
, Comp_Typ
);
5743 -- [Deep_]Adjust (V (J1, ..., JN))
5745 if Prim
= Adjust_Case
then
5746 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5749 -- [Deep_]Finalize (V (J1, ..., JN))
5751 else pragma Assert
(Prim
= Finalize_Case
);
5752 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5755 if Present
(Call
) then
5757 -- Generate the block which houses the adjust or finalize call:
5760 -- <adjust or finalize call>
5764 -- if not Raised then
5766 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5770 if Exceptions_OK
then
5772 Make_Block_Statement
(Loc
,
5773 Handled_Statement_Sequence
=>
5774 Make_Handled_Sequence_Of_Statements
(Loc
,
5775 Statements
=> New_List
(Call
),
5776 Exception_Handlers
=> New_List
(
5777 Build_Exception_Handler
(Final_Data
))));
5782 -- Generate the dimension loops starting from the innermost one
5784 -- for Jnn in [reverse] V'Range (Dim) loop
5788 J
:= Last
(Index_List
);
5790 while Present
(J
) and then Dim
> 0 loop
5796 Make_Loop_Statement
(Loc
,
5798 Make_Iteration_Scheme
(Loc
,
5799 Loop_Parameter_Specification
=>
5800 Make_Loop_Parameter_Specification
(Loc
,
5801 Defining_Identifier
=> Loop_Id
,
5802 Discrete_Subtype_Definition
=>
5803 Make_Attribute_Reference
(Loc
,
5804 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5805 Attribute_Name
=> Name_Range
,
5806 Expressions
=> New_List
(
5807 Make_Integer_Literal
(Loc
, Dim
))),
5810 Prim
= Finalize_Case
)),
5812 Statements
=> New_List
(Core_Loop
),
5813 End_Label
=> Empty
);
5818 -- Generate the block which contains the core loop, declarations
5819 -- of the abort flag, the exception occurrence, the raised flag
5820 -- and the conditional raise:
5823 -- Abort : constant Boolean := Triggered_By_Abort;
5825 -- Abort : constant Boolean := False; -- no abort
5827 -- E : Exception_Occurrence;
5828 -- Raised : Boolean := False;
5833 -- if Raised and then not Abort then
5834 -- Raise_From_Controlled_Operation (E);
5838 Stmts
:= New_List
(Core_Loop
);
5840 if Exceptions_OK
then
5841 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
5845 Make_Block_Statement
(Loc
,
5846 Declarations
=> Final_Decls
,
5847 Handled_Statement_Sequence
=>
5848 Make_Handled_Sequence_Of_Statements
(Loc
,
5849 Statements
=> Stmts
));
5851 -- Otherwise previous errors or a missing full view may prevent the
5852 -- proper freezing of the component type. If this is the case, there
5853 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
5856 Block
:= Make_Null_Statement
(Loc
);
5859 return New_List
(Block
);
5860 end Build_Adjust_Or_Finalize_Statements
;
5862 ---------------------------------
5863 -- Build_Initialize_Statements --
5864 ---------------------------------
5866 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
5867 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5868 Final_List
: constant List_Id
:= New_List
;
5869 Index_List
: constant List_Id
:= New_List
;
5870 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5871 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5873 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
;
5874 -- Generate the following assignment:
5875 -- Counter := V'Length (1) *
5877 -- V'Length (N) - Counter;
5879 -- Counter_Id denotes the entity of the counter.
5881 function Build_Finalization_Call
return Node_Id
;
5882 -- Generate a deep finalization call for an array element
5884 procedure Build_Indexes
;
5885 -- Generate the initialization and finalization indexes used in the
5888 function Build_Initialization_Call
return Node_Id
;
5889 -- Generate a deep initialization call for an array element
5891 ----------------------
5892 -- Build_Assignment --
5893 ----------------------
5895 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
is
5900 -- Start from the first dimension and generate:
5905 Make_Attribute_Reference
(Loc
,
5906 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5907 Attribute_Name
=> Name_Length
,
5908 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
5910 -- Process the rest of the dimensions, generate:
5911 -- Expr * V'Length (N)
5914 while Dim
<= Num_Dims
loop
5916 Make_Op_Multiply
(Loc
,
5919 Make_Attribute_Reference
(Loc
,
5920 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5921 Attribute_Name
=> Name_Length
,
5922 Expressions
=> New_List
(
5923 Make_Integer_Literal
(Loc
, Dim
))));
5929 -- Counter := Expr - Counter;
5932 Make_Assignment_Statement
(Loc
,
5933 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5935 Make_Op_Subtract
(Loc
,
5937 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
5938 end Build_Assignment
;
5940 -----------------------------
5941 -- Build_Finalization_Call --
5942 -----------------------------
5944 function Build_Finalization_Call
return Node_Id
is
5945 Comp_Ref
: constant Node_Id
:=
5946 Make_Indexed_Component
(Loc
,
5947 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5948 Expressions
=> New_References_To
(Final_List
, Loc
));
5951 Set_Etype
(Comp_Ref
, Comp_Typ
);
5954 -- [Deep_]Finalize (V);
5956 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5957 end Build_Finalization_Call
;
5963 procedure Build_Indexes
is
5965 -- Generate the following identifiers:
5966 -- Jnn - for initialization
5967 -- Fnn - for finalization
5969 for Dim
in 1 .. Num_Dims
loop
5970 Append_To
(Index_List
,
5971 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5973 Append_To
(Final_List
,
5974 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
5978 -------------------------------
5979 -- Build_Initialization_Call --
5980 -------------------------------
5982 function Build_Initialization_Call
return Node_Id
is
5983 Comp_Ref
: constant Node_Id
:=
5984 Make_Indexed_Component
(Loc
,
5985 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5986 Expressions
=> New_References_To
(Index_List
, Loc
));
5989 Set_Etype
(Comp_Ref
, Comp_Typ
);
5992 -- [Deep_]Initialize (V (J1, ..., JN));
5994 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5995 end Build_Initialization_Call
;
5999 Counter_Id
: Entity_Id
;
6003 Final_Block
: Node_Id
;
6004 Final_Data
: Finalization_Exception_Data
;
6005 Final_Decls
: List_Id
:= No_List
;
6006 Final_Loop
: Node_Id
;
6007 Init_Block
: Node_Id
;
6008 Init_Call
: Node_Id
;
6009 Init_Loop
: Node_Id
;
6014 -- Start of processing for Build_Initialize_Statements
6017 Counter_Id
:= Make_Temporary
(Loc
, 'C');
6018 Final_Decls
:= New_List
;
6021 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6023 -- Generate the block which houses the finalization call, the index
6024 -- guard and the handler which triggers Program_Error later on.
6026 -- if Counter > 0 then
6027 -- Counter := Counter - 1;
6030 -- [Deep_]Finalize (V (F1, ..., FN));
6033 -- if not Raised then
6035 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6040 Fin_Stmt
:= Build_Finalization_Call
;
6042 if Present
(Fin_Stmt
) then
6043 if Exceptions_OK
then
6045 Make_Block_Statement
(Loc
,
6046 Handled_Statement_Sequence
=>
6047 Make_Handled_Sequence_Of_Statements
(Loc
,
6048 Statements
=> New_List
(Fin_Stmt
),
6049 Exception_Handlers
=> New_List
(
6050 Build_Exception_Handler
(Final_Data
))));
6053 -- This is the core of the loop, the dimension iterators are added
6054 -- one by one in reverse.
6057 Make_If_Statement
(Loc
,
6060 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6061 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
6063 Then_Statements
=> New_List
(
6064 Make_Assignment_Statement
(Loc
,
6065 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6067 Make_Op_Subtract
(Loc
,
6068 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6069 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
6071 Else_Statements
=> New_List
(Fin_Stmt
));
6073 -- Generate all finalization loops starting from the innermost
6076 -- for Fnn in reverse V'Range (Dim) loop
6080 F
:= Last
(Final_List
);
6082 while Present
(F
) and then Dim
> 0 loop
6088 Make_Loop_Statement
(Loc
,
6090 Make_Iteration_Scheme
(Loc
,
6091 Loop_Parameter_Specification
=>
6092 Make_Loop_Parameter_Specification
(Loc
,
6093 Defining_Identifier
=> Loop_Id
,
6094 Discrete_Subtype_Definition
=>
6095 Make_Attribute_Reference
(Loc
,
6096 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6097 Attribute_Name
=> Name_Range
,
6098 Expressions
=> New_List
(
6099 Make_Integer_Literal
(Loc
, Dim
))),
6101 Reverse_Present
=> True)),
6103 Statements
=> New_List
(Final_Loop
),
6104 End_Label
=> Empty
);
6109 -- Generate the block which contains the finalization loops, the
6110 -- declarations of the abort flag, the exception occurrence, the
6111 -- raised flag and the conditional raise.
6114 -- Abort : constant Boolean := Triggered_By_Abort;
6116 -- Abort : constant Boolean := False; -- no abort
6118 -- E : Exception_Occurrence;
6119 -- Raised : Boolean := False;
6125 -- V'Length (N) - Counter;
6129 -- if Raised and then not Abort then
6130 -- Raise_From_Controlled_Operation (E);
6136 Stmts
:= New_List
(Build_Assignment
(Counter_Id
), Final_Loop
);
6138 if Exceptions_OK
then
6139 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6140 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
6144 Make_Block_Statement
(Loc
,
6145 Declarations
=> Final_Decls
,
6146 Handled_Statement_Sequence
=>
6147 Make_Handled_Sequence_Of_Statements
(Loc
,
6148 Statements
=> Stmts
));
6150 -- Otherwise previous errors or a missing full view may prevent the
6151 -- proper freezing of the component type. If this is the case, there
6152 -- is no [Deep_]Finalize primitive to call.
6155 Final_Block
:= Make_Null_Statement
(Loc
);
6158 -- Generate the block which contains the initialization call and
6159 -- the partial finalization code.
6162 -- [Deep_]Initialize (V (J1, ..., JN));
6164 -- Counter := Counter + 1;
6168 -- <finalization code>
6171 Init_Call
:= Build_Initialization_Call
;
6173 -- Only create finalization block if there is a non-trivial
6174 -- call to initialization.
6176 if Present
(Init_Call
)
6177 and then Nkind
(Init_Call
) /= N_Null_Statement
6180 Make_Block_Statement
(Loc
,
6181 Handled_Statement_Sequence
=>
6182 Make_Handled_Sequence_Of_Statements
(Loc
,
6183 Statements
=> New_List
(Init_Call
),
6184 Exception_Handlers
=> New_List
(
6185 Make_Exception_Handler
(Loc
,
6186 Exception_Choices
=> New_List
(
6187 Make_Others_Choice
(Loc
)),
6188 Statements
=> New_List
(Final_Block
)))));
6190 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
6191 Make_Assignment_Statement
(Loc
,
6192 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6195 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6196 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
6198 -- Generate all initialization loops starting from the innermost
6201 -- for Jnn in V'Range (Dim) loop
6205 J
:= Last
(Index_List
);
6207 while Present
(J
) and then Dim
> 0 loop
6213 Make_Loop_Statement
(Loc
,
6215 Make_Iteration_Scheme
(Loc
,
6216 Loop_Parameter_Specification
=>
6217 Make_Loop_Parameter_Specification
(Loc
,
6218 Defining_Identifier
=> Loop_Id
,
6219 Discrete_Subtype_Definition
=>
6220 Make_Attribute_Reference
(Loc
,
6221 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6222 Attribute_Name
=> Name_Range
,
6223 Expressions
=> New_List
(
6224 Make_Integer_Literal
(Loc
, Dim
))))),
6226 Statements
=> New_List
(Init_Loop
),
6227 End_Label
=> Empty
);
6232 -- Generate the block which contains the counter variable and the
6233 -- initialization loops.
6236 -- Counter : Integer := 0;
6242 Make_Block_Statement
(Loc
,
6243 Declarations
=> New_List
(
6244 Make_Object_Declaration
(Loc
,
6245 Defining_Identifier
=> Counter_Id
,
6246 Object_Definition
=>
6247 New_Occurrence_Of
(Standard_Integer
, Loc
),
6248 Expression
=> Make_Integer_Literal
(Loc
, 0))),
6250 Handled_Statement_Sequence
=>
6251 Make_Handled_Sequence_Of_Statements
(Loc
,
6252 Statements
=> New_List
(Init_Loop
)));
6254 -- Otherwise previous errors or a missing full view may prevent the
6255 -- proper freezing of the component type. If this is the case, there
6256 -- is no [Deep_]Initialize primitive to call.
6259 Init_Block
:= Make_Null_Statement
(Loc
);
6262 return New_List
(Init_Block
);
6263 end Build_Initialize_Statements
;
6265 -----------------------
6266 -- New_References_To --
6267 -----------------------
6269 function New_References_To
6271 Loc
: Source_Ptr
) return List_Id
6273 Refs
: constant List_Id
:= New_List
;
6278 while Present
(Id
) loop
6279 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
6284 end New_References_To
;
6286 -- Start of processing for Make_Deep_Array_Body
6290 when Address_Case
=>
6291 return Make_Finalize_Address_Stmts
(Typ
);
6296 return Build_Adjust_Or_Finalize_Statements
(Typ
);
6298 when Initialize_Case
=>
6299 return Build_Initialize_Statements
(Typ
);
6301 end Make_Deep_Array_Body
;
6303 --------------------
6304 -- Make_Deep_Proc --
6305 --------------------
6307 function Make_Deep_Proc
6308 (Prim
: Final_Primitives
;
6310 Stmts
: List_Id
) return Entity_Id
6312 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6314 Proc_Id
: Entity_Id
;
6317 -- Create the object formal, generate:
6318 -- V : System.Address
6320 if Prim
= Address_Case
then
6321 Formals
:= New_List
(
6322 Make_Parameter_Specification
(Loc
,
6323 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6325 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6332 Formals
:= New_List
(
6333 Make_Parameter_Specification
(Loc
,
6334 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6336 Out_Present
=> True,
6337 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
6339 -- F : Boolean := True
6341 if Prim
= Adjust_Case
6342 or else Prim
= Finalize_Case
6345 Make_Parameter_Specification
(Loc
,
6346 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
6348 New_Occurrence_Of
(Standard_Boolean
, Loc
),
6350 New_Occurrence_Of
(Standard_True
, Loc
)));
6355 Make_Defining_Identifier
(Loc
,
6356 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
6359 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6362 -- exception -- Finalize and Adjust cases only
6363 -- raise Program_Error;
6364 -- end Deep_Initialize / Adjust / Finalize;
6368 -- procedure Finalize_Address (V : System.Address) is
6371 -- end Finalize_Address;
6374 Make_Subprogram_Body
(Loc
,
6376 Make_Procedure_Specification
(Loc
,
6377 Defining_Unit_Name
=> Proc_Id
,
6378 Parameter_Specifications
=> Formals
),
6380 Declarations
=> Empty_List
,
6382 Handled_Statement_Sequence
=>
6383 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
6385 -- If there are no calls to component initialization, indicate that
6386 -- the procedure is trivial, so prevent calls to it.
6388 if Is_Empty_List
(Stmts
)
6389 or else Nkind
(First
(Stmts
)) = N_Null_Statement
6391 Set_Is_Trivial_Subprogram
(Proc_Id
);
6397 ---------------------------
6398 -- Make_Deep_Record_Body --
6399 ---------------------------
6401 function Make_Deep_Record_Body
6402 (Prim
: Final_Primitives
;
6404 Is_Local
: Boolean := False) return List_Id
6406 Exceptions_OK
: constant Boolean := Exceptions_In_Finalization_OK
;
6408 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
6409 -- Build the statements necessary to adjust a record type. The type may
6410 -- have discriminants and contain variant parts. Generate:
6414 -- [Deep_]Adjust (V.Comp_1);
6416 -- when Id : others =>
6417 -- if not Raised then
6419 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6424 -- [Deep_]Adjust (V.Comp_N);
6426 -- when Id : others =>
6427 -- if not Raised then
6429 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6434 -- Deep_Adjust (V._parent, False); -- If applicable
6436 -- when Id : others =>
6437 -- if not Raised then
6439 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6445 -- Adjust (V); -- If applicable
6448 -- if not Raised then
6450 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6455 -- if Raised and then not Abort then
6456 -- Raise_From_Controlled_Operation (E);
6460 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
6461 -- Build the statements necessary to finalize a record type. The type
6462 -- may have discriminants and contain variant parts. Generate:
6465 -- Abort : constant Boolean := Triggered_By_Abort;
6467 -- Abort : constant Boolean := False; -- no abort
6468 -- E : Exception_Occurrence;
6469 -- Raised : Boolean := False;
6474 -- Finalize (V); -- If applicable
6477 -- if not Raised then
6479 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6484 -- case Variant_1 is
6486 -- case State_Counter_N => -- If Is_Local is enabled
6496 -- <<LN>> -- If Is_Local is enabled
6498 -- [Deep_]Finalize (V.Comp_N);
6501 -- if not Raised then
6503 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6509 -- [Deep_]Finalize (V.Comp_1);
6512 -- if not Raised then
6514 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6520 -- case State_Counter_1 => -- If Is_Local is enabled
6526 -- Deep_Finalize (V._parent, False); -- If applicable
6528 -- when Id : others =>
6529 -- if not Raised then
6531 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6535 -- if Raised and then not Abort then
6536 -- Raise_From_Controlled_Operation (E);
6540 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
6541 -- Given a derived tagged type Typ, traverse all components, find field
6542 -- _parent and return its type.
6544 procedure Preprocess_Components
6546 Num_Comps
: out Nat
;
6547 Has_POC
: out Boolean);
6548 -- Examine all components in component list Comps, count all controlled
6549 -- components and determine whether at least one of them is per-object
6550 -- constrained. Component _parent is always skipped.
6552 -----------------------------
6553 -- Build_Adjust_Statements --
6554 -----------------------------
6556 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
6557 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6558 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6560 Finalizer_Data
: Finalization_Exception_Data
;
6562 function Process_Component_List_For_Adjust
6563 (Comps
: Node_Id
) return List_Id
;
6564 -- Build all necessary adjust statements for a single component list
6566 ---------------------------------------
6567 -- Process_Component_List_For_Adjust --
6568 ---------------------------------------
6570 function Process_Component_List_For_Adjust
6571 (Comps
: Node_Id
) return List_Id
6573 Stmts
: constant List_Id
:= New_List
;
6575 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
6576 -- Process the declaration of a single controlled component
6578 ----------------------------------
6579 -- Process_Component_For_Adjust --
6580 ----------------------------------
6582 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
6583 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6584 Typ
: constant Entity_Id
:= Etype
(Id
);
6590 -- [Deep_]Adjust (V.Id);
6594 -- if not Raised then
6596 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6603 Make_Selected_Component
(Loc
,
6604 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6605 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6608 -- Guard against a missing [Deep_]Adjust when the component
6609 -- type was not properly frozen.
6611 if Present
(Adj_Call
) then
6612 if Exceptions_OK
then
6614 Make_Block_Statement
(Loc
,
6615 Handled_Statement_Sequence
=>
6616 Make_Handled_Sequence_Of_Statements
(Loc
,
6617 Statements
=> New_List
(Adj_Call
),
6618 Exception_Handlers
=> New_List
(
6619 Build_Exception_Handler
(Finalizer_Data
))));
6622 Append_To
(Stmts
, Adj_Call
);
6624 end Process_Component_For_Adjust
;
6629 Decl_Id
: Entity_Id
;
6630 Decl_Typ
: Entity_Id
;
6635 -- Start of processing for Process_Component_List_For_Adjust
6638 -- Perform an initial check, determine the number of controlled
6639 -- components in the current list and whether at least one of them
6640 -- is per-object constrained.
6642 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6644 -- The processing in this routine is done in the following order:
6645 -- 1) Regular components
6646 -- 2) Per-object constrained components
6649 if Num_Comps
> 0 then
6651 -- Process all regular components in order of declarations
6653 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6654 while Present
(Decl
) loop
6655 Decl_Id
:= Defining_Identifier
(Decl
);
6656 Decl_Typ
:= Etype
(Decl_Id
);
6658 -- Skip _parent as well as per-object constrained components
6660 if Chars
(Decl_Id
) /= Name_uParent
6661 and then Needs_Finalization
(Decl_Typ
)
6663 if Has_Access_Constraint
(Decl_Id
)
6664 and then No
(Expression
(Decl
))
6668 Process_Component_For_Adjust
(Decl
);
6672 Next_Non_Pragma
(Decl
);
6675 -- Process all per-object constrained components in order of
6679 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6680 while Present
(Decl
) loop
6681 Decl_Id
:= Defining_Identifier
(Decl
);
6682 Decl_Typ
:= Etype
(Decl_Id
);
6686 if Chars
(Decl_Id
) /= Name_uParent
6687 and then Needs_Finalization
(Decl_Typ
)
6688 and then Has_Access_Constraint
(Decl_Id
)
6689 and then No
(Expression
(Decl
))
6691 Process_Component_For_Adjust
(Decl
);
6694 Next_Non_Pragma
(Decl
);
6699 -- Process all variants, if any
6702 if Present
(Variant_Part
(Comps
)) then
6704 Var_Alts
: constant List_Id
:= New_List
;
6708 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6709 while Present
(Var
) loop
6712 -- when <discrete choices> =>
6713 -- <adjust statements>
6715 Append_To
(Var_Alts
,
6716 Make_Case_Statement_Alternative
(Loc
,
6718 New_Copy_List
(Discrete_Choices
(Var
)),
6720 Process_Component_List_For_Adjust
(
6721 Component_List
(Var
))));
6723 Next_Non_Pragma
(Var
);
6727 -- case V.<discriminant> is
6728 -- when <discrete choices 1> =>
6729 -- <adjust statements 1>
6731 -- when <discrete choices N> =>
6732 -- <adjust statements N>
6736 Make_Case_Statement
(Loc
,
6738 Make_Selected_Component
(Loc
,
6739 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6741 Make_Identifier
(Loc
,
6742 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6743 Alternatives
=> Var_Alts
);
6747 -- Add the variant case statement to the list of statements
6749 if Present
(Var_Case
) then
6750 Append_To
(Stmts
, Var_Case
);
6753 -- If the component list did not have any controlled components
6754 -- nor variants, return null.
6756 if Is_Empty_List
(Stmts
) then
6757 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
6761 end Process_Component_List_For_Adjust
;
6765 Bod_Stmts
: List_Id
:= No_List
;
6766 Finalizer_Decls
: List_Id
:= No_List
;
6769 -- Start of processing for Build_Adjust_Statements
6772 Finalizer_Decls
:= New_List
;
6773 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6775 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6776 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6781 -- Create an adjust sequence for all record components
6783 if Present
(Component_List
(Rec_Def
)) then
6785 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
6788 -- A derived record type must adjust all inherited components. This
6789 -- action poses the following problem:
6791 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
6796 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
6798 -- Deep_Adjust (Obj._parent);
6803 -- Adjusting the derived type will invoke Adjust of the parent and
6804 -- then that of the derived type. This is undesirable because both
6805 -- routines may modify shared components. Only the Adjust of the
6806 -- derived type should be invoked.
6808 -- To prevent this double adjustment of shared components,
6809 -- Deep_Adjust uses a flag to control the invocation of Adjust:
6811 -- procedure Deep_Adjust
6812 -- (Obj : in out Some_Type;
6813 -- Flag : Boolean := True)
6821 -- When Deep_Adjust is invokes for field _parent, a value of False is
6822 -- provided for the flag:
6824 -- Deep_Adjust (Obj._parent, False);
6826 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
6828 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6833 if Needs_Finalization
(Par_Typ
) then
6837 Make_Selected_Component
(Loc
,
6838 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6840 Make_Identifier
(Loc
, Name_uParent
)),
6846 -- Deep_Adjust (V._parent, False);
6849 -- when Id : others =>
6850 -- if not Raised then
6852 -- Save_Occurrence (E,
6853 -- Get_Current_Excep.all.all);
6857 if Present
(Call
) then
6860 if Exceptions_OK
then
6862 Make_Block_Statement
(Loc
,
6863 Handled_Statement_Sequence
=>
6864 Make_Handled_Sequence_Of_Statements
(Loc
,
6865 Statements
=> New_List
(Adj_Stmt
),
6866 Exception_Handlers
=> New_List
(
6867 Build_Exception_Handler
(Finalizer_Data
))));
6870 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
6876 -- Adjust the object. This action must be performed last after all
6877 -- components have been adjusted.
6879 if Is_Controlled
(Typ
) then
6885 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Adjust
);
6894 -- if not Raised then
6896 -- Save_Occurrence (E,
6897 -- Get_Current_Excep.all.all);
6902 if Present
(Proc
) then
6904 Make_Procedure_Call_Statement
(Loc
,
6905 Name
=> New_Occurrence_Of
(Proc
, Loc
),
6906 Parameter_Associations
=> New_List
(
6907 Make_Identifier
(Loc
, Name_V
)));
6909 if Exceptions_OK
then
6911 Make_Block_Statement
(Loc
,
6912 Handled_Statement_Sequence
=>
6913 Make_Handled_Sequence_Of_Statements
(Loc
,
6914 Statements
=> New_List
(Adj_Stmt
),
6915 Exception_Handlers
=> New_List
(
6916 Build_Exception_Handler
6917 (Finalizer_Data
))));
6920 Append_To
(Bod_Stmts
,
6921 Make_If_Statement
(Loc
,
6922 Condition
=> Make_Identifier
(Loc
, Name_F
),
6923 Then_Statements
=> New_List
(Adj_Stmt
)));
6928 -- At this point either all adjustment statements have been generated
6929 -- or the type is not controlled.
6931 if Is_Empty_List
(Bod_Stmts
) then
6932 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
6938 -- Abort : constant Boolean := Triggered_By_Abort;
6940 -- Abort : constant Boolean := False; -- no abort
6942 -- E : Exception_Occurrence;
6943 -- Raised : Boolean := False;
6946 -- <adjust statements>
6948 -- if Raised and then not Abort then
6949 -- Raise_From_Controlled_Operation (E);
6954 if Exceptions_OK
then
6955 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
6960 Make_Block_Statement
(Loc
,
6963 Handled_Statement_Sequence
=>
6964 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6966 end Build_Adjust_Statements
;
6968 -------------------------------
6969 -- Build_Finalize_Statements --
6970 -------------------------------
6972 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
6973 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6974 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6977 Finalizer_Data
: Finalization_Exception_Data
;
6979 function Process_Component_List_For_Finalize
6980 (Comps
: Node_Id
) return List_Id
;
6981 -- Build all necessary finalization statements for a single component
6982 -- list. The statements may include a jump circuitry if flag Is_Local
6985 -----------------------------------------
6986 -- Process_Component_List_For_Finalize --
6987 -----------------------------------------
6989 function Process_Component_List_For_Finalize
6990 (Comps
: Node_Id
) return List_Id
6992 procedure Process_Component_For_Finalize
6997 Num_Comps
: in out Nat
);
6998 -- Process the declaration of a single controlled component. If
6999 -- flag Is_Local is enabled, create the corresponding label and
7000 -- jump circuitry. Alts is the list of case alternatives, Decls
7001 -- is the top level declaration list where labels are declared
7002 -- and Stmts is the list of finalization actions. Num_Comps
7003 -- denotes the current number of components needing finalization.
7005 ------------------------------------
7006 -- Process_Component_For_Finalize --
7007 ------------------------------------
7009 procedure Process_Component_For_Finalize
7014 Num_Comps
: in out Nat
)
7016 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7017 Typ
: constant Entity_Id
:= Etype
(Id
);
7024 Label_Id
: Entity_Id
;
7031 Make_Identifier
(Loc
,
7032 Chars
=> New_External_Name
('L', Num_Comps
));
7033 Set_Entity
(Label_Id
,
7034 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7035 Label
:= Make_Label
(Loc
, Label_Id
);
7038 Make_Implicit_Label_Declaration
(Loc
,
7039 Defining_Identifier
=> Entity
(Label_Id
),
7040 Label_Construct
=> Label
));
7047 Make_Case_Statement_Alternative
(Loc
,
7048 Discrete_Choices
=> New_List
(
7049 Make_Integer_Literal
(Loc
, Num_Comps
)),
7051 Statements
=> New_List
(
7052 Make_Goto_Statement
(Loc
,
7054 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7059 Append_To
(Stmts
, Label
);
7061 -- Decrease the number of components to be processed.
7062 -- This action yields a new Label_Id in future calls.
7064 Num_Comps
:= Num_Comps
- 1;
7069 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7071 -- begin -- Exception handlers allowed
7072 -- [Deep_]Finalize (V.Id);
7075 -- if not Raised then
7077 -- Save_Occurrence (E,
7078 -- Get_Current_Excep.all.all);
7085 Make_Selected_Component
(Loc
,
7086 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7087 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7090 -- Guard against a missing [Deep_]Finalize when the component
7091 -- type was not properly frozen.
7093 if Present
(Fin_Call
) then
7094 if Exceptions_OK
then
7096 Make_Block_Statement
(Loc
,
7097 Handled_Statement_Sequence
=>
7098 Make_Handled_Sequence_Of_Statements
(Loc
,
7099 Statements
=> New_List
(Fin_Call
),
7100 Exception_Handlers
=> New_List
(
7101 Build_Exception_Handler
(Finalizer_Data
))));
7104 Append_To
(Stmts
, Fin_Call
);
7106 end Process_Component_For_Finalize
;
7111 Counter_Id
: Entity_Id
:= Empty
;
7113 Decl_Id
: Entity_Id
;
7114 Decl_Typ
: Entity_Id
;
7117 Jump_Block
: Node_Id
;
7119 Label_Id
: Entity_Id
;
7124 -- Start of processing for Process_Component_List_For_Finalize
7127 -- Perform an initial check, look for controlled and per-object
7128 -- constrained components.
7130 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7132 -- Create a state counter to service the current component list.
7133 -- This step is performed before the variants are inspected in
7134 -- order to generate the same state counter names as those from
7135 -- Build_Initialize_Statements.
7137 if Num_Comps
> 0 and then Is_Local
then
7138 Counter
:= Counter
+ 1;
7141 Make_Defining_Identifier
(Loc
,
7142 Chars
=> New_External_Name
('C', Counter
));
7145 -- Process the component in the following order:
7147 -- 2) Per-object constrained components
7148 -- 3) Regular components
7150 -- Start with the variant parts
7153 if Present
(Variant_Part
(Comps
)) then
7155 Var_Alts
: constant List_Id
:= New_List
;
7159 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7160 while Present
(Var
) loop
7163 -- when <discrete choices> =>
7164 -- <finalize statements>
7166 Append_To
(Var_Alts
,
7167 Make_Case_Statement_Alternative
(Loc
,
7169 New_Copy_List
(Discrete_Choices
(Var
)),
7171 Process_Component_List_For_Finalize
(
7172 Component_List
(Var
))));
7174 Next_Non_Pragma
(Var
);
7178 -- case V.<discriminant> is
7179 -- when <discrete choices 1> =>
7180 -- <finalize statements 1>
7182 -- when <discrete choices N> =>
7183 -- <finalize statements N>
7187 Make_Case_Statement
(Loc
,
7189 Make_Selected_Component
(Loc
,
7190 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7192 Make_Identifier
(Loc
,
7193 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7194 Alternatives
=> Var_Alts
);
7198 -- The current component list does not have a single controlled
7199 -- component, however it may contain variants. Return the case
7200 -- statement for the variants or nothing.
7202 if Num_Comps
= 0 then
7203 if Present
(Var_Case
) then
7204 return New_List
(Var_Case
);
7206 return New_List
(Make_Null_Statement
(Loc
));
7210 -- Prepare all lists
7216 -- Process all per-object constrained components in reverse order
7219 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7220 while Present
(Decl
) loop
7221 Decl_Id
:= Defining_Identifier
(Decl
);
7222 Decl_Typ
:= Etype
(Decl_Id
);
7226 if Chars
(Decl_Id
) /= Name_uParent
7227 and then Needs_Finalization
(Decl_Typ
)
7228 and then Has_Access_Constraint
(Decl_Id
)
7229 and then No
(Expression
(Decl
))
7231 Process_Component_For_Finalize
7232 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7235 Prev_Non_Pragma
(Decl
);
7239 -- Process the rest of the components in reverse order
7241 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7242 while Present
(Decl
) loop
7243 Decl_Id
:= Defining_Identifier
(Decl
);
7244 Decl_Typ
:= Etype
(Decl_Id
);
7248 if Chars
(Decl_Id
) /= Name_uParent
7249 and then Needs_Finalization
(Decl_Typ
)
7251 -- Skip per-object constrained components since they were
7252 -- handled in the above step.
7254 if Has_Access_Constraint
(Decl_Id
)
7255 and then No
(Expression
(Decl
))
7259 Process_Component_For_Finalize
7260 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7264 Prev_Non_Pragma
(Decl
);
7269 -- LN : label; -- If Is_Local is enabled
7274 -- case CounterX is .
7284 -- <<LN>> -- If Is_Local is enabled
7286 -- [Deep_]Finalize (V.CompY);
7288 -- when Id : others =>
7289 -- if not Raised then
7291 -- Save_Occurrence (E,
7292 -- Get_Current_Excep.all.all);
7296 -- <<L0>> -- If Is_Local is enabled
7301 -- Add the declaration of default jump location L0, its
7302 -- corresponding alternative and its place in the statements.
7304 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
7305 Set_Entity
(Label_Id
,
7306 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7307 Label
:= Make_Label
(Loc
, Label_Id
);
7309 Append_To
(Decls
, -- declaration
7310 Make_Implicit_Label_Declaration
(Loc
,
7311 Defining_Identifier
=> Entity
(Label_Id
),
7312 Label_Construct
=> Label
));
7314 Append_To
(Alts
, -- alternative
7315 Make_Case_Statement_Alternative
(Loc
,
7316 Discrete_Choices
=> New_List
(
7317 Make_Others_Choice
(Loc
)),
7319 Statements
=> New_List
(
7320 Make_Goto_Statement
(Loc
,
7321 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7323 Append_To
(Stmts
, Label
); -- statement
7325 -- Create the jump block
7328 Make_Case_Statement
(Loc
,
7329 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
7330 Alternatives
=> Alts
));
7334 Make_Block_Statement
(Loc
,
7335 Declarations
=> Decls
,
7336 Handled_Statement_Sequence
=>
7337 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
7339 if Present
(Var_Case
) then
7340 return New_List
(Var_Case
, Jump_Block
);
7342 return New_List
(Jump_Block
);
7344 end Process_Component_List_For_Finalize
;
7348 Bod_Stmts
: List_Id
:= No_List
;
7349 Finalizer_Decls
: List_Id
:= No_List
;
7352 -- Start of processing for Build_Finalize_Statements
7355 Finalizer_Decls
:= New_List
;
7356 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7358 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7359 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7364 -- Create a finalization sequence for all record components
7366 if Present
(Component_List
(Rec_Def
)) then
7368 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
7371 -- A derived record type must finalize all inherited components. This
7372 -- action poses the following problem:
7374 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7379 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7381 -- Deep_Finalize (Obj._parent);
7386 -- Finalizing the derived type will invoke Finalize of the parent and
7387 -- then that of the derived type. This is undesirable because both
7388 -- routines may modify shared components. Only the Finalize of the
7389 -- derived type should be invoked.
7391 -- To prevent this double adjustment of shared components,
7392 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7394 -- procedure Deep_Finalize
7395 -- (Obj : in out Some_Type;
7396 -- Flag : Boolean := True)
7404 -- When Deep_Finalize is invoked for field _parent, a value of False
7405 -- is provided for the flag:
7407 -- Deep_Finalize (Obj._parent, False);
7409 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7411 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7416 if Needs_Finalization
(Par_Typ
) then
7420 Make_Selected_Component
(Loc
,
7421 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7423 Make_Identifier
(Loc
, Name_uParent
)),
7429 -- Deep_Finalize (V._parent, False);
7432 -- when Id : others =>
7433 -- if not Raised then
7435 -- Save_Occurrence (E,
7436 -- Get_Current_Excep.all.all);
7440 if Present
(Call
) then
7443 if Exceptions_OK
then
7445 Make_Block_Statement
(Loc
,
7446 Handled_Statement_Sequence
=>
7447 Make_Handled_Sequence_Of_Statements
(Loc
,
7448 Statements
=> New_List
(Fin_Stmt
),
7449 Exception_Handlers
=> New_List
(
7450 Build_Exception_Handler
7451 (Finalizer_Data
))));
7454 Append_To
(Bod_Stmts
, Fin_Stmt
);
7460 -- Finalize the object. This action must be performed first before
7461 -- all components have been finalized.
7463 if Is_Controlled
(Typ
) and then not Is_Local
then
7469 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Finalize
);
7478 -- if not Raised then
7480 -- Save_Occurrence (E,
7481 -- Get_Current_Excep.all.all);
7486 if Present
(Proc
) then
7488 Make_Procedure_Call_Statement
(Loc
,
7489 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7490 Parameter_Associations
=> New_List
(
7491 Make_Identifier
(Loc
, Name_V
)));
7493 if Exceptions_OK
then
7495 Make_Block_Statement
(Loc
,
7496 Handled_Statement_Sequence
=>
7497 Make_Handled_Sequence_Of_Statements
(Loc
,
7498 Statements
=> New_List
(Fin_Stmt
),
7499 Exception_Handlers
=> New_List
(
7500 Build_Exception_Handler
7501 (Finalizer_Data
))));
7504 Prepend_To
(Bod_Stmts
,
7505 Make_If_Statement
(Loc
,
7506 Condition
=> Make_Identifier
(Loc
, Name_F
),
7507 Then_Statements
=> New_List
(Fin_Stmt
)));
7512 -- At this point either all finalization statements have been
7513 -- generated or the type is not controlled.
7515 if No
(Bod_Stmts
) then
7516 return New_List
(Make_Null_Statement
(Loc
));
7520 -- Abort : constant Boolean := Triggered_By_Abort;
7522 -- Abort : constant Boolean := False; -- no abort
7524 -- E : Exception_Occurrence;
7525 -- Raised : Boolean := False;
7528 -- <finalize statements>
7530 -- if Raised and then not Abort then
7531 -- Raise_From_Controlled_Operation (E);
7536 if Exceptions_OK
then
7537 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
7542 Make_Block_Statement
(Loc
,
7545 Handled_Statement_Sequence
=>
7546 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7548 end Build_Finalize_Statements
;
7550 -----------------------
7551 -- Parent_Field_Type --
7552 -----------------------
7554 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
7558 Field
:= First_Entity
(Typ
);
7559 while Present
(Field
) loop
7560 if Chars
(Field
) = Name_uParent
then
7561 return Etype
(Field
);
7564 Next_Entity
(Field
);
7567 -- A derived tagged type should always have a parent field
7569 raise Program_Error
;
7570 end Parent_Field_Type
;
7572 ---------------------------
7573 -- Preprocess_Components --
7574 ---------------------------
7576 procedure Preprocess_Components
7578 Num_Comps
: out Nat
;
7579 Has_POC
: out Boolean)
7589 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7590 while Present
(Decl
) loop
7591 Id
:= Defining_Identifier
(Decl
);
7594 -- Skip field _parent
7596 if Chars
(Id
) /= Name_uParent
7597 and then Needs_Finalization
(Typ
)
7599 Num_Comps
:= Num_Comps
+ 1;
7601 if Has_Access_Constraint
(Id
)
7602 and then No
(Expression
(Decl
))
7608 Next_Non_Pragma
(Decl
);
7610 end Preprocess_Components
;
7612 -- Start of processing for Make_Deep_Record_Body
7616 when Address_Case
=>
7617 return Make_Finalize_Address_Stmts
(Typ
);
7620 return Build_Adjust_Statements
(Typ
);
7622 when Finalize_Case
=>
7623 return Build_Finalize_Statements
(Typ
);
7625 when Initialize_Case
=>
7627 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7630 if Is_Controlled
(Typ
) then
7632 Make_Procedure_Call_Statement
(Loc
,
7635 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
7636 Parameter_Associations
=> New_List
(
7637 Make_Identifier
(Loc
, Name_V
))));
7643 end Make_Deep_Record_Body
;
7645 ----------------------
7646 -- Make_Final_Call --
7647 ----------------------
7649 function Make_Final_Call
7652 Skip_Self
: Boolean := False) return Node_Id
7654 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7656 Fin_Id
: Entity_Id
:= Empty
;
7663 -- Recover the proper type which contains [Deep_]Finalize
7665 if Is_Class_Wide_Type
(Typ
) then
7666 Utyp
:= Root_Type
(Typ
);
7669 elsif Is_Concurrent_Type
(Typ
) then
7670 Utyp
:= Corresponding_Record_Type
(Typ
);
7672 Ref
:= Convert_Concurrent
(Ref
, Typ
);
7674 elsif Is_Private_Type
(Typ
)
7675 and then Present
(Full_View
(Typ
))
7676 and then Is_Concurrent_Type
(Full_View
(Typ
))
7678 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
7680 Ref
:= Convert_Concurrent
(Ref
, Full_View
(Typ
));
7687 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7688 Set_Assignment_OK
(Ref
);
7690 -- Deal with untagged derivation of private views. If the parent type
7691 -- is a protected type, Deep_Finalize is found on the corresponding
7692 -- record of the ancestor.
7694 if Is_Untagged_Derivation
(Typ
) then
7695 if Is_Protected_Type
(Typ
) then
7696 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7698 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7700 if Is_Protected_Type
(Utyp
) then
7701 Utyp
:= Corresponding_Record_Type
(Utyp
);
7705 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7706 Set_Assignment_OK
(Ref
);
7709 -- Deal with derived private types which do not inherit primitives from
7710 -- their parents. In this case, [Deep_]Finalize can be found in the full
7711 -- view of the parent type.
7714 and then Is_Tagged_Type
(Utyp
)
7715 and then Is_Derived_Type
(Utyp
)
7716 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
7717 and then Is_Private_Type
(Etype
(Utyp
))
7718 and then Present
(Full_View
(Etype
(Utyp
)))
7720 Utyp
:= Full_View
(Etype
(Utyp
));
7721 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7722 Set_Assignment_OK
(Ref
);
7725 -- When dealing with the completion of a private type, use the base type
7728 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
7729 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
7731 Utyp
:= Base_Type
(Utyp
);
7732 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7733 Set_Assignment_OK
(Ref
);
7736 -- The underlying type may not be present due to a missing full view. In
7737 -- this case freezing did not take place and there is no [Deep_]Finalize
7738 -- primitive to call.
7743 elsif Skip_Self
then
7744 if Has_Controlled_Component
(Utyp
) then
7745 if Is_Tagged_Type
(Utyp
) then
7746 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7748 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7752 -- Class-wide types, interfaces and types with controlled components
7754 elsif Is_Class_Wide_Type
(Typ
)
7755 or else Is_Interface
(Typ
)
7756 or else Has_Controlled_Component
(Utyp
)
7758 if Is_Tagged_Type
(Utyp
) then
7759 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7761 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7764 -- Derivations from [Limited_]Controlled
7766 elsif Is_Controlled
(Utyp
) then
7767 if Has_Controlled_Component
(Utyp
) then
7768 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7770 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
7775 elsif Is_Tagged_Type
(Utyp
) then
7776 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7779 raise Program_Error
;
7782 if Present
(Fin_Id
) then
7784 -- When finalizing a class-wide object, do not convert to the root
7785 -- type in order to produce a dispatching call.
7787 if Is_Class_Wide_Type
(Typ
) then
7790 -- Ensure that a finalization routine is at least decorated in order
7791 -- to inspect the object parameter.
7793 elsif Analyzed
(Fin_Id
)
7794 or else Ekind
(Fin_Id
) = E_Procedure
7796 -- In certain cases, such as the creation of Stream_Read, the
7797 -- visible entity of the type is its full view. Since Stream_Read
7798 -- will have to create an object of type Typ, the local object
7799 -- will be finalzed by the scope finalizer generated later on. The
7800 -- object parameter of Deep_Finalize will always use the private
7801 -- view of the type. To avoid such a clash between a private and a
7802 -- full view, perform an unchecked conversion of the object
7803 -- reference to the private view.
7806 Formal_Typ
: constant Entity_Id
:=
7807 Etype
(First_Formal
(Fin_Id
));
7809 if Is_Private_Type
(Formal_Typ
)
7810 and then Present
(Full_View
(Formal_Typ
))
7811 and then Full_View
(Formal_Typ
) = Utyp
7813 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
7817 Ref
:= Convert_View
(Fin_Id
, Ref
);
7824 Skip_Self
=> Skip_Self
);
7828 end Make_Final_Call
;
7830 --------------------------------
7831 -- Make_Finalize_Address_Body --
7832 --------------------------------
7834 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
7835 Is_Task
: constant Boolean :=
7836 Ekind
(Typ
) = E_Record_Type
7837 and then Is_Concurrent_Record_Type
(Typ
)
7838 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
7840 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7841 Proc_Id
: Entity_Id
;
7845 -- The corresponding records of task types are not controlled by design.
7846 -- For the sake of completeness, create an empty Finalize_Address to be
7847 -- used in task class-wide allocations.
7852 -- Nothing to do if the type is not controlled or it already has a
7853 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
7854 -- come from source. These are usually generated for completeness and
7855 -- do not need the Finalize_Address primitive.
7857 elsif not Needs_Finalization
(Typ
)
7858 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
7860 (Is_Class_Wide_Type
(Typ
)
7861 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
7862 and then not Comes_From_Source
(Root_Type
(Typ
)))
7867 -- Do not generate Finalize_Address routine for CodePeer
7869 if CodePeer_Mode
then
7874 Make_Defining_Identifier
(Loc
,
7875 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
7879 -- procedure <Typ>FD (V : System.Address) is
7881 -- null; -- for tasks
7883 -- declare -- for all other types
7884 -- type Pnn is access all Typ;
7885 -- for Pnn'Storage_Size use 0;
7887 -- [Deep_]Finalize (Pnn (V).all);
7892 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
7894 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
7898 Make_Subprogram_Body
(Loc
,
7900 Make_Procedure_Specification
(Loc
,
7901 Defining_Unit_Name
=> Proc_Id
,
7903 Parameter_Specifications
=> New_List
(
7904 Make_Parameter_Specification
(Loc
,
7905 Defining_Identifier
=>
7906 Make_Defining_Identifier
(Loc
, Name_V
),
7908 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
7910 Declarations
=> No_List
,
7912 Handled_Statement_Sequence
=>
7913 Make_Handled_Sequence_Of_Statements
(Loc
,
7914 Statements
=> Stmts
)));
7916 Set_TSS
(Typ
, Proc_Id
);
7917 end Make_Finalize_Address_Body
;
7919 ---------------------------------
7920 -- Make_Finalize_Address_Stmts --
7921 ---------------------------------
7923 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
7924 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7927 Desig_Typ
: Entity_Id
;
7928 Fin_Block
: Node_Id
;
7931 Ptr_Typ
: Entity_Id
;
7934 if Is_Array_Type
(Typ
) then
7935 if Is_Constrained
(First_Subtype
(Typ
)) then
7936 Desig_Typ
:= First_Subtype
(Typ
);
7938 Desig_Typ
:= Base_Type
(Typ
);
7941 -- Class-wide types of constrained root types
7943 elsif Is_Class_Wide_Type
(Typ
)
7944 and then Has_Discriminants
(Root_Type
(Typ
))
7946 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
7949 Parent_Typ
: Entity_Id
;
7952 -- Climb the parent type chain looking for a non-constrained type
7954 Parent_Typ
:= Root_Type
(Typ
);
7955 while Parent_Typ
/= Etype
(Parent_Typ
)
7956 and then Has_Discriminants
(Parent_Typ
)
7958 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
7960 Parent_Typ
:= Etype
(Parent_Typ
);
7963 -- Handle views created for tagged types with unknown
7966 if Is_Underlying_Record_View
(Parent_Typ
) then
7967 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
7970 Desig_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
7980 -- type Ptr_Typ is access all Typ;
7981 -- for Ptr_Typ'Storage_Size use 0;
7983 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
7986 Make_Full_Type_Declaration
(Loc
,
7987 Defining_Identifier
=> Ptr_Typ
,
7989 Make_Access_To_Object_Definition
(Loc
,
7990 All_Present
=> True,
7991 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))),
7993 Make_Attribute_Definition_Clause
(Loc
,
7994 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
7995 Chars
=> Name_Storage_Size
,
7996 Expression
=> Make_Integer_Literal
(Loc
, 0)));
7998 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
8000 -- Unconstrained arrays require special processing in order to retrieve
8001 -- the elements. To achieve this, we have to skip the dope vector which
8002 -- lays in front of the elements and then use a thin pointer to perform
8003 -- the address-to-access conversion.
8005 if Is_Array_Type
(Typ
)
8006 and then not Is_Constrained
(First_Subtype
(Typ
))
8009 Dope_Id
: Entity_Id
;
8012 -- Ensure that Ptr_Typ a thin pointer, generate:
8013 -- for Ptr_Typ'Size use System.Address'Size;
8016 Make_Attribute_Definition_Clause
(Loc
,
8017 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8020 Make_Integer_Literal
(Loc
, System_Address_Size
)));
8023 -- Dnn : constant Storage_Offset :=
8024 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8026 Dope_Id
:= Make_Temporary
(Loc
, 'D');
8029 Make_Object_Declaration
(Loc
,
8030 Defining_Identifier
=> Dope_Id
,
8031 Constant_Present
=> True,
8032 Object_Definition
=>
8033 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
8035 Make_Op_Divide
(Loc
,
8037 Make_Attribute_Reference
(Loc
,
8038 Prefix
=> New_Occurrence_Of
(Desig_Typ
, Loc
),
8039 Attribute_Name
=> Name_Descriptor_Size
),
8041 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
8043 -- Shift the address from the start of the dope vector to the
8044 -- start of the elements:
8048 -- Note that this is done through a wrapper routine since RTSfind
8049 -- cannot retrieve operations with string names of the form "+".
8052 Make_Function_Call
(Loc
,
8054 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
8055 Parameter_Associations
=> New_List
(
8057 New_Occurrence_Of
(Dope_Id
, Loc
)));
8064 Make_Explicit_Dereference
(Loc
,
8065 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
8068 if Present
(Fin_Call
) then
8070 Make_Block_Statement
(Loc
,
8071 Declarations
=> Decls
,
8072 Handled_Statement_Sequence
=>
8073 Make_Handled_Sequence_Of_Statements
(Loc
,
8074 Statements
=> New_List
(Fin_Call
)));
8076 -- Otherwise previous errors or a missing full view may prevent the
8077 -- proper freezing of the designated type. If this is the case, there
8078 -- is no [Deep_]Finalize primitive to call.
8081 Fin_Block
:= Make_Null_Statement
(Loc
);
8084 return New_List
(Fin_Block
);
8085 end Make_Finalize_Address_Stmts
;
8087 -------------------------------------
8088 -- Make_Handler_For_Ctrl_Operation --
8089 -------------------------------------
8093 -- when E : others =>
8094 -- Raise_From_Controlled_Operation (E);
8099 -- raise Program_Error [finalize raised exception];
8101 -- depending on whether Raise_From_Controlled_Operation is available
8103 function Make_Handler_For_Ctrl_Operation
8104 (Loc
: Source_Ptr
) return Node_Id
8107 -- Choice parameter (for the first case above)
8109 Raise_Node
: Node_Id
;
8110 -- Procedure call or raise statement
8113 -- Standard run-time: add choice parameter E and pass it to
8114 -- Raise_From_Controlled_Operation so that the original exception
8115 -- name and message can be recorded in the exception message for
8118 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
8119 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
8121 Make_Procedure_Call_Statement
(Loc
,
8124 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
8125 Parameter_Associations
=> New_List
(
8126 New_Occurrence_Of
(E_Occ
, Loc
)));
8128 -- Restricted run-time: exception messages are not supported
8133 Make_Raise_Program_Error
(Loc
,
8134 Reason
=> PE_Finalize_Raised_Exception
);
8138 Make_Implicit_Exception_Handler
(Loc
,
8139 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8140 Choice_Parameter
=> E_Occ
,
8141 Statements
=> New_List
(Raise_Node
));
8142 end Make_Handler_For_Ctrl_Operation
;
8144 --------------------
8145 -- Make_Init_Call --
8146 --------------------
8148 function Make_Init_Call
8150 Typ
: Entity_Id
) return Node_Id
8152 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8161 -- Deal with the type and object reference. Depending on the context, an
8162 -- object reference may need several conversions.
8164 if Is_Concurrent_Type
(Typ
) then
8166 Utyp
:= Corresponding_Record_Type
(Typ
);
8167 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8169 elsif Is_Private_Type
(Typ
)
8170 and then Present
(Full_View
(Typ
))
8171 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8174 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8175 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8182 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8183 Set_Assignment_OK
(Ref
);
8185 -- Deal with untagged derivation of private views
8187 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
8188 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8189 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8191 -- The following is to prevent problems with UC see 1.156 RH ???
8193 Set_Assignment_OK
(Ref
);
8196 -- If the underlying_type is a subtype, then we are dealing with the
8197 -- completion of a private type. We need to access the base type and
8198 -- generate a conversion to it.
8200 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8201 pragma Assert
(Is_Private_Type
(Typ
));
8202 Utyp
:= Base_Type
(Utyp
);
8203 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8206 -- The underlying type may not be present due to a missing full view.
8207 -- In this case freezing did not take place and there is no suitable
8208 -- [Deep_]Initialize primitive to call.
8214 -- Select the appropriate version of initialize
8216 if Has_Controlled_Component
(Utyp
) then
8217 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
8219 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
8220 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
8223 -- If initialization procedure for an array of controlled objects is
8224 -- trivial, do not generate a useless call to it.
8226 if (Is_Array_Type
(Utyp
) and then Is_Trivial_Subprogram
(Proc
))
8228 (not Comes_From_Source
(Proc
)
8229 and then Present
(Alias
(Proc
))
8230 and then Is_Trivial_Subprogram
(Alias
(Proc
)))
8232 return Make_Null_Statement
(Loc
);
8235 -- The object reference may need another conversion depending on the
8236 -- type of the formal and that of the actual.
8238 Ref
:= Convert_View
(Proc
, Ref
);
8241 -- [Deep_]Initialize (Ref);
8244 Make_Procedure_Call_Statement
(Loc
,
8245 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8246 Parameter_Associations
=> New_List
(Ref
));
8249 ------------------------------
8250 -- Make_Local_Deep_Finalize --
8251 ------------------------------
8253 function Make_Local_Deep_Finalize
8255 Nam
: Entity_Id
) return Node_Id
8257 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8261 Formals
:= New_List
(
8265 Make_Parameter_Specification
(Loc
,
8266 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
8268 Out_Present
=> True,
8269 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
8271 -- F : Boolean := True
8273 Make_Parameter_Specification
(Loc
,
8274 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
8275 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8276 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
8278 -- Add the necessary number of counters to represent the initialization
8279 -- state of an object.
8282 Make_Subprogram_Body
(Loc
,
8284 Make_Procedure_Specification
(Loc
,
8285 Defining_Unit_Name
=> Nam
,
8286 Parameter_Specifications
=> Formals
),
8288 Declarations
=> No_List
,
8290 Handled_Statement_Sequence
=>
8291 Make_Handled_Sequence_Of_Statements
(Loc
,
8292 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
8293 end Make_Local_Deep_Finalize
;
8295 ------------------------------------
8296 -- Make_Set_Finalize_Address_Call --
8297 ------------------------------------
8299 function Make_Set_Finalize_Address_Call
8301 Ptr_Typ
: Entity_Id
) return Node_Id
8303 -- It is possible for Ptr_Typ to be a partial view, if the access type
8304 -- is a full view declared in the private part of a nested package, and
8305 -- the finalization actions take place when completing analysis of the
8306 -- enclosing unit. For this reason use Underlying_Type twice below.
8308 Desig_Typ
: constant Entity_Id
:=
8310 (Designated_Type
(Underlying_Type
(Ptr_Typ
)));
8311 Fin_Addr
: constant Entity_Id
:= Finalize_Address
(Desig_Typ
);
8312 Fin_Mas
: constant Entity_Id
:=
8313 Finalization_Master
(Underlying_Type
(Ptr_Typ
));
8316 -- Both the finalization master and primitive Finalize_Address must be
8319 pragma Assert
(Present
(Fin_Addr
) and Present
(Fin_Mas
));
8322 -- Set_Finalize_Address
8323 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8326 Make_Procedure_Call_Statement
(Loc
,
8328 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
8329 Parameter_Associations
=> New_List
(
8330 New_Occurrence_Of
(Fin_Mas
, Loc
),
8332 Make_Attribute_Reference
(Loc
,
8333 Prefix
=> New_Occurrence_Of
(Fin_Addr
, Loc
),
8334 Attribute_Name
=> Name_Unrestricted_Access
)));
8335 end Make_Set_Finalize_Address_Call
;
8337 --------------------------
8338 -- Make_Transient_Block --
8339 --------------------------
8341 function Make_Transient_Block
8344 Par
: Node_Id
) return Node_Id
8346 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean;
8347 -- Determine whether scoping entity Id manages the secondary stack
8349 -----------------------
8350 -- Manages_Sec_Stack --
8351 -----------------------
8353 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean is
8357 -- An exception handler with a choice parameter utilizes a dummy
8358 -- block to provide a declarative region. Such a block should not
8359 -- be considered because it never manifests in the tree and can
8360 -- never release the secondary stack.
8364 Uses_Sec_Stack
(Id
) and then not Is_Exception_Handler
(Id
);
8371 return Uses_Sec_Stack
(Id
);
8376 end Manages_Sec_Stack
;
8380 Decls
: constant List_Id
:= New_List
;
8381 Instrs
: constant List_Id
:= New_List
(Action
);
8382 Trans_Id
: constant Entity_Id
:= Current_Scope
;
8388 -- Start of processing for Make_Transient_Block
8391 -- Even though the transient block is tasked with managing the secondary
8392 -- stack, the block may forgo this functionality depending on how the
8393 -- secondary stack is managed by enclosing scopes.
8395 if Manages_Sec_Stack
(Trans_Id
) then
8397 -- Determine whether an enclosing scope already manages the secondary
8400 Scop
:= Scope
(Trans_Id
);
8401 while Present
(Scop
) loop
8403 -- It should not be possible to reach Standard without hitting one
8404 -- of the other cases first unless Standard was manually pushed.
8406 if Scop
= Standard_Standard
then
8409 -- The transient block is within a function which returns on the
8410 -- secondary stack. Take a conservative approach and assume that
8411 -- the value on the secondary stack is part of the result. Note
8412 -- that it is not possible to detect this dependency without flow
8413 -- analysis which the compiler does not have. Letting the object
8414 -- live longer than the transient block will not leak any memory
8415 -- because the caller will reclaim the total storage used by the
8418 elsif Ekind
(Scop
) = E_Function
8419 and then Sec_Stack_Needed_For_Return
(Scop
)
8421 Set_Uses_Sec_Stack
(Trans_Id
, False);
8424 -- The transient block must manage the secondary stack when the
8425 -- block appears within a loop in order to reclaim the memory at
8428 elsif Ekind
(Scop
) = E_Loop
then
8431 -- The transient block does not need to manage the secondary stack
8432 -- when there is an enclosing construct which already does that.
8433 -- This optimization saves on SS_Mark and SS_Release calls but may
8434 -- allow objects to live a little longer than required.
8436 -- The transient block must manage the secondary stack when switch
8437 -- -gnatd.s (strict management) is in effect.
8439 elsif Manages_Sec_Stack
(Scop
) and then not Debug_Flag_Dot_S
then
8440 Set_Uses_Sec_Stack
(Trans_Id
, False);
8443 -- Prevent the search from going too far because transient blocks
8444 -- are bounded by packages and subprogram scopes.
8446 elsif Ekind_In
(Scop
, E_Entry
,
8456 Scop
:= Scope
(Scop
);
8460 -- Create the transient block. Set the parent now since the block itself
8461 -- is not part of the tree. The current scope is the E_Block entity that
8462 -- has been pushed by Establish_Transient_Scope.
8464 pragma Assert
(Ekind
(Trans_Id
) = E_Block
);
8467 Make_Block_Statement
(Loc
,
8468 Identifier
=> New_Occurrence_Of
(Trans_Id
, Loc
),
8469 Declarations
=> Decls
,
8470 Handled_Statement_Sequence
=>
8471 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
8472 Has_Created_Identifier
=> True);
8473 Set_Parent
(Block
, Par
);
8475 -- Insert actions stuck in the transient scopes as well as all freezing
8476 -- nodes needed by those actions. Do not insert cleanup actions here,
8477 -- they will be transferred to the newly created block.
8479 Insert_Actions_In_Scope_Around
8480 (Action
, Clean
=> False, Manage_SS
=> False);
8482 Insert
:= Prev
(Action
);
8484 if Present
(Insert
) then
8485 Freeze_All
(First_Entity
(Trans_Id
), Insert
);
8488 -- Transfer cleanup actions to the newly created block
8491 Cleanup_Actions
: List_Id
8492 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
8493 Actions_To_Be_Wrapped
(Cleanup
);
8495 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
8496 Cleanup_Actions
:= No_List
;
8499 -- When the transient scope was established, we pushed the entry for the
8500 -- transient scope onto the scope stack, so that the scope was active
8501 -- for the installation of finalizable entities etc. Now we must remove
8502 -- this entry, since we have constructed a proper block.
8507 end Make_Transient_Block
;
8509 ------------------------
8510 -- Node_To_Be_Wrapped --
8511 ------------------------
8513 function Node_To_Be_Wrapped
return Node_Id
is
8515 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
8516 end Node_To_Be_Wrapped
;
8518 ----------------------------
8519 -- Set_Node_To_Be_Wrapped --
8520 ----------------------------
8522 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
8524 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
8525 end Set_Node_To_Be_Wrapped
;
8527 ----------------------------
8528 -- Store_Actions_In_Scope --
8529 ----------------------------
8531 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
8532 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
8533 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
8536 if No
(Actions
) then
8539 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
8540 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
8542 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
8547 elsif AK
= Before
then
8548 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
8551 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
8553 end Store_Actions_In_Scope
;
8555 ----------------------------------
8556 -- Store_After_Actions_In_Scope --
8557 ----------------------------------
8559 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
8561 Store_Actions_In_Scope
(After
, L
);
8562 end Store_After_Actions_In_Scope
;
8564 -----------------------------------
8565 -- Store_Before_Actions_In_Scope --
8566 -----------------------------------
8568 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
8570 Store_Actions_In_Scope
(Before
, L
);
8571 end Store_Before_Actions_In_Scope
;
8573 -----------------------------------
8574 -- Store_Cleanup_Actions_In_Scope --
8575 -----------------------------------
8577 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
8579 Store_Actions_In_Scope
(Cleanup
, L
);
8580 end Store_Cleanup_Actions_In_Scope
;
8582 --------------------------------
8583 -- Wrap_Transient_Declaration --
8584 --------------------------------
8586 -- If a transient scope has been established during the processing of the
8587 -- Expression of an Object_Declaration, it is not possible to wrap the
8588 -- declaration into a transient block as usual case, otherwise the object
8589 -- would be itself declared in the wrong scope. Therefore, all entities (if
8590 -- any) defined in the transient block are moved to the proper enclosing
8591 -- scope. Furthermore, if they are controlled variables they are finalized
8592 -- right after the declaration. The finalization list of the transient
8593 -- scope is defined as a renaming of the enclosing one so during their
8594 -- initialization they will be attached to the proper finalization list.
8595 -- For instance, the following declaration :
8597 -- X : Typ := F (G (A), G (B));
8599 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
8600 -- is expanded into :
8602 -- X : Typ := [ complex Expression-Action ];
8603 -- [Deep_]Finalize (_v1);
8604 -- [Deep_]Finalize (_v2);
8606 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
8611 Curr_S
:= Current_Scope
;
8612 Encl_S
:= Scope
(Curr_S
);
8614 -- Insert all actions including cleanup generated while analyzing or
8615 -- expanding the transient context back into the tree. Manage the
8616 -- secondary stack when the object declaration appears in a library
8617 -- level package [body].
8619 Insert_Actions_In_Scope_Around
8623 Uses_Sec_Stack
(Curr_S
)
8624 and then Nkind
(N
) = N_Object_Declaration
8625 and then Ekind_In
(Encl_S
, E_Package
, E_Package_Body
)
8626 and then Is_Library_Level_Entity
(Encl_S
));
8629 -- Relocate local entities declared within the transient scope to the
8630 -- enclosing scope. This action sets their Is_Public flag accordingly.
8632 Transfer_Entities
(Curr_S
, Encl_S
);
8634 -- Mark the enclosing dynamic scope to ensure that the secondary stack
8635 -- is properly released upon exiting the said scope.
8637 if Uses_Sec_Stack
(Curr_S
) then
8638 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
8640 -- Do not mark a function that returns on the secondary stack as the
8641 -- reclamation is done by the caller.
8643 if Ekind
(Curr_S
) = E_Function
8644 and then Requires_Transient_Scope
(Etype
(Curr_S
))
8648 -- Otherwise mark the enclosing dynamic scope
8651 Set_Uses_Sec_Stack
(Curr_S
);
8652 Check_Restriction
(No_Secondary_Stack
, N
);
8655 end Wrap_Transient_Declaration
;
8657 -------------------------------
8658 -- Wrap_Transient_Expression --
8659 -------------------------------
8661 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
8662 Loc
: constant Source_Ptr
:= Sloc
(N
);
8663 Expr
: Node_Id
:= Relocate_Node
(N
);
8664 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
8665 Typ
: constant Entity_Id
:= Etype
(N
);
8672 -- M : constant Mark_Id := SS_Mark;
8673 -- procedure Finalizer is ... (See Build_Finalizer)
8676 -- Temp := <Expr>; -- general case
8677 -- Temp := (if <Expr> then True else False); -- boolean case
8683 -- A special case is made for Boolean expressions so that the back-end
8684 -- knows to generate a conditional branch instruction, if running with
8685 -- -fpreserve-control-flow. This ensures that a control flow change
8686 -- signalling the decision outcome occurs before the cleanup actions.
8688 if Opt
.Suppress_Control_Flow_Optimizations
8689 and then Is_Boolean_Type
(Typ
)
8692 Make_If_Expression
(Loc
,
8693 Expressions
=> New_List
(
8695 New_Occurrence_Of
(Standard_True
, Loc
),
8696 New_Occurrence_Of
(Standard_False
, Loc
)));
8699 Insert_Actions
(N
, New_List
(
8700 Make_Object_Declaration
(Loc
,
8701 Defining_Identifier
=> Temp
,
8702 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
8704 Make_Transient_Block
(Loc
,
8706 Make_Assignment_Statement
(Loc
,
8707 Name
=> New_Occurrence_Of
(Temp
, Loc
),
8708 Expression
=> Expr
),
8709 Par
=> Parent
(N
))));
8711 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
8712 Analyze_And_Resolve
(N
, Typ
);
8713 end Wrap_Transient_Expression
;
8715 ------------------------------
8716 -- Wrap_Transient_Statement --
8717 ------------------------------
8719 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
8720 Loc
: constant Source_Ptr
:= Sloc
(N
);
8721 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
8726 -- M : constant Mark_Id := SS_Mark;
8727 -- procedure Finalizer is ... (See Build_Finalizer)
8737 Make_Transient_Block
(Loc
,
8739 Par
=> Parent
(N
)));
8741 -- With the scope stack back to normal, we can call analyze on the
8742 -- resulting block. At this point, the transient scope is being
8743 -- treated like a perfectly normal scope, so there is nothing
8744 -- special about it.
8746 -- Note: Wrap_Transient_Statement is called with the node already
8747 -- analyzed (i.e. Analyzed (N) is True). This is important, since
8748 -- otherwise we would get a recursive processing of the node when
8749 -- we do this Analyze call.
8752 end Wrap_Transient_Statement
;