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
);
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 expansion of iterator loops generates an object
2104 -- declaration where the Ekind is explicitly set to loop
2105 -- parameter. This is to ensure that the loop parameter behaves
2106 -- as a constant from user code point of view. Such object are
2107 -- never controlled and do not require finalization.
2109 elsif Ekind
(Obj_Id
) = E_Loop_Parameter
then
2112 -- The object is of the form:
2113 -- Obj : [constant] Typ [:= Expr];
2115 -- Do not process tag-to-class-wide conversions because they do
2116 -- not yield an object. Do not process the incomplete view of a
2117 -- deferred constant. Note that an object initialized by means
2118 -- of a build-in-place function call may appear as a deferred
2119 -- constant after expansion activities. These kinds of objects
2120 -- must be finalized.
2122 elsif not Is_Imported
(Obj_Id
)
2123 and then Needs_Finalization
(Obj_Typ
)
2124 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
2125 and then not (Ekind
(Obj_Id
) = E_Constant
2126 and then not Has_Completion
(Obj_Id
)
2127 and then No
(BIP_Initialization_Call
(Obj_Id
)))
2131 -- The object is of the form:
2132 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2134 -- Obj : Access_Typ :=
2135 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2137 elsif Is_Access_Type
(Obj_Typ
)
2138 and then Needs_Finalization
2139 (Available_View
(Designated_Type
(Obj_Typ
)))
2140 and then Present
(Expr
)
2142 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
2144 (Is_Non_BIP_Func_Call
(Expr
)
2145 and then not Is_Related_To_Func_Return
(Obj_Id
)))
2147 Processing_Actions
(Has_No_Init
=> True);
2149 -- Processing for "hook" objects generated for transient
2150 -- objects declared inside an Expression_With_Actions.
2152 elsif Is_Access_Type
(Obj_Typ
)
2153 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2154 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2155 N_Object_Declaration
2157 Processing_Actions
(Has_No_Init
=> True);
2159 -- Process intermediate results of an if expression with one
2160 -- of the alternatives using a controlled function call.
2162 elsif Is_Access_Type
(Obj_Typ
)
2163 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2164 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2165 N_Defining_Identifier
2166 and then Present
(Expr
)
2167 and then Nkind
(Expr
) = N_Null
2169 Processing_Actions
(Has_No_Init
=> True);
2171 -- Simple protected objects which use type System.Tasking.
2172 -- Protected_Objects.Protection to manage their locks should
2173 -- be treated as controlled since they require manual cleanup.
2174 -- The only exception is illustrated in the following example:
2177 -- type Ctrl is new Controlled ...
2178 -- procedure Finalize (Obj : in out Ctrl);
2182 -- package body Pkg is
2183 -- protected Prot is
2184 -- procedure Do_Something (Obj : in out Ctrl);
2187 -- protected body Prot is
2188 -- procedure Do_Something (Obj : in out Ctrl) is ...
2191 -- procedure Finalize (Obj : in out Ctrl) is
2193 -- Prot.Do_Something (Obj);
2197 -- Since for the most part entities in package bodies depend on
2198 -- those in package specs, Prot's lock should be cleaned up
2199 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2200 -- This act however attempts to invoke Do_Something and fails
2201 -- because the lock has disappeared.
2203 elsif Ekind
(Obj_Id
) = E_Variable
2204 and then not In_Library_Level_Package_Body
(Obj_Id
)
2205 and then (Is_Simple_Protected_Type
(Obj_Typ
)
2206 or else Has_Simple_Protected_Object
(Obj_Typ
))
2208 Processing_Actions
(Is_Protected
=> True);
2211 -- Specific cases of object renamings
2213 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2214 Obj_Id
:= Defining_Identifier
(Decl
);
2215 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2217 -- Bypass any form of processing for objects which have their
2218 -- finalization disabled. This applies only to objects at the
2221 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2224 -- Ignored Ghost object renamings do not need any cleanup
2225 -- actions because they will not appear in the final tree.
2227 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2230 -- Return object of a build-in-place function. This case is
2231 -- recognized and marked by the expansion of an extended return
2232 -- statement (see Expand_N_Extended_Return_Statement).
2234 elsif Needs_Finalization
(Obj_Typ
)
2235 and then Is_Return_Object
(Obj_Id
)
2236 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2238 Processing_Actions
(Has_No_Init
=> True);
2240 -- Detect a case where a source object has been initialized by
2241 -- a controlled function call or another object which was later
2242 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
2244 -- Obj1 : CW_Type := Src_Obj;
2245 -- Obj2 : CW_Type := Function_Call (...);
2247 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
2248 -- Tmp : ... := Function_Call (...)'reference;
2249 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
2251 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
2252 Processing_Actions
(Has_No_Init
=> True);
2255 -- Inspect the freeze node of an access-to-controlled type and
2256 -- look for a delayed finalization master. This case arises when
2257 -- the freeze actions are inserted at a later time than the
2258 -- expansion of the context. Since Build_Finalizer is never called
2259 -- on a single construct twice, the master will be ultimately
2260 -- left out and never finalized. This is also needed for freeze
2261 -- actions of designated types themselves, since in some cases the
2262 -- finalization master is associated with a designated type's
2263 -- freeze node rather than that of the access type (see handling
2264 -- for freeze actions in Build_Finalization_Master).
2266 elsif Nkind
(Decl
) = N_Freeze_Entity
2267 and then Present
(Actions
(Decl
))
2269 Typ
:= Entity
(Decl
);
2271 -- Freeze nodes for ignored Ghost types do not need cleanup
2272 -- actions because they will never appear in the final tree.
2274 if Is_Ignored_Ghost_Entity
(Typ
) then
2277 elsif (Is_Access_Type
(Typ
)
2278 and then not Is_Access_Subprogram_Type
(Typ
)
2279 and then Needs_Finalization
2280 (Available_View
(Designated_Type
(Typ
))))
2281 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2283 Old_Counter_Val
:= Counter_Val
;
2285 -- Freeze nodes are considered to be identical to packages
2286 -- and blocks in terms of nesting. The difference is that
2287 -- a finalization master created inside the freeze node is
2288 -- at the same nesting level as the node itself.
2290 Process_Declarations
(Actions
(Decl
), Preprocess
);
2292 -- The freeze node contains a finalization master
2296 and then No
(Last_Top_Level_Ctrl_Construct
)
2297 and then Counter_Val
> Old_Counter_Val
2299 Last_Top_Level_Ctrl_Construct
:= Decl
;
2303 -- Nested package declarations, avoid generics
2305 elsif Nkind
(Decl
) = N_Package_Declaration
then
2306 Pack_Id
:= Defining_Entity
(Decl
);
2307 Spec
:= Specification
(Decl
);
2309 -- Do not inspect an ignored Ghost package because all code
2310 -- found within will not appear in the final tree.
2312 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
2315 elsif Ekind
(Pack_Id
) /= E_Generic_Package
then
2316 Old_Counter_Val
:= Counter_Val
;
2317 Process_Declarations
2318 (Private_Declarations
(Spec
), Preprocess
);
2319 Process_Declarations
2320 (Visible_Declarations
(Spec
), Preprocess
);
2322 -- Either the visible or the private declarations contain a
2323 -- controlled object. The nested package declaration is the
2324 -- last such construct.
2328 and then No
(Last_Top_Level_Ctrl_Construct
)
2329 and then Counter_Val
> Old_Counter_Val
2331 Last_Top_Level_Ctrl_Construct
:= Decl
;
2335 -- Nested package bodies, avoid generics
2337 elsif Nkind
(Decl
) = N_Package_Body
then
2339 -- Do not inspect an ignored Ghost package body because all
2340 -- code found within will not appear in the final tree.
2342 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
2345 elsif Ekind
(Corresponding_Spec
(Decl
)) /=
2348 Old_Counter_Val
:= Counter_Val
;
2349 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2351 -- The nested package body is the last construct to contain
2352 -- a controlled object.
2356 and then No
(Last_Top_Level_Ctrl_Construct
)
2357 and then Counter_Val
> Old_Counter_Val
2359 Last_Top_Level_Ctrl_Construct
:= Decl
;
2363 -- Handle a rare case caused by a controlled transient object
2364 -- created as part of a record init proc. The variable is wrapped
2365 -- in a block, but the block is not associated with a transient
2368 elsif Nkind
(Decl
) = N_Block_Statement
2369 and then Inside_Init_Proc
2371 Old_Counter_Val
:= Counter_Val
;
2373 if Present
(Handled_Statement_Sequence
(Decl
)) then
2374 Process_Declarations
2375 (Statements
(Handled_Statement_Sequence
(Decl
)),
2379 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2381 -- Either the declaration or statement list of the block has a
2382 -- controlled object.
2386 and then No
(Last_Top_Level_Ctrl_Construct
)
2387 and then Counter_Val
> Old_Counter_Val
2389 Last_Top_Level_Ctrl_Construct
:= Decl
;
2392 -- Handle the case where the original context has been wrapped in
2393 -- a block to avoid interference between exception handlers and
2394 -- At_End handlers. Treat the block as transparent and process its
2397 elsif Nkind
(Decl
) = N_Block_Statement
2398 and then Is_Finalization_Wrapper
(Decl
)
2400 if Present
(Handled_Statement_Sequence
(Decl
)) then
2401 Process_Declarations
2402 (Statements
(Handled_Statement_Sequence
(Decl
)),
2406 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2409 Prev_Non_Pragma
(Decl
);
2411 end Process_Declarations
;
2413 --------------------------------
2414 -- Process_Object_Declaration --
2415 --------------------------------
2417 procedure Process_Object_Declaration
2419 Has_No_Init
: Boolean := False;
2420 Is_Protected
: Boolean := False)
2422 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2423 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2425 Init_Typ
: Entity_Id
;
2426 -- The initialization type of the related object declaration. Note
2427 -- that this is not necessarily the same type as Obj_Typ because of
2428 -- possible type derivations.
2430 Obj_Typ
: Entity_Id
;
2431 -- The type of the related object declaration
2433 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2434 -- Func_Id denotes a build-in-place function. Generate the following
2437 -- if BIPallocfrom > Secondary_Stack'Pos
2438 -- and then BIPfinalizationmaster /= null
2441 -- type Ptr_Typ is access Obj_Typ;
2442 -- for Ptr_Typ'Storage_Pool
2443 -- use Base_Pool (BIPfinalizationmaster);
2445 -- Free (Ptr_Typ (Temp));
2449 -- Obj_Typ is the type of the current object, Temp is the original
2450 -- allocation which Obj_Id renames.
2452 procedure Find_Last_Init
2453 (Last_Init
: out Node_Id
;
2454 Body_Insert
: out Node_Id
);
2455 -- Find the last initialization call related to object declaration
2456 -- Decl. Last_Init denotes the last initialization call which follows
2457 -- Decl. Body_Insert denotes a node where the finalizer body could be
2458 -- potentially inserted after (if blocks are involved).
2460 -----------------------------
2461 -- Build_BIP_Cleanup_Stmts --
2462 -----------------------------
2464 function Build_BIP_Cleanup_Stmts
2465 (Func_Id
: Entity_Id
) return Node_Id
2467 Decls
: constant List_Id
:= New_List
;
2468 Fin_Mas_Id
: constant Entity_Id
:=
2469 Build_In_Place_Formal
2470 (Func_Id
, BIP_Finalization_Master
);
2471 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2472 Temp_Id
: constant Entity_Id
:=
2473 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2477 Free_Stmt
: Node_Id
;
2478 Pool_Id
: Entity_Id
;
2479 Ptr_Typ
: Entity_Id
;
2483 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2485 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2488 Make_Object_Renaming_Declaration
(Loc
,
2489 Defining_Identifier
=> Pool_Id
,
2491 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2493 Make_Explicit_Dereference
(Loc
,
2495 Make_Function_Call
(Loc
,
2497 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2498 Parameter_Associations
=> New_List
(
2499 Make_Explicit_Dereference
(Loc
,
2501 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2503 -- Create an access type which uses the storage pool of the
2504 -- caller's finalization master.
2507 -- type Ptr_Typ is access Func_Typ;
2509 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2512 Make_Full_Type_Declaration
(Loc
,
2513 Defining_Identifier
=> Ptr_Typ
,
2515 Make_Access_To_Object_Definition
(Loc
,
2516 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2518 -- Perform minor decoration in order to set the master and the
2519 -- storage pool attributes.
2521 Set_Ekind
(Ptr_Typ
, E_Access_Type
);
2522 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2523 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2525 -- Create an explicit free statement. Note that the free uses the
2526 -- caller's pool expressed as a renaming.
2529 Make_Free_Statement
(Loc
,
2531 Unchecked_Convert_To
(Ptr_Typ
,
2532 New_Occurrence_Of
(Temp_Id
, Loc
)));
2534 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2536 -- Create a block to house the dummy type and the instantiation as
2537 -- well as to perform the cleanup the temporary.
2543 -- Free (Ptr_Typ (Temp_Id));
2547 Make_Block_Statement
(Loc
,
2548 Declarations
=> Decls
,
2549 Handled_Statement_Sequence
=>
2550 Make_Handled_Sequence_Of_Statements
(Loc
,
2551 Statements
=> New_List
(Free_Stmt
)));
2554 -- if BIPfinalizationmaster /= null then
2558 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2559 Right_Opnd
=> Make_Null
(Loc
));
2561 -- For constrained or tagged results escalate the condition to
2562 -- include the allocation format. Generate:
2564 -- if BIPallocform > Secondary_Stack'Pos
2565 -- and then BIPfinalizationmaster /= null
2568 if not Is_Constrained
(Func_Typ
)
2569 or else Is_Tagged_Type
(Func_Typ
)
2572 Alloc
: constant Entity_Id
:=
2573 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2579 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2581 Make_Integer_Literal
(Loc
,
2583 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2585 Right_Opnd
=> Cond
);
2595 Make_If_Statement
(Loc
,
2597 Then_Statements
=> New_List
(Free_Blk
));
2598 end Build_BIP_Cleanup_Stmts
;
2600 --------------------
2601 -- Find_Last_Init --
2602 --------------------
2604 procedure Find_Last_Init
2605 (Last_Init
: out Node_Id
;
2606 Body_Insert
: out Node_Id
)
2608 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2609 -- Find the last initialization call within the statements of
2612 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2613 -- Determine whether node N denotes one of the initialization
2614 -- procedures of types Init_Typ or Obj_Typ.
2616 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2617 -- Given a statement which is part of a list, return the next
2618 -- statement while skipping over dynamic elab checks.
2620 -----------------------------
2621 -- Find_Last_Init_In_Block --
2622 -----------------------------
2624 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2625 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2629 -- Examine the individual statements of the block in reverse to
2630 -- locate the last initialization call.
2632 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2633 Stmt
:= Last
(Statements
(HSS
));
2634 while Present
(Stmt
) loop
2636 -- Peek inside nested blocks in case aborts are allowed
2638 if Nkind
(Stmt
) = N_Block_Statement
then
2639 return Find_Last_Init_In_Block
(Stmt
);
2641 elsif Is_Init_Call
(Stmt
) then
2650 end Find_Last_Init_In_Block
;
2656 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2657 function Is_Init_Proc_Of
2658 (Subp_Id
: Entity_Id
;
2659 Typ
: Entity_Id
) return Boolean;
2660 -- Determine whether subprogram Subp_Id is a valid init proc of
2663 ---------------------
2664 -- Is_Init_Proc_Of --
2665 ---------------------
2667 function Is_Init_Proc_Of
2668 (Subp_Id
: Entity_Id
;
2669 Typ
: Entity_Id
) return Boolean
2671 Deep_Init
: Entity_Id
:= Empty
;
2672 Prim_Init
: Entity_Id
:= Empty
;
2673 Type_Init
: Entity_Id
:= Empty
;
2676 -- Obtain all possible initialization routines of the
2677 -- related type and try to match the subprogram entity
2678 -- against one of them.
2682 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2684 -- Primitive Initialize
2686 if Is_Controlled
(Typ
) then
2687 Prim_Init
:= Find_Optional_Prim_Op
(Typ
, Name_Initialize
);
2689 if Present
(Prim_Init
) then
2690 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2694 -- Type initialization routine
2696 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2697 Type_Init
:= Base_Init_Proc
(Typ
);
2701 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2703 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2705 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2706 end Is_Init_Proc_Of
;
2710 Call_Id
: Entity_Id
;
2712 -- Start of processing for Is_Init_Call
2715 if Nkind
(N
) = N_Procedure_Call_Statement
2716 and then Nkind
(Name
(N
)) = N_Identifier
2718 Call_Id
:= Entity
(Name
(N
));
2720 -- Consider both the type of the object declaration and its
2721 -- related initialization type.
2724 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2726 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2732 -----------------------------
2733 -- Next_Suitable_Statement --
2734 -----------------------------
2736 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2737 Result
: Node_Id
:= Next
(Stmt
);
2740 -- Skip over access-before-elaboration checks
2742 if Dynamic_Elaboration_Checks
2743 and then Nkind
(Result
) = N_Raise_Program_Error
2745 Result
:= Next
(Result
);
2749 end Next_Suitable_Statement
;
2757 Deep_Init_Found
: Boolean := False;
2758 -- A flag set when a call to [Deep_]Initialize has been found
2760 -- Start of processing for Find_Last_Init
2764 Body_Insert
:= Empty
;
2766 -- Object renamings and objects associated with controlled
2767 -- function results do not require initialization.
2773 Stmt
:= Next_Suitable_Statement
(Decl
);
2775 -- Nothing to do for an object with suppressed initialization
2777 if No_Initialization
(Decl
) then
2780 -- In all other cases the initialization calls follow the related
2781 -- object. The general structure of object initialization built by
2782 -- routine Default_Initialize_Object is as follows:
2784 -- [begin -- aborts allowed
2786 -- Type_Init_Proc (Obj);
2787 -- [begin] -- exceptions allowed
2788 -- Deep_Initialize (Obj);
2789 -- [exception -- exceptions allowed
2791 -- Deep_Finalize (Obj, Self => False);
2794 -- [at end -- aborts allowed
2798 -- When aborts are allowed, the initialization calls are housed
2801 elsif Nkind
(Stmt
) = N_Block_Statement
then
2802 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
2803 Body_Insert
:= Stmt
;
2805 -- Otherwise the initialization calls follow the related object
2808 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
2810 -- Check for an optional call to Deep_Initialize which may
2811 -- appear within a block depending on whether the object has
2812 -- controlled components.
2814 if Present
(Stmt_2
) then
2815 if Nkind
(Stmt_2
) = N_Block_Statement
then
2816 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
2818 if Present
(Call
) then
2819 Deep_Init_Found
:= True;
2821 Body_Insert
:= Stmt_2
;
2824 elsif Is_Init_Call
(Stmt_2
) then
2825 Deep_Init_Found
:= True;
2826 Last_Init
:= Stmt_2
;
2827 Body_Insert
:= Last_Init
;
2831 -- If the object lacks a call to Deep_Initialize, then it must
2832 -- have a call to its related type init proc.
2834 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
2836 Body_Insert
:= Last_Init
;
2844 Count_Ins
: Node_Id
;
2846 Fin_Stmts
: List_Id
:= No_List
;
2849 Label_Id
: Entity_Id
;
2852 -- Start of processing for Process_Object_Declaration
2855 -- Handle the object type and the reference to the object
2857 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
2858 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2861 if Is_Access_Type
(Obj_Typ
) then
2862 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2863 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2865 elsif Is_Concurrent_Type
(Obj_Typ
)
2866 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
2868 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
2869 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2871 elsif Is_Private_Type
(Obj_Typ
)
2872 and then Present
(Full_View
(Obj_Typ
))
2874 Obj_Typ
:= Full_View
(Obj_Typ
);
2875 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2877 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
2878 Obj_Typ
:= Base_Type
(Obj_Typ
);
2879 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2886 Set_Etype
(Obj_Ref
, Obj_Typ
);
2888 -- Handle the initialization type of the object declaration
2890 Init_Typ
:= Obj_Typ
;
2892 if Is_Private_Type
(Init_Typ
)
2893 and then Present
(Full_View
(Init_Typ
))
2895 Init_Typ
:= Full_View
(Init_Typ
);
2897 elsif Is_Untagged_Derivation
(Init_Typ
) then
2898 Init_Typ
:= Root_Type
(Init_Typ
);
2905 -- Set a new value for the state counter and insert the statement
2906 -- after the object declaration. Generate:
2908 -- Counter := <value>;
2911 Make_Assignment_Statement
(Loc
,
2912 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
2913 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
2915 -- Insert the counter after all initialization has been done. The
2916 -- place of insertion depends on the context.
2918 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
) then
2920 -- The object is initialized by a build-in-place function call.
2921 -- The counter insertion point is after the function call.
2923 if Present
(BIP_Initialization_Call
(Obj_Id
)) then
2924 Count_Ins
:= BIP_Initialization_Call
(Obj_Id
);
2927 -- The object is initialized by an aggregate. Insert the counter
2928 -- after the last aggregate assignment.
2930 elsif Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
2931 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
2934 -- In all other cases the counter is inserted after the last call
2935 -- to either [Deep_]Initialize or the type-specific init proc.
2938 Find_Last_Init
(Count_Ins
, Body_Ins
);
2941 -- In all other cases the counter is inserted after the last call to
2942 -- either [Deep_]Initialize or the type-specific init proc.
2945 Find_Last_Init
(Count_Ins
, Body_Ins
);
2948 -- If the Initialize function is null or trivial, the call will have
2949 -- been replaced with a null statement, in which case place counter
2950 -- declaration after object declaration itself.
2952 if No
(Count_Ins
) then
2956 Insert_After
(Count_Ins
, Inc_Decl
);
2959 -- If the current declaration is the last in the list, the finalizer
2960 -- body needs to be inserted after the set counter statement for the
2961 -- current object declaration. This is complicated by the fact that
2962 -- the set counter statement may appear in abort deferred block. In
2963 -- that case, the proper insertion place is after the block.
2965 if No
(Finalizer_Insert_Nod
) then
2967 -- Insertion after an abort deffered block
2969 if Present
(Body_Ins
) then
2970 Finalizer_Insert_Nod
:= Body_Ins
;
2972 Finalizer_Insert_Nod
:= Inc_Decl
;
2976 -- Create the associated label with this object, generate:
2978 -- L<counter> : label;
2981 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
2983 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
2984 Label
:= Make_Label
(Loc
, Label_Id
);
2986 Prepend_To
(Finalizer_Decls
,
2987 Make_Implicit_Label_Declaration
(Loc
,
2988 Defining_Identifier
=> Entity
(Label_Id
),
2989 Label_Construct
=> Label
));
2991 -- Create the associated jump with this object, generate:
2993 -- when <counter> =>
2996 Prepend_To
(Jump_Alts
,
2997 Make_Case_Statement_Alternative
(Loc
,
2998 Discrete_Choices
=> New_List
(
2999 Make_Integer_Literal
(Loc
, Counter_Val
)),
3000 Statements
=> New_List
(
3001 Make_Goto_Statement
(Loc
,
3002 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3004 -- Insert the jump destination, generate:
3008 Append_To
(Finalizer_Stmts
, Label
);
3010 -- Processing for simple protected objects. Such objects require
3011 -- manual finalization of their lock managers.
3013 if Is_Protected
then
3014 if Is_Simple_Protected_Type
(Obj_Typ
) then
3015 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
3017 if Present
(Fin_Call
) then
3018 Fin_Stmts
:= New_List
(Fin_Call
);
3021 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
3022 if Is_Record_Type
(Obj_Typ
) then
3023 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
3024 elsif Is_Array_Type
(Obj_Typ
) then
3025 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
3031 -- System.Tasking.Protected_Objects.Finalize_Protection
3039 if Present
(Fin_Stmts
) and then Exceptions_OK
then
3040 Fin_Stmts
:= New_List
(
3041 Make_Block_Statement
(Loc
,
3042 Handled_Statement_Sequence
=>
3043 Make_Handled_Sequence_Of_Statements
(Loc
,
3044 Statements
=> Fin_Stmts
,
3046 Exception_Handlers
=> New_List
(
3047 Make_Exception_Handler
(Loc
,
3048 Exception_Choices
=> New_List
(
3049 Make_Others_Choice
(Loc
)),
3051 Statements
=> New_List
(
3052 Make_Null_Statement
(Loc
)))))));
3055 -- Processing for regular controlled objects
3060 -- [Deep_]Finalize (Obj);
3063 -- when Id : others =>
3064 -- if not Raised then
3066 -- Save_Occurrence (E, Id);
3075 -- Guard against a missing [Deep_]Finalize when the object type
3076 -- was not properly frozen.
3078 if No
(Fin_Call
) then
3079 Fin_Call
:= Make_Null_Statement
(Loc
);
3082 -- For CodePeer, the exception handlers normally generated here
3083 -- generate complex flowgraphs which result in capacity problems.
3084 -- Omitting these handlers for CodePeer is justified as follows:
3086 -- If a handler is dead, then omitting it is surely ok
3088 -- If a handler is live, then CodePeer should flag the
3089 -- potentially-exception-raising construct that causes it
3090 -- to be live. That is what we are interested in, not what
3091 -- happens after the exception is raised.
3093 if Exceptions_OK
and not CodePeer_Mode
then
3094 Fin_Stmts
:= New_List
(
3095 Make_Block_Statement
(Loc
,
3096 Handled_Statement_Sequence
=>
3097 Make_Handled_Sequence_Of_Statements
(Loc
,
3098 Statements
=> New_List
(Fin_Call
),
3100 Exception_Handlers
=> New_List
(
3101 Build_Exception_Handler
3102 (Finalizer_Data
, For_Package
)))));
3104 -- When exception handlers are prohibited, the finalization call
3105 -- appears unprotected. Any exception raised during finalization
3106 -- will bypass the circuitry which ensures the cleanup of all
3107 -- remaining objects.
3110 Fin_Stmts
:= New_List
(Fin_Call
);
3113 -- If we are dealing with a return object of a build-in-place
3114 -- function, generate the following cleanup statements:
3116 -- if BIPallocfrom > Secondary_Stack'Pos
3117 -- and then BIPfinalizationmaster /= null
3120 -- type Ptr_Typ is access Obj_Typ;
3121 -- for Ptr_Typ'Storage_Pool use
3122 -- Base_Pool (BIPfinalizationmaster.all).all;
3124 -- Free (Ptr_Typ (Temp));
3128 -- The generated code effectively detaches the temporary from the
3129 -- caller finalization master and deallocates the object.
3131 if Is_Return_Object
(Obj_Id
) then
3133 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
3135 if Is_Build_In_Place_Function
(Func_Id
)
3136 and then Needs_BIP_Finalization_Master
(Func_Id
)
3138 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
3143 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
3144 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
3146 -- Temporaries created for the purpose of "exporting" a
3147 -- transient object out of an Expression_With_Actions (EWA)
3148 -- need guards. The following illustrates the usage of such
3151 -- Access_Typ : access [all] Obj_Typ;
3152 -- Temp : Access_Typ := null;
3153 -- <Counter> := ...;
3156 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3157 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3159 -- Temp := Ctrl_Trans'Unchecked_Access;
3162 -- The finalization machinery does not process EWA nodes as
3163 -- this may lead to premature finalization of expressions. Note
3164 -- that Temp is marked as being properly initialized regardless
3165 -- of whether the initialization of Ctrl_Trans succeeded. Since
3166 -- a failed initialization may leave Temp with a value of null,
3167 -- add a guard to handle this case:
3169 -- if Obj /= null then
3170 -- <object finalization statements>
3173 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
3174 N_Object_Declaration
3176 Fin_Stmts
:= New_List
(
3177 Make_If_Statement
(Loc
,
3180 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
3181 Right_Opnd
=> Make_Null
(Loc
)),
3182 Then_Statements
=> Fin_Stmts
));
3184 -- Return objects use a flag to aid in processing their
3185 -- potential finalization when the enclosing function fails
3186 -- to return properly. Generate:
3189 -- <object finalization statements>
3193 Fin_Stmts
:= New_List
(
3194 Make_If_Statement
(Loc
,
3199 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
3201 Then_Statements
=> Fin_Stmts
));
3206 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
3208 -- Since the declarations are examined in reverse, the state counter
3209 -- must be decremented in order to keep with the true position of
3212 Counter_Val
:= Counter_Val
- 1;
3213 end Process_Object_Declaration
;
3215 -------------------------------------
3216 -- Process_Tagged_Type_Declaration --
3217 -------------------------------------
3219 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
3220 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3221 DT_Ptr
: constant Entity_Id
:=
3222 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
3225 -- Ada.Tags.Unregister_Tag (<Typ>P);
3227 Append_To
(Tagged_Type_Stmts
,
3228 Make_Procedure_Call_Statement
(Loc
,
3230 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
3231 Parameter_Associations
=> New_List
(
3232 New_Occurrence_Of
(DT_Ptr
, Loc
))));
3233 end Process_Tagged_Type_Declaration
;
3235 -- Start of processing for Build_Finalizer
3240 -- Do not perform this expansion in SPARK mode because it is not
3243 if GNATprove_Mode
then
3247 -- Step 1: Extract all lists which may contain controlled objects or
3248 -- library-level tagged types.
3250 if For_Package_Spec
then
3251 Decls
:= Visible_Declarations
(Specification
(N
));
3252 Priv_Decls
:= Private_Declarations
(Specification
(N
));
3254 -- Retrieve the package spec id
3256 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
3258 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
3259 Spec_Id
:= Defining_Identifier
(Spec_Id
);
3262 -- Accept statement, block, entry body, package body, protected body,
3263 -- subprogram body or task body.
3266 Decls
:= Declarations
(N
);
3267 HSS
:= Handled_Statement_Sequence
(N
);
3269 if Present
(HSS
) then
3270 if Present
(Statements
(HSS
)) then
3271 Stmts
:= Statements
(HSS
);
3274 if Present
(At_End_Proc
(HSS
)) then
3275 Prev_At_End
:= At_End_Proc
(HSS
);
3279 -- Retrieve the package spec id for package bodies
3281 if For_Package_Body
then
3282 Spec_Id
:= Corresponding_Spec
(N
);
3286 -- Do not process nested packages since those are handled by the
3287 -- enclosing scope's finalizer. Do not process non-expanded package
3288 -- instantiations since those will be re-analyzed and re-expanded.
3292 (not Is_Library_Level_Entity
(Spec_Id
)
3294 -- Nested packages are considered to be library level entities,
3295 -- but do not need to be processed separately. True library level
3296 -- packages have a scope value of 1.
3298 or else Scope_Depth_Value
(Spec_Id
) /= Uint_1
3299 or else (Is_Generic_Instance
(Spec_Id
)
3300 and then Package_Instantiation
(Spec_Id
) /= N
))
3305 -- Step 2: Object [pre]processing
3309 -- Preprocess the visible declarations now in order to obtain the
3310 -- correct number of controlled object by the time the private
3311 -- declarations are processed.
3313 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3315 -- From all the possible contexts, only package specifications may
3316 -- have private declarations.
3318 if For_Package_Spec
then
3319 Process_Declarations
3320 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
3323 -- The current context may lack controlled objects, but require some
3324 -- other form of completion (task termination for instance). In such
3325 -- cases, the finalizer must be created and carry the additional
3328 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3332 -- The preprocessing has determined that the context has controlled
3333 -- objects or library-level tagged types.
3335 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3337 -- Private declarations are processed first in order to preserve
3338 -- possible dependencies between public and private objects.
3340 if For_Package_Spec
then
3341 Process_Declarations
(Priv_Decls
);
3344 Process_Declarations
(Decls
);
3350 -- Preprocess both declarations and statements
3352 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3353 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3355 -- At this point it is known that N has controlled objects. Ensure
3356 -- that N has a declarative list since the finalizer spec will be
3359 if Has_Ctrl_Objs
and then No
(Decls
) then
3360 Set_Declarations
(N
, New_List
);
3361 Decls
:= Declarations
(N
);
3362 Spec_Decls
:= Decls
;
3365 -- The current context may lack controlled objects, but require some
3366 -- other form of completion (task termination for instance). In such
3367 -- cases, the finalizer must be created and carry the additional
3370 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3374 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3375 Process_Declarations
(Stmts
);
3376 Process_Declarations
(Decls
);
3380 -- Step 3: Finalizer creation
3382 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3385 end Build_Finalizer
;
3387 --------------------------
3388 -- Build_Finalizer_Call --
3389 --------------------------
3391 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3392 Is_Prot_Body
: constant Boolean :=
3393 Nkind
(N
) = N_Subprogram_Body
3394 and then Is_Protected_Subprogram_Body
(N
);
3395 -- Determine whether N denotes the protected version of a subprogram
3396 -- which belongs to a protected type.
3398 Loc
: constant Source_Ptr
:= Sloc
(N
);
3402 -- Do not perform this expansion in SPARK mode because we do not create
3403 -- finalizers in the first place.
3405 if GNATprove_Mode
then
3409 -- The At_End handler should have been assimilated by the finalizer
3411 HSS
:= Handled_Statement_Sequence
(N
);
3412 pragma Assert
(No
(At_End_Proc
(HSS
)));
3414 -- If the construct to be cleaned up is a protected subprogram body, the
3415 -- finalizer call needs to be associated with the block which wraps the
3416 -- unprotected version of the subprogram. The following illustrates this
3419 -- procedure Prot_SubpP is
3420 -- procedure finalizer is
3422 -- Service_Entries (Prot_Obj);
3429 -- Prot_SubpN (Prot_Obj);
3435 if Is_Prot_Body
then
3436 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
3438 -- An At_End handler and regular exception handlers cannot coexist in
3439 -- the same statement sequence. Wrap the original statements in a block.
3441 elsif Present
(Exception_Handlers
(HSS
)) then
3443 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
3448 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3450 Set_Handled_Statement_Sequence
(N
,
3451 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3453 HSS
:= Handled_Statement_Sequence
(N
);
3454 Set_End_Label
(HSS
, End_Lab
);
3458 Set_At_End_Proc
(HSS
, New_Occurrence_Of
(Fin_Id
, Loc
));
3460 Analyze
(At_End_Proc
(HSS
));
3461 Expand_At_End_Handler
(HSS
, Empty
);
3462 end Build_Finalizer_Call
;
3464 ---------------------
3465 -- Build_Late_Proc --
3466 ---------------------
3468 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3470 for Final_Prim
in Name_Of
'Range loop
3471 if Name_Of
(Final_Prim
) = Nam
then
3474 (Prim
=> Final_Prim
,
3476 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3479 end Build_Late_Proc
;
3481 -------------------------------
3482 -- Build_Object_Declarations --
3483 -------------------------------
3485 procedure Build_Object_Declarations
3486 (Data
: out Finalization_Exception_Data
;
3489 For_Package
: Boolean := False)
3494 -- This variable captures an unused dummy internal entity, see the
3495 -- comment associated with its use.
3498 pragma Assert
(Decls
/= No_List
);
3500 -- Always set the proper location as it may be needed even when
3501 -- exception propagation is forbidden.
3505 if Restriction_Active
(No_Exception_Propagation
) then
3506 Data
.Abort_Id
:= Empty
;
3508 Data
.Raised_Id
:= Empty
;
3512 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3514 -- In certain scenarios, finalization can be triggered by an abort. If
3515 -- the finalization itself fails and raises an exception, the resulting
3516 -- Program_Error must be supressed and replaced by an abort signal. In
3517 -- order to detect this scenario, save the state of entry into the
3518 -- finalization code.
3520 -- This is not needed for library-level finalizers as they are called by
3521 -- the environment task and cannot be aborted.
3523 if not For_Package
then
3524 if Abort_Allowed
then
3525 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3528 -- Abort_Id : constant Boolean := <A_Expr>;
3531 Make_Object_Declaration
(Loc
,
3532 Defining_Identifier
=> Data
.Abort_Id
,
3533 Constant_Present
=> True,
3534 Object_Definition
=>
3535 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3537 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
3539 -- Abort is not required
3542 -- Generate a dummy entity to ensure that the internal symbols are
3543 -- in sync when a unit is compiled with and without aborts.
3545 Dummy
:= Make_Temporary
(Loc
, 'A');
3546 Data
.Abort_Id
:= Empty
;
3549 -- Library-level finalizers
3552 Data
.Abort_Id
:= Empty
;
3555 if Exception_Extra_Info
then
3556 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3559 -- E_Id : Exception_Occurrence;
3562 Make_Object_Declaration
(Loc
,
3563 Defining_Identifier
=> Data
.E_Id
,
3564 Object_Definition
=>
3565 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3566 Set_No_Initialization
(Decl
);
3568 Append_To
(Decls
, Decl
);
3575 -- Raised_Id : Boolean := False;
3578 Make_Object_Declaration
(Loc
,
3579 Defining_Identifier
=> Data
.Raised_Id
,
3580 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3581 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3582 end Build_Object_Declarations
;
3584 ---------------------------
3585 -- Build_Raise_Statement --
3586 ---------------------------
3588 function Build_Raise_Statement
3589 (Data
: Finalization_Exception_Data
) return Node_Id
3595 -- Standard run-time use the specialized routine
3596 -- Raise_From_Controlled_Operation.
3598 if Exception_Extra_Info
3599 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3602 Make_Procedure_Call_Statement
(Data
.Loc
,
3605 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3606 Parameter_Associations
=>
3607 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3609 -- Restricted run-time: exception messages are not supported and hence
3610 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3615 Make_Raise_Program_Error
(Data
.Loc
,
3616 Reason
=> PE_Finalize_Raised_Exception
);
3621 -- Raised_Id and then not Abort_Id
3625 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3627 if Present
(Data
.Abort_Id
) then
3628 Expr
:= Make_And_Then
(Data
.Loc
,
3631 Make_Op_Not
(Data
.Loc
,
3632 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3637 -- if Raised_Id and then not Abort_Id then
3638 -- Raise_From_Controlled_Operation (E_Id);
3640 -- raise Program_Error; -- restricted runtime
3644 Make_If_Statement
(Data
.Loc
,
3646 Then_Statements
=> New_List
(Stmt
));
3647 end Build_Raise_Statement
;
3649 -----------------------------
3650 -- Build_Record_Deep_Procs --
3651 -----------------------------
3653 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3657 (Prim
=> Initialize_Case
,
3659 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3661 if not Is_Limited_View
(Typ
) then
3664 (Prim
=> Adjust_Case
,
3666 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3669 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3670 -- suppressed since these routine will not be used.
3672 if not Restriction_Active
(No_Finalization
) then
3675 (Prim
=> Finalize_Case
,
3677 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3679 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3681 if not CodePeer_Mode
then
3684 (Prim
=> Address_Case
,
3686 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3689 end Build_Record_Deep_Procs
;
3695 function Cleanup_Array
3698 Typ
: Entity_Id
) return List_Id
3700 Loc
: constant Source_Ptr
:= Sloc
(N
);
3701 Index_List
: constant List_Id
:= New_List
;
3703 function Free_Component
return List_Id
;
3704 -- Generate the code to finalize the task or protected subcomponents
3705 -- of a single component of the array.
3707 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3708 -- Generate a loop over one dimension of the array
3710 --------------------
3711 -- Free_Component --
3712 --------------------
3714 function Free_Component
return List_Id
is
3715 Stmts
: List_Id
:= New_List
;
3717 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3720 -- Component type is known to contain tasks or protected objects
3723 Make_Indexed_Component
(Loc
,
3724 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3725 Expressions
=> Index_List
);
3727 Set_Etype
(Tsk
, C_Typ
);
3729 if Is_Task_Type
(C_Typ
) then
3730 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3732 elsif Is_Simple_Protected_Type
(C_Typ
) then
3733 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3735 elsif Is_Record_Type
(C_Typ
) then
3736 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3738 elsif Is_Array_Type
(C_Typ
) then
3739 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3745 ------------------------
3746 -- Free_One_Dimension --
3747 ------------------------
3749 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3753 if Dim
> Number_Dimensions
(Typ
) then
3754 return Free_Component
;
3756 -- Here we generate the required loop
3759 Index
:= Make_Temporary
(Loc
, 'J');
3760 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
3763 Make_Implicit_Loop_Statement
(N
,
3764 Identifier
=> Empty
,
3766 Make_Iteration_Scheme
(Loc
,
3767 Loop_Parameter_Specification
=>
3768 Make_Loop_Parameter_Specification
(Loc
,
3769 Defining_Identifier
=> Index
,
3770 Discrete_Subtype_Definition
=>
3771 Make_Attribute_Reference
(Loc
,
3772 Prefix
=> Duplicate_Subexpr
(Obj
),
3773 Attribute_Name
=> Name_Range
,
3774 Expressions
=> New_List
(
3775 Make_Integer_Literal
(Loc
, Dim
))))),
3776 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3778 end Free_One_Dimension
;
3780 -- Start of processing for Cleanup_Array
3783 return Free_One_Dimension
(1);
3786 --------------------
3787 -- Cleanup_Record --
3788 --------------------
3790 function Cleanup_Record
3793 Typ
: Entity_Id
) return List_Id
3795 Loc
: constant Source_Ptr
:= Sloc
(N
);
3798 Stmts
: constant List_Id
:= New_List
;
3799 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3802 if Has_Discriminants
(U_Typ
)
3803 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3804 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3807 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3809 -- For now, do not attempt to free a component that may appear in a
3810 -- variant, and instead issue a warning. Doing this "properly" would
3811 -- require building a case statement and would be quite a mess. Note
3812 -- that the RM only requires that free "work" for the case of a task
3813 -- access value, so already we go way beyond this in that we deal
3814 -- with the array case and non-discriminated record cases.
3817 ("task/protected object in variant record will not be freed??", N
);
3818 return New_List
(Make_Null_Statement
(Loc
));
3821 Comp
:= First_Component
(Typ
);
3822 while Present
(Comp
) loop
3823 if Has_Task
(Etype
(Comp
))
3824 or else Has_Simple_Protected_Object
(Etype
(Comp
))
3827 Make_Selected_Component
(Loc
,
3828 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3829 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3830 Set_Etype
(Tsk
, Etype
(Comp
));
3832 if Is_Task_Type
(Etype
(Comp
)) then
3833 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3835 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3836 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3838 elsif Is_Record_Type
(Etype
(Comp
)) then
3840 -- Recurse, by generating the prefix of the argument to
3841 -- the eventual cleanup call.
3843 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3845 elsif Is_Array_Type
(Etype
(Comp
)) then
3846 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3850 Next_Component
(Comp
);
3856 ------------------------------
3857 -- Cleanup_Protected_Object --
3858 ------------------------------
3860 function Cleanup_Protected_Object
3862 Ref
: Node_Id
) return Node_Id
3864 Loc
: constant Source_Ptr
:= Sloc
(N
);
3867 -- For restricted run-time libraries (Ravenscar), tasks are
3868 -- non-terminating, and protected objects can only appear at library
3869 -- level, so we do not want finalization of protected objects.
3871 if Restricted_Profile
then
3876 Make_Procedure_Call_Statement
(Loc
,
3878 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
3879 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3881 end Cleanup_Protected_Object
;
3887 function Cleanup_Task
3889 Ref
: Node_Id
) return Node_Id
3891 Loc
: constant Source_Ptr
:= Sloc
(N
);
3894 -- For restricted run-time libraries (Ravenscar), tasks are
3895 -- non-terminating and they can only appear at library level, so we do
3896 -- not want finalization of task objects.
3898 if Restricted_Profile
then
3903 Make_Procedure_Call_Statement
(Loc
,
3905 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
3906 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3910 ------------------------------
3911 -- Check_Visibly_Controlled --
3912 ------------------------------
3914 procedure Check_Visibly_Controlled
3915 (Prim
: Final_Primitives
;
3917 E
: in out Entity_Id
;
3918 Cref
: in out Node_Id
)
3920 Parent_Type
: Entity_Id
;
3924 if Is_Derived_Type
(Typ
)
3925 and then Comes_From_Source
(E
)
3926 and then not Present
(Overridden_Operation
(E
))
3928 -- We know that the explicit operation on the type does not override
3929 -- the inherited operation of the parent, and that the derivation
3930 -- is from a private type that is not visibly controlled.
3932 Parent_Type
:= Etype
(Typ
);
3933 Op
:= Find_Optional_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
3935 if Present
(Op
) then
3938 -- Wrap the object to be initialized into the proper
3939 -- unchecked conversion, to be compatible with the operation
3942 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
3943 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
3945 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
3949 end Check_Visibly_Controlled
;
3955 function Convert_View
3958 Ind
: Pos
:= 1) return Node_Id
3960 Fent
: Entity_Id
:= First_Entity
(Proc
);
3965 for J
in 2 .. Ind
loop
3969 Ftyp
:= Etype
(Fent
);
3971 if Nkind_In
(Arg
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
3972 Atyp
:= Entity
(Subtype_Mark
(Arg
));
3974 Atyp
:= Etype
(Arg
);
3977 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
3978 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
3981 and then Present
(Atyp
)
3982 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
3983 and then Base_Type
(Underlying_Type
(Atyp
)) =
3984 Base_Type
(Underlying_Type
(Ftyp
))
3986 return Unchecked_Convert_To
(Ftyp
, Arg
);
3988 -- If the argument is already a conversion, as generated by
3989 -- Make_Init_Call, set the target type to the type of the formal
3990 -- directly, to avoid spurious typing problems.
3992 elsif Nkind_In
(Arg
, N_Unchecked_Type_Conversion
, N_Type_Conversion
)
3993 and then not Is_Class_Wide_Type
(Atyp
)
3995 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
3996 Set_Etype
(Arg
, Ftyp
);
3999 -- Otherwise, introduce a conversion when the designated object
4000 -- has a type derived from the formal of the controlled routine.
4002 elsif Is_Private_Type
(Ftyp
)
4003 and then Present
(Atyp
)
4004 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
4006 return Unchecked_Convert_To
(Ftyp
, Arg
);
4013 -------------------------------
4014 -- CW_Or_Has_Controlled_Part --
4015 -------------------------------
4017 function CW_Or_Has_Controlled_Part
(T
: Entity_Id
) return Boolean is
4019 return Is_Class_Wide_Type
(T
) or else Needs_Finalization
(T
);
4020 end CW_Or_Has_Controlled_Part
;
4022 ------------------------
4023 -- Enclosing_Function --
4024 ------------------------
4026 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
4027 Func_Id
: Entity_Id
;
4031 while Present
(Func_Id
) and then Func_Id
/= Standard_Standard
loop
4032 if Ekind
(Func_Id
) = E_Function
then
4036 Func_Id
:= Scope
(Func_Id
);
4040 end Enclosing_Function
;
4042 -------------------------------
4043 -- Establish_Transient_Scope --
4044 -------------------------------
4046 -- This procedure is called each time a transient block has to be inserted
4047 -- that is to say for each call to a function with unconstrained or tagged
4048 -- result. It creates a new scope on the stack scope in order to enclose
4049 -- all transient variables generated.
4051 procedure Establish_Transient_Scope
(N
: Node_Id
; Sec_Stack
: Boolean) is
4052 Loc
: constant Source_Ptr
:= Sloc
(N
);
4053 Iter_Loop
: Entity_Id
;
4054 Scop_Id
: Entity_Id
;
4055 Scop_Rec
: Scope_Stack_Entry
;
4056 Wrap_Node
: Node_Id
;
4059 -- Do not create a new transient scope if there is an existing transient
4060 -- scope on the stack.
4062 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4063 Scop_Rec
:= Scope_Stack
.Table
(Index
);
4064 Scop_Id
:= Scop_Rec
.Entity
;
4066 -- The current scope is transient. If the scope being established
4067 -- needs to manage the secondary stack, then the existing scope
4068 -- overtakes that function.
4070 if Scop_Rec
.Is_Transient
then
4072 Set_Uses_Sec_Stack
(Scop_Id
);
4077 -- Prevent the search from going too far because transient blocks
4078 -- are bounded by packages and subprogram scopes. Reaching Standard
4079 -- should be impossible without hitting one of the other cases first
4080 -- unless Standard was manually pushed.
4082 elsif Scop_Id
= Standard_Standard
4083 or else Ekind_In
(Scop_Id
, E_Entry
,
4094 Wrap_Node
:= Find_Node_To_Be_Wrapped
(N
);
4096 -- The context does not contain a node that requires a transient scope,
4099 if No
(Wrap_Node
) then
4102 -- If the node to wrap is an iteration_scheme, the expression is one of
4103 -- the bounds, and the expansion will make an explicit declaration for
4104 -- it (see Analyze_Iteration_Scheme, sem_ch5.adb), so do not apply any
4105 -- transformations here. Same for an Ada 2012 iterator specification,
4106 -- where a block is created for the expression that build the container.
4108 elsif Nkind_In
(Wrap_Node
, N_Iteration_Scheme
,
4109 N_Iterator_Specification
)
4113 -- In formal verification mode, if the node to wrap is a pragma check,
4114 -- this node and enclosed expression are not expanded, so do not apply
4115 -- any transformations here.
4117 elsif GNATprove_Mode
4118 and then Nkind
(Wrap_Node
) = N_Pragma
4119 and then Get_Pragma_Id
(Wrap_Node
) = Pragma_Check
4123 -- Create a block entity to act as a transient scope. Note that when the
4124 -- node to be wrapped is an expression or a statement, a real physical
4125 -- block is constructed (see routines Wrap_Transient_Expression and
4126 -- Wrap_Transient_Statement) and inserted into the tree.
4129 Push_Scope
(New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B'));
4130 Set_Scope_Is_Transient
;
4132 -- The transient scope must also take care of the secondary stack
4136 Set_Uses_Sec_Stack
(Current_Scope
);
4137 Check_Restriction
(No_Secondary_Stack
, N
);
4139 -- The expansion of iterator loops generates references to objects
4140 -- in order to extract elements from a container:
4142 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4143 -- Obj : <object type> renames Ref.all.Element.all;
4145 -- These references are controlled and returned on the secondary
4146 -- stack. A new reference is created at each iteration of the loop
4147 -- and as a result it must be finalized and the space occupied by
4148 -- it on the secondary stack reclaimed at the end of the current
4151 -- When the context that requires a transient scope is a call to
4152 -- routine Reference, the node to be wrapped is the source object:
4154 -- for Obj of Container loop
4156 -- Routine Wrap_Transient_Declaration however does not generate a
4157 -- physical block as wrapping a declaration will kill it too ealy.
4158 -- To handle this peculiar case, mark the related iterator loop as
4159 -- requiring the secondary stack. This signals the finalization
4160 -- machinery to manage the secondary stack (see routine
4161 -- Process_Statements_For_Controlled_Objects).
4163 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Current_Scope
);
4165 if Present
(Iter_Loop
) then
4166 Set_Uses_Sec_Stack
(Iter_Loop
);
4170 Set_Etype
(Current_Scope
, Standard_Void_Type
);
4171 Set_Node_To_Be_Wrapped
(Wrap_Node
);
4173 if Debug_Flag_W
then
4174 Write_Str
(" <Transient>");
4178 end Establish_Transient_Scope
;
4180 ----------------------------
4181 -- Expand_Cleanup_Actions --
4182 ----------------------------
4184 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
4185 Scop
: constant Entity_Id
:= Current_Scope
;
4187 Is_Asynchronous_Call
: constant Boolean :=
4188 Nkind
(N
) = N_Block_Statement
4189 and then Is_Asynchronous_Call_Block
(N
);
4190 Is_Master
: constant Boolean :=
4191 Nkind
(N
) /= N_Entry_Body
4192 and then Is_Task_Master
(N
);
4193 Is_Protected_Subp_Body
: constant Boolean :=
4194 Nkind
(N
) = N_Subprogram_Body
4195 and then Is_Protected_Subprogram_Body
(N
);
4196 Is_Task_Allocation
: constant Boolean :=
4197 Nkind
(N
) = N_Block_Statement
4198 and then Is_Task_Allocation_Block
(N
);
4199 Is_Task_Body
: constant Boolean :=
4200 Nkind
(Original_Node
(N
)) = N_Task_Body
;
4201 Needs_Sec_Stack_Mark
: constant Boolean :=
4202 Uses_Sec_Stack
(Scop
)
4204 not Sec_Stack_Needed_For_Return
(Scop
);
4205 Needs_Custom_Cleanup
: constant Boolean :=
4206 Nkind
(N
) = N_Block_Statement
4207 and then Present
(Cleanup_Actions
(N
));
4209 Actions_Required
: constant Boolean :=
4210 Requires_Cleanup_Actions
(N
, True)
4211 or else Is_Asynchronous_Call
4213 or else Is_Protected_Subp_Body
4214 or else Is_Task_Allocation
4215 or else Is_Task_Body
4216 or else Needs_Sec_Stack_Mark
4217 or else Needs_Custom_Cleanup
;
4219 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
4223 procedure Wrap_HSS_In_Block
;
4224 -- Move HSS inside a new block along with the original exception
4225 -- handlers. Make the newly generated block the sole statement of HSS.
4227 -----------------------
4228 -- Wrap_HSS_In_Block --
4229 -----------------------
4231 procedure Wrap_HSS_In_Block
is
4233 Block_Id
: Entity_Id
;
4237 -- Preserve end label to provide proper cross-reference information
4239 End_Lab
:= End_Label
(HSS
);
4241 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
4243 Block_Id
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
4244 Set_Identifier
(Block
, New_Occurrence_Of
(Block_Id
, Loc
));
4245 Set_Etype
(Block_Id
, Standard_Void_Type
);
4246 Set_Block_Node
(Block_Id
, Identifier
(Block
));
4248 -- Signal the finalization machinery that this particular block
4249 -- contains the original context.
4251 Set_Is_Finalization_Wrapper
(Block
);
4253 Set_Handled_Statement_Sequence
(N
,
4254 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
4255 HSS
:= Handled_Statement_Sequence
(N
);
4257 Set_First_Real_Statement
(HSS
, Block
);
4258 Set_End_Label
(HSS
, End_Lab
);
4260 -- Comment needed here, see RH for 1.306 ???
4262 if Nkind
(N
) = N_Subprogram_Body
then
4263 Set_Has_Nested_Block_With_Handler
(Scop
);
4265 end Wrap_HSS_In_Block
;
4267 -- Start of processing for Expand_Cleanup_Actions
4270 -- The current construct does not need any form of servicing
4272 if not Actions_Required
then
4275 -- If the current node is a rewritten task body and the descriptors have
4276 -- not been delayed (due to some nested instantiations), do not generate
4277 -- redundant cleanup actions.
4280 and then Nkind
(N
) = N_Subprogram_Body
4281 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
4286 if Needs_Custom_Cleanup
then
4287 Cln
:= Cleanup_Actions
(N
);
4293 Decls
: List_Id
:= Declarations
(N
);
4295 Mark
: Entity_Id
:= Empty
;
4296 New_Decls
: List_Id
;
4300 -- If we are generating expanded code for debugging purposes, use the
4301 -- Sloc of the point of insertion for the cleanup code. The Sloc will
4302 -- be updated subsequently to reference the proper line in .dg files.
4303 -- If we are not debugging generated code, use No_Location instead,
4304 -- so that no debug information is generated for the cleanup code.
4305 -- This makes the behavior of the NEXT command in GDB monotonic, and
4306 -- makes the placement of breakpoints more accurate.
4308 if Debug_Generated_Code
then
4314 -- Set polling off. The finalization and cleanup code is executed
4315 -- with aborts deferred.
4317 Old_Poll
:= Polling_Required
;
4318 Polling_Required
:= False;
4320 -- A task activation call has already been built for a task
4321 -- allocation block.
4323 if not Is_Task_Allocation
then
4324 Build_Task_Activation_Call
(N
);
4328 Establish_Task_Master
(N
);
4331 New_Decls
:= New_List
;
4333 -- If secondary stack is in use, generate:
4335 -- Mnn : constant Mark_Id := SS_Mark;
4337 if Needs_Sec_Stack_Mark
then
4338 Mark
:= Make_Temporary
(Loc
, 'M');
4340 Append_To
(New_Decls
, Build_SS_Mark_Call
(Loc
, Mark
));
4341 Set_Uses_Sec_Stack
(Scop
, False);
4344 -- If exception handlers are present, wrap the sequence of statements
4345 -- in a block since it is not possible to have exception handlers and
4346 -- an At_End handler in the same construct.
4348 if Present
(Exception_Handlers
(HSS
)) then
4351 -- Ensure that the First_Real_Statement field is set
4353 elsif No
(First_Real_Statement
(HSS
)) then
4354 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
4357 -- Do not move the Activation_Chain declaration in the context of
4358 -- task allocation blocks. Task allocation blocks use _chain in their
4359 -- cleanup handlers and gigi complains if it is declared in the
4360 -- sequence of statements of the scope that declares the handler.
4362 if Is_Task_Allocation
then
4364 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
4368 Decl
:= First
(Decls
);
4369 while Nkind
(Decl
) /= N_Object_Declaration
4370 or else Defining_Identifier
(Decl
) /= Chain
4374 -- A task allocation block should always include a _chain
4377 pragma Assert
(Present
(Decl
));
4381 Prepend_To
(New_Decls
, Decl
);
4385 -- Ensure the presence of a declaration list in order to successfully
4386 -- append all original statements to it.
4389 Set_Declarations
(N
, New_List
);
4390 Decls
:= Declarations
(N
);
4393 -- Move the declarations into the sequence of statements in order to
4394 -- have them protected by the At_End handler. It may seem weird to
4395 -- put declarations in the sequence of statement but in fact nothing
4396 -- forbids that at the tree level.
4398 Append_List_To
(Decls
, Statements
(HSS
));
4399 Set_Statements
(HSS
, Decls
);
4401 -- Reset the Sloc of the handled statement sequence to properly
4402 -- reflect the new initial "statement" in the sequence.
4404 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
4406 -- The declarations of finalizer spec and auxiliary variables replace
4407 -- the old declarations that have been moved inward.
4409 Set_Declarations
(N
, New_Decls
);
4410 Analyze_Declarations
(New_Decls
);
4412 -- Generate finalization calls for all controlled objects appearing
4413 -- in the statements of N. Add context specific cleanup for various
4418 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
4420 Top_Decls
=> New_Decls
,
4421 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
4425 if Present
(Fin_Id
) then
4426 Build_Finalizer_Call
(N
, Fin_Id
);
4429 -- Restore saved polling mode
4431 Polling_Required
:= Old_Poll
;
4433 end Expand_Cleanup_Actions
;
4435 ---------------------------
4436 -- Expand_N_Package_Body --
4437 ---------------------------
4439 -- Add call to Activate_Tasks if body is an activator (actual processing
4440 -- is in chapter 9).
4442 -- Generate subprogram descriptor for elaboration routine
4444 -- Encode entity names in package body
4446 procedure Expand_N_Package_Body
(N
: Node_Id
) is
4447 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
4451 -- This is done only for non-generic packages
4453 if Ekind
(Spec_Id
) = E_Package
then
4454 Push_Scope
(Corresponding_Spec
(N
));
4456 -- Build dispatch tables of library level tagged types
4458 if Tagged_Type_Expansion
4459 and then Is_Library_Level_Entity
(Spec_Id
)
4461 Build_Static_Dispatch_Tables
(N
);
4464 Build_Task_Activation_Call
(N
);
4466 -- When the package is subject to pragma Initial_Condition, the
4467 -- assertion expression must be verified at the end of the body
4470 if Present
(Get_Pragma
(Spec_Id
, Pragma_Initial_Condition
)) then
4471 Expand_Pragma_Initial_Condition
(N
);
4477 Set_Elaboration_Flag
(N
, Corresponding_Spec
(N
));
4478 Set_In_Package_Body
(Spec_Id
, False);
4480 -- Set to encode entity names in package body before gigi is called
4482 Qualify_Entity_Names
(N
);
4484 if Ekind
(Spec_Id
) /= E_Generic_Package
then
4487 Clean_Stmts
=> No_List
,
4489 Top_Decls
=> No_List
,
4490 Defer_Abort
=> False,
4493 if Present
(Fin_Id
) then
4495 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
4498 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
4499 Body_Ent
:= Defining_Identifier
(Body_Ent
);
4502 Set_Finalizer
(Body_Ent
, Fin_Id
);
4506 end Expand_N_Package_Body
;
4508 ----------------------------------
4509 -- Expand_N_Package_Declaration --
4510 ----------------------------------
4512 -- Add call to Activate_Tasks if there are tasks declared and the package
4513 -- has no body. Note that in Ada 83 this may result in premature activation
4514 -- of some tasks, given that we cannot tell whether a body will eventually
4517 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
4518 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4519 Spec
: constant Node_Id
:= Specification
(N
);
4523 No_Body
: Boolean := False;
4524 -- True in the case of a package declaration that is a compilation
4525 -- unit and for which no associated body will be compiled in this
4529 -- Case of a package declaration other than a compilation unit
4531 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4534 -- Case of a compilation unit that does not require a body
4536 elsif not Body_Required
(Parent
(N
))
4537 and then not Unit_Requires_Body
(Id
)
4541 -- Special case of generating calling stubs for a remote call interface
4542 -- package: even though the package declaration requires one, the body
4543 -- won't be processed in this compilation (so any stubs for RACWs
4544 -- declared in the package must be generated here, along with the spec).
4546 elsif Parent
(N
) = Cunit
(Main_Unit
)
4547 and then Is_Remote_Call_Interface
(Id
)
4548 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4553 -- For a nested instance, delay processing until freeze point
4555 if Has_Delayed_Freeze
(Id
)
4556 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4561 -- For a package declaration that implies no associated body, generate
4562 -- task activation call and RACW supporting bodies now (since we won't
4563 -- have a specific separate compilation unit for that).
4568 -- Generate RACW subprogram bodies
4570 if Has_RACW
(Id
) then
4571 Decls
:= Private_Declarations
(Spec
);
4574 Decls
:= Visible_Declarations
(Spec
);
4579 Set_Visible_Declarations
(Spec
, Decls
);
4582 Append_RACW_Bodies
(Decls
, Id
);
4583 Analyze_List
(Decls
);
4586 -- Generate task activation call as last step of elaboration
4588 if Present
(Activation_Chain_Entity
(N
)) then
4589 Build_Task_Activation_Call
(N
);
4592 -- When the package is subject to pragma Initial_Condition and lacks
4593 -- a body, the assertion expression must be verified at the end of
4594 -- the visible declarations. Otherwise the check is performed at the
4595 -- end of the body statements (see Expand_N_Package_Body).
4597 if Present
(Get_Pragma
(Id
, Pragma_Initial_Condition
)) then
4598 Expand_Pragma_Initial_Condition
(N
);
4604 -- Build dispatch tables of library level tagged types
4606 if Tagged_Type_Expansion
4607 and then (Is_Compilation_Unit
(Id
)
4608 or else (Is_Generic_Instance
(Id
)
4609 and then Is_Library_Level_Entity
(Id
)))
4611 Build_Static_Dispatch_Tables
(N
);
4614 -- Note: it is not necessary to worry about generating a subprogram
4615 -- descriptor, since the only way to get exception handlers into a
4616 -- package spec is to include instantiations, and that would cause
4617 -- generation of subprogram descriptors to be delayed in any case.
4619 -- Set to encode entity names in package spec before gigi is called
4621 Qualify_Entity_Names
(N
);
4623 if Ekind
(Id
) /= E_Generic_Package
then
4626 Clean_Stmts
=> No_List
,
4628 Top_Decls
=> No_List
,
4629 Defer_Abort
=> False,
4632 Set_Finalizer
(Id
, Fin_Id
);
4634 end Expand_N_Package_Declaration
;
4636 -----------------------------
4637 -- Find_Node_To_Be_Wrapped --
4638 -----------------------------
4640 function Find_Node_To_Be_Wrapped
(N
: Node_Id
) return Node_Id
is
4642 The_Parent
: Node_Id
;
4648 case Nkind
(The_Parent
) is
4650 -- Simple statement can be wrapped
4655 -- Usually assignments are good candidate for wrapping except
4656 -- when they have been generated as part of a controlled aggregate
4657 -- where the wrapping should take place more globally. Note that
4658 -- No_Ctrl_Actions may be set also for non-controlled assignements
4659 -- in order to disable the use of dispatching _assign, so we need
4660 -- to test explicitly for a controlled type here.
4662 when N_Assignment_Statement
=>
4663 if No_Ctrl_Actions
(The_Parent
)
4664 and then Needs_Finalization
(Etype
(Name
(The_Parent
)))
4671 -- An entry call statement is a special case if it occurs in the
4672 -- context of a Timed_Entry_Call. In this case we wrap the entire
4673 -- timed entry call.
4675 when N_Entry_Call_Statement
4676 | N_Procedure_Call_Statement
4678 if Nkind
(Parent
(The_Parent
)) = N_Entry_Call_Alternative
4679 and then Nkind_In
(Parent
(Parent
(The_Parent
)),
4681 N_Conditional_Entry_Call
)
4683 return Parent
(Parent
(The_Parent
));
4688 -- Object declarations are also a boundary for the transient scope
4689 -- even if they are not really wrapped. For further details, see
4690 -- Wrap_Transient_Declaration.
4692 when N_Object_Declaration
4693 | N_Object_Renaming_Declaration
4694 | N_Subtype_Declaration
4698 -- The expression itself is to be wrapped if its parent is a
4699 -- compound statement or any other statement where the expression
4700 -- is known to be scalar.
4702 when N_Accept_Alternative
4703 | N_Attribute_Definition_Clause
4706 | N_Delay_Alternative
4707 | N_Delay_Until_Statement
4708 | N_Delay_Relative_Statement
4709 | N_Discriminant_Association
4711 | N_Entry_Body_Formal_Part
4714 | N_Iteration_Scheme
4715 | N_Terminate_Alternative
4717 pragma Assert
(Present
(P
));
4720 when N_Attribute_Reference
=>
4721 if Is_Procedure_Attribute_Name
4722 (Attribute_Name
(The_Parent
))
4727 -- A raise statement can be wrapped. This will arise when the
4728 -- expression in a raise_with_expression uses the secondary
4729 -- stack, for example.
4731 when N_Raise_Statement
=>
4734 -- If the expression is within the iteration scheme of a loop,
4735 -- we must create a declaration for it, followed by an assignment
4736 -- in order to have a usable statement to wrap.
4738 when N_Loop_Parameter_Specification
=>
4739 return Parent
(The_Parent
);
4741 -- The following nodes contains "dummy calls" which don't need to
4744 when N_Component_Declaration
4745 | N_Discriminant_Specification
4746 | N_Parameter_Specification
4750 -- The return statement is not to be wrapped when the function
4751 -- itself needs wrapping at the outer-level
4753 when N_Simple_Return_Statement
=>
4755 Applies_To
: constant Entity_Id
:=
4757 (Return_Statement_Entity
(The_Parent
));
4758 Return_Type
: constant Entity_Id
:= Etype
(Applies_To
);
4760 if Requires_Transient_Scope
(Return_Type
) then
4767 -- If we leave a scope without having been able to find a node to
4768 -- wrap, something is going wrong but this can happen in error
4769 -- situation that are not detected yet (such as a dynamic string
4770 -- in a pragma export)
4772 when N_Block_Statement
4774 | N_Package_Declaration
4779 -- Otherwise continue the search
4786 The_Parent
:= Parent
(P
);
4788 end Find_Node_To_Be_Wrapped
;
4790 ----------------------------------
4791 -- Has_New_Controlled_Component --
4792 ----------------------------------
4794 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
4798 if not Is_Tagged_Type
(E
) then
4799 return Has_Controlled_Component
(E
);
4800 elsif not Is_Derived_Type
(E
) then
4801 return Has_Controlled_Component
(E
);
4804 Comp
:= First_Component
(E
);
4805 while Present
(Comp
) loop
4806 if Chars
(Comp
) = Name_uParent
then
4809 elsif Scope
(Original_Record_Component
(Comp
)) = E
4810 and then Needs_Finalization
(Etype
(Comp
))
4815 Next_Component
(Comp
);
4819 end Has_New_Controlled_Component
;
4821 ---------------------------------
4822 -- Has_Simple_Protected_Object --
4823 ---------------------------------
4825 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
4827 if Has_Task
(T
) then
4830 elsif Is_Simple_Protected_Type
(T
) then
4833 elsif Is_Array_Type
(T
) then
4834 return Has_Simple_Protected_Object
(Component_Type
(T
));
4836 elsif Is_Record_Type
(T
) then
4841 Comp
:= First_Component
(T
);
4842 while Present
(Comp
) loop
4843 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
4847 Next_Component
(Comp
);
4856 end Has_Simple_Protected_Object
;
4858 ------------------------------------
4859 -- Insert_Actions_In_Scope_Around --
4860 ------------------------------------
4862 procedure Insert_Actions_In_Scope_Around
4865 Manage_SS
: Boolean)
4867 Act_Before
: constant List_Id
:=
4868 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
4869 Act_After
: constant List_Id
:=
4870 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
4871 Act_Cleanup
: constant List_Id
:=
4872 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
4873 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
4874 -- Last), but this was incorrect as Process_Transients_In_Scope may
4875 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
4877 procedure Process_Transients_In_Scope
4878 (First_Object
: Node_Id
;
4879 Last_Object
: Node_Id
;
4880 Related_Node
: Node_Id
);
4881 -- Find all transient objects in the list First_Object .. Last_Object
4882 -- and generate finalization actions for them. Related_Node denotes the
4883 -- node which created all transient objects.
4885 ---------------------------------
4886 -- Process_Transients_In_Scope --
4887 ---------------------------------
4889 procedure Process_Transients_In_Scope
4890 (First_Object
: Node_Id
;
4891 Last_Object
: Node_Id
;
4892 Related_Node
: Node_Id
)
4894 Exceptions_OK
: constant Boolean := Exceptions_In_Finalization_OK
;
4896 Must_Hook
: Boolean := False;
4897 -- Flag denoting whether the context requires transient object
4898 -- export to the outer finalizer.
4900 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
4901 -- Determine whether an arbitrary node denotes a subprogram call
4903 procedure Detect_Subprogram_Call
is
4904 new Traverse_Proc
(Is_Subprogram_Call
);
4906 procedure Process_Transient_In_Scope
4907 (Obj_Decl
: Node_Id
;
4908 Blk_Data
: Finalization_Exception_Data
;
4909 Blk_Stmts
: List_Id
);
4910 -- Generate finalization actions for a single transient object
4911 -- denoted by object declaration Obj_Decl. Blk_Data is the
4912 -- exception data of the enclosing block. Blk_Stmts denotes the
4913 -- statements of the enclosing block.
4915 ------------------------
4916 -- Is_Subprogram_Call --
4917 ------------------------
4919 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
4921 -- A regular procedure or function call
4923 if Nkind
(N
) in N_Subprogram_Call
then
4929 -- Heavy expansion may relocate function calls outside the related
4930 -- node. Inspect the original node to detect the initial placement
4933 elsif Original_Node
(N
) /= N
then
4934 Detect_Subprogram_Call
(Original_Node
(N
));
4942 -- Generalized indexing always involves a function call
4944 elsif Nkind
(N
) = N_Indexed_Component
4945 and then Present
(Generalized_Indexing
(N
))
4955 end Is_Subprogram_Call
;
4957 --------------------------------
4958 -- Process_Transient_In_Scope --
4959 --------------------------------
4961 procedure Process_Transient_In_Scope
4962 (Obj_Decl
: Node_Id
;
4963 Blk_Data
: Finalization_Exception_Data
;
4964 Blk_Stmts
: List_Id
)
4966 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
4967 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
4969 Fin_Stmts
: List_Id
;
4970 Hook_Assign
: Node_Id
;
4971 Hook_Clear
: Node_Id
;
4972 Hook_Decl
: Node_Id
;
4973 Hook_Insert
: Node_Id
;
4977 -- Mark the transient object as successfully processed to avoid
4978 -- double finalization.
4980 Set_Is_Finalized_Transient
(Obj_Id
);
4982 -- Construct all the pieces necessary to hook and finalize the
4983 -- transient object.
4985 Build_Transient_Object_Statements
4986 (Obj_Decl
=> Obj_Decl
,
4987 Fin_Call
=> Fin_Call
,
4988 Hook_Assign
=> Hook_Assign
,
4989 Hook_Clear
=> Hook_Clear
,
4990 Hook_Decl
=> Hook_Decl
,
4991 Ptr_Decl
=> Ptr_Decl
);
4993 -- The context contains at least one subprogram call which may
4994 -- raise an exception. This scenario employs "hooking" to pass
4995 -- transient objects to the enclosing finalizer in case of an
5000 -- Add the access type which provides a reference to the
5001 -- transient object. Generate:
5003 -- type Ptr_Typ is access all Desig_Typ;
5005 Insert_Action
(Obj_Decl
, Ptr_Decl
);
5007 -- Add the temporary which acts as a hook to the transient
5008 -- object. Generate:
5010 -- Hook : Ptr_Typ := null;
5012 Insert_Action
(Obj_Decl
, Hook_Decl
);
5014 -- When the transient object is initialized by an aggregate,
5015 -- the hook must capture the object after the last aggregate
5016 -- assignment takes place. Only then is the object considered
5017 -- fully initialized. Generate:
5019 -- Hook := Ptr_Typ (Obj_Id);
5021 -- Hook := Obj_Id'Unrestricted_Access;
5023 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
5024 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
5026 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
5028 -- Otherwise the hook seizes the related object immediately
5031 Hook_Insert
:= Obj_Decl
;
5034 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
5037 -- When exception propagation is enabled wrap the hook clear
5038 -- statement and the finalization call into a block to catch
5039 -- potential exceptions raised during finalization. Generate:
5043 -- [Deep_]Finalize (Obj_Ref);
5047 -- if not Raised then
5050 -- (Enn, Get_Current_Excep.all.all);
5054 if Exceptions_OK
then
5055 Fin_Stmts
:= New_List
;
5058 Append_To
(Fin_Stmts
, Hook_Clear
);
5061 Append_To
(Fin_Stmts
, Fin_Call
);
5063 Prepend_To
(Blk_Stmts
,
5064 Make_Block_Statement
(Loc
,
5065 Handled_Statement_Sequence
=>
5066 Make_Handled_Sequence_Of_Statements
(Loc
,
5067 Statements
=> Fin_Stmts
,
5068 Exception_Handlers
=> New_List
(
5069 Build_Exception_Handler
(Blk_Data
)))));
5071 -- Otherwise generate:
5074 -- [Deep_]Finalize (Obj_Ref);
5076 -- Note that the statements are inserted in reverse order to
5077 -- achieve the desired final order outlined above.
5080 Prepend_To
(Blk_Stmts
, Fin_Call
);
5083 Prepend_To
(Blk_Stmts
, Hook_Clear
);
5086 end Process_Transient_In_Scope
;
5090 Built
: Boolean := False;
5091 Blk_Data
: Finalization_Exception_Data
;
5092 Blk_Decl
: Node_Id
:= Empty
;
5093 Blk_Decls
: List_Id
:= No_List
;
5095 Blk_Stmts
: List_Id
;
5099 -- Start of processing for Process_Transients_In_Scope
5102 -- The expansion performed by this routine is as follows:
5104 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5105 -- Hook_1 : Ptr_Typ_1 := null;
5106 -- Ctrl_Trans_Obj_1 : ...;
5107 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5109 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5110 -- Hook_N : Ptr_Typ_N := null;
5111 -- Ctrl_Trans_Obj_N : ...;
5112 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5115 -- Abrt : constant Boolean := ...;
5116 -- Ex : Exception_Occurrence;
5117 -- Raised : Boolean := False;
5124 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5128 -- if not Raised then
5130 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5135 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5139 -- if not Raised then
5141 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5146 -- if Raised and not Abrt then
5147 -- Raise_From_Controlled_Operation (Ex);
5151 -- Recognize a scenario where the transient context is an object
5152 -- declaration initialized by a build-in-place function call:
5154 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5156 -- The rough expansion of the above is:
5158 -- Temp : ... := Ctrl_Func_Call;
5160 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5162 -- The finalization of any transient object must happen after the
5163 -- build-in-place function call is executed.
5165 if Nkind
(N
) = N_Object_Declaration
5166 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
5169 Blk_Ins
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
5171 -- Search the context for at least one subprogram call. If found, the
5172 -- machinery exports all transient objects to the enclosing finalizer
5173 -- due to the possibility of abnormal call termination.
5176 Detect_Subprogram_Call
(N
);
5177 Blk_Ins
:= Last_Object
;
5181 Insert_List_After_And_Analyze
(Blk_Ins
, Act_Cleanup
);
5184 -- Examine all objects in the list First_Object .. Last_Object
5186 Obj_Decl
:= First_Object
;
5187 while Present
(Obj_Decl
) loop
5188 if Nkind
(Obj_Decl
) = N_Object_Declaration
5189 and then Analyzed
(Obj_Decl
)
5190 and then Is_Finalizable_Transient
(Obj_Decl
, N
)
5192 -- Do not process the node to be wrapped since it will be
5193 -- handled by the enclosing finalizer.
5195 and then Obj_Decl
/= Related_Node
5197 Loc
:= Sloc
(Obj_Decl
);
5199 -- Before generating the clean up code for the first transient
5200 -- object, create a wrapper block which houses all hook clear
5201 -- statements and finalization calls. This wrapper is needed by
5206 Blk_Stmts
:= New_List
;
5209 -- Abrt : constant Boolean := ...;
5210 -- Ex : Exception_Occurrence;
5211 -- Raised : Boolean := False;
5213 if Exceptions_OK
then
5214 Blk_Decls
:= New_List
;
5215 Build_Object_Declarations
(Blk_Data
, Blk_Decls
, Loc
);
5219 Make_Block_Statement
(Loc
,
5220 Declarations
=> Blk_Decls
,
5221 Handled_Statement_Sequence
=>
5222 Make_Handled_Sequence_Of_Statements
(Loc
,
5223 Statements
=> Blk_Stmts
));
5226 -- Construct all necessary circuitry to hook and finalize a
5227 -- single transient object.
5229 Process_Transient_In_Scope
5230 (Obj_Decl
=> Obj_Decl
,
5231 Blk_Data
=> Blk_Data
,
5232 Blk_Stmts
=> Blk_Stmts
);
5235 -- Terminate the scan after the last object has been processed to
5236 -- avoid touching unrelated code.
5238 if Obj_Decl
= Last_Object
then
5245 -- Complete the decoration of the enclosing finalization block and
5246 -- insert it into the tree.
5248 if Present
(Blk_Decl
) then
5250 -- Note that this Abort_Undefer does not require a extra block or
5251 -- an AT_END handler because each finalization exception is caught
5252 -- in its own corresponding finalization block. As a result, the
5253 -- call to Abort_Defer always takes place.
5255 if Abort_Allowed
then
5256 Prepend_To
(Blk_Stmts
,
5257 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5259 Append_To
(Blk_Stmts
,
5260 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5264 -- if Raised and then not Abrt then
5265 -- Raise_From_Controlled_Operation (Ex);
5268 if Exceptions_OK
then
5269 Append_To
(Blk_Stmts
, Build_Raise_Statement
(Blk_Data
));
5272 Insert_After_And_Analyze
(Blk_Ins
, Blk_Decl
);
5274 end Process_Transients_In_Scope
;
5278 Loc
: constant Source_Ptr
:= Sloc
(N
);
5279 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
5280 First_Obj
: Node_Id
;
5282 Mark_Id
: Entity_Id
;
5285 -- Start of processing for Insert_Actions_In_Scope_Around
5288 if No
(Act_Before
) and then No
(Act_After
) and then No
(Act_Cleanup
) then
5292 -- If the node to be wrapped is the trigger of an asynchronous select,
5293 -- it is not part of a statement list. The actions must be inserted
5294 -- before the select itself, which is part of some list of statements.
5295 -- Note that the triggering alternative includes the triggering
5296 -- statement and an optional statement list. If the node to be
5297 -- wrapped is part of that list, the normal insertion applies.
5299 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
5300 and then not Is_List_Member
(Node_To_Wrap
)
5302 Target
:= Parent
(Parent
(Node_To_Wrap
));
5307 First_Obj
:= Target
;
5310 -- Add all actions associated with a transient scope into the main tree.
5311 -- There are several scenarios here:
5313 -- +--- Before ----+ +----- After ---+
5314 -- 1) First_Obj ....... Target ........ Last_Obj
5316 -- 2) First_Obj ....... Target
5318 -- 3) Target ........ Last_Obj
5320 -- Flag declarations are inserted before the first object
5322 if Present
(Act_Before
) then
5323 First_Obj
:= First
(Act_Before
);
5324 Insert_List_Before
(Target
, Act_Before
);
5327 -- Finalization calls are inserted after the last object
5329 if Present
(Act_After
) then
5330 Last_Obj
:= Last
(Act_After
);
5331 Insert_List_After
(Target
, Act_After
);
5334 -- Mark and release the secondary stack when the context warrants it
5337 Mark_Id
:= Make_Temporary
(Loc
, 'M');
5340 -- Mnn : constant Mark_Id := SS_Mark;
5342 Insert_Before_And_Analyze
5343 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
5346 -- SS_Release (Mnn);
5348 Insert_After_And_Analyze
5349 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
5352 -- Check for transient objects associated with Target and generate the
5353 -- appropriate finalization actions for them.
5355 Process_Transients_In_Scope
5356 (First_Object
=> First_Obj
,
5357 Last_Object
=> Last_Obj
,
5358 Related_Node
=> Target
);
5360 -- Reset the action lists
5363 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
5365 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
5369 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
5371 end Insert_Actions_In_Scope_Around
;
5373 ------------------------------
5374 -- Is_Simple_Protected_Type --
5375 ------------------------------
5377 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
5380 Is_Protected_Type
(T
)
5381 and then not Uses_Lock_Free
(T
)
5382 and then not Has_Entries
(T
)
5383 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
5384 end Is_Simple_Protected_Type
;
5386 -----------------------
5387 -- Make_Adjust_Call --
5388 -----------------------
5390 function Make_Adjust_Call
5393 Skip_Self
: Boolean := False) return Node_Id
5395 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5396 Adj_Id
: Entity_Id
:= Empty
;
5403 -- Recover the proper type which contains Deep_Adjust
5405 if Is_Class_Wide_Type
(Typ
) then
5406 Utyp
:= Root_Type
(Typ
);
5411 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
5412 Set_Assignment_OK
(Ref
);
5414 -- Deal with untagged derivation of private views
5416 if Present
(Utyp
) and then Is_Untagged_Derivation
(Typ
) then
5417 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
5418 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5419 Set_Assignment_OK
(Ref
);
5422 -- When dealing with the completion of a private type, use the base
5425 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
5426 pragma Assert
(Is_Private_Type
(Typ
));
5428 Utyp
:= Base_Type
(Utyp
);
5429 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5432 -- The underlying type may not be present due to a missing full view. In
5433 -- this case freezing did not take place and there is no [Deep_]Adjust
5434 -- primitive to call.
5439 elsif Skip_Self
then
5440 if Has_Controlled_Component
(Utyp
) then
5441 if Is_Tagged_Type
(Utyp
) then
5442 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5444 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5448 -- Class-wide types, interfaces and types with controlled components
5450 elsif Is_Class_Wide_Type
(Typ
)
5451 or else Is_Interface
(Typ
)
5452 or else Has_Controlled_Component
(Utyp
)
5454 if Is_Tagged_Type
(Utyp
) then
5455 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5457 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5460 -- Derivations from [Limited_]Controlled
5462 elsif Is_Controlled
(Utyp
) then
5463 if Has_Controlled_Component
(Utyp
) then
5464 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5466 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
5471 elsif Is_Tagged_Type
(Utyp
) then
5472 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5475 raise Program_Error
;
5478 if Present
(Adj_Id
) then
5480 -- If the object is unanalyzed, set its expected type for use in
5481 -- Convert_View in case an additional conversion is needed.
5484 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
5486 Set_Etype
(Ref
, Typ
);
5489 -- The object reference may need another conversion depending on the
5490 -- type of the formal and that of the actual.
5492 if not Is_Class_Wide_Type
(Typ
) then
5493 Ref
:= Convert_View
(Adj_Id
, Ref
);
5500 Skip_Self
=> Skip_Self
);
5504 end Make_Adjust_Call
;
5506 ----------------------
5507 -- Make_Detach_Call --
5508 ----------------------
5510 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
5511 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5515 Make_Procedure_Call_Statement
(Loc
,
5517 New_Occurrence_Of
(RTE
(RE_Detach
), Loc
),
5518 Parameter_Associations
=> New_List
(
5519 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5520 end Make_Detach_Call
;
5528 Proc_Id
: Entity_Id
;
5530 Skip_Self
: Boolean := False) return Node_Id
5532 Params
: constant List_Id
:= New_List
(Param
);
5535 -- Do not apply the controlled action to the object itself by signaling
5536 -- the related routine to avoid self.
5539 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
5543 Make_Procedure_Call_Statement
(Loc
,
5544 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
5545 Parameter_Associations
=> Params
);
5548 --------------------------
5549 -- Make_Deep_Array_Body --
5550 --------------------------
5552 function Make_Deep_Array_Body
5553 (Prim
: Final_Primitives
;
5554 Typ
: Entity_Id
) return List_Id
5556 Exceptions_OK
: constant Boolean := Exceptions_In_Finalization_OK
;
5558 function Build_Adjust_Or_Finalize_Statements
5559 (Typ
: Entity_Id
) return List_Id
;
5560 -- Create the statements necessary to adjust or finalize an array of
5561 -- controlled elements. Generate:
5564 -- Abort : constant Boolean := Triggered_By_Abort;
5566 -- Abort : constant Boolean := False; -- no abort
5568 -- E : Exception_Occurrence;
5569 -- Raised : Boolean := False;
5572 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
5573 -- ^-- in the finalization case
5575 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
5577 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
5581 -- if not Raised then
5583 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5590 -- if Raised and then not Abort then
5591 -- Raise_From_Controlled_Operation (E);
5595 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
5596 -- Create the statements necessary to initialize an array of controlled
5597 -- elements. Include a mechanism to carry out partial finalization if an
5598 -- exception occurs. Generate:
5601 -- Counter : Integer := 0;
5604 -- for J1 in V'Range (1) loop
5606 -- for JN in V'Range (N) loop
5608 -- [Deep_]Initialize (V (J1, ..., JN));
5610 -- Counter := Counter + 1;
5615 -- Abort : constant Boolean := Triggered_By_Abort;
5617 -- Abort : constant Boolean := False; -- no abort
5618 -- E : Exception_Occurrence;
5619 -- Raised : Boolean := False;
5626 -- V'Length (N) - Counter;
5628 -- for F1 in reverse V'Range (1) loop
5630 -- for FN in reverse V'Range (N) loop
5631 -- if Counter > 0 then
5632 -- Counter := Counter - 1;
5635 -- [Deep_]Finalize (V (F1, ..., FN));
5639 -- if not Raised then
5641 -- Save_Occurrence (E,
5642 -- Get_Current_Excep.all.all);
5651 -- if Raised and then not Abort then
5652 -- Raise_From_Controlled_Operation (E);
5661 function New_References_To
5663 Loc
: Source_Ptr
) return List_Id
;
5664 -- Given a list of defining identifiers, return a list of references to
5665 -- the original identifiers, in the same order as they appear.
5667 -----------------------------------------
5668 -- Build_Adjust_Or_Finalize_Statements --
5669 -----------------------------------------
5671 function Build_Adjust_Or_Finalize_Statements
5672 (Typ
: Entity_Id
) return List_Id
5674 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5675 Index_List
: constant List_Id
:= New_List
;
5676 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5677 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5679 procedure Build_Indexes
;
5680 -- Generate the indexes used in the dimension loops
5686 procedure Build_Indexes
is
5688 -- Generate the following identifiers:
5689 -- Jnn - for initialization
5691 for Dim
in 1 .. Num_Dims
loop
5692 Append_To
(Index_List
,
5693 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5699 Final_Decls
: List_Id
:= No_List
;
5700 Final_Data
: Finalization_Exception_Data
;
5704 Core_Loop
: Node_Id
;
5707 Loop_Id
: Entity_Id
;
5710 -- Start of processing for Build_Adjust_Or_Finalize_Statements
5713 Final_Decls
:= New_List
;
5716 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
5719 Make_Indexed_Component
(Loc
,
5720 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5721 Expressions
=> New_References_To
(Index_List
, Loc
));
5722 Set_Etype
(Comp_Ref
, Comp_Typ
);
5725 -- [Deep_]Adjust (V (J1, ..., JN))
5727 if Prim
= Adjust_Case
then
5728 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5731 -- [Deep_]Finalize (V (J1, ..., JN))
5733 else pragma Assert
(Prim
= Finalize_Case
);
5734 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5737 if Present
(Call
) then
5739 -- Generate the block which houses the adjust or finalize call:
5742 -- <adjust or finalize call>
5746 -- if not Raised then
5748 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5752 if Exceptions_OK
then
5754 Make_Block_Statement
(Loc
,
5755 Handled_Statement_Sequence
=>
5756 Make_Handled_Sequence_Of_Statements
(Loc
,
5757 Statements
=> New_List
(Call
),
5758 Exception_Handlers
=> New_List
(
5759 Build_Exception_Handler
(Final_Data
))));
5764 -- Generate the dimension loops starting from the innermost one
5766 -- for Jnn in [reverse] V'Range (Dim) loop
5770 J
:= Last
(Index_List
);
5772 while Present
(J
) and then Dim
> 0 loop
5778 Make_Loop_Statement
(Loc
,
5780 Make_Iteration_Scheme
(Loc
,
5781 Loop_Parameter_Specification
=>
5782 Make_Loop_Parameter_Specification
(Loc
,
5783 Defining_Identifier
=> Loop_Id
,
5784 Discrete_Subtype_Definition
=>
5785 Make_Attribute_Reference
(Loc
,
5786 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5787 Attribute_Name
=> Name_Range
,
5788 Expressions
=> New_List
(
5789 Make_Integer_Literal
(Loc
, Dim
))),
5792 Prim
= Finalize_Case
)),
5794 Statements
=> New_List
(Core_Loop
),
5795 End_Label
=> Empty
);
5800 -- Generate the block which contains the core loop, declarations
5801 -- of the abort flag, the exception occurrence, the raised flag
5802 -- and the conditional raise:
5805 -- Abort : constant Boolean := Triggered_By_Abort;
5807 -- Abort : constant Boolean := False; -- no abort
5809 -- E : Exception_Occurrence;
5810 -- Raised : Boolean := False;
5815 -- if Raised and then not Abort then
5816 -- Raise_From_Controlled_Operation (E);
5820 Stmts
:= New_List
(Core_Loop
);
5822 if Exceptions_OK
then
5823 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
5827 Make_Block_Statement
(Loc
,
5828 Declarations
=> Final_Decls
,
5829 Handled_Statement_Sequence
=>
5830 Make_Handled_Sequence_Of_Statements
(Loc
,
5831 Statements
=> Stmts
));
5833 -- Otherwise previous errors or a missing full view may prevent the
5834 -- proper freezing of the component type. If this is the case, there
5835 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
5838 Block
:= Make_Null_Statement
(Loc
);
5841 return New_List
(Block
);
5842 end Build_Adjust_Or_Finalize_Statements
;
5844 ---------------------------------
5845 -- Build_Initialize_Statements --
5846 ---------------------------------
5848 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
5849 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5850 Final_List
: constant List_Id
:= New_List
;
5851 Index_List
: constant List_Id
:= New_List
;
5852 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5853 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5855 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
;
5856 -- Generate the following assignment:
5857 -- Counter := V'Length (1) *
5859 -- V'Length (N) - Counter;
5861 -- Counter_Id denotes the entity of the counter.
5863 function Build_Finalization_Call
return Node_Id
;
5864 -- Generate a deep finalization call for an array element
5866 procedure Build_Indexes
;
5867 -- Generate the initialization and finalization indexes used in the
5870 function Build_Initialization_Call
return Node_Id
;
5871 -- Generate a deep initialization call for an array element
5873 ----------------------
5874 -- Build_Assignment --
5875 ----------------------
5877 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
is
5882 -- Start from the first dimension and generate:
5887 Make_Attribute_Reference
(Loc
,
5888 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5889 Attribute_Name
=> Name_Length
,
5890 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
5892 -- Process the rest of the dimensions, generate:
5893 -- Expr * V'Length (N)
5896 while Dim
<= Num_Dims
loop
5898 Make_Op_Multiply
(Loc
,
5901 Make_Attribute_Reference
(Loc
,
5902 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5903 Attribute_Name
=> Name_Length
,
5904 Expressions
=> New_List
(
5905 Make_Integer_Literal
(Loc
, Dim
))));
5911 -- Counter := Expr - Counter;
5914 Make_Assignment_Statement
(Loc
,
5915 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
5917 Make_Op_Subtract
(Loc
,
5919 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
5920 end Build_Assignment
;
5922 -----------------------------
5923 -- Build_Finalization_Call --
5924 -----------------------------
5926 function Build_Finalization_Call
return Node_Id
is
5927 Comp_Ref
: constant Node_Id
:=
5928 Make_Indexed_Component
(Loc
,
5929 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5930 Expressions
=> New_References_To
(Final_List
, Loc
));
5933 Set_Etype
(Comp_Ref
, Comp_Typ
);
5936 -- [Deep_]Finalize (V);
5938 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5939 end Build_Finalization_Call
;
5945 procedure Build_Indexes
is
5947 -- Generate the following identifiers:
5948 -- Jnn - for initialization
5949 -- Fnn - for finalization
5951 for Dim
in 1 .. Num_Dims
loop
5952 Append_To
(Index_List
,
5953 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5955 Append_To
(Final_List
,
5956 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
5960 -------------------------------
5961 -- Build_Initialization_Call --
5962 -------------------------------
5964 function Build_Initialization_Call
return Node_Id
is
5965 Comp_Ref
: constant Node_Id
:=
5966 Make_Indexed_Component
(Loc
,
5967 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5968 Expressions
=> New_References_To
(Index_List
, Loc
));
5971 Set_Etype
(Comp_Ref
, Comp_Typ
);
5974 -- [Deep_]Initialize (V (J1, ..., JN));
5976 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5977 end Build_Initialization_Call
;
5981 Counter_Id
: Entity_Id
;
5985 Final_Block
: Node_Id
;
5986 Final_Data
: Finalization_Exception_Data
;
5987 Final_Decls
: List_Id
:= No_List
;
5988 Final_Loop
: Node_Id
;
5989 Init_Block
: Node_Id
;
5990 Init_Call
: Node_Id
;
5991 Init_Loop
: Node_Id
;
5996 -- Start of processing for Build_Initialize_Statements
5999 Counter_Id
:= Make_Temporary
(Loc
, 'C');
6000 Final_Decls
:= New_List
;
6003 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6005 -- Generate the block which houses the finalization call, the index
6006 -- guard and the handler which triggers Program_Error later on.
6008 -- if Counter > 0 then
6009 -- Counter := Counter - 1;
6012 -- [Deep_]Finalize (V (F1, ..., FN));
6015 -- if not Raised then
6017 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6022 Fin_Stmt
:= Build_Finalization_Call
;
6024 if Present
(Fin_Stmt
) then
6025 if Exceptions_OK
then
6027 Make_Block_Statement
(Loc
,
6028 Handled_Statement_Sequence
=>
6029 Make_Handled_Sequence_Of_Statements
(Loc
,
6030 Statements
=> New_List
(Fin_Stmt
),
6031 Exception_Handlers
=> New_List
(
6032 Build_Exception_Handler
(Final_Data
))));
6035 -- This is the core of the loop, the dimension iterators are added
6036 -- one by one in reverse.
6039 Make_If_Statement
(Loc
,
6042 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6043 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
6045 Then_Statements
=> New_List
(
6046 Make_Assignment_Statement
(Loc
,
6047 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6049 Make_Op_Subtract
(Loc
,
6050 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6051 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
6053 Else_Statements
=> New_List
(Fin_Stmt
));
6055 -- Generate all finalization loops starting from the innermost
6058 -- for Fnn in reverse V'Range (Dim) loop
6062 F
:= Last
(Final_List
);
6064 while Present
(F
) and then Dim
> 0 loop
6070 Make_Loop_Statement
(Loc
,
6072 Make_Iteration_Scheme
(Loc
,
6073 Loop_Parameter_Specification
=>
6074 Make_Loop_Parameter_Specification
(Loc
,
6075 Defining_Identifier
=> Loop_Id
,
6076 Discrete_Subtype_Definition
=>
6077 Make_Attribute_Reference
(Loc
,
6078 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6079 Attribute_Name
=> Name_Range
,
6080 Expressions
=> New_List
(
6081 Make_Integer_Literal
(Loc
, Dim
))),
6083 Reverse_Present
=> True)),
6085 Statements
=> New_List
(Final_Loop
),
6086 End_Label
=> Empty
);
6091 -- Generate the block which contains the finalization loops, the
6092 -- declarations of the abort flag, the exception occurrence, the
6093 -- raised flag and the conditional raise.
6096 -- Abort : constant Boolean := Triggered_By_Abort;
6098 -- Abort : constant Boolean := False; -- no abort
6100 -- E : Exception_Occurrence;
6101 -- Raised : Boolean := False;
6107 -- V'Length (N) - Counter;
6111 -- if Raised and then not Abort then
6112 -- Raise_From_Controlled_Operation (E);
6118 Stmts
:= New_List
(Build_Assignment
(Counter_Id
), Final_Loop
);
6120 if Exceptions_OK
then
6121 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6122 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
6126 Make_Block_Statement
(Loc
,
6127 Declarations
=> Final_Decls
,
6128 Handled_Statement_Sequence
=>
6129 Make_Handled_Sequence_Of_Statements
(Loc
,
6130 Statements
=> Stmts
));
6132 -- Otherwise previous errors or a missing full view may prevent the
6133 -- proper freezing of the component type. If this is the case, there
6134 -- is no [Deep_]Finalize primitive to call.
6137 Final_Block
:= Make_Null_Statement
(Loc
);
6140 -- Generate the block which contains the initialization call and
6141 -- the partial finalization code.
6144 -- [Deep_]Initialize (V (J1, ..., JN));
6146 -- Counter := Counter + 1;
6150 -- <finalization code>
6153 Init_Call
:= Build_Initialization_Call
;
6155 -- Only create finalization block if there is a non-trivial
6156 -- call to initialization.
6158 if Present
(Init_Call
)
6159 and then Nkind
(Init_Call
) /= N_Null_Statement
6162 Make_Block_Statement
(Loc
,
6163 Handled_Statement_Sequence
=>
6164 Make_Handled_Sequence_Of_Statements
(Loc
,
6165 Statements
=> New_List
(Init_Call
),
6166 Exception_Handlers
=> New_List
(
6167 Make_Exception_Handler
(Loc
,
6168 Exception_Choices
=> New_List
(
6169 Make_Others_Choice
(Loc
)),
6170 Statements
=> New_List
(Final_Block
)))));
6172 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
6173 Make_Assignment_Statement
(Loc
,
6174 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6177 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6178 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
6180 -- Generate all initialization loops starting from the innermost
6183 -- for Jnn in V'Range (Dim) loop
6187 J
:= Last
(Index_List
);
6189 while Present
(J
) and then Dim
> 0 loop
6195 Make_Loop_Statement
(Loc
,
6197 Make_Iteration_Scheme
(Loc
,
6198 Loop_Parameter_Specification
=>
6199 Make_Loop_Parameter_Specification
(Loc
,
6200 Defining_Identifier
=> Loop_Id
,
6201 Discrete_Subtype_Definition
=>
6202 Make_Attribute_Reference
(Loc
,
6203 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6204 Attribute_Name
=> Name_Range
,
6205 Expressions
=> New_List
(
6206 Make_Integer_Literal
(Loc
, Dim
))))),
6208 Statements
=> New_List
(Init_Loop
),
6209 End_Label
=> Empty
);
6214 -- Generate the block which contains the counter variable and the
6215 -- initialization loops.
6218 -- Counter : Integer := 0;
6224 Make_Block_Statement
(Loc
,
6225 Declarations
=> New_List
(
6226 Make_Object_Declaration
(Loc
,
6227 Defining_Identifier
=> Counter_Id
,
6228 Object_Definition
=>
6229 New_Occurrence_Of
(Standard_Integer
, Loc
),
6230 Expression
=> Make_Integer_Literal
(Loc
, 0))),
6232 Handled_Statement_Sequence
=>
6233 Make_Handled_Sequence_Of_Statements
(Loc
,
6234 Statements
=> New_List
(Init_Loop
)));
6236 -- Otherwise previous errors or a missing full view may prevent the
6237 -- proper freezing of the component type. If this is the case, there
6238 -- is no [Deep_]Initialize primitive to call.
6241 Init_Block
:= Make_Null_Statement
(Loc
);
6244 return New_List
(Init_Block
);
6245 end Build_Initialize_Statements
;
6247 -----------------------
6248 -- New_References_To --
6249 -----------------------
6251 function New_References_To
6253 Loc
: Source_Ptr
) return List_Id
6255 Refs
: constant List_Id
:= New_List
;
6260 while Present
(Id
) loop
6261 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
6266 end New_References_To
;
6268 -- Start of processing for Make_Deep_Array_Body
6272 when Address_Case
=>
6273 return Make_Finalize_Address_Stmts
(Typ
);
6278 return Build_Adjust_Or_Finalize_Statements
(Typ
);
6280 when Initialize_Case
=>
6281 return Build_Initialize_Statements
(Typ
);
6283 end Make_Deep_Array_Body
;
6285 --------------------
6286 -- Make_Deep_Proc --
6287 --------------------
6289 function Make_Deep_Proc
6290 (Prim
: Final_Primitives
;
6292 Stmts
: List_Id
) return Entity_Id
6294 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6296 Proc_Id
: Entity_Id
;
6299 -- Create the object formal, generate:
6300 -- V : System.Address
6302 if Prim
= Address_Case
then
6303 Formals
:= New_List
(
6304 Make_Parameter_Specification
(Loc
,
6305 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6307 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6314 Formals
:= New_List
(
6315 Make_Parameter_Specification
(Loc
,
6316 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6318 Out_Present
=> True,
6319 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
6321 -- F : Boolean := True
6323 if Prim
= Adjust_Case
6324 or else Prim
= Finalize_Case
6327 Make_Parameter_Specification
(Loc
,
6328 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
6330 New_Occurrence_Of
(Standard_Boolean
, Loc
),
6332 New_Occurrence_Of
(Standard_True
, Loc
)));
6337 Make_Defining_Identifier
(Loc
,
6338 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
6341 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6344 -- exception -- Finalize and Adjust cases only
6345 -- raise Program_Error;
6346 -- end Deep_Initialize / Adjust / Finalize;
6350 -- procedure Finalize_Address (V : System.Address) is
6353 -- end Finalize_Address;
6356 Make_Subprogram_Body
(Loc
,
6358 Make_Procedure_Specification
(Loc
,
6359 Defining_Unit_Name
=> Proc_Id
,
6360 Parameter_Specifications
=> Formals
),
6362 Declarations
=> Empty_List
,
6364 Handled_Statement_Sequence
=>
6365 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
6367 -- If there are no calls to component initialization, indicate that
6368 -- the procedure is trivial, so prevent calls to it.
6370 if Is_Empty_List
(Stmts
)
6371 or else Nkind
(First
(Stmts
)) = N_Null_Statement
6373 Set_Is_Trivial_Subprogram
(Proc_Id
);
6379 ---------------------------
6380 -- Make_Deep_Record_Body --
6381 ---------------------------
6383 function Make_Deep_Record_Body
6384 (Prim
: Final_Primitives
;
6386 Is_Local
: Boolean := False) return List_Id
6388 Exceptions_OK
: constant Boolean := Exceptions_In_Finalization_OK
;
6390 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
6391 -- Build the statements necessary to adjust a record type. The type may
6392 -- have discriminants and contain variant parts. Generate:
6396 -- [Deep_]Adjust (V.Comp_1);
6398 -- when Id : others =>
6399 -- if not Raised then
6401 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6406 -- [Deep_]Adjust (V.Comp_N);
6408 -- when Id : others =>
6409 -- if not Raised then
6411 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6416 -- Deep_Adjust (V._parent, False); -- If applicable
6418 -- when Id : others =>
6419 -- if not Raised then
6421 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6427 -- Adjust (V); -- If applicable
6430 -- if not Raised then
6432 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6437 -- if Raised and then not Abort then
6438 -- Raise_From_Controlled_Operation (E);
6442 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
6443 -- Build the statements necessary to finalize a record type. The type
6444 -- may have discriminants and contain variant parts. Generate:
6447 -- Abort : constant Boolean := Triggered_By_Abort;
6449 -- Abort : constant Boolean := False; -- no abort
6450 -- E : Exception_Occurrence;
6451 -- Raised : Boolean := False;
6456 -- Finalize (V); -- If applicable
6459 -- if not Raised then
6461 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6466 -- case Variant_1 is
6468 -- case State_Counter_N => -- If Is_Local is enabled
6478 -- <<LN>> -- If Is_Local is enabled
6480 -- [Deep_]Finalize (V.Comp_N);
6483 -- if not Raised then
6485 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6491 -- [Deep_]Finalize (V.Comp_1);
6494 -- if not Raised then
6496 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6502 -- case State_Counter_1 => -- If Is_Local is enabled
6508 -- Deep_Finalize (V._parent, False); -- If applicable
6510 -- when Id : others =>
6511 -- if not Raised then
6513 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6517 -- if Raised and then not Abort then
6518 -- Raise_From_Controlled_Operation (E);
6522 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
6523 -- Given a derived tagged type Typ, traverse all components, find field
6524 -- _parent and return its type.
6526 procedure Preprocess_Components
6528 Num_Comps
: out Nat
;
6529 Has_POC
: out Boolean);
6530 -- Examine all components in component list Comps, count all controlled
6531 -- components and determine whether at least one of them is per-object
6532 -- constrained. Component _parent is always skipped.
6534 -----------------------------
6535 -- Build_Adjust_Statements --
6536 -----------------------------
6538 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
6539 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6540 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6542 Finalizer_Data
: Finalization_Exception_Data
;
6544 function Process_Component_List_For_Adjust
6545 (Comps
: Node_Id
) return List_Id
;
6546 -- Build all necessary adjust statements for a single component list
6548 ---------------------------------------
6549 -- Process_Component_List_For_Adjust --
6550 ---------------------------------------
6552 function Process_Component_List_For_Adjust
6553 (Comps
: Node_Id
) return List_Id
6555 Stmts
: constant List_Id
:= New_List
;
6557 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
6558 -- Process the declaration of a single controlled component
6560 ----------------------------------
6561 -- Process_Component_For_Adjust --
6562 ----------------------------------
6564 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
6565 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6566 Typ
: constant Entity_Id
:= Etype
(Id
);
6572 -- [Deep_]Adjust (V.Id);
6576 -- if not Raised then
6578 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6585 Make_Selected_Component
(Loc
,
6586 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6587 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6590 -- Guard against a missing [Deep_]Adjust when the component
6591 -- type was not properly frozen.
6593 if Present
(Adj_Call
) then
6594 if Exceptions_OK
then
6596 Make_Block_Statement
(Loc
,
6597 Handled_Statement_Sequence
=>
6598 Make_Handled_Sequence_Of_Statements
(Loc
,
6599 Statements
=> New_List
(Adj_Call
),
6600 Exception_Handlers
=> New_List
(
6601 Build_Exception_Handler
(Finalizer_Data
))));
6604 Append_To
(Stmts
, Adj_Call
);
6606 end Process_Component_For_Adjust
;
6611 Decl_Id
: Entity_Id
;
6612 Decl_Typ
: Entity_Id
;
6617 -- Start of processing for Process_Component_List_For_Adjust
6620 -- Perform an initial check, determine the number of controlled
6621 -- components in the current list and whether at least one of them
6622 -- is per-object constrained.
6624 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6626 -- The processing in this routine is done in the following order:
6627 -- 1) Regular components
6628 -- 2) Per-object constrained components
6631 if Num_Comps
> 0 then
6633 -- Process all regular components in order of declarations
6635 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6636 while Present
(Decl
) loop
6637 Decl_Id
:= Defining_Identifier
(Decl
);
6638 Decl_Typ
:= Etype
(Decl_Id
);
6640 -- Skip _parent as well as per-object constrained components
6642 if Chars
(Decl_Id
) /= Name_uParent
6643 and then Needs_Finalization
(Decl_Typ
)
6645 if Has_Access_Constraint
(Decl_Id
)
6646 and then No
(Expression
(Decl
))
6650 Process_Component_For_Adjust
(Decl
);
6654 Next_Non_Pragma
(Decl
);
6657 -- Process all per-object constrained components in order of
6661 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6662 while Present
(Decl
) loop
6663 Decl_Id
:= Defining_Identifier
(Decl
);
6664 Decl_Typ
:= Etype
(Decl_Id
);
6668 if Chars
(Decl_Id
) /= Name_uParent
6669 and then Needs_Finalization
(Decl_Typ
)
6670 and then Has_Access_Constraint
(Decl_Id
)
6671 and then No
(Expression
(Decl
))
6673 Process_Component_For_Adjust
(Decl
);
6676 Next_Non_Pragma
(Decl
);
6681 -- Process all variants, if any
6684 if Present
(Variant_Part
(Comps
)) then
6686 Var_Alts
: constant List_Id
:= New_List
;
6690 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6691 while Present
(Var
) loop
6694 -- when <discrete choices> =>
6695 -- <adjust statements>
6697 Append_To
(Var_Alts
,
6698 Make_Case_Statement_Alternative
(Loc
,
6700 New_Copy_List
(Discrete_Choices
(Var
)),
6702 Process_Component_List_For_Adjust
(
6703 Component_List
(Var
))));
6705 Next_Non_Pragma
(Var
);
6709 -- case V.<discriminant> is
6710 -- when <discrete choices 1> =>
6711 -- <adjust statements 1>
6713 -- when <discrete choices N> =>
6714 -- <adjust statements N>
6718 Make_Case_Statement
(Loc
,
6720 Make_Selected_Component
(Loc
,
6721 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6723 Make_Identifier
(Loc
,
6724 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6725 Alternatives
=> Var_Alts
);
6729 -- Add the variant case statement to the list of statements
6731 if Present
(Var_Case
) then
6732 Append_To
(Stmts
, Var_Case
);
6735 -- If the component list did not have any controlled components
6736 -- nor variants, return null.
6738 if Is_Empty_List
(Stmts
) then
6739 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
6743 end Process_Component_List_For_Adjust
;
6747 Bod_Stmts
: List_Id
:= No_List
;
6748 Finalizer_Decls
: List_Id
:= No_List
;
6751 -- Start of processing for Build_Adjust_Statements
6754 Finalizer_Decls
:= New_List
;
6755 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
6757 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
6758 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
6763 -- Create an adjust sequence for all record components
6765 if Present
(Component_List
(Rec_Def
)) then
6767 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
6770 -- A derived record type must adjust all inherited components. This
6771 -- action poses the following problem:
6773 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
6778 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
6780 -- Deep_Adjust (Obj._parent);
6785 -- Adjusting the derived type will invoke Adjust of the parent and
6786 -- then that of the derived type. This is undesirable because both
6787 -- routines may modify shared components. Only the Adjust of the
6788 -- derived type should be invoked.
6790 -- To prevent this double adjustment of shared components,
6791 -- Deep_Adjust uses a flag to control the invocation of Adjust:
6793 -- procedure Deep_Adjust
6794 -- (Obj : in out Some_Type;
6795 -- Flag : Boolean := True)
6803 -- When Deep_Adjust is invokes for field _parent, a value of False is
6804 -- provided for the flag:
6806 -- Deep_Adjust (Obj._parent, False);
6808 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
6810 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
6815 if Needs_Finalization
(Par_Typ
) then
6819 Make_Selected_Component
(Loc
,
6820 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6822 Make_Identifier
(Loc
, Name_uParent
)),
6828 -- Deep_Adjust (V._parent, False);
6831 -- when Id : others =>
6832 -- if not Raised then
6834 -- Save_Occurrence (E,
6835 -- Get_Current_Excep.all.all);
6839 if Present
(Call
) then
6842 if Exceptions_OK
then
6844 Make_Block_Statement
(Loc
,
6845 Handled_Statement_Sequence
=>
6846 Make_Handled_Sequence_Of_Statements
(Loc
,
6847 Statements
=> New_List
(Adj_Stmt
),
6848 Exception_Handlers
=> New_List
(
6849 Build_Exception_Handler
(Finalizer_Data
))));
6852 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
6858 -- Adjust the object. This action must be performed last after all
6859 -- components have been adjusted.
6861 if Is_Controlled
(Typ
) then
6867 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Adjust
);
6876 -- if not Raised then
6878 -- Save_Occurrence (E,
6879 -- Get_Current_Excep.all.all);
6884 if Present
(Proc
) then
6886 Make_Procedure_Call_Statement
(Loc
,
6887 Name
=> New_Occurrence_Of
(Proc
, Loc
),
6888 Parameter_Associations
=> New_List
(
6889 Make_Identifier
(Loc
, Name_V
)));
6891 if Exceptions_OK
then
6893 Make_Block_Statement
(Loc
,
6894 Handled_Statement_Sequence
=>
6895 Make_Handled_Sequence_Of_Statements
(Loc
,
6896 Statements
=> New_List
(Adj_Stmt
),
6897 Exception_Handlers
=> New_List
(
6898 Build_Exception_Handler
6899 (Finalizer_Data
))));
6902 Append_To
(Bod_Stmts
,
6903 Make_If_Statement
(Loc
,
6904 Condition
=> Make_Identifier
(Loc
, Name_F
),
6905 Then_Statements
=> New_List
(Adj_Stmt
)));
6910 -- At this point either all adjustment statements have been generated
6911 -- or the type is not controlled.
6913 if Is_Empty_List
(Bod_Stmts
) then
6914 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
6920 -- Abort : constant Boolean := Triggered_By_Abort;
6922 -- Abort : constant Boolean := False; -- no abort
6924 -- E : Exception_Occurrence;
6925 -- Raised : Boolean := False;
6928 -- <adjust statements>
6930 -- if Raised and then not Abort then
6931 -- Raise_From_Controlled_Operation (E);
6936 if Exceptions_OK
then
6937 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
6942 Make_Block_Statement
(Loc
,
6945 Handled_Statement_Sequence
=>
6946 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
6948 end Build_Adjust_Statements
;
6950 -------------------------------
6951 -- Build_Finalize_Statements --
6952 -------------------------------
6954 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
6955 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6956 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6959 Finalizer_Data
: Finalization_Exception_Data
;
6961 function Process_Component_List_For_Finalize
6962 (Comps
: Node_Id
) return List_Id
;
6963 -- Build all necessary finalization statements for a single component
6964 -- list. The statements may include a jump circuitry if flag Is_Local
6967 -----------------------------------------
6968 -- Process_Component_List_For_Finalize --
6969 -----------------------------------------
6971 function Process_Component_List_For_Finalize
6972 (Comps
: Node_Id
) return List_Id
6974 procedure Process_Component_For_Finalize
6979 Num_Comps
: in out Nat
);
6980 -- Process the declaration of a single controlled component. If
6981 -- flag Is_Local is enabled, create the corresponding label and
6982 -- jump circuitry. Alts is the list of case alternatives, Decls
6983 -- is the top level declaration list where labels are declared
6984 -- and Stmts is the list of finalization actions. Num_Comps
6985 -- denotes the current number of components needing finalization.
6987 ------------------------------------
6988 -- Process_Component_For_Finalize --
6989 ------------------------------------
6991 procedure Process_Component_For_Finalize
6996 Num_Comps
: in out Nat
)
6998 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6999 Typ
: constant Entity_Id
:= Etype
(Id
);
7006 Label_Id
: Entity_Id
;
7013 Make_Identifier
(Loc
,
7014 Chars
=> New_External_Name
('L', Num_Comps
));
7015 Set_Entity
(Label_Id
,
7016 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7017 Label
:= Make_Label
(Loc
, Label_Id
);
7020 Make_Implicit_Label_Declaration
(Loc
,
7021 Defining_Identifier
=> Entity
(Label_Id
),
7022 Label_Construct
=> Label
));
7029 Make_Case_Statement_Alternative
(Loc
,
7030 Discrete_Choices
=> New_List
(
7031 Make_Integer_Literal
(Loc
, Num_Comps
)),
7033 Statements
=> New_List
(
7034 Make_Goto_Statement
(Loc
,
7036 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7041 Append_To
(Stmts
, Label
);
7043 -- Decrease the number of components to be processed.
7044 -- This action yields a new Label_Id in future calls.
7046 Num_Comps
:= Num_Comps
- 1;
7051 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7053 -- begin -- Exception handlers allowed
7054 -- [Deep_]Finalize (V.Id);
7057 -- if not Raised then
7059 -- Save_Occurrence (E,
7060 -- Get_Current_Excep.all.all);
7067 Make_Selected_Component
(Loc
,
7068 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7069 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7072 -- Guard against a missing [Deep_]Finalize when the component
7073 -- type was not properly frozen.
7075 if Present
(Fin_Call
) then
7076 if Exceptions_OK
then
7078 Make_Block_Statement
(Loc
,
7079 Handled_Statement_Sequence
=>
7080 Make_Handled_Sequence_Of_Statements
(Loc
,
7081 Statements
=> New_List
(Fin_Call
),
7082 Exception_Handlers
=> New_List
(
7083 Build_Exception_Handler
(Finalizer_Data
))));
7086 Append_To
(Stmts
, Fin_Call
);
7088 end Process_Component_For_Finalize
;
7093 Counter_Id
: Entity_Id
:= Empty
;
7095 Decl_Id
: Entity_Id
;
7096 Decl_Typ
: Entity_Id
;
7099 Jump_Block
: Node_Id
;
7101 Label_Id
: Entity_Id
;
7106 -- Start of processing for Process_Component_List_For_Finalize
7109 -- Perform an initial check, look for controlled and per-object
7110 -- constrained components.
7112 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7114 -- Create a state counter to service the current component list.
7115 -- This step is performed before the variants are inspected in
7116 -- order to generate the same state counter names as those from
7117 -- Build_Initialize_Statements.
7119 if Num_Comps
> 0 and then Is_Local
then
7120 Counter
:= Counter
+ 1;
7123 Make_Defining_Identifier
(Loc
,
7124 Chars
=> New_External_Name
('C', Counter
));
7127 -- Process the component in the following order:
7129 -- 2) Per-object constrained components
7130 -- 3) Regular components
7132 -- Start with the variant parts
7135 if Present
(Variant_Part
(Comps
)) then
7137 Var_Alts
: constant List_Id
:= New_List
;
7141 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7142 while Present
(Var
) loop
7145 -- when <discrete choices> =>
7146 -- <finalize statements>
7148 Append_To
(Var_Alts
,
7149 Make_Case_Statement_Alternative
(Loc
,
7151 New_Copy_List
(Discrete_Choices
(Var
)),
7153 Process_Component_List_For_Finalize
(
7154 Component_List
(Var
))));
7156 Next_Non_Pragma
(Var
);
7160 -- case V.<discriminant> is
7161 -- when <discrete choices 1> =>
7162 -- <finalize statements 1>
7164 -- when <discrete choices N> =>
7165 -- <finalize statements N>
7169 Make_Case_Statement
(Loc
,
7171 Make_Selected_Component
(Loc
,
7172 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7174 Make_Identifier
(Loc
,
7175 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7176 Alternatives
=> Var_Alts
);
7180 -- The current component list does not have a single controlled
7181 -- component, however it may contain variants. Return the case
7182 -- statement for the variants or nothing.
7184 if Num_Comps
= 0 then
7185 if Present
(Var_Case
) then
7186 return New_List
(Var_Case
);
7188 return New_List
(Make_Null_Statement
(Loc
));
7192 -- Prepare all lists
7198 -- Process all per-object constrained components in reverse order
7201 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7202 while Present
(Decl
) loop
7203 Decl_Id
:= Defining_Identifier
(Decl
);
7204 Decl_Typ
:= Etype
(Decl_Id
);
7208 if Chars
(Decl_Id
) /= Name_uParent
7209 and then Needs_Finalization
(Decl_Typ
)
7210 and then Has_Access_Constraint
(Decl_Id
)
7211 and then No
(Expression
(Decl
))
7213 Process_Component_For_Finalize
7214 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7217 Prev_Non_Pragma
(Decl
);
7221 -- Process the rest of the components in reverse order
7223 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7224 while Present
(Decl
) loop
7225 Decl_Id
:= Defining_Identifier
(Decl
);
7226 Decl_Typ
:= Etype
(Decl_Id
);
7230 if Chars
(Decl_Id
) /= Name_uParent
7231 and then Needs_Finalization
(Decl_Typ
)
7233 -- Skip per-object constrained components since they were
7234 -- handled in the above step.
7236 if Has_Access_Constraint
(Decl_Id
)
7237 and then No
(Expression
(Decl
))
7241 Process_Component_For_Finalize
7242 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7246 Prev_Non_Pragma
(Decl
);
7251 -- LN : label; -- If Is_Local is enabled
7256 -- case CounterX is .
7266 -- <<LN>> -- If Is_Local is enabled
7268 -- [Deep_]Finalize (V.CompY);
7270 -- when Id : others =>
7271 -- if not Raised then
7273 -- Save_Occurrence (E,
7274 -- Get_Current_Excep.all.all);
7278 -- <<L0>> -- If Is_Local is enabled
7283 -- Add the declaration of default jump location L0, its
7284 -- corresponding alternative and its place in the statements.
7286 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
7287 Set_Entity
(Label_Id
,
7288 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7289 Label
:= Make_Label
(Loc
, Label_Id
);
7291 Append_To
(Decls
, -- declaration
7292 Make_Implicit_Label_Declaration
(Loc
,
7293 Defining_Identifier
=> Entity
(Label_Id
),
7294 Label_Construct
=> Label
));
7296 Append_To
(Alts
, -- alternative
7297 Make_Case_Statement_Alternative
(Loc
,
7298 Discrete_Choices
=> New_List
(
7299 Make_Others_Choice
(Loc
)),
7301 Statements
=> New_List
(
7302 Make_Goto_Statement
(Loc
,
7303 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7305 Append_To
(Stmts
, Label
); -- statement
7307 -- Create the jump block
7310 Make_Case_Statement
(Loc
,
7311 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
7312 Alternatives
=> Alts
));
7316 Make_Block_Statement
(Loc
,
7317 Declarations
=> Decls
,
7318 Handled_Statement_Sequence
=>
7319 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
7321 if Present
(Var_Case
) then
7322 return New_List
(Var_Case
, Jump_Block
);
7324 return New_List
(Jump_Block
);
7326 end Process_Component_List_For_Finalize
;
7330 Bod_Stmts
: List_Id
:= No_List
;
7331 Finalizer_Decls
: List_Id
:= No_List
;
7334 -- Start of processing for Build_Finalize_Statements
7337 Finalizer_Decls
:= New_List
;
7338 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7340 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7341 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7346 -- Create a finalization sequence for all record components
7348 if Present
(Component_List
(Rec_Def
)) then
7350 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
7353 -- A derived record type must finalize all inherited components. This
7354 -- action poses the following problem:
7356 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7361 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7363 -- Deep_Finalize (Obj._parent);
7368 -- Finalizing the derived type will invoke Finalize of the parent and
7369 -- then that of the derived type. This is undesirable because both
7370 -- routines may modify shared components. Only the Finalize of the
7371 -- derived type should be invoked.
7373 -- To prevent this double adjustment of shared components,
7374 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7376 -- procedure Deep_Finalize
7377 -- (Obj : in out Some_Type;
7378 -- Flag : Boolean := True)
7386 -- When Deep_Finalize is invoked for field _parent, a value of False
7387 -- is provided for the flag:
7389 -- Deep_Finalize (Obj._parent, False);
7391 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7393 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7398 if Needs_Finalization
(Par_Typ
) then
7402 Make_Selected_Component
(Loc
,
7403 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7405 Make_Identifier
(Loc
, Name_uParent
)),
7411 -- Deep_Finalize (V._parent, False);
7414 -- when Id : others =>
7415 -- if not Raised then
7417 -- Save_Occurrence (E,
7418 -- Get_Current_Excep.all.all);
7422 if Present
(Call
) then
7425 if Exceptions_OK
then
7427 Make_Block_Statement
(Loc
,
7428 Handled_Statement_Sequence
=>
7429 Make_Handled_Sequence_Of_Statements
(Loc
,
7430 Statements
=> New_List
(Fin_Stmt
),
7431 Exception_Handlers
=> New_List
(
7432 Build_Exception_Handler
7433 (Finalizer_Data
))));
7436 Append_To
(Bod_Stmts
, Fin_Stmt
);
7442 -- Finalize the object. This action must be performed first before
7443 -- all components have been finalized.
7445 if Is_Controlled
(Typ
) and then not Is_Local
then
7451 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Finalize
);
7460 -- if not Raised then
7462 -- Save_Occurrence (E,
7463 -- Get_Current_Excep.all.all);
7468 if Present
(Proc
) then
7470 Make_Procedure_Call_Statement
(Loc
,
7471 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7472 Parameter_Associations
=> New_List
(
7473 Make_Identifier
(Loc
, Name_V
)));
7475 if Exceptions_OK
then
7477 Make_Block_Statement
(Loc
,
7478 Handled_Statement_Sequence
=>
7479 Make_Handled_Sequence_Of_Statements
(Loc
,
7480 Statements
=> New_List
(Fin_Stmt
),
7481 Exception_Handlers
=> New_List
(
7482 Build_Exception_Handler
7483 (Finalizer_Data
))));
7486 Prepend_To
(Bod_Stmts
,
7487 Make_If_Statement
(Loc
,
7488 Condition
=> Make_Identifier
(Loc
, Name_F
),
7489 Then_Statements
=> New_List
(Fin_Stmt
)));
7494 -- At this point either all finalization statements have been
7495 -- generated or the type is not controlled.
7497 if No
(Bod_Stmts
) then
7498 return New_List
(Make_Null_Statement
(Loc
));
7502 -- Abort : constant Boolean := Triggered_By_Abort;
7504 -- Abort : constant Boolean := False; -- no abort
7506 -- E : Exception_Occurrence;
7507 -- Raised : Boolean := False;
7510 -- <finalize statements>
7512 -- if Raised and then not Abort then
7513 -- Raise_From_Controlled_Operation (E);
7518 if Exceptions_OK
then
7519 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
7524 Make_Block_Statement
(Loc
,
7527 Handled_Statement_Sequence
=>
7528 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7530 end Build_Finalize_Statements
;
7532 -----------------------
7533 -- Parent_Field_Type --
7534 -----------------------
7536 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
7540 Field
:= First_Entity
(Typ
);
7541 while Present
(Field
) loop
7542 if Chars
(Field
) = Name_uParent
then
7543 return Etype
(Field
);
7546 Next_Entity
(Field
);
7549 -- A derived tagged type should always have a parent field
7551 raise Program_Error
;
7552 end Parent_Field_Type
;
7554 ---------------------------
7555 -- Preprocess_Components --
7556 ---------------------------
7558 procedure Preprocess_Components
7560 Num_Comps
: out Nat
;
7561 Has_POC
: out Boolean)
7571 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7572 while Present
(Decl
) loop
7573 Id
:= Defining_Identifier
(Decl
);
7576 -- Skip field _parent
7578 if Chars
(Id
) /= Name_uParent
7579 and then Needs_Finalization
(Typ
)
7581 Num_Comps
:= Num_Comps
+ 1;
7583 if Has_Access_Constraint
(Id
)
7584 and then No
(Expression
(Decl
))
7590 Next_Non_Pragma
(Decl
);
7592 end Preprocess_Components
;
7594 -- Start of processing for Make_Deep_Record_Body
7598 when Address_Case
=>
7599 return Make_Finalize_Address_Stmts
(Typ
);
7602 return Build_Adjust_Statements
(Typ
);
7604 when Finalize_Case
=>
7605 return Build_Finalize_Statements
(Typ
);
7607 when Initialize_Case
=>
7609 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7612 if Is_Controlled
(Typ
) then
7614 Make_Procedure_Call_Statement
(Loc
,
7617 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
7618 Parameter_Associations
=> New_List
(
7619 Make_Identifier
(Loc
, Name_V
))));
7625 end Make_Deep_Record_Body
;
7627 ----------------------
7628 -- Make_Final_Call --
7629 ----------------------
7631 function Make_Final_Call
7634 Skip_Self
: Boolean := False) return Node_Id
7636 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7638 Fin_Id
: Entity_Id
:= Empty
;
7645 -- Recover the proper type which contains [Deep_]Finalize
7647 if Is_Class_Wide_Type
(Typ
) then
7648 Utyp
:= Root_Type
(Typ
);
7651 elsif Is_Concurrent_Type
(Typ
) then
7652 Utyp
:= Corresponding_Record_Type
(Typ
);
7654 Ref
:= Convert_Concurrent
(Ref
, Typ
);
7656 elsif Is_Private_Type
(Typ
)
7657 and then Present
(Full_View
(Typ
))
7658 and then Is_Concurrent_Type
(Full_View
(Typ
))
7660 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
7662 Ref
:= Convert_Concurrent
(Ref
, Full_View
(Typ
));
7669 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7670 Set_Assignment_OK
(Ref
);
7672 -- Deal with untagged derivation of private views. If the parent type
7673 -- is a protected type, Deep_Finalize is found on the corresponding
7674 -- record of the ancestor.
7676 if Is_Untagged_Derivation
(Typ
) then
7677 if Is_Protected_Type
(Typ
) then
7678 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7680 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7682 if Is_Protected_Type
(Utyp
) then
7683 Utyp
:= Corresponding_Record_Type
(Utyp
);
7687 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7688 Set_Assignment_OK
(Ref
);
7691 -- Deal with derived private types which do not inherit primitives from
7692 -- their parents. In this case, [Deep_]Finalize can be found in the full
7693 -- view of the parent type.
7696 and then Is_Tagged_Type
(Utyp
)
7697 and then Is_Derived_Type
(Utyp
)
7698 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
7699 and then Is_Private_Type
(Etype
(Utyp
))
7700 and then Present
(Full_View
(Etype
(Utyp
)))
7702 Utyp
:= Full_View
(Etype
(Utyp
));
7703 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7704 Set_Assignment_OK
(Ref
);
7707 -- When dealing with the completion of a private type, use the base type
7710 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
7711 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
7713 Utyp
:= Base_Type
(Utyp
);
7714 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7715 Set_Assignment_OK
(Ref
);
7718 -- The underlying type may not be present due to a missing full view. In
7719 -- this case freezing did not take place and there is no [Deep_]Finalize
7720 -- primitive to call.
7725 elsif Skip_Self
then
7726 if Has_Controlled_Component
(Utyp
) then
7727 if Is_Tagged_Type
(Utyp
) then
7728 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7730 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7734 -- Class-wide types, interfaces and types with controlled components
7736 elsif Is_Class_Wide_Type
(Typ
)
7737 or else Is_Interface
(Typ
)
7738 or else Has_Controlled_Component
(Utyp
)
7740 if Is_Tagged_Type
(Utyp
) then
7741 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7743 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7746 -- Derivations from [Limited_]Controlled
7748 elsif Is_Controlled
(Utyp
) then
7749 if Has_Controlled_Component
(Utyp
) then
7750 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7752 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
7757 elsif Is_Tagged_Type
(Utyp
) then
7758 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7761 raise Program_Error
;
7764 if Present
(Fin_Id
) then
7766 -- When finalizing a class-wide object, do not convert to the root
7767 -- type in order to produce a dispatching call.
7769 if Is_Class_Wide_Type
(Typ
) then
7772 -- Ensure that a finalization routine is at least decorated in order
7773 -- to inspect the object parameter.
7775 elsif Analyzed
(Fin_Id
)
7776 or else Ekind
(Fin_Id
) = E_Procedure
7778 -- In certain cases, such as the creation of Stream_Read, the
7779 -- visible entity of the type is its full view. Since Stream_Read
7780 -- will have to create an object of type Typ, the local object
7781 -- will be finalzed by the scope finalizer generated later on. The
7782 -- object parameter of Deep_Finalize will always use the private
7783 -- view of the type. To avoid such a clash between a private and a
7784 -- full view, perform an unchecked conversion of the object
7785 -- reference to the private view.
7788 Formal_Typ
: constant Entity_Id
:=
7789 Etype
(First_Formal
(Fin_Id
));
7791 if Is_Private_Type
(Formal_Typ
)
7792 and then Present
(Full_View
(Formal_Typ
))
7793 and then Full_View
(Formal_Typ
) = Utyp
7795 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
7799 Ref
:= Convert_View
(Fin_Id
, Ref
);
7806 Skip_Self
=> Skip_Self
);
7810 end Make_Final_Call
;
7812 --------------------------------
7813 -- Make_Finalize_Address_Body --
7814 --------------------------------
7816 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
7817 Is_Task
: constant Boolean :=
7818 Ekind
(Typ
) = E_Record_Type
7819 and then Is_Concurrent_Record_Type
(Typ
)
7820 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
7822 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7823 Proc_Id
: Entity_Id
;
7827 -- The corresponding records of task types are not controlled by design.
7828 -- For the sake of completeness, create an empty Finalize_Address to be
7829 -- used in task class-wide allocations.
7834 -- Nothing to do if the type is not controlled or it already has a
7835 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
7836 -- come from source. These are usually generated for completeness and
7837 -- do not need the Finalize_Address primitive.
7839 elsif not Needs_Finalization
(Typ
)
7840 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
7842 (Is_Class_Wide_Type
(Typ
)
7843 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
7844 and then not Comes_From_Source
(Root_Type
(Typ
)))
7849 -- Do not generate Finalize_Address routine for CodePeer
7851 if CodePeer_Mode
then
7856 Make_Defining_Identifier
(Loc
,
7857 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
7861 -- procedure <Typ>FD (V : System.Address) is
7863 -- null; -- for tasks
7865 -- declare -- for all other types
7866 -- type Pnn is access all Typ;
7867 -- for Pnn'Storage_Size use 0;
7869 -- [Deep_]Finalize (Pnn (V).all);
7874 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
7876 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
7880 Make_Subprogram_Body
(Loc
,
7882 Make_Procedure_Specification
(Loc
,
7883 Defining_Unit_Name
=> Proc_Id
,
7885 Parameter_Specifications
=> New_List
(
7886 Make_Parameter_Specification
(Loc
,
7887 Defining_Identifier
=>
7888 Make_Defining_Identifier
(Loc
, Name_V
),
7890 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
7892 Declarations
=> No_List
,
7894 Handled_Statement_Sequence
=>
7895 Make_Handled_Sequence_Of_Statements
(Loc
,
7896 Statements
=> Stmts
)));
7898 Set_TSS
(Typ
, Proc_Id
);
7899 end Make_Finalize_Address_Body
;
7901 ---------------------------------
7902 -- Make_Finalize_Address_Stmts --
7903 ---------------------------------
7905 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
7906 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7909 Desig_Typ
: Entity_Id
;
7910 Fin_Block
: Node_Id
;
7913 Ptr_Typ
: Entity_Id
;
7916 if Is_Array_Type
(Typ
) then
7917 if Is_Constrained
(First_Subtype
(Typ
)) then
7918 Desig_Typ
:= First_Subtype
(Typ
);
7920 Desig_Typ
:= Base_Type
(Typ
);
7923 -- Class-wide types of constrained root types
7925 elsif Is_Class_Wide_Type
(Typ
)
7926 and then Has_Discriminants
(Root_Type
(Typ
))
7928 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
7931 Parent_Typ
: Entity_Id
;
7934 -- Climb the parent type chain looking for a non-constrained type
7936 Parent_Typ
:= Root_Type
(Typ
);
7937 while Parent_Typ
/= Etype
(Parent_Typ
)
7938 and then Has_Discriminants
(Parent_Typ
)
7940 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
7942 Parent_Typ
:= Etype
(Parent_Typ
);
7945 -- Handle views created for tagged types with unknown
7948 if Is_Underlying_Record_View
(Parent_Typ
) then
7949 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
7952 Desig_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
7962 -- type Ptr_Typ is access all Typ;
7963 -- for Ptr_Typ'Storage_Size use 0;
7965 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
7968 Make_Full_Type_Declaration
(Loc
,
7969 Defining_Identifier
=> Ptr_Typ
,
7971 Make_Access_To_Object_Definition
(Loc
,
7972 All_Present
=> True,
7973 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))),
7975 Make_Attribute_Definition_Clause
(Loc
,
7976 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
7977 Chars
=> Name_Storage_Size
,
7978 Expression
=> Make_Integer_Literal
(Loc
, 0)));
7980 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
7982 -- Unconstrained arrays require special processing in order to retrieve
7983 -- the elements. To achieve this, we have to skip the dope vector which
7984 -- lays in front of the elements and then use a thin pointer to perform
7985 -- the address-to-access conversion.
7987 if Is_Array_Type
(Typ
)
7988 and then not Is_Constrained
(First_Subtype
(Typ
))
7991 Dope_Id
: Entity_Id
;
7994 -- Ensure that Ptr_Typ a thin pointer, generate:
7995 -- for Ptr_Typ'Size use System.Address'Size;
7998 Make_Attribute_Definition_Clause
(Loc
,
7999 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8002 Make_Integer_Literal
(Loc
, System_Address_Size
)));
8005 -- Dnn : constant Storage_Offset :=
8006 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8008 Dope_Id
:= Make_Temporary
(Loc
, 'D');
8011 Make_Object_Declaration
(Loc
,
8012 Defining_Identifier
=> Dope_Id
,
8013 Constant_Present
=> True,
8014 Object_Definition
=>
8015 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
8017 Make_Op_Divide
(Loc
,
8019 Make_Attribute_Reference
(Loc
,
8020 Prefix
=> New_Occurrence_Of
(Desig_Typ
, Loc
),
8021 Attribute_Name
=> Name_Descriptor_Size
),
8023 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
8025 -- Shift the address from the start of the dope vector to the
8026 -- start of the elements:
8030 -- Note that this is done through a wrapper routine since RTSfind
8031 -- cannot retrieve operations with string names of the form "+".
8034 Make_Function_Call
(Loc
,
8036 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
8037 Parameter_Associations
=> New_List
(
8039 New_Occurrence_Of
(Dope_Id
, Loc
)));
8046 Make_Explicit_Dereference
(Loc
,
8047 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
8050 if Present
(Fin_Call
) then
8052 Make_Block_Statement
(Loc
,
8053 Declarations
=> Decls
,
8054 Handled_Statement_Sequence
=>
8055 Make_Handled_Sequence_Of_Statements
(Loc
,
8056 Statements
=> New_List
(Fin_Call
)));
8058 -- Otherwise previous errors or a missing full view may prevent the
8059 -- proper freezing of the designated type. If this is the case, there
8060 -- is no [Deep_]Finalize primitive to call.
8063 Fin_Block
:= Make_Null_Statement
(Loc
);
8066 return New_List
(Fin_Block
);
8067 end Make_Finalize_Address_Stmts
;
8069 -------------------------------------
8070 -- Make_Handler_For_Ctrl_Operation --
8071 -------------------------------------
8075 -- when E : others =>
8076 -- Raise_From_Controlled_Operation (E);
8081 -- raise Program_Error [finalize raised exception];
8083 -- depending on whether Raise_From_Controlled_Operation is available
8085 function Make_Handler_For_Ctrl_Operation
8086 (Loc
: Source_Ptr
) return Node_Id
8089 -- Choice parameter (for the first case above)
8091 Raise_Node
: Node_Id
;
8092 -- Procedure call or raise statement
8095 -- Standard run-time: add choice parameter E and pass it to
8096 -- Raise_From_Controlled_Operation so that the original exception
8097 -- name and message can be recorded in the exception message for
8100 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
8101 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
8103 Make_Procedure_Call_Statement
(Loc
,
8106 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
8107 Parameter_Associations
=> New_List
(
8108 New_Occurrence_Of
(E_Occ
, Loc
)));
8110 -- Restricted run-time: exception messages are not supported
8115 Make_Raise_Program_Error
(Loc
,
8116 Reason
=> PE_Finalize_Raised_Exception
);
8120 Make_Implicit_Exception_Handler
(Loc
,
8121 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8122 Choice_Parameter
=> E_Occ
,
8123 Statements
=> New_List
(Raise_Node
));
8124 end Make_Handler_For_Ctrl_Operation
;
8126 --------------------
8127 -- Make_Init_Call --
8128 --------------------
8130 function Make_Init_Call
8132 Typ
: Entity_Id
) return Node_Id
8134 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8143 -- Deal with the type and object reference. Depending on the context, an
8144 -- object reference may need several conversions.
8146 if Is_Concurrent_Type
(Typ
) then
8148 Utyp
:= Corresponding_Record_Type
(Typ
);
8149 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8151 elsif Is_Private_Type
(Typ
)
8152 and then Present
(Full_View
(Typ
))
8153 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8156 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8157 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8164 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8165 Set_Assignment_OK
(Ref
);
8167 -- Deal with untagged derivation of private views
8169 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
8170 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8171 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8173 -- The following is to prevent problems with UC see 1.156 RH ???
8175 Set_Assignment_OK
(Ref
);
8178 -- If the underlying_type is a subtype, then we are dealing with the
8179 -- completion of a private type. We need to access the base type and
8180 -- generate a conversion to it.
8182 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8183 pragma Assert
(Is_Private_Type
(Typ
));
8184 Utyp
:= Base_Type
(Utyp
);
8185 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8188 -- The underlying type may not be present due to a missing full view.
8189 -- In this case freezing did not take place and there is no suitable
8190 -- [Deep_]Initialize primitive to call.
8196 -- Select the appropriate version of initialize
8198 if Has_Controlled_Component
(Utyp
) then
8199 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
8201 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
8202 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
8205 -- If initialization procedure for an array of controlled objects is
8206 -- trivial, do not generate a useless call to it.
8208 if (Is_Array_Type
(Utyp
) and then Is_Trivial_Subprogram
(Proc
))
8210 (not Comes_From_Source
(Proc
)
8211 and then Present
(Alias
(Proc
))
8212 and then Is_Trivial_Subprogram
(Alias
(Proc
)))
8214 return Make_Null_Statement
(Loc
);
8217 -- The object reference may need another conversion depending on the
8218 -- type of the formal and that of the actual.
8220 Ref
:= Convert_View
(Proc
, Ref
);
8223 -- [Deep_]Initialize (Ref);
8226 Make_Procedure_Call_Statement
(Loc
,
8227 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8228 Parameter_Associations
=> New_List
(Ref
));
8231 ------------------------------
8232 -- Make_Local_Deep_Finalize --
8233 ------------------------------
8235 function Make_Local_Deep_Finalize
8237 Nam
: Entity_Id
) return Node_Id
8239 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8243 Formals
:= New_List
(
8247 Make_Parameter_Specification
(Loc
,
8248 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
8250 Out_Present
=> True,
8251 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
8253 -- F : Boolean := True
8255 Make_Parameter_Specification
(Loc
,
8256 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
8257 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8258 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
8260 -- Add the necessary number of counters to represent the initialization
8261 -- state of an object.
8264 Make_Subprogram_Body
(Loc
,
8266 Make_Procedure_Specification
(Loc
,
8267 Defining_Unit_Name
=> Nam
,
8268 Parameter_Specifications
=> Formals
),
8270 Declarations
=> No_List
,
8272 Handled_Statement_Sequence
=>
8273 Make_Handled_Sequence_Of_Statements
(Loc
,
8274 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
8275 end Make_Local_Deep_Finalize
;
8277 ------------------------------------
8278 -- Make_Set_Finalize_Address_Call --
8279 ------------------------------------
8281 function Make_Set_Finalize_Address_Call
8283 Ptr_Typ
: Entity_Id
) return Node_Id
8285 -- It is possible for Ptr_Typ to be a partial view, if the access type
8286 -- is a full view declared in the private part of a nested package, and
8287 -- the finalization actions take place when completing analysis of the
8288 -- enclosing unit. For this reason use Underlying_Type twice below.
8290 Desig_Typ
: constant Entity_Id
:=
8292 (Designated_Type
(Underlying_Type
(Ptr_Typ
)));
8293 Fin_Addr
: constant Entity_Id
:= Finalize_Address
(Desig_Typ
);
8294 Fin_Mas
: constant Entity_Id
:=
8295 Finalization_Master
(Underlying_Type
(Ptr_Typ
));
8298 -- Both the finalization master and primitive Finalize_Address must be
8301 pragma Assert
(Present
(Fin_Addr
) and Present
(Fin_Mas
));
8304 -- Set_Finalize_Address
8305 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8308 Make_Procedure_Call_Statement
(Loc
,
8310 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
8311 Parameter_Associations
=> New_List
(
8312 New_Occurrence_Of
(Fin_Mas
, Loc
),
8314 Make_Attribute_Reference
(Loc
,
8315 Prefix
=> New_Occurrence_Of
(Fin_Addr
, Loc
),
8316 Attribute_Name
=> Name_Unrestricted_Access
)));
8317 end Make_Set_Finalize_Address_Call
;
8319 --------------------------
8320 -- Make_Transient_Block --
8321 --------------------------
8323 function Make_Transient_Block
8326 Par
: Node_Id
) return Node_Id
8328 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean;
8329 -- Determine whether scoping entity Id manages the secondary stack
8331 -----------------------
8332 -- Manages_Sec_Stack --
8333 -----------------------
8335 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean is
8339 -- An exception handler with a choice parameter utilizes a dummy
8340 -- block to provide a declarative region. Such a block should not
8341 -- be considered because it never manifests in the tree and can
8342 -- never release the secondary stack.
8346 Uses_Sec_Stack
(Id
) and then not Is_Exception_Handler
(Id
);
8353 return Uses_Sec_Stack
(Id
);
8358 end Manages_Sec_Stack
;
8362 Decls
: constant List_Id
:= New_List
;
8363 Instrs
: constant List_Id
:= New_List
(Action
);
8364 Trans_Id
: constant Entity_Id
:= Current_Scope
;
8370 -- Start of processing for Make_Transient_Block
8373 -- Even though the transient block is tasked with managing the secondary
8374 -- stack, the block may forgo this functionality depending on how the
8375 -- secondary stack is managed by enclosing scopes.
8377 if Manages_Sec_Stack
(Trans_Id
) then
8379 -- Determine whether an enclosing scope already manages the secondary
8382 Scop
:= Scope
(Trans_Id
);
8383 while Present
(Scop
) loop
8385 -- It should not be possible to reach Standard without hitting one
8386 -- of the other cases first unless Standard was manually pushed.
8388 if Scop
= Standard_Standard
then
8391 -- The transient block is within a function which returns on the
8392 -- secondary stack. Take a conservative approach and assume that
8393 -- the value on the secondary stack is part of the result. Note
8394 -- that it is not possible to detect this dependency without flow
8395 -- analysis which the compiler does not have. Letting the object
8396 -- live longer than the transient block will not leak any memory
8397 -- because the caller will reclaim the total storage used by the
8400 elsif Ekind
(Scop
) = E_Function
8401 and then Sec_Stack_Needed_For_Return
(Scop
)
8403 Set_Uses_Sec_Stack
(Trans_Id
, False);
8406 -- The transient block must manage the secondary stack when the
8407 -- block appears within a loop in order to reclaim the memory at
8410 elsif Ekind
(Scop
) = E_Loop
then
8413 -- The transient block does not need to manage the secondary stack
8414 -- when there is an enclosing construct which already does that.
8415 -- This optimization saves on SS_Mark and SS_Release calls but may
8416 -- allow objects to live a little longer than required.
8418 -- The transient block must manage the secondary stack when switch
8419 -- -gnatd.s (strict management) is in effect.
8421 elsif Manages_Sec_Stack
(Scop
) and then not Debug_Flag_Dot_S
then
8422 Set_Uses_Sec_Stack
(Trans_Id
, False);
8425 -- Prevent the search from going too far because transient blocks
8426 -- are bounded by packages and subprogram scopes.
8428 elsif Ekind_In
(Scop
, E_Entry
,
8438 Scop
:= Scope
(Scop
);
8442 -- Create the transient block. Set the parent now since the block itself
8443 -- is not part of the tree. The current scope is the E_Block entity that
8444 -- has been pushed by Establish_Transient_Scope.
8446 pragma Assert
(Ekind
(Trans_Id
) = E_Block
);
8449 Make_Block_Statement
(Loc
,
8450 Identifier
=> New_Occurrence_Of
(Trans_Id
, Loc
),
8451 Declarations
=> Decls
,
8452 Handled_Statement_Sequence
=>
8453 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
8454 Has_Created_Identifier
=> True);
8455 Set_Parent
(Block
, Par
);
8457 -- Insert actions stuck in the transient scopes as well as all freezing
8458 -- nodes needed by those actions. Do not insert cleanup actions here,
8459 -- they will be transferred to the newly created block.
8461 Insert_Actions_In_Scope_Around
8462 (Action
, Clean
=> False, Manage_SS
=> False);
8464 Insert
:= Prev
(Action
);
8466 if Present
(Insert
) then
8467 Freeze_All
(First_Entity
(Trans_Id
), Insert
);
8470 -- Transfer cleanup actions to the newly created block
8473 Cleanup_Actions
: List_Id
8474 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
8475 Actions_To_Be_Wrapped
(Cleanup
);
8477 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
8478 Cleanup_Actions
:= No_List
;
8481 -- When the transient scope was established, we pushed the entry for the
8482 -- transient scope onto the scope stack, so that the scope was active
8483 -- for the installation of finalizable entities etc. Now we must remove
8484 -- this entry, since we have constructed a proper block.
8489 end Make_Transient_Block
;
8491 ------------------------
8492 -- Node_To_Be_Wrapped --
8493 ------------------------
8495 function Node_To_Be_Wrapped
return Node_Id
is
8497 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
8498 end Node_To_Be_Wrapped
;
8500 ----------------------------
8501 -- Set_Node_To_Be_Wrapped --
8502 ----------------------------
8504 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
8506 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
8507 end Set_Node_To_Be_Wrapped
;
8509 ----------------------------
8510 -- Store_Actions_In_Scope --
8511 ----------------------------
8513 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
8514 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
8515 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
8518 if No
(Actions
) then
8521 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
8522 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
8524 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
8529 elsif AK
= Before
then
8530 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
8533 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
8535 end Store_Actions_In_Scope
;
8537 ----------------------------------
8538 -- Store_After_Actions_In_Scope --
8539 ----------------------------------
8541 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
8543 Store_Actions_In_Scope
(After
, L
);
8544 end Store_After_Actions_In_Scope
;
8546 -----------------------------------
8547 -- Store_Before_Actions_In_Scope --
8548 -----------------------------------
8550 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
8552 Store_Actions_In_Scope
(Before
, L
);
8553 end Store_Before_Actions_In_Scope
;
8555 -----------------------------------
8556 -- Store_Cleanup_Actions_In_Scope --
8557 -----------------------------------
8559 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
8561 Store_Actions_In_Scope
(Cleanup
, L
);
8562 end Store_Cleanup_Actions_In_Scope
;
8564 --------------------------------
8565 -- Wrap_Transient_Declaration --
8566 --------------------------------
8568 -- If a transient scope has been established during the processing of the
8569 -- Expression of an Object_Declaration, it is not possible to wrap the
8570 -- declaration into a transient block as usual case, otherwise the object
8571 -- would be itself declared in the wrong scope. Therefore, all entities (if
8572 -- any) defined in the transient block are moved to the proper enclosing
8573 -- scope. Furthermore, if they are controlled variables they are finalized
8574 -- right after the declaration. The finalization list of the transient
8575 -- scope is defined as a renaming of the enclosing one so during their
8576 -- initialization they will be attached to the proper finalization list.
8577 -- For instance, the following declaration :
8579 -- X : Typ := F (G (A), G (B));
8581 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
8582 -- is expanded into :
8584 -- X : Typ := [ complex Expression-Action ];
8585 -- [Deep_]Finalize (_v1);
8586 -- [Deep_]Finalize (_v2);
8588 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
8593 Curr_S
:= Current_Scope
;
8594 Encl_S
:= Scope
(Curr_S
);
8596 -- Insert all actions including cleanup generated while analyzing or
8597 -- expanding the transient context back into the tree. Manage the
8598 -- secondary stack when the object declaration appears in a library
8599 -- level package [body].
8601 Insert_Actions_In_Scope_Around
8605 Uses_Sec_Stack
(Curr_S
)
8606 and then Nkind
(N
) = N_Object_Declaration
8607 and then Ekind_In
(Encl_S
, E_Package
, E_Package_Body
)
8608 and then Is_Library_Level_Entity
(Encl_S
));
8611 -- Relocate local entities declared within the transient scope to the
8612 -- enclosing scope. This action sets their Is_Public flag accordingly.
8614 Transfer_Entities
(Curr_S
, Encl_S
);
8616 -- Mark the enclosing dynamic scope to ensure that the secondary stack
8617 -- is properly released upon exiting the said scope.
8619 if Uses_Sec_Stack
(Curr_S
) then
8620 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
8622 -- Do not mark a function that returns on the secondary stack as the
8623 -- reclamation is done by the caller.
8625 if Ekind
(Curr_S
) = E_Function
8626 and then Requires_Transient_Scope
(Etype
(Curr_S
))
8630 -- Otherwise mark the enclosing dynamic scope
8633 Set_Uses_Sec_Stack
(Curr_S
);
8634 Check_Restriction
(No_Secondary_Stack
, N
);
8637 end Wrap_Transient_Declaration
;
8639 -------------------------------
8640 -- Wrap_Transient_Expression --
8641 -------------------------------
8643 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
8644 Loc
: constant Source_Ptr
:= Sloc
(N
);
8645 Expr
: Node_Id
:= Relocate_Node
(N
);
8646 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
8647 Typ
: constant Entity_Id
:= Etype
(N
);
8654 -- M : constant Mark_Id := SS_Mark;
8655 -- procedure Finalizer is ... (See Build_Finalizer)
8658 -- Temp := <Expr>; -- general case
8659 -- Temp := (if <Expr> then True else False); -- boolean case
8665 -- A special case is made for Boolean expressions so that the back-end
8666 -- knows to generate a conditional branch instruction, if running with
8667 -- -fpreserve-control-flow. This ensures that a control flow change
8668 -- signalling the decision outcome occurs before the cleanup actions.
8670 if Opt
.Suppress_Control_Flow_Optimizations
8671 and then Is_Boolean_Type
(Typ
)
8674 Make_If_Expression
(Loc
,
8675 Expressions
=> New_List
(
8677 New_Occurrence_Of
(Standard_True
, Loc
),
8678 New_Occurrence_Of
(Standard_False
, Loc
)));
8681 Insert_Actions
(N
, New_List
(
8682 Make_Object_Declaration
(Loc
,
8683 Defining_Identifier
=> Temp
,
8684 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
8686 Make_Transient_Block
(Loc
,
8688 Make_Assignment_Statement
(Loc
,
8689 Name
=> New_Occurrence_Of
(Temp
, Loc
),
8690 Expression
=> Expr
),
8691 Par
=> Parent
(N
))));
8693 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
8694 Analyze_And_Resolve
(N
, Typ
);
8695 end Wrap_Transient_Expression
;
8697 ------------------------------
8698 -- Wrap_Transient_Statement --
8699 ------------------------------
8701 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
8702 Loc
: constant Source_Ptr
:= Sloc
(N
);
8703 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
8708 -- M : constant Mark_Id := SS_Mark;
8709 -- procedure Finalizer is ... (See Build_Finalizer)
8719 Make_Transient_Block
(Loc
,
8721 Par
=> Parent
(N
)));
8723 -- With the scope stack back to normal, we can call analyze on the
8724 -- resulting block. At this point, the transient scope is being
8725 -- treated like a perfectly normal scope, so there is nothing
8726 -- special about it.
8728 -- Note: Wrap_Transient_Statement is called with the node already
8729 -- analyzed (i.e. Analyzed (N) is True). This is important, since
8730 -- otherwise we would get a recursive processing of the node when
8731 -- we do this Analyze call.
8734 end Wrap_Transient_Statement
;