1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This package contains virtually all expansion mechanisms related to
30 with Atree
; use Atree
;
31 with Debug
; use Debug
;
32 with Einfo
; use Einfo
;
33 with Elists
; use Elists
;
34 with Errout
; use Errout
;
35 with Exp_Ch6
; use Exp_Ch6
;
36 with Exp_Ch9
; use Exp_Ch9
;
37 with Exp_Ch11
; use Exp_Ch11
;
38 with Exp_Dbug
; use Exp_Dbug
;
39 with Exp_Dist
; use Exp_Dist
;
40 with Exp_Disp
; use Exp_Disp
;
41 with Exp_Prag
; use Exp_Prag
;
42 with Exp_Tss
; use Exp_Tss
;
43 with Exp_Util
; use Exp_Util
;
44 with Freeze
; use Freeze
;
46 with Nlists
; use Nlists
;
47 with Nmake
; use Nmake
;
49 with Output
; use Output
;
50 with Restrict
; use Restrict
;
51 with Rident
; use Rident
;
52 with Rtsfind
; use Rtsfind
;
53 with Sinfo
; use Sinfo
;
55 with Sem_Aux
; use Sem_Aux
;
56 with Sem_Ch3
; use Sem_Ch3
;
57 with Sem_Ch7
; use Sem_Ch7
;
58 with Sem_Ch8
; use Sem_Ch8
;
59 with Sem_Res
; use Sem_Res
;
60 with Sem_Util
; use Sem_Util
;
61 with Snames
; use Snames
;
62 with Stand
; use Stand
;
63 with Tbuild
; use Tbuild
;
64 with Ttypes
; use Ttypes
;
65 with Uintp
; use Uintp
;
67 package body Exp_Ch7
is
69 --------------------------------
70 -- Transient Scope Management --
71 --------------------------------
73 -- A transient scope is created when temporary objects are created by the
74 -- compiler. These temporary objects are allocated on the secondary stack
75 -- and the transient scope is responsible for finalizing the object when
76 -- appropriate and reclaiming the memory at the right time. The temporary
77 -- objects are generally the objects allocated to store the result of a
78 -- function returning an unconstrained or a tagged value. Expressions
79 -- needing to be wrapped in a transient scope (functions calls returning
80 -- unconstrained or tagged values) may appear in 3 different contexts which
81 -- lead to 3 different kinds of transient scope expansion:
83 -- 1. In a simple statement (procedure call, assignment, ...). In this
84 -- case the instruction is wrapped into a transient block. See
85 -- Wrap_Transient_Statement for details.
87 -- 2. In an expression of a control structure (test in a IF statement,
88 -- expression in a CASE statement, ...). See Wrap_Transient_Expression
91 -- 3. In a expression of an object_declaration. No wrapping is possible
92 -- here, so the finalization actions, if any, are done right after the
93 -- declaration and the secondary stack deallocation is done in the
94 -- proper enclosing scope. See Wrap_Transient_Declaration for details.
96 -- Note about functions returning tagged types: it has been decided to
97 -- always allocate their result in the secondary stack, even though is not
98 -- absolutely mandatory when the tagged type is constrained because the
99 -- caller knows the size of the returned object and thus could allocate the
100 -- result in the primary stack. An exception to this is when the function
101 -- builds its result in place, as is done for functions with inherently
102 -- limited result types for Ada 2005. In that case, certain callers may
103 -- pass the address of a constrained object as the target object for the
106 -- By allocating tagged results in the secondary stack a number of
107 -- implementation difficulties are avoided:
109 -- - If it is a dispatching function call, the computation of the size of
110 -- the result is possible but complex from the outside.
112 -- - If the returned type is controlled, the assignment of the returned
113 -- value to the anonymous object involves an Adjust, and we have no
114 -- easy way to access the anonymous object created by the back end.
116 -- - If the returned type is class-wide, this is an unconstrained type
119 -- Furthermore, the small loss in efficiency which is the result of this
120 -- decision is not such a big deal because functions returning tagged types
121 -- are not as common in practice compared to functions returning access to
124 --------------------------------------------------
125 -- Transient Blocks and Finalization Management --
126 --------------------------------------------------
128 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
;
129 -- Locate a suitable context for arbitrary node N which may need to be
130 -- serviced by a transient scope. Return Empty if no suitable context is
133 procedure Insert_Actions_In_Scope_Around
136 Manage_SS
: Boolean);
137 -- Insert the before-actions kept in the scope stack before N, and the
138 -- after-actions after N, which must be a member of a list. If flag Clean
139 -- is set, insert any cleanup actions. If flag Manage_SS is set, insert
140 -- calls to mark and release the secondary stack.
142 function Make_Transient_Block
145 Par
: Node_Id
) return Node_Id
;
146 -- Action is a single statement or object declaration. Par is the proper
147 -- parent of the generated block. Create a transient block whose name is
148 -- the current scope and the only handled statement is Action. If Action
149 -- involves controlled objects or secondary stack usage, the corresponding
150 -- cleanup actions are performed at the end of the block.
152 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
);
153 -- Set the field Node_To_Be_Wrapped of the current scope
155 -- ??? The entire comment needs to be rewritten
156 -- ??? which entire comment?
158 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
);
159 -- Shared processing for Store_xxx_Actions_In_Scope
161 -----------------------------
162 -- Finalization Management --
163 -----------------------------
165 -- This part describe how Initialization/Adjustment/Finalization procedures
166 -- are generated and called. Two cases must be considered, types that are
167 -- Controlled (Is_Controlled flag set) and composite types that contain
168 -- controlled components (Has_Controlled_Component flag set). In the first
169 -- case the procedures to call are the user-defined primitive operations
170 -- Initialize/Adjust/Finalize. In the second case, GNAT generates
171 -- Deep_Initialize, Deep_Adjust and Deep_Finalize that are in charge
172 -- of calling the former procedures on the controlled components.
174 -- For records with Has_Controlled_Component set, a hidden "controller"
175 -- component is inserted. This controller component contains its own
176 -- finalization list on which all controlled components are attached
177 -- creating an indirection on the upper-level Finalization list. This
178 -- technique facilitates the management of objects whose number of
179 -- controlled components changes during execution. This controller
180 -- component is itself controlled and is attached to the upper-level
181 -- finalization chain. Its adjust primitive is in charge of calling adjust
182 -- on the components and adjusting the finalization pointer to match their
183 -- new location (see a-finali.adb).
185 -- It is not possible to use a similar technique for arrays that have
186 -- Has_Controlled_Component set. In this case, deep procedures are
187 -- generated that call initialize/adjust/finalize + attachment or
188 -- detachment on the finalization list for all component.
190 -- Initialize calls: they are generated for declarations or dynamic
191 -- allocations of Controlled objects with no initial value. They are always
192 -- followed by an attachment to the current Finalization Chain. For the
193 -- dynamic allocation case this the chain attached to the scope of the
194 -- access type definition otherwise, this is the chain of the current
197 -- Adjust Calls: They are generated on 2 occasions: (1) for declarations
198 -- or dynamic allocations of Controlled objects with an initial value.
199 -- (2) after an assignment. In the first case they are followed by an
200 -- attachment to the final chain, in the second case they are not.
202 -- Finalization Calls: They are generated on (1) scope exit, (2)
203 -- assignments, (3) unchecked deallocations. In case (3) they have to
204 -- be detached from the final chain, in case (2) they must not and in
205 -- case (1) this is not important since we are exiting the scope anyway.
209 -- Type extensions will have a new record controller at each derivation
210 -- level containing controlled components. The record controller for
211 -- the parent/ancestor is attached to the finalization list of the
212 -- extension's record controller (i.e. the parent is like a component
213 -- of the extension).
215 -- For types that are both Is_Controlled and Has_Controlled_Components,
216 -- the record controller and the object itself are handled separately.
217 -- It could seem simpler to attach the object at the end of its record
218 -- controller but this would not tackle view conversions properly.
220 -- A classwide type can always potentially have controlled components
221 -- but the record controller of the corresponding actual type may not
222 -- be known at compile time so the dispatch table contains a special
223 -- field that allows computation of the offset of the record controller
224 -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset.
226 -- Here is a simple example of the expansion of a controlled block :
230 -- Y : Controlled := Init;
236 -- Z : R := (C => X);
246 -- _L : System.FI.Finalizable_Ptr;
248 -- procedure _Clean is
251 -- System.FI.Finalize_List (_L);
259 -- Attach_To_Final_List (_L, Finalizable (X), 1);
260 -- at end: Abort_Undefer;
261 -- Y : Controlled := Init;
263 -- Attach_To_Final_List (_L, Finalizable (Y), 1);
271 -- Deep_Initialize (W, _L, 1);
272 -- at end: Abort_Under;
273 -- Z : R := (C => X);
274 -- Deep_Adjust (Z, _L, 1);
278 -- Deep_Finalize (W, False);
279 -- <save W's final pointers>
281 -- <restore W's final pointers>
282 -- Deep_Adjust (W, _L, 0);
287 type Final_Primitives
is
288 (Initialize_Case
, Adjust_Case
, Finalize_Case
, Address_Case
);
289 -- This enumeration type is defined in order to ease sharing code for
290 -- building finalization procedures for composite types.
292 Name_Of
: constant array (Final_Primitives
) of Name_Id
:=
293 (Initialize_Case
=> Name_Initialize
,
294 Adjust_Case
=> Name_Adjust
,
295 Finalize_Case
=> Name_Finalize
,
296 Address_Case
=> Name_Finalize_Address
);
297 Deep_Name_Of
: constant array (Final_Primitives
) of TSS_Name_Type
:=
298 (Initialize_Case
=> TSS_Deep_Initialize
,
299 Adjust_Case
=> TSS_Deep_Adjust
,
300 Finalize_Case
=> TSS_Deep_Finalize
,
301 Address_Case
=> TSS_Finalize_Address
);
303 function Allows_Finalization_Master
(Typ
: Entity_Id
) return Boolean;
304 -- Determine whether access type Typ may have a finalization master
306 procedure Build_Array_Deep_Procs
(Typ
: Entity_Id
);
307 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
308 -- Has_Controlled_Component set and store them using the TSS mechanism.
310 function Build_Cleanup_Statements
312 Additional_Cleanup
: List_Id
) return List_Id
;
313 -- Create the cleanup calls for an asynchronous call block, task master,
314 -- protected subprogram body, task allocation block or task body, or
315 -- additional cleanup actions parked on a transient block. If the context
316 -- does not contain the above constructs, the routine returns an empty
319 procedure Build_Finalizer
321 Clean_Stmts
: List_Id
;
324 Defer_Abort
: Boolean;
325 Fin_Id
: out Entity_Id
);
326 -- N may denote an accept statement, block, entry body, package body,
327 -- package spec, protected body, subprogram body, or a task body. Create
328 -- a procedure which contains finalization calls for all controlled objects
329 -- declared in the declarative or statement region of N. The calls are
330 -- built in reverse order relative to the original declarations. In the
331 -- case of a task body, the routine delays the creation of the finalizer
332 -- until all statements have been moved to the task body procedure.
333 -- Clean_Stmts may contain additional context-dependent code used to abort
334 -- asynchronous calls or complete tasks (see Build_Cleanup_Statements).
335 -- Mark_Id is the secondary stack used in the current context or Empty if
336 -- missing. Top_Decls is the list on which the declaration of the finalizer
337 -- is attached in the non-package case. Defer_Abort indicates that the
338 -- statements passed in perform actions that require abort to be deferred,
339 -- such as for task termination. Fin_Id is the finalizer declaration
342 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
);
343 -- N is a construct which contains a handled sequence of statements, Fin_Id
344 -- is the entity of a finalizer. Create an At_End handler which covers the
345 -- statements of N and calls Fin_Id. If the handled statement sequence has
346 -- an exception handler, the statements will be wrapped in a block to avoid
347 -- unwanted interaction with the new At_End handler.
349 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
);
350 -- Build the deep Initialize/Adjust/Finalize for a record Typ with
351 -- Has_Component_Component set and store them using the TSS mechanism.
353 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 cleanup.
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 cleanup, the finalization
1558 -- machinery is added after the cleanup 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
1782 if Present
(Mark_Id
) then
1784 Release
: Node_Id
:= Build_SS_Release_Call
(Loc
, Mark_Id
);
1787 -- If the context is a build-in-place function, the secondary
1788 -- stack must be released, unless the build-in-place function
1789 -- itself is returning on the secondary stack. Generate:
1791 -- if BIP_Alloc_Form /= Secondary_Stack then
1792 -- SS_Release (Mark_Id);
1795 -- Note that if the function returns on the secondary stack,
1796 -- then the responsibility of reclaiming the space is always
1797 -- left to the caller (recursively if needed).
1799 if Nkind
(N
) = N_Subprogram_Body
then
1801 Spec_Id
: constant Entity_Id
:=
1802 Unique_Defining_Entity
(N
);
1803 BIP_SS
: constant Boolean :=
1804 Is_Build_In_Place_Function
(Spec_Id
)
1805 and then Needs_BIP_Alloc_Form
(Spec_Id
);
1809 Make_If_Statement
(Loc
,
1814 (Build_In_Place_Formal
1815 (Spec_Id
, BIP_Alloc_Form
), Loc
),
1817 Make_Integer_Literal
(Loc
,
1819 (BIP_Allocation_Form
'Pos
1820 (Secondary_Stack
)))),
1822 Then_Statements
=> New_List
(Release
));
1827 Append_To
(Finalizer_Stmts
, Release
);
1831 -- Protect the statements with abort defer/undefer. This is only when
1832 -- aborts are allowed and the cleanup statements require deferral or
1833 -- there are controlled objects to be finalized. Note that the abort
1834 -- defer/undefer pair does not require an extra block because each
1835 -- finalization exception is caught in its corresponding finalization
1836 -- block. As a result, the call to Abort_Defer always takes place.
1838 if Abort_Allowed
and then (Defer_Abort
or Has_Ctrl_Objs
) then
1839 Prepend_To
(Finalizer_Stmts
,
1840 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
1842 Append_To
(Finalizer_Stmts
,
1843 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
1846 -- The local exception does not need to be reraised for library-level
1847 -- finalizers. Note that this action must be carried out after object
1848 -- cleanup, secondary stack release, and abort undeferral. Generate:
1850 -- if Raised and then not Abort then
1851 -- Raise_From_Controlled_Operation (E);
1854 if Has_Ctrl_Objs
and Exceptions_OK
and not For_Package
then
1855 Append_To
(Finalizer_Stmts
,
1856 Build_Raise_Statement
(Finalizer_Data
));
1860 -- procedure Fin_Id is
1861 -- Abort : constant Boolean := Triggered_By_Abort;
1863 -- Abort : constant Boolean := False; -- no abort
1865 -- E : Exception_Occurrence; -- All added if flag
1866 -- Raised : Boolean := False; -- Has_Ctrl_Objs is set
1872 -- Abort_Defer; -- Added if abort is allowed
1873 -- <call to Prev_At_End> -- Added if exists
1874 -- <cleanup statements> -- Added if Acts_As_Clean
1875 -- <jump block> -- Added if Has_Ctrl_Objs
1876 -- <finalization statements> -- Added if Has_Ctrl_Objs
1877 -- <stack release> -- Added if Mark_Id exists
1878 -- Abort_Undefer; -- Added if abort is allowed
1879 -- <exception propagation> -- Added if Has_Ctrl_Objs
1882 -- Create the body of the finalizer
1884 Body_Id
:= Make_Defining_Identifier
(Loc
, Chars
(Fin_Id
));
1887 Set_Has_Qualified_Name
(Body_Id
);
1888 Set_Has_Fully_Qualified_Name
(Body_Id
);
1892 Make_Subprogram_Body
(Loc
,
1894 Make_Procedure_Specification
(Loc
,
1895 Defining_Unit_Name
=> Body_Id
),
1896 Declarations
=> Finalizer_Decls
,
1897 Handled_Statement_Sequence
=>
1898 Make_Handled_Sequence_Of_Statements
(Loc
,
1899 Statements
=> Finalizer_Stmts
));
1901 -- Step 4: Spec and body insertion, analysis
1905 -- If the package spec has private declarations, the finalizer
1906 -- body must be added to the end of the list in order to have
1907 -- visibility of all private controlled objects.
1909 if For_Package_Spec
then
1910 if Present
(Priv_Decls
) then
1911 Append_To
(Priv_Decls
, Fin_Spec
);
1912 Append_To
(Priv_Decls
, Fin_Body
);
1914 Append_To
(Decls
, Fin_Spec
);
1915 Append_To
(Decls
, Fin_Body
);
1918 -- For package bodies, both the finalizer spec and body are
1919 -- inserted at the end of the package declarations.
1922 Append_To
(Decls
, Fin_Spec
);
1923 Append_To
(Decls
, Fin_Body
);
1926 -- Push the name of the package
1928 Push_Scope
(Spec_Id
);
1936 -- Create the spec for the finalizer. The At_End handler must be
1937 -- able to call the body which resides in a nested structure.
1941 -- procedure Fin_Id; -- Spec
1943 -- <objects and possibly statements>
1944 -- procedure Fin_Id is ... -- Body
1947 -- Fin_Id; -- At_End handler
1950 pragma Assert
(Present
(Spec_Decls
));
1952 Append_To
(Spec_Decls
, Fin_Spec
);
1955 -- When the finalizer acts solely as a cleanup routine, the body
1956 -- is inserted right after the spec.
1958 if Acts_As_Clean
and not Has_Ctrl_Objs
then
1959 Insert_After
(Fin_Spec
, Fin_Body
);
1961 -- In all other cases the body is inserted after either:
1963 -- 1) The counter update statement of the last controlled object
1964 -- 2) The last top level nested controlled package
1965 -- 3) The last top level controlled instantiation
1968 -- Manually freeze the spec. This is somewhat of a hack because
1969 -- a subprogram is frozen when its body is seen and the freeze
1970 -- node appears right before the body. However, in this case,
1971 -- the spec must be frozen earlier since the At_End handler
1972 -- must be able to call it.
1975 -- procedure Fin_Id; -- Spec
1976 -- [Fin_Id] -- Freeze node
1980 -- Fin_Id; -- At_End handler
1983 Ensure_Freeze_Node
(Fin_Id
);
1984 Insert_After
(Fin_Spec
, Freeze_Node
(Fin_Id
));
1985 Set_Is_Frozen
(Fin_Id
);
1987 -- In the case where the last construct to contain a controlled
1988 -- object is either a nested package, an instantiation or a
1989 -- freeze node, the body must be inserted directly after the
1992 if Nkind_In
(Last_Top_Level_Ctrl_Construct
,
1994 N_Package_Declaration
,
1997 Finalizer_Insert_Nod
:= Last_Top_Level_Ctrl_Construct
;
2000 Insert_After
(Finalizer_Insert_Nod
, Fin_Body
);
2003 Analyze
(Fin_Body
, Suppress
=> All_Checks
);
2005 end Create_Finalizer
;
2007 --------------------------
2008 -- Process_Declarations --
2009 --------------------------
2011 procedure Process_Declarations
2013 Preprocess
: Boolean := False;
2014 Top_Level
: Boolean := False)
2019 Obj_Typ
: Entity_Id
;
2020 Pack_Id
: Entity_Id
;
2024 Old_Counter_Val
: Nat
;
2025 -- This variable is used to determine whether a nested package or
2026 -- instance contains at least one controlled object.
2028 procedure Processing_Actions
2029 (Has_No_Init
: Boolean := False;
2030 Is_Protected
: Boolean := False);
2031 -- Depending on the mode of operation of Process_Declarations, either
2032 -- increment the controlled object counter, set the controlled object
2033 -- flag and store the last top level construct or process the current
2034 -- declaration. Flag Has_No_Init is used to propagate scenarios where
2035 -- the current declaration may not have initialization proc(s). Flag
2036 -- Is_Protected should be set when the current declaration denotes a
2037 -- simple protected object.
2039 ------------------------
2040 -- Processing_Actions --
2041 ------------------------
2043 procedure Processing_Actions
2044 (Has_No_Init
: Boolean := False;
2045 Is_Protected
: Boolean := False)
2048 -- Library-level tagged type
2050 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2052 Has_Tagged_Types
:= True;
2054 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2055 Last_Top_Level_Ctrl_Construct
:= Decl
;
2059 Process_Tagged_Type_Declaration
(Decl
);
2062 -- Controlled object declaration
2066 Counter_Val
:= Counter_Val
+ 1;
2067 Has_Ctrl_Objs
:= True;
2069 if Top_Level
and then No
(Last_Top_Level_Ctrl_Construct
) then
2070 Last_Top_Level_Ctrl_Construct
:= Decl
;
2074 Process_Object_Declaration
(Decl
, Has_No_Init
, Is_Protected
);
2077 end Processing_Actions
;
2079 -- Start of processing for Process_Declarations
2082 if No
(Decls
) or else Is_Empty_List
(Decls
) then
2086 -- Process all declarations in reverse order
2088 Decl
:= Last_Non_Pragma
(Decls
);
2089 while Present
(Decl
) loop
2091 -- Library-level tagged types
2093 if Nkind
(Decl
) = N_Full_Type_Declaration
then
2094 Typ
:= Defining_Identifier
(Decl
);
2096 -- Ignored Ghost types do not need any cleanup actions because
2097 -- they will not appear in the final tree.
2099 if Is_Ignored_Ghost_Entity
(Typ
) then
2102 elsif Is_Tagged_Type
(Typ
)
2103 and then Is_Library_Level_Entity
(Typ
)
2104 and then Convention
(Typ
) = Convention_Ada
2105 and then Present
(Access_Disp_Table
(Typ
))
2106 and then RTE_Available
(RE_Register_Tag
)
2107 and then not Is_Abstract_Type
(Typ
)
2108 and then not No_Run_Time_Mode
2113 -- Regular object declarations
2115 elsif Nkind
(Decl
) = N_Object_Declaration
then
2116 Obj_Id
:= Defining_Identifier
(Decl
);
2117 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2118 Expr
:= Expression
(Decl
);
2120 -- Bypass any form of processing for objects which have their
2121 -- finalization disabled. This applies only to objects at the
2124 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2127 -- Finalization of transient objects are treated separately in
2128 -- order to handle sensitive cases. These include:
2130 -- * Aggregate expansion
2131 -- * If, case, and expression with actions expansion
2132 -- * Transient scopes
2134 -- If one of those contexts has marked the transient object as
2135 -- ignored, do not generate finalization actions for it.
2137 elsif Is_Finalized_Transient
(Obj_Id
)
2138 or else Is_Ignored_Transient
(Obj_Id
)
2142 -- Ignored Ghost objects do not need any cleanup actions
2143 -- because they will not appear in the final tree.
2145 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2148 -- The object is of the form:
2149 -- Obj : [constant] Typ [:= Expr];
2151 -- Do not process tag-to-class-wide conversions because they do
2152 -- not yield an object. Do not process the incomplete view of a
2153 -- deferred constant. Note that an object initialized by means
2154 -- of a build-in-place function call may appear as a deferred
2155 -- constant after expansion activities. These kinds of objects
2156 -- must be finalized.
2158 elsif not Is_Imported
(Obj_Id
)
2159 and then Needs_Finalization
(Obj_Typ
)
2160 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
2161 and then not (Ekind
(Obj_Id
) = E_Constant
2162 and then not Has_Completion
(Obj_Id
)
2163 and then No
(BIP_Initialization_Call
(Obj_Id
)))
2167 -- The object is of the form:
2168 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
2170 -- Obj : Access_Typ :=
2171 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
2173 elsif Is_Access_Type
(Obj_Typ
)
2174 and then Needs_Finalization
2175 (Available_View
(Designated_Type
(Obj_Typ
)))
2176 and then Present
(Expr
)
2178 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
2180 (Is_Non_BIP_Func_Call
(Expr
)
2181 and then not Is_Related_To_Func_Return
(Obj_Id
)))
2183 Processing_Actions
(Has_No_Init
=> True);
2185 -- Processing for "hook" objects generated for transient
2186 -- objects declared inside an Expression_With_Actions.
2188 elsif Is_Access_Type
(Obj_Typ
)
2189 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2190 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2191 N_Object_Declaration
2193 Processing_Actions
(Has_No_Init
=> True);
2195 -- Process intermediate results of an if expression with one
2196 -- of the alternatives using a controlled function call.
2198 elsif Is_Access_Type
(Obj_Typ
)
2199 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2200 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
2201 N_Defining_Identifier
2202 and then Present
(Expr
)
2203 and then Nkind
(Expr
) = N_Null
2205 Processing_Actions
(Has_No_Init
=> True);
2207 -- Simple protected objects which use type System.Tasking.
2208 -- Protected_Objects.Protection to manage their locks should
2209 -- be treated as controlled since they require manual cleanup.
2210 -- The only exception is illustrated in the following example:
2213 -- type Ctrl is new Controlled ...
2214 -- procedure Finalize (Obj : in out Ctrl);
2218 -- package body Pkg is
2219 -- protected Prot is
2220 -- procedure Do_Something (Obj : in out Ctrl);
2223 -- protected body Prot is
2224 -- procedure Do_Something (Obj : in out Ctrl) is ...
2227 -- procedure Finalize (Obj : in out Ctrl) is
2229 -- Prot.Do_Something (Obj);
2233 -- Since for the most part entities in package bodies depend on
2234 -- those in package specs, Prot's lock should be cleaned up
2235 -- first. The subsequent cleanup of the spec finalizes Lib_Obj.
2236 -- This act however attempts to invoke Do_Something and fails
2237 -- because the lock has disappeared.
2239 elsif Ekind
(Obj_Id
) = E_Variable
2240 and then not In_Library_Level_Package_Body
(Obj_Id
)
2241 and then (Is_Simple_Protected_Type
(Obj_Typ
)
2242 or else Has_Simple_Protected_Object
(Obj_Typ
))
2244 Processing_Actions
(Is_Protected
=> True);
2247 -- Specific cases of object renamings
2249 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
2250 Obj_Id
:= Defining_Identifier
(Decl
);
2251 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2253 -- Bypass any form of processing for objects which have their
2254 -- finalization disabled. This applies only to objects at the
2257 if For_Package
and then Finalize_Storage_Only
(Obj_Typ
) then
2260 -- Ignored Ghost object renamings do not need any cleanup
2261 -- actions because they will not appear in the final tree.
2263 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
2266 -- Return object of a build-in-place function. This case is
2267 -- recognized and marked by the expansion of an extended return
2268 -- statement (see Expand_N_Extended_Return_Statement).
2270 elsif Needs_Finalization
(Obj_Typ
)
2271 and then Is_Return_Object
(Obj_Id
)
2272 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
2274 Processing_Actions
(Has_No_Init
=> True);
2276 -- Detect a case where a source object has been initialized by
2277 -- a controlled function call or another object which was later
2278 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
2280 -- Obj1 : CW_Type := Src_Obj;
2281 -- Obj2 : CW_Type := Function_Call (...);
2283 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
2284 -- Tmp : ... := Function_Call (...)'reference;
2285 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
2287 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
2288 Processing_Actions
(Has_No_Init
=> True);
2291 -- Inspect the freeze node of an access-to-controlled type and
2292 -- look for a delayed finalization master. This case arises when
2293 -- the freeze actions are inserted at a later time than the
2294 -- expansion of the context. Since Build_Finalizer is never called
2295 -- on a single construct twice, the master will be ultimately
2296 -- left out and never finalized. This is also needed for freeze
2297 -- actions of designated types themselves, since in some cases the
2298 -- finalization master is associated with a designated type's
2299 -- freeze node rather than that of the access type (see handling
2300 -- for freeze actions in Build_Finalization_Master).
2302 elsif Nkind
(Decl
) = N_Freeze_Entity
2303 and then Present
(Actions
(Decl
))
2305 Typ
:= Entity
(Decl
);
2307 -- Freeze nodes for ignored Ghost types do not need cleanup
2308 -- actions because they will never appear in the final tree.
2310 if Is_Ignored_Ghost_Entity
(Typ
) then
2313 elsif (Is_Access_Type
(Typ
)
2314 and then not Is_Access_Subprogram_Type
(Typ
)
2315 and then Needs_Finalization
2316 (Available_View
(Designated_Type
(Typ
))))
2317 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
))
2319 Old_Counter_Val
:= Counter_Val
;
2321 -- Freeze nodes are considered to be identical to packages
2322 -- and blocks in terms of nesting. The difference is that
2323 -- a finalization master created inside the freeze node is
2324 -- at the same nesting level as the node itself.
2326 Process_Declarations
(Actions
(Decl
), Preprocess
);
2328 -- The freeze node contains a finalization master
2332 and then No
(Last_Top_Level_Ctrl_Construct
)
2333 and then Counter_Val
> Old_Counter_Val
2335 Last_Top_Level_Ctrl_Construct
:= Decl
;
2339 -- Nested package declarations, avoid generics
2341 elsif Nkind
(Decl
) = N_Package_Declaration
then
2342 Pack_Id
:= Defining_Entity
(Decl
);
2343 Spec
:= Specification
(Decl
);
2345 -- Do not inspect an ignored Ghost package because all code
2346 -- found within will not appear in the final tree.
2348 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
2351 elsif Ekind
(Pack_Id
) /= E_Generic_Package
then
2352 Old_Counter_Val
:= Counter_Val
;
2353 Process_Declarations
2354 (Private_Declarations
(Spec
), Preprocess
);
2355 Process_Declarations
2356 (Visible_Declarations
(Spec
), Preprocess
);
2358 -- Either the visible or the private declarations contain a
2359 -- controlled object. The nested package declaration is the
2360 -- last such construct.
2364 and then No
(Last_Top_Level_Ctrl_Construct
)
2365 and then Counter_Val
> Old_Counter_Val
2367 Last_Top_Level_Ctrl_Construct
:= Decl
;
2371 -- Nested package bodies, avoid generics
2373 elsif Nkind
(Decl
) = N_Package_Body
then
2375 -- Do not inspect an ignored Ghost package body because all
2376 -- code found within will not appear in the final tree.
2378 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
2381 elsif Ekind
(Corresponding_Spec
(Decl
)) /=
2384 Old_Counter_Val
:= Counter_Val
;
2385 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2387 -- The nested package body is the last construct to contain
2388 -- a controlled object.
2392 and then No
(Last_Top_Level_Ctrl_Construct
)
2393 and then Counter_Val
> Old_Counter_Val
2395 Last_Top_Level_Ctrl_Construct
:= Decl
;
2399 -- Handle a rare case caused by a controlled transient object
2400 -- created as part of a record init proc. The variable is wrapped
2401 -- in a block, but the block is not associated with a transient
2404 elsif Nkind
(Decl
) = N_Block_Statement
2405 and then Inside_Init_Proc
2407 Old_Counter_Val
:= Counter_Val
;
2409 if Present
(Handled_Statement_Sequence
(Decl
)) then
2410 Process_Declarations
2411 (Statements
(Handled_Statement_Sequence
(Decl
)),
2415 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2417 -- Either the declaration or statement list of the block has a
2418 -- controlled object.
2422 and then No
(Last_Top_Level_Ctrl_Construct
)
2423 and then Counter_Val
> Old_Counter_Val
2425 Last_Top_Level_Ctrl_Construct
:= Decl
;
2428 -- Handle the case where the original context has been wrapped in
2429 -- a block to avoid interference between exception handlers and
2430 -- At_End handlers. Treat the block as transparent and process its
2433 elsif Nkind
(Decl
) = N_Block_Statement
2434 and then Is_Finalization_Wrapper
(Decl
)
2436 if Present
(Handled_Statement_Sequence
(Decl
)) then
2437 Process_Declarations
2438 (Statements
(Handled_Statement_Sequence
(Decl
)),
2442 Process_Declarations
(Declarations
(Decl
), Preprocess
);
2445 Prev_Non_Pragma
(Decl
);
2447 end Process_Declarations
;
2449 --------------------------------
2450 -- Process_Object_Declaration --
2451 --------------------------------
2453 procedure Process_Object_Declaration
2455 Has_No_Init
: Boolean := False;
2456 Is_Protected
: Boolean := False)
2458 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
2459 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
2461 Init_Typ
: Entity_Id
;
2462 -- The initialization type of the related object declaration. Note
2463 -- that this is not necessarily the same type as Obj_Typ because of
2464 -- possible type derivations.
2466 Obj_Typ
: Entity_Id
;
2467 -- The type of the related object declaration
2469 function Build_BIP_Cleanup_Stmts
(Func_Id
: Entity_Id
) return Node_Id
;
2470 -- Func_Id denotes a build-in-place function. Generate the following
2473 -- if BIPallocfrom > Secondary_Stack'Pos
2474 -- and then BIPfinalizationmaster /= null
2477 -- type Ptr_Typ is access Obj_Typ;
2478 -- for Ptr_Typ'Storage_Pool
2479 -- use Base_Pool (BIPfinalizationmaster);
2481 -- Free (Ptr_Typ (Temp));
2485 -- Obj_Typ is the type of the current object, Temp is the original
2486 -- allocation which Obj_Id renames.
2488 procedure Find_Last_Init
2489 (Last_Init
: out Node_Id
;
2490 Body_Insert
: out Node_Id
);
2491 -- Find the last initialization call related to object declaration
2492 -- Decl. Last_Init denotes the last initialization call which follows
2493 -- Decl. Body_Insert denotes a node where the finalizer body could be
2494 -- potentially inserted after (if blocks are involved).
2496 -----------------------------
2497 -- Build_BIP_Cleanup_Stmts --
2498 -----------------------------
2500 function Build_BIP_Cleanup_Stmts
2501 (Func_Id
: Entity_Id
) return Node_Id
2503 Decls
: constant List_Id
:= New_List
;
2504 Fin_Mas_Id
: constant Entity_Id
:=
2505 Build_In_Place_Formal
2506 (Func_Id
, BIP_Finalization_Master
);
2507 Func_Typ
: constant Entity_Id
:= Etype
(Func_Id
);
2508 Temp_Id
: constant Entity_Id
:=
2509 Entity
(Prefix
(Name
(Parent
(Obj_Id
))));
2513 Free_Stmt
: Node_Id
;
2514 Pool_Id
: Entity_Id
;
2515 Ptr_Typ
: Entity_Id
;
2519 -- Pool_Id renames Base_Pool (BIPfinalizationmaster.all).all;
2521 Pool_Id
:= Make_Temporary
(Loc
, 'P');
2524 Make_Object_Renaming_Declaration
(Loc
,
2525 Defining_Identifier
=> Pool_Id
,
2527 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
),
2529 Make_Explicit_Dereference
(Loc
,
2531 Make_Function_Call
(Loc
,
2533 New_Occurrence_Of
(RTE
(RE_Base_Pool
), Loc
),
2534 Parameter_Associations
=> New_List
(
2535 Make_Explicit_Dereference
(Loc
,
2537 New_Occurrence_Of
(Fin_Mas_Id
, Loc
)))))));
2539 -- Create an access type which uses the storage pool of the
2540 -- caller's finalization master.
2543 -- type Ptr_Typ is access Func_Typ;
2545 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
2548 Make_Full_Type_Declaration
(Loc
,
2549 Defining_Identifier
=> Ptr_Typ
,
2551 Make_Access_To_Object_Definition
(Loc
,
2552 Subtype_Indication
=> New_Occurrence_Of
(Func_Typ
, Loc
))));
2554 -- Perform minor decoration in order to set the master and the
2555 -- storage pool attributes.
2557 Set_Ekind
(Ptr_Typ
, E_Access_Type
);
2558 Set_Finalization_Master
(Ptr_Typ
, Fin_Mas_Id
);
2559 Set_Associated_Storage_Pool
(Ptr_Typ
, Pool_Id
);
2561 -- Create an explicit free statement. Note that the free uses the
2562 -- caller's pool expressed as a renaming.
2565 Make_Free_Statement
(Loc
,
2567 Unchecked_Convert_To
(Ptr_Typ
,
2568 New_Occurrence_Of
(Temp_Id
, Loc
)));
2570 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
2572 -- Create a block to house the dummy type and the instantiation as
2573 -- well as to perform the cleanup the temporary.
2579 -- Free (Ptr_Typ (Temp_Id));
2583 Make_Block_Statement
(Loc
,
2584 Declarations
=> Decls
,
2585 Handled_Statement_Sequence
=>
2586 Make_Handled_Sequence_Of_Statements
(Loc
,
2587 Statements
=> New_List
(Free_Stmt
)));
2590 -- if BIPfinalizationmaster /= null then
2594 Left_Opnd
=> New_Occurrence_Of
(Fin_Mas_Id
, Loc
),
2595 Right_Opnd
=> Make_Null
(Loc
));
2597 -- For constrained or tagged results escalate the condition to
2598 -- include the allocation format. Generate:
2600 -- if BIPallocform > Secondary_Stack'Pos
2601 -- and then BIPfinalizationmaster /= null
2604 if not Is_Constrained
(Func_Typ
)
2605 or else Is_Tagged_Type
(Func_Typ
)
2608 Alloc
: constant Entity_Id
:=
2609 Build_In_Place_Formal
(Func_Id
, BIP_Alloc_Form
);
2615 Left_Opnd
=> New_Occurrence_Of
(Alloc
, Loc
),
2617 Make_Integer_Literal
(Loc
,
2619 (BIP_Allocation_Form
'Pos (Secondary_Stack
)))),
2621 Right_Opnd
=> Cond
);
2631 Make_If_Statement
(Loc
,
2633 Then_Statements
=> New_List
(Free_Blk
));
2634 end Build_BIP_Cleanup_Stmts
;
2636 --------------------
2637 -- Find_Last_Init --
2638 --------------------
2640 procedure Find_Last_Init
2641 (Last_Init
: out Node_Id
;
2642 Body_Insert
: out Node_Id
)
2644 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
;
2645 -- Find the last initialization call within the statements of
2648 function Is_Init_Call
(N
: Node_Id
) return Boolean;
2649 -- Determine whether node N denotes one of the initialization
2650 -- procedures of types Init_Typ or Obj_Typ.
2652 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
;
2653 -- Obtain the next statement which follows list member Stmt while
2654 -- ignoring artifacts related to access-before-elaboration checks.
2656 -----------------------------
2657 -- Find_Last_Init_In_Block --
2658 -----------------------------
2660 function Find_Last_Init_In_Block
(Blk
: Node_Id
) return Node_Id
is
2661 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2665 -- Examine the individual statements of the block in reverse to
2666 -- locate the last initialization call.
2668 if Present
(HSS
) and then Present
(Statements
(HSS
)) then
2669 Stmt
:= Last
(Statements
(HSS
));
2670 while Present
(Stmt
) loop
2672 -- Peek inside nested blocks in case aborts are allowed
2674 if Nkind
(Stmt
) = N_Block_Statement
then
2675 return Find_Last_Init_In_Block
(Stmt
);
2677 elsif Is_Init_Call
(Stmt
) then
2686 end Find_Last_Init_In_Block
;
2692 function Is_Init_Call
(N
: Node_Id
) return Boolean is
2693 function Is_Init_Proc_Of
2694 (Subp_Id
: Entity_Id
;
2695 Typ
: Entity_Id
) return Boolean;
2696 -- Determine whether subprogram Subp_Id is a valid init proc of
2699 ---------------------
2700 -- Is_Init_Proc_Of --
2701 ---------------------
2703 function Is_Init_Proc_Of
2704 (Subp_Id
: Entity_Id
;
2705 Typ
: Entity_Id
) return Boolean
2707 Deep_Init
: Entity_Id
:= Empty
;
2708 Prim_Init
: Entity_Id
:= Empty
;
2709 Type_Init
: Entity_Id
:= Empty
;
2712 -- Obtain all possible initialization routines of the
2713 -- related type and try to match the subprogram entity
2714 -- against one of them.
2718 Deep_Init
:= TSS
(Typ
, TSS_Deep_Initialize
);
2720 -- Primitive Initialize
2722 if Is_Controlled
(Typ
) then
2723 Prim_Init
:= Find_Optional_Prim_Op
(Typ
, Name_Initialize
);
2725 if Present
(Prim_Init
) then
2726 Prim_Init
:= Ultimate_Alias
(Prim_Init
);
2730 -- Type initialization routine
2732 if Has_Non_Null_Base_Init_Proc
(Typ
) then
2733 Type_Init
:= Base_Init_Proc
(Typ
);
2737 (Present
(Deep_Init
) and then Subp_Id
= Deep_Init
)
2739 (Present
(Prim_Init
) and then Subp_Id
= Prim_Init
)
2741 (Present
(Type_Init
) and then Subp_Id
= Type_Init
);
2742 end Is_Init_Proc_Of
;
2746 Call_Id
: Entity_Id
;
2748 -- Start of processing for Is_Init_Call
2751 if Nkind
(N
) = N_Procedure_Call_Statement
2752 and then Nkind
(Name
(N
)) = N_Identifier
2754 Call_Id
:= Entity
(Name
(N
));
2756 -- Consider both the type of the object declaration and its
2757 -- related initialization type.
2760 Is_Init_Proc_Of
(Call_Id
, Init_Typ
)
2762 Is_Init_Proc_Of
(Call_Id
, Obj_Typ
);
2768 -----------------------------
2769 -- Next_Suitable_Statement --
2770 -----------------------------
2772 function Next_Suitable_Statement
(Stmt
: Node_Id
) return Node_Id
is
2776 -- Skip call markers and Program_Error raises installed by the
2779 Result
:= Next
(Stmt
);
2780 while Present
(Result
) loop
2781 if not Nkind_In
(Result
, N_Call_Marker
,
2782 N_Raise_Program_Error
)
2787 Result
:= Next
(Result
);
2791 end Next_Suitable_Statement
;
2799 Deep_Init_Found
: Boolean := False;
2800 -- A flag set when a call to [Deep_]Initialize has been found
2802 -- Start of processing for Find_Last_Init
2806 Body_Insert
:= Empty
;
2808 -- Object renamings and objects associated with controlled
2809 -- function results do not require initialization.
2815 Stmt
:= Next_Suitable_Statement
(Decl
);
2817 -- For an object with suppressed initialization, we check whether
2818 -- there is in fact no initialization expression. If there is not,
2819 -- then this is an object declaration that has been turned into a
2820 -- different object declaration that calls the build-in-place
2821 -- function in a 'Reference attribute, as in "F(...)'Reference".
2822 -- We search for that later object declaration, so that the
2823 -- Inc_Decl will be inserted after the call. Otherwise, if the
2824 -- call raises an exception, we will finalize the (uninitialized)
2825 -- object, which is wrong.
2827 if No_Initialization
(Decl
) then
2828 if No
(Expression
(Last_Init
)) then
2830 Last_Init
:= Next
(Last_Init
);
2831 exit when No
(Last_Init
);
2832 exit when Nkind
(Last_Init
) = N_Object_Declaration
2833 and then Nkind
(Expression
(Last_Init
)) = N_Reference
2834 and then Nkind
(Prefix
(Expression
(Last_Init
))) =
2836 and then Is_Expanded_Build_In_Place_Call
2837 (Prefix
(Expression
(Last_Init
)));
2843 -- In all other cases the initialization calls follow the related
2844 -- object. The general structure of object initialization built by
2845 -- routine Default_Initialize_Object is as follows:
2847 -- [begin -- aborts allowed
2849 -- Type_Init_Proc (Obj);
2850 -- [begin] -- exceptions allowed
2851 -- Deep_Initialize (Obj);
2852 -- [exception -- exceptions allowed
2854 -- Deep_Finalize (Obj, Self => False);
2857 -- [at end -- aborts allowed
2861 -- When aborts are allowed, the initialization calls are housed
2864 elsif Nkind
(Stmt
) = N_Block_Statement
then
2865 Last_Init
:= Find_Last_Init_In_Block
(Stmt
);
2866 Body_Insert
:= Stmt
;
2868 -- Otherwise the initialization calls follow the related object
2871 Stmt_2
:= Next_Suitable_Statement
(Stmt
);
2873 -- Check for an optional call to Deep_Initialize which may
2874 -- appear within a block depending on whether the object has
2875 -- controlled components.
2877 if Present
(Stmt_2
) then
2878 if Nkind
(Stmt_2
) = N_Block_Statement
then
2879 Call
:= Find_Last_Init_In_Block
(Stmt_2
);
2881 if Present
(Call
) then
2882 Deep_Init_Found
:= True;
2884 Body_Insert
:= Stmt_2
;
2887 elsif Is_Init_Call
(Stmt_2
) then
2888 Deep_Init_Found
:= True;
2889 Last_Init
:= Stmt_2
;
2890 Body_Insert
:= Last_Init
;
2894 -- If the object lacks a call to Deep_Initialize, then it must
2895 -- have a call to its related type init proc.
2897 if not Deep_Init_Found
and then Is_Init_Call
(Stmt
) then
2899 Body_Insert
:= Last_Init
;
2907 Count_Ins
: Node_Id
;
2909 Fin_Stmts
: List_Id
:= No_List
;
2912 Label_Id
: Entity_Id
;
2915 -- Start of processing for Process_Object_Declaration
2918 -- Handle the object type and the reference to the object
2920 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
2921 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
2924 if Is_Access_Type
(Obj_Typ
) then
2925 Obj_Typ
:= Directly_Designated_Type
(Obj_Typ
);
2926 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2928 elsif Is_Concurrent_Type
(Obj_Typ
)
2929 and then Present
(Corresponding_Record_Type
(Obj_Typ
))
2931 Obj_Typ
:= Corresponding_Record_Type
(Obj_Typ
);
2932 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2934 elsif Is_Private_Type
(Obj_Typ
)
2935 and then Present
(Full_View
(Obj_Typ
))
2937 Obj_Typ
:= Full_View
(Obj_Typ
);
2938 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2940 elsif Obj_Typ
/= Base_Type
(Obj_Typ
) then
2941 Obj_Typ
:= Base_Type
(Obj_Typ
);
2942 Obj_Ref
:= Unchecked_Convert_To
(Obj_Typ
, Obj_Ref
);
2949 Set_Etype
(Obj_Ref
, Obj_Typ
);
2951 -- Handle the initialization type of the object declaration
2953 Init_Typ
:= Obj_Typ
;
2955 if Is_Private_Type
(Init_Typ
)
2956 and then Present
(Full_View
(Init_Typ
))
2958 Init_Typ
:= Full_View
(Init_Typ
);
2960 elsif Is_Untagged_Derivation
(Init_Typ
) then
2961 Init_Typ
:= Root_Type
(Init_Typ
);
2968 -- Set a new value for the state counter and insert the statement
2969 -- after the object declaration. Generate:
2971 -- Counter := <value>;
2974 Make_Assignment_Statement
(Loc
,
2975 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
2976 Expression
=> Make_Integer_Literal
(Loc
, Counter_Val
));
2978 -- Insert the counter after all initialization has been done. The
2979 -- place of insertion depends on the context.
2981 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
) then
2983 -- The object is initialized by a build-in-place function call.
2984 -- The counter insertion point is after the function call.
2986 if Present
(BIP_Initialization_Call
(Obj_Id
)) then
2987 Count_Ins
:= BIP_Initialization_Call
(Obj_Id
);
2990 -- The object is initialized by an aggregate. Insert the counter
2991 -- after the last aggregate assignment.
2993 elsif Present
(Last_Aggregate_Assignment
(Obj_Id
)) then
2994 Count_Ins
:= Last_Aggregate_Assignment
(Obj_Id
);
2997 -- In all other cases the counter is inserted after the last call
2998 -- to either [Deep_]Initialize or the type-specific init proc.
3001 Find_Last_Init
(Count_Ins
, Body_Ins
);
3004 -- In all other cases the counter is inserted after the last call to
3005 -- either [Deep_]Initialize or the type-specific init proc.
3008 Find_Last_Init
(Count_Ins
, Body_Ins
);
3011 -- If the Initialize function is null or trivial, the call will have
3012 -- been replaced with a null statement, in which case place counter
3013 -- declaration after object declaration itself.
3015 if No
(Count_Ins
) then
3019 Insert_After
(Count_Ins
, Inc_Decl
);
3022 -- If the current declaration is the last in the list, the finalizer
3023 -- body needs to be inserted after the set counter statement for the
3024 -- current object declaration. This is complicated by the fact that
3025 -- the set counter statement may appear in abort deferred block. In
3026 -- that case, the proper insertion place is after the block.
3028 if No
(Finalizer_Insert_Nod
) then
3030 -- Insertion after an abort deferred block
3032 if Present
(Body_Ins
) then
3033 Finalizer_Insert_Nod
:= Body_Ins
;
3035 Finalizer_Insert_Nod
:= Inc_Decl
;
3039 -- Create the associated label with this object, generate:
3041 -- L<counter> : label;
3044 Make_Identifier
(Loc
, New_External_Name
('L', Counter_Val
));
3046 (Label_Id
, Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
3047 Label
:= Make_Label
(Loc
, Label_Id
);
3049 Prepend_To
(Finalizer_Decls
,
3050 Make_Implicit_Label_Declaration
(Loc
,
3051 Defining_Identifier
=> Entity
(Label_Id
),
3052 Label_Construct
=> Label
));
3054 -- Create the associated jump with this object, generate:
3056 -- when <counter> =>
3059 Prepend_To
(Jump_Alts
,
3060 Make_Case_Statement_Alternative
(Loc
,
3061 Discrete_Choices
=> New_List
(
3062 Make_Integer_Literal
(Loc
, Counter_Val
)),
3063 Statements
=> New_List
(
3064 Make_Goto_Statement
(Loc
,
3065 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
3067 -- Insert the jump destination, generate:
3071 Append_To
(Finalizer_Stmts
, Label
);
3073 -- Processing for simple protected objects. Such objects require
3074 -- manual finalization of their lock managers.
3076 if Is_Protected
then
3077 if Is_Simple_Protected_Type
(Obj_Typ
) then
3078 Fin_Call
:= Cleanup_Protected_Object
(Decl
, Obj_Ref
);
3080 if Present
(Fin_Call
) then
3081 Fin_Stmts
:= New_List
(Fin_Call
);
3084 elsif Has_Simple_Protected_Object
(Obj_Typ
) then
3085 if Is_Record_Type
(Obj_Typ
) then
3086 Fin_Stmts
:= Cleanup_Record
(Decl
, Obj_Ref
, Obj_Typ
);
3087 elsif Is_Array_Type
(Obj_Typ
) then
3088 Fin_Stmts
:= Cleanup_Array
(Decl
, Obj_Ref
, Obj_Typ
);
3094 -- System.Tasking.Protected_Objects.Finalize_Protection
3102 if Present
(Fin_Stmts
) and then Exceptions_OK
then
3103 Fin_Stmts
:= New_List
(
3104 Make_Block_Statement
(Loc
,
3105 Handled_Statement_Sequence
=>
3106 Make_Handled_Sequence_Of_Statements
(Loc
,
3107 Statements
=> Fin_Stmts
,
3109 Exception_Handlers
=> New_List
(
3110 Make_Exception_Handler
(Loc
,
3111 Exception_Choices
=> New_List
(
3112 Make_Others_Choice
(Loc
)),
3114 Statements
=> New_List
(
3115 Make_Null_Statement
(Loc
)))))));
3118 -- Processing for regular controlled objects
3123 -- [Deep_]Finalize (Obj);
3126 -- when Id : others =>
3127 -- if not Raised then
3129 -- Save_Occurrence (E, Id);
3138 -- Guard against a missing [Deep_]Finalize when the object type
3139 -- was not properly frozen.
3141 if No
(Fin_Call
) then
3142 Fin_Call
:= Make_Null_Statement
(Loc
);
3145 -- For CodePeer, the exception handlers normally generated here
3146 -- generate complex flowgraphs which result in capacity problems.
3147 -- Omitting these handlers for CodePeer is justified as follows:
3149 -- If a handler is dead, then omitting it is surely ok
3151 -- If a handler is live, then CodePeer should flag the
3152 -- potentially-exception-raising construct that causes it
3153 -- to be live. That is what we are interested in, not what
3154 -- happens after the exception is raised.
3156 if Exceptions_OK
and not CodePeer_Mode
then
3157 Fin_Stmts
:= New_List
(
3158 Make_Block_Statement
(Loc
,
3159 Handled_Statement_Sequence
=>
3160 Make_Handled_Sequence_Of_Statements
(Loc
,
3161 Statements
=> New_List
(Fin_Call
),
3163 Exception_Handlers
=> New_List
(
3164 Build_Exception_Handler
3165 (Finalizer_Data
, For_Package
)))));
3167 -- When exception handlers are prohibited, the finalization call
3168 -- appears unprotected. Any exception raised during finalization
3169 -- will bypass the circuitry which ensures the cleanup of all
3170 -- remaining objects.
3173 Fin_Stmts
:= New_List
(Fin_Call
);
3176 -- If we are dealing with a return object of a build-in-place
3177 -- function, generate the following cleanup statements:
3179 -- if BIPallocfrom > Secondary_Stack'Pos
3180 -- and then BIPfinalizationmaster /= null
3183 -- type Ptr_Typ is access Obj_Typ;
3184 -- for Ptr_Typ'Storage_Pool use
3185 -- Base_Pool (BIPfinalizationmaster.all).all;
3187 -- Free (Ptr_Typ (Temp));
3191 -- The generated code effectively detaches the temporary from the
3192 -- caller finalization master and deallocates the object.
3194 if Is_Return_Object
(Obj_Id
) then
3196 Func_Id
: constant Entity_Id
:= Enclosing_Function
(Obj_Id
);
3198 if Is_Build_In_Place_Function
(Func_Id
)
3199 and then Needs_BIP_Finalization_Master
(Func_Id
)
3201 Append_To
(Fin_Stmts
, Build_BIP_Cleanup_Stmts
(Func_Id
));
3206 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
3207 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
3209 -- Temporaries created for the purpose of "exporting" a
3210 -- transient object out of an Expression_With_Actions (EWA)
3211 -- need guards. The following illustrates the usage of such
3214 -- Access_Typ : access [all] Obj_Typ;
3215 -- Temp : Access_Typ := null;
3216 -- <Counter> := ...;
3219 -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
3220 -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
3222 -- Temp := Ctrl_Trans'Unchecked_Access;
3225 -- The finalization machinery does not process EWA nodes as
3226 -- this may lead to premature finalization of expressions. Note
3227 -- that Temp is marked as being properly initialized regardless
3228 -- of whether the initialization of Ctrl_Trans succeeded. Since
3229 -- a failed initialization may leave Temp with a value of null,
3230 -- add a guard to handle this case:
3232 -- if Obj /= null then
3233 -- <object finalization statements>
3236 if Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
3237 N_Object_Declaration
3239 Fin_Stmts
:= New_List
(
3240 Make_If_Statement
(Loc
,
3243 Left_Opnd
=> New_Occurrence_Of
(Obj_Id
, Loc
),
3244 Right_Opnd
=> Make_Null
(Loc
)),
3245 Then_Statements
=> Fin_Stmts
));
3247 -- Return objects use a flag to aid in processing their
3248 -- potential finalization when the enclosing function fails
3249 -- to return properly. Generate:
3252 -- <object finalization statements>
3256 Fin_Stmts
:= New_List
(
3257 Make_If_Statement
(Loc
,
3262 (Status_Flag_Or_Transient_Decl
(Obj_Id
), Loc
)),
3264 Then_Statements
=> Fin_Stmts
));
3269 Append_List_To
(Finalizer_Stmts
, Fin_Stmts
);
3271 -- Since the declarations are examined in reverse, the state counter
3272 -- must be decremented in order to keep with the true position of
3275 Counter_Val
:= Counter_Val
- 1;
3276 end Process_Object_Declaration
;
3278 -------------------------------------
3279 -- Process_Tagged_Type_Declaration --
3280 -------------------------------------
3282 procedure Process_Tagged_Type_Declaration
(Decl
: Node_Id
) is
3283 Typ
: constant Entity_Id
:= Defining_Identifier
(Decl
);
3284 DT_Ptr
: constant Entity_Id
:=
3285 Node
(First_Elmt
(Access_Disp_Table
(Typ
)));
3288 -- Ada.Tags.Unregister_Tag (<Typ>P);
3290 Append_To
(Tagged_Type_Stmts
,
3291 Make_Procedure_Call_Statement
(Loc
,
3293 New_Occurrence_Of
(RTE
(RE_Unregister_Tag
), Loc
),
3294 Parameter_Associations
=> New_List
(
3295 New_Occurrence_Of
(DT_Ptr
, Loc
))));
3296 end Process_Tagged_Type_Declaration
;
3298 -- Start of processing for Build_Finalizer
3303 -- Do not perform this expansion in SPARK mode because it is not
3306 if GNATprove_Mode
then
3310 -- Step 1: Extract all lists which may contain controlled objects or
3311 -- library-level tagged types.
3313 if For_Package_Spec
then
3314 Decls
:= Visible_Declarations
(Specification
(N
));
3315 Priv_Decls
:= Private_Declarations
(Specification
(N
));
3317 -- Retrieve the package spec id
3319 Spec_Id
:= Defining_Unit_Name
(Specification
(N
));
3321 if Nkind
(Spec_Id
) = N_Defining_Program_Unit_Name
then
3322 Spec_Id
:= Defining_Identifier
(Spec_Id
);
3325 -- Accept statement, block, entry body, package body, protected body,
3326 -- subprogram body or task body.
3329 Decls
:= Declarations
(N
);
3330 HSS
:= Handled_Statement_Sequence
(N
);
3332 if Present
(HSS
) then
3333 if Present
(Statements
(HSS
)) then
3334 Stmts
:= Statements
(HSS
);
3337 if Present
(At_End_Proc
(HSS
)) then
3338 Prev_At_End
:= At_End_Proc
(HSS
);
3342 -- Retrieve the package spec id for package bodies
3344 if For_Package_Body
then
3345 Spec_Id
:= Corresponding_Spec
(N
);
3349 -- Do not process nested packages since those are handled by the
3350 -- enclosing scope's finalizer. Do not process non-expanded package
3351 -- instantiations since those will be re-analyzed and re-expanded.
3355 (not Is_Library_Level_Entity
(Spec_Id
)
3357 -- Nested packages are considered to be library level entities,
3358 -- but do not need to be processed separately. True library level
3359 -- packages have a scope value of 1.
3361 or else Scope_Depth_Value
(Spec_Id
) /= Uint_1
3362 or else (Is_Generic_Instance
(Spec_Id
)
3363 and then Package_Instantiation
(Spec_Id
) /= N
))
3368 -- Step 2: Object [pre]processing
3372 -- Preprocess the visible declarations now in order to obtain the
3373 -- correct number of controlled object by the time the private
3374 -- declarations are processed.
3376 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3378 -- From all the possible contexts, only package specifications may
3379 -- have private declarations.
3381 if For_Package_Spec
then
3382 Process_Declarations
3383 (Priv_Decls
, Preprocess
=> True, Top_Level
=> True);
3386 -- The current context may lack controlled objects, but require some
3387 -- other form of completion (task termination for instance). In such
3388 -- cases, the finalizer must be created and carry the additional
3391 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3395 -- The preprocessing has determined that the context has controlled
3396 -- objects or library-level tagged types.
3398 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3400 -- Private declarations are processed first in order to preserve
3401 -- possible dependencies between public and private objects.
3403 if For_Package_Spec
then
3404 Process_Declarations
(Priv_Decls
);
3407 Process_Declarations
(Decls
);
3413 -- Preprocess both declarations and statements
3415 Process_Declarations
(Decls
, Preprocess
=> True, Top_Level
=> True);
3416 Process_Declarations
(Stmts
, Preprocess
=> True, Top_Level
=> True);
3418 -- At this point it is known that N has controlled objects. Ensure
3419 -- that N has a declarative list since the finalizer spec will be
3422 if Has_Ctrl_Objs
and then No
(Decls
) then
3423 Set_Declarations
(N
, New_List
);
3424 Decls
:= Declarations
(N
);
3425 Spec_Decls
:= Decls
;
3428 -- The current context may lack controlled objects, but require some
3429 -- other form of completion (task termination for instance). In such
3430 -- cases, the finalizer must be created and carry the additional
3433 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3437 if Has_Ctrl_Objs
or Has_Tagged_Types
then
3438 Process_Declarations
(Stmts
);
3439 Process_Declarations
(Decls
);
3443 -- Step 3: Finalizer creation
3445 if Acts_As_Clean
or Has_Ctrl_Objs
or Has_Tagged_Types
then
3448 end Build_Finalizer
;
3450 --------------------------
3451 -- Build_Finalizer_Call --
3452 --------------------------
3454 procedure Build_Finalizer_Call
(N
: Node_Id
; Fin_Id
: Entity_Id
) is
3455 Is_Prot_Body
: constant Boolean :=
3456 Nkind
(N
) = N_Subprogram_Body
3457 and then Is_Protected_Subprogram_Body
(N
);
3458 -- Determine whether N denotes the protected version of a subprogram
3459 -- which belongs to a protected type.
3461 Loc
: constant Source_Ptr
:= Sloc
(N
);
3465 -- Do not perform this expansion in SPARK mode because we do not create
3466 -- finalizers in the first place.
3468 if GNATprove_Mode
then
3472 -- The At_End handler should have been assimilated by the finalizer
3474 HSS
:= Handled_Statement_Sequence
(N
);
3475 pragma Assert
(No
(At_End_Proc
(HSS
)));
3477 -- If the construct to be cleaned up is a protected subprogram body, the
3478 -- finalizer call needs to be associated with the block which wraps the
3479 -- unprotected version of the subprogram. The following illustrates this
3482 -- procedure Prot_SubpP is
3483 -- procedure finalizer is
3485 -- Service_Entries (Prot_Obj);
3492 -- Prot_SubpN (Prot_Obj);
3498 if Is_Prot_Body
then
3499 HSS
:= Handled_Statement_Sequence
(Last
(Statements
(HSS
)));
3501 -- An At_End handler and regular exception handlers cannot coexist in
3502 -- the same statement sequence. Wrap the original statements in a block.
3504 elsif Present
(Exception_Handlers
(HSS
)) then
3506 End_Lab
: constant Node_Id
:= End_Label
(HSS
);
3511 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
3513 Set_Handled_Statement_Sequence
(N
,
3514 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
3516 HSS
:= Handled_Statement_Sequence
(N
);
3517 Set_End_Label
(HSS
, End_Lab
);
3521 Set_At_End_Proc
(HSS
, New_Occurrence_Of
(Fin_Id
, Loc
));
3523 Analyze
(At_End_Proc
(HSS
));
3524 Expand_At_End_Handler
(HSS
, Empty
);
3525 end Build_Finalizer_Call
;
3527 ---------------------
3528 -- Build_Late_Proc --
3529 ---------------------
3531 procedure Build_Late_Proc
(Typ
: Entity_Id
; Nam
: Name_Id
) is
3533 for Final_Prim
in Name_Of
'Range loop
3534 if Name_Of
(Final_Prim
) = Nam
then
3537 (Prim
=> Final_Prim
,
3539 Stmts
=> Make_Deep_Record_Body
(Final_Prim
, Typ
)));
3542 end Build_Late_Proc
;
3544 -------------------------------
3545 -- Build_Object_Declarations --
3546 -------------------------------
3548 procedure Build_Object_Declarations
3549 (Data
: out Finalization_Exception_Data
;
3552 For_Package
: Boolean := False)
3557 -- This variable captures an unused dummy internal entity, see the
3558 -- comment associated with its use.
3561 pragma Assert
(Decls
/= No_List
);
3563 -- Always set the proper location as it may be needed even when
3564 -- exception propagation is forbidden.
3568 if Restriction_Active
(No_Exception_Propagation
) then
3569 Data
.Abort_Id
:= Empty
;
3571 Data
.Raised_Id
:= Empty
;
3575 Data
.Raised_Id
:= Make_Temporary
(Loc
, 'R');
3577 -- In certain scenarios, finalization can be triggered by an abort. If
3578 -- the finalization itself fails and raises an exception, the resulting
3579 -- Program_Error must be supressed and replaced by an abort signal. In
3580 -- order to detect this scenario, save the state of entry into the
3581 -- finalization code.
3583 -- This is not needed for library-level finalizers as they are called by
3584 -- the environment task and cannot be aborted.
3586 if not For_Package
then
3587 if Abort_Allowed
then
3588 Data
.Abort_Id
:= Make_Temporary
(Loc
, 'A');
3591 -- Abort_Id : constant Boolean := <A_Expr>;
3594 Make_Object_Declaration
(Loc
,
3595 Defining_Identifier
=> Data
.Abort_Id
,
3596 Constant_Present
=> True,
3597 Object_Definition
=>
3598 New_Occurrence_Of
(Standard_Boolean
, Loc
),
3600 New_Occurrence_Of
(RTE
(RE_Triggered_By_Abort
), Loc
)));
3602 -- Abort is not required
3605 -- Generate a dummy entity to ensure that the internal symbols are
3606 -- in sync when a unit is compiled with and without aborts.
3608 Dummy
:= Make_Temporary
(Loc
, 'A');
3609 Data
.Abort_Id
:= Empty
;
3612 -- Library-level finalizers
3615 Data
.Abort_Id
:= Empty
;
3618 if Exception_Extra_Info
then
3619 Data
.E_Id
:= Make_Temporary
(Loc
, 'E');
3622 -- E_Id : Exception_Occurrence;
3625 Make_Object_Declaration
(Loc
,
3626 Defining_Identifier
=> Data
.E_Id
,
3627 Object_Definition
=>
3628 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
));
3629 Set_No_Initialization
(Decl
);
3631 Append_To
(Decls
, Decl
);
3638 -- Raised_Id : Boolean := False;
3641 Make_Object_Declaration
(Loc
,
3642 Defining_Identifier
=> Data
.Raised_Id
,
3643 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3644 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
3645 end Build_Object_Declarations
;
3647 ---------------------------
3648 -- Build_Raise_Statement --
3649 ---------------------------
3651 function Build_Raise_Statement
3652 (Data
: Finalization_Exception_Data
) return Node_Id
3658 -- Standard run-time use the specialized routine
3659 -- Raise_From_Controlled_Operation.
3661 if Exception_Extra_Info
3662 and then RTE_Available
(RE_Raise_From_Controlled_Operation
)
3665 Make_Procedure_Call_Statement
(Data
.Loc
,
3668 (RTE
(RE_Raise_From_Controlled_Operation
), Data
.Loc
),
3669 Parameter_Associations
=>
3670 New_List
(New_Occurrence_Of
(Data
.E_Id
, Data
.Loc
)));
3672 -- Restricted run-time: exception messages are not supported and hence
3673 -- Raise_From_Controlled_Operation is not supported. Raise Program_Error
3678 Make_Raise_Program_Error
(Data
.Loc
,
3679 Reason
=> PE_Finalize_Raised_Exception
);
3684 -- Raised_Id and then not Abort_Id
3688 Expr
:= New_Occurrence_Of
(Data
.Raised_Id
, Data
.Loc
);
3690 if Present
(Data
.Abort_Id
) then
3691 Expr
:= Make_And_Then
(Data
.Loc
,
3694 Make_Op_Not
(Data
.Loc
,
3695 Right_Opnd
=> New_Occurrence_Of
(Data
.Abort_Id
, Data
.Loc
)));
3700 -- if Raised_Id and then not Abort_Id then
3701 -- Raise_From_Controlled_Operation (E_Id);
3703 -- raise Program_Error; -- restricted runtime
3707 Make_If_Statement
(Data
.Loc
,
3709 Then_Statements
=> New_List
(Stmt
));
3710 end Build_Raise_Statement
;
3712 -----------------------------
3713 -- Build_Record_Deep_Procs --
3714 -----------------------------
3716 procedure Build_Record_Deep_Procs
(Typ
: Entity_Id
) is
3720 (Prim
=> Initialize_Case
,
3722 Stmts
=> Make_Deep_Record_Body
(Initialize_Case
, Typ
)));
3724 if not Is_Limited_View
(Typ
) then
3727 (Prim
=> Adjust_Case
,
3729 Stmts
=> Make_Deep_Record_Body
(Adjust_Case
, Typ
)));
3732 -- Do not generate Deep_Finalize and Finalize_Address if finalization is
3733 -- suppressed since these routine will not be used.
3735 if not Restriction_Active
(No_Finalization
) then
3738 (Prim
=> Finalize_Case
,
3740 Stmts
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
)));
3742 -- Create TSS primitive Finalize_Address (unless CodePeer_Mode)
3744 if not CodePeer_Mode
then
3747 (Prim
=> Address_Case
,
3749 Stmts
=> Make_Deep_Record_Body
(Address_Case
, Typ
)));
3752 end Build_Record_Deep_Procs
;
3758 function Cleanup_Array
3761 Typ
: Entity_Id
) return List_Id
3763 Loc
: constant Source_Ptr
:= Sloc
(N
);
3764 Index_List
: constant List_Id
:= New_List
;
3766 function Free_Component
return List_Id
;
3767 -- Generate the code to finalize the task or protected subcomponents
3768 -- of a single component of the array.
3770 function Free_One_Dimension
(Dim
: Int
) return List_Id
;
3771 -- Generate a loop over one dimension of the array
3773 --------------------
3774 -- Free_Component --
3775 --------------------
3777 function Free_Component
return List_Id
is
3778 Stmts
: List_Id
:= New_List
;
3780 C_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
3783 -- Component type is known to contain tasks or protected objects
3786 Make_Indexed_Component
(Loc
,
3787 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3788 Expressions
=> Index_List
);
3790 Set_Etype
(Tsk
, C_Typ
);
3792 if Is_Task_Type
(C_Typ
) then
3793 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3795 elsif Is_Simple_Protected_Type
(C_Typ
) then
3796 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3798 elsif Is_Record_Type
(C_Typ
) then
3799 Stmts
:= Cleanup_Record
(N
, Tsk
, C_Typ
);
3801 elsif Is_Array_Type
(C_Typ
) then
3802 Stmts
:= Cleanup_Array
(N
, Tsk
, C_Typ
);
3808 ------------------------
3809 -- Free_One_Dimension --
3810 ------------------------
3812 function Free_One_Dimension
(Dim
: Int
) return List_Id
is
3816 if Dim
> Number_Dimensions
(Typ
) then
3817 return Free_Component
;
3819 -- Here we generate the required loop
3822 Index
:= Make_Temporary
(Loc
, 'J');
3823 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
3826 Make_Implicit_Loop_Statement
(N
,
3827 Identifier
=> Empty
,
3829 Make_Iteration_Scheme
(Loc
,
3830 Loop_Parameter_Specification
=>
3831 Make_Loop_Parameter_Specification
(Loc
,
3832 Defining_Identifier
=> Index
,
3833 Discrete_Subtype_Definition
=>
3834 Make_Attribute_Reference
(Loc
,
3835 Prefix
=> Duplicate_Subexpr
(Obj
),
3836 Attribute_Name
=> Name_Range
,
3837 Expressions
=> New_List
(
3838 Make_Integer_Literal
(Loc
, Dim
))))),
3839 Statements
=> Free_One_Dimension
(Dim
+ 1)));
3841 end Free_One_Dimension
;
3843 -- Start of processing for Cleanup_Array
3846 return Free_One_Dimension
(1);
3849 --------------------
3850 -- Cleanup_Record --
3851 --------------------
3853 function Cleanup_Record
3856 Typ
: Entity_Id
) return List_Id
3858 Loc
: constant Source_Ptr
:= Sloc
(N
);
3861 Stmts
: constant List_Id
:= New_List
;
3862 U_Typ
: constant Entity_Id
:= Underlying_Type
(Typ
);
3865 if Has_Discriminants
(U_Typ
)
3866 and then Nkind
(Parent
(U_Typ
)) = N_Full_Type_Declaration
3867 and then Nkind
(Type_Definition
(Parent
(U_Typ
))) = N_Record_Definition
3870 (Variant_Part
(Component_List
(Type_Definition
(Parent
(U_Typ
)))))
3872 -- For now, do not attempt to free a component that may appear in a
3873 -- variant, and instead issue a warning. Doing this "properly" would
3874 -- require building a case statement and would be quite a mess. Note
3875 -- that the RM only requires that free "work" for the case of a task
3876 -- access value, so already we go way beyond this in that we deal
3877 -- with the array case and non-discriminated record cases.
3880 ("task/protected object in variant record will not be freed??", N
);
3881 return New_List
(Make_Null_Statement
(Loc
));
3884 Comp
:= First_Component
(Typ
);
3885 while Present
(Comp
) loop
3886 if Has_Task
(Etype
(Comp
))
3887 or else Has_Simple_Protected_Object
(Etype
(Comp
))
3890 Make_Selected_Component
(Loc
,
3891 Prefix
=> Duplicate_Subexpr_No_Checks
(Obj
),
3892 Selector_Name
=> New_Occurrence_Of
(Comp
, Loc
));
3893 Set_Etype
(Tsk
, Etype
(Comp
));
3895 if Is_Task_Type
(Etype
(Comp
)) then
3896 Append_To
(Stmts
, Cleanup_Task
(N
, Tsk
));
3898 elsif Is_Simple_Protected_Type
(Etype
(Comp
)) then
3899 Append_To
(Stmts
, Cleanup_Protected_Object
(N
, Tsk
));
3901 elsif Is_Record_Type
(Etype
(Comp
)) then
3903 -- Recurse, by generating the prefix of the argument to
3904 -- the eventual cleanup call.
3906 Append_List_To
(Stmts
, Cleanup_Record
(N
, Tsk
, Etype
(Comp
)));
3908 elsif Is_Array_Type
(Etype
(Comp
)) then
3909 Append_List_To
(Stmts
, Cleanup_Array
(N
, Tsk
, Etype
(Comp
)));
3913 Next_Component
(Comp
);
3919 ------------------------------
3920 -- Cleanup_Protected_Object --
3921 ------------------------------
3923 function Cleanup_Protected_Object
3925 Ref
: Node_Id
) return Node_Id
3927 Loc
: constant Source_Ptr
:= Sloc
(N
);
3930 -- For restricted run-time libraries (Ravenscar), tasks are
3931 -- non-terminating, and protected objects can only appear at library
3932 -- level, so we do not want finalization of protected objects.
3934 if Restricted_Profile
then
3939 Make_Procedure_Call_Statement
(Loc
,
3941 New_Occurrence_Of
(RTE
(RE_Finalize_Protection
), Loc
),
3942 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3944 end Cleanup_Protected_Object
;
3950 function Cleanup_Task
3952 Ref
: Node_Id
) return Node_Id
3954 Loc
: constant Source_Ptr
:= Sloc
(N
);
3957 -- For restricted run-time libraries (Ravenscar), tasks are
3958 -- non-terminating and they can only appear at library level, so we do
3959 -- not want finalization of task objects.
3961 if Restricted_Profile
then
3966 Make_Procedure_Call_Statement
(Loc
,
3968 New_Occurrence_Of
(RTE
(RE_Free_Task
), Loc
),
3969 Parameter_Associations
=> New_List
(Concurrent_Ref
(Ref
)));
3973 ------------------------------
3974 -- Check_Visibly_Controlled --
3975 ------------------------------
3977 procedure Check_Visibly_Controlled
3978 (Prim
: Final_Primitives
;
3980 E
: in out Entity_Id
;
3981 Cref
: in out Node_Id
)
3983 Parent_Type
: Entity_Id
;
3987 if Is_Derived_Type
(Typ
)
3988 and then Comes_From_Source
(E
)
3989 and then not Present
(Overridden_Operation
(E
))
3991 -- We know that the explicit operation on the type does not override
3992 -- the inherited operation of the parent, and that the derivation
3993 -- is from a private type that is not visibly controlled.
3995 Parent_Type
:= Etype
(Typ
);
3996 Op
:= Find_Optional_Prim_Op
(Parent_Type
, Name_Of
(Prim
));
3998 if Present
(Op
) then
4001 -- Wrap the object to be initialized into the proper
4002 -- unchecked conversion, to be compatible with the operation
4005 if Nkind
(Cref
) = N_Unchecked_Type_Conversion
then
4006 Cref
:= Unchecked_Convert_To
(Parent_Type
, Expression
(Cref
));
4008 Cref
:= Unchecked_Convert_To
(Parent_Type
, Cref
);
4012 end Check_Visibly_Controlled
;
4018 function Convert_View
4021 Ind
: Pos
:= 1) return Node_Id
4023 Fent
: Entity_Id
:= First_Entity
(Proc
);
4028 for J
in 2 .. Ind
loop
4032 Ftyp
:= Etype
(Fent
);
4034 if Nkind_In
(Arg
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
4035 Atyp
:= Entity
(Subtype_Mark
(Arg
));
4037 Atyp
:= Etype
(Arg
);
4040 if Is_Abstract_Subprogram
(Proc
) and then Is_Tagged_Type
(Ftyp
) then
4041 return Unchecked_Convert_To
(Class_Wide_Type
(Ftyp
), Arg
);
4044 and then Present
(Atyp
)
4045 and then (Is_Private_Type
(Ftyp
) or else Is_Private_Type
(Atyp
))
4046 and then Base_Type
(Underlying_Type
(Atyp
)) =
4047 Base_Type
(Underlying_Type
(Ftyp
))
4049 return Unchecked_Convert_To
(Ftyp
, Arg
);
4051 -- If the argument is already a conversion, as generated by
4052 -- Make_Init_Call, set the target type to the type of the formal
4053 -- directly, to avoid spurious typing problems.
4055 elsif Nkind_In
(Arg
, N_Unchecked_Type_Conversion
, N_Type_Conversion
)
4056 and then not Is_Class_Wide_Type
(Atyp
)
4058 Set_Subtype_Mark
(Arg
, New_Occurrence_Of
(Ftyp
, Sloc
(Arg
)));
4059 Set_Etype
(Arg
, Ftyp
);
4062 -- Otherwise, introduce a conversion when the designated object
4063 -- has a type derived from the formal of the controlled routine.
4065 elsif Is_Private_Type
(Ftyp
)
4066 and then Present
(Atyp
)
4067 and then Is_Derived_Type
(Underlying_Type
(Base_Type
(Atyp
)))
4069 return Unchecked_Convert_To
(Ftyp
, Arg
);
4076 -------------------------------
4077 -- CW_Or_Has_Controlled_Part --
4078 -------------------------------
4080 function CW_Or_Has_Controlled_Part
(T
: Entity_Id
) return Boolean is
4082 return Is_Class_Wide_Type
(T
) or else Needs_Finalization
(T
);
4083 end CW_Or_Has_Controlled_Part
;
4085 ------------------------
4086 -- Enclosing_Function --
4087 ------------------------
4089 function Enclosing_Function
(E
: Entity_Id
) return Entity_Id
is
4090 Func_Id
: Entity_Id
;
4094 while Present
(Func_Id
) and then Func_Id
/= Standard_Standard
loop
4095 if Ekind
(Func_Id
) = E_Function
then
4099 Func_Id
:= Scope
(Func_Id
);
4103 end Enclosing_Function
;
4105 -------------------------------
4106 -- Establish_Transient_Scope --
4107 -------------------------------
4109 -- This procedure is called each time a transient block has to be inserted
4110 -- that is to say for each call to a function with unconstrained or tagged
4111 -- result. It creates a new scope on the scope stack in order to enclose
4112 -- all transient variables generated.
4114 procedure Establish_Transient_Scope
4116 Manage_Sec_Stack
: Boolean)
4118 procedure Create_Transient_Scope
(Constr
: Node_Id
);
4119 -- Place a new scope on the scope stack in order to service construct
4120 -- Constr. The new scope may also manage the secondary stack.
4122 procedure Delegate_Sec_Stack_Management
;
4123 -- Move the management of the secondary stack to the nearest enclosing
4126 function Find_Enclosing_Transient_Scope
return Entity_Id
;
4127 -- Examine the scope stack looking for the nearest enclosing transient
4128 -- scope. Return Empty if no such scope exists.
4130 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean;
4131 -- Determine whether arbitrary Id denotes a package or subprogram [body]
4133 ----------------------------
4134 -- Create_Transient_Scope --
4135 ----------------------------
4137 procedure Create_Transient_Scope
(Constr
: Node_Id
) is
4138 Loc
: constant Source_Ptr
:= Sloc
(N
);
4140 Iter_Loop
: Entity_Id
;
4141 Trans_Scop
: Entity_Id
;
4144 Trans_Scop
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
4145 Set_Etype
(Trans_Scop
, Standard_Void_Type
);
4147 Push_Scope
(Trans_Scop
);
4148 Set_Node_To_Be_Wrapped
(Constr
);
4149 Set_Scope_Is_Transient
;
4151 -- The transient scope must also manage the secondary stack
4153 if Manage_Sec_Stack
then
4154 Set_Uses_Sec_Stack
(Trans_Scop
);
4155 Check_Restriction
(No_Secondary_Stack
, N
);
4157 -- The expansion of iterator loops generates references to objects
4158 -- in order to extract elements from a container:
4160 -- Ref : Reference_Type_Ptr := Reference (Container, Cursor);
4161 -- Obj : <object type> renames Ref.all.Element.all;
4163 -- These references are controlled and returned on the secondary
4164 -- stack. A new reference is created at each iteration of the loop
4165 -- and as a result it must be finalized and the space occupied by
4166 -- it on the secondary stack reclaimed at the end of the current
4169 -- When the context that requires a transient scope is a call to
4170 -- routine Reference, the node to be wrapped is the source object:
4172 -- for Obj of Container loop
4174 -- Routine Wrap_Transient_Declaration however does not generate a
4175 -- physical block as wrapping a declaration will kill it too ealy.
4176 -- To handle this peculiar case, mark the related iterator loop as
4177 -- requiring the secondary stack. This signals the finalization
4178 -- machinery to manage the secondary stack (see routine
4179 -- Process_Statements_For_Controlled_Objects).
4181 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Trans_Scop
);
4183 if Present
(Iter_Loop
) then
4184 Set_Uses_Sec_Stack
(Iter_Loop
);
4188 if Debug_Flag_W
then
4189 Write_Str
(" <Transient>");
4192 end Create_Transient_Scope
;
4194 -----------------------------------
4195 -- Delegate_Sec_Stack_Management --
4196 -----------------------------------
4198 procedure Delegate_Sec_Stack_Management
is
4199 Scop_Id
: Entity_Id
;
4200 Scop_Rec
: Scope_Stack_Entry
;
4203 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4204 Scop_Rec
:= Scope_Stack
.Table
(Index
);
4205 Scop_Id
:= Scop_Rec
.Entity
;
4207 -- Prevent the search from going too far or within the scope space
4210 if Scop_Id
= Standard_Standard
then
4213 -- No transient scope should be encountered during the traversal
4214 -- because Establish_Transient_Scope should have already handled
4217 elsif Scop_Rec
.Is_Transient
then
4218 pragma Assert
(False);
4221 -- The construct which requires secondary stack management is
4222 -- always enclosed by a package or subprogram scope.
4224 elsif Is_Package_Or_Subprogram
(Scop_Id
) then
4225 Set_Uses_Sec_Stack
(Scop_Id
);
4226 Check_Restriction
(No_Secondary_Stack
, N
);
4232 -- At this point no suitable scope was found. This should never occur
4233 -- because a construct is always enclosed by a compilation unit which
4236 pragma Assert
(False);
4237 end Delegate_Sec_Stack_Management
;
4239 ------------------------------------
4240 -- Find_Enclosing_Transient_Scope --
4241 ------------------------------------
4243 function Find_Enclosing_Transient_Scope
return Entity_Id
is
4244 Scop_Id
: Entity_Id
;
4245 Scop_Rec
: Scope_Stack_Entry
;
4248 for Index
in reverse Scope_Stack
.First
.. Scope_Stack
.Last
loop
4249 Scop_Rec
:= Scope_Stack
.Table
(Index
);
4250 Scop_Id
:= Scop_Rec
.Entity
;
4252 -- Prevent the search from going too far or within the scope space
4255 if Scop_Id
= Standard_Standard
4256 or else Is_Package_Or_Subprogram
(Scop_Id
)
4260 elsif Scop_Rec
.Is_Transient
then
4266 end Find_Enclosing_Transient_Scope
;
4268 ------------------------------
4269 -- Is_Package_Or_Subprogram --
4270 ------------------------------
4272 function Is_Package_Or_Subprogram
(Id
: Entity_Id
) return Boolean is
4274 return Ekind_In
(Id
, E_Entry
,
4280 end Is_Package_Or_Subprogram
;
4284 Trans_Id
: constant Entity_Id
:= Find_Enclosing_Transient_Scope
;
4287 -- Start of processing for Establish_Transient_Scope
4290 -- Do not create a new transient scope if there is an existing transient
4291 -- scope on the stack.
4293 if Present
(Trans_Id
) then
4295 -- If the transient scope was requested for purposes of managing the
4296 -- secondary stack, then the existing scope must perform this task.
4298 if Manage_Sec_Stack
then
4299 Set_Uses_Sec_Stack
(Trans_Id
);
4305 -- At this point it is known that the scope stack is free of transient
4306 -- scopes. Locate the proper construct which must be serviced by a new
4309 Context
:= Find_Transient_Context
(N
);
4311 if Present
(Context
) then
4312 if Nkind
(Context
) = N_Assignment_Statement
then
4314 -- An assignment statement with suppressed controlled semantics
4315 -- does not need a transient scope because finalization is not
4316 -- desirable at this point. Note that No_Ctrl_Actions is also
4317 -- set for non-controlled assignments to suppress dispatching
4320 if No_Ctrl_Actions
(Context
)
4321 and then Needs_Finalization
(Etype
(Name
(Context
)))
4323 -- When a controlled component is initialized by a function
4324 -- call, the result on the secondary stack is always assigned
4325 -- to the component. Signal the nearest suitable scope that it
4326 -- is safe to manage the secondary stack.
4328 if Manage_Sec_Stack
and then Within_Init_Proc
then
4329 Delegate_Sec_Stack_Management
;
4332 -- Otherwise the assignment is a normal transient context and thus
4333 -- requires a transient scope.
4336 Create_Transient_Scope
(Context
);
4342 Create_Transient_Scope
(Context
);
4345 end Establish_Transient_Scope
;
4347 ----------------------------
4348 -- Expand_Cleanup_Actions --
4349 ----------------------------
4351 procedure Expand_Cleanup_Actions
(N
: Node_Id
) is
4352 pragma Assert
(Nkind_In
(N
, N_Block_Statement
,
4354 N_Extended_Return_Statement
,
4358 Scop
: constant Entity_Id
:= Current_Scope
;
4360 Is_Asynchronous_Call
: constant Boolean :=
4361 Nkind
(N
) = N_Block_Statement
4362 and then Is_Asynchronous_Call_Block
(N
);
4363 Is_Master
: constant Boolean :=
4364 Nkind
(N
) /= N_Extended_Return_Statement
4365 and then Nkind
(N
) /= N_Entry_Body
4366 and then Is_Task_Master
(N
);
4367 Is_Protected_Subp_Body
: constant Boolean :=
4368 Nkind
(N
) = N_Subprogram_Body
4369 and then Is_Protected_Subprogram_Body
(N
);
4370 Is_Task_Allocation
: constant Boolean :=
4371 Nkind
(N
) = N_Block_Statement
4372 and then Is_Task_Allocation_Block
(N
);
4373 Is_Task_Body
: constant Boolean :=
4374 Nkind
(Original_Node
(N
)) = N_Task_Body
;
4376 -- We mark the secondary stack if it is used in this construct, and
4377 -- we're not returning a function result on the secondary stack, except
4378 -- that a build-in-place function that might or might not return on the
4379 -- secondary stack always needs a mark. A run-time test is required in
4380 -- the case where the build-in-place function has a BIP_Alloc extra
4381 -- parameter (see Create_Finalizer).
4383 Needs_Sec_Stack_Mark
: constant Boolean :=
4384 (Uses_Sec_Stack
(Scop
)
4386 not Sec_Stack_Needed_For_Return
(Scop
))
4388 (Is_Build_In_Place_Function
(Scop
)
4389 and then Needs_BIP_Alloc_Form
(Scop
));
4391 Needs_Custom_Cleanup
: constant Boolean :=
4392 Nkind
(N
) = N_Block_Statement
4393 and then Present
(Cleanup_Actions
(N
));
4395 Actions_Required
: constant Boolean :=
4396 Requires_Cleanup_Actions
(N
, True)
4397 or else Is_Asynchronous_Call
4399 or else Is_Protected_Subp_Body
4400 or else Is_Task_Allocation
4401 or else Is_Task_Body
4402 or else Needs_Sec_Stack_Mark
4403 or else Needs_Custom_Cleanup
;
4405 HSS
: Node_Id
:= Handled_Statement_Sequence
(N
);
4409 procedure Wrap_HSS_In_Block
;
4410 -- Move HSS inside a new block along with the original exception
4411 -- handlers. Make the newly generated block the sole statement of HSS.
4413 -----------------------
4414 -- Wrap_HSS_In_Block --
4415 -----------------------
4417 procedure Wrap_HSS_In_Block
is
4419 Block_Id
: Entity_Id
;
4423 -- Preserve end label to provide proper cross-reference information
4425 End_Lab
:= End_Label
(HSS
);
4427 Make_Block_Statement
(Loc
, Handled_Statement_Sequence
=> HSS
);
4429 Block_Id
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
4430 Set_Identifier
(Block
, New_Occurrence_Of
(Block_Id
, Loc
));
4431 Set_Etype
(Block_Id
, Standard_Void_Type
);
4432 Set_Block_Node
(Block_Id
, Identifier
(Block
));
4434 -- Signal the finalization machinery that this particular block
4435 -- contains the original context.
4437 Set_Is_Finalization_Wrapper
(Block
);
4439 Set_Handled_Statement_Sequence
(N
,
4440 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(Block
)));
4441 HSS
:= Handled_Statement_Sequence
(N
);
4443 Set_First_Real_Statement
(HSS
, Block
);
4444 Set_End_Label
(HSS
, End_Lab
);
4446 -- Comment needed here, see RH for 1.306 ???
4448 if Nkind
(N
) = N_Subprogram_Body
then
4449 Set_Has_Nested_Block_With_Handler
(Scop
);
4451 end Wrap_HSS_In_Block
;
4453 -- Start of processing for Expand_Cleanup_Actions
4456 -- The current construct does not need any form of servicing
4458 if not Actions_Required
then
4461 -- If the current node is a rewritten task body and the descriptors have
4462 -- not been delayed (due to some nested instantiations), do not generate
4463 -- redundant cleanup actions.
4466 and then Nkind
(N
) = N_Subprogram_Body
4467 and then not Delay_Subprogram_Descriptors
(Corresponding_Spec
(N
))
4472 -- If an extended return statement contains something like
4476 -- where F is a build-in-place function call returning a controlled
4477 -- type, then a temporary object will be implicitly declared as part
4478 -- of the statement list, and this will need cleanup. In such cases,
4481 -- return Result : T := ... do
4482 -- <statements> -- possibly with handlers
4487 -- return Result : T := ... do
4488 -- declare -- no declarations
4490 -- <statements> -- possibly with handlers
4491 -- end; -- no handlers
4494 -- So Expand_Cleanup_Actions will end up being called recursively on the
4497 if Nkind
(N
) = N_Extended_Return_Statement
then
4499 Block
: constant Node_Id
:=
4500 Make_Block_Statement
(Sloc
(N
),
4501 Declarations
=> Empty_List
,
4502 Handled_Statement_Sequence
=>
4503 Handled_Statement_Sequence
(N
));
4505 Set_Handled_Statement_Sequence
(N
,
4506 Make_Handled_Sequence_Of_Statements
(Sloc
(N
),
4507 Statements
=> New_List
(Block
)));
4512 -- Analysis of the block did all the work
4517 if Needs_Custom_Cleanup
then
4518 Cln
:= Cleanup_Actions
(N
);
4524 Decls
: List_Id
:= Declarations
(N
);
4526 Mark
: Entity_Id
:= Empty
;
4527 New_Decls
: List_Id
;
4531 -- If we are generating expanded code for debugging purposes, use the
4532 -- Sloc of the point of insertion for the cleanup code. The Sloc will
4533 -- be updated subsequently to reference the proper line in .dg files.
4534 -- If we are not debugging generated code, use No_Location instead,
4535 -- so that no debug information is generated for the cleanup code.
4536 -- This makes the behavior of the NEXT command in GDB monotonic, and
4537 -- makes the placement of breakpoints more accurate.
4539 if Debug_Generated_Code
then
4545 -- Set polling off. The finalization and cleanup code is executed
4546 -- with aborts deferred.
4548 Old_Poll
:= Polling_Required
;
4549 Polling_Required
:= False;
4551 -- A task activation call has already been built for a task
4552 -- allocation block.
4554 if not Is_Task_Allocation
then
4555 Build_Task_Activation_Call
(N
);
4559 Establish_Task_Master
(N
);
4562 New_Decls
:= New_List
;
4564 -- If secondary stack is in use, generate:
4566 -- Mnn : constant Mark_Id := SS_Mark;
4568 if Needs_Sec_Stack_Mark
then
4569 Mark
:= Make_Temporary
(Loc
, 'M');
4571 Append_To
(New_Decls
, Build_SS_Mark_Call
(Loc
, Mark
));
4572 Set_Uses_Sec_Stack
(Scop
, False);
4575 -- If exception handlers are present, wrap the sequence of statements
4576 -- in a block since it is not possible to have exception handlers and
4577 -- an At_End handler in the same construct.
4579 if Present
(Exception_Handlers
(HSS
)) then
4582 -- Ensure that the First_Real_Statement field is set
4584 elsif No
(First_Real_Statement
(HSS
)) then
4585 Set_First_Real_Statement
(HSS
, First
(Statements
(HSS
)));
4588 -- Do not move the Activation_Chain declaration in the context of
4589 -- task allocation blocks. Task allocation blocks use _chain in their
4590 -- cleanup handlers and gigi complains if it is declared in the
4591 -- sequence of statements of the scope that declares the handler.
4593 if Is_Task_Allocation
then
4595 Chain
: constant Entity_Id
:= Activation_Chain_Entity
(N
);
4599 Decl
:= First
(Decls
);
4600 while Nkind
(Decl
) /= N_Object_Declaration
4601 or else Defining_Identifier
(Decl
) /= Chain
4605 -- A task allocation block should always include a _chain
4608 pragma Assert
(Present
(Decl
));
4612 Prepend_To
(New_Decls
, Decl
);
4616 -- Ensure the presence of a declaration list in order to successfully
4617 -- append all original statements to it.
4620 Set_Declarations
(N
, New_List
);
4621 Decls
:= Declarations
(N
);
4624 -- Move the declarations into the sequence of statements in order to
4625 -- have them protected by the At_End handler. It may seem weird to
4626 -- put declarations in the sequence of statement but in fact nothing
4627 -- forbids that at the tree level.
4629 Append_List_To
(Decls
, Statements
(HSS
));
4630 Set_Statements
(HSS
, Decls
);
4632 -- Reset the Sloc of the handled statement sequence to properly
4633 -- reflect the new initial "statement" in the sequence.
4635 Set_Sloc
(HSS
, Sloc
(First
(Decls
)));
4637 -- The declarations of finalizer spec and auxiliary variables replace
4638 -- the old declarations that have been moved inward.
4640 Set_Declarations
(N
, New_Decls
);
4641 Analyze_Declarations
(New_Decls
);
4643 -- Generate finalization calls for all controlled objects appearing
4644 -- in the statements of N. Add context specific cleanup for various
4649 Clean_Stmts
=> Build_Cleanup_Statements
(N
, Cln
),
4651 Top_Decls
=> New_Decls
,
4652 Defer_Abort
=> Nkind
(Original_Node
(N
)) = N_Task_Body
4656 if Present
(Fin_Id
) then
4657 Build_Finalizer_Call
(N
, Fin_Id
);
4660 -- Restore saved polling mode
4662 Polling_Required
:= Old_Poll
;
4664 end Expand_Cleanup_Actions
;
4666 ---------------------------
4667 -- Expand_N_Package_Body --
4668 ---------------------------
4670 -- Add call to Activate_Tasks if body is an activator (actual processing
4671 -- is in chapter 9).
4673 -- Generate subprogram descriptor for elaboration routine
4675 -- Encode entity names in package body
4677 procedure Expand_N_Package_Body
(N
: Node_Id
) is
4678 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(N
);
4682 -- This is done only for non-generic packages
4684 if Ekind
(Spec_Id
) = E_Package
then
4685 Push_Scope
(Spec_Id
);
4687 -- Build dispatch tables of library level tagged types
4689 if Tagged_Type_Expansion
4690 and then Is_Library_Level_Entity
(Spec_Id
)
4692 Build_Static_Dispatch_Tables
(N
);
4695 Build_Task_Activation_Call
(N
);
4697 -- Verify the run-time semantics of pragma Initial_Condition at the
4698 -- end of the body statements.
4700 Expand_Pragma_Initial_Condition
(Spec_Id
, N
);
4705 Set_Elaboration_Flag
(N
, Spec_Id
);
4706 Set_In_Package_Body
(Spec_Id
, False);
4708 -- Set to encode entity names in package body before gigi is called
4710 Qualify_Entity_Names
(N
);
4712 if Ekind
(Spec_Id
) /= E_Generic_Package
then
4715 Clean_Stmts
=> No_List
,
4717 Top_Decls
=> No_List
,
4718 Defer_Abort
=> False,
4721 if Present
(Fin_Id
) then
4723 Body_Ent
: Node_Id
:= Defining_Unit_Name
(N
);
4726 if Nkind
(Body_Ent
) = N_Defining_Program_Unit_Name
then
4727 Body_Ent
:= Defining_Identifier
(Body_Ent
);
4730 Set_Finalizer
(Body_Ent
, Fin_Id
);
4734 end Expand_N_Package_Body
;
4736 ----------------------------------
4737 -- Expand_N_Package_Declaration --
4738 ----------------------------------
4740 -- Add call to Activate_Tasks if there are tasks declared and the package
4741 -- has no body. Note that in Ada 83 this may result in premature activation
4742 -- of some tasks, given that we cannot tell whether a body will eventually
4745 procedure Expand_N_Package_Declaration
(N
: Node_Id
) is
4746 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4747 Spec
: constant Node_Id
:= Specification
(N
);
4751 No_Body
: Boolean := False;
4752 -- True in the case of a package declaration that is a compilation
4753 -- unit and for which no associated body will be compiled in this
4757 -- Case of a package declaration other than a compilation unit
4759 if Nkind
(Parent
(N
)) /= N_Compilation_Unit
then
4762 -- Case of a compilation unit that does not require a body
4764 elsif not Body_Required
(Parent
(N
))
4765 and then not Unit_Requires_Body
(Id
)
4769 -- Special case of generating calling stubs for a remote call interface
4770 -- package: even though the package declaration requires one, the body
4771 -- won't be processed in this compilation (so any stubs for RACWs
4772 -- declared in the package must be generated here, along with the spec).
4774 elsif Parent
(N
) = Cunit
(Main_Unit
)
4775 and then Is_Remote_Call_Interface
(Id
)
4776 and then Distribution_Stub_Mode
= Generate_Caller_Stub_Body
4781 -- For a nested instance, delay processing until freeze point
4783 if Has_Delayed_Freeze
(Id
)
4784 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit
4789 -- For a package declaration that implies no associated body, generate
4790 -- task activation call and RACW supporting bodies now (since we won't
4791 -- have a specific separate compilation unit for that).
4796 -- Generate RACW subprogram bodies
4798 if Has_RACW
(Id
) then
4799 Decls
:= Private_Declarations
(Spec
);
4802 Decls
:= Visible_Declarations
(Spec
);
4807 Set_Visible_Declarations
(Spec
, Decls
);
4810 Append_RACW_Bodies
(Decls
, Id
);
4811 Analyze_List
(Decls
);
4814 -- Generate task activation call as last step of elaboration
4816 if Present
(Activation_Chain_Entity
(N
)) then
4817 Build_Task_Activation_Call
(N
);
4820 -- Verify the run-time semantics of pragma Initial_Condition at the
4821 -- end of the private declarations when the package lacks a body.
4823 Expand_Pragma_Initial_Condition
(Id
, N
);
4828 -- Build dispatch tables of library level tagged types
4830 if Tagged_Type_Expansion
4831 and then (Is_Compilation_Unit
(Id
)
4832 or else (Is_Generic_Instance
(Id
)
4833 and then Is_Library_Level_Entity
(Id
)))
4835 Build_Static_Dispatch_Tables
(N
);
4838 -- Note: it is not necessary to worry about generating a subprogram
4839 -- descriptor, since the only way to get exception handlers into a
4840 -- package spec is to include instantiations, and that would cause
4841 -- generation of subprogram descriptors to be delayed in any case.
4843 -- Set to encode entity names in package spec before gigi is called
4845 Qualify_Entity_Names
(N
);
4847 if Ekind
(Id
) /= E_Generic_Package
then
4850 Clean_Stmts
=> No_List
,
4852 Top_Decls
=> No_List
,
4853 Defer_Abort
=> False,
4856 Set_Finalizer
(Id
, Fin_Id
);
4858 end Expand_N_Package_Declaration
;
4860 ----------------------------
4861 -- Find_Transient_Context --
4862 ----------------------------
4864 function Find_Transient_Context
(N
: Node_Id
) return Node_Id
is
4871 while Present
(Curr
) loop
4872 case Nkind
(Curr
) is
4876 -- Declarations act as a boundary for a transient scope even if
4877 -- they are not wrapped, see Wrap_Transient_Declaration.
4879 when N_Object_Declaration
4880 | N_Object_Renaming_Declaration
4881 | N_Subtype_Declaration
4887 -- Statements and statement-like constructs act as a boundary for
4888 -- a transient scope.
4890 when N_Accept_Alternative
4891 | N_Attribute_Definition_Clause
4893 | N_Case_Statement_Alternative
4895 | N_Delay_Alternative
4896 | N_Delay_Until_Statement
4897 | N_Delay_Relative_Statement
4898 | N_Discriminant_Association
4900 | N_Entry_Body_Formal_Part
4903 | N_Terminate_Alternative
4905 pragma Assert
(Present
(Prev
));
4908 when N_Assignment_Statement
=>
4911 when N_Entry_Call_Statement
4912 | N_Procedure_Call_Statement
4914 -- When an entry or procedure call acts as the alternative of a
4915 -- conditional or timed entry call, the proper context is that
4916 -- of the alternative.
4918 if Nkind
(Parent
(Curr
)) = N_Entry_Call_Alternative
4919 and then Nkind_In
(Parent
(Parent
(Curr
)),
4920 N_Conditional_Entry_Call
,
4923 return Parent
(Parent
(Curr
));
4925 -- General case for entry or procedure calls
4933 -- Pragma Check is not a valid transient context in GNATprove
4934 -- mode because the pragma must remain unchanged.
4937 and then Get_Pragma_Id
(Curr
) = Pragma_Check
4941 -- General case for pragmas
4947 when N_Raise_Statement
=>
4950 when N_Simple_Return_Statement
=>
4952 -- A return statement is not a valid transient context when the
4953 -- function itself requires transient scope management because
4954 -- the result will be reclaimed too early.
4956 if Requires_Transient_Scope
(Etype
4957 (Return_Applies_To
(Return_Statement_Entity
(Curr
))))
4961 -- General case for return statements
4969 when N_Attribute_Reference
=>
4970 if Is_Procedure_Attribute_Name
(Attribute_Name
(Curr
)) then
4974 -- An iteration scheme or an Ada 2012 iterator specification is
4975 -- not a valid context because Analyze_Iteration_Scheme already
4976 -- employs special processing for them.
4978 when N_Iteration_Scheme
4979 | N_Iterator_Specification
4983 when N_Loop_Parameter_Specification
=>
4985 -- An iteration scheme is not a valid context because routine
4986 -- Analyze_Iteration_Scheme already employs special processing.
4988 if Nkind
(Parent
(Curr
)) = N_Iteration_Scheme
then
4991 return Parent
(Curr
);
4996 -- The following nodes represent "dummy contexts" which do not
4997 -- need to be wrapped.
4999 when N_Component_Declaration
5000 | N_Discriminant_Specification
5001 | N_Parameter_Specification
5005 -- If the traversal leaves a scope without having been able to
5006 -- find a construct to wrap, something is going wrong, but this
5007 -- can happen in error situations that are not detected yet (such
5008 -- as a dynamic string in a pragma Export).
5010 when N_Block_Statement
5013 | N_Package_Declaration
5027 Curr
:= Parent
(Curr
);
5031 end Find_Transient_Context
;
5033 ----------------------------------
5034 -- Has_New_Controlled_Component --
5035 ----------------------------------
5037 function Has_New_Controlled_Component
(E
: Entity_Id
) return Boolean is
5041 if not Is_Tagged_Type
(E
) then
5042 return Has_Controlled_Component
(E
);
5043 elsif not Is_Derived_Type
(E
) then
5044 return Has_Controlled_Component
(E
);
5047 Comp
:= First_Component
(E
);
5048 while Present
(Comp
) loop
5049 if Chars
(Comp
) = Name_uParent
then
5052 elsif Scope
(Original_Record_Component
(Comp
)) = E
5053 and then Needs_Finalization
(Etype
(Comp
))
5058 Next_Component
(Comp
);
5062 end Has_New_Controlled_Component
;
5064 ---------------------------------
5065 -- Has_Simple_Protected_Object --
5066 ---------------------------------
5068 function Has_Simple_Protected_Object
(T
: Entity_Id
) return Boolean is
5070 if Has_Task
(T
) then
5073 elsif Is_Simple_Protected_Type
(T
) then
5076 elsif Is_Array_Type
(T
) then
5077 return Has_Simple_Protected_Object
(Component_Type
(T
));
5079 elsif Is_Record_Type
(T
) then
5084 Comp
:= First_Component
(T
);
5085 while Present
(Comp
) loop
5086 if Has_Simple_Protected_Object
(Etype
(Comp
)) then
5090 Next_Component
(Comp
);
5099 end Has_Simple_Protected_Object
;
5101 ------------------------------------
5102 -- Insert_Actions_In_Scope_Around --
5103 ------------------------------------
5105 procedure Insert_Actions_In_Scope_Around
5108 Manage_SS
: Boolean)
5110 Act_Before
: constant List_Id
:=
5111 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
);
5112 Act_After
: constant List_Id
:=
5113 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
);
5114 Act_Cleanup
: constant List_Id
:=
5115 Scope_Stack
.Table
(Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
);
5116 -- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
5117 -- Last), but this was incorrect as Process_Transients_In_Scope may
5118 -- introduce new scopes and cause a reallocation of Scope_Stack.Table.
5120 procedure Process_Transients_In_Scope
5121 (First_Object
: Node_Id
;
5122 Last_Object
: Node_Id
;
5123 Related_Node
: Node_Id
);
5124 -- Find all transient objects in the list First_Object .. Last_Object
5125 -- and generate finalization actions for them. Related_Node denotes the
5126 -- node which created all transient objects.
5128 ---------------------------------
5129 -- Process_Transients_In_Scope --
5130 ---------------------------------
5132 procedure Process_Transients_In_Scope
5133 (First_Object
: Node_Id
;
5134 Last_Object
: Node_Id
;
5135 Related_Node
: Node_Id
)
5137 Exceptions_OK
: constant Boolean := Exceptions_In_Finalization_OK
;
5139 Must_Hook
: Boolean := False;
5140 -- Flag denoting whether the context requires transient object
5141 -- export to the outer finalizer.
5143 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
;
5144 -- Determine whether an arbitrary node denotes a subprogram call
5146 procedure Detect_Subprogram_Call
is
5147 new Traverse_Proc
(Is_Subprogram_Call
);
5149 procedure Process_Transient_In_Scope
5150 (Obj_Decl
: Node_Id
;
5151 Blk_Data
: Finalization_Exception_Data
;
5152 Blk_Stmts
: List_Id
);
5153 -- Generate finalization actions for a single transient object
5154 -- denoted by object declaration Obj_Decl. Blk_Data is the
5155 -- exception data of the enclosing block. Blk_Stmts denotes the
5156 -- statements of the enclosing block.
5158 ------------------------
5159 -- Is_Subprogram_Call --
5160 ------------------------
5162 function Is_Subprogram_Call
(N
: Node_Id
) return Traverse_Result
is
5164 -- A regular procedure or function call
5166 if Nkind
(N
) in N_Subprogram_Call
then
5172 -- Heavy expansion may relocate function calls outside the related
5173 -- node. Inspect the original node to detect the initial placement
5176 elsif Original_Node
(N
) /= N
then
5177 Detect_Subprogram_Call
(Original_Node
(N
));
5185 -- Generalized indexing always involves a function call
5187 elsif Nkind
(N
) = N_Indexed_Component
5188 and then Present
(Generalized_Indexing
(N
))
5198 end Is_Subprogram_Call
;
5200 --------------------------------
5201 -- Process_Transient_In_Scope --
5202 --------------------------------
5204 procedure Process_Transient_In_Scope
5205 (Obj_Decl
: Node_Id
;
5206 Blk_Data
: Finalization_Exception_Data
;
5207 Blk_Stmts
: List_Id
)
5209 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
5210 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
5212 Fin_Stmts
: List_Id
;
5213 Hook_Assign
: Node_Id
;
5214 Hook_Clear
: Node_Id
;
5215 Hook_Decl
: Node_Id
;
5216 Hook_Insert
: Node_Id
;
5220 -- Mark the transient object as successfully processed to avoid
5221 -- double finalization.
5223 Set_Is_Finalized_Transient
(Obj_Id
);
5225 -- Construct all the pieces necessary to hook and finalize the
5226 -- transient object.
5228 Build_Transient_Object_Statements
5229 (Obj_Decl
=> Obj_Decl
,
5230 Fin_Call
=> Fin_Call
,
5231 Hook_Assign
=> Hook_Assign
,
5232 Hook_Clear
=> Hook_Clear
,
5233 Hook_Decl
=> Hook_Decl
,
5234 Ptr_Decl
=> Ptr_Decl
);
5236 -- The context contains at least one subprogram call which may
5237 -- raise an exception. This scenario employs "hooking" to pass
5238 -- transient objects to the enclosing finalizer in case of an
5243 -- Add the access type which provides a reference to the
5244 -- transient object. Generate:
5246 -- type Ptr_Typ is access all Desig_Typ;
5248 Insert_Action
(Obj_Decl
, Ptr_Decl
);
5250 -- Add the temporary which acts as a hook to the transient
5251 -- object. Generate:
5253 -- Hook : Ptr_Typ := null;
5255 Insert_Action
(Obj_Decl
, Hook_Decl
);
5257 -- When the transient object is initialized by an aggregate,
5258 -- the hook must capture the object after the last aggregate
5259 -- assignment takes place. Only then is the object considered
5260 -- fully initialized. Generate:
5262 -- Hook := Ptr_Typ (Obj_Id);
5264 -- Hook := Obj_Id'Unrestricted_Access;
5266 if Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
5267 and then Present
(Last_Aggregate_Assignment
(Obj_Id
))
5269 Hook_Insert
:= Last_Aggregate_Assignment
(Obj_Id
);
5271 -- Otherwise the hook seizes the related object immediately
5274 Hook_Insert
:= Obj_Decl
;
5277 Insert_After_And_Analyze
(Hook_Insert
, Hook_Assign
);
5280 -- When exception propagation is enabled wrap the hook clear
5281 -- statement and the finalization call into a block to catch
5282 -- potential exceptions raised during finalization. Generate:
5286 -- [Deep_]Finalize (Obj_Ref);
5290 -- if not Raised then
5293 -- (Enn, Get_Current_Excep.all.all);
5297 if Exceptions_OK
then
5298 Fin_Stmts
:= New_List
;
5301 Append_To
(Fin_Stmts
, Hook_Clear
);
5304 Append_To
(Fin_Stmts
, Fin_Call
);
5306 Prepend_To
(Blk_Stmts
,
5307 Make_Block_Statement
(Loc
,
5308 Handled_Statement_Sequence
=>
5309 Make_Handled_Sequence_Of_Statements
(Loc
,
5310 Statements
=> Fin_Stmts
,
5311 Exception_Handlers
=> New_List
(
5312 Build_Exception_Handler
(Blk_Data
)))));
5314 -- Otherwise generate:
5317 -- [Deep_]Finalize (Obj_Ref);
5319 -- Note that the statements are inserted in reverse order to
5320 -- achieve the desired final order outlined above.
5323 Prepend_To
(Blk_Stmts
, Fin_Call
);
5326 Prepend_To
(Blk_Stmts
, Hook_Clear
);
5329 end Process_Transient_In_Scope
;
5333 Built
: Boolean := False;
5334 Blk_Data
: Finalization_Exception_Data
;
5335 Blk_Decl
: Node_Id
:= Empty
;
5336 Blk_Decls
: List_Id
:= No_List
;
5338 Blk_Stmts
: List_Id
;
5342 -- Start of processing for Process_Transients_In_Scope
5345 -- The expansion performed by this routine is as follows:
5347 -- type Ptr_Typ_1 is access all Ctrl_Trans_Obj_1_Typ;
5348 -- Hook_1 : Ptr_Typ_1 := null;
5349 -- Ctrl_Trans_Obj_1 : ...;
5350 -- Hook_1 := Ctrl_Trans_Obj_1'Unrestricted_Access;
5352 -- type Ptr_Typ_N is access all Ctrl_Trans_Obj_N_Typ;
5353 -- Hook_N : Ptr_Typ_N := null;
5354 -- Ctrl_Trans_Obj_N : ...;
5355 -- Hook_N := Ctrl_Trans_Obj_N'Unrestricted_Access;
5358 -- Abrt : constant Boolean := ...;
5359 -- Ex : Exception_Occurrence;
5360 -- Raised : Boolean := False;
5367 -- [Deep_]Finalize (Ctrl_Trans_Obj_N);
5371 -- if not Raised then
5373 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5378 -- [Deep_]Finalize (Ctrl_Trans_Obj_1);
5382 -- if not Raised then
5384 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
5389 -- if Raised and not Abrt then
5390 -- Raise_From_Controlled_Operation (Ex);
5394 -- Recognize a scenario where the transient context is an object
5395 -- declaration initialized by a build-in-place function call:
5397 -- Obj : ... := BIP_Function_Call (Ctrl_Func_Call);
5399 -- The rough expansion of the above is:
5401 -- Temp : ... := Ctrl_Func_Call;
5403 -- Res : ... := BIP_Func_Call (..., Obj, ...);
5405 -- The finalization of any transient object must happen after the
5406 -- build-in-place function call is executed.
5408 if Nkind
(N
) = N_Object_Declaration
5409 and then Present
(BIP_Initialization_Call
(Defining_Identifier
(N
)))
5412 Blk_Ins
:= BIP_Initialization_Call
(Defining_Identifier
(N
));
5414 -- Search the context for at least one subprogram call. If found, the
5415 -- machinery exports all transient objects to the enclosing finalizer
5416 -- due to the possibility of abnormal call termination.
5419 Detect_Subprogram_Call
(N
);
5420 Blk_Ins
:= Last_Object
;
5424 Insert_List_After_And_Analyze
(Blk_Ins
, Act_Cleanup
);
5427 -- Examine all objects in the list First_Object .. Last_Object
5429 Obj_Decl
:= First_Object
;
5430 while Present
(Obj_Decl
) loop
5431 if Nkind
(Obj_Decl
) = N_Object_Declaration
5432 and then Analyzed
(Obj_Decl
)
5433 and then Is_Finalizable_Transient
(Obj_Decl
, N
)
5435 -- Do not process the node to be wrapped since it will be
5436 -- handled by the enclosing finalizer.
5438 and then Obj_Decl
/= Related_Node
5440 Loc
:= Sloc
(Obj_Decl
);
5442 -- Before generating the cleanup code for the first transient
5443 -- object, create a wrapper block which houses all hook clear
5444 -- statements and finalization calls. This wrapper is needed by
5449 Blk_Stmts
:= New_List
;
5452 -- Abrt : constant Boolean := ...;
5453 -- Ex : Exception_Occurrence;
5454 -- Raised : Boolean := False;
5456 if Exceptions_OK
then
5457 Blk_Decls
:= New_List
;
5458 Build_Object_Declarations
(Blk_Data
, Blk_Decls
, Loc
);
5462 Make_Block_Statement
(Loc
,
5463 Declarations
=> Blk_Decls
,
5464 Handled_Statement_Sequence
=>
5465 Make_Handled_Sequence_Of_Statements
(Loc
,
5466 Statements
=> Blk_Stmts
));
5469 -- Construct all necessary circuitry to hook and finalize a
5470 -- single transient object.
5472 Process_Transient_In_Scope
5473 (Obj_Decl
=> Obj_Decl
,
5474 Blk_Data
=> Blk_Data
,
5475 Blk_Stmts
=> Blk_Stmts
);
5478 -- Terminate the scan after the last object has been processed to
5479 -- avoid touching unrelated code.
5481 if Obj_Decl
= Last_Object
then
5488 -- Complete the decoration of the enclosing finalization block and
5489 -- insert it into the tree.
5491 if Present
(Blk_Decl
) then
5493 -- Note that this Abort_Undefer does not require a extra block or
5494 -- an AT_END handler because each finalization exception is caught
5495 -- in its own corresponding finalization block. As a result, the
5496 -- call to Abort_Defer always takes place.
5498 if Abort_Allowed
then
5499 Prepend_To
(Blk_Stmts
,
5500 Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5502 Append_To
(Blk_Stmts
,
5503 Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5507 -- if Raised and then not Abrt then
5508 -- Raise_From_Controlled_Operation (Ex);
5511 if Exceptions_OK
then
5512 Append_To
(Blk_Stmts
, Build_Raise_Statement
(Blk_Data
));
5515 Insert_After_And_Analyze
(Blk_Ins
, Blk_Decl
);
5517 end Process_Transients_In_Scope
;
5521 Loc
: constant Source_Ptr
:= Sloc
(N
);
5522 Node_To_Wrap
: constant Node_Id
:= Node_To_Be_Wrapped
;
5523 First_Obj
: Node_Id
;
5525 Mark_Id
: Entity_Id
;
5528 -- Start of processing for Insert_Actions_In_Scope_Around
5531 -- Nothing to do if the scope does not manage the secondary stack or
5532 -- does not contain meaninful actions for insertion.
5535 and then No
(Act_Before
)
5536 and then No
(Act_After
)
5537 and then No
(Act_Cleanup
)
5542 -- If the node to be wrapped is the trigger of an asynchronous select,
5543 -- it is not part of a statement list. The actions must be inserted
5544 -- before the select itself, which is part of some list of statements.
5545 -- Note that the triggering alternative includes the triggering
5546 -- statement and an optional statement list. If the node to be
5547 -- wrapped is part of that list, the normal insertion applies.
5549 if Nkind
(Parent
(Node_To_Wrap
)) = N_Triggering_Alternative
5550 and then not Is_List_Member
(Node_To_Wrap
)
5552 Target
:= Parent
(Parent
(Node_To_Wrap
));
5557 First_Obj
:= Target
;
5560 -- Add all actions associated with a transient scope into the main tree.
5561 -- There are several scenarios here:
5563 -- +--- Before ----+ +----- After ---+
5564 -- 1) First_Obj ....... Target ........ Last_Obj
5566 -- 2) First_Obj ....... Target
5568 -- 3) Target ........ Last_Obj
5570 -- Flag declarations are inserted before the first object
5572 if Present
(Act_Before
) then
5573 First_Obj
:= First
(Act_Before
);
5574 Insert_List_Before
(Target
, Act_Before
);
5577 -- Finalization calls are inserted after the last object
5579 if Present
(Act_After
) then
5580 Last_Obj
:= Last
(Act_After
);
5581 Insert_List_After
(Target
, Act_After
);
5584 -- Mark and release the secondary stack when the context warrants it
5587 Mark_Id
:= Make_Temporary
(Loc
, 'M');
5590 -- Mnn : constant Mark_Id := SS_Mark;
5592 Insert_Before_And_Analyze
5593 (First_Obj
, Build_SS_Mark_Call
(Loc
, Mark_Id
));
5596 -- SS_Release (Mnn);
5598 Insert_After_And_Analyze
5599 (Last_Obj
, Build_SS_Release_Call
(Loc
, Mark_Id
));
5602 -- Check for transient objects associated with Target and generate the
5603 -- appropriate finalization actions for them.
5605 Process_Transients_In_Scope
5606 (First_Object
=> First_Obj
,
5607 Last_Object
=> Last_Obj
,
5608 Related_Node
=> Target
);
5610 -- Reset the action lists
5613 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Before
) := No_List
;
5615 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(After
) := No_List
;
5619 (Scope_Stack
.Last
).Actions_To_Be_Wrapped
(Cleanup
) := No_List
;
5621 end Insert_Actions_In_Scope_Around
;
5623 ------------------------------
5624 -- Is_Simple_Protected_Type --
5625 ------------------------------
5627 function Is_Simple_Protected_Type
(T
: Entity_Id
) return Boolean is
5630 Is_Protected_Type
(T
)
5631 and then not Uses_Lock_Free
(T
)
5632 and then not Has_Entries
(T
)
5633 and then Is_RTE
(Find_Protection_Type
(T
), RE_Protection
);
5634 end Is_Simple_Protected_Type
;
5636 -----------------------
5637 -- Make_Adjust_Call --
5638 -----------------------
5640 function Make_Adjust_Call
5643 Skip_Self
: Boolean := False) return Node_Id
5645 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5646 Adj_Id
: Entity_Id
:= Empty
;
5653 -- Recover the proper type which contains Deep_Adjust
5655 if Is_Class_Wide_Type
(Typ
) then
5656 Utyp
:= Root_Type
(Typ
);
5661 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
5662 Set_Assignment_OK
(Ref
);
5664 -- Deal with untagged derivation of private views
5666 if Present
(Utyp
) and then Is_Untagged_Derivation
(Typ
) then
5667 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
5668 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5669 Set_Assignment_OK
(Ref
);
5672 -- When dealing with the completion of a private type, use the base
5675 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
5676 pragma Assert
(Is_Private_Type
(Typ
));
5678 Utyp
:= Base_Type
(Utyp
);
5679 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
5682 -- The underlying type may not be present due to a missing full view. In
5683 -- this case freezing did not take place and there is no [Deep_]Adjust
5684 -- primitive to call.
5689 elsif Skip_Self
then
5690 if Has_Controlled_Component
(Utyp
) then
5691 if Is_Tagged_Type
(Utyp
) then
5692 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5694 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5698 -- Class-wide types, interfaces and types with controlled components
5700 elsif Is_Class_Wide_Type
(Typ
)
5701 or else Is_Interface
(Typ
)
5702 or else Has_Controlled_Component
(Utyp
)
5704 if Is_Tagged_Type
(Utyp
) then
5705 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5707 Adj_Id
:= TSS
(Utyp
, TSS_Deep_Adjust
);
5710 -- Derivations from [Limited_]Controlled
5712 elsif Is_Controlled
(Utyp
) then
5713 if Has_Controlled_Component
(Utyp
) then
5714 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5716 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Adjust_Case
));
5721 elsif Is_Tagged_Type
(Utyp
) then
5722 Adj_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Adjust
);
5725 raise Program_Error
;
5728 if Present
(Adj_Id
) then
5730 -- If the object is unanalyzed, set its expected type for use in
5731 -- Convert_View in case an additional conversion is needed.
5734 and then Nkind
(Ref
) /= N_Unchecked_Type_Conversion
5736 Set_Etype
(Ref
, Typ
);
5739 -- The object reference may need another conversion depending on the
5740 -- type of the formal and that of the actual.
5742 if not Is_Class_Wide_Type
(Typ
) then
5743 Ref
:= Convert_View
(Adj_Id
, Ref
);
5750 Skip_Self
=> Skip_Self
);
5754 end Make_Adjust_Call
;
5756 ----------------------
5757 -- Make_Detach_Call --
5758 ----------------------
5760 function Make_Detach_Call
(Obj_Ref
: Node_Id
) return Node_Id
is
5761 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
5765 Make_Procedure_Call_Statement
(Loc
,
5767 New_Occurrence_Of
(RTE
(RE_Detach
), Loc
),
5768 Parameter_Associations
=> New_List
(
5769 Unchecked_Convert_To
(RTE
(RE_Root_Controlled_Ptr
), Obj_Ref
)));
5770 end Make_Detach_Call
;
5778 Proc_Id
: Entity_Id
;
5780 Skip_Self
: Boolean := False) return Node_Id
5782 Params
: constant List_Id
:= New_List
(Param
);
5785 -- Do not apply the controlled action to the object itself by signaling
5786 -- the related routine to avoid self.
5789 Append_To
(Params
, New_Occurrence_Of
(Standard_False
, Loc
));
5793 Make_Procedure_Call_Statement
(Loc
,
5794 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
5795 Parameter_Associations
=> Params
);
5798 --------------------------
5799 -- Make_Deep_Array_Body --
5800 --------------------------
5802 function Make_Deep_Array_Body
5803 (Prim
: Final_Primitives
;
5804 Typ
: Entity_Id
) return List_Id
5806 Exceptions_OK
: constant Boolean := Exceptions_In_Finalization_OK
;
5808 function Build_Adjust_Or_Finalize_Statements
5809 (Typ
: Entity_Id
) return List_Id
;
5810 -- Create the statements necessary to adjust or finalize an array of
5811 -- controlled elements. Generate:
5814 -- Abort : constant Boolean := Triggered_By_Abort;
5816 -- Abort : constant Boolean := False; -- no abort
5818 -- E : Exception_Occurrence;
5819 -- Raised : Boolean := False;
5822 -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
5823 -- ^-- in the finalization case
5825 -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
5827 -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
5831 -- if not Raised then
5833 -- Save_Occurrence (E, Get_Current_Excep.all.all);
5840 -- if Raised and then not Abort then
5841 -- Raise_From_Controlled_Operation (E);
5845 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
;
5846 -- Create the statements necessary to initialize an array of controlled
5847 -- elements. Include a mechanism to carry out partial finalization if an
5848 -- exception occurs. Generate:
5851 -- Counter : Integer := 0;
5854 -- for J1 in V'Range (1) loop
5856 -- for JN in V'Range (N) loop
5858 -- [Deep_]Initialize (V (J1, ..., JN));
5860 -- Counter := Counter + 1;
5865 -- Abort : constant Boolean := Triggered_By_Abort;
5867 -- Abort : constant Boolean := False; -- no abort
5868 -- E : Exception_Occurrence;
5869 -- Raised : Boolean := False;
5876 -- V'Length (N) - Counter;
5878 -- for F1 in reverse V'Range (1) loop
5880 -- for FN in reverse V'Range (N) loop
5881 -- if Counter > 0 then
5882 -- Counter := Counter - 1;
5885 -- [Deep_]Finalize (V (F1, ..., FN));
5889 -- if not Raised then
5891 -- Save_Occurrence (E,
5892 -- Get_Current_Excep.all.all);
5901 -- if Raised and then not Abort then
5902 -- Raise_From_Controlled_Operation (E);
5911 function New_References_To
5913 Loc
: Source_Ptr
) return List_Id
;
5914 -- Given a list of defining identifiers, return a list of references to
5915 -- the original identifiers, in the same order as they appear.
5917 -----------------------------------------
5918 -- Build_Adjust_Or_Finalize_Statements --
5919 -----------------------------------------
5921 function Build_Adjust_Or_Finalize_Statements
5922 (Typ
: Entity_Id
) return List_Id
5924 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
5925 Index_List
: constant List_Id
:= New_List
;
5926 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
5927 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
5929 procedure Build_Indexes
;
5930 -- Generate the indexes used in the dimension loops
5936 procedure Build_Indexes
is
5938 -- Generate the following identifiers:
5939 -- Jnn - for initialization
5941 for Dim
in 1 .. Num_Dims
loop
5942 Append_To
(Index_List
,
5943 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
5949 Final_Decls
: List_Id
:= No_List
;
5950 Final_Data
: Finalization_Exception_Data
;
5954 Core_Loop
: Node_Id
;
5957 Loop_Id
: Entity_Id
;
5960 -- Start of processing for Build_Adjust_Or_Finalize_Statements
5963 Final_Decls
:= New_List
;
5966 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
5969 Make_Indexed_Component
(Loc
,
5970 Prefix
=> Make_Identifier
(Loc
, Name_V
),
5971 Expressions
=> New_References_To
(Index_List
, Loc
));
5972 Set_Etype
(Comp_Ref
, Comp_Typ
);
5975 -- [Deep_]Adjust (V (J1, ..., JN))
5977 if Prim
= Adjust_Case
then
5978 Call
:= Make_Adjust_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5981 -- [Deep_]Finalize (V (J1, ..., JN))
5983 else pragma Assert
(Prim
= Finalize_Case
);
5984 Call
:= Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
5987 if Present
(Call
) then
5989 -- Generate the block which houses the adjust or finalize call:
5992 -- <adjust or finalize call>
5996 -- if not Raised then
5998 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6002 if Exceptions_OK
then
6004 Make_Block_Statement
(Loc
,
6005 Handled_Statement_Sequence
=>
6006 Make_Handled_Sequence_Of_Statements
(Loc
,
6007 Statements
=> New_List
(Call
),
6008 Exception_Handlers
=> New_List
(
6009 Build_Exception_Handler
(Final_Data
))));
6014 -- Generate the dimension loops starting from the innermost one
6016 -- for Jnn in [reverse] V'Range (Dim) loop
6020 J
:= Last
(Index_List
);
6022 while Present
(J
) and then Dim
> 0 loop
6028 Make_Loop_Statement
(Loc
,
6030 Make_Iteration_Scheme
(Loc
,
6031 Loop_Parameter_Specification
=>
6032 Make_Loop_Parameter_Specification
(Loc
,
6033 Defining_Identifier
=> Loop_Id
,
6034 Discrete_Subtype_Definition
=>
6035 Make_Attribute_Reference
(Loc
,
6036 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6037 Attribute_Name
=> Name_Range
,
6038 Expressions
=> New_List
(
6039 Make_Integer_Literal
(Loc
, Dim
))),
6042 Prim
= Finalize_Case
)),
6044 Statements
=> New_List
(Core_Loop
),
6045 End_Label
=> Empty
);
6050 -- Generate the block which contains the core loop, declarations
6051 -- of the abort flag, the exception occurrence, the raised flag
6052 -- and the conditional raise:
6055 -- Abort : constant Boolean := Triggered_By_Abort;
6057 -- Abort : constant Boolean := False; -- no abort
6059 -- E : Exception_Occurrence;
6060 -- Raised : Boolean := False;
6065 -- if Raised and then not Abort then
6066 -- Raise_From_Controlled_Operation (E);
6070 Stmts
:= New_List
(Core_Loop
);
6072 if Exceptions_OK
then
6073 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6077 Make_Block_Statement
(Loc
,
6078 Declarations
=> Final_Decls
,
6079 Handled_Statement_Sequence
=>
6080 Make_Handled_Sequence_Of_Statements
(Loc
,
6081 Statements
=> Stmts
));
6083 -- Otherwise previous errors or a missing full view may prevent the
6084 -- proper freezing of the component type. If this is the case, there
6085 -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
6088 Block
:= Make_Null_Statement
(Loc
);
6091 return New_List
(Block
);
6092 end Build_Adjust_Or_Finalize_Statements
;
6094 ---------------------------------
6095 -- Build_Initialize_Statements --
6096 ---------------------------------
6098 function Build_Initialize_Statements
(Typ
: Entity_Id
) return List_Id
is
6099 Comp_Typ
: constant Entity_Id
:= Component_Type
(Typ
);
6100 Final_List
: constant List_Id
:= New_List
;
6101 Index_List
: constant List_Id
:= New_List
;
6102 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6103 Num_Dims
: constant Int
:= Number_Dimensions
(Typ
);
6105 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
;
6106 -- Generate the following assignment:
6107 -- Counter := V'Length (1) *
6109 -- V'Length (N) - Counter;
6111 -- Counter_Id denotes the entity of the counter.
6113 function Build_Finalization_Call
return Node_Id
;
6114 -- Generate a deep finalization call for an array element
6116 procedure Build_Indexes
;
6117 -- Generate the initialization and finalization indexes used in the
6120 function Build_Initialization_Call
return Node_Id
;
6121 -- Generate a deep initialization call for an array element
6123 ----------------------
6124 -- Build_Assignment --
6125 ----------------------
6127 function Build_Assignment
(Counter_Id
: Entity_Id
) return Node_Id
is
6132 -- Start from the first dimension and generate:
6137 Make_Attribute_Reference
(Loc
,
6138 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6139 Attribute_Name
=> Name_Length
,
6140 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, Dim
)));
6142 -- Process the rest of the dimensions, generate:
6143 -- Expr * V'Length (N)
6146 while Dim
<= Num_Dims
loop
6148 Make_Op_Multiply
(Loc
,
6151 Make_Attribute_Reference
(Loc
,
6152 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6153 Attribute_Name
=> Name_Length
,
6154 Expressions
=> New_List
(
6155 Make_Integer_Literal
(Loc
, Dim
))));
6161 -- Counter := Expr - Counter;
6164 Make_Assignment_Statement
(Loc
,
6165 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6167 Make_Op_Subtract
(Loc
,
6169 Right_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
)));
6170 end Build_Assignment
;
6172 -----------------------------
6173 -- Build_Finalization_Call --
6174 -----------------------------
6176 function Build_Finalization_Call
return Node_Id
is
6177 Comp_Ref
: constant Node_Id
:=
6178 Make_Indexed_Component
(Loc
,
6179 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6180 Expressions
=> New_References_To
(Final_List
, Loc
));
6183 Set_Etype
(Comp_Ref
, Comp_Typ
);
6186 -- [Deep_]Finalize (V);
6188 return Make_Final_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6189 end Build_Finalization_Call
;
6195 procedure Build_Indexes
is
6197 -- Generate the following identifiers:
6198 -- Jnn - for initialization
6199 -- Fnn - for finalization
6201 for Dim
in 1 .. Num_Dims
loop
6202 Append_To
(Index_List
,
6203 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
)));
6205 Append_To
(Final_List
,
6206 Make_Defining_Identifier
(Loc
, New_External_Name
('F', Dim
)));
6210 -------------------------------
6211 -- Build_Initialization_Call --
6212 -------------------------------
6214 function Build_Initialization_Call
return Node_Id
is
6215 Comp_Ref
: constant Node_Id
:=
6216 Make_Indexed_Component
(Loc
,
6217 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6218 Expressions
=> New_References_To
(Index_List
, Loc
));
6221 Set_Etype
(Comp_Ref
, Comp_Typ
);
6224 -- [Deep_]Initialize (V (J1, ..., JN));
6226 return Make_Init_Call
(Obj_Ref
=> Comp_Ref
, Typ
=> Comp_Typ
);
6227 end Build_Initialization_Call
;
6231 Counter_Id
: Entity_Id
;
6235 Final_Block
: Node_Id
;
6236 Final_Data
: Finalization_Exception_Data
;
6237 Final_Decls
: List_Id
:= No_List
;
6238 Final_Loop
: Node_Id
;
6239 Init_Block
: Node_Id
;
6240 Init_Call
: Node_Id
;
6241 Init_Loop
: Node_Id
;
6246 -- Start of processing for Build_Initialize_Statements
6249 Counter_Id
:= Make_Temporary
(Loc
, 'C');
6250 Final_Decls
:= New_List
;
6253 Build_Object_Declarations
(Final_Data
, Final_Decls
, Loc
);
6255 -- Generate the block which houses the finalization call, the index
6256 -- guard and the handler which triggers Program_Error later on.
6258 -- if Counter > 0 then
6259 -- Counter := Counter - 1;
6262 -- [Deep_]Finalize (V (F1, ..., FN));
6265 -- if not Raised then
6267 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6272 Fin_Stmt
:= Build_Finalization_Call
;
6274 if Present
(Fin_Stmt
) then
6275 if Exceptions_OK
then
6277 Make_Block_Statement
(Loc
,
6278 Handled_Statement_Sequence
=>
6279 Make_Handled_Sequence_Of_Statements
(Loc
,
6280 Statements
=> New_List
(Fin_Stmt
),
6281 Exception_Handlers
=> New_List
(
6282 Build_Exception_Handler
(Final_Data
))));
6285 -- This is the core of the loop, the dimension iterators are added
6286 -- one by one in reverse.
6289 Make_If_Statement
(Loc
,
6292 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6293 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
6295 Then_Statements
=> New_List
(
6296 Make_Assignment_Statement
(Loc
,
6297 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6299 Make_Op_Subtract
(Loc
,
6300 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6301 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
6303 Else_Statements
=> New_List
(Fin_Stmt
));
6305 -- Generate all finalization loops starting from the innermost
6308 -- for Fnn in reverse V'Range (Dim) loop
6312 F
:= Last
(Final_List
);
6314 while Present
(F
) and then Dim
> 0 loop
6320 Make_Loop_Statement
(Loc
,
6322 Make_Iteration_Scheme
(Loc
,
6323 Loop_Parameter_Specification
=>
6324 Make_Loop_Parameter_Specification
(Loc
,
6325 Defining_Identifier
=> Loop_Id
,
6326 Discrete_Subtype_Definition
=>
6327 Make_Attribute_Reference
(Loc
,
6328 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6329 Attribute_Name
=> Name_Range
,
6330 Expressions
=> New_List
(
6331 Make_Integer_Literal
(Loc
, Dim
))),
6333 Reverse_Present
=> True)),
6335 Statements
=> New_List
(Final_Loop
),
6336 End_Label
=> Empty
);
6341 -- Generate the block which contains the finalization loops, the
6342 -- declarations of the abort flag, the exception occurrence, the
6343 -- raised flag and the conditional raise.
6346 -- Abort : constant Boolean := Triggered_By_Abort;
6348 -- Abort : constant Boolean := False; -- no abort
6350 -- E : Exception_Occurrence;
6351 -- Raised : Boolean := False;
6357 -- V'Length (N) - Counter;
6361 -- if Raised and then not Abort then
6362 -- Raise_From_Controlled_Operation (E);
6368 Stmts
:= New_List
(Build_Assignment
(Counter_Id
), Final_Loop
);
6370 if Exceptions_OK
then
6371 Append_To
(Stmts
, Build_Raise_Statement
(Final_Data
));
6372 Append_To
(Stmts
, Make_Raise_Statement
(Loc
));
6376 Make_Block_Statement
(Loc
,
6377 Declarations
=> Final_Decls
,
6378 Handled_Statement_Sequence
=>
6379 Make_Handled_Sequence_Of_Statements
(Loc
,
6380 Statements
=> Stmts
));
6382 -- Otherwise previous errors or a missing full view may prevent the
6383 -- proper freezing of the component type. If this is the case, there
6384 -- is no [Deep_]Finalize primitive to call.
6387 Final_Block
:= Make_Null_Statement
(Loc
);
6390 -- Generate the block which contains the initialization call and
6391 -- the partial finalization code.
6394 -- [Deep_]Initialize (V (J1, ..., JN));
6396 -- Counter := Counter + 1;
6400 -- <finalization code>
6403 Init_Call
:= Build_Initialization_Call
;
6405 -- Only create finalization block if there is a non-trivial
6406 -- call to initialization.
6408 if Present
(Init_Call
)
6409 and then Nkind
(Init_Call
) /= N_Null_Statement
6412 Make_Block_Statement
(Loc
,
6413 Handled_Statement_Sequence
=>
6414 Make_Handled_Sequence_Of_Statements
(Loc
,
6415 Statements
=> New_List
(Init_Call
),
6416 Exception_Handlers
=> New_List
(
6417 Make_Exception_Handler
(Loc
,
6418 Exception_Choices
=> New_List
(
6419 Make_Others_Choice
(Loc
)),
6420 Statements
=> New_List
(Final_Block
)))));
6422 Append_To
(Statements
(Handled_Statement_Sequence
(Init_Loop
)),
6423 Make_Assignment_Statement
(Loc
,
6424 Name
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6427 Left_Opnd
=> New_Occurrence_Of
(Counter_Id
, Loc
),
6428 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
6430 -- Generate all initialization loops starting from the innermost
6433 -- for Jnn in V'Range (Dim) loop
6437 J
:= Last
(Index_List
);
6439 while Present
(J
) and then Dim
> 0 loop
6445 Make_Loop_Statement
(Loc
,
6447 Make_Iteration_Scheme
(Loc
,
6448 Loop_Parameter_Specification
=>
6449 Make_Loop_Parameter_Specification
(Loc
,
6450 Defining_Identifier
=> Loop_Id
,
6451 Discrete_Subtype_Definition
=>
6452 Make_Attribute_Reference
(Loc
,
6453 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6454 Attribute_Name
=> Name_Range
,
6455 Expressions
=> New_List
(
6456 Make_Integer_Literal
(Loc
, Dim
))))),
6458 Statements
=> New_List
(Init_Loop
),
6459 End_Label
=> Empty
);
6464 -- Generate the block which contains the counter variable and the
6465 -- initialization loops.
6468 -- Counter : Integer := 0;
6474 Make_Block_Statement
(Loc
,
6475 Declarations
=> New_List
(
6476 Make_Object_Declaration
(Loc
,
6477 Defining_Identifier
=> Counter_Id
,
6478 Object_Definition
=>
6479 New_Occurrence_Of
(Standard_Integer
, Loc
),
6480 Expression
=> Make_Integer_Literal
(Loc
, 0))),
6482 Handled_Statement_Sequence
=>
6483 Make_Handled_Sequence_Of_Statements
(Loc
,
6484 Statements
=> New_List
(Init_Loop
)));
6486 -- Otherwise previous errors or a missing full view may prevent the
6487 -- proper freezing of the component type. If this is the case, there
6488 -- is no [Deep_]Initialize primitive to call.
6491 Init_Block
:= Make_Null_Statement
(Loc
);
6494 return New_List
(Init_Block
);
6495 end Build_Initialize_Statements
;
6497 -----------------------
6498 -- New_References_To --
6499 -----------------------
6501 function New_References_To
6503 Loc
: Source_Ptr
) return List_Id
6505 Refs
: constant List_Id
:= New_List
;
6510 while Present
(Id
) loop
6511 Append_To
(Refs
, New_Occurrence_Of
(Id
, Loc
));
6516 end New_References_To
;
6518 -- Start of processing for Make_Deep_Array_Body
6522 when Address_Case
=>
6523 return Make_Finalize_Address_Stmts
(Typ
);
6528 return Build_Adjust_Or_Finalize_Statements
(Typ
);
6530 when Initialize_Case
=>
6531 return Build_Initialize_Statements
(Typ
);
6533 end Make_Deep_Array_Body
;
6535 --------------------
6536 -- Make_Deep_Proc --
6537 --------------------
6539 function Make_Deep_Proc
6540 (Prim
: Final_Primitives
;
6542 Stmts
: List_Id
) return Entity_Id
6544 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6546 Proc_Id
: Entity_Id
;
6549 -- Create the object formal, generate:
6550 -- V : System.Address
6552 if Prim
= Address_Case
then
6553 Formals
:= New_List
(
6554 Make_Parameter_Specification
(Loc
,
6555 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6557 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6564 Formals
:= New_List
(
6565 Make_Parameter_Specification
(Loc
,
6566 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
6568 Out_Present
=> True,
6569 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)));
6571 -- F : Boolean := True
6573 if Prim
= Adjust_Case
6574 or else Prim
= Finalize_Case
6577 Make_Parameter_Specification
(Loc
,
6578 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
6580 New_Occurrence_Of
(Standard_Boolean
, Loc
),
6582 New_Occurrence_Of
(Standard_True
, Loc
)));
6587 Make_Defining_Identifier
(Loc
,
6588 Chars
=> Make_TSS_Name
(Typ
, Deep_Name_Of
(Prim
)));
6591 -- procedure Deep_Initialize / Adjust / Finalize (V : in out <typ>) is
6594 -- exception -- Finalize and Adjust cases only
6595 -- raise Program_Error;
6596 -- end Deep_Initialize / Adjust / Finalize;
6600 -- procedure Finalize_Address (V : System.Address) is
6603 -- end Finalize_Address;
6606 Make_Subprogram_Body
(Loc
,
6608 Make_Procedure_Specification
(Loc
,
6609 Defining_Unit_Name
=> Proc_Id
,
6610 Parameter_Specifications
=> Formals
),
6612 Declarations
=> Empty_List
,
6614 Handled_Statement_Sequence
=>
6615 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)));
6617 -- If there are no calls to component initialization, indicate that
6618 -- the procedure is trivial, so prevent calls to it.
6620 if Is_Empty_List
(Stmts
)
6621 or else Nkind
(First
(Stmts
)) = N_Null_Statement
6623 Set_Is_Trivial_Subprogram
(Proc_Id
);
6629 ---------------------------
6630 -- Make_Deep_Record_Body --
6631 ---------------------------
6633 function Make_Deep_Record_Body
6634 (Prim
: Final_Primitives
;
6636 Is_Local
: Boolean := False) return List_Id
6638 Exceptions_OK
: constant Boolean := Exceptions_In_Finalization_OK
;
6640 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
;
6641 -- Build the statements necessary to adjust a record type. The type may
6642 -- have discriminants and contain variant parts. Generate:
6646 -- [Deep_]Adjust (V.Comp_1);
6648 -- when Id : others =>
6649 -- if not Raised then
6651 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6656 -- [Deep_]Adjust (V.Comp_N);
6658 -- when Id : others =>
6659 -- if not Raised then
6661 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6666 -- Deep_Adjust (V._parent, False); -- If applicable
6668 -- when Id : others =>
6669 -- if not Raised then
6671 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6677 -- Adjust (V); -- If applicable
6680 -- if not Raised then
6682 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6687 -- if Raised and then not Abort then
6688 -- Raise_From_Controlled_Operation (E);
6692 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
;
6693 -- Build the statements necessary to finalize a record type. The type
6694 -- may have discriminants and contain variant parts. Generate:
6697 -- Abort : constant Boolean := Triggered_By_Abort;
6699 -- Abort : constant Boolean := False; -- no abort
6700 -- E : Exception_Occurrence;
6701 -- Raised : Boolean := False;
6706 -- Finalize (V); -- If applicable
6709 -- if not Raised then
6711 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6716 -- case Variant_1 is
6718 -- case State_Counter_N => -- If Is_Local is enabled
6728 -- <<LN>> -- If Is_Local is enabled
6730 -- [Deep_]Finalize (V.Comp_N);
6733 -- if not Raised then
6735 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6741 -- [Deep_]Finalize (V.Comp_1);
6744 -- if not Raised then
6746 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6752 -- case State_Counter_1 => -- If Is_Local is enabled
6758 -- Deep_Finalize (V._parent, False); -- If applicable
6760 -- when Id : others =>
6761 -- if not Raised then
6763 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6767 -- if Raised and then not Abort then
6768 -- Raise_From_Controlled_Operation (E);
6772 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
;
6773 -- Given a derived tagged type Typ, traverse all components, find field
6774 -- _parent and return its type.
6776 procedure Preprocess_Components
6778 Num_Comps
: out Nat
;
6779 Has_POC
: out Boolean);
6780 -- Examine all components in component list Comps, count all controlled
6781 -- components and determine whether at least one of them is per-object
6782 -- constrained. Component _parent is always skipped.
6784 -----------------------------
6785 -- Build_Adjust_Statements --
6786 -----------------------------
6788 function Build_Adjust_Statements
(Typ
: Entity_Id
) return List_Id
is
6789 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
6790 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
6792 Finalizer_Data
: Finalization_Exception_Data
;
6794 function Process_Component_List_For_Adjust
6795 (Comps
: Node_Id
) return List_Id
;
6796 -- Build all necessary adjust statements for a single component list
6798 ---------------------------------------
6799 -- Process_Component_List_For_Adjust --
6800 ---------------------------------------
6802 function Process_Component_List_For_Adjust
6803 (Comps
: Node_Id
) return List_Id
6805 Stmts
: constant List_Id
:= New_List
;
6807 procedure Process_Component_For_Adjust
(Decl
: Node_Id
);
6808 -- Process the declaration of a single controlled component
6810 ----------------------------------
6811 -- Process_Component_For_Adjust --
6812 ----------------------------------
6814 procedure Process_Component_For_Adjust
(Decl
: Node_Id
) is
6815 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6816 Typ
: constant Entity_Id
:= Etype
(Id
);
6822 -- [Deep_]Adjust (V.Id);
6826 -- if not Raised then
6828 -- Save_Occurrence (E, Get_Current_Excep.all.all);
6835 Make_Selected_Component
(Loc
,
6836 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6837 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
6840 -- Guard against a missing [Deep_]Adjust when the component
6841 -- type was not properly frozen.
6843 if Present
(Adj_Call
) then
6844 if Exceptions_OK
then
6846 Make_Block_Statement
(Loc
,
6847 Handled_Statement_Sequence
=>
6848 Make_Handled_Sequence_Of_Statements
(Loc
,
6849 Statements
=> New_List
(Adj_Call
),
6850 Exception_Handlers
=> New_List
(
6851 Build_Exception_Handler
(Finalizer_Data
))));
6854 Append_To
(Stmts
, Adj_Call
);
6856 end Process_Component_For_Adjust
;
6861 Decl_Id
: Entity_Id
;
6862 Decl_Typ
: Entity_Id
;
6867 -- Start of processing for Process_Component_List_For_Adjust
6870 -- Perform an initial check, determine the number of controlled
6871 -- components in the current list and whether at least one of them
6872 -- is per-object constrained.
6874 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
6876 -- The processing in this routine is done in the following order:
6877 -- 1) Regular components
6878 -- 2) Per-object constrained components
6881 if Num_Comps
> 0 then
6883 -- Process all regular components in order of declarations
6885 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6886 while Present
(Decl
) loop
6887 Decl_Id
:= Defining_Identifier
(Decl
);
6888 Decl_Typ
:= Etype
(Decl_Id
);
6890 -- Skip _parent as well as per-object constrained components
6892 if Chars
(Decl_Id
) /= Name_uParent
6893 and then Needs_Finalization
(Decl_Typ
)
6895 if Has_Access_Constraint
(Decl_Id
)
6896 and then No
(Expression
(Decl
))
6900 Process_Component_For_Adjust
(Decl
);
6904 Next_Non_Pragma
(Decl
);
6907 -- Process all per-object constrained components in order of
6911 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
6912 while Present
(Decl
) loop
6913 Decl_Id
:= Defining_Identifier
(Decl
);
6914 Decl_Typ
:= Etype
(Decl_Id
);
6918 if Chars
(Decl_Id
) /= Name_uParent
6919 and then Needs_Finalization
(Decl_Typ
)
6920 and then Has_Access_Constraint
(Decl_Id
)
6921 and then No
(Expression
(Decl
))
6923 Process_Component_For_Adjust
(Decl
);
6926 Next_Non_Pragma
(Decl
);
6931 -- Process all variants, if any
6934 if Present
(Variant_Part
(Comps
)) then
6936 Var_Alts
: constant List_Id
:= New_List
;
6940 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
6941 while Present
(Var
) loop
6944 -- when <discrete choices> =>
6945 -- <adjust statements>
6947 Append_To
(Var_Alts
,
6948 Make_Case_Statement_Alternative
(Loc
,
6950 New_Copy_List
(Discrete_Choices
(Var
)),
6952 Process_Component_List_For_Adjust
(
6953 Component_List
(Var
))));
6955 Next_Non_Pragma
(Var
);
6959 -- case V.<discriminant> is
6960 -- when <discrete choices 1> =>
6961 -- <adjust statements 1>
6963 -- when <discrete choices N> =>
6964 -- <adjust statements N>
6968 Make_Case_Statement
(Loc
,
6970 Make_Selected_Component
(Loc
,
6971 Prefix
=> Make_Identifier
(Loc
, Name_V
),
6973 Make_Identifier
(Loc
,
6974 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
6975 Alternatives
=> Var_Alts
);
6979 -- Add the variant case statement to the list of statements
6981 if Present
(Var_Case
) then
6982 Append_To
(Stmts
, Var_Case
);
6985 -- If the component list did not have any controlled components
6986 -- nor variants, return null.
6988 if Is_Empty_List
(Stmts
) then
6989 Append_To
(Stmts
, Make_Null_Statement
(Loc
));
6993 end Process_Component_List_For_Adjust
;
6997 Bod_Stmts
: List_Id
:= No_List
;
6998 Finalizer_Decls
: List_Id
:= No_List
;
7001 -- Start of processing for Build_Adjust_Statements
7004 Finalizer_Decls
:= New_List
;
7005 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7007 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7008 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7013 -- Create an adjust sequence for all record components
7015 if Present
(Component_List
(Rec_Def
)) then
7017 Process_Component_List_For_Adjust
(Component_List
(Rec_Def
));
7020 -- A derived record type must adjust all inherited components. This
7021 -- action poses the following problem:
7023 -- procedure Deep_Adjust (Obj : in out Parent_Typ) is
7028 -- procedure Deep_Adjust (Obj : in out Derived_Typ) is
7030 -- Deep_Adjust (Obj._parent);
7035 -- Adjusting the derived type will invoke Adjust of the parent and
7036 -- then that of the derived type. This is undesirable because both
7037 -- routines may modify shared components. Only the Adjust of the
7038 -- derived type should be invoked.
7040 -- To prevent this double adjustment of shared components,
7041 -- Deep_Adjust uses a flag to control the invocation of Adjust:
7043 -- procedure Deep_Adjust
7044 -- (Obj : in out Some_Type;
7045 -- Flag : Boolean := True)
7053 -- When Deep_Adjust is invokes for field _parent, a value of False is
7054 -- provided for the flag:
7056 -- Deep_Adjust (Obj._parent, False);
7058 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7060 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7065 if Needs_Finalization
(Par_Typ
) then
7069 Make_Selected_Component
(Loc
,
7070 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7072 Make_Identifier
(Loc
, Name_uParent
)),
7078 -- Deep_Adjust (V._parent, False);
7081 -- when Id : others =>
7082 -- if not Raised then
7084 -- Save_Occurrence (E,
7085 -- Get_Current_Excep.all.all);
7089 if Present
(Call
) then
7092 if Exceptions_OK
then
7094 Make_Block_Statement
(Loc
,
7095 Handled_Statement_Sequence
=>
7096 Make_Handled_Sequence_Of_Statements
(Loc
,
7097 Statements
=> New_List
(Adj_Stmt
),
7098 Exception_Handlers
=> New_List
(
7099 Build_Exception_Handler
(Finalizer_Data
))));
7102 Prepend_To
(Bod_Stmts
, Adj_Stmt
);
7108 -- Adjust the object. This action must be performed last after all
7109 -- components have been adjusted.
7111 if Is_Controlled
(Typ
) then
7117 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Adjust
);
7126 -- if not Raised then
7128 -- Save_Occurrence (E,
7129 -- Get_Current_Excep.all.all);
7134 if Present
(Proc
) then
7136 Make_Procedure_Call_Statement
(Loc
,
7137 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7138 Parameter_Associations
=> New_List
(
7139 Make_Identifier
(Loc
, Name_V
)));
7141 if Exceptions_OK
then
7143 Make_Block_Statement
(Loc
,
7144 Handled_Statement_Sequence
=>
7145 Make_Handled_Sequence_Of_Statements
(Loc
,
7146 Statements
=> New_List
(Adj_Stmt
),
7147 Exception_Handlers
=> New_List
(
7148 Build_Exception_Handler
7149 (Finalizer_Data
))));
7152 Append_To
(Bod_Stmts
,
7153 Make_If_Statement
(Loc
,
7154 Condition
=> Make_Identifier
(Loc
, Name_F
),
7155 Then_Statements
=> New_List
(Adj_Stmt
)));
7160 -- At this point either all adjustment statements have been generated
7161 -- or the type is not controlled.
7163 if Is_Empty_List
(Bod_Stmts
) then
7164 Append_To
(Bod_Stmts
, Make_Null_Statement
(Loc
));
7170 -- Abort : constant Boolean := Triggered_By_Abort;
7172 -- Abort : constant Boolean := False; -- no abort
7174 -- E : Exception_Occurrence;
7175 -- Raised : Boolean := False;
7178 -- <adjust statements>
7180 -- if Raised and then not Abort then
7181 -- Raise_From_Controlled_Operation (E);
7186 if Exceptions_OK
then
7187 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
7192 Make_Block_Statement
(Loc
,
7195 Handled_Statement_Sequence
=>
7196 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7198 end Build_Adjust_Statements
;
7200 -------------------------------
7201 -- Build_Finalize_Statements --
7202 -------------------------------
7204 function Build_Finalize_Statements
(Typ
: Entity_Id
) return List_Id
is
7205 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7206 Typ_Def
: constant Node_Id
:= Type_Definition
(Parent
(Typ
));
7209 Finalizer_Data
: Finalization_Exception_Data
;
7211 function Process_Component_List_For_Finalize
7212 (Comps
: Node_Id
) return List_Id
;
7213 -- Build all necessary finalization statements for a single component
7214 -- list. The statements may include a jump circuitry if flag Is_Local
7217 -----------------------------------------
7218 -- Process_Component_List_For_Finalize --
7219 -----------------------------------------
7221 function Process_Component_List_For_Finalize
7222 (Comps
: Node_Id
) return List_Id
7224 procedure Process_Component_For_Finalize
7229 Num_Comps
: in out Nat
);
7230 -- Process the declaration of a single controlled component. If
7231 -- flag Is_Local is enabled, create the corresponding label and
7232 -- jump circuitry. Alts is the list of case alternatives, Decls
7233 -- is the top level declaration list where labels are declared
7234 -- and Stmts is the list of finalization actions. Num_Comps
7235 -- denotes the current number of components needing finalization.
7237 ------------------------------------
7238 -- Process_Component_For_Finalize --
7239 ------------------------------------
7241 procedure Process_Component_For_Finalize
7246 Num_Comps
: in out Nat
)
7248 Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
7249 Typ
: constant Entity_Id
:= Etype
(Id
);
7256 Label_Id
: Entity_Id
;
7263 Make_Identifier
(Loc
,
7264 Chars
=> New_External_Name
('L', Num_Comps
));
7265 Set_Entity
(Label_Id
,
7266 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7267 Label
:= Make_Label
(Loc
, Label_Id
);
7270 Make_Implicit_Label_Declaration
(Loc
,
7271 Defining_Identifier
=> Entity
(Label_Id
),
7272 Label_Construct
=> Label
));
7279 Make_Case_Statement_Alternative
(Loc
,
7280 Discrete_Choices
=> New_List
(
7281 Make_Integer_Literal
(Loc
, Num_Comps
)),
7283 Statements
=> New_List
(
7284 Make_Goto_Statement
(Loc
,
7286 New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7291 Append_To
(Stmts
, Label
);
7293 -- Decrease the number of components to be processed.
7294 -- This action yields a new Label_Id in future calls.
7296 Num_Comps
:= Num_Comps
- 1;
7301 -- [Deep_]Finalize (V.Id); -- No_Exception_Propagation
7303 -- begin -- Exception handlers allowed
7304 -- [Deep_]Finalize (V.Id);
7307 -- if not Raised then
7309 -- Save_Occurrence (E,
7310 -- Get_Current_Excep.all.all);
7317 Make_Selected_Component
(Loc
,
7318 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7319 Selector_Name
=> Make_Identifier
(Loc
, Chars
(Id
))),
7322 -- Guard against a missing [Deep_]Finalize when the component
7323 -- type was not properly frozen.
7325 if Present
(Fin_Call
) then
7326 if Exceptions_OK
then
7328 Make_Block_Statement
(Loc
,
7329 Handled_Statement_Sequence
=>
7330 Make_Handled_Sequence_Of_Statements
(Loc
,
7331 Statements
=> New_List
(Fin_Call
),
7332 Exception_Handlers
=> New_List
(
7333 Build_Exception_Handler
(Finalizer_Data
))));
7336 Append_To
(Stmts
, Fin_Call
);
7338 end Process_Component_For_Finalize
;
7343 Counter_Id
: Entity_Id
:= Empty
;
7345 Decl_Id
: Entity_Id
;
7346 Decl_Typ
: Entity_Id
;
7349 Jump_Block
: Node_Id
;
7351 Label_Id
: Entity_Id
;
7356 -- Start of processing for Process_Component_List_For_Finalize
7359 -- Perform an initial check, look for controlled and per-object
7360 -- constrained components.
7362 Preprocess_Components
(Comps
, Num_Comps
, Has_POC
);
7364 -- Create a state counter to service the current component list.
7365 -- This step is performed before the variants are inspected in
7366 -- order to generate the same state counter names as those from
7367 -- Build_Initialize_Statements.
7369 if Num_Comps
> 0 and then Is_Local
then
7370 Counter
:= Counter
+ 1;
7373 Make_Defining_Identifier
(Loc
,
7374 Chars
=> New_External_Name
('C', Counter
));
7377 -- Process the component in the following order:
7379 -- 2) Per-object constrained components
7380 -- 3) Regular components
7382 -- Start with the variant parts
7385 if Present
(Variant_Part
(Comps
)) then
7387 Var_Alts
: constant List_Id
:= New_List
;
7391 Var
:= First_Non_Pragma
(Variants
(Variant_Part
(Comps
)));
7392 while Present
(Var
) loop
7395 -- when <discrete choices> =>
7396 -- <finalize statements>
7398 Append_To
(Var_Alts
,
7399 Make_Case_Statement_Alternative
(Loc
,
7401 New_Copy_List
(Discrete_Choices
(Var
)),
7403 Process_Component_List_For_Finalize
(
7404 Component_List
(Var
))));
7406 Next_Non_Pragma
(Var
);
7410 -- case V.<discriminant> is
7411 -- when <discrete choices 1> =>
7412 -- <finalize statements 1>
7414 -- when <discrete choices N> =>
7415 -- <finalize statements N>
7419 Make_Case_Statement
(Loc
,
7421 Make_Selected_Component
(Loc
,
7422 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7424 Make_Identifier
(Loc
,
7425 Chars
=> Chars
(Name
(Variant_Part
(Comps
))))),
7426 Alternatives
=> Var_Alts
);
7430 -- The current component list does not have a single controlled
7431 -- component, however it may contain variants. Return the case
7432 -- statement for the variants or nothing.
7434 if Num_Comps
= 0 then
7435 if Present
(Var_Case
) then
7436 return New_List
(Var_Case
);
7438 return New_List
(Make_Null_Statement
(Loc
));
7442 -- Prepare all lists
7448 -- Process all per-object constrained components in reverse order
7451 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7452 while Present
(Decl
) loop
7453 Decl_Id
:= Defining_Identifier
(Decl
);
7454 Decl_Typ
:= Etype
(Decl_Id
);
7458 if Chars
(Decl_Id
) /= Name_uParent
7459 and then Needs_Finalization
(Decl_Typ
)
7460 and then Has_Access_Constraint
(Decl_Id
)
7461 and then No
(Expression
(Decl
))
7463 Process_Component_For_Finalize
7464 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7467 Prev_Non_Pragma
(Decl
);
7471 -- Process the rest of the components in reverse order
7473 Decl
:= Last_Non_Pragma
(Component_Items
(Comps
));
7474 while Present
(Decl
) loop
7475 Decl_Id
:= Defining_Identifier
(Decl
);
7476 Decl_Typ
:= Etype
(Decl_Id
);
7480 if Chars
(Decl_Id
) /= Name_uParent
7481 and then Needs_Finalization
(Decl_Typ
)
7483 -- Skip per-object constrained components since they were
7484 -- handled in the above step.
7486 if Has_Access_Constraint
(Decl_Id
)
7487 and then No
(Expression
(Decl
))
7491 Process_Component_For_Finalize
7492 (Decl
, Alts
, Decls
, Stmts
, Num_Comps
);
7496 Prev_Non_Pragma
(Decl
);
7501 -- LN : label; -- If Is_Local is enabled
7506 -- case CounterX is .
7516 -- <<LN>> -- If Is_Local is enabled
7518 -- [Deep_]Finalize (V.CompY);
7520 -- when Id : others =>
7521 -- if not Raised then
7523 -- Save_Occurrence (E,
7524 -- Get_Current_Excep.all.all);
7528 -- <<L0>> -- If Is_Local is enabled
7533 -- Add the declaration of default jump location L0, its
7534 -- corresponding alternative and its place in the statements.
7536 Label_Id
:= Make_Identifier
(Loc
, New_External_Name
('L', 0));
7537 Set_Entity
(Label_Id
,
7538 Make_Defining_Identifier
(Loc
, Chars
(Label_Id
)));
7539 Label
:= Make_Label
(Loc
, Label_Id
);
7541 Append_To
(Decls
, -- declaration
7542 Make_Implicit_Label_Declaration
(Loc
,
7543 Defining_Identifier
=> Entity
(Label_Id
),
7544 Label_Construct
=> Label
));
7546 Append_To
(Alts
, -- alternative
7547 Make_Case_Statement_Alternative
(Loc
,
7548 Discrete_Choices
=> New_List
(
7549 Make_Others_Choice
(Loc
)),
7551 Statements
=> New_List
(
7552 Make_Goto_Statement
(Loc
,
7553 Name
=> New_Occurrence_Of
(Entity
(Label_Id
), Loc
)))));
7555 Append_To
(Stmts
, Label
); -- statement
7557 -- Create the jump block
7560 Make_Case_Statement
(Loc
,
7561 Expression
=> Make_Identifier
(Loc
, Chars
(Counter_Id
)),
7562 Alternatives
=> Alts
));
7566 Make_Block_Statement
(Loc
,
7567 Declarations
=> Decls
,
7568 Handled_Statement_Sequence
=>
7569 Make_Handled_Sequence_Of_Statements
(Loc
, Stmts
));
7571 if Present
(Var_Case
) then
7572 return New_List
(Var_Case
, Jump_Block
);
7574 return New_List
(Jump_Block
);
7576 end Process_Component_List_For_Finalize
;
7580 Bod_Stmts
: List_Id
:= No_List
;
7581 Finalizer_Decls
: List_Id
:= No_List
;
7584 -- Start of processing for Build_Finalize_Statements
7587 Finalizer_Decls
:= New_List
;
7588 Build_Object_Declarations
(Finalizer_Data
, Finalizer_Decls
, Loc
);
7590 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
7591 Rec_Def
:= Record_Extension_Part
(Typ_Def
);
7596 -- Create a finalization sequence for all record components
7598 if Present
(Component_List
(Rec_Def
)) then
7600 Process_Component_List_For_Finalize
(Component_List
(Rec_Def
));
7603 -- A derived record type must finalize all inherited components. This
7604 -- action poses the following problem:
7606 -- procedure Deep_Finalize (Obj : in out Parent_Typ) is
7611 -- procedure Deep_Finalize (Obj : in out Derived_Typ) is
7613 -- Deep_Finalize (Obj._parent);
7618 -- Finalizing the derived type will invoke Finalize of the parent and
7619 -- then that of the derived type. This is undesirable because both
7620 -- routines may modify shared components. Only the Finalize of the
7621 -- derived type should be invoked.
7623 -- To prevent this double adjustment of shared components,
7624 -- Deep_Finalize uses a flag to control the invocation of Finalize:
7626 -- procedure Deep_Finalize
7627 -- (Obj : in out Some_Type;
7628 -- Flag : Boolean := True)
7636 -- When Deep_Finalize is invoked for field _parent, a value of False
7637 -- is provided for the flag:
7639 -- Deep_Finalize (Obj._parent, False);
7641 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7643 Par_Typ
: constant Entity_Id
:= Parent_Field_Type
(Typ
);
7648 if Needs_Finalization
(Par_Typ
) then
7652 Make_Selected_Component
(Loc
,
7653 Prefix
=> Make_Identifier
(Loc
, Name_V
),
7655 Make_Identifier
(Loc
, Name_uParent
)),
7661 -- Deep_Finalize (V._parent, False);
7664 -- when Id : others =>
7665 -- if not Raised then
7667 -- Save_Occurrence (E,
7668 -- Get_Current_Excep.all.all);
7672 if Present
(Call
) then
7675 if Exceptions_OK
then
7677 Make_Block_Statement
(Loc
,
7678 Handled_Statement_Sequence
=>
7679 Make_Handled_Sequence_Of_Statements
(Loc
,
7680 Statements
=> New_List
(Fin_Stmt
),
7681 Exception_Handlers
=> New_List
(
7682 Build_Exception_Handler
7683 (Finalizer_Data
))));
7686 Append_To
(Bod_Stmts
, Fin_Stmt
);
7692 -- Finalize the object. This action must be performed first before
7693 -- all components have been finalized.
7695 if Is_Controlled
(Typ
) and then not Is_Local
then
7701 Proc
:= Find_Optional_Prim_Op
(Typ
, Name_Finalize
);
7710 -- if not Raised then
7712 -- Save_Occurrence (E,
7713 -- Get_Current_Excep.all.all);
7718 if Present
(Proc
) then
7720 Make_Procedure_Call_Statement
(Loc
,
7721 Name
=> New_Occurrence_Of
(Proc
, Loc
),
7722 Parameter_Associations
=> New_List
(
7723 Make_Identifier
(Loc
, Name_V
)));
7725 if Exceptions_OK
then
7727 Make_Block_Statement
(Loc
,
7728 Handled_Statement_Sequence
=>
7729 Make_Handled_Sequence_Of_Statements
(Loc
,
7730 Statements
=> New_List
(Fin_Stmt
),
7731 Exception_Handlers
=> New_List
(
7732 Build_Exception_Handler
7733 (Finalizer_Data
))));
7736 Prepend_To
(Bod_Stmts
,
7737 Make_If_Statement
(Loc
,
7738 Condition
=> Make_Identifier
(Loc
, Name_F
),
7739 Then_Statements
=> New_List
(Fin_Stmt
)));
7744 -- At this point either all finalization statements have been
7745 -- generated or the type is not controlled.
7747 if No
(Bod_Stmts
) then
7748 return New_List
(Make_Null_Statement
(Loc
));
7752 -- Abort : constant Boolean := Triggered_By_Abort;
7754 -- Abort : constant Boolean := False; -- no abort
7756 -- E : Exception_Occurrence;
7757 -- Raised : Boolean := False;
7760 -- <finalize statements>
7762 -- if Raised and then not Abort then
7763 -- Raise_From_Controlled_Operation (E);
7768 if Exceptions_OK
then
7769 Append_To
(Bod_Stmts
, Build_Raise_Statement
(Finalizer_Data
));
7774 Make_Block_Statement
(Loc
,
7777 Handled_Statement_Sequence
=>
7778 Make_Handled_Sequence_Of_Statements
(Loc
, Bod_Stmts
)));
7780 end Build_Finalize_Statements
;
7782 -----------------------
7783 -- Parent_Field_Type --
7784 -----------------------
7786 function Parent_Field_Type
(Typ
: Entity_Id
) return Entity_Id
is
7790 Field
:= First_Entity
(Typ
);
7791 while Present
(Field
) loop
7792 if Chars
(Field
) = Name_uParent
then
7793 return Etype
(Field
);
7796 Next_Entity
(Field
);
7799 -- A derived tagged type should always have a parent field
7801 raise Program_Error
;
7802 end Parent_Field_Type
;
7804 ---------------------------
7805 -- Preprocess_Components --
7806 ---------------------------
7808 procedure Preprocess_Components
7810 Num_Comps
: out Nat
;
7811 Has_POC
: out Boolean)
7821 Decl
:= First_Non_Pragma
(Component_Items
(Comps
));
7822 while Present
(Decl
) loop
7823 Id
:= Defining_Identifier
(Decl
);
7826 -- Skip field _parent
7828 if Chars
(Id
) /= Name_uParent
7829 and then Needs_Finalization
(Typ
)
7831 Num_Comps
:= Num_Comps
+ 1;
7833 if Has_Access_Constraint
(Id
)
7834 and then No
(Expression
(Decl
))
7840 Next_Non_Pragma
(Decl
);
7842 end Preprocess_Components
;
7844 -- Start of processing for Make_Deep_Record_Body
7848 when Address_Case
=>
7849 return Make_Finalize_Address_Stmts
(Typ
);
7852 return Build_Adjust_Statements
(Typ
);
7854 when Finalize_Case
=>
7855 return Build_Finalize_Statements
(Typ
);
7857 when Initialize_Case
=>
7859 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
7862 if Is_Controlled
(Typ
) then
7864 Make_Procedure_Call_Statement
(Loc
,
7867 (Find_Prim_Op
(Typ
, Name_Of
(Prim
)), Loc
),
7868 Parameter_Associations
=> New_List
(
7869 Make_Identifier
(Loc
, Name_V
))));
7875 end Make_Deep_Record_Body
;
7877 ----------------------
7878 -- Make_Final_Call --
7879 ----------------------
7881 function Make_Final_Call
7884 Skip_Self
: Boolean := False) return Node_Id
7886 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
7888 Fin_Id
: Entity_Id
:= Empty
;
7895 -- Recover the proper type which contains [Deep_]Finalize
7897 if Is_Class_Wide_Type
(Typ
) then
7898 Utyp
:= Root_Type
(Typ
);
7901 elsif Is_Concurrent_Type
(Typ
) then
7902 Utyp
:= Corresponding_Record_Type
(Typ
);
7904 Ref
:= Convert_Concurrent
(Ref
, Typ
);
7906 elsif Is_Private_Type
(Typ
)
7907 and then Present
(Full_View
(Typ
))
7908 and then Is_Concurrent_Type
(Full_View
(Typ
))
7910 Utyp
:= Corresponding_Record_Type
(Full_View
(Typ
));
7912 Ref
:= Convert_Concurrent
(Ref
, Full_View
(Typ
));
7919 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
7920 Set_Assignment_OK
(Ref
);
7922 -- Deal with untagged derivation of private views. If the parent type
7923 -- is a protected type, Deep_Finalize is found on the corresponding
7924 -- record of the ancestor.
7926 if Is_Untagged_Derivation
(Typ
) then
7927 if Is_Protected_Type
(Typ
) then
7928 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
7930 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
7932 if Is_Protected_Type
(Utyp
) then
7933 Utyp
:= Corresponding_Record_Type
(Utyp
);
7937 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7938 Set_Assignment_OK
(Ref
);
7941 -- Deal with derived private types which do not inherit primitives from
7942 -- their parents. In this case, [Deep_]Finalize can be found in the full
7943 -- view of the parent type.
7946 and then Is_Tagged_Type
(Utyp
)
7947 and then Is_Derived_Type
(Utyp
)
7948 and then Is_Empty_Elmt_List
(Primitive_Operations
(Utyp
))
7949 and then Is_Private_Type
(Etype
(Utyp
))
7950 and then Present
(Full_View
(Etype
(Utyp
)))
7952 Utyp
:= Full_View
(Etype
(Utyp
));
7953 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7954 Set_Assignment_OK
(Ref
);
7957 -- When dealing with the completion of a private type, use the base type
7960 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
7961 pragma Assert
(Present
(Atyp
) and then Is_Private_Type
(Atyp
));
7963 Utyp
:= Base_Type
(Utyp
);
7964 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
7965 Set_Assignment_OK
(Ref
);
7968 -- The underlying type may not be present due to a missing full view. In
7969 -- this case freezing did not take place and there is no [Deep_]Finalize
7970 -- primitive to call.
7975 elsif Skip_Self
then
7976 if Has_Controlled_Component
(Utyp
) then
7977 if Is_Tagged_Type
(Utyp
) then
7978 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7980 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7984 -- Class-wide types, interfaces and types with controlled components
7986 elsif Is_Class_Wide_Type
(Typ
)
7987 or else Is_Interface
(Typ
)
7988 or else Has_Controlled_Component
(Utyp
)
7990 if Is_Tagged_Type
(Utyp
) then
7991 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
7993 Fin_Id
:= TSS
(Utyp
, TSS_Deep_Finalize
);
7996 -- Derivations from [Limited_]Controlled
7998 elsif Is_Controlled
(Utyp
) then
7999 if Has_Controlled_Component
(Utyp
) then
8000 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8002 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, Name_Of
(Finalize_Case
));
8007 elsif Is_Tagged_Type
(Utyp
) then
8008 Fin_Id
:= Find_Optional_Prim_Op
(Utyp
, TSS_Deep_Finalize
);
8011 raise Program_Error
;
8014 if Present
(Fin_Id
) then
8016 -- When finalizing a class-wide object, do not convert to the root
8017 -- type in order to produce a dispatching call.
8019 if Is_Class_Wide_Type
(Typ
) then
8022 -- Ensure that a finalization routine is at least decorated in order
8023 -- to inspect the object parameter.
8025 elsif Analyzed
(Fin_Id
)
8026 or else Ekind
(Fin_Id
) = E_Procedure
8028 -- In certain cases, such as the creation of Stream_Read, the
8029 -- visible entity of the type is its full view. Since Stream_Read
8030 -- will have to create an object of type Typ, the local object
8031 -- will be finalzed by the scope finalizer generated later on. The
8032 -- object parameter of Deep_Finalize will always use the private
8033 -- view of the type. To avoid such a clash between a private and a
8034 -- full view, perform an unchecked conversion of the object
8035 -- reference to the private view.
8038 Formal_Typ
: constant Entity_Id
:=
8039 Etype
(First_Formal
(Fin_Id
));
8041 if Is_Private_Type
(Formal_Typ
)
8042 and then Present
(Full_View
(Formal_Typ
))
8043 and then Full_View
(Formal_Typ
) = Utyp
8045 Ref
:= Unchecked_Convert_To
(Formal_Typ
, Ref
);
8049 Ref
:= Convert_View
(Fin_Id
, Ref
);
8056 Skip_Self
=> Skip_Self
);
8060 end Make_Final_Call
;
8062 --------------------------------
8063 -- Make_Finalize_Address_Body --
8064 --------------------------------
8066 procedure Make_Finalize_Address_Body
(Typ
: Entity_Id
) is
8067 Is_Task
: constant Boolean :=
8068 Ekind
(Typ
) = E_Record_Type
8069 and then Is_Concurrent_Record_Type
(Typ
)
8070 and then Ekind
(Corresponding_Concurrent_Type
(Typ
)) =
8072 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8073 Proc_Id
: Entity_Id
;
8077 -- The corresponding records of task types are not controlled by design.
8078 -- For the sake of completeness, create an empty Finalize_Address to be
8079 -- used in task class-wide allocations.
8084 -- Nothing to do if the type is not controlled or it already has a
8085 -- TSS entry for Finalize_Address. Skip class-wide subtypes which do not
8086 -- come from source. These are usually generated for completeness and
8087 -- do not need the Finalize_Address primitive.
8089 elsif not Needs_Finalization
(Typ
)
8090 or else Present
(TSS
(Typ
, TSS_Finalize_Address
))
8092 (Is_Class_Wide_Type
(Typ
)
8093 and then Ekind
(Root_Type
(Typ
)) = E_Record_Subtype
8094 and then not Comes_From_Source
(Root_Type
(Typ
)))
8099 -- Do not generate Finalize_Address routine for CodePeer
8101 if CodePeer_Mode
then
8106 Make_Defining_Identifier
(Loc
,
8107 Make_TSS_Name
(Typ
, TSS_Finalize_Address
));
8111 -- procedure <Typ>FD (V : System.Address) is
8113 -- null; -- for tasks
8115 -- declare -- for all other types
8116 -- type Pnn is access all Typ;
8117 -- for Pnn'Storage_Size use 0;
8119 -- [Deep_]Finalize (Pnn (V).all);
8124 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
8126 Stmts
:= Make_Finalize_Address_Stmts
(Typ
);
8130 Make_Subprogram_Body
(Loc
,
8132 Make_Procedure_Specification
(Loc
,
8133 Defining_Unit_Name
=> Proc_Id
,
8135 Parameter_Specifications
=> New_List
(
8136 Make_Parameter_Specification
(Loc
,
8137 Defining_Identifier
=>
8138 Make_Defining_Identifier
(Loc
, Name_V
),
8140 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)))),
8142 Declarations
=> No_List
,
8144 Handled_Statement_Sequence
=>
8145 Make_Handled_Sequence_Of_Statements
(Loc
,
8146 Statements
=> Stmts
)));
8148 Set_TSS
(Typ
, Proc_Id
);
8149 end Make_Finalize_Address_Body
;
8151 ---------------------------------
8152 -- Make_Finalize_Address_Stmts --
8153 ---------------------------------
8155 function Make_Finalize_Address_Stmts
(Typ
: Entity_Id
) return List_Id
is
8156 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8159 Desig_Typ
: Entity_Id
;
8160 Fin_Block
: Node_Id
;
8163 Ptr_Typ
: Entity_Id
;
8166 if Is_Array_Type
(Typ
) then
8167 if Is_Constrained
(First_Subtype
(Typ
)) then
8168 Desig_Typ
:= First_Subtype
(Typ
);
8170 Desig_Typ
:= Base_Type
(Typ
);
8173 -- Class-wide types of constrained root types
8175 elsif Is_Class_Wide_Type
(Typ
)
8176 and then Has_Discriminants
(Root_Type
(Typ
))
8178 Is_Empty_Elmt_List
(Discriminant_Constraint
(Root_Type
(Typ
)))
8181 Parent_Typ
: Entity_Id
;
8184 -- Climb the parent type chain looking for a non-constrained type
8186 Parent_Typ
:= Root_Type
(Typ
);
8187 while Parent_Typ
/= Etype
(Parent_Typ
)
8188 and then Has_Discriminants
(Parent_Typ
)
8190 Is_Empty_Elmt_List
(Discriminant_Constraint
(Parent_Typ
))
8192 Parent_Typ
:= Etype
(Parent_Typ
);
8195 -- Handle views created for tagged types with unknown
8198 if Is_Underlying_Record_View
(Parent_Typ
) then
8199 Parent_Typ
:= Underlying_Record_View
(Parent_Typ
);
8202 Desig_Typ
:= Class_Wide_Type
(Underlying_Type
(Parent_Typ
));
8212 -- type Ptr_Typ is access all Typ;
8213 -- for Ptr_Typ'Storage_Size use 0;
8215 Ptr_Typ
:= Make_Temporary
(Loc
, 'P');
8218 Make_Full_Type_Declaration
(Loc
,
8219 Defining_Identifier
=> Ptr_Typ
,
8221 Make_Access_To_Object_Definition
(Loc
,
8222 All_Present
=> True,
8223 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
))),
8225 Make_Attribute_Definition_Clause
(Loc
,
8226 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8227 Chars
=> Name_Storage_Size
,
8228 Expression
=> Make_Integer_Literal
(Loc
, 0)));
8230 Obj_Expr
:= Make_Identifier
(Loc
, Name_V
);
8232 -- Unconstrained arrays require special processing in order to retrieve
8233 -- the elements. To achieve this, we have to skip the dope vector which
8234 -- lays in front of the elements and then use a thin pointer to perform
8235 -- the address-to-access conversion.
8237 if Is_Array_Type
(Typ
)
8238 and then not Is_Constrained
(First_Subtype
(Typ
))
8241 Dope_Id
: Entity_Id
;
8244 -- Ensure that Ptr_Typ a thin pointer, generate:
8245 -- for Ptr_Typ'Size use System.Address'Size;
8248 Make_Attribute_Definition_Clause
(Loc
,
8249 Name
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
8252 Make_Integer_Literal
(Loc
, System_Address_Size
)));
8255 -- Dnn : constant Storage_Offset :=
8256 -- Desig_Typ'Descriptor_Size / Storage_Unit;
8258 Dope_Id
:= Make_Temporary
(Loc
, 'D');
8261 Make_Object_Declaration
(Loc
,
8262 Defining_Identifier
=> Dope_Id
,
8263 Constant_Present
=> True,
8264 Object_Definition
=>
8265 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
8267 Make_Op_Divide
(Loc
,
8269 Make_Attribute_Reference
(Loc
,
8270 Prefix
=> New_Occurrence_Of
(Desig_Typ
, Loc
),
8271 Attribute_Name
=> Name_Descriptor_Size
),
8273 Make_Integer_Literal
(Loc
, System_Storage_Unit
))));
8275 -- Shift the address from the start of the dope vector to the
8276 -- start of the elements:
8280 -- Note that this is done through a wrapper routine since RTSfind
8281 -- cannot retrieve operations with string names of the form "+".
8284 Make_Function_Call
(Loc
,
8286 New_Occurrence_Of
(RTE
(RE_Add_Offset_To_Address
), Loc
),
8287 Parameter_Associations
=> New_List
(
8289 New_Occurrence_Of
(Dope_Id
, Loc
)));
8296 Make_Explicit_Dereference
(Loc
,
8297 Prefix
=> Unchecked_Convert_To
(Ptr_Typ
, Obj_Expr
)),
8300 if Present
(Fin_Call
) then
8302 Make_Block_Statement
(Loc
,
8303 Declarations
=> Decls
,
8304 Handled_Statement_Sequence
=>
8305 Make_Handled_Sequence_Of_Statements
(Loc
,
8306 Statements
=> New_List
(Fin_Call
)));
8308 -- Otherwise previous errors or a missing full view may prevent the
8309 -- proper freezing of the designated type. If this is the case, there
8310 -- is no [Deep_]Finalize primitive to call.
8313 Fin_Block
:= Make_Null_Statement
(Loc
);
8316 return New_List
(Fin_Block
);
8317 end Make_Finalize_Address_Stmts
;
8319 -------------------------------------
8320 -- Make_Handler_For_Ctrl_Operation --
8321 -------------------------------------
8325 -- when E : others =>
8326 -- Raise_From_Controlled_Operation (E);
8331 -- raise Program_Error [finalize raised exception];
8333 -- depending on whether Raise_From_Controlled_Operation is available
8335 function Make_Handler_For_Ctrl_Operation
8336 (Loc
: Source_Ptr
) return Node_Id
8339 -- Choice parameter (for the first case above)
8341 Raise_Node
: Node_Id
;
8342 -- Procedure call or raise statement
8345 -- Standard run-time: add choice parameter E and pass it to
8346 -- Raise_From_Controlled_Operation so that the original exception
8347 -- name and message can be recorded in the exception message for
8350 if RTE_Available
(RE_Raise_From_Controlled_Operation
) then
8351 E_Occ
:= Make_Defining_Identifier
(Loc
, Name_E
);
8353 Make_Procedure_Call_Statement
(Loc
,
8356 (RTE
(RE_Raise_From_Controlled_Operation
), Loc
),
8357 Parameter_Associations
=> New_List
(
8358 New_Occurrence_Of
(E_Occ
, Loc
)));
8360 -- Restricted run-time: exception messages are not supported
8365 Make_Raise_Program_Error
(Loc
,
8366 Reason
=> PE_Finalize_Raised_Exception
);
8370 Make_Implicit_Exception_Handler
(Loc
,
8371 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8372 Choice_Parameter
=> E_Occ
,
8373 Statements
=> New_List
(Raise_Node
));
8374 end Make_Handler_For_Ctrl_Operation
;
8376 --------------------
8377 -- Make_Init_Call --
8378 --------------------
8380 function Make_Init_Call
8382 Typ
: Entity_Id
) return Node_Id
8384 Loc
: constant Source_Ptr
:= Sloc
(Obj_Ref
);
8393 -- Deal with the type and object reference. Depending on the context, an
8394 -- object reference may need several conversions.
8396 if Is_Concurrent_Type
(Typ
) then
8398 Utyp
:= Corresponding_Record_Type
(Typ
);
8399 Ref
:= Convert_Concurrent
(Ref
, Typ
);
8401 elsif Is_Private_Type
(Typ
)
8402 and then Present
(Full_View
(Typ
))
8403 and then Is_Concurrent_Type
(Underlying_Type
(Typ
))
8406 Utyp
:= Corresponding_Record_Type
(Underlying_Type
(Typ
));
8407 Ref
:= Convert_Concurrent
(Ref
, Underlying_Type
(Typ
));
8414 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
8415 Set_Assignment_OK
(Ref
);
8417 -- Deal with untagged derivation of private views
8419 if Is_Untagged_Derivation
(Typ
) and then not Is_Conc
then
8420 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
8421 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8423 -- The following is to prevent problems with UC see 1.156 RH ???
8425 Set_Assignment_OK
(Ref
);
8428 -- If the underlying_type is a subtype, then we are dealing with the
8429 -- completion of a private type. We need to access the base type and
8430 -- generate a conversion to it.
8432 if Present
(Utyp
) and then Utyp
/= Base_Type
(Utyp
) then
8433 pragma Assert
(Is_Private_Type
(Typ
));
8434 Utyp
:= Base_Type
(Utyp
);
8435 Ref
:= Unchecked_Convert_To
(Utyp
, Ref
);
8438 -- The underlying type may not be present due to a missing full view.
8439 -- In this case freezing did not take place and there is no suitable
8440 -- [Deep_]Initialize primitive to call.
8446 -- Select the appropriate version of initialize
8448 if Has_Controlled_Component
(Utyp
) then
8449 Proc
:= TSS
(Utyp
, Deep_Name_Of
(Initialize_Case
));
8451 Proc
:= Find_Prim_Op
(Utyp
, Name_Of
(Initialize_Case
));
8452 Check_Visibly_Controlled
(Initialize_Case
, Typ
, Proc
, Ref
);
8455 -- If initialization procedure for an array of controlled objects is
8456 -- trivial, do not generate a useless call to it.
8458 if (Is_Array_Type
(Utyp
) and then Is_Trivial_Subprogram
(Proc
))
8460 (not Comes_From_Source
(Proc
)
8461 and then Present
(Alias
(Proc
))
8462 and then Is_Trivial_Subprogram
(Alias
(Proc
)))
8464 return Make_Null_Statement
(Loc
);
8467 -- The object reference may need another conversion depending on the
8468 -- type of the formal and that of the actual.
8470 Ref
:= Convert_View
(Proc
, Ref
);
8473 -- [Deep_]Initialize (Ref);
8476 Make_Procedure_Call_Statement
(Loc
,
8477 Name
=> New_Occurrence_Of
(Proc
, Loc
),
8478 Parameter_Associations
=> New_List
(Ref
));
8481 ------------------------------
8482 -- Make_Local_Deep_Finalize --
8483 ------------------------------
8485 function Make_Local_Deep_Finalize
8487 Nam
: Entity_Id
) return Node_Id
8489 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
8493 Formals
:= New_List
(
8497 Make_Parameter_Specification
(Loc
,
8498 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_V
),
8500 Out_Present
=> True,
8501 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
)),
8503 -- F : Boolean := True
8505 Make_Parameter_Specification
(Loc
,
8506 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_F
),
8507 Parameter_Type
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
8508 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
8510 -- Add the necessary number of counters to represent the initialization
8511 -- state of an object.
8514 Make_Subprogram_Body
(Loc
,
8516 Make_Procedure_Specification
(Loc
,
8517 Defining_Unit_Name
=> Nam
,
8518 Parameter_Specifications
=> Formals
),
8520 Declarations
=> No_List
,
8522 Handled_Statement_Sequence
=>
8523 Make_Handled_Sequence_Of_Statements
(Loc
,
8524 Statements
=> Make_Deep_Record_Body
(Finalize_Case
, Typ
, True)));
8525 end Make_Local_Deep_Finalize
;
8527 ------------------------------------
8528 -- Make_Set_Finalize_Address_Call --
8529 ------------------------------------
8531 function Make_Set_Finalize_Address_Call
8533 Ptr_Typ
: Entity_Id
) return Node_Id
8535 -- It is possible for Ptr_Typ to be a partial view, if the access type
8536 -- is a full view declared in the private part of a nested package, and
8537 -- the finalization actions take place when completing analysis of the
8538 -- enclosing unit. For this reason use Underlying_Type twice below.
8540 Desig_Typ
: constant Entity_Id
:=
8542 (Designated_Type
(Underlying_Type
(Ptr_Typ
)));
8543 Fin_Addr
: constant Entity_Id
:= Finalize_Address
(Desig_Typ
);
8544 Fin_Mas
: constant Entity_Id
:=
8545 Finalization_Master
(Underlying_Type
(Ptr_Typ
));
8548 -- Both the finalization master and primitive Finalize_Address must be
8551 pragma Assert
(Present
(Fin_Addr
) and Present
(Fin_Mas
));
8554 -- Set_Finalize_Address
8555 -- (<Ptr_Typ>FM, <Desig_Typ>FD'Unrestricted_Access);
8558 Make_Procedure_Call_Statement
(Loc
,
8560 New_Occurrence_Of
(RTE
(RE_Set_Finalize_Address
), Loc
),
8561 Parameter_Associations
=> New_List
(
8562 New_Occurrence_Of
(Fin_Mas
, Loc
),
8564 Make_Attribute_Reference
(Loc
,
8565 Prefix
=> New_Occurrence_Of
(Fin_Addr
, Loc
),
8566 Attribute_Name
=> Name_Unrestricted_Access
)));
8567 end Make_Set_Finalize_Address_Call
;
8569 --------------------------
8570 -- Make_Transient_Block --
8571 --------------------------
8573 function Make_Transient_Block
8576 Par
: Node_Id
) return Node_Id
8578 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean;
8579 -- Determine whether scoping entity Id manages the secondary stack
8581 -----------------------
8582 -- Manages_Sec_Stack --
8583 -----------------------
8585 function Manages_Sec_Stack
(Id
: Entity_Id
) return Boolean is
8589 -- An exception handler with a choice parameter utilizes a dummy
8590 -- block to provide a declarative region. Such a block should not
8591 -- be considered because it never manifests in the tree and can
8592 -- never release the secondary stack.
8596 Uses_Sec_Stack
(Id
) and then not Is_Exception_Handler
(Id
);
8603 return Uses_Sec_Stack
(Id
);
8608 end Manages_Sec_Stack
;
8612 Decls
: constant List_Id
:= New_List
;
8613 Instrs
: constant List_Id
:= New_List
(Action
);
8614 Trans_Id
: constant Entity_Id
:= Current_Scope
;
8620 -- Start of processing for Make_Transient_Block
8623 -- Even though the transient block is tasked with managing the secondary
8624 -- stack, the block may forgo this functionality depending on how the
8625 -- secondary stack is managed by enclosing scopes.
8627 if Manages_Sec_Stack
(Trans_Id
) then
8629 -- Determine whether an enclosing scope already manages the secondary
8632 Scop
:= Scope
(Trans_Id
);
8633 while Present
(Scop
) loop
8635 -- It should not be possible to reach Standard without hitting one
8636 -- of the other cases first unless Standard was manually pushed.
8638 if Scop
= Standard_Standard
then
8641 -- The transient block is within a function which returns on the
8642 -- secondary stack. Take a conservative approach and assume that
8643 -- the value on the secondary stack is part of the result. Note
8644 -- that it is not possible to detect this dependency without flow
8645 -- analysis which the compiler does not have. Letting the object
8646 -- live longer than the transient block will not leak any memory
8647 -- because the caller will reclaim the total storage used by the
8650 elsif Ekind
(Scop
) = E_Function
8651 and then Sec_Stack_Needed_For_Return
(Scop
)
8653 Set_Uses_Sec_Stack
(Trans_Id
, False);
8656 -- The transient block must manage the secondary stack when the
8657 -- block appears within a loop in order to reclaim the memory at
8660 elsif Ekind
(Scop
) = E_Loop
then
8663 -- The transient block does not need to manage the secondary stack
8664 -- when there is an enclosing construct which already does that.
8665 -- This optimization saves on SS_Mark and SS_Release calls but may
8666 -- allow objects to live a little longer than required.
8668 -- The transient block must manage the secondary stack when switch
8669 -- -gnatd.s (strict management) is in effect.
8671 elsif Manages_Sec_Stack
(Scop
) and then not Debug_Flag_Dot_S
then
8672 Set_Uses_Sec_Stack
(Trans_Id
, False);
8675 -- Prevent the search from going too far because transient blocks
8676 -- are bounded by packages and subprogram scopes.
8678 elsif Ekind_In
(Scop
, E_Entry
,
8688 Scop
:= Scope
(Scop
);
8692 -- Create the transient block. Set the parent now since the block itself
8693 -- is not part of the tree. The current scope is the E_Block entity that
8694 -- has been pushed by Establish_Transient_Scope.
8696 pragma Assert
(Ekind
(Trans_Id
) = E_Block
);
8699 Make_Block_Statement
(Loc
,
8700 Identifier
=> New_Occurrence_Of
(Trans_Id
, Loc
),
8701 Declarations
=> Decls
,
8702 Handled_Statement_Sequence
=>
8703 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Instrs
),
8704 Has_Created_Identifier
=> True);
8705 Set_Parent
(Block
, Par
);
8707 -- Insert actions stuck in the transient scopes as well as all freezing
8708 -- nodes needed by those actions. Do not insert cleanup actions here,
8709 -- they will be transferred to the newly created block.
8711 Insert_Actions_In_Scope_Around
8712 (Action
, Clean
=> False, Manage_SS
=> False);
8714 Insert
:= Prev
(Action
);
8716 if Present
(Insert
) then
8717 Freeze_All
(First_Entity
(Trans_Id
), Insert
);
8720 -- Transfer cleanup actions to the newly created block
8723 Cleanup_Actions
: List_Id
8724 renames Scope_Stack
.Table
(Scope_Stack
.Last
).
8725 Actions_To_Be_Wrapped
(Cleanup
);
8727 Set_Cleanup_Actions
(Block
, Cleanup_Actions
);
8728 Cleanup_Actions
:= No_List
;
8731 -- When the transient scope was established, we pushed the entry for the
8732 -- transient scope onto the scope stack, so that the scope was active
8733 -- for the installation of finalizable entities etc. Now we must remove
8734 -- this entry, since we have constructed a proper block.
8739 end Make_Transient_Block
;
8741 ------------------------
8742 -- Node_To_Be_Wrapped --
8743 ------------------------
8745 function Node_To_Be_Wrapped
return Node_Id
is
8747 return Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
;
8748 end Node_To_Be_Wrapped
;
8750 ----------------------------
8751 -- Set_Node_To_Be_Wrapped --
8752 ----------------------------
8754 procedure Set_Node_To_Be_Wrapped
(N
: Node_Id
) is
8756 Scope_Stack
.Table
(Scope_Stack
.Last
).Node_To_Be_Wrapped
:= N
;
8757 end Set_Node_To_Be_Wrapped
;
8759 ----------------------------
8760 -- Store_Actions_In_Scope --
8761 ----------------------------
8763 procedure Store_Actions_In_Scope
(AK
: Scope_Action_Kind
; L
: List_Id
) is
8764 SE
: Scope_Stack_Entry
renames Scope_Stack
.Table
(Scope_Stack
.Last
);
8765 Actions
: List_Id
renames SE
.Actions_To_Be_Wrapped
(AK
);
8768 if No
(Actions
) then
8771 if Is_List_Member
(SE
.Node_To_Be_Wrapped
) then
8772 Set_Parent
(L
, Parent
(SE
.Node_To_Be_Wrapped
));
8774 Set_Parent
(L
, SE
.Node_To_Be_Wrapped
);
8779 elsif AK
= Before
then
8780 Insert_List_After_And_Analyze
(Last
(Actions
), L
);
8783 Insert_List_Before_And_Analyze
(First
(Actions
), L
);
8785 end Store_Actions_In_Scope
;
8787 ----------------------------------
8788 -- Store_After_Actions_In_Scope --
8789 ----------------------------------
8791 procedure Store_After_Actions_In_Scope
(L
: List_Id
) is
8793 Store_Actions_In_Scope
(After
, L
);
8794 end Store_After_Actions_In_Scope
;
8796 -----------------------------------
8797 -- Store_Before_Actions_In_Scope --
8798 -----------------------------------
8800 procedure Store_Before_Actions_In_Scope
(L
: List_Id
) is
8802 Store_Actions_In_Scope
(Before
, L
);
8803 end Store_Before_Actions_In_Scope
;
8805 -----------------------------------
8806 -- Store_Cleanup_Actions_In_Scope --
8807 -----------------------------------
8809 procedure Store_Cleanup_Actions_In_Scope
(L
: List_Id
) is
8811 Store_Actions_In_Scope
(Cleanup
, L
);
8812 end Store_Cleanup_Actions_In_Scope
;
8814 --------------------------------
8815 -- Wrap_Transient_Declaration --
8816 --------------------------------
8818 -- If a transient scope has been established during the processing of the
8819 -- Expression of an Object_Declaration, it is not possible to wrap the
8820 -- declaration into a transient block as usual case, otherwise the object
8821 -- would be itself declared in the wrong scope. Therefore, all entities (if
8822 -- any) defined in the transient block are moved to the proper enclosing
8823 -- scope. Furthermore, if they are controlled variables they are finalized
8824 -- right after the declaration. The finalization list of the transient
8825 -- scope is defined as a renaming of the enclosing one so during their
8826 -- initialization they will be attached to the proper finalization list.
8827 -- For instance, the following declaration :
8829 -- X : Typ := F (G (A), G (B));
8831 -- (where G(A) and G(B) return controlled values, expanded as _v1 and _v2)
8832 -- is expanded into :
8834 -- X : Typ := [ complex Expression-Action ];
8835 -- [Deep_]Finalize (_v1);
8836 -- [Deep_]Finalize (_v2);
8838 procedure Wrap_Transient_Declaration
(N
: Node_Id
) is
8843 Curr_S
:= Current_Scope
;
8844 Encl_S
:= Scope
(Curr_S
);
8846 -- Insert all actions including cleanup generated while analyzing or
8847 -- expanding the transient context back into the tree. Manage the
8848 -- secondary stack when the object declaration appears in a library
8849 -- level package [body].
8851 Insert_Actions_In_Scope_Around
8855 Uses_Sec_Stack
(Curr_S
)
8856 and then Nkind
(N
) = N_Object_Declaration
8857 and then Ekind_In
(Encl_S
, E_Package
, E_Package_Body
)
8858 and then Is_Library_Level_Entity
(Encl_S
));
8861 -- Relocate local entities declared within the transient scope to the
8862 -- enclosing scope. This action sets their Is_Public flag accordingly.
8864 Transfer_Entities
(Curr_S
, Encl_S
);
8866 -- Mark the enclosing dynamic scope to ensure that the secondary stack
8867 -- is properly released upon exiting the said scope.
8869 if Uses_Sec_Stack
(Curr_S
) then
8870 Curr_S
:= Enclosing_Dynamic_Scope
(Curr_S
);
8872 -- Do not mark a function that returns on the secondary stack as the
8873 -- reclamation is done by the caller.
8875 if Ekind
(Curr_S
) = E_Function
8876 and then Requires_Transient_Scope
(Etype
(Curr_S
))
8880 -- Otherwise mark the enclosing dynamic scope
8883 Set_Uses_Sec_Stack
(Curr_S
);
8884 Check_Restriction
(No_Secondary_Stack
, N
);
8887 end Wrap_Transient_Declaration
;
8889 -------------------------------
8890 -- Wrap_Transient_Expression --
8891 -------------------------------
8893 procedure Wrap_Transient_Expression
(N
: Node_Id
) is
8894 Loc
: constant Source_Ptr
:= Sloc
(N
);
8895 Expr
: Node_Id
:= Relocate_Node
(N
);
8896 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
8897 Typ
: constant Entity_Id
:= Etype
(N
);
8904 -- M : constant Mark_Id := SS_Mark;
8905 -- procedure Finalizer is ... (See Build_Finalizer)
8908 -- Temp := <Expr>; -- general case
8909 -- Temp := (if <Expr> then True else False); -- boolean case
8915 -- A special case is made for Boolean expressions so that the back end
8916 -- knows to generate a conditional branch instruction, if running with
8917 -- -fpreserve-control-flow. This ensures that a control-flow change
8918 -- signaling the decision outcome occurs before the cleanup actions.
8920 if Opt
.Suppress_Control_Flow_Optimizations
8921 and then Is_Boolean_Type
(Typ
)
8924 Make_If_Expression
(Loc
,
8925 Expressions
=> New_List
(
8927 New_Occurrence_Of
(Standard_True
, Loc
),
8928 New_Occurrence_Of
(Standard_False
, Loc
)));
8931 Insert_Actions
(N
, New_List
(
8932 Make_Object_Declaration
(Loc
,
8933 Defining_Identifier
=> Temp
,
8934 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
)),
8936 Make_Transient_Block
(Loc
,
8938 Make_Assignment_Statement
(Loc
,
8939 Name
=> New_Occurrence_Of
(Temp
, Loc
),
8940 Expression
=> Expr
),
8941 Par
=> Parent
(N
))));
8943 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
8944 Analyze_And_Resolve
(N
, Typ
);
8945 end Wrap_Transient_Expression
;
8947 ------------------------------
8948 -- Wrap_Transient_Statement --
8949 ------------------------------
8951 procedure Wrap_Transient_Statement
(N
: Node_Id
) is
8952 Loc
: constant Source_Ptr
:= Sloc
(N
);
8953 New_Stmt
: constant Node_Id
:= Relocate_Node
(N
);
8958 -- M : constant Mark_Id := SS_Mark;
8959 -- procedure Finalizer is ... (See Build_Finalizer)
8969 Make_Transient_Block
(Loc
,
8971 Par
=> Parent
(N
)));
8973 -- With the scope stack back to normal, we can call analyze on the
8974 -- resulting block. At this point, the transient scope is being
8975 -- treated like a perfectly normal scope, so there is nothing
8976 -- special about it.
8978 -- Note: Wrap_Transient_Statement is called with the node already
8979 -- analyzed (i.e. Analyzed (N) is True). This is important, since
8980 -- otherwise we would get a recursive processing of the node when
8981 -- we do this Analyze call.
8984 end Wrap_Transient_Statement
;